free-monads.hs

{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}

module Main where

data Free f a = Pure a | Branch (f (Free f a))
deriving instance (Show a, Show (f (Free f a))) => Show (Free f a)


instance Functor f => Functor (Free f) where
    --fmap :: (a -> b) -> Free f a -> Free f b
    fmap fn (Pure a) = Pure (fn a)
    -- fmap :: (a -> b) Branch (f (Free f a))
    fmap fn (Branch b) = Branch (((fmap . fmap) fn) b)

join :: Functor f => Free f (Free f a) -> Free f a
join (Pure a) = a
join (Branch x) = Branch (fmap join x)

instance Functor f => Monad (Free f) where
     return a = Pure a
     (>>=) x f  = join (fmap f x)


instance Functor f => Applicative (Free f) where
    pure = return
    --(<*>) :: f (a -> b) ->f a -> fb
    (<*>) freefn freea = do fn <- freefn; a <- freea; return $ fn a


type Key = String
type Value = String

data DSL next = Get Key (Value -> next) |
           Set Key Value next |
           Done
 

instance Functor DSL where
    --fmap :: (a -> b) -> DSL a -> DSL b
    fmap f (Get key user) = Get key (f . user)
    fmap f (Set key value next) = Set key value (f next)
    fmap f Done = Done



--Branch (DSL (Pure Value))
getLift :: Key -> Free DSL Value
getLift key = Branch (Get key (\value -> Pure value)) -- is this right?

setLift :: Key -> Value -> Free DSL ()
setLift key value = Branch ((Set key value (Pure ())))

doneLift :: Free DSL a
doneLift = Branch Done

run :: Free DSL a -> IO ()
run (Pure a) = return ()
run (Branch (Set key value f)) = (putStrLn  ("setting: " ++ key ++ " |to: " ++ value)) >> run f
run (Branch (Get key user)) = (putStrLn ("getting: " ++ key)) >> run (user ("value-for-key-" ++ key))
run (Branch Done) = print "all done!"


simpleTest = do
    bolluVal <- getLift "bollu-key"
    setLift bolluVal "newVal"
    doneLift

main :: IO ()
main = run simpleTest