commit 265005f8c688929d7ed60bfe2e62f9ed50c09609 Author: welp Date: Fri Nov 29 14:55:41 2019 +0100 files written on presentation diff --git a/Langdsl.hs b/Langdsl.hs new file mode 100644 index 0000000..0c8e03e --- /dev/null +++ b/Langdsl.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE DeriveFunctor #-} + +module Langdsl where + +import Control.Monad +import Parser + +data Toy a next = Output a next | Bell next | Done + deriving Functor + +newtype Fix f = Fix (f (Fix f)) + +type Toy2 a = Fix (Toy a) + +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 a) >>= f = Free $ (fmap (>>= f) a) + +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 + +sub :: Free (Toy Char) () +sub = do + output 'x' + bell + +prog = do + sub + output 'A' + done + +toyParser :: Parser (Toy c) diff --git a/Parser.hs b/Parser.hs new file mode 100644 index 0000000..83422c0 --- /dev/null +++ b/Parser.hs @@ -0,0 +1,37 @@ +module Parser where + +import Data.Char +import Control.Arrow +import Control.Applicative +import Control.Monad + +newtype Parser a = Parser { parse :: String -> [(a,String)] } + +instance Functor Parser where + fmap f (Parser a) = Parser $ \s -> first f <$> a s + +instance Applicative Parser where + pure x = Parser $ \s -> pure (x,s) + (Parser pab) <*> (Parser pa) = Parser $ \s -> do + (ab, s1) <- pab s + (a, s2) <- pa s1 + pure (ab a, s2) + +instance Monad Parser where + return = pure + (Parser a) >>= f = Parser $ \s -> (\(x,s1) -> parse (f x) s1) =<< a s + +instance Alternative Parser where + empty = Parser $ \s -> [] + (Parser p) <|> (Parser q) = Parser $ \s -> p s <|> q s + +token :: Parser Char +token = Parser $ \s -> case s of + (x:xs) -> [(x,xs)] + _ -> [] + +satisfy :: (Char -> Bool) -> Parser Char +satisfy p = do + x <- token + guard (p x) + pure x