{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE TupleSections #-}
module Main (main) where
import Dep.Has
import Dep.Env
import Dep.Dynamic
import Control.Monad.Dep.Class
import Control.Monad.Reader
import Data.Functor.Constant
import Data.Functor.Compose
import Data.Coerce
import Data.Kind
import Data.List (intercalate)
import GHC.Generics (Generic)
import Test.Tasty
import Test.Tasty.HUnit
import Prelude hiding (log)
import Data.Functor.Identity
import GHC.TypeLits
import Control.Monad.Trans.Cont
import Data.Aeson
import Data.Aeson.Types
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.IORef
import System.IO
import Control.Exception
import Control.Arrow (Kleisli (..))
import Data.Text qualified as Text
import Data.Function ((&))
import Data.Functor ((<&>), ($>))
import Data.String
import Data.Typeable
type Logger :: (Type -> Type) -> Type
newtype Logger d = Logger {
info :: String -> d ()
}
data Repository d = Repository
{ findById :: Int -> d (Maybe String)
, putById :: Int -> String -> d ()
, insert :: String -> d Int
}
data Controller d = Controller
{ create :: d Int
, append :: Int -> String -> d Bool
, inspect :: Int -> d (Maybe String)
}
type MessagePrefix = Text.Text
data LoggerConfiguration = LoggerConfiguration {
messagePrefix :: MessagePrefix
} deriving stock (Show, Generic)
deriving anyclass FromJSON
makeStdoutLogger :: MonadIO m => MessagePrefix -> env -> Logger m
makeStdoutLogger prefix _ = Logger (\msg -> liftIO (putStrLn (Text.unpack prefix ++ msg)))
allocateMap :: ContT () IO (IORef (Map Int String))
allocateMap = ContT $ bracket (newIORef Map.empty) pure
makeInMemoryRepository
:: Has Logger IO env
=> IORef (Map Int String)
-> env
-> Repository IO
makeInMemoryRepository ref (asCall -> call) = do
Repository {
findById = \key -> do
call info "I'm going to do a lookup in the map!"
theMap <- readIORef ref
pure (Map.lookup key theMap)
, putById = \key content -> do
theMap <- readIORef ref
writeIORef ref $ Map.insert key content theMap
, insert = \content -> do
call info "I'm going to insert in the map!"
theMap <- readIORef ref
let next = Map.size theMap
writeIORef ref $ Map.insert next content theMap
pure next
}
makeController :: (Has Logger m env, Has Repository m env, Monad m) => env -> Controller m
makeController (asCall -> call) = Controller {
create = do
call info "Creating a new empty resource."
key <- call insert ""
pure key
, append = \key extra -> do
call info "Appending to a resource"
mresource <- call findById key
case mresource of
Nothing -> do
pure False
Just resource -> do
call putById key (resource ++ extra)
pure True
, inspect = \key -> do
call findById key
}
-- from Has-using to positional
makeControllerPositional :: Monad m => Logger m -> Repository m -> Controller m
makeControllerPositional a b = makeController $ addDep a $ addDep b $ emptyEnv
-- from positional to Has-using
makeController' :: (Has Logger m env, Has Repository m env, Monad m) => env -> Controller m
makeController' env = makeControllerPositional (dep env) (dep env)
-- from purely Has-using to MonadDep-using
-- but this is very verbose. See 'component' in "Control.Monad.Dep.Advice" of package dep-t-advice
-- for an alternative.
makeController'' :: MonadDep [Has Logger, Has Repository] d e m => Controller m
makeController'' = Controller {
create = useEnv \env -> create (makeController env)
, append = \a b -> useEnv \env -> append (makeController env) a b
, inspect = \a -> useEnv \env -> inspect (makeController env) a
}
--
-- type EnvHKD :: (Type -> Type) -> (Type -> Type) -> Type
-- data EnvHKD h m = EnvHKD
-- { logger :: h (Logger m),
-- repository :: h (Repository m),
-- controller :: h (Controller m)
-- } deriving stock Generic
-- deriving anyclass (Phased, DemotableFieldNames, FieldsFindableByType)
--
-- deriving via Autowired (EnvHKD Identity m) instance Autowireable r_ m (EnvHKD Identity m) => Has r_ m (EnvHKD Identity m)
type Field = (,) String
type Configurator = Kleisli Parser Value
parseConf :: FromJSON a => Configurator a
parseConf = Kleisli parseJSON
type Allocator = ContT () IO
type Phases env = Field `Compose` Configurator `Compose` Allocator `Compose` Constructor env
env :: DynamicEnv (Phases (DynamicEnv Identity IO)) IO
env =
insertDep @Logger (fromBare $
("logger",) $
parseConf <&> \(LoggerConfiguration {messagePrefix}) ->
pure @Allocator $
makeStdoutLogger messagePrefix)
$ insertDep @Repository (fromBare $
("repository",) $
pure @Configurator $
allocateMap <&> \ref ->
makeInMemoryRepository ref)
$ insertDep @Controller (fromBare $
("controller",) $
pure @Configurator $
pure @Allocator $
makeController)
$ mempty
env' :: Kleisli Parser Object (DynamicEnv (Allocator `Compose` Constructor (DynamicEnv Identity IO)) IO)
env' = traverseH trans env
where
trans (Compose (fieldName, Compose (Kleisli f))) =
Kleisli \o -> explicitParseField f o (fromString fieldName)
testEnvConstruction :: Assertion
testEnvConstruction = do
let parseResult = eitherDecode' (fromString "{ \"logger\" : { \"messagePrefix\" : \"[foo]\" }, \"repository\" : null, \"controller\" : null }")
print parseResult
let Right value = parseResult
Kleisli (withObject "configuration" -> parser) = env'
Right allocators = parseEither parser value
runContT (pullPhase @Allocator allocators) \constructors -> do
let (asCall -> call) = fixEnv constructors
resourceId <- call create
call append resourceId "foo"
call append resourceId "bar"
Just result <- call inspect resourceId
assertEqual "" "foobar" $ result
envMissing :: DynamicEnv (Phases (DynamicEnv Identity IO)) IO
envMissing =
insertDep (
("repository",()) `bindPhase` \() ->
skipPhase @Configurator $
allocateMap `bindPhase` \ref ->
constructor (makeInMemoryRepository ref)
)
$ insertDep (
("controller",()) `bindPhase` \() ->
skipPhase @Configurator $
skipPhase @Allocator $
constructor makeController
)
$ mempty
envMissing' :: Kleisli Parser Object (DynamicEnv (Allocator `Compose` Constructor (DynamicEnv Identity IO)) IO)
envMissing' = traverseH trans envMissing
where
trans (Compose (fieldName, Compose (Kleisli f))) =
Kleisli \o -> explicitParseField f o (fromString fieldName)
testMissingDep :: Assertion
testMissingDep = do
let parseResult = eitherDecode' (fromString "{ \"logger\" : { \"messagePrefix\" : \"[foo]\" }, \"repository\" : null, \"controller\" : null }")
print parseResult
let Right value = parseResult
Kleisli (withObject "configuration" -> parser) = envMissing'
Right allocators = parseEither parser value
runContT (pullPhase @Allocator allocators) \constructors -> do
let (asCall -> call) = fixEnv constructors
e <- tryJust (fromException @DepNotFound) (call create)
case e of
Left (DepNotFound x) | x == typeRep (Proxy @(Logger IO)) -> pure ()
_ -> assertFailure "exception expected"
--
--
--
tests :: TestTree
tests =
testGroup
"All"
[
testCase "environmentConstruction" testEnvConstruction
, testCase "missing" testMissingDep
]
main :: IO ()
main = defaultMain tests