SimpleDSL.hs

{-# LANGUAGE  RankNTypes, FlexibleInstances, FlexibleContexts, UndecidableInstances #-}
module Free where

import Control.Monad.IO.Class
import Data.IORef
import Control.Applicative
import Control.Monad
import Data.Maybe (fromMaybe)
import qualified Control.Monad.Trans.State as ST
import qualified Data.Map as M

-- original post: http://softwareengineering.stackexchange.com/questions/242795/what-is-the-free-monad-interpreter-pattern

-- Free monad instance

data Free f a
  = Pure a
  | Free (f (Free f a))

instance Functor f => Functor (Free f) where
  fmap f (Pure a) = Pure (f a)
  fmap f (Free x) = Free (fmap (f <$>) x)
  
instance Functor f => Applicative (Free f) where
  pure = return
  (<*>) = ap

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

-- simple DSL for a query system

data DSL next = Get String (String -> next)
              | Set String String next
              | End 

instance Functor DSL where
  fmap f (Get name k)          = Get name (f . k)
  fmap f (Set name value next) = Set name value (f next)
  fmap f End                   = End

-- DSL -> State interpreter. note that End is superfluous here.

runDSL :: Free DSL a -> ST.State (M.Map String String) a
runDSL (Free (Get key k)) = 
  do hash <- ST.get
     let res = fromMaybe "nope" $ M.lookup key hash
     runDSL $ k res

runDSL (Free (Set key value next)) =
  do hash <- ST.get
     ST.put $ M.insert key value hash
     runDSL next
    
runDSL (Pure a) = return a
runDSL (Free End) = undefined

-- lifting functions

liftFree :: Functor f => f a -> Free f a
liftFree action = Free (fmap Pure action)

get key       = liftFree (Get key id)
set key value = liftFree (Set key value ())
end           = liftFree End

-- examples

p4 = do foo <- get "foo"
        set "bar" foo

follow :: String -> Free DSL String
follow key = do key' <- get key
                get key'
                
p5 = do foo <- follow "foo"
        set "bar" foo

out4 = ST.execState (runDSL p4) (M.fromList [("foo","baz")])
--fromList [("bar","baz"),("foo","baz")]

out5 = ST.execState (runDSL p5) (M.fromList [("foo","baz"),("baz","bar")])
--fromList [("bar","bar"),("baz","bar"),("foo","baz")]