-- | Notes taken by Deimantė Davidavičiūtė
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE DeriveFunctor #-}
module Lessons.Lesson12 (MyDomain, MyDomainAlgebra(..), calculte, store, restore, myProgram, runInIO, runInState, runState) where

-- | Free monad over a small domain-specific algebra.
--
-- @Free f a@ lets us build programs where effects are described
-- by the functor 'f' and interpreted later.
import Control.Monad.Free (Free (..))
import Control.Monad.Trans.State.Strict (State, get, put, runState)

import Lessons.Lesson11 (Expr(..), eval)

-- | The algebra of our domain:
--
-- 'Calculate Expr (Integer -> next)': evaluate an arithmetic expression, then pass the resulting Integer to the continuation.
--
-- 'Store Integer (() -> next)': store a number and continue.
--
-- 'Restore (Integer -> next)': fetch the last stored number and continue.
data MyDomainAlgebra next = Calculate Expr (Integer -> next)
                          | Store Integer (() -> next)
                          | Restore (Integer -> next)

-- | Our algebra must be a Functor to build a Free monad.
-- Demonstration of functorial mapping (not tied to our type):
--
-- >>> fmap (+5) (Just 5)
-- Just 10

instance Functor MyDomainAlgebra where
  fmap :: (a -> b) -> MyDomainAlgebra a -> MyDomainAlgebra b
  fmap :: forall a b. (a -> b) -> MyDomainAlgebra a -> MyDomainAlgebra b
fmap a -> b
f (Calculate Expr
e Integer -> a
next) = Expr -> (Integer -> b) -> MyDomainAlgebra b
forall next. Expr -> (Integer -> next) -> MyDomainAlgebra next
Calculate Expr
e (\Integer
a -> a -> b
f (Integer -> a
next Integer
a))
  fmap a -> b
f (Store Integer
i () -> a
next) = Integer -> (() -> b) -> MyDomainAlgebra b
forall next. Integer -> (() -> next) -> MyDomainAlgebra next
Store Integer
i (\()
a -> a -> b
f (() -> a
next ()
a))
  fmap a -> b
f (Restore Integer -> a
next) = (Integer -> b) -> MyDomainAlgebra b
forall next. (Integer -> next) -> MyDomainAlgebra next
Restore (\Integer
a -> a -> b
f (Integer -> a
next Integer
a))

-- | The Free monad over 'MyDomainAlgebra'.
type MyDomain a = Free MyDomainAlgebra a

-- | Lift a 'Calculate' instruction into the Free program.
calculte :: Expr -> MyDomain Integer
calculte :: Expr -> MyDomain Integer
calculte Expr
e = MyDomainAlgebra (MyDomain Integer) -> MyDomain Integer
forall (f :: * -> *) a. f (Free f a) -> Free f a
Free (Expr
-> (Integer -> MyDomain Integer)
-> MyDomainAlgebra (MyDomain Integer)
forall next. Expr -> (Integer -> next) -> MyDomainAlgebra next
Calculate Expr
e Integer -> MyDomain Integer
forall (f :: * -> *) a. a -> Free f a
Pure)

-- | Lift a 'Store' instruction.
store :: Integer -> MyDomain ()
store :: Integer -> MyDomain ()
store Integer
i = MyDomainAlgebra (MyDomain ()) -> MyDomain ()
forall (f :: * -> *) a. f (Free f a) -> Free f a
Free (Integer -> (() -> MyDomain ()) -> MyDomainAlgebra (MyDomain ())
forall next. Integer -> (() -> next) -> MyDomainAlgebra next
Store Integer
i () -> MyDomain ()
forall (f :: * -> *) a. a -> Free f a
Pure)

-- | Lift a 'Restore' instruction.
restore :: MyDomain Integer
restore :: MyDomain Integer
restore = MyDomainAlgebra (MyDomain Integer) -> MyDomain Integer
forall (f :: * -> *) a. f (Free f a) -> Free f a
Free ((Integer -> MyDomain Integer) -> MyDomainAlgebra (MyDomain Integer)
forall next. (Integer -> next) -> MyDomainAlgebra next
Restore Integer -> MyDomain Integer
forall (f :: * -> *) a. a -> Free f a
Pure)

-- | A sample program composed of our domain actions.
--
-- Calculates an expression and binds it to 'r'
-- Restores previously stored value 'v0'.
-- Stores 'r' and then stores 42.
-- Restores 'v1' and returns the sum.
myProgram :: MyDomain Integer
myProgram :: MyDomain Integer
myProgram = do
  Integer
r <- Expr -> MyDomain Integer
calculte (Expr -> MyDomain Integer) -> Expr -> MyDomain Integer
forall a b. (a -> b) -> a -> b
$ Expr -> Expr
Neg (Expr -> Expr -> Expr
Add (Integer -> Expr
Lit Integer
5) (Expr -> Expr -> Expr
Add (Integer -> Expr
Lit Integer
4) (Integer -> Expr
Lit Integer
6)))
  Integer
v0 <- MyDomain Integer
restore
  Integer -> MyDomain ()
store Integer
r
  Integer -> MyDomain ()
store Integer
42
  Integer
v1 <- MyDomain Integer
restore
  Integer -> MyDomain Integer
forall a. a -> Free MyDomainAlgebra a
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> MyDomain Integer) -> Integer -> MyDomain Integer
forall a b. (a -> b) -> a -> b
$ Integer
r Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
v0 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
v1

-- | An interpreter that runs the program in IO.
-- Effects are implemented as printing/prompts and pure evaluation.
runInIO :: MyDomain a -> IO a
runInIO :: forall a. MyDomain a -> IO a
runInIO (Pure a
v) = a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
v
runInIO (Free MyDomainAlgebra (Free MyDomainAlgebra a)
step) = do
  Free MyDomainAlgebra a
next <- MyDomainAlgebra (Free MyDomainAlgebra a)
-> IO (Free MyDomainAlgebra a)
forall a. MyDomainAlgebra a -> IO a
runStep MyDomainAlgebra (Free MyDomainAlgebra a)
step
  Free MyDomainAlgebra a -> IO a
forall a. MyDomain a -> IO a
runInIO Free MyDomainAlgebra a
next
  where
    runStep :: MyDomainAlgebra a -> IO a
    runStep :: forall a. MyDomainAlgebra a -> IO a
runStep (Calculate Expr
exp Integer -> a
next) = a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> IO a) -> a -> IO a
forall a b. (a -> b) -> a -> b
$ Integer -> a
next (Expr -> Integer
eval Expr
exp)
    runStep (Store Integer
i () -> a
next) = do
      String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Please enter this number when asked: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
i
      a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> IO a) -> a -> IO a
forall a b. (a -> b) -> a -> b
$ () -> a
next ()
    runStep (Restore Integer -> a
next) = do
      String -> IO ()
putStrLn String
"Please enter the last number"
      String
s <- IO String
getLine
      a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> IO a) -> a -> IO a
forall a b. (a -> b) -> a -> b
$ Integer -> a
next (String -> Integer
forall a. Read a => String -> a
read String
s)

-- | Interpreter that runs the program in pure 'State Integer'.
-- The state holds the latest stored number.
--
-- >>> runState (runInState myProgram) 0
-- (27,42)
runInState :: MyDomain a -> State Integer a
runInState :: forall a. MyDomain a -> State Integer a
runInState (Pure a
v) = a -> StateT Integer Identity a
forall a. a -> StateT Integer Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return a
v
runInState (Free MyDomainAlgebra (Free MyDomainAlgebra a)
step) = do
  Free MyDomainAlgebra a
next <- MyDomainAlgebra (Free MyDomainAlgebra a)
-> State Integer (Free MyDomainAlgebra a)
forall a. MyDomainAlgebra a -> State Integer a
runStep MyDomainAlgebra (Free MyDomainAlgebra a)
step
  Free MyDomainAlgebra a -> StateT Integer Identity a
forall a. MyDomain a -> State Integer a
runInState Free MyDomainAlgebra a
next
  where
    runStep :: MyDomainAlgebra a -> State Integer a
    runStep :: forall a. MyDomainAlgebra a -> State Integer a
runStep (Calculate Expr
exp Integer -> a
next) = a -> StateT Integer Identity a
forall a. a -> StateT Integer Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> StateT Integer Identity a) -> a -> StateT Integer Identity a
forall a b. (a -> b) -> a -> b
$ Integer -> a
next (Expr -> Integer
eval Expr
exp)
    runStep (Store Integer
i () -> a
next) = Integer -> StateT Integer Identity ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put Integer
i StateT Integer Identity ()
-> StateT Integer Identity a -> StateT Integer Identity a
forall a b.
StateT Integer Identity a
-> StateT Integer Identity b -> StateT Integer Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> StateT Integer Identity a
forall a. a -> StateT Integer Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> a
next ())
    runStep (Restore Integer -> a
next) = StateT Integer Identity Integer
forall (m :: * -> *) s. Monad m => StateT s m s
get StateT Integer Identity Integer
-> (Integer -> StateT Integer Identity a)
-> StateT Integer Identity a
forall a b.
StateT Integer Identity a
-> (a -> StateT Integer Identity b) -> StateT Integer Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (a -> StateT Integer Identity a
forall a. a -> StateT Integer Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> StateT Integer Identity a)
-> (Integer -> a) -> Integer -> StateT Integer Identity a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> a
next)


-- | Compose two programs applicatively, sharing the same interpreter/state.
--
-- >>> runState (runInState myTwoPrograms) 0
-- ((27,69),42)
myTwoPrograms :: MyDomain (Integer, Integer)
myTwoPrograms :: MyDomain (Integer, Integer)
myTwoPrograms = (,) (Integer -> Integer -> (Integer, Integer))
-> MyDomain Integer
-> Free MyDomainAlgebra (Integer -> (Integer, Integer))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MyDomain Integer
myProgram Free MyDomainAlgebra (Integer -> (Integer, Integer))
-> MyDomain Integer -> MyDomain (Integer, Integer)
forall a b.
Free MyDomainAlgebra (a -> b)
-> Free MyDomainAlgebra a -> Free MyDomainAlgebra b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> MyDomain Integer
myProgram