高阶的Parser:可变运算优先级

如果需要更flex的运算优先级可咋整？

怕是要把这个标注运算优先级的Optable当做参数，一级一级的传下去了。。。

 

module ParserImpl where

import AST
import Text.ParserCombinators.ReadP as P
import Data.Char

import Control.Applicative

-- do not change the type!

parseStringTerm :: OpTable -> String -> Either ErrMsg Term
parseStringTerm table str = let flist = tabterms table []
                                fstTerm = head flist 
                                term = pTerm fstTerm
                                result = parsefTerms term str
                            in result

parseStringCmds :: OpTable -> String -> Either ErrMsg [Cmd]
parseStringCmds table str = let flist = tabterms table []
                                term = head flist
                                cmds = pCmds (pTerm term)
                                result = parsefCmds cmds str
                            in result


-- start parser --


opCollect :: [FName] ->  ReadP (Term -> Term -> Term)
opCollect [fname] = do
        _ <- symbol fname
        return (\expr1 expr2 -> TFun fname [expr1,expr2])
opCollect (fname:flist) = let 
        a = opCollect [fname]
        b = opCollect flist
        in (a +++ b)

tabterms :: OpTable -> [ReadP Term] -> [ReadP Term]
tabterms (OpTable [(fix,flist)]) topTerm =
    let fOterm = opCollect flist
    in case fix of
        FRight -> case topTerm of
                   [] -> let a = (chainr1 basicTerm fOterm)
                             b = pbasicTerm a
                             c = (chainr1 b fOterm)
                             d = pbasicTerm c
                         in [d]
                   [tt] -> let a = (chainr1 tt fOterm)
                               b = pbasicTerm a
                               c = (chainr1 b fOterm)
                               d = pbasicTerm c
                           in [d]
        _ -> case topTerm of
                   [] -> let a = (chainl1 basicTerm fOterm)
                             b = pbasicTerm a
                             c = (chainl1 b fOterm)
                             d = pbasicTerm c
                         in [d]
                   [tt] -> let a = (chainl1 tt fOterm)
                               b = pbasicTerm a
                               c = (chainl1 b fOterm)
                               d = pbasicTerm c
                           in [d]
                           
tabterms (OpTable ((fix,fnlist) : flist)) topTerm =
    case topTerm of
        [] -> let fOterm = opCollect fnlist
                  alist = (tabterms (OpTable flist) [])
                  atop = head alist
                  blist = (tabterms (OpTable flist) [pbasicTerm atop])
                  btop = pTerm (head blist)
                  ct = pTerm (chainr1 btop fOterm)
              in case fix of
                  FRight -> [pTerm (chainr1 ct fOterm)] ++ blist
                  _ -> [pTerm (chainl1 ct fOterm)] ++ blist
        [tt] -> let fOterm = opCollect fnlist
                    alist = (tabterms (OpTable flist) [tt])
                    atop = pTerm (head alist)
                in case fix of
                    FRight -> [pTerm (chainr1 atop fOterm)] ++ alist
                    _ -> [pTerm (chainl1 atop fOterm)] ++ alist


parsefTerms :: ReadP Term -> String -> Either ErrMsg Term
parsefTerms fterm str =
    case null (readP_to_S fterm str) of
        True -> Left (show (readP_to_S fterm str))
        False -> case [x | x <- readP_to_S fterm str,snd x == ""] of
                   [] -> Left (show (readP_to_S fterm str))
                   legalstr -> Right (fst (head legalstr))

parsefCmds :: ReadP [Cmd] -> String -> Either ErrMsg [Cmd]
parsefCmds cmds str =
    case null (readP_to_S cmds str) of
        True -> Left (show (readP_to_S cmds str))
        False -> case [x | x <- readP_to_S cmds str,snd x == ""] of
                   [] -> Left (show (readP_to_S cmds str))
                   legalstr -> Right (fst (head legalstr))

symbol :: String -> ReadP String
symbol s = token $ string s

token :: ReadP a -> ReadP a
token p = do
             skipSpaces
             a <- p
             skipSpaces
             return a

pVName :: ReadP Term
pVName = do
    fist <- satisfy isLetter
    send <- munch (\x -> isLetter x || isDigit x)
    return (TVar (fist : send))

pFName :: ReadP FName
pFName = do
    fist <- satisfy isLetter
    send <- munch (\x -> isLetter x || isDigit x)
    return (fist : send)

pPName :: ReadP PName
pPName = do
    fist <- satisfy isLetter
    send <- munch (\x -> isLetter x || isDigit x)
    return (fist : send)

pNumber :: ReadP Term
pNumber = do
    sym <- option ' ' (char '~')
    number <- munch1 isDigit
    case sym of
        '~' -> return (TNum (read ('-' : number)))
        _ -> return(TNum (read number))

pFun :: ReadP Term -> ReadP Term
pFun term = (do
    fname <- token pFName
    _ <- symbol "("
    terms <- token (pTerms term)
    _ <- symbol ")"
    return (TFun fname terms))
    <|> (do
    fname <- token pFName
    _ <- symbol "("
    _ <- symbol ")"
    return (TFun fname []))

pbasicTerm :: ReadP Term -> ReadP Term
pbasicTerm term = (do
                _ <- symbol "("
                a <- token term
                _ <- symbol ")"
                return a) <|> (pFun term) <|> term <|> basicTerm

pTerm :: ReadP Term -> ReadP Term
pTerm term = (do
                _ <- symbol "("
                a <- token term
                _ <- symbol ")"
                return a) <|> (pFun term) <|> term

basicTerm :: ReadP Term
basicTerm = token pNumber
        <|> token pVName

pTerms :: ReadP Term -> ReadP [Term]
pTerms term = (pCommaTerm term)
          <|> (do
           a <- token term
           return [a])
pCommaTerm :: ReadP Term -> ReadP [Term]
pCommaTerm term = do
    a <- token term
    com <- token (pComTerHelper term)
    return (a : com)
pComTerHelper :: ReadP Term -> ReadP [Term]
pComTerHelper term = (do
    _ <- symbol ","
    pCommaTerm term) <|>
                     (do
    _ <- symbol ","
    a <- token term
    return [a])

pCond :: ReadP Term -> ReadP Cond
pCond term = (do -- one termz empty
    name <- token pPName
    _ <- symbol "("
    _ <- symbol ")"
    return (Cond name [] []))
    <|> (do      -- one termz not empty
    name <- token pPName
    _ <- symbol "("
    terms <- token (pTerms term)
    _ <- symbol ")"
    return (Cond name terms []))
    <|> (do      -- two termz(empty) and terms
    name <- token pPName
    _ <- symbol "("
    _ <- symbol ";"
    terms <- token (pTerms term)
    _ <- symbol ")"    
    return (Cond name [] terms))
    <|> (do      -- two termz(not empty) and terms
    name <- token pPName
    _ <- symbol "("
    term1 <- token (pTerms term)
    _ <- symbol ";"
    term2 <- token (pTerms term)
    _ <- symbol ")"
    return (Cond name term1 term2))

pConds :: ReadP Term -> ReadP [Cond]
pConds term = (pCommaConds term)
          <|> (do
          a <- token (pCond term)
          return [a])
pCommaConds :: ReadP Term -> ReadP [Cond]
pCommaConds term = do
    a <- token (pCond term)
    com <- token (pComConHelper term)
    return (a : com)
pComConHelper :: ReadP Term -> ReadP [Cond]
pComConHelper term = (do
    _ <- symbol ","
    pCommaConds term) <|>
                     (do
    _ <- symbol ","
    a <- token (pCond term)
    return [a])

pRule :: ReadP Term -> ReadP Rule
pRule term = (do
    term1 <- token term
    _ <- symbol "="
    term2 <- token term
    _ <- symbol "."
    return (Rule term1 term2 []))
    <|> (do
    term1 <- token term
    _ <- symbol "="
    term2 <- token term
    _ <- symbol "|"
    cons <- token (pConds term)
    _ <- symbol "."
    return (Rule term1 term2 cons))

pCmd :: ReadP Term -> ReadP Cmd
pCmd term = (do
    rule <- token (pRule term)
    return (CRule rule))
    <|> (do
    t <- token term
    _ <- symbol "?"
    return (CQuery t False))
    <|> (do
    t <- token term
    _ <- symbol "??"
    return (CQuery t True))

pCmds :: ReadP Term -> ReadP [Cmd]
pCmds term = (do
    a <- token (pCmd term)
    as <- token (pCmds term)
    return (a : as))
    <|> (do
    a <- token (pCmd term)
    return [a])