diff --git a/composite-base.cabal b/composite-base.cabal --- a/composite-base.cabal +++ b/composite-base.cabal @@ -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 diff --git a/src/Composite/Record.hs b/src/Composite/Record.hs --- a/src/Composite/Record.hs +++ b/src/Composite/Record.hs @@ -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 diff --git a/src/Composite/TH.hs b/src/Composite/TH.hs --- a/src/Composite/TH.hs +++ b/src/Composite/TH.hs @@ -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) |] diff --git a/test/RecordSpec.hs b/test/RecordSpec.hs --- a/test/RecordSpec.hs +++ b/test/RecordSpec.hs @@ -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