badfnparser.hs

-- Naive attempt at functional parsing
-- (so there is lots of plumbing in each combinator)
--
-- NOTE: This is NOT a good example of haskell to learn from.
-- 
import qualified Data.Map as M
import Prelude hiding ( (>>=), (>>), return) 

main = interact $ unlines . map runTest . tail . lines

runTest s = case expr s of
  (Success ex, _rem) -> toRNF ex
  err                -> show err

-- Sticking with a type synonym as far as possible makes things much more readable
-- (at least for this novice).  It's only when we want to make our parser an instance
-- of a typeclass that we'd have to make it instead a newtype.

type Parser a = (String -> (Result a, String))

data Result a = Success a | ParseError String deriving (Show)

char :: Char -> Parser Char
char c list@(x:xs) | x == c = (Success c, xs)
                   | otherwise = (ParseError ("Expected "++show c), list)
char c list            = (ParseError ("Expected "++show c), list)

oneOf :: [Char] -> Parser Char
oneOf cs list@(x:xs) | x `elem` cs = (Success x, xs) 
                     | otherwise   = (ParseError ("Expected one of " ++ cs), list)
oneOf cs [] = (ParseError $ "End of input when expecting one of " ++cs, [])

-- when we want the result of both sequenced parsers, how should we make it available?
-- This sequencing combinator makes a parser which will return a tuple (a, b).
(>>=^) :: Parser a -> Parser b -> Parser (a,b)
(>>=^) p1 p2 = \list -> case p1 list of
  (ParseError e, rem1) -> (ParseError e, rem1)
  (Success v1, rem1) -> case p2 rem1 of
    (Success v2, rem2) -> (Success (v1,v2), rem2)
    (ParseError e, rem2) -> (ParseError e, rem2)

-- As an alternative to the above method, the following sequencing combinator uses
-- the naming of a lambda arg to expose the result of the first parser

(>>=) :: Parser a -> (a -> Parser b) -> Parser b
p1 >>= f = \list -> case p1 list of
  (ParseError e, rem1) -> (ParseError e, rem1)
  (Success v1, rem1) -> case (f v1) rem1 of
    (Success v2, rem2) -> (Success v2, rem2)
    (ParseError e, rem2) -> (ParseError e, rem2)

(>>) :: Parser a -> Parser b -> Parser b
(>>) p1 p2 = \list -> case p1 list of
  (Success _, rem1) -> p2 rem1
  (ParseError e, rem1) -> (ParseError e, rem1)

(<<) :: Parser a -> Parser b -> Parser a
(<<) p1 p2 = \list -> let (v1, rem1) = p1 list
                       in case p2 rem1 of
  (Success _, rem2) -> (v1, rem2)
  (ParseError e, rem2) -> (ParseError e, rem2)

(|^) :: Parser a -> Parser a -> Parser a
(|^) p1 p2 = \list -> case p1 list of
  r1@((Success _), rem) -> r1
  (ParseError e, rem)   -> p2 list

anyChar :: Parser Char
anyChar [] = (ParseError "Expected any char but got empty list", []) 
anyChar (c:cs) = (Success c, cs)

alpha = oneOf ['a'..'z']
digit = oneOf ['0'..'9']

alphas = many1 alpha
digits = many1 digit

number :: Parser Int
number = \list -> case digits list of
  (Success cs, rem) -> (Success (read cs), rem) 
  (ParseError e, rem) -> (ParseError e, rem)

many1 :: Parser a -> Parser [a]
many1 p = \list -> case p list of
  (Success a, rem) -> many0 [a] p rem
  err@(ParseError e, rem) -> (ParseError e, rem)

many0 :: [a] -> Parser a -> Parser [a]
many0 already p = \list -> case p list of
  (Success v, rem) -> (many0 (already++[v]) p rem)
  (ParseError _, _) -> (Success already, list)

data Op = Op Char deriving (Show)
data Expr = Var Char | Expr Expr Op Expr deriving (Show)

-- op = \list -> case oneOf "+-/*^" list of
-- at the very least, this should not accept [a-z()]
op = \list -> case anyChar list of
  (Success a, rem) -> (Success (Op a), rem)
  (ParseError e, rem) -> (ParseError e, rem)

var :: Parser Expr
var = \list -> case oneOf ['a'..'z'] list of
  (Success c, rem) -> (Success (Var c), rem) 
  (ParseError e, rem) -> (ParseError e, rem)

expr = var |^ bracketedExprBetter

-- compare this way with the version underneath it
-- in this version, we use a sequence combinator which returns Parser (a, b) when given Parser a and Parser b.  
-- The resulting nested tuples can be ugly.
bracketedExpr = \list -> 
  case (char '(' >> 
        expr     >>=^ 
        op       >>=^ 
        expr     << 
        char ')') list of
    (ParseError e, rem) -> (ParseError e, rem)
    (Success ((e1, o), e2), rem) -> (Success (Expr e1 o e2), rem)

-- in this version, we use >>= :: Parser a -> (a -> Parser b) -> Parser b
-- Here, the naming of args to our lambdas allows us to name our intermediate parsing results.
-- Note that the lambdas are nested, but conventionally we don't indent each further, for readability.
bracketedExprBetter =  
  char '(' >>
  expr >>= \e1 ->
  op   >>= \o  ->
  expr >>= \e2 ->
  char ')' >> 
  (return $ (Expr e1 o e2))

return :: a -> Parser a
return v = \list -> (Success v, list)

exprToStr :: Expr -> String
exprToStr (Var c) = [c]
exprToStr (Expr e1 (Op o) e2) = "(" ++ exprToStr e1 ++ [o] ++ exprToStr e2 ++ ")"

toRNF :: Expr -> String
toRNF (Expr e1 (Op o) e2) = toRNF e1 ++ toRNF e2 ++ [o]
toRNF (Var v) = [v]

type Binding = M.Map Char Integer

eval :: Expr -> Binding -> Integer
eval (Expr e1 o e2) b = apply o (eval e1 b) (eval e2 b)
eval (Var c) b = case M.lookup c b of
  Just i -> i
  Nothing -> error $ "No binding for variable " ++ [c]

apply :: Op -> Integer -> Integer -> Integer
apply (Op '+') = (+)
apply (Op '-') = (-)
apply (Op '*') = (*)
apply (Op '/') = div
apply (Op '^') = (^)
apply (Op c) = error $ "Unknown operator: " ++ [c]

runAndPrint :: String -> Binding -> Integer
runAndPrint s b = case expr s of
  (Success x, r) -> eval x b
  pe@(ParseError er, r) -> error $ show pe

-- so that you can play quickly in ghci
demo = runAndPrint demoExpr demoBinding
demoExpr = "(((b+c)/a)^c)"
demoBinding = M.fromList [('a', 3), ('b', 10), ('c', 2)]