161 lines
4.1 KiB
Haskell
161 lines
4.1 KiB
Haskell
{-# LANGUAGE LambdaCase, DeriveFunctor, FlexibleContexts #-}
|
|
|
|
module ParserD where
|
|
|
|
import Data.Char
|
|
import Control.Arrow
|
|
import Control.Applicative
|
|
import Control.Monad
|
|
import Data.Functor
|
|
|
|
newtype Parser a = Parser { parse :: String -> [(a, String)] }
|
|
|
|
runParser :: Parser a -> String -> Maybe a
|
|
runParser = (match .). parse
|
|
where
|
|
match [(a, [])] = Just a -- Consumed entire string, success
|
|
match _ = Nothing -- had tokens left / other reason
|
|
|
|
-- to get a better understanding of the process, let's write a simple parser
|
|
-- it will consume a single character from the input and do nothing with it
|
|
item :: Parser Char
|
|
item = Parser $ \case
|
|
(x:xs) -> [(x,xs)]
|
|
_ -> []
|
|
|
|
-- what if we only wanted the next character to only be 'c', for example?
|
|
satisfy :: (Char -> Bool) -> Parser Char
|
|
satisfy p = do
|
|
c <- item
|
|
if p c
|
|
then pure c
|
|
else empty
|
|
|
|
char :: Char -> Parser Char
|
|
char c = satisfy (== c)
|
|
|
|
instance Functor Parser where
|
|
-- change the type of parser
|
|
fmap f (Parser sa) = Parser $ fmap (first f) . sa
|
|
|
|
instance Applicative Parser where
|
|
-- inject a value into the parser
|
|
pure a = Parser $ \s -> [(a,s)]
|
|
-- sequence two parsers together
|
|
(Parser fab) <*> (Parser fa) = Parser $ \s ->
|
|
[(ab a,s2) | (ab, s1) <- fab s, (a, s2) <- fa s1]
|
|
|
|
instance Monad Parser where
|
|
return = pure
|
|
-- sequence two parsers, second one depending on the first
|
|
pa >>= apb = Parser $ \s -> (\(a, s1) -> parse (apb a) s1) =<< parse pa s
|
|
|
|
instance Alternative Parser where
|
|
empty = Parser $ \s -> []
|
|
Parser a <|> Parser b = Parser $ \s -> a s <> b s
|
|
|
|
string :: String -> Parser String
|
|
string [] = pure ""
|
|
string (x:xs) = char x *> string xs
|
|
-- string = foldM ( (*>) . char )
|
|
|
|
numbern :: (Read a, Integral a) => Int -> Parser a
|
|
numbern n = read <$> replicateM n (satisfy isDigit)
|
|
|
|
-- HH:MM:SS
|
|
timestamp :: Parser (Int,Int,Int)
|
|
timestamp = do
|
|
h <- numbern 2
|
|
guard (h >= 0 && h <= 24)
|
|
char ':'
|
|
m <- numbern 2
|
|
guard (m >= 0 && m < 60)
|
|
char ':'
|
|
s <- numbern 2
|
|
guard (s >= 0 && s < 60)
|
|
pure (h,m,s)
|
|
|
|
-- toy parsing
|
|
evalParser :: Parser x -> String -> x
|
|
evalParser p s = case parse p s of
|
|
((x,_):_) -> x
|
|
_ -> error "error"
|
|
|
|
data Toy a next =
|
|
Output a next
|
|
| Bell next
|
|
| Done
|
|
deriving Functor
|
|
|
|
data Free f r = Free (f (Free f r)) | Pure r deriving Functor
|
|
instance Functor f => Monad (Free f) where
|
|
return = Pure
|
|
(Pure r) >>= f = f r
|
|
(Free x) >>= f = Free (fmap (>>= f) x)
|
|
|
|
instance Functor f => Applicative (Free f) where
|
|
pure = Pure
|
|
(<*>) = ap
|
|
|
|
liftF x = Free ( fmap Pure x )
|
|
output x = liftF (Output x ())
|
|
bell = liftF (Bell ())
|
|
done = liftF Done
|
|
|
|
whitespace = "\t \n"
|
|
noneOf set = some $ satisfy (not . (`elem` set))
|
|
someOf set = some $ satisfy (`elem` set)
|
|
|
|
reserved = do
|
|
outParse <|> bellParse <|> doneParse
|
|
where
|
|
outParse = do
|
|
string "output"
|
|
satisfy (`elem` whitespace)
|
|
cmd <- timestamp
|
|
pure $ output cmd
|
|
bellParse = string "bell" *> pure bell
|
|
doneParse = string "done" *> pure done
|
|
|
|
toyParser = foldr (>>) (Pure ()) <$> many (reserved <* satisfy (== '\n'))
|
|
|
|
data FreeF f a b = PureF a | FreeF (f b)
|
|
deriving Functor
|
|
|
|
project (Pure r) = PureF r
|
|
project (Free f) = FreeF f
|
|
|
|
cata :: (FreeF (Toy a) r b -> b) -> Free (Toy a) r -> b
|
|
cata f = h where h = f . fmap h . project
|
|
|
|
countBells :: FreeF (Toy a) r Int -> Int
|
|
countBells (PureF x) = 0 -- no done termination, could ve error instead?
|
|
countBells (FreeF r) = case r of
|
|
Done -> 0
|
|
Bell r -> 1 + r
|
|
Output _ r -> r
|
|
|
|
eval :: Show a => FreeF (Toy a) r (IO ()) -> IO ()
|
|
eval (PureF x) = pure () --error "improper termination"
|
|
eval (FreeF r) = case r of
|
|
Done -> pure ()
|
|
Bell r -> putChar '\7' >> r
|
|
Output x r -> print x >> r
|
|
{-
|
|
instance Alternative Parser where
|
|
empty = Parser $ \s -> []
|
|
-- parse with the first, or if it fails, the second
|
|
p1 <|> p2 = Parser $ \s ->
|
|
case parse p1 s of
|
|
[] -> parse p2 s
|
|
res -> res
|
|
-}
|
|
|
|
-- let's give them a spin!
|
|
-- parse (satisfy (== 'c') *> item <* satisfy (== 'e')) "caaae"
|
|
-- parse (satisfy (== 'c') *> many item <* satisfy (== 'e')) "caaae"
|
|
-- the second one doesn't work. why?
|
|
-- answer: our alternative instance
|
|
-- doesn't produce a stream of all possible parses
|
|
|