packages feed

caps (empty) → 0.1

raw patch · 5 files changed

+746/−0 lines, 5 filesdep +basedep +capsdep +mtlsetup-changed

Dependencies added: base, caps, mtl, tasty, tasty-hunit, template-haskell, transformers, typerep-map

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2017, Vladislav Zavialov++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Vladislav Zavialov nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ caps.cabal view
@@ -0,0 +1,33 @@+name:                caps+version:             0.1+synopsis:            Monadic capabilities with late binding+license:             BSD3+license-file:        LICENSE+author:              Vladislav Zavialov+maintainer:          vlad.z.4096@gmail.com+category:            Control+build-type:          Simple+cabal-version:       >=1.10++library+  exposed-modules:     Monad.Capabilities+  build-depends:       base >=4.10 && <4.15,+                       transformers,+                       typerep-map >=0.3,+                       template-haskell+  hs-source-dirs:      src+  default-language:    Haskell2010+  ghc-options:         -Wall+                       -fno-warn-unticked-promoted-constructors+                       -fno-warn-partial-type-signatures++test-suite test-examples+  build-depends:       base >=4.10 && <4.15,+                       caps,+                       mtl,+                       tasty,+                       tasty-hunit+  main-is:             TestExamples.hs+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  default-language:    Haskell2010
+ src/Monad/Capabilities.hs view
@@ -0,0 +1,584 @@+{-# LANGUAGE TypeInType, GADTs, ScopedTypeVariables, FlexibleInstances,+             TypeOperators, ConstraintKinds, TypeFamilies, PartialTypeSignatures,+             UndecidableInstances, ViewPatterns, RankNTypes, TypeApplications,+             MultiParamTypeClasses, UndecidableSuperClasses, TemplateHaskell,+             StandaloneDeriving, DerivingStrategies, GeneralizedNewtypeDeriving #-}++{-|++Monadic capabilities are additional methods for a base monad. For instance, when+our base monad is 'IO', our capabilities might include logging, networking,+database access, and so on.++This framework allows mutually recursive late-bound capabilities with runtime+dispatch and a type-safe interface.++A capability is defined as a record type with methods parametrized over a base+monad:++@+data Logging m =+  Logging+    { _logError :: String -> m (),+      _logDebug :: String -> m ()+    }+@++We can define implementations as values of this record type:++@+loggingDummy :: Monad m => CapImpl Logging '[] m+loggingDummy = CapImpl $ Logging (\\_ -> return ()) (\\_ -> return ())++loggingIO :: MonadIO m => CapImpl Logging '[] m+loggingIO = CapImpl $+  Logging+    { _logError = \\msg -> liftIO . putStrLn $ "[Error] " ++ msg+      _logDebug = \\msg -> liftIO . putStrLn $ "[Debug] " ++ msg+    }+@++The dictionary is wrapped in 'CapImpl' to guarantee that it is sufficiently+polymorphic (this is required to support simultaneous use of monadic actions in+negative position and capability extension).++Then we want to use this capability in the 'CapsT' monad (which is nothing more+but a synonym for 'ReaderT' of 'Capabilities'), and for this we define a helper+per method:++@+logError :: HasCap Logging caps => String -> CapsT caps m ()+logError message = withCap $ \\cap -> _logError cap message++logDebug :: HasCap Logging caps => String -> CapsT caps m ()+logDebug message = withCap $ \\cap -> _logDebug cap message+@++We can define other capabilities in a similar manner:++@+data Networking m =+  Networking+    { _sendRequest :: ByteString -> m ByteString }++data FileStorage m =+  FileStorage+    { _readFile :: FilePath -> m ByteString,+      _writeFile :: FilePath -> ByteString -> m ()+    }+@++Implementations of capabilities may depend on other capabilities, which are+listed in their signature. For instance, this is how we can define the+'FileStorage' capability using the 'Logging' capability:++@+fileStorageIO :: MonadIO m => CapImpl FileStorage '[Logging] m+fileStorageIO = CapImpl $+  FileStorage+    { _readFile = \\path -> do+        logDebug $ "readFile " ++ path+        lift $ ByteString.readFile path+      _writeFile = \\path content -> do+        logDebug $+          "writeFile " ++ path +++          " (" ++ show (ByteString.length content) +++          " bytes)"+        lift $ ByteString.writeFile path content+    }+@++Here the @fileStorageIO@ implementation requires a logging capability,+but it's not specified which one.++When we decided what set of capabilities our application needs, we can put them+together in a 'Capabilities' map and run the application with this map in a+'ReaderT' context:++@+caps = buildCaps $+  AddCap loggingIO $+  AddCap fileStorageIO $+  BaseCaps emptyCaps++flip runReaderT caps $ do+  config <- readFile "config.yaml"+  ...+@++Capabilities passed to 'buildCaps' can depend on each other. The order does not+matter (although it is reflected in the types), and duplicate capabilities are+disallowed.++We can override a capability locally:++@+do+  config <- readFile "config.yaml"+  withReaderT (overrideCap loggingDummy) $ do+    -- logging is disabled here+    writeFile "config-backup.yaml" config+    ...+@++or we can add more capabilities:++@+do+  config <- readFile "config.yaml"+  networkingImpl <- parseNetworkingConfig config+  withReaderT (addCap networkingImpl) $ do+    -- networking capability added+    resp <- sendRequest req+    ...+@++-}++module Monad.Capabilities+  (+    -- * Capabilities+    Capabilities(),+    CapsT,+    emptyCaps,+    buildCaps,+    CapabilitiesBuilder(..),+    CapImpl(..),+    getCap,+    overrideCap,+    addCap,+    insertCap,+    withCap,+    checkCap,+    adjustCap,++    -- * Default capabilities+    Context(..),+    HasContext,+    newContext,+    askContext,+    localContext,++    -- * Type-level checks+    type HasCap,+    type HasCaps,+    type HasNoCap,+    HasCapDecision(..),++    -- * Utils+    makeCap++  ) where++import Control.Monad.Trans.Reader+import Data.Kind (Type, Constraint)+import Data.Traversable+import Data.Proxy+import Data.Type.Equality+import Data.List (foldl1')+import GHC.TypeLits (TypeError, ErrorMessage(..))+import Type.Reflection (Typeable)+import Data.Coerce (coerce)+import Unsafe.Coerce (unsafeCoerce)++import qualified Data.TypeRepMap as TypeRepMap+import Data.TypeRepMap (TypeRepMap)++import qualified Language.Haskell.TH as TH++type MonadK = Type -> Type++type CapK = MonadK -> Type++-- | @'Capabilities' caps m@ is a map of capabilities @caps@ over a base monad+-- @m@. Consider the following capabilities:+--+-- @+-- data X m = X (String -> m String)+-- data Y m = Y (Int -> m Bool)+-- @+--+-- We can construct a map of capabilities with the following type:+--+-- @+-- capsXY :: Capabilities '[X, Y] IO+-- @+--+-- In this case, @capsXY@ would be a map with two elements, one at key @X@ and+-- one at key @Y@. The types of capabilities themselves serve as keys.+--+-- 'Capabilities' is a heterogeneous collection, meaning that its values have+-- different types. The type of a value is determined by the key:+--+-- @+--+--  X:   X (\\_ -> return "hi") :: X (CapsT '[X, Y] IO)+--  Y:   Y (\\_ -> return True) :: Y (CapsT '[X, Y] IO)+-- ----  ---------------------    --------------------+-- keys         values              types of values+-- @+--+-- Notice that stored dictionaries are parametrized not just by the base monad+-- @IO@, but with the 'CapsT' transformer on top. This means that each+-- capability has access to all other capabilities and itself.+--+newtype Capabilities (caps :: [CapK]) (m :: MonadK) =+  Capabilities (TypeRepMap (CapElem m))++emptyCaps :: Capabilities '[] m+emptyCaps = Capabilities TypeRepMap.empty++deriving newtype instance Show (Capabilities caps m)++-- | The 'CapsT' transformer adds access to capabilities. This is a convenience+-- synonym for 'ReaderT' of 'Capabilities', and all 'ReaderT' functions+-- ('runReaderT', 'withReaderT') can be used with it.+type CapsT caps m = ReaderT (Capabilities caps m) m++-- | The 'CapImpl' newtype guarantees that the wrapped capability implementation+-- is sufficiently polymorphic so that required subtyping properties hold in+-- methods that take monadic actions as input (negative position).+--+-- This rules out using 'addCap', 'insertCap', and 'buildCaps' inside capability+-- implementations in an unsafe manner.+data CapImpl cap icaps m where+  CapImpl ::+    WithSpine icaps =>+    { getCapImpl :: forall caps. HasCaps icaps caps => cap (CapsT caps m)+    } ->+    CapImpl cap icaps m++newtype CapElem m cap =+  CapElem { getCapElem :: forall caps. cap (CapsT caps m) }++overCapElem ::+  (forall caps. cap (CapsT caps m) -> cap' (CapsT caps m')) ->+  CapElem m cap ->+  CapElem m' cap'+overCapElem f (CapElem cap) = CapElem (f cap)++-- Continuation-passing encoding of a list spine:+--+-- data Spine xs where+--   Cons :: Spine xs -> Spine (x : xs)+--   Nil :: Spine '[]+--+class WithSpine xs where+  onSpine ::+    forall r.+    Proxy xs ->+    ((xs ~ '[]) => r) ->+    (forall y ys.+      (xs ~ (y : ys)) =>+      WithSpine ys =>+      Proxy y ->+      Proxy ys ->+      r) ->+    r++instance WithSpine '[] where+  onSpine _ onNil _ = onNil++instance WithSpine xs => WithSpine (x : xs) where+  onSpine _ _ onCons = onCons Proxy Proxy++toCapElem ::+  forall cap icaps m.+  CapImpl cap icaps m ->+  CapElem m cap+toCapElem (CapImpl cap) = CapElem+  (fiatHasElems (Proxy @icaps) (Proxy @caps) cap :: forall caps. cap (CapsT caps m))++fiatHasElems ::+  forall icaps caps.+  WithSpine icaps =>+  Proxy icaps ->+  Proxy caps ->+  forall r. (HasCaps icaps caps => r) -> r+fiatHasElems Proxy Proxy r =+  onSpine (Proxy @icaps)+    -- nil+    r+    -- cons+    (\(Proxy :: Proxy cap) (Proxy :: Proxy icaps') ->+       case unsafeUnitConstr @(HasCap cap caps) of+         Refl -> fiatHasElems (Proxy @icaps') (Proxy @caps) r)++{-++Since 'caps' is phantom, we can reorder capabilities, remove non-unique+capabilities, or extend them.++The tricky case is extension. Assume @caps'@ subsumes @caps@, and consider each+@cap n@ where @n ~ CapsT caps m@ individually. When we cast this to use @caps'@,+we must know that @cap@ will continue to work correctly.++1. Assume @cap@ uses @n@ in positive position exclusively. This means that the+   capability defines methods that take @Capabilities caps m@ as input, and+   it's okay if we pass @Capabilities caps' m@ instead, as we will simply have+   some unnecessary input.++2. Assume @cap@ uses @n@ in a negative poistion as well. This means that the+   capability defines method that will be passing @Capabilities caps m@ to+   other monadic actions. But when we cast to @caps'@, these monadic actions+   require @Capabilities caps' m@, where @caps'@ subsumes @caps@, so at runtime+   it's possible that we don't pass all needed capabilities for them.++In order for (2) to be safe, we need to place an additional requirement on+capabilities which use the provided @Capabilities caps m@ in a negative position:++  The positive occurence of @Capabilities caps m@ must come from a value+  provided by an occurence of @Capabilities caps m@ in a negative position,+  unmodified, rather than be constructed.++Essentially, we want capabilities to do only two things with @Capabilities@:++* extract parts of it with 'getCap'+* pass it along++In this case, even when on types we put @Capabilities caps m@ in a positive+position (where @caps@ might be insufficient), at runtime we know that these+capabilities actually contain @caps'@.++We guarantee this property by the 'CapImpl' newtype.++-}++-- | 'CapabilitiesBuilder' is a type to extend capabilities.+--+-- The @allCaps@ parameter is a list of capabilities that will be provided to+-- 'buildCaps' eventually, when the building process is done. The @caps@+-- parameter is the part of capabilities that was constructed so far. The+-- builder is considered complete when @allCaps ~ caps@, only then it can be+-- passed to 'buildCaps'.+data CapabilitiesBuilder (allCaps :: [CapK]) (caps :: [CapK]) (m :: MonadK) where+  AddCap ::+    (Typeable cap, HasCaps icaps allCaps, HasNoCap cap caps) =>+    CapImpl cap icaps m ->+    CapabilitiesBuilder allCaps caps m ->+    CapabilitiesBuilder allCaps (cap : caps) m+  BaseCaps ::+    Capabilities caps m ->+    CapabilitiesBuilder allCaps caps m++-- | Build a map of capabilities from individual implementations:+--+-- @+-- capsXY :: Capabilities '[X, Y] IO+-- capsXY = buildCaps $+--     AddCap xImpl $+--     AddCap yImpl $+--     BaseCaps emptyCaps+-- @+buildCaps :: forall caps m. CapabilitiesBuilder caps caps m -> Capabilities caps m+buildCaps = Capabilities . go+  where+    go ::+      CapabilitiesBuilder caps caps' m ->+      TypeRepMap (CapElem m)+    go (BaseCaps (Capabilities caps)) = caps+    go (AddCap capImpl otherCaps) =+      TypeRepMap.insert (toCapElem capImpl) (go otherCaps)++-- | Ensure that the @caps@ list has an element @cap@.+type family HasCap cap caps :: Constraint where+  HasCap cap (cap  : _) = ()+  HasCap cap (cap' : caps) = HasCap cap caps+  HasCap cap '[] =+    TypeError+      (Text "Capability " :<>:+       ShowType cap :<>:+       Text " must be available")++-- | Ensure that the @caps@ list subsumes @icaps@. It is equivalent+-- to a @HasCap icap caps@ constraint for each @icap@ in @icaps@.+type family HasCaps icaps caps :: Constraint where+  HasCaps '[] _ = ()+  HasCaps (icap : icaps) caps = (HasCap icap caps, HasCaps icaps caps)++-- | Ensure that the @caps@ list does not have an element @cap@.+type family HasNoCap cap caps :: Constraint where+  HasNoCap cap (cap : _) =+    TypeError+      (Text "Capability " :<>:+       ShowType cap :<>:+       Text " is already present")+  HasNoCap cap (cap' : caps) = HasNoCap cap caps+  HasNoCap cap '[] = ()++-- | Lookup a capability in a 'Capabilities' map. The 'HasCap' constraint+-- guarantees that the lookup does not fail.+getCap :: forall cap m caps. (Typeable cap, HasCap cap caps) => Capabilities caps m -> cap (CapsT caps m)+getCap (Capabilities m) =+  case TypeRepMap.lookup m of+    Nothing -> error "getCap: impossible"+    Just e -> getCapElem e++-- An internal function that adds capabilities.+unsafeInsertCap ::+  (Typeable cap, HasCaps icaps caps') =>+  CapImpl cap icaps m ->+  Capabilities caps m ->+  Capabilities caps' m+unsafeInsertCap capImpl (Capabilities caps) =+  Capabilities (TypeRepMap.insert (toCapElem capImpl) caps)++-- | Extend the set of capabilities. In case the capability is already present,+-- it will be overriden (as with 'overrideCap'), but occur twice in the type.+insertCap ::+  (Typeable cap, HasCaps icaps (cap : caps)) =>+  CapImpl cap icaps m ->+  Capabilities caps m ->+  Capabilities (cap : caps) m+insertCap = unsafeInsertCap++-- | Extend the set of capabilities. In case the capability is already present,+-- a type error occurs.+addCap ::+  (Typeable cap, HasNoCap cap caps, HasCaps icaps (cap : caps)) =>+  CapImpl cap icaps m ->+  Capabilities caps m ->+  Capabilities (cap : caps) m+addCap capImpl caps = buildCaps (AddCap capImpl $ BaseCaps caps)++-- | Override the implementation of an existing capability.+overrideCap ::+  (Typeable cap, HasCap cap caps, HasCaps icaps caps) =>+  CapImpl cap icaps m ->+  Capabilities caps m ->+  Capabilities caps m+overrideCap = unsafeInsertCap++-- | Override the implementation of an existing capability using the previous+-- implementation. This is a more efficient equivalent to extracting a+-- capability with 'getCap', adjusting it with a function, and putting it back+-- with 'overrideCap'.+adjustCap ::+  forall cap caps m.+  (Typeable cap, HasCap cap caps) =>+  (forall caps'. cap (CapsT caps' m) -> cap (CapsT caps' m)) ->+  Capabilities caps m ->+  Capabilities caps m+adjustCap f (Capabilities caps) =+  Capabilities (TypeRepMap.adjust (overCapElem f) caps)++-- | Extract a capability from 'CapsT' and provide it to a continuation.+withCap :: (Typeable cap, HasCap cap caps) => (cap (CapsT caps m) -> CapsT caps m a) -> CapsT caps m a+withCap cont = ReaderT $ \caps -> runReaderT (cont (getCap caps)) caps++-- | Evidence that @cap@ is present or absent in @caps@.+data HasCapDecision cap caps where+  HasNoCap :: HasNoCap cap caps => HasCapDecision cap caps+  HasCap :: HasCap cap caps => HasCapDecision cap caps++instance Show (HasCapDecision cap caps) where+  show HasNoCap = "HasNoCap"+  show HasCap = "HasCap"++-- | Determine at runtime whether 'HasCap cap caps' or 'HasNoCap cap caps' holds.+checkCap :: forall cap caps m. Typeable cap => Capabilities caps m -> HasCapDecision cap caps+checkCap (Capabilities m) =+  if TypeRepMap.member @cap m+  then case unsafeUnitConstr @(HasCap cap caps) of Refl -> HasCap+  else case unsafeUnitConstr @(HasNoCap cap caps) of Refl -> HasNoCap++-- Use to construct 'HasCap' or 'HasNoCap'.+unsafeUnitConstr :: c :~: (() :: Constraint)+unsafeUnitConstr = unsafeCoerce Refl++-- | The 'Context' capability is used to model the @Reader@ effect within the+-- capabilities framework.+newtype Context x (m :: MonadK) = Context x++-- | The 'HasContext' constraint is a shorthand for 'HasCap' of 'Context'.+class (Typeable x, HasCap (Context x) caps) => HasContext x caps+instance (Typeable x, HasCap (Context x) caps) => HasContext x caps++-- | Initialize a 'Context' capability.+newContext :: forall x m. x -> CapImpl (Context x) '[] m+newContext x = CapImpl (Context x)++-- | Retrieve the context value. Moral equivalent of 'ask'.+askContext :: (HasContext x caps, Applicative m) => CapsT caps m x+askContext = withCap (\(Context x) -> pure x)++-- | Execute a computation with a modified context value. Moral equivalent of 'local'.+localContext :: forall x caps m a. (HasContext x caps) => (x -> x) -> CapsT caps m a -> CapsT caps m a+localContext f = local (adjustCap @(Context x) (coerce f))++makeCap :: TH.Name -> TH.DecsQ+makeCap capName = do+  let className = TH.mkName ("Monad" ++ TH.nameBase capName)+  info <- TH.reify capName+  (vbts, tyVars) <-+    case info of+      TH.TyConI (TH.DataD    _ _ tyVars _ [TH.RecC _ vbts] _) -> return (vbts, tyVars)+      TH.TyConI (TH.NewtypeD _ _ tyVars _ (TH.RecC _ vbts) _) -> return (vbts, tyVars)+      _ -> fail "Capabilities must be single-constructor record types"+  (mVar, extraTyVars) <-+    case reverse tyVars of+      (tv:tvs) -> return (tv, reverse tvs)+      _ -> fail "Capability must have a monadic parameter"+  let+    parametrize name = foldl1' TH.appT (TH.conT name : map tyVarBndrT extraTyVars)+    capType = parametrize capName+    classType = parametrize className+  methodSpecs <- for vbts $ \(fieldName, _, ty) -> do+    methodName <-+      case TH.nameBase fieldName of+        ('_':methodName) -> return $ TH.mkName methodName+        _ -> fail "Capability method names must start with underscores"+    tyArgList <-+      let+        toArgList (TH.ArrowT `TH.AppT` a `TH.AppT` b) = a:toArgList b+        toArgList (TH.ForallT _ _ a) = toArgList a+        toArgList _ = []+      in+        return $ toArgList ty+    return (methodName, fieldName, ty, tyArgList)+  class_decs <- (:[]) <$>+    TH.classD+      (TH.cxt [])+      className+      tyVars+      []+      [ TH.sigD methodName (return ty)+      | (methodName, _, ty, _) <- methodSpecs+      ]+  let+    methodDec methodName fieldName tyArgList = do+      TH.funD methodName+        [do+          argNames <- do+            for (zip [0..] tyArgList) $ \(i, _tyArg) ->+              TH.newName ("arg" ++ show (i::Int))+          let+            pats = map TH.varP argNames+            args = map TH.varE argNames+            body = TH.normalB $ do+              lamName <- TH.newName "cap"+              TH.appE (TH.appTypeE [e|withCap|] capType) $+                TH.lam1E (TH.varP lamName) $+                  foldl1' TH.appE (TH.varE fieldName : TH.varE lamName : args)+          TH.clause pats body []+        ]+  instance_decs <- (:[]) <$> do+    rVar <- TH.newName "r"+    capsVar <- TH.newName "caps"+    let typeableConstraints = [ [t|Typeable $(tyVarBndrT v)|] | v <- extraTyVars ]+    TH.instanceD+      (TH.cxt $+        [ [t|HasCap $capType $(TH.varT capsVar)|],+          [t| $(TH.varT rVar) ~ Capabilities $(TH.varT capsVar) $(tyVarBndrT' mVar) |]+        ] ++ typeableConstraints)+      [t| $classType (ReaderT $(TH.varT rVar) $(tyVarBndrT' mVar)) |]+      [ methodDec methodName fieldName tyArgList+      | (methodName, fieldName, _, tyArgList) <- methodSpecs+      ]+  return (class_decs ++ instance_decs)+  where+    tyVarBndrT (TH.PlainTV name) = TH.varT name+    tyVarBndrT (TH.KindedTV name k) = TH.sigT (TH.varT name) k++    tyVarBndrT' (TH.PlainTV name) = TH.varT name+    tyVarBndrT' (TH.KindedTV name _) = TH.varT name
+ test/TestExamples.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE DataKinds, TypeFamilies, RankNTypes, UndecidableInstances,+             MultiParamTypeClasses, FlexibleInstances, TypeApplications,+             AllowAmbiguousTypes, ScopedTypeVariables, TemplateHaskell #-}++{-# OPTIONS -ddump-splices #-}++module Main where++import Test.Tasty+import Test.Tasty.HUnit++import Control.Monad.Reader+import Monad.Capabilities++-------- Effect declarations ----------++data Logging msg m = Logging+  { _logError :: msg -> m (),+    _logWarning :: msg -> m ()+  }++makeCap ''Logging++data DB k v m = DB+  { _dbGet :: k -> m v,+    _dbPut :: k -> v -> m (),+    _dbWithLock :: forall a. (String -> m a) -> m a+  }++makeCap ''DB++-------- Effect implementations ----------++loggingDummy :: forall msg m. Monad m => CapImpl (Logging msg) '[] m+loggingDummy = CapImpl $ Logging+  { _logError = \_ -> return (),+    _logWarning = \_ -> return ()+  }++loggingIO :: MonadIO m => CapImpl (Logging String) '[Logging String] m+loggingIO = CapImpl $ Logging+  { _logError = liftIO . putStrLn,+    _logWarning = logError -- recursive use of capabilities!+  }++dbDummy :: Monad m => CapImpl (DB String Integer) '[Logging String] m+dbDummy = CapImpl $ DB+  { _dbGet = \key -> do logWarning ("get " ++ key); return 0,+    _dbPut = \key value -> do logWarning ("put " ++ key ++ " " ++ show value); return (),+    _dbWithLock = \m -> m "lock"+  }++-------- Test implementations ----------++testLoggingOverride :: TestTree+testLoggingOverride = testCase "logging override" $ do+  let+    caps = buildCaps $+      AddCap loggingIO $ -- try commenting out this line,+                         -- you get a nice error message+      -- AddCap loggingDummy $ -- try uncommenting this line,+                               -- you get a nice error message+      AddCap dbDummy $+      BaseCaps emptyCaps+  flip runReaderT caps $ do+    v :: Integer <- dbGet "k" -- will have log output+    withReaderT (overrideCap @(Logging String) loggingDummy) $ do+      dbPut "k2" v -- will not have log output+  -- I KNOW THIS IS NOT A PROPER UNIT TEST :)+  -- Check the output in the console manually for now.++testAddingDb :: TestTree+testAddingDb = testCase "adding db" $ do+  let+    caps = buildCaps $+      AddCap loggingIO $+      BaseCaps emptyCaps+  flip runReaderT caps $ do+    -- can't have DB access here+    withReaderT (insertCap dbDummy) $ do+      -- have DB access here+      dbPut "k" (42 :: Integer)+  -- I KNOW THIS IS NOT A PROPER UNIT TEST :)+  -- Check the output in the console manually for now.+++-------- Test tree and Main ----------++main :: IO ()+main = do+  defaultMain suite++suite :: TestTree+suite = testGroup "Capabilities"+  [ testLoggingOverride,+    testAddingDb+  ]