Purescript port of the original Haskell "Modern FP with MTL"

Modern FP with mtl.purs

module Modern_FP_With_MTL where

import Effect.Console as Console
import Effect (Effect)
import Effect.Class (class MonadEffect, liftEffect)
import Control.Monad.Trans.Class (class MonadTrans, lift)
import Prelude

{-
Since Purescript does not have Haskell's "GeneralizedNewtypeDeriving" language
extension, we have to write a lot of boilerplate to show that
the `NewtypeForCapabilityT` newtype is at least a Monad plus other capabilities.

Thus, the boilerplate type class instances for Monad are at bottom of file
as well as their `runCapabilityT` functions

Also, `Array Path` was used instead of Haskell's `List Path`/`[Path]`
to reduce the number of required imports
-}

--------------------------------------------------------------------------------
type Path = String
type Bytes = String

-- The API for cloud files.
class Monad m <= MonadCloud m where
  saveFile :: Path -> Bytes -> m Unit
  listFiles :: Path -> m (Array Path)

--------------------------------------------------------------------------------
-- The API for logging.
class Monad m <= MonadLog m where
  log :: Level -> String -> m Unit

data Level
  = Debug
  | Info

--------------------------------------------------------------------------------
-- The API for REST clients.
class Monad m <= MonadRest m where
  get :: Path -> m Bytes
  put :: Path -> Bytes -> m Bytes

--------------------------------------------------------------------------------
-- An instrumenting implementation that adds logging to every call.
newtype CloudFilesLogT m a = CloudFilesLogT (m a)

derive newtype instance cfl6 :: (MonadLog m) => MonadLog (CloudFilesLogT m)

instance cfl7 :: (MonadLog m,MonadCloud m) => MonadCloud (CloudFilesLogT m) where
  saveFile p bytes = do
    log Debug ("Saving file: " <> p)
    lift (saveFile p bytes)
  listFiles path = do
    log Debug ("Listing " <> path)
    lift (listFiles path)

instance cfl8 :: MonadTrans CloudFilesLogT where
  lift = CloudFilesLogT

--------------------------------------------------------------------------------
-- An implementation of logging to standard out.
newtype StdoutLoggingT m a = StdoutLoggingT (m a)

derive newtype instance slt6 :: (MonadEffect m) => MonadEffect (StdoutLoggingT m)

instance slt7 :: MonadEffect m => MonadLog (StdoutLoggingT m) where
  log Info msg = liftEffect (Console.log ("[Info] " <> msg))
  log Debug msg = liftEffect (Console.log ("[Debug] " <> msg))

--------------------------------------------------------------------------------
-- An implementation of MonadCloud that uses a REST client.
newtype CloudFilesRestT m a = CloudFilesRestT (m a)

derive newtype instance cfrt6 :: (MonadRest m) => MonadRest (CloudFilesRestT m)
derive newtype instance cfrt7 :: (MonadLog m) => MonadLog (CloudFilesRestT m)

instance cfrt8 :: MonadRest m => MonadCloud (CloudFilesRestT m) where
  saveFile path bytes = do
    void $ put ("/file/" <> path) bytes
    pure unit
  listFiles path = do
    void $ get ("/files/" <> path)
    pure ["MockFile"]

--------------------------------------------------------------------------------
-- A (non-functional) REST client.
newtype RestClientT m a = RestClientT (m a)

derive newtype instance rct6 :: (MonadEffect m) => MonadEffect (RestClientT m)
derive newtype instance rct7 :: (MonadLog m) => MonadLog (RestClientT m)

instance rct8 :: MonadEffect m => MonadRest (RestClientT m) where
  get path = do
    liftEffect (Console.log $ "I should GET " <> path)
    pure ""
  put path bytes = do
    liftEffect (Console.log $ "I should PUT " <> path <> " " <> bytes)
    pure ""

--------------------------------------------------------------------------------
-- Our application only talks about MonadCloud and MonadLog.
app :: forall m. MonadCloud m => MonadLog m => m Unit
app = do
  fileArray <- listFiles "/home/ollie"
  case fileArray of
    [f] -> do
      log Info ("Found " <> f)
      saveFile f "Ollie"
    _ -> pure unit
  pure unit

-- Running the application chooses to instrument with extra logging, use the
-- REST client and to send all logs to stdout.
main :: Effect Unit
main = do
  Console.log "\nDo the same thing as the original example\n"

  runStdoutLoggingT (runRestClient (runCloudFilesRestT (runCloudFilesLogging app)))

  Console.log "\nDo the same thing but remove the intermediate logging\n"

  runStdoutLoggingT (runRestClient (runCloudFilesRestT app))

-- Boilerplate run computation by unwrapping its newtype wrapper
runCloudFilesLogging :: forall m a. CloudFilesLogT m a -> m a
runCloudFilesLogging (CloudFilesLogT comp) = comp

runCloudFilesRestT :: forall m a. CloudFilesRestT m a -> m a
runCloudFilesRestT (CloudFilesRestT comp) = comp

runRestClient :: forall m a. RestClientT m a -> m a
runRestClient (RestClientT comp) = comp

runStdoutLoggingT :: forall m a. StdoutLoggingT m a -> m a
runStdoutLoggingT (StdoutLoggingT comp) = comp

-- Boilerplate type class derivations:
derive newtype instance cfl1 :: (Functor m) => Functor (CloudFilesLogT m)
derive newtype instance cfl2 :: (Applicative m) => Applicative (CloudFilesLogT m)
derive newtype instance cfl3 :: (Apply m) => Apply (CloudFilesLogT m)
derive newtype instance cfl4 :: (Bind m) => Bind (CloudFilesLogT m)
derive newtype instance cfl5 :: (Monad m) => Monad (CloudFilesLogT m)

derive newtype instance slt1 :: (Functor m) => Functor (StdoutLoggingT m)
derive newtype instance slt2 :: (Applicative m) => Applicative (StdoutLoggingT m)
derive newtype instance slt3 :: (Apply m) => Apply (StdoutLoggingT m)
derive newtype instance slt4 :: (Bind m) => Bind (StdoutLoggingT m)
derive newtype instance slt5 :: (Monad m) => Monad (StdoutLoggingT m)

derive newtype instance cfrt1 :: (Functor m) => Functor (CloudFilesRestT m)
derive newtype instance cfrt2 :: (Applicative m) => Applicative (CloudFilesRestT m)
derive newtype instance cfrt3 :: (Apply m) => Apply (CloudFilesRestT m)
derive newtype instance cfrt4 :: (Bind m) => Bind (CloudFilesRestT m)
derive newtype instance cfrt5 :: (Monad m) => Monad (CloudFilesRestT m)

derive newtype instance rct1 :: (Functor m) => Functor (RestClientT m)
derive newtype instance rct2 :: (Applicative m) => Applicative (RestClientT m)
derive newtype instance rct3 :: (Apply m) => Apply (RestClientT m)
derive newtype instance rct4 :: (Bind m) => Bind (RestClientT m)
derive newtype instance rct5 :: (Monad m) => Monad (RestClientT m)