Last active
June 18, 2016 19:38
-
-
Save TrevorBasinger/6b14695f82c6144d2bace8525f2cc713 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
module Lib where | |
import System.Directory | |
-- Free Monad and helpers | |
data Free f a = Free (f (Free f a)) | Pure a | |
instance Functor f => Functor (Free f) where | |
fmap k (Pure a) = Pure (k a) | |
fmap k (Free f) = Free $ fmap (fmap k) f | |
instance Functor f => Applicative (Free f) where | |
pure = Pure | |
Pure k <*> Pure a = Pure (k a) | |
Pure k <*> Free mb = Free $ fmap k <$> mb | |
Free k <*> a = Free $ fmap (\f -> f <*> a) k | |
instance Functor f => Monad (Free f) where | |
return = pure | |
(Pure a) >>= f = f a | |
(Free a) >>= f = Free $ (>>= f) <$> a | |
liftF :: Functor f => f a -> Free f a | |
liftF f = Free $ Pure <$> f | |
iter :: Functor f => (f a -> a) -> Free f a -> a | |
iter _ (Pure a) = a | |
iter k (Free f) = k (iter k <$> f) | |
iterM :: (Functor f, Monad m) => (f (m a) -> m a) -> Free f a -> m a | |
iterM _ (Pure a) = return a | |
iterM k (Free f) = k (iterM k <$> f) | |
-- Implementation of a free monad dsl | |
data DSLF a = | |
Echo String a | |
| ReadLine (String -> a) | |
| Ls FilePath ([String] -> a) | |
type DSL = Free DSLF | |
instance Functor DSLF where | |
fmap f (Echo str a) = Echo str (f a) | |
fmap f (ReadLine k) = ReadLine (f . k) | |
fmap f (Ls path k) = Ls path (f . k) | |
echo :: String -> DSL () | |
echo str = liftF $ Echo str () | |
ls :: FilePath -> DSL [String] | |
ls path = liftF (Ls path id) | |
readLine :: DSL String | |
readLine = liftF $ ReadLine id | |
testDSL :: DSL () | |
testDSL = do | |
echo "getting directory contest of $CWD:" | |
echo "" | |
xs <- fmap formatNice . zip [1..] <$> ls "." | |
mapM echo xs | |
pure () | |
where | |
formatNice :: (Int, String) -> String | |
formatNice (i, str) = show i ++ ") " ++ str | |
-- Interpreter | |
runDSL :: DSL a -> IO a | |
runDSL = iterM $ \op -> | |
case op of | |
Echo str next -> putStrLn str >> next | |
Ls path k -> listDirectory path >>= k | |
ReadLine k -> getLine >>= k | |
void :: Monad m => m a -> m () | |
void m = m >> return () | |
someFunc :: IO () | |
someFunc = void $ runDSL testDSL |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment