Parser.hs

{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE StandaloneDeriving #-}
-- |

module Main where

import Control.Applicative (Alternative(..), (<|>))
import Data.List (foldl', intercalate)
import Data.Monoid ((<>))
import qualified Data.Char as Char


type Stream a = [a]

emptyStream = []

data ParserSingle a t = ParserSingle (Stream a -> Maybe (Stream a, t))

unParserSingle (ParserSingle p) = p

runParserSingle (ParserSingle p) s = p s

instance Functor (ParserSingle s) where
    fmap f (ParserSingle p) = ParserSingle $ \s ->
        {-# SCC "ParserSingle_fmap" #-}
        case p s of
        Nothing -> Nothing
        Just (s', t) -> Just (s', f t)


instance Applicative (ParserSingle s) where
    pure x = ParserSingle $ \s -> Just (s, x)
    (ParserSingle pf) <*> ppx =
        {-# SCC "ParserSingle_<*>" #-}
        ParserSingle $ \s -> case pf s of
        Nothing -> Nothing
        Just (s', f) -> case unParserSingle ppx s' of
            Nothing -> Nothing
            Just (s'', x) -> Just (s'', f x)

instance Alternative (ParserSingle s) where
    empty = ParserSingle $ const Nothing
    (ParserSingle px) <|> y =
        {-# SCC "ParserSingle_<|>" #-}
        ParserSingle $ \s ->
        case px s of
        Nothing -> unParserSingle y s
        Just (s', t) -> Just (s', t)


data Parser a t where
    PZero :: Parser a t
    POne :: (ParserSingle a t) -> Parser a t
    PAlt :: [Parser a t] -> Parser a t
    PApp :: (Parser a (u -> t)) -> (Parser a u) -> Parser a t
    PSome :: Parser a t -> Parser a [t]

instance Show (Parser a t) where
    show (PZero) = "PZero"
    show (POne _) = "POne"
    show (PAlt ps) = "(" ++ intercalate " | " (map show ps) ++ ")"
    show (PApp pf px) = show pf ++ " <*> " ++ show px
    show (PSome p) = "some " ++ show p

instance Functor (Parser s) where
    fmap f p = pure f <*> p

instance Applicative (Parser s) where
    pure = POne . pure
    p <*> x = PApp p x

instance Alternative (Parser s) where
    empty                         = PZero
    p       <|> PZero   = p
    PZero   <|> p       = p
    PAlt xs <|> PAlt ys = PAlt $ xs ++ ys
    PAlt xs <|> p       = PAlt $ xs ++ [p]
    p       <|> PAlt xs = PAlt $ p : xs
    p1      <|> p2      = PAlt [p1, p2]

    some p = PSome p
    many p = some p <|> pure []

fmapParserResult :: (a -> b) -> (s, a) -> (s, b)
fmapParserResult = fmap

runParser :: Parser a t -> Stream a -> Maybe (Stream a, [t])
runParser PZero _ = Nothing
runParser (POne p) s =
    case runParserSingle p s of
    Nothing -> Nothing
    Just (s', t) -> Just (s', [t])
runParser (PApp pf px) s =
    case runParser pf s of
    Nothing -> Nothing
    Just (s', fs) -> case runParser px s' of
        Nothing -> Nothing
        Just (s'', xs) -> Just (s'', concatMap (\x -> map ($ x) fs) xs)
runParser (PSome p) s =
    case runParser p s of
    Nothing -> Nothing
    Just (s', x) -> fmap (fmapParserResult reverse) $ go s' [x]
    where
        go s1 x1 =
            case runParser p s1 of
            Nothing -> Just (s1, x1)
            Just (s2, x2) -> go s2 (x2 : x1)

runParser (PAlt ps) s = firstJust $ map (flip runParser s) ps
    where firstJust []              = Nothing
          firstJust (Just x  : mxs) = Just x
          firstJust (Nothing : mxs) = firstJust mxs

----------------------------------------------------------------------
-- Examples

isSingle f = ParserSingle $
           \s -> case s of
           (x:s') | f x -> Just (s', x)
           _ -> Nothing

is = POne . isSingle

are = many . is

letter = is Char.isLetter

str = some letter

space = is Char.isSpace

digitToNum c = Char.ord c - Char.ord '0'
digit = fmap digitToNum $ is Char.isDigit

num = fmap fromDecimal $ some digit
    where fromDecimal = foldl' (\accum x -> 10 * accum + x) 0

data Lit = LitStr String | LitNum Int
         deriving (Show)

litStr = LitStr <$> str
litNum = LitNum <$> num
lit = (many space *> litStr) <|> (many space *> litNum)


-- Lambda calculus:
--
-- x = [a-z]+
-- e = x | \x -> e | e e
--

data Expr = Var String | Lam String Expr | App Expr Expr
          deriving (Show)

data Token = Space | Arrow | Slash
           deriving (Show)

spaces = fmap (const Space) $ many space
inSpace p = spaces *> p <* spaces

slash = fmap (const Slash) $ is (== '\\')
arrow = fmap (const Arrow) $ is (== '-') *> is (== '>')

sstr = inSpace str

openPar = is (=='(')
closePar = is (==')')

withParens x = openPar *> x <* closePar
optParens x = x <|> withParens x

expr = optParens $ var <|> lam <|> app

var = Var <$> str
app = App <$> (expr <* space) <*> expr
lam = Lam <$> (slash *> sstr <* arrow) <*> expr

main = do
    print $ runParser app "\\x-> x x"