mirror of
https://github.com/sdiehl/write-you-a-haskell.git
synced 2024-09-11 19:47:31 +03:00
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
|