Worked example with most of the source derived from: http://aaronlevin.ca/post/136494428283/extensible-effects-in-the-van-laarhoven-free-monad

effects-vl-demo.cabal

name:                haskell-effects
version:             0.1.0.0
synopsis:            Effects, yes
-- description:
license:             BSD3
license-file:        LICENSE
author:              Allele Dev
maintainer:          [email protected]
-- copyright:
category:            Data
build-type:          Simple
-- extra-source-files:
cabal-version:       >=1.10

library
  exposed-modules:     Data.Effects.FreeVL
  -- other-modules:
  -- other-extensions:
  build-depends:       base >=4.8 && <4.9
                     , wreq
                     , lens
                     , bytestring
                     , http-client
                     , http-types
                     , random
  hs-source-dirs:      src
  ghc-options:         -Wall -fno-warn-type-defaults
  default-language:    Haskell2010

FreeVLDemo.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}
-- Findings: almost everything could be inferred
-- Changes:
--   * Modified random effect to use randomRIO form
--     - `(flip mod 10) getRand` was forcing an `Integral (FreeVL effs Int` Constraint up the stack
module Data.Effects.FreeVL where

import Control.Arrow ((&&&))
import Control.Concurrent (threadDelay)
import Control.Exception (catch)
import Data.ByteString.Lazy (ByteString)
import Network.Wreq (get, post, Response)
import Network.HTTP.Client (HttpException(StatusCodeException))
import qualified Network.HTTP.Types.Status as S
import System.Random (randomRIO, Random)

--------------------------------------------------------------------------------
--                         Free VL: Round 1, 1 Effect, No Composition         --
--------------------------------------------------------------------------------
type Url = String
type RequestBody = ByteString

data Logging1 m = Logging1 { infoLogger :: String -> m ()
                           , debugLogger :: String -> m ()
                           }

newtype FreeVL1 effect a =
  FreeVL1 { runFreeVL1 :: forall m. Monad m => effect m -> m a }

data NewHttp m =
  NewHttp { getNewHttp  :: Url -> m (Response ByteString)
          , postNewHttp :: Url -> RequestBody -> m (Response ByteString)
          }

newHttpIO :: NewHttp IO
newHttpIO = NewHttp { getNewHttp = get, postNewHttp = post }

freeVL1IOInterpreter :: FreeVL1 NewHttp a -> IO a
freeVL1IOInterpreter prog = runFreeVL1 prog newHttpIO

newGet :: Url -> FreeVL1 NewHttp (Response ByteString)
newGet url = FreeVL1 (`getNewHttp` url)

--------------------------------------------------------------------------------
--                 Free VL Round 2 - Effect Stacks                            --
--------------------------------------------------------------------------------
data EffectStack a (m :: * -> *) where
  EmptyEffect :: EffectStack '[] m
  ConsEffect :: eff m -> EffectStack effs m -> EffectStack (eff ': effs) m

newtype FreeVL effs a =
  FreeVL { runFreeVL :: forall m. Monad m => EffectStack effs m -> m a }

instance Functor (FreeVL effs) where
  fmap f (FreeVL run) = FreeVL (fmap f . run)

instance Applicative (FreeVL effs) where
  pure a = FreeVL (const (pure a))
  (FreeVL fab) <*> (FreeVL a) =
    FreeVL $ uncurry (<*>) . (fab &&& a)

instance Monad (FreeVL effs) where
  (FreeVL run) >>= f =
    FreeVL $ \effs -> run effs >>= \a -> runFreeVL (f a) effs

interpret :: Monad m => EffectStack effs m -> FreeVL effs a -> m a
interpret interpreter prog = runFreeVL prog interpreter

class HasEffect (effs :: [((* -> *) -> *)]) (eff :: ((* -> *) -> *)) where
  getEff :: EffectStack effs m -> eff m

instance {-# OVERLAPPABLE #-}
  HasEffect effects effect => HasEffect (x ': effects) effect where
  getEff (ConsEffect _ effs) = getEff effs

instance {-# OVERLAPPABLE #-}
  HasEffect (effect ': effects) effect where
  getEff (ConsEffect eff _) = eff

-- not inferrable
liftVL :: HasEffect effs eff
       => (forall m. eff m -> m a)
       -> FreeVL effs a
liftVL getOp = FreeVL (getOp . getEff)

data Http m =
  Http { getHttpEff  :: Url -> m (Either Int (Response ByteString))
       , postHttpEff :: Url -> RequestBody -> m (Either Int (Response ByteString))
       }

data Logging m = Logging { logEff :: String -> m () }

data RandomR m = RandomR { getRandomEff :: forall a. Random a => (a,a) -> m a }

data Suspend m = Suspend { suspendEff :: Int -> m () }

getHttp' :: HasEffect effs Http
        => Url -> FreeVL effs (Either Int (Response ByteString))
getHttp' url = liftVL (`getHttpEff` url)

postHttp' :: HasEffect effs Http
          => Url -> RequestBody -> FreeVL effs (Either Int (Response ByteString))
postHttp' url body = liftVL (\eff -> postHttpEff eff url body)

logMsg' :: HasEffect effs Logging
        => String -> FreeVL effs ()
logMsg' msg = liftVL (`logEff` msg)

-- not inferable in original (0 arguments, ambiguous types), inferable here
getRand' :: (Random a, HasEffect effs RandomR) => a -> a -> FreeVL effs a
getRand' lower upper = liftVL (\eff -> getRandomEff eff (lower,upper))

suspend' :: HasEffect effs Suspend => Int -> FreeVL effs ()
suspend' i = liftVL (`suspendEff` i)

--------------------------------------------------------------------------------
--         Worked Example: 4-Effect IO Intepreter Using VL                    --
--------------------------------------------------------------------------------
-- inferred:
{-
repeatReq :: forall (effs :: [(* -> *) -> *]).
             ( HasEffect effs Http,
             , HasEffect effs Suspend
             , HasEffect effs Random)
             )
             => Url -> FreeVL effs (Either Int (Response ByteString))
-}
repeatReq :: ( HasEffect effs Http
             , HasEffect effs Suspend
             , HasEffect effs RandomR
             ) => Url -> FreeVL effs (Either Int (Response ByteString))
repeatReq url = do
  numRetries <- getRand' (0 :: Int) 10
  eResponse <- getHttp' url
  go numRetries eResponse
  where
    go 0 r = return r
    go i _ = do
      eResponse <- getHttp' url
      case eResponse of
        r@(Right _) -> return r
        (Left _) -> suspend' 100 >> go (i-1) eResponse

withLog :: HasEffect effs Logging
        => String -> String -> FreeVL effs b -> FreeVL effs b
withLog preMsg postMsg prog = do
  logMsg' preMsg
  a <- prog
  logMsg' postMsg
  return a

program :: ( HasEffect effs Logging
           , HasEffect effs RandomR
           , HasEffect effs Suspend
           , HasEffect effs Http
           ) => FreeVL effs (Either Int (Response ByteString))
program = withLog "running" "done" (repeatReq "http://php.net")

(.:.) :: eff m -> EffectStack effs m -> EffectStack (eff ': effs) m
eff .:. effs = ConsEffect eff effs
infixr 4 .:.

handleException :: HttpException -> Either Int a
handleException (StatusCodeException status _ _) = Left (S.statusCode status)
handleException _ = error "unhandled"

httpIO :: Http IO
httpIO =
  let handler = return . handleException
  in Http { getHttpEff  =
            \req -> (Right <$> get req) `catch` handler
          , postHttpEff =
              \req body -> (Right <$> post req body) `catch` handler
          }

logIO :: Logging IO
logIO = Logging { logEff = putStrLn }

randIO :: RandomR IO
randIO = RandomR { getRandomEff = randomRIO }

suspendIO :: Suspend IO
suspendIO = Suspend { suspendEff = threadDelay }

-- minor change: type list syntax sugar
type MyEffects = '[Http, Logging, RandomR, Suspend]

ioIntepreter :: EffectStack MyEffects IO
ioIntepreter = httpIO .:. logIO .:. randIO .:. suspendIO .:. EmptyEffect

main :: IO ()
main = interpret ioIntepreter program >> putStrLn "precious"