mirror of
https://github.com/sdiehl/write-you-a-haskell.git
synced 2024-09-11 19:47:31 +03:00
ca8b771489
The text doesn't mention ambigous parses, and the code didn't handle them. The easiest way to fix the code without necessarily having to write about this case is to hande it as parse error and merge it with the no parse case by replacing the [] pattern with _.
178 lines
3.9 KiB
Haskell
178 lines
3.9 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
|
|
|
|
module NanoParsec where
|
|
|
|
import Data.Char
|
|
import Control.Monad
|
|
import Control.Applicative
|
|
|
|
newtype Parser a = Parser { parse :: String -> [(a,String)] }
|
|
|
|
runParser :: Parser a -> String -> a
|
|
runParser m s =
|
|
case parse m s of
|
|
[(res, [])] -> res
|
|
[(_, rs)] -> error "Parser did not consume entire stream."
|
|
_ -> error "Parser error."
|
|
|
|
item :: Parser Char
|
|
item = Parser $ \s ->
|
|
case s of
|
|
[] -> []
|
|
(c:cs) -> [(c,cs)]
|
|
|
|
bind :: Parser a -> (a -> Parser b) -> Parser b
|
|
bind p f = Parser $ \s -> concatMap (\(a, s') -> parse (f a) s') $ parse p s
|
|
|
|
unit :: a -> Parser a
|
|
unit a = Parser (\s -> [(a,s)])
|
|
|
|
instance Functor Parser where
|
|
fmap f (Parser cs) = Parser (\s -> [(f a, b) | (a, b) <- cs s])
|
|
|
|
instance Applicative Parser where
|
|
pure = return
|
|
(Parser cs1) <*> (Parser cs2) = Parser (\s -> [(f a, s2) | (f, s1) <- cs1 s, (a, s2) <- cs2 s1])
|
|
|
|
instance Monad Parser where
|
|
return = unit
|
|
(>>=) = bind
|
|
|
|
instance MonadPlus Parser where
|
|
mzero = failure
|
|
mplus = combine
|
|
|
|
instance Alternative Parser where
|
|
empty = mzero
|
|
(<|>) = option
|
|
|
|
combine :: Parser a -> Parser a -> Parser a
|
|
combine p q = Parser (\s -> parse p s ++ parse q s)
|
|
|
|
failure :: Parser a
|
|
failure = Parser (\cs -> [])
|
|
|
|
option :: Parser a -> Parser a -> Parser a
|
|
option p q = Parser $ \s ->
|
|
case parse (mplus p q) s of
|
|
[] -> []
|
|
(x:xs) -> [x]
|
|
|
|
satisfy :: (Char -> Bool) -> Parser Char
|
|
satisfy p = item `bind` \c ->
|
|
if p c
|
|
then unit c
|
|
else (Parser (\cs -> []))
|
|
|
|
-------------------------------------------------------------------------------
|
|
-- Combinators
|
|
-------------------------------------------------------------------------------
|
|
|
|
oneOf :: [Char] -> Parser Char
|
|
oneOf s = satisfy (flip elem s)
|
|
|
|
chainl :: Parser a -> Parser (a -> a -> a) -> a -> Parser a
|
|
chainl p op a = (p `chainl1` op) <|> return a
|
|
|
|
chainl1 :: Parser a -> Parser (a -> a -> a) -> Parser a
|
|
p `chainl1` op = do {a <- p; rest a}
|
|
where rest a = (do f <- op
|
|
b <- p
|
|
rest (f a b))
|
|
<|> return a
|
|
|
|
char :: Char -> Parser Char
|
|
char c = satisfy (c ==)
|
|
|
|
natural :: Parser Integer
|
|
natural = read <$> some (satisfy isDigit)
|
|
|
|
string :: String -> Parser String
|
|
string [] = return []
|
|
string (c:cs) = do { char c; string cs; return (c:cs)}
|
|
|
|
token :: Parser a -> Parser a
|
|
token p = do { a <- p; spaces ; return a}
|
|
|
|
reserved :: String -> Parser String
|
|
reserved s = token (string s)
|
|
|
|
spaces :: Parser String
|
|
spaces = many $ oneOf " \n\r"
|
|
|
|
digit :: Parser Char
|
|
digit = satisfy isDigit
|
|
|
|
number :: Parser Int
|
|
number = do
|
|
s <- string "-" <|> return []
|
|
cs <- some digit
|
|
return $ read (s ++ cs)
|
|
|
|
parens :: Parser a -> Parser a
|
|
parens m = do
|
|
reserved "("
|
|
n <- m
|
|
reserved ")"
|
|
return n
|
|
|
|
-------------------------------------------------------------------------------
|
|
-- Calulator parser
|
|
-------------------------------------------------------------------------------
|
|
|
|
-- number = [ "-" ] digit { digit }.
|
|
-- digit = "0" | "1" | ... | "8" | "9".
|
|
-- expr = term { addop term }.
|
|
-- term = factor { mulop factor }.
|
|
-- factor = "(" expr ")" | number.
|
|
-- addop = "+" | "-".
|
|
-- mulop = "*".
|
|
|
|
data Expr
|
|
= Add Expr Expr
|
|
| Mul Expr Expr
|
|
| Sub Expr Expr
|
|
| Lit Int
|
|
deriving Show
|
|
|
|
eval :: Expr -> Int
|
|
eval ex = case ex of
|
|
Add a b -> eval a + eval b
|
|
Mul a b -> eval a * eval b
|
|
Sub a b -> eval a - eval b
|
|
Lit n -> n
|
|
|
|
int :: Parser Expr
|
|
int = do
|
|
n <- number
|
|
return (Lit n)
|
|
|
|
expr :: Parser Expr
|
|
expr = term `chainl1` addop
|
|
|
|
term :: Parser Expr
|
|
term = factor `chainl1` mulop
|
|
|
|
factor :: Parser Expr
|
|
factor =
|
|
int
|
|
<|> parens expr
|
|
|
|
infixOp :: String -> (a -> a -> a) -> Parser (a -> a -> a)
|
|
infixOp x f = reserved x >> return f
|
|
|
|
addop :: Parser (Expr -> Expr -> Expr)
|
|
addop = (infixOp "+" Add) <|> (infixOp "-" Sub)
|
|
|
|
mulop :: Parser (Expr -> Expr -> Expr)
|
|
mulop = infixOp "*" Mul
|
|
|
|
run :: String -> Expr
|
|
run = runParser expr
|
|
|
|
main :: IO ()
|
|
main = forever $ do
|
|
putStr "> "
|
|
a <- getLine
|
|
print $ eval $ run a
|