From af425841a63ee73603cc09510d95a36e646ddafd Mon Sep 17 00:00:00 2001 From: Tom Smeding Date: Thu, 19 Apr 2018 11:45:46 +0200 Subject: Build with stack --- parser.hs | 240 -------------------------------------------------------------- 1 file changed, 240 deletions(-) delete mode 100644 parser.hs (limited to 'parser.hs') diff --git a/parser.hs b/parser.hs deleted file mode 100644 index 636c04f..0000000 --- a/parser.hs +++ /dev/null @@ -1,240 +0,0 @@ -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 = do - poptws - res <- pinfixoperator ('+','-') pproduct Sum Negative False False - poptws - return res - -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