[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