[haskell] make a parser combinator

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