ones written before presentation - have some more code

This commit is contained in:
welp 2019-11-29 14:58:29 +01:00
parent ad40b9b7f8
commit 8eebeafbd7
2 changed files with 244 additions and 0 deletions

85
langdsl_done.hs Normal file
View File

@ -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

159
parser_done.hs Normal file
View File

@ -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