[haskell] make a parser combinator
This commit is contained in:
parent
8c8228f563
commit
024945dd43
|
@ -0,0 +1,298 @@
|
||||||
|
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 Alternative Result where
|
||||||
|
-- (<|>) r1 r2 = case r1 of
|
||||||
|
-- Ok _ _ -> r1
|
||||||
|
-- Err -> r2
|
||||||
|
|
||||||
|
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
|
||||||
|
|
||||||
|
-- between :: Char -> Char -> Parser a
|
||||||
|
-- between open close = Parser $ \inp ->
|
||||||
|
-- case inp of
|
||||||
|
-- [] -> empty
|
||||||
|
-- c:cs ->
|
||||||
|
-- if c==open
|
||||||
|
|
||||||
|
|
||||||
|
--------------------------------------------------
|
||||||
|
|
||||||
|
{- Trying out -}
|
||||||
|
|
||||||
|
ca = char 'a'
|
||||||
|
eg = (many ca) <|> empty
|
||||||
|
-- λ> parse eg "a"
|
||||||
|
-- Ok "a" ""
|
||||||
|
-- λ> parse eg "aaaaaa"
|
||||||
|
-- Ok "aaaaaa" ""
|
||||||
|
-- λ> parse eg "baa"
|
||||||
|
-- Ok "" "baa"
|
||||||
|
|
||||||
|
|
||||||
|
-- λ> parse nat "123"
|
||||||
|
-- Ok 123 ""
|
||||||
|
-- λ> parse nat "123ab"
|
||||||
|
-- Ok 123 "ab"
|
||||||
|
|
||||||
|
-- λ> parse spaces " a"
|
||||||
|
-- Ok " " "a"
|
||||||
|
|
||||||
|
-- λ> parse (choice $ map char "abcd") "c"
|
||||||
|
-- Ok 'c' ""
|
||||||
|
-- λ> parse (many (choice $ map char "abcd")) "cabcdcdabdeh"
|
||||||
|
-- Ok "cabcdcdabd" "eh"
|
||||||
|
|
||||||
|
--------------------------------------------------
|
||||||
|
|
||||||
|
{-
|
||||||
|
- Expression language example
|
||||||
|
|
||||||
|
E = n
|
||||||
|
| E + E
|
||||||
|
|
||||||
|
After removing left recursion:
|
||||||
|
|
||||||
|
E = E + E | n
|
||||||
|
|
||||||
|
E = n E'
|
||||||
|
E' = + E E' | ε
|
||||||
|
-}
|
||||||
|
|
||||||
|
|
||||||
|
data Expr
|
||||||
|
= Val Int
|
||||||
|
| Add Expr Expr
|
||||||
|
deriving Show
|
||||||
|
|
||||||
|
eval :: Expr -> Int
|
||||||
|
eval e = case e of
|
||||||
|
Val n -> n
|
||||||
|
Add e1 e2 -> (eval e1) + (eval e2)
|
||||||
|
|
||||||
|
-- parser for `Expr'
|
||||||
|
|
||||||
|
op = do
|
||||||
|
spaces
|
||||||
|
char '+'
|
||||||
|
return Add
|
||||||
|
|
||||||
|
cnst = do
|
||||||
|
spaces
|
||||||
|
n <- nat
|
||||||
|
return $ (Val . read) n
|
||||||
|
|
||||||
|
-- cnst = Val . read <$> nat
|
||||||
|
|
||||||
|
expr = chainl cnst op
|
||||||
|
|
||||||
|
-- E :: Parser Expr
|
||||||
|
-- E = do
|
||||||
|
-- n <- nat
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
-- pE =
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
-- λ> parse valP "234"
|
||||||
|
-- Ok (Val 234) ""
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
--------------------------------------------------
|
||||||
|
|
||||||
|
|
||||||
|
{- Useful functions -}
|
||||||
|
|
||||||
|
-- λ> :t traverse
|
||||||
|
-- traverse
|
||||||
|
-- :: (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b)
|
||||||
|
-- λ> :t mapM
|
||||||
|
-- mapM :: (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
-- -- newtype Parser a = Parser {
|
||||||
|
-- -- -- | Run parser on some input
|
||||||
|
-- -- parse :: String -> (Maybe [a], String)
|
||||||
|
-- -- }
|
||||||
|
|
||||||
|
-- -- satisfy :: (Char -> Bool) -> Parser Char
|
||||||
|
-- -- satisfy f = Parser $ \inp ->
|
||||||
|
-- -- case inp of
|
||||||
|
-- -- [] -> (Nothing, [])
|
||||||
|
-- -- ch:str ->
|
||||||
|
-- -- if f ch then (Just [ch], str)
|
||||||
|
-- -- else (Nothing, inp)
|
||||||
|
|
||||||
|
-- -- char :: Char -> Parser Char
|
||||||
|
-- -- char a = satisfy (==a)
|
||||||
|
|
||||||
|
-- -- instance Functor Parser where
|
||||||
|
-- -- fmap fab (Parser fa) = Parser $ \inp -> do
|
||||||
|
-- -- -- res <- fa inp
|
||||||
|
-- -- -- return (fab <$> res)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
-- -- import Control.Applicative -- for `Alternative' typeclass
|
||||||
|
-- -- import qualified Data.Char
|
||||||
|
|
||||||
|
-- newtype Parser a = Parser {
|
||||||
|
-- -- | Run parser on some input
|
||||||
|
-- parse :: String -> Maybe [(a, String)]
|
||||||
|
-- }
|
||||||
|
|
||||||
|
-- satisfy :: (Char -> Bool) -> Parser Char
|
||||||
|
-- satisfy f = Parser $ \inp ->
|
||||||
|
-- case inp of
|
||||||
|
-- [] -> Nothing
|
||||||
|
-- ch:str ->
|
||||||
|
-- if f ch then Just [(ch, str)]
|
||||||
|
-- else Nothing
|
||||||
|
|
||||||
|
-- char :: Char -> Parser Char
|
||||||
|
-- char a = satisfy (==a)
|
||||||
|
|
||||||
|
-- instance Functor Parser where
|
||||||
|
-- fmap fab (Parser fa) = Parser $ \inp ->
|
||||||
|
-- case (fa inp) of
|
||||||
|
-- Just ls -> Just $ map (\x -> (fab (fst x), snd x)) ls
|
||||||
|
-- Nothing -> Nothing
|
||||||
|
|
||||||
|
-- instance Applicative Parser where
|
||||||
|
-- <*> f (
|
||||||
|
|
||||||
|
-- instance Monad Parser where
|
Loading…
Reference in New Issue