diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Changelog for can-i-haz +## 0.2.0.0 + +* Added `CoHas` class (dual to `Has`), allowing injecting values into sum types. + ## 0.1.0.1 * Added documentation. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -50,9 +50,21 @@ ``` and use `ask extract` instead of `ask` (but this is something you'd have to do anyway). +## Reversing the arrows: `CoHas` + +There is a dual (but arguably less frequent) problem of combining different parts of an application +living in different `MonadError` environments. +The duality is due to us now wanting to _inject_ values of a type _into_ a "wider" _sum_ type +(as opposed to _projecting_ values _out_ of some _product_ type). +The `CoHas` class serves exactly this purpose. + ## Documentation Perhaps the best source is the [Haddock docs](http://hackage.haskell.org/package/can-i-haz/docs/Control-Monad-Reader-Has.html). + +## Acknowledgements + +Thanks lyxia @ #haskell for the type families-based derivation of the `GHas` instance. [travis]: [travis-badge]: diff --git a/can-i-haz.cabal b/can-i-haz.cabal --- a/can-i-haz.cabal +++ b/can-i-haz.cabal @@ -4,11 +4,11 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 1b0fd0317bcbd2ea753912693f9779a96e7743d0610d5c3c77e30e0206b23b70 +-- hash: f095662cefa6570b0b71e77b9752c4419c6e4597b04918e7a0671690c9efb5c4 name: can-i-haz -version: 0.1.0.1 -synopsis: Generic implementation of the Has pattern +version: 0.2.0.0 +synopsis: Generic implementation of the Has and CoHas patterns description: Please see the README on GitHub at category: Control homepage: https://github.com/0xd34df00d/can-i-haz#readme @@ -29,7 +29,9 @@ library exposed-modules: + Control.Monad.Except.CoHas Control.Monad.Reader.Has + Data.Path other-modules: Paths_can_i_haz hs-source-dirs: @@ -50,9 +52,9 @@ test ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N build-depends: - base >=4.7 && <5 + HUnit + , base >=4.7 && <5 , can-i-haz , deepseq , hspec - , should-not-typecheck default-language: Haskell2010 diff --git a/src/Control/Monad/Except/CoHas.hs b/src/Control/Monad/Except/CoHas.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Except/CoHas.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE TypeOperators, DataKinds, PolyKinds, TypeFamilies, ConstraintKinds #-} +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables, DefaultSignatures #-} +{-# LANGUAGE Safe #-} + +{-| +Description: Generic implementation of the CoHas injection pattern (dual to Has) +Stability: experimental + +This module defines a class 'CoHas' intended to be used with the 'Control.Monad.Except.MonadError' class +(and similar ones) or 'Control.Monad.Except.Except'/'Control.Monad.ExceptT' types. + += The problem + +Assume there are several types representing the possible errors in different parts of an application: + +@ +data DbError = ... +data WebUIError = ... +@ + +as well as a single sum type containing all of those: + +@ +data AppError + = AppDbError DbError + | AppWebUIError WebUIError +@ + +What should be the @MonadError@ constraint of the DB module and web module respectively? + +1. It could be @MonadError AppError m@ for both, introducing unnecessary coupling. + +2. Or it could be @MonadError DbError m@ for the DB module and + @MonadError WebError m@ for the web module respectively, but combining them becomes a pain. + +Or, it could be @MonadError e m, CoHas AppError e@ for the DB module (and similarly for the web module), +where some appropriately defined @CoHas option sum@ class allows injecting @option@ +creating a value of the @sum@ type. +This approach keeps both modules decoupled, while allowing using them in the same monad stack. + +The only downside is that now one has to define the @CoHas@ class +and write tedious instances for the @AppError@ type (and potentially other types in case of, for example, tests). + +But why bother doing the work that the machine will happily do for you? + += The solution + +This module defines the generic 'CoHas' class as well as hides all the boilerplate behind "GHC.Generics", +so all you have to do is to add the corresponding @deriving@-clause: + +@ +data AppError + = AppDbError DbError + | AppWebUIError WebUIError + deriving (Generic, CoHas DbError, CoHas WebUIError) +@ + +and use @throwError . inject@ instead of @throwError@ (but this is something you'd have to do anyway). + += Type safety + +What should happen if @sum@ does not have any way to construct it from @option@ at all? +Of course, this means that we cannot inject @option@ into @sum@, and no 'CoHas' instance can be derived at all. +Indeed, this library will refuse to generate an instance in this case. + +On the other hand, what should happen if @sum@ contains multiple values of type @option@ +(like @Either option option@), perhaps on different levels of nesting? +While technically we could make an arbitrary choice, like taking the first one in breadth-first or depth-first order, +we instead decide that such a choice is inherently ambiguous, +so this library will refuse to generate an instance in this case as well. + +-} + +module Control.Monad.Except.CoHas +( CoHas(..) +, SuccessfulSearch +) where + +import Data.Proxy +import GHC.Generics + +import Data.Path + +type family Search option (g :: k -> *) :: MaybePath where + Search option (K1 _ option) = 'Found 'Here + Search option (K1 _ other) = 'NotFound + Search option (M1 _ _ x) = Search option x + Search option (f :+: g) = Combine (Search option f) (Search option g) + Search _ _ = 'NotFound + +class GCoHas (path :: Path) option gsum where + ginject :: Proxy path -> option -> gsum p + +instance GCoHas 'Here rec (K1 i rec) where + ginject _ = K1 + +instance GCoHas path option sum => GCoHas path option (M1 i t sum) where + ginject proxy = M1 . ginject proxy + +instance GCoHas path option l => GCoHas ('L path) option (l :+: r) where + ginject _ = L1 . ginject (Proxy :: Proxy path) + +instance GCoHas path option r => GCoHas ('R path) option (l :+: r) where + ginject _ = R1 . ginject (Proxy :: Proxy path) + +-- | Type alias representing that the search of @option@ in @sum@ has been successful. +-- +-- The @path@ is used to guide the default generic implementation of 'CoHas'. +type SuccessfulSearch option sum path = (Search option (Rep sum) ~ 'Found path, GCoHas path option (Rep sum)) + +-- | The @CoHas option sum@ class is used for sum types that could be created from a value of type @option@. +class CoHas option sum where + -- | Inject an @option@ into the @sum@ type. + -- + -- The default implementation searches @sum@ for some constructor + -- that's compatible with @option@ (potentially recursively) and creates @sum@ using that constructor. + -- The default implementation typechecks if and only if there is a single matching constructor. + inject :: option -> sum + + default inject :: forall path. (Generic sum, SuccessfulSearch option sum path) => option -> sum + inject = to . ginject (Proxy :: Proxy path) + +-- | Each type can be injected into itself (and that is an 'id' injection). +instance CoHas sum sum where + inject = id + +instance SuccessfulSearch l (Either l r) path => CoHas l (Either l r) +instance SuccessfulSearch r (Either l r) path => CoHas r (Either l r) diff --git a/src/Control/Monad/Reader/Has.hs b/src/Control/Monad/Reader/Has.hs --- a/src/Control/Monad/Reader/Has.hs +++ b/src/Control/Monad/Reader/Has.hs @@ -2,7 +2,6 @@ {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables, DefaultSignatures #-} {-# LANGUAGE Safe #-} -{-# OPTIONS_HADDOCK show-extensions #-} {-| Description : Generic implementation of the Has pattern @@ -14,7 +13,7 @@ = The problem Assume there are two types representing the 'Control.Monad.Reader.MonadReader' environments -for different parts of an app: +for different parts of an application: @ data DbConfig = DbConfig { .. } @@ -42,7 +41,7 @@ This approach keeps both modules decoupled, while allowing using them in the same monad stack. The only downside is that now one has to define the @Has@ class and write tediuos instances for the @AppEnv@ type -(and potentially other types in case of tests). +(and potentially other types in case of, for example, tests). But why bother doing the work that the machine will happily do for you? @@ -60,16 +59,32 @@ and use @ask extract@ instead of @ask@ (but this is something you'd have to do anyway). +Note that this 'Generic'-based implementation walks the types recursively, +so it's totally possible to derive 'Has' for some nested type, for example: + +@ +data DbConfig = DbConfig + { connInfo :: ConnInfo + , retriesPolicy :: RetriesPolicy + } +data WebConfig = WebConfig { .. } + +data AppEnv = AppEnv + { dbConfig :: DbConfig + , webConfig :: WebConfig + } deriving (Generic, Has DbConfig, Has WebConfig, Has ConnInfo, Has RetriesPolicy) +@ + = Type safety What should happen if @record@ does not have any field of type @part@ at all? Of course, this means that we cannot project @part@ out of @record@, and no 'Has' instance can be derived at all. -Indeed, this library will fail to generate an instance in this case. +Indeed, this library will refuse to generate an instance in this case. On the other hand, what should happen if @record@ contains multiple values of type @part@, perhaps on different levels of nesting? While technically we could make an arbitrary choice, like taking the first one in breadth-first or depth-first order, we instead decide that such a choice is inherently ambiguous, -so this library will fail to generate an instance in this case as well. +so this library will refuse to generate an instance in this case as well. -} @@ -81,14 +96,7 @@ import Data.Proxy import GHC.Generics -data Path = L Path | R Path | Here deriving (Show) -data MaybePath = NotFound | Conflict | Found Path deriving (Show) - -type family Combine p1 p2 where - Combine ('Found path) 'NotFound = 'Found ('L path) - Combine 'NotFound ('Found path) = 'Found ('R path) - Combine 'NotFound 'NotFound = 'NotFound - Combine _ _ = 'Conflict +import Data.Path type family Search part (g :: k -> *) :: MaybePath where Search part (K1 _ part) = 'Found 'Here @@ -103,7 +111,7 @@ instance GHas 'Here rec (K1 i rec) where gextract _ (K1 x) = x -instance GHas path part struct => GHas path part (M1 i t struct) where +instance GHas path part record => GHas path part (M1 i t record) where gextract proxy (M1 x) = gextract proxy x instance GHas path part l => GHas ('L path) part (l :*: r) where diff --git a/src/Data/Path.hs b/src/Data/Path.hs new file mode 100644 --- /dev/null +++ b/src/Data/Path.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE DataKinds, TypeFamilies #-} + +module Data.Path where + +data Path = L Path | R Path | Here deriving (Show) +data MaybePath = NotFound | Conflict | Found Path deriving (Show) + +type family Combine p1 p2 where + Combine ('Found path) 'NotFound = 'Found ('L path) + Combine 'NotFound ('Found path) = 'Found ('R path) + Combine 'NotFound 'NotFound = 'NotFound + Combine _ _ = 'Conflict diff --git a/test/Common.hs b/test/Common.hs --- a/test/Common.hs +++ b/test/Common.hs @@ -1,10 +1,12 @@ {-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} +{-# LANGUAGE Strict #-} module Common where import Control.DeepSeq import GHC.Generics +import Control.Monad.Except.CoHas import Control.Monad.Reader.Has data FooEnv = FooEnv @@ -21,3 +23,7 @@ { fooEnv :: FooEnv , barEnv :: BarEnv } deriving (Eq, Ord, Show, Generic, NFData, Has FooEnv, Has BarEnv) + +data AppErr = FooEnvErr FooEnv + | BarEnvErr BarEnv + deriving (Eq, Ord, Show, Generic, NFData, CoHas FooEnv, CoHas BarEnv) diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,30 +1,68 @@ +{-# LANGUAGE MultiParamTypeClasses, RankNTypes, GADTs #-} + import Test.Hspec -import Test.ShouldNotTypecheck +import Test.HUnit.Lang +import Control.DeepSeq +import Control.Exception +import Data.List + +import Control.Monad.Except.CoHas import Control.Monad.Reader.Has import Common import TypecheckFailures +-- Reimplementing due to https://github.com/CRogers/should-not-typecheck/issues/18 +shouldNotTypecheck :: NFData a => (() ~ () => a) -> Assertion +shouldNotTypecheck a = do + result <- try (evaluate $ force a) + case result of + Right _ -> assertFailure "Expected expression to not compile but it did compile" + Left e@(TypeError msg) -> case isSuffixOf "(deferred type error)" msg of + True -> return () + False -> throwIO e + main :: IO () main = hspec $ do let baseFooEnv = FooEnv 10 "meh" let baseBarEnv = BarEnv 4.2 [1, 2, 3] - describe "Basic Has instance" $ - it "any type Has itself" $ do - let exFoo = extract baseFooEnv - exFoo `shouldBe` baseFooEnv - describe "Generic Has instances" $ do - it "envs have their components" $ do - let exFoo = extract $ AppEnv baseFooEnv baseBarEnv - exFoo `shouldBe` baseFooEnv - let exBar = extract $ AppEnv baseFooEnv baseBarEnv - exBar `shouldBe` baseBarEnv - it "tuples have their components" $ do - let exFoo = extract (baseFooEnv, baseBarEnv) - exFoo `shouldBe` baseFooEnv - let exBar = extract (baseFooEnv, baseBarEnv) - exBar `shouldBe` baseBarEnv - describe "Should not typecheck" $ do - it "if there is no such type in the hierarchy" $ shouldNotTypecheck extractMissing - it "if there is more than one such type in the hierarchy" $ shouldNotTypecheck extractMultiple + describe "Has" $ do + describe "Basic instance" $ + it "any type Has itself" $ do + let exFoo = extract baseFooEnv + exFoo `shouldBe` baseFooEnv + describe "Generic instances" $ do + it "envs have their components" $ do + let exFoo = extract $ AppEnv baseFooEnv baseBarEnv + exFoo `shouldBe` baseFooEnv + let exBar = extract $ AppEnv baseFooEnv baseBarEnv + exBar `shouldBe` baseBarEnv + it "tuples have their components" $ do + let exFoo = extract (baseFooEnv, baseBarEnv) + exFoo `shouldBe` baseFooEnv + let exBar = extract (baseFooEnv, baseBarEnv) + exBar `shouldBe` baseBarEnv + describe "Should not typecheck" $ do + it "if there is no such type in the hierarchy" $ shouldNotTypecheck extractMissing + it "if there is more than one such type in the hierarchy" $ shouldNotTypecheck extractMultiple + describe "CoHas" $ do + describe "Basic instance" $ + it "any type CoHas itself" $ do + let injected = 10 :: Int + let inFoo = inject injected + inFoo `shouldBe` injected + describe "Generic instances" $ do + it "sums have their components" $ do + let inFoo = inject baseFooEnv + inFoo `shouldBe` FooEnvErr baseFooEnv + let inBar = inject baseBarEnv + inBar `shouldBe` BarEnvErr baseBarEnv + it "Either has its components" $ do + let inFoo = inject baseFooEnv :: Either FooEnv Int + inFoo `shouldBe` Left baseFooEnv + let inBar = inject baseBarEnv :: Either Int BarEnv + inBar `shouldBe` Right baseBarEnv + describe "Should not typecheck" $ do + it "if there is no such type in the hierarchy" $ shouldNotTypecheck injectMissing + it "if there is more than one such type in the hierarchy" $ shouldNotTypecheck injectMultiple diff --git a/test/TypecheckFailures.hs b/test/TypecheckFailures.hs --- a/test/TypecheckFailures.hs +++ b/test/TypecheckFailures.hs @@ -3,14 +3,23 @@ module TypecheckFailures where +import Control.Monad.Except.CoHas import Control.Monad.Reader.Has import Common -instance Has FooEnv BarEnv +instance Has BarEnv FooEnv extractMissing :: FooEnv -> BarEnv extractMissing = extract extractMultiple :: (FooEnv, FooEnv) -> FooEnv extractMultiple = extract + +instance CoHas FooEnv BarEnv + +injectMissing :: FooEnv -> BarEnv +injectMissing = inject + +injectMultiple :: FooEnv -> Either FooEnv FooEnv +injectMultiple = inject