can-i-haz 0.1.0.1 → 0.2.0.0

raw patch · 9 files changed

+259/−39 lines, 9 filesdep +HUnitdep −should-not-typecheckPVP ok

version bump matches the API change (PVP)

Dependencies added: HUnit

Dependencies removed: should-not-typecheck

API changes (from Hackage documentation)

Files

• ChangeLog.md +4/−0
• README.md +12/−0
• can-i-haz.cabal +7/−5
• src/Control/Monad/Except/CoHas.hs +129/−0
• src/Control/Monad/Reader/Has.hs +22/−14
• src/Data/Path.hs +12/−0
• test/Common.hs +6/−0
• test/Spec.hs +57/−19
• test/TypecheckFailures.hs +10/−1

@@ -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.

@@ -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]:        <https://travis-ci.org/0xd34df00d/can-i-haz> [travis-badge]:  <https://travis-ci.org/0xd34df00d/can-i-haz.svg?branch=master>

@@ -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 <https://github.com/0xd34df00d/can-i-haz#readme> 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

@@ -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)

@@ -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

@@ -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

@@ -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)

@@ -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

@@ -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