summaryrefslogtreecommitdiff
path: root/parser.hs
diff options
context:
space:
mode:
Diffstat (limited to 'parser.hs')
-rw-r--r--parser.hs236
1 files changed, 236 insertions, 0 deletions
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