├── .github └── workflows │ └── ci.yml ├── .gitignore ├── LICENSE ├── Setup.hs ├── caps.cabal ├── shell.nix ├── src └── Monad │ └── Capabilities.hs └── test └── TestExamples.hs /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: 4 | pull_request: 5 | push: 6 | branches: [ master ] 7 | 8 | jobs: 9 | cabal-build: 10 | strategy: 11 | matrix: 12 | ghc-version: 13 | - "8.4.4" 14 | - "8.6.5" 15 | - "8.8.4" 16 | - "8.10.4" 17 | - "9.0.2" 18 | runs-on: ubuntu-latest 19 | steps: 20 | - uses: actions/checkout@v2 21 | - uses: haskell/actions/setup@v1 22 | with: 23 | cabal-version: "3.4" 24 | ghc-version: ${{ matrix.ghc-version }} 25 | - name: Cache 26 | uses: actions/cache@v1 27 | with: 28 | path: ~/.cabal 29 | key: ${{ runner.os }}-${{ matrix.ghc-version }} 30 | - name: Install dependencies 31 | run: | 32 | cabal update 33 | cabal build --only-dependencies --enable-tests --enable-benchmarks 34 | - name: Build 35 | run: cabal build --enable-tests --enable-benchmarks all 36 | # - name: Run tests 37 | # run: cabal test all 38 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Cabal 2 | dist 3 | dist-newstyle 4 | .cabal-sandbox/ 5 | cabal.sandbox.config 6 | cabal.project.local 7 | .ghc.environment* 8 | 9 | # Profiling 10 | *.prof 11 | 12 | # Stack 13 | .stack-work 14 | 15 | # Emacs 16 | TAGS 17 | .dir-locals.el 18 | 19 | # Vim 20 | tags 21 | *.swp 22 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017, Vladislav Zavialov 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Vladislav Zavialov nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /caps.cabal: -------------------------------------------------------------------------------- 1 | name: caps 2 | version: 0.1 3 | synopsis: Monadic capabilities with late binding 4 | license: BSD3 5 | license-file: LICENSE 6 | author: Vladislav Zavialov 7 | maintainer: vlad.z.4096@gmail.com 8 | category: Control 9 | build-type: Simple 10 | cabal-version: >=1.10 11 | 12 | library 13 | exposed-modules: Monad.Capabilities 14 | build-depends: base >=4.10 && <4.16, 15 | transformers, 16 | typerep-map >=0.3, 17 | template-haskell 18 | hs-source-dirs: src 19 | default-language: Haskell2010 20 | ghc-options: -Wall 21 | -fno-warn-unticked-promoted-constructors 22 | -fno-warn-partial-type-signatures 23 | 24 | test-suite test-examples 25 | build-depends: base >=4.10 && <4.16, 26 | caps, 27 | mtl, 28 | tasty, 29 | tasty-hunit 30 | main-is: TestExamples.hs 31 | type: exitcode-stdio-1.0 32 | hs-source-dirs: test 33 | default-language: Haskell2010 34 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | # { stdenv, pkgs, haskell }: 2 | with import { }; 3 | 4 | stdenv.mkDerivation rec { 5 | name = "caps"; 6 | buildInputs = [ 7 | haskell.compiler.ghc902 8 | pkgs.cabal-install 9 | pkgs.pkgconfig 10 | ]; 11 | } 12 | -------------------------------------------------------------------------------- /src/Monad/Capabilities.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeInType, GADTs, ScopedTypeVariables, FlexibleInstances, 2 | TypeOperators, ConstraintKinds, TypeFamilies, PartialTypeSignatures, 3 | UndecidableInstances, ViewPatterns, RankNTypes, TypeApplications, 4 | MultiParamTypeClasses, UndecidableSuperClasses, TemplateHaskell, 5 | StandaloneDeriving, DerivingStrategies, GeneralizedNewtypeDeriving, CPP #-} 6 | 7 | {-| 8 | 9 | Monadic capabilities are additional methods for a base monad. For instance, when 10 | our base monad is 'IO', our capabilities might include logging, networking, 11 | database access, and so on. 12 | 13 | This framework allows mutually recursive late-bound capabilities with runtime 14 | dispatch and a type-safe interface. 15 | 16 | A capability is defined as a record type with methods parametrized over a base 17 | monad: 18 | 19 | @ 20 | data Logging m = 21 | Logging 22 | { _logError :: String -> m (), 23 | _logDebug :: String -> m () 24 | } 25 | @ 26 | 27 | We can define implementations as values of this record type: 28 | 29 | @ 30 | loggingDummy :: Monad m => CapImpl Logging '[] m 31 | loggingDummy = CapImpl $ Logging (\\_ -> return ()) (\\_ -> return ()) 32 | 33 | loggingIO :: MonadIO m => CapImpl Logging '[] m 34 | loggingIO = CapImpl $ 35 | Logging 36 | { _logError = \\msg -> liftIO . putStrLn $ "[Error] " ++ msg 37 | _logDebug = \\msg -> liftIO . putStrLn $ "[Debug] " ++ msg 38 | } 39 | @ 40 | 41 | The dictionary is wrapped in 'CapImpl' to guarantee that it is sufficiently 42 | polymorphic (this is required to support simultaneous use of monadic actions in 43 | negative position and capability extension). 44 | 45 | Then we want to use this capability in the 'CapsT' monad (which is nothing more 46 | but a synonym for 'ReaderT' of 'Capabilities'), and for this we define a helper 47 | per method: 48 | 49 | @ 50 | logError :: HasCap Logging caps => String -> CapsT caps m () 51 | logError message = withCap $ \\cap -> _logError cap message 52 | 53 | logDebug :: HasCap Logging caps => String -> CapsT caps m () 54 | logDebug message = withCap $ \\cap -> _logDebug cap message 55 | @ 56 | 57 | We can define other capabilities in a similar manner: 58 | 59 | @ 60 | data Networking m = 61 | Networking 62 | { _sendRequest :: ByteString -> m ByteString } 63 | 64 | data FileStorage m = 65 | FileStorage 66 | { _readFile :: FilePath -> m ByteString, 67 | _writeFile :: FilePath -> ByteString -> m () 68 | } 69 | @ 70 | 71 | Implementations of capabilities may depend on other capabilities, which are 72 | listed in their signature. For instance, this is how we can define the 73 | 'FileStorage' capability using the 'Logging' capability: 74 | 75 | @ 76 | fileStorageIO :: MonadIO m => CapImpl FileStorage '[Logging] m 77 | fileStorageIO = CapImpl $ 78 | FileStorage 79 | { _readFile = \\path -> do 80 | logDebug $ "readFile " ++ path 81 | lift $ ByteString.readFile path 82 | _writeFile = \\path content -> do 83 | logDebug $ 84 | "writeFile " ++ path ++ 85 | " (" ++ show (ByteString.length content) ++ 86 | " bytes)" 87 | lift $ ByteString.writeFile path content 88 | } 89 | @ 90 | 91 | Here the @fileStorageIO@ implementation requires a logging capability, 92 | but it's not specified which one. 93 | 94 | When we decided what set of capabilities our application needs, we can put them 95 | together in a 'Capabilities' map and run the application with this map in a 96 | 'ReaderT' context: 97 | 98 | @ 99 | caps = buildCaps $ 100 | AddCap loggingIO $ 101 | AddCap fileStorageIO $ 102 | BaseCaps emptyCaps 103 | 104 | flip runReaderT caps $ do 105 | config <- readFile "config.yaml" 106 | ... 107 | @ 108 | 109 | Capabilities passed to 'buildCaps' can depend on each other. The order does not 110 | matter (although it is reflected in the types), and duplicate capabilities are 111 | disallowed. 112 | 113 | We can override a capability locally: 114 | 115 | @ 116 | do 117 | config <- readFile "config.yaml" 118 | withReaderT (overrideCap loggingDummy) $ do 119 | -- logging is disabled here 120 | writeFile "config-backup.yaml" config 121 | ... 122 | @ 123 | 124 | or we can add more capabilities: 125 | 126 | @ 127 | do 128 | config <- readFile "config.yaml" 129 | networkingImpl <- parseNetworkingConfig config 130 | withReaderT (addCap networkingImpl) $ do 131 | -- networking capability added 132 | resp <- sendRequest req 133 | ... 134 | @ 135 | 136 | -} 137 | 138 | module Monad.Capabilities 139 | ( 140 | -- * Capabilities 141 | Capabilities(), 142 | CapsT, 143 | emptyCaps, 144 | buildCaps, 145 | CapabilitiesBuilder(..), 146 | CapImpl(..), 147 | getCap, 148 | overrideCap, 149 | addCap, 150 | insertCap, 151 | withCap, 152 | checkCap, 153 | adjustCap, 154 | 155 | -- * Default capabilities 156 | Context(..), 157 | HasContext, 158 | newContext, 159 | askContext, 160 | localContext, 161 | 162 | -- * Type-level checks 163 | type HasCap, 164 | type HasCaps, 165 | type HasNoCap, 166 | HasCapDecision(..), 167 | 168 | -- * Utils 169 | makeCap 170 | 171 | ) where 172 | 173 | import Control.Monad.Trans.Reader 174 | import Data.Kind (Type, Constraint) 175 | import Data.Traversable 176 | import Data.Proxy 177 | import Data.Type.Equality 178 | import Data.List (foldl1') 179 | import GHC.TypeLits (TypeError, ErrorMessage(..)) 180 | import Type.Reflection (Typeable) 181 | import Data.Coerce (coerce) 182 | import Unsafe.Coerce (unsafeCoerce) 183 | 184 | import qualified Data.TypeRepMap as TypeRepMap 185 | import Data.TypeRepMap (TypeRepMap) 186 | 187 | import qualified Language.Haskell.TH as TH 188 | 189 | type MonadK = Type -> Type 190 | 191 | type CapK = MonadK -> Type 192 | 193 | -- | @'Capabilities' caps m@ is a map of capabilities @caps@ over a base monad 194 | -- @m@. Consider the following capabilities: 195 | -- 196 | -- @ 197 | -- data X m = X (String -> m String) 198 | -- data Y m = Y (Int -> m Bool) 199 | -- @ 200 | -- 201 | -- We can construct a map of capabilities with the following type: 202 | -- 203 | -- @ 204 | -- capsXY :: Capabilities '[X, Y] IO 205 | -- @ 206 | -- 207 | -- In this case, @capsXY@ would be a map with two elements, one at key @X@ and 208 | -- one at key @Y@. The types of capabilities themselves serve as keys. 209 | -- 210 | -- 'Capabilities' is a heterogeneous collection, meaning that its values have 211 | -- different types. The type of a value is determined by the key: 212 | -- 213 | -- @ 214 | -- 215 | -- X: X (\\_ -> return "hi") :: X (CapsT '[X, Y] IO) 216 | -- Y: Y (\\_ -> return True) :: Y (CapsT '[X, Y] IO) 217 | -- ---- --------------------- -------------------- 218 | -- keys values types of values 219 | -- @ 220 | -- 221 | -- Notice that stored dictionaries are parametrized not just by the base monad 222 | -- @IO@, but with the 'CapsT' transformer on top. This means that each 223 | -- capability has access to all other capabilities and itself. 224 | -- 225 | newtype Capabilities (caps :: [CapK]) (m :: MonadK) = 226 | Capabilities (TypeRepMap (CapElem m)) 227 | 228 | emptyCaps :: Capabilities '[] m 229 | emptyCaps = Capabilities TypeRepMap.empty 230 | 231 | deriving newtype instance Show (Capabilities caps m) 232 | 233 | -- | The 'CapsT' transformer adds access to capabilities. This is a convenience 234 | -- synonym for 'ReaderT' of 'Capabilities', and all 'ReaderT' functions 235 | -- ('runReaderT', 'withReaderT') can be used with it. 236 | type CapsT caps m = ReaderT (Capabilities caps m) m 237 | 238 | -- | The 'CapImpl' newtype guarantees that the wrapped capability implementation 239 | -- is sufficiently polymorphic so that required subtyping properties hold in 240 | -- methods that take monadic actions as input (negative position). 241 | -- 242 | -- This rules out using 'addCap', 'insertCap', and 'buildCaps' inside capability 243 | -- implementations in an unsafe manner. 244 | data CapImpl cap icaps m where 245 | CapImpl :: 246 | WithSpine icaps => 247 | { getCapImpl :: forall caps. HasCaps icaps caps => cap (CapsT caps m) 248 | } -> 249 | CapImpl cap icaps m 250 | 251 | newtype CapElem m cap = 252 | CapElem { getCapElem :: forall caps. cap (CapsT caps m) } 253 | 254 | overCapElem :: 255 | (forall caps. cap (CapsT caps m) -> cap' (CapsT caps m')) -> 256 | CapElem m cap -> 257 | CapElem m' cap' 258 | overCapElem f (CapElem cap) = CapElem (f cap) 259 | 260 | -- Continuation-passing encoding of a list spine: 261 | -- 262 | -- data Spine xs where 263 | -- Cons :: Spine xs -> Spine (x : xs) 264 | -- Nil :: Spine '[] 265 | -- 266 | class WithSpine xs where 267 | onSpine :: 268 | forall r. 269 | Proxy xs -> 270 | ((xs ~ '[]) => r) -> 271 | (forall y ys. 272 | (xs ~ (y : ys)) => 273 | WithSpine ys => 274 | Proxy y -> 275 | Proxy ys -> 276 | r) -> 277 | r 278 | 279 | instance WithSpine '[] where 280 | onSpine _ onNil _ = onNil 281 | 282 | instance WithSpine xs => WithSpine (x : xs) where 283 | onSpine _ _ onCons = onCons Proxy Proxy 284 | 285 | toCapElem :: 286 | forall cap icaps m. 287 | CapImpl cap icaps m -> 288 | CapElem m cap 289 | toCapElem (CapImpl cap) = CapElem 290 | (fiatHasElems (Proxy @icaps) (Proxy @caps) cap :: forall caps. cap (CapsT caps m)) 291 | 292 | fiatHasElems :: 293 | forall icaps caps. 294 | WithSpine icaps => 295 | Proxy icaps -> 296 | Proxy caps -> 297 | forall r. (HasCaps icaps caps => r) -> r 298 | fiatHasElems Proxy Proxy r = 299 | onSpine (Proxy @icaps) 300 | -- nil 301 | r 302 | -- cons 303 | (\(Proxy :: Proxy cap) (Proxy :: Proxy icaps') -> 304 | case unsafeUnitConstr @(HasCap cap caps) of 305 | Refl -> fiatHasElems (Proxy @icaps') (Proxy @caps) r) 306 | 307 | {- 308 | 309 | Since 'caps' is phantom, we can reorder capabilities, remove non-unique 310 | capabilities, or extend them. 311 | 312 | The tricky case is extension. Assume @caps'@ subsumes @caps@, and consider each 313 | @cap n@ where @n ~ CapsT caps m@ individually. When we cast this to use @caps'@, 314 | we must know that @cap@ will continue to work correctly. 315 | 316 | 1. Assume @cap@ uses @n@ in positive position exclusively. This means that the 317 | capability defines methods that take @Capabilities caps m@ as input, and 318 | it's okay if we pass @Capabilities caps' m@ instead, as we will simply have 319 | some unnecessary input. 320 | 321 | 2. Assume @cap@ uses @n@ in a negative poistion as well. This means that the 322 | capability defines method that will be passing @Capabilities caps m@ to 323 | other monadic actions. But when we cast to @caps'@, these monadic actions 324 | require @Capabilities caps' m@, where @caps'@ subsumes @caps@, so at runtime 325 | it's possible that we don't pass all needed capabilities for them. 326 | 327 | In order for (2) to be safe, we need to place an additional requirement on 328 | capabilities which use the provided @Capabilities caps m@ in a negative position: 329 | 330 | The positive occurence of @Capabilities caps m@ must come from a value 331 | provided by an occurence of @Capabilities caps m@ in a negative position, 332 | unmodified, rather than be constructed. 333 | 334 | Essentially, we want capabilities to do only two things with @Capabilities@: 335 | 336 | * extract parts of it with 'getCap' 337 | * pass it along 338 | 339 | In this case, even when on types we put @Capabilities caps m@ in a positive 340 | position (where @caps@ might be insufficient), at runtime we know that these 341 | capabilities actually contain @caps'@. 342 | 343 | We guarantee this property by the 'CapImpl' newtype. 344 | 345 | -} 346 | 347 | -- | 'CapabilitiesBuilder' is a type to extend capabilities. 348 | -- 349 | -- The @allCaps@ parameter is a list of capabilities that will be provided to 350 | -- 'buildCaps' eventually, when the building process is done. The @caps@ 351 | -- parameter is the part of capabilities that was constructed so far. The 352 | -- builder is considered complete when @allCaps ~ caps@, only then it can be 353 | -- passed to 'buildCaps'. 354 | data CapabilitiesBuilder (allCaps :: [CapK]) (caps :: [CapK]) (m :: MonadK) where 355 | AddCap :: 356 | (Typeable cap, HasCaps icaps allCaps, HasNoCap cap caps) => 357 | CapImpl cap icaps m -> 358 | CapabilitiesBuilder allCaps caps m -> 359 | CapabilitiesBuilder allCaps (cap : caps) m 360 | BaseCaps :: 361 | Capabilities caps m -> 362 | CapabilitiesBuilder allCaps caps m 363 | 364 | -- | Build a map of capabilities from individual implementations: 365 | -- 366 | -- @ 367 | -- capsXY :: Capabilities '[X, Y] IO 368 | -- capsXY = buildCaps $ 369 | -- AddCap xImpl $ 370 | -- AddCap yImpl $ 371 | -- BaseCaps emptyCaps 372 | -- @ 373 | buildCaps :: forall caps m. CapabilitiesBuilder caps caps m -> Capabilities caps m 374 | buildCaps = Capabilities . go 375 | where 376 | go :: 377 | CapabilitiesBuilder caps caps' m -> 378 | TypeRepMap (CapElem m) 379 | go (BaseCaps (Capabilities caps)) = caps 380 | go (AddCap capImpl otherCaps) = 381 | TypeRepMap.insert (toCapElem capImpl) (go otherCaps) 382 | 383 | -- | Ensure that the @caps@ list has an element @cap@. 384 | type family HasCap cap caps :: Constraint where 385 | HasCap cap (cap : _) = () 386 | HasCap cap (cap' : caps) = HasCap cap caps 387 | HasCap cap '[] = 388 | TypeError 389 | (Text "Capability " :<>: 390 | ShowType cap :<>: 391 | Text " must be available") 392 | 393 | -- | Ensure that the @caps@ list subsumes @icaps@. It is equivalent 394 | -- to a @HasCap icap caps@ constraint for each @icap@ in @icaps@. 395 | type family HasCaps icaps caps :: Constraint where 396 | HasCaps '[] _ = () 397 | HasCaps (icap : icaps) caps = (HasCap icap caps, HasCaps icaps caps) 398 | 399 | -- | Ensure that the @caps@ list does not have an element @cap@. 400 | type family HasNoCap cap caps :: Constraint where 401 | HasNoCap cap (cap : _) = 402 | TypeError 403 | (Text "Capability " :<>: 404 | ShowType cap :<>: 405 | Text " is already present") 406 | HasNoCap cap (cap' : caps) = HasNoCap cap caps 407 | HasNoCap cap '[] = () 408 | 409 | -- | Lookup a capability in a 'Capabilities' map. The 'HasCap' constraint 410 | -- guarantees that the lookup does not fail. 411 | getCap :: forall cap m caps. (Typeable cap, HasCap cap caps) => Capabilities caps m -> cap (CapsT caps m) 412 | getCap (Capabilities m) = 413 | case TypeRepMap.lookup m of 414 | Nothing -> error "getCap: impossible" 415 | Just e -> getCapElem e 416 | 417 | -- An internal function that adds capabilities. 418 | unsafeInsertCap :: 419 | (Typeable cap, HasCaps icaps caps') => 420 | CapImpl cap icaps m -> 421 | Capabilities caps m -> 422 | Capabilities caps' m 423 | unsafeInsertCap capImpl (Capabilities caps) = 424 | Capabilities (TypeRepMap.insert (toCapElem capImpl) caps) 425 | 426 | -- | Extend the set of capabilities. In case the capability is already present, 427 | -- it will be overriden (as with 'overrideCap'), but occur twice in the type. 428 | insertCap :: 429 | (Typeable cap, HasCaps icaps (cap : caps)) => 430 | CapImpl cap icaps m -> 431 | Capabilities caps m -> 432 | Capabilities (cap : caps) m 433 | insertCap = unsafeInsertCap 434 | 435 | -- | Extend the set of capabilities. In case the capability is already present, 436 | -- a type error occurs. 437 | addCap :: 438 | (Typeable cap, HasNoCap cap caps, HasCaps icaps (cap : caps)) => 439 | CapImpl cap icaps m -> 440 | Capabilities caps m -> 441 | Capabilities (cap : caps) m 442 | addCap capImpl caps = buildCaps (AddCap capImpl $ BaseCaps caps) 443 | 444 | -- | Override the implementation of an existing capability. 445 | overrideCap :: 446 | (Typeable cap, HasCap cap caps, HasCaps icaps caps) => 447 | CapImpl cap icaps m -> 448 | Capabilities caps m -> 449 | Capabilities caps m 450 | overrideCap = unsafeInsertCap 451 | 452 | -- | Override the implementation of an existing capability using the previous 453 | -- implementation. This is a more efficient equivalent to extracting a 454 | -- capability with 'getCap', adjusting it with a function, and putting it back 455 | -- with 'overrideCap'. 456 | adjustCap :: 457 | forall cap caps m. 458 | (Typeable cap, HasCap cap caps) => 459 | (forall caps'. cap (CapsT caps' m) -> cap (CapsT caps' m)) -> 460 | Capabilities caps m -> 461 | Capabilities caps m 462 | adjustCap f (Capabilities caps) = 463 | Capabilities (TypeRepMap.adjust (overCapElem f) caps) 464 | 465 | -- | Extract a capability from 'CapsT' and provide it to a continuation. 466 | withCap :: (Typeable cap, HasCap cap caps) => (cap (CapsT caps m) -> CapsT caps m a) -> CapsT caps m a 467 | withCap cont = ReaderT $ \caps -> runReaderT (cont (getCap caps)) caps 468 | 469 | -- | Evidence that @cap@ is present or absent in @caps@. 470 | data HasCapDecision cap caps where 471 | HasNoCap :: HasNoCap cap caps => HasCapDecision cap caps 472 | HasCap :: HasCap cap caps => HasCapDecision cap caps 473 | 474 | instance Show (HasCapDecision cap caps) where 475 | show HasNoCap = "HasNoCap" 476 | show HasCap = "HasCap" 477 | 478 | -- | Determine at runtime whether 'HasCap cap caps' or 'HasNoCap cap caps' holds. 479 | checkCap :: forall cap caps m. Typeable cap => Capabilities caps m -> HasCapDecision cap caps 480 | checkCap (Capabilities m) = 481 | if TypeRepMap.member @cap m 482 | then case unsafeUnitConstr @(HasCap cap caps) of Refl -> HasCap 483 | else case unsafeUnitConstr @(HasNoCap cap caps) of Refl -> HasNoCap 484 | 485 | -- Use to construct 'HasCap' or 'HasNoCap'. 486 | unsafeUnitConstr :: c :~: (() :: Constraint) 487 | unsafeUnitConstr = unsafeCoerce Refl 488 | 489 | -- | The 'Context' capability is used to model the @Reader@ effect within the 490 | -- capabilities framework. 491 | newtype Context x (m :: MonadK) = Context x 492 | 493 | -- | The 'HasContext' constraint is a shorthand for 'HasCap' of 'Context'. 494 | class (Typeable x, HasCap (Context x) caps) => HasContext x caps 495 | instance (Typeable x, HasCap (Context x) caps) => HasContext x caps 496 | 497 | -- | Initialize a 'Context' capability. 498 | newContext :: forall x m. x -> CapImpl (Context x) '[] m 499 | newContext x = CapImpl (Context x) 500 | 501 | -- | Retrieve the context value. Moral equivalent of 'ask'. 502 | askContext :: (HasContext x caps, Applicative m) => CapsT caps m x 503 | askContext = withCap (\(Context x) -> pure x) 504 | 505 | -- | Execute a computation with a modified context value. Moral equivalent of 'local'. 506 | localContext :: forall x caps m a. (HasContext x caps) => (x -> x) -> CapsT caps m a -> CapsT caps m a 507 | localContext f = local (adjustCap @(Context x) (coerce f)) 508 | 509 | makeCap :: TH.Name -> TH.DecsQ 510 | makeCap capName = do 511 | let className = TH.mkName ("Monad" ++ TH.nameBase capName) 512 | info <- TH.reify capName 513 | (vbts, tyVars) <- 514 | case info of 515 | TH.TyConI (TH.DataD _ _ tyVars _ [TH.RecC _ vbts] _) -> return (vbts, tyVars) 516 | TH.TyConI (TH.NewtypeD _ _ tyVars _ (TH.RecC _ vbts) _) -> return (vbts, tyVars) 517 | _ -> fail "Capabilities must be single-constructor record types" 518 | (mVar, extraTyVars) <- 519 | case reverse tyVars of 520 | (tv:tvs) -> return (tv, reverse tvs) 521 | _ -> fail "Capability must have a monadic parameter" 522 | let 523 | parametrize name = foldl1' TH.appT (TH.conT name : map tyVarBndrT extraTyVars) 524 | capType = parametrize capName 525 | classType = parametrize className 526 | methodSpecs <- for vbts $ \(fieldName, _, ty) -> do 527 | methodName <- 528 | case TH.nameBase fieldName of 529 | ('_':methodName) -> return $ TH.mkName methodName 530 | _ -> fail "Capability method names must start with underscores" 531 | tyArgList <- 532 | let 533 | toArgList (TH.ArrowT `TH.AppT` a `TH.AppT` b) = a:toArgList b 534 | toArgList (TH.ForallT _ _ a) = toArgList a 535 | toArgList _ = [] 536 | in 537 | return $ toArgList ty 538 | return (methodName, fieldName, ty, tyArgList) 539 | class_decs <- (:[]) <$> 540 | TH.classD 541 | (TH.cxt []) 542 | className 543 | tyVars 544 | [] 545 | [ TH.sigD methodName (return ty) 546 | | (methodName, _, ty, _) <- methodSpecs 547 | ] 548 | let 549 | methodDec methodName fieldName tyArgList = do 550 | TH.funD methodName 551 | [do 552 | argNames <- do 553 | for (zip [0..] tyArgList) $ \(i, _tyArg) -> 554 | TH.newName ("arg" ++ show (i::Int)) 555 | let 556 | pats = map TH.varP argNames 557 | args = map TH.varE argNames 558 | body = TH.normalB $ do 559 | lamName <- TH.newName "cap" 560 | TH.appE (TH.appTypeE [e|withCap|] capType) $ 561 | TH.lam1E (TH.varP lamName) $ 562 | foldl1' TH.appE (TH.varE fieldName : TH.varE lamName : args) 563 | TH.clause pats body [] 564 | ] 565 | instance_decs <- (:[]) <$> do 566 | rVar <- TH.newName "r" 567 | capsVar <- TH.newName "caps" 568 | let typeableConstraints = [ [t|Typeable $(tyVarBndrT v)|] | v <- extraTyVars ] 569 | TH.instanceD 570 | (TH.cxt $ 571 | [ [t|HasCap $capType $(TH.varT capsVar)|], 572 | [t| $(TH.varT rVar) ~ Capabilities $(TH.varT capsVar) $(tyVarBndrT' mVar) |] 573 | ] ++ typeableConstraints) 574 | [t| $classType (ReaderT $(TH.varT rVar) $(tyVarBndrT' mVar)) |] 575 | [ methodDec methodName fieldName tyArgList 576 | | (methodName, fieldName, _, tyArgList) <- methodSpecs 577 | ] 578 | return (class_decs ++ instance_decs) 579 | where 580 | #if MIN_VERSION_base(4, 15, 1) 581 | tyVarBndrT (TH.PlainTV name _) = TH.varT name 582 | tyVarBndrT (TH.KindedTV name _ k) = TH.sigT (TH.varT name) k 583 | 584 | tyVarBndrT' (TH.PlainTV name _) = TH.varT name 585 | tyVarBndrT' (TH.KindedTV name _ _) = TH.varT name 586 | #else 587 | tyVarBndrT (TH.PlainTV name) = TH.varT name 588 | tyVarBndrT (TH.KindedTV name k) = TH.sigT (TH.varT name) k 589 | 590 | tyVarBndrT' (TH.PlainTV name) = TH.varT name 591 | tyVarBndrT' (TH.KindedTV name _) = TH.varT name 592 | #endif 593 | -------------------------------------------------------------------------------- /test/TestExamples.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, TypeFamilies, RankNTypes, UndecidableInstances, 2 | MultiParamTypeClasses, FlexibleInstances, TypeApplications, 3 | AllowAmbiguousTypes, ScopedTypeVariables, TemplateHaskell #-} 4 | 5 | {-# OPTIONS -ddump-splices #-} 6 | 7 | module Main where 8 | 9 | import Test.Tasty 10 | import Test.Tasty.HUnit 11 | 12 | import Control.Monad.Reader 13 | import Monad.Capabilities 14 | 15 | -------- Effect declarations ---------- 16 | 17 | data Logging msg m = Logging 18 | { _logError :: msg -> m (), 19 | _logWarning :: msg -> m () 20 | } 21 | 22 | makeCap ''Logging 23 | 24 | data DB k v m = DB 25 | { _dbGet :: k -> m v, 26 | _dbPut :: k -> v -> m (), 27 | _dbWithLock :: forall a. (String -> m a) -> m a 28 | } 29 | 30 | makeCap ''DB 31 | 32 | -------- Effect implementations ---------- 33 | 34 | loggingDummy :: forall msg m. Monad m => CapImpl (Logging msg) '[] m 35 | loggingDummy = CapImpl $ Logging 36 | { _logError = \_ -> return (), 37 | _logWarning = \_ -> return () 38 | } 39 | 40 | loggingIO :: MonadIO m => CapImpl (Logging String) '[Logging String] m 41 | loggingIO = CapImpl $ Logging 42 | { _logError = liftIO . putStrLn, 43 | _logWarning = logError -- recursive use of capabilities! 44 | } 45 | 46 | dbDummy :: Monad m => CapImpl (DB String Integer) '[Logging String] m 47 | dbDummy = CapImpl $ DB 48 | { _dbGet = \key -> do logWarning ("get " ++ key); return 0, 49 | _dbPut = \key value -> do logWarning ("put " ++ key ++ " " ++ show value); return (), 50 | _dbWithLock = \m -> m "lock" 51 | } 52 | 53 | -------- Test implementations ---------- 54 | 55 | testLoggingOverride :: TestTree 56 | testLoggingOverride = testCase "logging override" $ do 57 | let 58 | caps = buildCaps $ 59 | AddCap loggingIO $ -- try commenting out this line, 60 | -- you get a nice error message 61 | -- AddCap loggingDummy $ -- try uncommenting this line, 62 | -- you get a nice error message 63 | AddCap dbDummy $ 64 | BaseCaps emptyCaps 65 | flip runReaderT caps $ do 66 | v :: Integer <- dbGet "k" -- will have log output 67 | withReaderT (overrideCap @(Logging String) loggingDummy) $ do 68 | dbPut "k2" v -- will not have log output 69 | -- I KNOW THIS IS NOT A PROPER UNIT TEST :) 70 | -- Check the output in the console manually for now. 71 | 72 | testAddingDb :: TestTree 73 | testAddingDb = testCase "adding db" $ do 74 | let 75 | caps = buildCaps $ 76 | AddCap loggingIO $ 77 | BaseCaps emptyCaps 78 | flip runReaderT caps $ do 79 | -- can't have DB access here 80 | withReaderT (insertCap dbDummy) $ do 81 | -- have DB access here 82 | dbPut "k" (42 :: Integer) 83 | -- I KNOW THIS IS NOT A PROPER UNIT TEST :) 84 | -- Check the output in the console manually for now. 85 | 86 | 87 | -------- Test tree and Main ---------- 88 | 89 | main :: IO () 90 | main = do 91 | defaultMain suite 92 | 93 | suite :: TestTree 94 | suite = testGroup "Capabilities" 95 | [ testLoggingOverride, 96 | testAddingDb 97 | ] 98 | --------------------------------------------------------------------------------