Adventures assembling records of capabilities. https://discourse.haskell.org/t/adventures-assembling-records-of-capabilities/

Rocs.hs

-- cabal v2-repl -b "transformers" -b "red-black-record" -b "sop-core" -b "managed" -b "profunctors" -b "aeson" -b "text"
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module Main where

import           Data.RBR (Record,insert,unit,FromRecord(fromRecord),ToRecord,RecordCode,
                           KeysValuesAll,KnownKey,demoteKeys,
                           Productlike,fromNP,toNP,
                           setField)
import           Data.SOP (I(I),unI,K(K),NP,(:.:)(Comp),All,Top)
import           Data.SOP.NP (sequence_NP,sequence'_NP,liftA2_NP)
import           Data.Function (fix)
import           Control.Monad.Managed (Managed,managed,with,liftIO)
import           Control.Monad.Trans.Reader (Reader,runReader,ReaderT,runReaderT,ask,asks)
import           Data.Aeson (Value(String,Number),object,Object,withObject)
import           Data.Aeson.Types (Parser,parseEither,explicitParseField)
import qualified Data.Aeson as A
import qualified Data.Text
import           Data.Profunctor (Star(Star))
import           Control.Exception (bracket_)
import qualified GHC.Generics

--
--
-- Main types

data Env = Env { 
                    simple :: SimpleCapability,
                    complex :: ComplexCapability
               } deriving (GHC.Generics.Generic, Show)
instance FromRecord Env 
instance ToRecord Env

-- A "leaf" capability that can be used by both the main program logic and
-- other capabilities.
data SimpleCapability = SimpleCapability Int deriving Show

-- A capability that requires the presence of SimpleCapability to work.
data ComplexCapability = ComplexCapability SimpleCapability deriving Show

-- Program logic. 
-- Actual program logic wouldn't take a concrete Env, it would likely
-- use the classy lenses approach.
dummyLogic :: ReaderT Env IO ()
dummyLogic = ask >>= liftIO . putStrLn . show

--
--
-- The simplest case

-- 
env :: Env
env =
    let simple' = SimpleCapability 7
     in Env { simple = simple', complex = ComplexCapability simple' }

--
--
-- An "open" record with fields taking functions from
-- the final environment.

openEnv :: Record (Reader Env) (RecordCode Env)
openEnv =
      insert @"simple"  (pure $ SimpleCapability 7)
    . insert @"complex" (makeComplex simple)
    $ unit

-- This capability constructor receives a getter for simplicity, in a real
-- application it could obtain its dependencies using something like classy
-- lenses or generic-lens.
makeComplex :: (r -> SimpleCapability) -> Reader r ComplexCapability
makeComplex getter = 
    do simple' <- asks getter
       pure $ ComplexCapability simple'

-- Seal an "open" record to obtain the final environment record.
fixRecord 
    :: forall r flat. (FromRecord r, Productlike '[] (RecordCode r) flat, All Top flat)
    => Record (Reader r) (RecordCode r)
    -> r
fixRecord = unI . fixHelper I

-- If we can partially "pull out" some field-wrapping functor from the
-- components of an n-ary product so that the field-wrapping functor becomes
-- Reader r, then we can take a labelled Record, pull out its wrapping functor
-- and “fix” it to get a plain record.
fixHelper 
    :: forall r flat f g. (FromRecord r, Productlike '[] (RecordCode r) flat, All Top flat,Functor g)
    => (NP f flat -> g (NP (Reader r) flat))
    -> Record f (RecordCode r)
    -> g r 
fixHelper adapt r = do
    let moveFunctionOutside np = runReader . sequence_NP $ np
        record2record np = fromRecord . fromNP <$> moveFunctionOutside np
    fix . record2record <$> adapt (toNP r)

--
--
-- Managed capabilities

-- An "open" record whose fields might perform resource allocations in Managed.
managedOpenEnv :: Record (Managed :.: Reader Env) (RecordCode Env)
managedOpenEnv =
      insert @"simple"  (Comp $ pure $ pure $ SimpleCapability 7)
    . insert @"complex" (makeManagedComplex simple)
    $ unit

-- A capability constructor that performs an allocation
makeManagedComplex :: (r -> SimpleCapability) -> (Managed :.: Reader r) ComplexCapability
makeManagedComplex getter = 
    Comp $ managed $ \cnt -> bracket_ (putStrLn "activating")
                                      (putStrLn "deactivating")
                                      (cnt $ makeComplex getter)

fixManagedRecord
    :: forall r flat. (FromRecord r, Productlike '[] (RecordCode r) flat, All Top flat)
    => Record (Managed :.: Reader r) (RecordCode r)
    -> Managed r
fixManagedRecord = fixHelper sequence'_NP

--
--
-- Managed capabilities with externalized configuration

-- An "open" record whose fields might perform resource allocations in Managed, and also
-- parse their configuration from a JSON Value.
externManagedOpenEnv :: Record (Star Parser A.Value :.: Managed :.: Reader Env) (RecordCode Env)
externManagedOpenEnv =
      insert @"simple"  makeExternManagedSimple
    . insert @"complex" (makeExternManagedComplex simple)
    $ unit

-- A capability constructor that parses its configuration from a JSON Value.
makeExternManagedSimple :: (Star Parser A.Value :.: Managed :.: Reader r) SimpleCapability
makeExternManagedSimple =
    Comp $ Star $ \v -> case v of
                           Number n  -> pure $ Comp $ pure $ pure $ SimpleCapability (truncate $ n)
                           _         -> fail "parse error simple conf"

-- A capability constructor that parses its configuration from a JSON Value and
-- performs resource allocations.
makeExternManagedComplex 
    :: (r -> SimpleCapability) 
    -> (Star Parser A.Value :.: Managed :.: Reader r) ComplexCapability
makeExternManagedComplex getter = 
    Comp $ Star $ \v -> case v of 
                           String _ -> pure $ makeManagedComplex getter
                           _        -> fail "parse error complex conf"

-- This fix functions is more involved than the others because we need to perform
-- JSON-related shenanigans.
-- Each field knows how to parse its own configuration, we must make them search
-- their configurations in the global JSON configuration object, using their field
-- names in the environments as the keys. 
-- For this, me must demote the keys from the type level.
fixExternManagedRecord
    :: forall r flat. (FromRecord r, Productlike '[] (RecordCode r) flat, All Top flat,
                       KeysValuesAll KnownKey (RecordCode r))
    => Record (Star Parser A.Value :.: Managed :.: Reader r) (RecordCode r)
    -> A.Value 
    -> Either String (Managed r)
fixExternManagedRecord r v =
    let mapKSS (K name) (Comp (Star f)) = Comp (Star (\o -> explicitParseField f o (Data.Text.pack name)))
        parseEachField np = liftA2_NP mapKSS (toNP @(RecordCode r) demoteKeys) np
        adapt :: NP (Star Parser A.Value :.: Managed :.: Reader r) flat 
              -> (Star Parser Object :.: Managed) (NP (Reader r) flat)
        adapt np = Comp (fmap sequence'_NP (sequence'_NP (parseEachField np)))
        Comp (Star parser) = fixHelper adapt r
     in parseEither (withObject "configuration" parser) v 

--
main :: IO ()
main = 
    do putStrLn "# run env"
       runReaderT dummyLogic env
       --
       putStrLn "# run modified env - change does not propagate"
       runReaderT dummyLogic env{ simple = SimpleCapability 8 }
       --
       putStrLn "# run open env"
       do let closedEnv = fixRecord openEnv 
          runReaderT dummyLogic closedEnv
       --
       putStrLn "# run modified open env - change does propagate"
       do let closedEnv = fixRecord (setField @"simple" (pure $ SimpleCapability 8) openEnv)
          runReaderT dummyLogic closedEnv
       --
       putStrLn "# run managed open env"
       with (fixManagedRecord managedOpenEnv) (runReaderT dummyLogic)
       --
       putStrLn "# run externally configured managed open env"
       do let v :: A.Value
              v = A.object [("simple",Number $ fromInteger 7),("complex",String "foo")]
              valueParser = fixExternManagedRecord externManagedOpenEnv
          case valueParser v of
              Left  errMsg -> putStrLn errMsg
              Right closedEnv -> with closedEnv (runReaderT dummyLogic)
       return ()