Monad Parsing in Haskell Type-Along

MonadicParsingInHaskell.hs

{-# LANGUAGE LambdaCase #-}

module Lib
  ( someFunc
  ) where

import           Control.Applicative (Alternative (empty, (<|>)))
import           Control.Monad       (MonadPlus (..))
import           Data.Bifunctor      (first)
import           Data.Char           (isDigit, isSpace, ord)

newtype Parser a = Parser { parse :: String -> [(a, String)] }

item :: Parser Char
item = Parser $ \case
  []       -> []
  (c : cs) -> [(c, cs)]

someFunc :: IO ()
someFunc =  print $ apply expr"1-2*3+4"

instance Functor Parser where
  fmap f p = Parser $ fmap (first f) . parse p

instance Applicative Parser where
  pure a = Parser $ \cs -> [(a, cs)]

  pf <*> p = Parser $ \cs -> do
    (f, cs') <- parse pf cs
    first f <$> parse p cs'

instance Monad Parser where
  p >>= f = Parser $ \cs -> concat [ parse (f a) cs' | (a, cs') <- parse p cs ]

instance Alternative Parser where
  empty = Parser $ const []
  p1 <|> p2 = Parser $ \cs -> parse p1 cs <> parse p2 cs

instance MonadPlus Parser

(+++) :: Parser a -> Parser a -> Parser a
p1 +++ p2 = Parser $ \cs -> case parse p1 cs <|> parse p2 cs of
  []      -> []
  (v : _) -> [v]

sat :: (Char -> Bool) -> Parser Char
sat p = do
  v <- item
  if p v then pure v else mzero

char :: Char -> Parser Char
char = sat . (==)

string :: String -> Parser String
string ""       = pure ""
string (c : cs) = do
  char c
  string cs
  pure $ c : cs

many :: Parser a -> Parser [a]
many p = many1 p +++ pure []

many1 :: Parser a -> Parser [a]
many1 p = do
  a  <- p
  as <- many p
  pure $ a : as

sepby :: Parser a -> Parser b -> Parser [a]
sepby p sep = (p `sepby1` sep) <|> pure []

sepby1 :: Parser a -> Parser b -> Parser [a]
sepby1 p sep = do
  a  <- p
  as <- many $ do
    sep
    p
  pure $ a : as

chainl :: Parser a -> Parser (a -> a -> a) -> a -> Parser a
chainl p op a = (p `chainl1` op) +++ return a

chainl1 :: Parser a -> Parser (a -> a -> a) -> Parser a
chainl1 p op = do
  a <- p
  rest a
 where
  rest a = (+++ return a) $ do
    f <- op
    b <- p
    rest $ f a b

space :: Parser String
space = many $ sat isSpace

token :: Parser a -> Parser a
token p = do
  a <- p
  space
  pure a

symb :: String -> Parser String
symb cs = token $ string cs

apply :: Parser a -> String -> [(a, String)]
apply p = parse $ do
  space
  p

expr :: Parser Int
addop :: Parser (Int -> Int -> Int)
mulop :: Parser (Int -> Int -> Int)

expr = term `chainl1` addop
term = factor `chainl1` mulop
factor = (digit +++) $ do
  symb "("
  n <- expr
  symb ")"
  pure n

digit = do
  x <- token $ sat isDigit
  pure $ ord x - ord '0'

addop = do {symb "+"; return (+)} +++ do {symb "-"; return (-)}
mulop = do {symb "*"; return (*)} +++ do {symb "/"; return (div)}