Lib.hs

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