it has recursion schemes tho

ParserD.hs

@@ -0,0 +1,160 @@
+{-# 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
+