Create a gist now

Instantly share code, notes, and snippets.

Haskell Hoodlums applicative parser exercise
module Expressions where
import Data.Maybe
import Data.Char
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)
instance Functor Result where
fmap f (Success a) = Success (f a)
fmap _ (Failure es) = Failure es
instance Applicative Result where
pure v = Success v
(Success f) <*> (Success x) = Success (f x)
(Failure xs) <*> (Failure ys) = Failure $ xs ++ ys
(Failure xs) <*> _ = Failure xs
_ <*> (Failure ys) = Failure ys
foldExpr :: (Int -> a) -> (Operator -> a -> a -> a) -> (String -> a) -> Expr -> a
foldExpr ft _ _ (Term i) = ft i
foldExpr ft fo fv (Op o u v) = fo o (foldExpr ft fo fv u) (foldExpr ft fo fv v)
foldExpr ft fo fv (Var id) = fv id
eval :: [(String, Int)] -> Expr -> Result Int
eval env = foldExpr Success applyOp getV
where
getV x = maybe (Failure [x]) Success $ lookup x env
applyOp :: Operator -> Result Int -> Result Int -> Result Int
applyOp o x y = getOp o <$> x <*> y
getOp :: Operator -> Int -> Int -> Int
getOp o = case o of
Sum -> (+)
Mult -> (*)
Sub -> (-)
Div -> div
printExpr :: Expr -> String
printExpr = foldExpr show (flip (printf "(%s %s %s)") . printOp) id
printOp o = case o of
Sum -> "+"
Mult -> "*"
Sub -> "-"
Div -> "/"
countTerms :: Expr -> Int
countTerms = foldExpr (const 1) (const (+)) (const 1)
sample = Op Mult (Op Sum (Var "x") (Var "y")) (Term 4)
---------
-- Parser
---------
newtype Parser a = Parser {runParser :: String -> Maybe (a, String)}
instance Functor Parser where
{- fmap f (Parser pa) = Parser $ \s -> case pa s of -}
{- Nothing -> Nothing -}
{- Just (a, s') -> Just (f a, s') -}
fmap f (Parser pa) = Parser $ \s -> (\(a, s') -> (f a, s')) <$> pa 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'') -}
Parser pf <*> parserA = Parser $ \s -> pf s >>= \(f, s') -> runParser (f <$> parserA) s'
instance Alternative Parser where
-- empty :: f a
empty = Parser $ \s -> Nothing
-- (<|>) :: f a -> f a -> f a
Parser pa <|> Parser pb = Parser $ \s -> maybe (pb s) Just (pa s)
anyCharP :: Parser Char
anyCharP = Parser p
where
p [] = Nothing
p (x : xs) = Just (x, xs)
combP :: (a -> b -> c) -> Parser a -> Parser b -> Parser c
combP f pa pb = f <$> pa <*> pb
predP :: (Char -> Bool) -> Parser Char
predP pred = Parser $ \s -> case runParser anyCharP s of
Just (c, s') -> if pred c then Just (c, s') else Nothing
Nothing -> Nothing
charP :: Char -> Parser Char
charP c = predP (c==)
blankP :: Parser String
blankP = many (predP isSpace)
tokenP :: Parser a -> Parser a
tokenP p = blankP *> p <* blankP
termP :: Parser Expr
termP = Term . read <$> some (predP isDigit)
varP :: Parser Expr
varP = Var <$> some (predP isAlpha)
sumOpP :: Parser Operator
sumOpP = const Sum <$> charP '+'
multOpP :: Parser Operator
multOpP = const Mult <$> charP '*'
subOpP :: Parser Operator
subOpP = const Sub <$> charP '-'
divOpP :: Parser Operator
divOpP = const Div <$> charP '/'
anyOpP :: Parser Operator
anyOpP = sumOpP <|> subOpP <|> multOpP <|> divOpP
combOpP l o r = flip Op <$> l <*> o <*> r
opP :: Parser Expr
opP = combOpP exprP (tokenP anyOpP) exprP
exprP :: Parser Expr
exprP = tokenP termP <|> tokenP varP <|> tokenP (charP '(' *> opP <* charP ')')
-------------
-- Precedence
-------------
leafP = tokenP termP <|> tokenP varP
-- Same precedence
exprP' :: Parser Expr
exprP' = combOpP leafP (tokenP anyOpP) exprP' <|> leafP
-- Different precedence
highP = combOpP leafP (tokenP (multOpP <|> divOpP)) highP <|> leafP
lowP = combOpP highP (tokenP (sumOpP <|> subOpP)) lowP <|> highP
-- Different and brackets
nodeP' = leafP <|> tokenP (charP '(' *> lowP' <* charP ')')
highP' = combOpP nodeP' (tokenP (multOpP <|> divOpP)) highP' <|> nodeP'
lowP' = combOpP highP' (tokenP (sumOpP <|> subOpP)) lowP' <|> highP'
tests = [ "(123+(1*(2/x)))"
, "(123 + (1 * (2/x)))"
, "( 123 + (1 * (2/ x) )) "
, "123+1*2/x"
, "123 + 1 * 2 / x"]
answer = Op Sum (Term 123) (Op Mult (Term 1) (Op Div (Term 2) (Var "x")))
test p ss = map assess $ zip ss (map (runParser p) ss)
where assess (s, Just (e, s')) = (s, Just e, e == answer)
assess (s, Nothing) = (s, Nothing, False)
main = putStrLn $ unlines $ map fmt (test lowP' tests)
where fmt (s, r, a) = printf "%30s -> %80s -> %5s" s (show r) (show a)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment