module Language.GroteTrap.Parser (
parseSentence, readParseTree, readExpression
) where
import Language.GroteTrap.Lexer
import Language.GroteTrap.Language
import Language.GroteTrap.ParseTree
import Language.GroteTrap.Range
import Language.GroteTrap.Util
import Data.List (groupBy, sortBy)
import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Pos (newPos)
import qualified Text.ParserCombinators.Parsec.Expr as P
withEOF :: Show tok => GenParser tok st t -> GenParser tok st t
withEOF p = do v <- p; eof; return v
parseSentence :: Monad m => Language a -> String -> m ParseTree
parseSentence lang input = tokenize lang input >>=
run "tokens" (withEOF $ pTree lang) . filter (not . isWhite . snd)
readParseTree :: Language a -> String -> ParseTree
readParseTree lang = fromError . parseSentence lang
readExpression :: Language a -> String -> a
readExpression lang = evaluate lang . readParseTree lang
pTree :: Language a -> GenParser TokenPos () ParseTree
pTree lang = P.buildExpressionParser (buildOperatorTable $ operators lang) (pUnit lang)
pUnit :: Language a -> GenParser TokenPos () ParseTree
pUnit lang = choice [pCall lang, pId, pInt, pParens lang]
pId :: GenParser TokenPos () ParseTree
pId = tok f where
f (pos, TId name) = Just $ PId pos name
f _ = Nothing
pInt :: GenParser TokenPos () ParseTree
pInt = tok f where
f (pos, TInt v) = Just $ PInt pos v
f _ = Nothing
pCall :: Language a -> GenParser TokenPos () ParseTree
pCall lang = do
(begin,name) <- tok f
static TOpen
args <- sepBy (pTree lang) (static TComma)
(end,_) <- static TClose
return $ PCall (begin,end) name args
where f (pos, TFunction name) = Just (pos, name)
f _ = Nothing
pParens :: Language a -> GenParser TokenPos () ParseTree
pParens lang = do
(begin,_) <- static TOpen
v <- pTree lang
(end,_) <- static TClose
return $ PParens (begin, end + 1) v
buildOperatorTable :: [Operator a] -> P.OperatorTable TokenPos () ParseTree
buildOperatorTable = map (map buildOperator) . orderedOperators
buildOperator :: Operator a -> P.Operator TokenPos () ParseTree
buildOperator (Unary _ fix _ tok) = xFix fix (pUna tok)
buildOperator (Binary _ fix _ tok) = P.Infix (pBin tok) (infixX fix)
buildOperator (Assoc _ _ tok) = P.Infix (pList tok) P.AssocLeft
xFix :: Fixity1 -> GenParser t st (a -> a) -> P.Operator t st a
xFix Prefix = P.Prefix
xFix Postfix = P.Postfix
infixX :: Fixity2 -> P.Assoc
infixX InfixL = P.AssocLeft
infixX InfixR = P.AssocRight
orderedOperators :: [Operator a] -> [[Operator a]]
orderedOperators = groupBy equalPriority . sortBy orderPriority where
equalPriority a1 a2 = opPrio a1 == opPrio a2
orderPriority a1 a2 = opPrio a1 `compare` opPrio a2
pList :: String -> GenParser TokenPos () (ParseTree -> ParseTree -> ParseTree)
pList token = do
(pos, _) <- static $ TOperator token
return $ assimilate token (pos, pos + length token)
assimilate :: String -> Range -> ParseTree -> ParseTree -> ParseTree
assimilate token range pt1@(PList rs tok ps) pt2
| token == tok = PList (rs ++ [range]) token (ps ++ [pt2])
| otherwise = PList [range] token [pt1,pt2]
assimilate token range pt1 pt2
= PList [range] token [pt1,pt2]
pBin :: String -> GenParser TokenPos () (ParseTree -> ParseTree -> ParseTree)
pBin token = do
(pos, _) <- static $ TOperator token
return $ PBinary (pos, pos + length token) token
pUna :: String -> GenParser TokenPos () (ParseTree -> ParseTree)
pUna token = do
(pos, _) <- static $ TOperator token
return $ PUnary (pos, pos + length token) token
tok :: (TokenPos -> Maybe a) -> GenParser TokenPos st a
tok = token show (newPos "tokens" 1 . fst)
static :: Token -> GenParser TokenPos () TokenPos
static t = tok (\tp@(_,x) -> if x == t then Just tp else Nothing)