ones written before presentation - have some more code
This commit is contained in:
parent
ad40b9b7f8
commit
8eebeafbd7
85
langdsl_done.hs
Normal file
85
langdsl_done.hs
Normal 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
159
parser_done.hs
Normal 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
|
||||||
|
|
Loading…
Reference in New Issue
Block a user