public
Last active

Haskell Hoodlums applicative parser exercise

  • Download Gist
hoodlums-homework-2010-11-11.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 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173
 
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)

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.