composite-base 0.7.5.0 → 0.7.6.0

raw patch · 4 files changed

+186/−33 lines, 4 filesdep ~basedep ~lensdep ~profunctorsPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base, lens, profunctors, template-haskell, vinyl

API changes (from Hackage documentation)

Files

• composite-base.cabal +63/−17
• src/Composite/Record.hs +45/−7
• src/Composite/TH.hs +59/−4
• test/RecordSpec.hs +19/−5

@@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.3.+-- This file has been generated from package.yaml by hpack version 0.34.5. -- -- see: https://github.com/sol/hpack ----- hash: 42cd7a9297580ad2d6a569e06f0a035a2d63a52e1725a2680e8b062db07f8910+-- hash: 1bd1f66bd3d38d9ed108f5b7c2e4d437903998f82224fddeefae706b03de417d  name:           composite-base-version:        0.7.5.0+version:        0.7.6.0 synopsis:       Shared utilities for composite-* packages. description:    Shared helpers for the various composite packages. category:       Records@@ -29,22 +29,45 @@       Paths_composite_base   hs-source-dirs:       src-  default-extensions: ConstraintKinds DataKinds FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving MultiParamTypeClasses NamedFieldPuns OverloadedStrings PatternSynonyms PolyKinds RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators ViewPatterns+  default-extensions:+      ConstraintKinds+      DataKinds+      FlexibleContexts+      FlexibleInstances+      FunctionalDependencies+      GADTs+      GeneralizedNewtypeDeriving+      MultiParamTypeClasses+      NamedFieldPuns+      OverloadedStrings+      PatternSynonyms+      PolyKinds+      RankNTypes+      RecordWildCards+      ScopedTypeVariables+      StandaloneDeriving+      StrictData+      TemplateHaskell+      TupleSections+      TypeApplications+      TypeFamilies+      TypeOperators+      ViewPatterns   ghc-options: -Wall -O2   build-depends:-      base >=4.7 && <5-    , deepseq >=1.4 && <1.5+      base >=4.12 && <5+    , deepseq ==1.4.*     , exceptions >=0.8.3 && <0.11-    , lens >=4.15.4 && <5.1+    , lens >=4.15.4 && <5.2     , monad-control >=1.0.2.2 && <1.1     , mtl >=2.2.1 && <2.3-    , profunctors >=5.2.1 && <5.6-    , template-haskell >=2.11.1.0 && <2.17+    , profunctors >=5.2.1 && <5.7+    , template-haskell >=2.11.1.0 && <2.19     , text >=1.2.2.2 && <1.3     , transformers >=0.5.2.0 && <0.6     , transformers-base >=0.4.4 && <0.5     , unliftio-core >=0.1.0.0 && <0.3.0.0-    , vinyl >=0.5.3 && <0.14+    , vinyl >=0.5.3 && <0.15   default-language: Haskell2010  test-suite composite-base-test@@ -56,23 +79,46 @@       Paths_composite_base   hs-source-dirs:       test-  default-extensions: ConstraintKinds DataKinds FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving MultiParamTypeClasses NamedFieldPuns OverloadedStrings PatternSynonyms PolyKinds RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators ViewPatterns+  default-extensions:+      ConstraintKinds+      DataKinds+      FlexibleContexts+      FlexibleInstances+      FunctionalDependencies+      GADTs+      GeneralizedNewtypeDeriving+      MultiParamTypeClasses+      NamedFieldPuns+      OverloadedStrings+      PatternSynonyms+      PolyKinds+      RankNTypes+      RecordWildCards+      ScopedTypeVariables+      StandaloneDeriving+      StrictData+      TemplateHaskell+      TupleSections+      TypeApplications+      TypeFamilies+      TypeOperators+      ViewPatterns   ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N -fno-warn-orphans   build-depends:       QuickCheck-    , base >=4.7 && <5+    , base >=4.12 && <5     , composite-base-    , deepseq >=1.4 && <1.5+    , deepseq ==1.4.*     , exceptions >=0.8.3 && <0.11     , hspec-    , lens >=4.15.4 && <5.1+    , lens >=4.15.4 && <5.2     , monad-control >=1.0.2.2 && <1.1     , mtl >=2.2.1 && <2.3-    , profunctors >=5.2.1 && <5.6-    , template-haskell >=2.11.1.0 && <2.17+    , profunctors >=5.2.1 && <5.7+    , template-haskell >=2.11.1.0 && <2.19     , text >=1.2.2.2 && <1.3     , transformers >=0.5.2.0 && <0.6     , transformers-base >=0.4.4 && <0.5     , unliftio-core >=0.1.0.0 && <0.3.0.0-    , vinyl >=0.5.3 && <0.14+    , vinyl >=0.5.3 && <0.15   default-language: Haskell2010

@@ -2,9 +2,9 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Composite.Record   ( Rec((:&), RNil), Record-  , pattern (:*:), pattern (:^:)+  , pattern (:*:), pattern (:^:), pattern (:!:)   , (:->)(Val, getVal), _Val, val, valName, valWithName-  , RElem, rlens, rlens'+  , RElem, rlens, rlens', rlensCo, rlensContra   , AllHave, HasInstances, ValuesAllHave   , zipRecsWith, reifyDicts, reifyVal, recordToNonEmpty   , ReifyNames(reifyNames)@@ -16,6 +16,7 @@ import Control.Lens (Iso, iso) import Control.Lens.TH (makeWrapped) import Data.Functor.Identity (Identity(Identity))+import Data.Functor.Contravariant (Contravariant(contramap)) import Data.Kind (Constraint) import Data.List.NonEmpty (NonEmpty((:|))) import Data.Proxy (Proxy(Proxy))@@ -169,6 +170,11 @@   (:^:) fa rs = fmap Val fa :& rs infixr 5 :^: +pattern (:!:) :: Contravariant f => () => f a -> Rec f rs -> Rec f (s :-> a ': rs)+pattern (:!:) fa rs <- (contramap Val -> fa) :& rs where+  (:!:) fa rs = contramap getVal fa :& rs+infixr 5 :!:+ -- |Reify the type of a val. reifyVal :: proxy (s :-> a) -> (s :-> a) -> (s :-> a) reifyVal _ = id@@ -217,15 +223,47 @@ -- Then: -- -- @---   view (rlens' fBar_)                      rec == Just "hello!"---   set  (rlens' fBar_) Nothing              rec == Just 123 :^: Nothing       :^: Nil---   over (rlens' fBar_) (fmap (map toUpper)) rec == Just 123 :^: Just "HELLO!" :^: Nil+--   view (rlensCo fBar_)                      rec == Just "hello!"+--   set  (rlensCo fBar_) Nothing              rec == Just 123 :^: Nothing       :^: Nil+--   over (rlensCo fBar_) (fmap (map toUpper)) rec == Just 123 :^: Just "HELLO!" :^: Nil -- @-rlens' :: (Functor f, Functor g, RElem (s :-> a) rs, Functor g) => proxy (s :-> a) -> (f a -> g (f a)) -> Rec f rs -> g (Rec f rs)-rlens' proxy f =+rlensCo :: (Functor f, Functor g, RElem (s :-> a) rs) => proxy (s :-> a) -> (f a -> g (f a)) -> Rec f rs -> g (Rec f rs)+rlensCo proxy f =   Vinyl.rlens $ \ (fmap (getVal . reifyVal proxy) -> fa) ->     fmap Val <$> f fa+{-# INLINE rlensCo #-}++-- |Synonym for `rlensCo`+rlens' :: (Functor f, Functor g, RElem (s :-> a) rs) => proxy (s :-> a) -> (f a -> g (f a)) -> Rec f rs -> g (Rec f rs)+rlens' = rlensCo {-# INLINE rlens' #-}++-- |Lens to a particular field of a record using a contravariant functor.+--+-- For example, given:+--+-- @+--   type FFoo = "foo" :-> Int+--   type FBar = "bar" :-> String+--   fBar_ :: Proxy FBar+--   fBar_ = Proxy+--+--   rec :: 'Rec' 'Predicate' '[FFoo, FBar]+--   rec = Predicate even :!: Predicate (even . length) :!: Nil+-- @+--+-- Then:+--+-- @+--   view (rlensContra fBar_)                           rec == Predicate even+--   set  (rlensContra fBar_) Predicate (odd . length)  rec == Predicate even :!: Predicate (odd . length) :!: Nil+--   over (rlensContra fBar_) (contramap show)          rec == Predicate even :!: Predicate (odd . length . show) :!: Nil+-- @+rlensContra :: (Contravariant f, Functor g, RElem (s :-> a) rs) => proxy (s :-> a) -> (f a -> g (f a)) -> Rec f rs -> g (Rec f rs)+rlensContra proxy f =+  Vinyl.rlens $ \(contramap (reifyVal proxy . Val) -> fa) ->+    contramap getVal <$> f fa+{-# INLINE rlensContra #-}  -- | 'zipWith' for Rec's. zipRecsWith :: (forall a. f a -> g a -> h a) -> Rec f as -> Rec g as -> Rec h as

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} module Composite.TH   ( withProxies   , withLensesAndProxies@@ -18,6 +19,9 @@   ( Q, newName, mkName, nameBase   , Body(NormalB), cxt, Dec(PragmaD, SigD, ValD), Exp(VarE), Inline(Inlinable), Name, Pat(VarP), Phases(AllPhases), Pragma(InlineP), RuleMatch(FunLike)   , Type(AppT, ConT, ForallT, VarT), TyVarBndr(PlainTV, KindedTV), varT+#if MIN_VERSION_template_haskell(2,17,0)+  , Specificity(SpecifiedSpec)+#endif   ) import Language.Haskell.TH.Lens (_TySynD) @@ -141,31 +145,62 @@ withOpticsAndProxies :: Q [Dec] -> Q [Dec] withOpticsAndProxies = withBoilerplate True True +#if MIN_VERSION_template_haskell(2,17,0)+tyUnitToSpec :: Specificity -> TyVarBndr () -> TyVarBndr Specificity+tyUnitToSpec x (PlainTV n ()) = PlainTV n x+tyUnitToSpec x (KindedTV n () k) = KindedTV n x k++fieldDecUnitToSpec :: Specificity -> FieldDec () -> FieldDec Specificity+fieldDecUnitToSpec x (FieldDec n b t v) = FieldDec n (map (tyUnitToSpec x) b) t v++data FieldDec a = FieldDec+#else data FieldDec = FieldDec+#endif   { fieldName        :: Name+#if MIN_VERSION_template_haskell(2,17,0)+  , fieldBinders     :: [TyVarBndr a]+#else   , fieldBinders     :: [TyVarBndr]+#endif   , fieldTypeApplied :: Type   , fieldValueType   :: Type   }+ -- |TH splice which implements 'withLensesAndProxies', 'withPrismsAndProxies', and 'withOpticsAndProxies' withBoilerplate :: Bool -> Bool -> Q [Dec] -> Q [Dec] withBoilerplate generateLenses generatePrisms qDecs = do   decs <- qDecs    let fieldDecs = catMaybes . map fieldDecMay . toListOf (each . _TySynD) $ decs-+#if MIN_VERSION_template_haskell(2,17,0)+  let sFieldDecs = map (fieldDecUnitToSpec SpecifiedSpec) fieldDecs+#endif   proxyDecs <- traverse proxyDecFor fieldDecs-  lensDecs  <- if generateLenses then traverse lensDecFor  fieldDecs else pure []+#if MIN_VERSION_template_haskell(2,17,0)+  lensDecs  <- if generateLenses then traverse lensDecFor sFieldDecs else pure []+  prismDecs <- if generatePrisms then traverse prismDecFor sFieldDecs else pure []+#else +  lensDecs  <- if generateLenses then traverse lensDecFor fieldDecs else pure []   prismDecs <- if generatePrisms then traverse prismDecFor fieldDecs else pure []-+#endif   pure $ decs <> concat proxyDecs <> concat lensDecs <> concat prismDecs +#if MIN_VERSION_template_haskell(2,17,0)+fieldDecMay :: (Name, [TyVarBndr ()], Type) -> Maybe (FieldDec ())+#else fieldDecMay :: (Name, [TyVarBndr], Type) -> Maybe FieldDec+#endif fieldDecMay (fieldName, fieldBinders, ty) = case ty of   AppT (AppT (ConT n) _) fieldValueType | n == ''(:->) ->     let fieldTypeApplied         = foldl' AppT (ConT fieldName) (map binderTy fieldBinders)-        binderTy (PlainTV n')    = VarT n'+#if MIN_VERSION_template_haskell(2,17,0)+        binderTy (PlainTV n' _ )    = VarT n'+        binderTy (KindedTV n' _ _) = VarT n'+#else+        binderTy (PlainTV n' )    = VarT n'         binderTy (KindedTV n' _) = VarT n'+#endif     in Just $ FieldDec {..}   _ ->     Nothing@@ -175,7 +210,11 @@ prismNameFor = mkName . ("_" ++) . nameBase proxyNameFor = mkName . (++ "_") . over _head toLower . nameBase +#if MIN_VERSION_template_haskell(2,17,0)+proxyDecFor :: FieldDec () -> Q [Dec]+#else proxyDecFor :: FieldDec -> Q [Dec]+#endif proxyDecFor (FieldDec { fieldName, fieldTypeApplied }) = do   let proxyName = proxyNameFor fieldName @@ -187,7 +226,11 @@     , ValD (VarP proxyName) (NormalB proxyVal) []     ] +#if MIN_VERSION_template_haskell(2,17,0)+lensDecFor :: FieldDec Specificity -> Q [Dec]+#else lensDecFor :: FieldDec -> Q [Dec]+#endif lensDecFor (FieldDec {..}) = do   f  <- newName "f"   rs <- newName "rs"@@ -197,7 +240,11 @@       proxyName               = proxyNameFor fieldName       lensName                = lensNameFor fieldName       proxyVal                = VarE proxyName+#if MIN_VERSION_template_haskell(2,17,0)+      lensBinders             = fieldBinders ++ [PlainTV f SpecifiedSpec, PlainTV rs SpecifiedSpec]+#else       lensBinders             = fieldBinders ++ [PlainTV f, PlainTV rs]+#endif    lensContext <- cxt [ [t| Functor $fTy |], [t| $(pure fieldTypeApplied) ∈ $rsTy |] ]   lensType    <- [t| ($(pure fieldValueType) -> $fTy $(pure fieldValueType)) -> (Record $rsTy -> $fTy (Record $rsTy)) |]@@ -209,7 +256,11 @@     , ValD (VarP lensName) (NormalB rlensVal) []     ] +#if MIN_VERSION_template_haskell(2,17,0)+prismDecFor :: FieldDec Specificity -> Q [Dec]+#else prismDecFor :: FieldDec -> Q [Dec]+#endif prismDecFor (FieldDec {..}) = do   rs <- newName "rs" @@ -217,7 +268,11 @@       proxyName               = proxyNameFor fieldName       prismName               = prismNameFor fieldName       proxyVal                = VarE proxyName+#if MIN_VERSION_template_haskell(2,17,0)+      prismBinders            = fieldBinders ++ [PlainTV rs SpecifiedSpec]+#else       prismBinders            = fieldBinders ++ [PlainTV rs]+#endif    prismContext  <- cxt [ [t| RecApplicative $rsTy |], [t| $(pure fieldTypeApplied) ∈ $rsTy |] ]   prismType     <- [t| Prism' (Field $rsTy) $(pure fieldValueType) |]

@@ -2,13 +2,15 @@  import Composite.Record import Composite.TH (withLensesAndProxies)-import Control.Lens (view, set, _Just)+import Control.Lens (set, view, _Just)+import Data.Functor.Contravariant (Predicate (Predicate, getPredicate)) import Test.Hspec (Spec, describe, it, shouldBe)  withLensesAndProxies [d|   type FFoo = "foo" :-> Int   type FBar = "bar" :-> String   |]+ type TestRec = '["foo" :-> Int, "bar" :-> String]  recordSuite :: Spec@@ -25,6 +27,12 @@           Just foo :^: Nothing :^: RNil = rec       foo `shouldBe` 123 +    it "Supports construction and deconstruction of a Rec f (Contravariant)" $ do+      let rec = Predicate even :!: Predicate (even . length) :!: RNil :: Rec Predicate TestRec+          foo :!: bar :!: RNil = rec+      getPredicate foo 123 `shouldBe` False+      getPredicate bar "foo" `shouldBe` False+     it "Supports lensing in a Rec Identity" $ do       let rec = 123 :*: "foo" :*: RNil :: Record TestRec       view (rlens fFoo_) rec `shouldBe` 123@@ -34,8 +42,14 @@      it "Supports lensing in a Rec Maybe" $ do       let rec = Just 123 :^: Nothing :^: RNil :: Rec Maybe TestRec-      view (rlens' fFoo_) rec `shouldBe` Just 123-      view (rlens' fBar_) rec `shouldBe` Nothing-      set (rlens' fFoo_ . _Just) 321   rec `shouldBe` (Just 321 :^: Nothing :^: RNil)-      set (rlens' fBar_ . _Just) "bar" rec `shouldBe` (Just 123 :^: Nothing :^: RNil)+      view (rlensCo fFoo_) rec `shouldBe` Just 123+      view (rlensCo fBar_) rec `shouldBe` Nothing+      set (rlensCo fFoo_ . _Just) 321   rec `shouldBe` (Just 321 :^: Nothing :^: RNil)+      set (rlensCo fBar_ . _Just) "bar" rec `shouldBe` (Just 123 :^: Nothing :^: RNil) +    it "Supports lensing in a Rec Predicate" $ do+      let rec = Predicate even :!: Predicate (even . length) :!: RNil :: Rec Predicate TestRec+      getPredicate (view (rlensContra fFoo_) rec) 123 `shouldBe` False+      getPredicate (view (rlensContra fBar_) rec) "foo" `shouldBe` False+      getPredicate (view (rlensContra fFoo_) (set (rlensContra fFoo_) (Predicate odd) rec)) 123 `shouldBe` True+      getPredicate (view (rlensContra fBar_) (set (rlensContra fBar_) (Predicate (odd . length)) rec)) "foo" `shouldBe` True