82 lines
2.2 KiB
Haskell
82 lines
2.2 KiB
Haskell
|
{-# LANGUAGE LambdaCase #-}
|
||
|
|
|
||
|
|
module Parser
|
||
|
|
( module Parser
|
||
|
|
, module Control.Applicative
|
||
|
|
) where
|
||
|
|
|
||
|
|
import Control.Applicative
|
||
|
|
import Data.Char
|
||
|
|
import Debug.Trace
|
||
|
|
|
||
|
|
newtype Parser a = Parser { runParser :: String -> Maybe (a, String) }
|
||
|
|
instance Functor Parser where
|
||
|
|
fmap f (Parser p) = Parser $ \input -> do
|
||
|
|
(value, rest) <- p input
|
||
|
|
return (f value, rest)
|
||
|
|
|
||
|
|
instance Applicative Parser where
|
||
|
|
pure a = Parser $ \input -> Just (a, input)
|
||
|
|
(Parser f) <*> (Parser g) = Parser $ \input -> do
|
||
|
|
(fn, rest) <- f input
|
||
|
|
(value, rest') <- g rest
|
||
|
|
return (fn value, rest')
|
||
|
|
|
||
|
|
instance Monad Parser where
|
||
|
|
return = pure
|
||
|
|
(Parser a) >>= f = Parser $ \input -> do
|
||
|
|
(value, rest) <- a input
|
||
|
|
let Parser b = f value
|
||
|
|
in b rest
|
||
|
|
|
||
|
|
instance Alternative Parser where
|
||
|
|
empty = Parser $ const Nothing
|
||
|
|
(Parser a) <|> (Parser b) = Parser $ \input -> a input <|> b input
|
||
|
|
|
||
|
|
instance MonadFail Parser where
|
||
|
|
fail s = Parser $ const Nothing
|
||
|
|
|
||
|
|
charP :: Char -> Parser Char
|
||
|
|
charP c = Parser $ \case
|
||
|
|
[] -> Nothing
|
||
|
|
(x : xs)
|
||
|
|
| x == c -> Just (c, xs)
|
||
|
|
| otherwise -> Nothing
|
||
|
|
|
||
|
|
stringP :: String -> Parser String
|
||
|
|
stringP = sequence . map charP
|
||
|
|
|
||
|
|
predP :: (Char -> Bool) -> Parser Char
|
||
|
|
predP pred = Parser $ \case
|
||
|
|
[] -> Nothing
|
||
|
|
(x : xs)
|
||
|
|
| pred x -> Just (x, xs)
|
||
|
|
| otherwise -> Nothing
|
||
|
|
|
||
|
|
digitP :: Parser Char
|
||
|
|
digitP = predP isDigit
|
||
|
|
|
||
|
|
numberP :: Parser Int
|
||
|
|
numberP = read <$> some digitP
|
||
|
|
|
||
|
|
letterP :: Parser Char
|
||
|
|
letterP = predP (`notElem` [':','\\', 'λ', '.', ' ', '-', '>', '*', '(', ')', '=', '\n'])
|
||
|
|
|
||
|
|
wordP :: Parser String
|
||
|
|
wordP = some letterP
|
||
|
|
|
||
|
|
spaceP :: Parser ()
|
||
|
|
spaceP = () <$ predP isSpace
|
||
|
|
|
||
|
|
notFollowedBy :: Parser a -> Parser b -> Parser a
|
||
|
|
a `notFollowedBy` b = Parser $ \input -> do
|
||
|
|
(value, rest) <- runParser a input
|
||
|
|
case runParser b rest of
|
||
|
|
Just _ -> Nothing
|
||
|
|
Nothing -> Just (value, rest)
|
||
|
|
|
||
|
|
debug :: Show a => Parser a -> Parser a
|
||
|
|
debug p = Parser $ \input -> case runParser p input of
|
||
|
|
ret@(Just (value, rest)) -> trace ("Input: " ++ input ++ "\nParsed: " ++ show value ++ "\nRest: " ++ rest ++ " (" ++ show (length rest) ++ ")") ret
|
||
|
|
Nothing -> trace ("Input: " ++ input) Nothing
|