diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,10 @@ # Changelog for can-i-haz +## 0.2.1.0 + +* Added the `update` method to `Has` (yay lenses). +* Fixed the documentation regarding the recursiveness of the search. + ## 0.2.0.1 * Less boilerplate for `Has` tuple instances and `CoHas` `Either` instance. diff --git a/can-i-haz.cabal b/can-i-haz.cabal --- a/can-i-haz.cabal +++ b/can-i-haz.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 0394d90d99b920a658070f87d57d6cd3df94ee5b5af1d08be8b70136c4888334 +-- hash: 92db1c8cf04877be4feda903d215b85919cb662aadcc285eb2f2e6e05f660886 name: can-i-haz -version: 0.2.0.1 +version: 0.2.1.0 synopsis: Generic implementation of the Has and CoHas patterns description: Please see the README on GitHub at category: Control diff --git a/src/Control/Monad/Except/CoHas.hs b/src/Control/Monad/Except/CoHas.hs --- a/src/Control/Monad/Except/CoHas.hs +++ b/src/Control/Monad/Except/CoHas.hs @@ -114,8 +114,8 @@ -- | 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. + -- that's compatible with @option@ and creates @sum@ using that constructor. + -- The default implementation typechecks iff there is a single matching constructor. inject :: option -> sum default inject :: forall path. (Generic sum, SuccessfulSearch option sum path) => option -> sum 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 @@ -59,22 +59,6 @@ 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? @@ -86,6 +70,18 @@ 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. += Updating the records, or poor man's lenses, and State + +One we know that a value of type @part@ is contained in @record@, +we might easily update a @record@ having a function that updates the @part@. +This is done in the obvious way: we just locate the @part@ in the @record@ and 'update' it! + +'Has' has a method for this, called (unsurprisingly) 'update'. + +Note that this might be used for more composable functions living in 'Control.Monad.State': +now instead of @MonadState StateType m@ we write @(MonadState s m, Has StateType s)@ +and use 'update' and 'extract' where necessary (likely in combination with 'modify' and 'gets'). + -} module Control.Monad.Reader.Has @@ -107,18 +103,23 @@ class GHas (path :: Path) part grecord where gextract :: Proxy path -> grecord p -> part + gupdate :: Proxy path -> (part -> part) -> grecord p -> grecord p instance GHas 'Here rec (K1 i rec) where gextract _ (K1 x) = x + gupdate _ f (K1 x) = K1 $ f x instance GHas path part record => GHas path part (M1 i t record) where gextract proxy (M1 x) = gextract proxy x + gupdate proxy f (M1 x) = M1 (gupdate proxy f x) instance GHas path part l => GHas ('L path) part (l :*: r) where gextract _ (l :*: _) = gextract (Proxy :: Proxy path) l + gupdate _ f (l :*: r) = gupdate (Proxy :: Proxy path) f l :*: r instance GHas path part r => GHas ('R path) part (l :*: r) where gextract _ (_ :*: r) = gextract (Proxy :: Proxy path) r + gupdate _ f (l :*: r) = l :*: gupdate (Proxy :: Proxy path) f r -- | Type alias representing that the search of @part@ in @record@ has been successful. -- @@ -130,17 +131,28 @@ class Has part record where -- | Extract a subvalue of type @part@ from the @record@. -- - -- The default implementation searches for some value of the type @part@ in @record@ (potentially recursively) - -- and returns that value. The default implementation typechecks if and only if - -- there is a single subvalue of type @part@ in @record@. + -- The default implementation searches for some value of the type @part@ in @record@ + -- and returns that value. + -- The default implementation typechecks iff there is a single subvalue of type @part@ in @record@. extract :: record -> part default extract :: forall path. (Generic record, SuccessfulSearch part record path) => record -> part extract = gextract (Proxy :: Proxy path) . from + -- | Update the @record@ given an update function for the @part@. + -- + -- The default implementation searches for some value of the type @part@ in @record@ + -- and updates that value using the supplied function. + -- The default implementation typechecks iff there is a single subvalue of type @part@ in @record@. + update :: (part -> part) -> record -> record + + default update :: forall path. (Generic record, SuccessfulSearch part record path) => (part -> part) -> record -> record + update f = to . gupdate (Proxy :: Proxy path) f . from + -- | Each type allows projecting itself (and that is an 'id' projection). instance Has record record where extract = id + update = id instance SuccessfulSearch a (a0, a1) path => Has a (a0, a1) instance SuccessfulSearch a (a0, a1, a2) path => Has a (a0, a1, a2) diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -19,30 +19,47 @@ 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 + Left e@(TypeError msg) -> if "(deferred type error)" `isSuffixOf` msg + then pure () + else throwIO e +fooEnvTwice :: FooEnv -> FooEnv +fooEnvTwice (FooEnv n s) = FooEnv (n * 2) (s <> s) + +barEnvCons :: BarEnv -> BarEnv +barEnvCons (BarEnv d xs) = BarEnv d (0 : xs) + main :: IO () main = hspec $ do let baseFooEnv = FooEnv 10 "meh" + let baseFooEnvTwice = FooEnv 20 "mehmeh" let baseBarEnv = BarEnv 4.2 [1, 2, 3] + let baseBarEnvCons = BarEnv 4.2 [0, 1, 2, 3] describe "Has" $ do - describe "Basic instance" $ + describe "Basic instance" $ do it "any type Has itself" $ do let exFoo = extract baseFooEnv exFoo `shouldBe` baseFooEnv + it "any type updates itself" $ do + let baseFooEnv' = update fooEnvTwice baseFooEnv + baseFooEnv' `shouldBe` baseFooEnvTwice 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 "envs update their components" $ do + let appEnv' = update fooEnvTwice $ update barEnvCons $ AppEnv baseFooEnv baseBarEnv + appEnv' `shouldBe` AppEnv baseFooEnvTwice baseBarEnvCons it "tuples have their components" $ do let exFoo = extract (baseFooEnv, baseBarEnv) exFoo `shouldBe` baseFooEnv let exBar = extract (baseFooEnv, baseBarEnv) exBar `shouldBe` baseBarEnv + it "tuples update their components" $ do + let pair' = update fooEnvTwice $ update barEnvCons (baseFooEnv, baseBarEnv) + pair' `shouldBe` (baseFooEnvTwice, baseBarEnvCons) 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