public
Last active

Applicative Parsing

  • Download Gist
Parser.hs
Haskell
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106
import Data.Maybe
import Text.Printf
import Control.Applicative
 
data Expr = Term Int | Op Operator Expr Expr | Var String
deriving (Show, Eq)
 
data Operator = Sum | Mult | Sub | Div
deriving (Show, Eq)
data Result a = Failure [String] | Success a
deriving (Show, Eq)
sampleStr = "2 + a * 4 - b"
 
newtype Parser a = Parser {runParser :: String -> Maybe (a, String)}
 
anyCharP :: Parser Char
anyCharP = Parser p
where
p [] = Nothing
p (x : xs) = Just (x, xs)
 
charP :: Char -> Parser Char
charP c = Parser $ \inp -> case inp of
(x:xs) | x == c -> Just (c, xs)
_ -> Nothing
 
combP :: (a -> b -> c) -> Parser a -> Parser b -> Parser c
combP f pa pb = f <$> pa <*> pb
 
instance Functor Parser where
fmap f (Parser pa) = Parser $ \s -> case pa s of
Nothing -> Nothing
Just (a, s') -> Just (f a, s')
 
instance Applicative Parser where
pure x = Parser $ \s -> Just (x, s)
(Parser pf) <*> (Parser pa) = Parser $ \s -> case pf s of
Nothing -> Nothing
Just (f, s') -> case pa s' of
Nothing -> Nothing
Just (a, s'') -> Just (f a, s'')
instance Alternative Parser where
empty = Parser $ \s -> Nothing
(Parser pa) <|> (Parser pb) = Parser $ \s -> case pa s of
Just (a, s') -> Just (a, s')
Nothing -> pb s
 
 
digitP = foldr1 (<|>) (map charP ['0'..'9'])
symbolCharP = foldr1 (<|>) (map charP (['a'..'z'] ++ ['A'..'Z'])) <|> digitP
 
-- lift char into a string
str :: Char -> String
str = \x -> [x]
 
-- zero or many
manyP :: Parser String -> Parser String
manyP p = many1P p <|> pure ""
 
-- one or many
many1P :: Parser String -> Parser String
many1P p = (++) <$> p <*> manyP p
 
-- parse an int
intP :: Parser Int
intP = read <$> many1P (str <$> digitP)
 
-- parse a non-whitespace string
symbolP :: Parser String
symbolP = many1P (str <$> symbolCharP)
 
operator1P :: Parser Operator
operator1P = (const Mult) <$> charP '*' <|>
(const Div) <$> charP '/'
 
operator2P :: Parser Operator
operator2P = (const Sum) <$> charP '+' <|>
(const Sub) <$> charP '-'
termP :: Parser Expr
termP = Term <$> intP
 
varP :: Parser Expr
varP = Var <$> symbolP
 
opP :: Parser Expr -> Parser Operator -> Parser Expr -> Parser Expr
opP pa op pb = (\a o b -> Op o a b) <$> pa <*> op <*> pb
 
bracketedOpP :: Parser Expr
bracketedOpP = charP '(' *> exprP <* charP ')'
 
-- left associative operator chaining, e.g. 1+2-3
chainlP :: Parser Expr -> Parser Operator -> Parser Expr
p `chainlP` op = (opP p op) (chainlP p op) <|> p
 
node :: Parser Expr
node = termP <|> varP <|> bracketedOpP
 
-- precedence is encoded in here
exprP :: Parser Expr
exprP = (node `chainlP` operator1P <|> node) `chainlP` operator2P
 
parseExpr :: String -> Maybe Expr
parseExpr s = maybe Nothing (Just . fst) (runParser exprP (filter (/=' ') s))

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.