如果需要更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])