From 024945dd43e9481482dc6bac853f9a99f6fb02ff Mon Sep 17 00:00:00 2001 From: Julin S Date: Sat, 28 Oct 2023 23:36:11 +0530 Subject: [PATCH] [haskell] make a parser combinator --- haskell/parser-combinator.hs | 298 +++++++++++++++++++++++++++++++++++ 1 file changed, 298 insertions(+) create mode 100644 haskell/parser-combinator.hs diff --git a/haskell/parser-combinator.hs b/haskell/parser-combinator.hs new file mode 100644 index 0000000..8e947c9 --- /dev/null +++ b/haskell/parser-combinator.hs @@ -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