Free Monads vs MTL regarding optimizations using AST transformations

FreeMonadOptimization.hs

{-# language DeriveFunctor #-}
{-# language GeneralizedNewtypeDeriving #-}
module FreeOpt where

import Control.Monad.Free
import Control.Monad.Trans
import System.Directory

-- | Define our Free Monad DSL
data FileF r =
  Write String String r
  | Delete String r
  | Copy String String r
  | Move String String r
  | Read (String -> r)
  | Log String r
  deriving (Functor)

-- | Smart constructors
write :: String -> String -> Free FileF ()
write path txt = liftF $ Write path txt ()

delete :: String -> Free FileF ()
delete path = liftF $ Delete path ()

copy :: String -> String -> Free FileF ()
copy from to = liftF $ Copy from to ()

move :: String -> String -> Free FileF ()
move from to = liftF $ Move from to ()

readLine :: Free FileF String
readLine = liftF $ Read id

logMsg :: String -> Free FileF ()
logMsg msg = liftF $ Log msg ()

-- | We can transform our data structure before execution
optimizeMove :: Free FileF a -> Free FileF a
optimizeMove (Pure a) = Pure a
optimizeMove (Free (Copy from to (Free (Delete f r)))) | f == from = Free $ Move from to (optimizeMove r)
optimizeMove (Free f) = Free (fmap optimizeMove f)


-- | Log each action we take
addLogging :: Free FileF a -> Free FileF a
addLogging (Pure a) = Pure a
addLogging (Free f@(Write path txt _)) = Free (Log ("Writing " ++ txt ++ " to " ++ path) (Free $ fmap addLogging f))
addLogging (Free f@(Delete path _)) = Free (Log ("Deleting " ++ path) (Free $ fmap addLogging f))
addLogging (Free f@(Copy from to _)) = Free (Log ("Copying " ++ from ++ " to " ++ to) (Free $ fmap addLogging f))
addLogging (Free f@(Move from to _)) = Free (Log ("Moving " ++ from ++ " to " ++ to) (Free $ fmap addLogging f))
addLogging (Free (Read f)) = Free (Read (\txt -> Free (Log ("Read " ++ txt ++ " from console") (addLogging (f txt)))))
addLogging (Free f) = Free (fmap addLogging f)


-- | We can run our FileF as IO
interpToIO :: Free FileF () -> IO ()
interpToIO (Pure ()) = return ()
interpToIO (Free (Write path txt r)) = writeFile path txt >> interpToIO r
interpToIO (Free (Delete path r)) = removeFile path >> interpToIO r
interpToIO (Free (Copy from to r)) = copyFile from to >> interpToIO r
interpToIO (Free (Move from to r)) = renameFile from to >> interpToIO r
interpToIO (Free (Read f)) = getLine >>= interpToIO . f
interpToIO (Free (Log msg r)) = putStrLn msg >> interpToIO r

-- | Here's a program
operations :: Free FileF ()
operations = do
  write "helloworld.txt" "Hello, World!"
  logMsg "Enter new filename"
  newFilename <- readLine
  if newFilename == "quit"
     then logMsg "See ya later"
     else copy "helloworld.txt" newFilename >> delete "helloworld.txt"


-- Note how we can now perform arbitrary optimizations over our calculations
-- We can compose our optimizations in any order to get the effects we want;
-- Note how (optimizeMove . addLogging) is different from  (addLogging . optimizeMove)
loggedOptimized :: IO ()
loggedOptimized = interpToIO . optimizeMove .  addLogging $ operations
-- > λ> loggedOptimized
-- > Writing Hello, World! to helloworld.txt
-- > Enter new filename
-- > NEW
-- > Read NEW from console
-- > Copying helloworld.txt to NEW
-- > Deleting helloworld.txt

optimizedLogged :: IO ()
optimizedLogged = interpToIO . addLogging . optimizeMove $ operations
-- > λ> optimizedLogged
-- > Writing Hello, World! to helloworld.txt
-- > Enter new filename
-- > NEW
-- > Read NEW from console
-- > Moving helloworld.txt to NEW


-- | Typeclass approach

class (Monad m) => MonadFile m where
  write' :: String -> String -> m ()
  delete' :: String -> m ()
  copy' :: String -> String -> m ()
  move' :: String -> String -> m ()
  log' :: String -> m ()

instance MonadFile IO where
  write' = writeFile
  delete' = removeFile
  copy' = copyFile
  move' = renameFile
  log' = print

newtype LoggedFileM m a = LoggedFileM
  { runWithLogs :: m a
  } deriving (Functor, Applicative, Monad)

instance (MonadFile m, MonadIO m) => MonadFile (LoggedFileM m) where
  write' path txt = LoggedFileM $ liftIO (print ("Writing " ++ txt ++ " to " ++ path)) >> write' path txt
  delete' path = LoggedFileM $ liftIO (print ("Deleting " ++ path)) >> delete' path
  copy' from to = LoggedFileM $ liftIO (print ("Copying " ++ from ++ " to " ++ to)) >> copy' from to
  move' from to = LoggedFileM $ liftIO (print ("Moving " ++ from ++ " to " ++ to)) >> move' from to
  log' msg = LoggedFileM $ liftIO (print msg)

-- class OptimizeMoveM ??
-- Can't introspect arbitrary monads :(

-- Rather than explicitly performing optimizations we rely on the compiler
-- to use the correct monad.
operationsM :: IO ()
operationsM = runWithLogs $ do
  write' "helloworld.txt" "Hello, World!"
  copy' "helloworld.txt" "new.txt"
  delete' "helloworld.txt"