Skip to content

Instantly share code, notes, and snippets.

@JordanMartinez
Forked from ocharles/Modern FP with mtl.hs
Last active March 19, 2021 06:55
Show Gist options
  • Save JordanMartinez/4eb9dd1f5ac4e5220ab3d2cc500c0fce to your computer and use it in GitHub Desktop.
Save JordanMartinez/4eb9dd1f5ac4e5220ab3d2cc500c0fce to your computer and use it in GitHub Desktop.
Purescript port of the original Haskell "Modern FP with MTL"
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)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment