From dd3db844dd49451f28d044cd1d2fd71430d73686 Mon Sep 17 00:00:00 2001 From: tomsmeding Date: Thu, 16 Jun 2016 23:24:47 +0200 Subject: Initial --- parser.hs | 236 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 236 insertions(+) create mode 100644 parser.hs (limited to 'parser.hs') diff --git a/parser.hs b/parser.hs new file mode 100644 index 0000000..6d8ed6d --- /dev/null +++ b/parser.hs @@ -0,0 +1,236 @@ +module Parser (parseExpression) where + +import Control.Applicative +import Control.Monad +import Data.Char +import Data.Maybe + +import AST +import Utility + + +parseExpression :: String -> Either String AST +parseExpression s = case parse pexpression s of + ((node,rest):_) -> case rest of + "" -> Right node + s -> Left $ "Cannot parse from '" ++ take 10 rest ++ "'" + _ -> Left "No valid parse" + + +newtype Parser a = Parser (String -> [(a,String)]) + +parse :: Parser a -> String -> [(a,String)] +parse (Parser p) = p + +instance Functor Parser where + fmap f p = Parser (\cs -> map (\(a,s) -> (f a,s)) $ parse p cs) + +instance Applicative Parser where + pure x = Parser (\cs -> [(x,cs)]) + (<*>) f p = Parser (\cs -> concat $ + map (\(a,s) -> parse (fmap a p) s) $ parse f cs) + +instance Monad Parser where + p >>= f = Parser (\cs -> concat $ + map (\(a,s) -> parse (f a) s) $ parse p cs) + +instance Alternative Parser where + empty = Parser (\_ -> []) + (<|>) p q = Parser (\cs -> parse p cs ++ parse q cs) + +instance MonadPlus Parser + + +--The deterministic choice operator: choose the first possibile parse (if +--available at all) from the results given by the two parsers. +--mplus is the non-deterministic choice operator; it would give all results. +mplus1 :: Parser a -> Parser a -> Parser a +mplus1 p q = Parser $ \cs -> case parse (mplus p q) cs of + [] -> [] + (x:_) -> [x] + +--(++) = mplus +(+++) = mplus1 + + +pitem :: Parser Char +pitem = Parser $ \s -> case s of + "" -> [] + (c:cs) -> [(c,cs)] + +psat :: (Char -> Bool) -> Parser Char +psat f = do + c <- pitem + if f c then return c else mzero + +--checks that the next char satisfies the predicate; does NOT consume characters +passert :: (Char -> Bool) -> Parser () +passert p = Parser $ \s -> case s of + "" -> [] + (c:_) -> if p c then [((),s)] else [] + +pchar :: Char -> Parser Char +pchar c = psat (==c) + +pstring :: String -> Parser String +pstring "" = return "" +pstring (c:cs) = do + pchar c + pstring cs + return (c:cs) + +pmany :: Parser a -> Parser [a] +pmany p = pmany1 p +++ return [] + +pmany1 :: Parser a -> Parser [a] +pmany1 p = do + a <- p + as <- pmany p + return (a:as) + +pinteger :: Parser Int +pinteger = do + s <- pmany $ psat isDigit + return $ read s + +pdouble :: Parser Double +pdouble = Parser reads + +pquotstring :: Parser String +pquotstring = Parser reads + +poptws :: Parser String +poptws = Parser $ pure . span isSpace + +pws :: Parser String +pws = Parser $ \s -> case span isSpace s of + ("",_) -> [] + tup@(_,_) -> [tup] + +pword :: Parser String +pword = do + c <- psat $ options [isAlpha,(=='_')] + cs <- pmany $ psat $ options [isAlpha,isDigit,(=='_')] + return (c:cs) + + +pnumber :: Parser AST +pnumber = liftM Number pdouble + +pvariable :: Parser AST +pvariable = liftM Variable $ pstring "PI" +++ (liftM pure (psat isAlpha)) + +pinfixoperator :: (Char,Char) -- +/- symbols + -> Parser AST -- term parser + -> ([AST] -> AST) -- Sum constructor + -> (AST -> AST) -- Negative constructor + -> Bool -- whether the plus sign is optional + -> Bool -- whether a negative sign cannot follow after a term + -> Parser AST -- Resulting parser +pinfixoperator (plus,minus) pterm sumconstr negconstr plusopt noneg = do + term <- pterm + pmoreterms term +++ return (sumconstr [term]) + where + pmoreterms term = if plusopt + then pmoretermsplus term +++ pmoretermsminus term +++ pmoretermsnothing term + else pmoretermsplus term +++ pmoretermsminus term + + pmoretermsplus term = do + poptws + pchar plus + poptws + nextterm <- pterm + let thissum = sumconstr [term,nextterm] + pmoreterms thissum +++ return thissum + pmoretermsminus term = do + poptws + pchar minus + poptws + nextterm <- pterm + let thissum = sumconstr [term,negconstr nextterm] + pmoreterms thissum +++ return thissum + pmoretermsnothing term = do + poptws + if noneg then passert (/='-') else return () + nextterm <- pterm + let thissum = sumconstr [term,nextterm] + pmoreterms thissum +++ return thissum + +psum :: Parser AST +psum = pinfixoperator ('+','-') pproduct Sum Negative False False + +pproduct :: Parser AST +pproduct = pinfixoperator ('*','/') pfactor Product Reciprocal True True + +pfactor :: Parser AST +pfactor = pnegative +++ pfactornoneg +++ pcapture +++ pcaptureterm + +pnegative :: Parser AST +pnegative = do {pchar '-'; poptws; f <- pfactor; return $ Negative f} +++ pfactornoneg + +pfactornoneg :: Parser AST +pfactornoneg = do + fact <- pnumber +++ pparenthetical +++ pfunctioncall +++ pvariable + ppower fact +++ pfactorial fact +++ return fact + where + ppower fact = do + poptws + pchar '^' + poptws + fact2 <- pfactornoneg + return $ Apply "pow" [fact,fact2] + pfactorial fact = do + poptws + pchar '!' + return $ Apply "fact" [fact] + + +pparenthetical :: Parser AST +pparenthetical = do + pchar '(' + poptws + sum <- psum + poptws + pchar ')' + return sum + +pfunctioncall :: Parser AST +pfunctioncall = do + name <- pword + poptws + pchar '(' + poptws + args <- parglist + poptws + pchar ')' + return $ Apply name args + where + parglist = do + arg <- parg + poptws + pmoreargs arg +++ return [arg] + pmoreargs arg = do + pchar ',' + poptws + args <- parglist + return (arg:args) + parg = pexpression + +pcapture :: Parser AST +pcapture = do + pchar '[' + name <- pmany1 $ psat (/=']') + pchar ']' + return $ Capture name + +pcaptureterm :: Parser AST +pcaptureterm = do + pchar '[' + pchar '[' + name <- pmany1 $ psat (/=']') + pchar ']' + pchar ']' + return $ CaptureTerm name + +pexpression :: Parser AST +pexpression = psum -- cgit v1.2.3-54-g00ecf