如果需要更flex的运算优先级可咋整？
怕是要把这个标注运算优先级的Optable当做参数，一级一级的传下去了。。。
module ParserImpl whereimport ASTimport Text.ParserCombinators.ReadP as Pimport Data.Charimport Control.Applicative-- do not change the type!parseStringTerm :: OpTable -> String -> Either ErrMsg TermparseStringTerm table str = let flist = tabterms table [] fstTerm = head flist term = pTerm fstTerm result = parsefTerms term str in resultparseStringCmds :: 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)] ++ alistparsefTerms :: ReadP Term -> String -> Either ErrMsg TermparsefTerms 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 Stringsymbol s = token $ string stoken :: ReadP a -> ReadP atoken p = do skipSpaces a <- p skipSpaces return apVName :: ReadP TermpVName = do fist <- satisfy isLetter send <- munch (\x -> isLetter x || isDigit x) return (TVar (fist : send))pFName :: ReadP FNamepFName = do fist <- satisfy isLetter send <- munch (\x -> isLetter x || isDigit x) return (fist : send)pPName :: ReadP PNamepPName = do fist <- satisfy isLetter send <- munch (\x -> isLetter x || isDigit x) return (fist : send)pNumber :: ReadP TermpNumber = do sym <- option ' ' (char '~') number <- munch1 isDigit case sym of '~' -> return (TNum (read ('-' : number))) _ -> return(TNum (read number))pFun :: ReadP Term -> ReadP TermpFun 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 TermpbasicTerm term = (do _ <- symbol "(" a <- token term _ <- symbol ")" return a) <|> (pFun term) <|> term <|> basicTermpTerm :: ReadP Term -> ReadP TermpTerm term = (do _ <- symbol "(" a <- token term _ <- symbol ")" return a) <|> (pFun term) <|> termbasicTerm :: ReadP TermbasicTerm = token pNumber <|> token pVNamepTerms :: 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 CondpCond 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 RulepRule 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 CmdpCmd 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])