module Parser where import Control.Applicative hiding ((<|>)) import Data.Char import Text.ParserCombinators.Parsec.Token import Text.ParserCombinators.Parsec data Language e = Lang { lLit :: Integer -> e , lPlus :: e -> e -> e , lLet :: String -> e -> e -> e , lVar :: String -> e , lNewref :: e -> e , lDeref :: e -> e , lAssign :: e -> e -> e , lCatch :: e -> e -> e } tok :: TokenParser st tok = makeTokenParser LanguageDef { commentStart = "{-" , commentEnd = "-}" , commentLine = "--" , nestedComments = True , identStart = satisfy (\c -> isAlpha c || c == '_') , identLetter = satisfy (\c -> isAlphaNum c || c == '_') , opStart = satisfy (`elem` "+:=!;") , opLetter = satisfy (`elem` "=") , reservedNames = ["let", "new", "try", "catch"] , reservedOpNames = ["+", ":=", "=", "!", ";"] , caseSensitive = True } parseExpr :: Language e -> String -> Either ParseError e parseExpr lang = parse exprP "" where exprP = do e <- expr0 eof return e expr0 = choice [ do reserved tok "let" x <- identifier tok reservedOp tok "=" e1 <- expr2 reservedOp tok ";" e2 <- expr0 return $ lLet lang x e1 e2 , do reserved tok "try" e1 <- expr0 reserved tok "catch" e2 <- expr0 return $ lCatch lang e1 e2 , expr1 ] expr1 = chainr1 expr2 (reservedOp tok ";" >> return (lLet lang "_")) expr2 = chainr1 expr3 (reservedOp tok ":=" >> return (lAssign lang)) expr3 = chainl1 expr4 plusP expr4 = choice [ atomP , do reservedOp tok "!" e <- expr4 return (lDeref lang e) , do reserved tok "new" e <- expr4 return (lNewref lang e) ] atomP = choice [ lLit lang <$> integer tok , lVar lang <$> identifier tok , parens tok expr0 ] plusP = reservedOp tok "+" >> return (lPlus lang)