ones written before presentation - have some more code

langdsl_done.hs

@@ -0,0 +1,85 @@
+{-# LANGUAGE DeriveFunctor, FlexibleContexts, GADTs #-}
+
+-- based on 'why free monads matter'
+
+--import Data.Functor.Foldable
+--import Control.Monad.Free
+--import qualified Control.Monad.Trans.Free as CMTF 
+import Control.Monad
+
+
+data Toy a next =
+  Output a next
+  | Bell next
+  | Done
+  deriving Functor
+
+-- absolutely unmanageable
+toy1 :: Toy Char (Toy a (Toy Char (Toy a next)))
+toy1 = Output 'A' (Bell (Output 'B' Done))
+
+newtype Fix f = Fix { unfix :: f (Fix f) }
+
+toy2 :: Fix (Toy Char)
+toy2 = Fix (Output 'A' (Fix (Bell (Fix (Output 'B' (Fix Done))))))
+
+-- What about subroutines?
+data Free f r = Free (f (Free f r)) | Pure r
+  deriving Functor
+
+instance Functor f => Applicative (Free f) where
+  pure = Pure
+  (<*>) = ap
+  
+instance Functor f => Monad (Free f) where
+  return = Pure
+  (Pure r) >>= f = f r
+  (Free x) >>= f = Free (fmap (>>= f) x)
+
+liftF cmd = Free (fmap Pure cmd)
+
+output x = liftF (Output x ())
+bell = liftF (Bell ())
+done = liftF Done
+
+toy3 :: Free (Toy Char) r
+toy3 = do
+  output 'A'
+  bell
+  output 'B'
+  done
+
+subroutine :: Free (Toy Char) ()
+subroutine = output 'A' >> bell
+
+program :: Free (Toy Char) r
+program = do
+  subroutine
+  output 'B'
+  bell
+  done
+
+-- what can we do with our "quoted" DSL?
+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
+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
+

parser_done.hs

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