124 lines
2.5 KiB
Haskell
124 lines
2.5 KiB
Haskell
module Parser where
|
|
|
|
import Control.Applicative -- for `Alternative' typeclass
|
|
import qualified Data.Char
|
|
|
|
data Result a
|
|
= Ok a String
|
|
| Err
|
|
deriving Show
|
|
|
|
newtype Parser a = Parser {
|
|
-- | Run parser on some input
|
|
parse :: String -> Result a
|
|
}
|
|
|
|
instance Functor Result where
|
|
-- f :: a -> b
|
|
-- ra :: Result a
|
|
fmap f ra = case ra of
|
|
Ok a rem -> Ok (f a) rem
|
|
Err -> Err
|
|
|
|
instance Functor Parser where
|
|
-- f :: a -> b
|
|
-- pa :: Parser a
|
|
fmap f pa = Parser $ \inp ->
|
|
-- resa :: Result a
|
|
let resa = parse pa inp in
|
|
f <$> resa
|
|
|
|
instance Applicative Parser where
|
|
-- pab :: Parser (a -> b)
|
|
-- pa :: Parser a
|
|
(<*>) pab pa = Parser $ \inp ->
|
|
-- resf :: Result (a -> b)
|
|
let resf = parse pab inp in
|
|
case resf of
|
|
-- f :: a -> b
|
|
Ok f remf ->
|
|
let resa = parse pa remf in
|
|
case resa of
|
|
-- resa :: Result a
|
|
Ok a rem -> Ok (f a) rem
|
|
Err -> Err
|
|
Err -> Err
|
|
|
|
-- pure :: a -> Parser a
|
|
pure a = Parser $ \inp -> Ok a inp
|
|
|
|
instance Monad Parser where
|
|
-- pa :: Parser a
|
|
-- f :: a -> Parser b
|
|
(>>=) pa f = Parser $ \inp ->
|
|
let resa = parse pa inp in
|
|
case resa of
|
|
-- resa :: Result a
|
|
Ok a rem ->
|
|
let res = f a in
|
|
-- res :: Parser b
|
|
parse res rem
|
|
Err -> Err
|
|
|
|
instance Alternative Parser where
|
|
-- empty is identity of (<|>)
|
|
empty = Parser $ \inp -> Err
|
|
|
|
(<|>) p1 p2 = Parser $ \inp ->
|
|
-- p1 p2 :: Parser a
|
|
let res = parse p1 inp in
|
|
case res of
|
|
Ok _ _ -> res
|
|
Err -> parse p2 inp
|
|
|
|
--------------------------------------------------
|
|
|
|
{- Helper functions -}
|
|
|
|
digitsToNat :: [Int] -> Int
|
|
digitsToNat = foldl (\res x -> res*10 + x) 0
|
|
|
|
satisfy :: (Char -> Bool) -> Parser Char
|
|
satisfy f = Parser $ \inp ->
|
|
case inp of
|
|
a:rem -> if f a then Ok a rem
|
|
else Err
|
|
_ -> Err
|
|
|
|
--------------------------------------------------
|
|
|
|
{- Primitive combinators -}
|
|
|
|
char :: Char -> Parser Char
|
|
char a = satisfy (==a)
|
|
|
|
digit :: Parser Char
|
|
digit = satisfy Data.Char.isDigit
|
|
|
|
nat :: Parser String
|
|
nat = some digit
|
|
|
|
spaces :: Parser String
|
|
spaces = many $ satisfy (==' ')
|
|
|
|
string :: String -> Parser String
|
|
string str = traverse char str
|
|
|
|
choice :: [Parser a] -> Parser a
|
|
choice ps = case ps of
|
|
[] -> empty
|
|
p:ps -> p <|> (choice ps)
|
|
|
|
-- For left-associative operations
|
|
chainl :: Parser a -> Parser (a -> a -> a) -> Parser a
|
|
chainl p op = do {
|
|
x <- p
|
|
; rest x
|
|
}
|
|
where
|
|
rest x = do {
|
|
f <- op
|
|
; y <- p
|
|
; rest (f x y)
|
|
} <|> return x
|