generic-lens 1.0.0.1 → 1.0.0.2

raw patch · 11 files changed

+241/−123 lines, 11 filesdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• ChangeLog.md +3/−0
• generic-lens.cabal +2/−2
• src/Data/Generics/Internal/Families/Has.hs +52/−9
• src/Data/Generics/Product/Fields.hs +10/−8
• src/Data/Generics/Product/Internal/GLens.hs +79/−0
• src/Data/Generics/Product/Internal/Keyed.hs +0/−60
• src/Data/Generics/Product/Internal/List.hs +3/−1
• src/Data/Generics/Product/Internal/Positions.hs +45/−26
• src/Data/Generics/Product/Internal/Subtype.hs +11/−6
• src/Data/Generics/Product/Positions.hs +28/−8
• src/Data/Generics/Product/Typed.hs +8/−3

@@ -1,3 +1,6 @@+## 1.0.0.2+- Fix compile-time performance regression+ ## 1.0.0.1 - Remove dump-core dependency - Relax upper bound on criterion (#42)

@@ -1,5 +1,5 @@ name:                 generic-lens-version:              1.0.0.1+version:              1.0.0.2 synopsis:             Generically derive traversals, lenses and prisms. description:          This library uses GHC.Generics to derive efficient optics (traversals, lenses and prisms) for algebraic data types in a type-directed way, with a focus on good type inference and error messages when possible. @@ -59,11 +59,11 @@                     , Data.Generics.Sum.Internal.Subtype                      , Data.Generics.Product.Internal.Positions+                    , Data.Generics.Product.Internal.GLens                     , Data.Generics.Product.Internal.Subtype                      , Data.Generics.Product.Internal.Constraints                     , Data.Generics.Product.Internal.List-                    , Data.Generics.Product.Internal.Keyed    build-depends:      base        >= 4.9 && <= 5.0                     , profunctors >= 5.0 && <= 6.0

@@ -16,6 +16,9 @@ ----------------------------------------------------------------------------- module Data.Generics.Internal.Families.Has   ( HasTotalFieldP+  , HasTotalTypeP+  , HasTotalPositionP+  , Pos   , HasPartialTypeP   , HasCtorP   , GTypes@@ -24,10 +27,13 @@ import Data.Type.Bool     (type (||), type (&&)) import Data.Type.Equality (type (==)) import GHC.Generics-import GHC.TypeLits       (Symbol, TypeError, ErrorMessage (..))+import GHC.TypeLits (Symbol, Nat)+import Data.Kind (Type)  import Data.Generics.Product.Internal.List +-- Note: these could be factored out into a single traversal+ type family HasTotalFieldP (field :: Symbol) f :: Bool where   HasTotalFieldP field (S1 ('MetaSel ('Just field) _ _ _) _)     = 'True@@ -41,18 +47,55 @@     = HasTotalFieldP field f   HasTotalFieldP field (D1 _ f)     = HasTotalFieldP field f-  HasTotalFieldP field (Rec0 _)+  HasTotalFieldP field (K1 _ _)     = 'False   HasTotalFieldP field U1     = 'False   HasTotalFieldP field V1     = 'False-  HasTotalFieldP field f-    = TypeError-        (     'ShowType f-        ':<>: 'Text " is not a valid GHC.Generics representation type"-        ) +type family HasTotalTypeP (typ :: Type) f :: Bool where+  HasTotalTypeP typ (S1 _ (K1 _ typ))+    = 'True+  HasTotalTypeP typ (l :*: r)+    = HasTotalTypeP typ l || HasTotalTypeP typ r+  HasTotalTypeP typ (l :+: r)+    = HasTotalTypeP typ l && HasTotalTypeP typ r+  HasTotalTypeP typ (S1 _ _)+    = 'False+  HasTotalTypeP typ (C1 _ f)+    = HasTotalTypeP typ f+  HasTotalTypeP typ (D1 _ f)+    = HasTotalTypeP typ f+  HasTotalTypeP typ (K1 _ _)+    = 'False+  HasTotalTypeP typ U1+    = 'False+  HasTotalTypeP typ V1+    = 'False++data Pos (p :: Nat)++type family HasTotalPositionP (pos :: Nat) f :: Bool where+  HasTotalPositionP pos (S1 _ (K1 (Pos pos) _))+    = 'True+  HasTotalPositionP pos (l :*: r)+    = HasTotalPositionP pos l || HasTotalPositionP pos r+  HasTotalPositionP pos (l :+: r)+    = HasTotalPositionP pos l && HasTotalPositionP pos r+  HasTotalPositionP pos (S1 _ _)+    = 'False+  HasTotalPositionP pos (C1 _ f)+    = HasTotalPositionP pos f+  HasTotalPositionP pos (D1 _ f)+    = HasTotalPositionP pos f+  HasTotalPositionP pos (K1 _ _)+    = 'False+  HasTotalPositionP pos U1+    = 'False+  HasTotalPositionP pos V1+    = 'False+ type family HasPartialTypeP a f :: Bool where   HasPartialTypeP t (l :+: r)     = HasPartialTypeP t l || HasPartialTypeP t r@@ -73,10 +116,10 @@   HasCtorP ctor _     = 'False -type family GTypes (rep :: * -> *) :: [((), *)] where+type family GTypes (rep :: Type -> Type) :: [((), Type)] where   GTypes (l :*: r)     = GTypes l ++ GTypes r-  GTypes (Rec0 a)+  GTypes (K1 _ a)     = '[ '( '(), a)]   GTypes (M1 _ m a)     = GTypes a

@@ -40,7 +40,7 @@ import Data.Generics.Internal.Families import Data.Generics.Internal.VL.Lens as VL import Data.Generics.Internal.Void-import Data.Generics.Product.Internal.Keyed+import Data.Generics.Product.Internal.GLens  import Data.Kind    (Constraint, Type) import GHC.Generics@@ -129,9 +129,9 @@ instance   ( Generic s   , ErrorUnless field s (CollectField field (Rep s))-  , GHasKey' field (Rep s) a+  , GLens' (HasTotalFieldPSym field) (Rep s) a   ) => HasField' field s a where-  field' f s = VL.ravel (repLens . gkey @field) f s+  field' f s = VL.ravel (repLens . glens @(HasTotalFieldPSym field)) f s  instance  -- see Note [Changing type parameters]   ( Generic s@@ -146,14 +146,13 @@ #endif   , Generic s'   , Generic t'-  , GHasKey' field (Rep s) a-  , GHasKey' field (Rep s') a'-  , GHasKey' field (Rep t') b'-  , GHasKey  field (Rep s) (Rep t) a b+  , GLens' (HasTotalFieldPSym field) (Rep s') a'+  , GLens' (HasTotalFieldPSym field) (Rep t') b'+  , GLens  (HasTotalFieldPSym field) (Rep s) (Rep t) a b   , t ~ Infer s a' b   , s ~ Infer t b' a   ) => HasField field s t a b where-  field f s = VL.ravel (repLens . gkey @field) f s+  field f s = VL.ravel (repLens . glens @(HasTotalFieldPSym field)) f s  -- -- See Note [Uncluttering type signatures] instance {-# OVERLAPPING #-} HasField f (Void1 a) (Void1 b) a b where@@ -180,3 +179,6 @@    ErrorUnless _ _ ('TypeStat '[] '[] _)     = ()++data HasTotalFieldPSym :: Symbol -> (TyFun (Type -> Type) Bool)+type instance Eval (HasTotalFieldPSym sym) tt = HasTotalFieldP sym tt

@@ -0,0 +1,79 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE AllowAmbiguousTypes    #-}+{-# LANGUAGE ConstraintKinds        #-}+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE KindSignatures         #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE Rank2Types             #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TypeApplications       #-}+{-# LANGUAGE TypeFamilies           #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE UndecidableInstances   #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Generics.Product.Internal.GLens+-- Copyright   :  (C) 2017 Csongor Kiss+-- License     :  BSD3+-- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Derive record field getters and setters generically.+--+-----------------------------------------------------------------------------++module Data.Generics.Product.Internal.GLens+  ( GLens (..)+  , GLens'+  , TyFun+  , Eval+  ) where++import Data.Generics.Internal.Profunctor.Lens (Lens, choosing, first, second)+import Data.Generics.Internal.Profunctor.Iso (kIso, sumIso, mIso)++import Data.Kind    (Type)+import GHC.Generics++type TyFun a b = a -> b -> Type+type family Eval (f :: TyFun a b) (x :: a) :: b++-- A generic lens that uses some predicate to determine which field to focus on+class GLens (pred :: TyFun (Type -> Type) Bool) (s :: Type -> Type) (t :: Type -> Type) a b | s pred -> a, t pred -> b where+  glens :: Lens (s x) (t x) a b++type GLens' pred s a = GLens pred s s a a++instance GProductLens (Eval pred l) pred l r l' r' a b+      => GLens pred (l :*: r) (l' :*: r') a b where++  glens = gproductField @(Eval pred l) @pred+  {-# INLINE glens #-}++instance (GLens pred l l' a b, GLens pred r r' a b) =>  GLens pred (l :+: r) (l' :+: r') a b where+  glens = sumIso . choosing (glens @pred) (glens @pred)+  {-# INLINE glens #-}++instance GLens pred (K1 r a) (K1 r b) a b where+  glens = kIso+  {-# INLINE glens #-}++instance (Functor g, GLens pred f g a b) => GLens pred (M1 m meta f) (M1 m meta g) a b where+  glens = mIso . glens @pred+  {-# INLINE glens #-}++class GProductLens (left :: Bool) (pred :: TyFun (Type -> Type) Bool) l r l' r' a b | pred l r -> a, pred l' r' -> b where+  gproductField :: Lens ((l :*: r) x) ((l' :*: r') x) a b++instance GLens pred l l' a b => GProductLens 'True pred l r l' r a b where+  gproductField = first . glens @pred+  {-# INLINE gproductField #-}++instance GLens pred r r' a b => GProductLens 'False pred l r l r' a b where+  gproductField = second . glens @pred+  {-# INLINE gproductField #-}

@@ -1,60 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes    #-}-{-# LANGUAGE CPP                    #-}-{-# LANGUAGE ConstraintKinds        #-}-{-# LANGUAGE FlexibleInstances      #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE GADTs                  #-}-{-# LANGUAGE ScopedTypeVariables    #-}-{-# LANGUAGE TypeApplications       #-}-{-# LANGUAGE TypeFamilies           #-}-{-# LANGUAGE TypeInType             #-}-{-# LANGUAGE TypeOperators          #-}-{-# LANGUAGE UndecidableInstances   #-}--#if __GLASGOW_HASKELL__ == 802-{-# OPTIONS_GHC -fno-solve-constant-dicts #-}-#endif------------------------------------------------------------------------------------- |--- Module      : Data.Generics.Product.Internal.Keyed--- Copyright   : (C) 2018 Csongor Kiss--- Maintainer  : Csongor Kiss <kiss.csongor.kiss@gmail.com>--- License     : BSD3--- Stability   : experimental--- Portability : non-portable--------------------------------------------------------------------------------------module Data.Generics.Product.Internal.Keyed-  ( GHasKey (..)-  , GHasKey'-  ) where--import Data.Generics.Product.Internal.List-import Data.Kind-import GHC.Generics-import Data.Generics.Internal.Profunctor.Lens-import Data.Generics.Internal.Profunctor.Iso--class GHasKey (key :: k) (s :: Type -> Type) (t :: Type -> Type) a b | s key -> a, t key -> b where-  gkey :: Lens (s x) (t x) a b--type GHasKey' key s a = GHasKey key s s a a--instance (GHasKey key l l' a b, GHasKey key r r' a b) =>  GHasKey key (l :+: r) (l' :+: r') a b where-  gkey = sumIso . choosing (gkey @key) (gkey @key)-  {-# INLINE gkey #-}--instance (GHasKey key f g a b) => GHasKey key (M1 D meta f) (M1 D meta g) a b where-  gkey = ravel (mLens . gkey @key)-  {-# INLINE gkey #-}--instance-  ( Elem as key i a-  , Elem bs key i b-  , IndexList i as bs a b-  , GIsList k f g as bs-  ) => GHasKey (key :: k) (M1 C meta f) (M1 C meta g) a b where-  gkey = mLens . glist @k . point @i-  {-# INLINE gkey #-}

@@ -40,8 +40,10 @@   , TupleToList   ) where -import GHC.TypeLits+#if __GLASGOW_HASKELL__ < 804 import Data.Semigroup+#endif+import GHC.TypeLits  import Data.Kind    (Type) import GHC.Generics

@@ -1,3 +1,4 @@+{-# LANGUAGE TypeInType #-} {-# LANGUAGE AllowAmbiguousTypes    #-} {-# LANGUAGE ConstraintKinds        #-} {-# LANGUAGE DataKinds              #-}@@ -27,42 +28,62 @@ -----------------------------------------------------------------------------  module Data.Generics.Product.Internal.Positions-  ( GHasPosition (..)-  , GHasPosition'-  , type (<?)+  ( type (<?)   , Size+  , CRep   ) where -import Data.Generics.Product.Internal.List+import Data.Generics.Internal.Families.Has (Pos) import Data.Kind      (Type) import Data.Type.Bool (If, Not) import GHC.Generics-import GHC.TypeLits   (type (<=?), type (+), type (-), Nat)-import Data.Generics.Internal.Profunctor.Lens-import Data.Generics.Internal.Profunctor.Iso+import GHC.TypeLits   (type (<=?), type (+), Nat) --- |As 'HasPosition' but over generic representations as defined by---  "GHC.Generics".-class GHasPosition (i :: Nat) (s :: Type -> Type) (t :: Type -> Type) a b | s i -> a, t i -> b, s t i -> b where-  gposition :: Lens (s x) (t x) a b+-- | Alias for the kind of the generic rep+type G k = k -> Type -type GHasPosition' i s a = GHasPosition i s s a a+-------------------------------------------------------------------------------- -instance (GHasPosition i l l' a b, GHasPosition i r r' a b) =>  GHasPosition i (l :+: r) (l' :+: r') a b where-  gposition = \x -> sumIso (choosing (gposition @i) (gposition @i) x)-  {-# INLINE gposition #-}+-- | In-order labeling of the generic tree with the field positions+--+-- We replace the (K1 R a) nodes with (K1 (Pos n) a), where 'n' is the position+-- of the field in question in the data type. This is convenient, because we+-- can reuse all the existing functions as long as they are polymorphic in the+-- first parameter of 'K1'.+type family CRep (a :: Type) :: G k where+  CRep rep = Fst (Traverse (Rep rep) 1) -instance GHasPosition i s t a b => GHasPosition i (M1 D meta s) (M1 D meta t) a b where-  gposition x = mLens (gposition @i x)-  {-# INLINE gposition #-}+-- | The actual traversal.+--+-- Might be cleaner if the sum and product parts were separated (as there's+-- and invariant that 'n' should be zero when we're at a sum node, which holds+-- for derived Generic instances (where the sums are strictly above the products))+type family Traverse (a :: G k) (n :: Nat) :: (G k, Nat) where+  Traverse (M1 mt m s) n+    = Traverse1 (M1 mt m) (Traverse s n)+  Traverse (l :+: r) n+    = '(Fst (Traverse l n) :+: Fst (Traverse r n), n)+  Traverse (l :*: r) n+    = TraverseProd (:*:) (Traverse l n) r+  Traverse (K1 _ p) n+    = '(K1 (Pos n) p, n + 1)+  Traverse U1 n+    = '(U1, n) -instance-  ( IndexList (i - 1) as bs a b-  , GIsList () f g as bs-  ) => GHasPosition i (M1 C meta f) (M1 C meta g) a b where-  gposition x = mIso (glist @() (point @(i - 1) x))-  {-# INLINE gposition #-}+type family Traverse1 (w :: G k -> G k) (z :: (G k, Nat)) :: (G k, Nat) where+  Traverse1 w '(i, n) = '(w i, n) +-- | For products, we first traverse the left-hand side, followed by the second+-- using the counter returned by the left traversal.+type family TraverseProd (c :: G k -> G k -> G k) (a :: (G k, Nat)) (r :: G k) :: (G k, Nat) where+  TraverseProd w '(i, n) r = Traverse1 (w i) (Traverse r n)++--------------------------------------------------------------------------------+-- Utilities++type family Fst (p :: (a, b)) :: a where+  Fst '(a, b) = a+ type family Size f :: Nat where   Size (l :*: r)     = Size l + Size r@@ -74,8 +95,6 @@     = Size f   Size f     = 1----------------------------------------------------------------------------------  type x <? y = Not (y <=? x) infixl 4 <?

@@ -1,3 +1,4 @@+{-# LANGUAGE TypeInType #-} {-# LANGUAGE AllowAmbiguousTypes       #-} {-# LANGUAGE DataKinds                 #-} {-# LANGUAGE FlexibleContexts          #-}@@ -31,11 +32,12 @@   ) where  import Data.Generics.Internal.Families-import Data.Generics.Product.Internal.Keyed+import Data.Generics.Product.Internal.GLens  import Data.Kind (Type) import GHC.Generics-import Data.Generics.Internal.Profunctor.Lens+import GHC.TypeLits (Symbol)+import Data.Generics.Internal.Profunctor.Lens (view)  -------------------------------------------------------------------------------- -- * Generic upcasting@@ -47,10 +49,10 @@   gupcast rep = gupcast rep :*: gupcast rep  instance-  GHasKey field sub sub t t+  GLens' (HasTotalFieldPSym field) sub t   => GUpcast sub (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) where -  gupcast r = M1 (K1 (view (gkey @field) r))+  gupcast r = M1 (K1 (view (glens @(HasTotalFieldPSym field)) r))  instance GUpcast sub sup => GUpcast sub (C1 c sup) where   gupcast = M1 . gupcast@@ -84,9 +86,12 @@   gsmashLeaf :: sup p -> sub p -> sub p  instance-  GHasKey field sup sup t t+  GLens' (HasTotalFieldPSym field) sup t   => GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'True where-  gsmashLeaf sup _ = M1 (K1 (view (gkey @field) sup))+  gsmashLeaf sup _ = M1 (K1 (view (glens @(HasTotalFieldPSym field)) sup))  instance GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'False where   gsmashLeaf _ = id++data HasTotalFieldPSym :: Symbol -> (TyFun (Type -> Type) Bool)+type instance Eval (HasTotalFieldPSym sym) tt = HasTotalFieldP sym tt

@@ -1,3 +1,5 @@+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE CPP #-} {-# LANGUAGE AllowAmbiguousTypes    #-} {-# LANGUAGE ConstraintKinds        #-}@@ -42,12 +44,14 @@ import Data.Generics.Internal.Void import Data.Generics.Internal.Families import Data.Generics.Product.Internal.Positions+import Data.Generics.Product.Internal.GLens  import Data.Kind      (Constraint, Type) import Data.Type.Bool (type (&&)) import GHC.Generics import GHC.TypeLits   (type (<=?),  Nat, TypeError, ErrorMessage(..))-import Data.Generics.Internal.Profunctor.Lens+import Data.Generics.Internal.Profunctor.Lens as P+import Data.Coerce  -- $setup -- == /Running example:/@@ -101,9 +105,11 @@ instance   ( Generic s   , ErrorUnless i s (0 <? i && i <=? Size (Rep s))-  , GHasPosition' i (Rep s) a+  , cs ~ CRep s+  , Coercible (Rep s) cs+  , GLens' (HasTotalPositionPSym i) cs a   ) => HasPosition' i s a where-  position' f s = VL.ravel (repLens . gposition @i) f s+  position' f s = VL.ravel (repLens . coerced @cs @cs . glens @(HasTotalPositionPSym i)) f s   {-# INLINE position' #-}  instance  -- see Note [Changing type parameters]@@ -119,17 +125,28 @@ #endif   , Generic s'   , Generic t'-  , GHasPosition' i (Rep s) a-  , GHasPosition' i (Rep s') a'-  , GHasPosition i (Rep s) (Rep t) a b+  , GLens (HasTotalPositionPSym i) cs ct a b+  , cs ~ CRep s+  , ct ~ CRep t+  , GLens' (HasTotalPositionPSym i) (CRep s') a'+  , GLens' (HasTotalPositionPSym i) (CRep t') b'   , t ~ Infer s a' b-  , GHasPosition' i (Rep t') b'   , s ~ Infer t b' a+  , Coercible cs (Rep s)+  , Coercible ct (Rep t)   ) => HasPosition i s t a b where -  position = VL.ravel (repLens . gposition @i)+  position = VL.ravel (repLens . coerced @cs @ct . glens @(HasTotalPositionPSym i))   {-# INLINE position #-} +-- We wouldn't need the universal 'x' here if we could express above that+-- forall x. Coercible (cs x) (Rep s x), but this requires quantified+-- constraints+coerced :: forall s t s' t' x a b. (Coercible t t', Coercible s s')+        => P.ALens a b (s x) (t x) -> P.ALens a b (s' x) (t' x)+coerced = coerce+{-# INLINE coerced #-}+ -- See Note [Uncluttering type signatures] instance {-# OVERLAPPING #-} HasPosition f (Void1 a) (Void1 b) a b where   position = undefined@@ -145,3 +162,6 @@    ErrorUnless _ _ 'True     = ()++data HasTotalPositionPSym  :: Nat -> (TyFun (Type -> Type) Bool)+type instance Eval (HasTotalPositionPSym t) tt = HasTotalPositionP t tt

@@ -7,6 +7,7 @@ {-# LANGUAGE ScopedTypeVariables   #-} {-# LANGUAGE TypeApplications      #-} {-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeInType            #-} {-# LANGUAGE TypeOperators         #-} {-# LANGUAGE UndecidableInstances  #-} @@ -33,7 +34,7 @@ import Data.Generics.Internal.Families import Data.Generics.Internal.VL.Lens as VL import Data.Generics.Internal.Void-import Data.Generics.Product.Internal.Keyed+import Data.Generics.Product.Internal.GLens  import Data.Kind    (Constraint, Type) import GHC.Generics (Generic (Rep))@@ -110,10 +111,10 @@ instance   ( Generic s   , ErrorUnlessOne a s (CollectTotalType a (Rep s))-  , GHasKey a (Rep s) (Rep s) a a+  , GLens (HasTotalTypePSym a) (Rep s) (Rep s) a a   ) => HasType a s where -  typed f s = VL.ravel (repLens . gkey @a) f s+  typed f s = VL.ravel (repLens . glens @(HasTotalTypePSym a)) f s  -- See Note [Uncluttering type signatures] instance {-# OVERLAPPING #-} HasType a Void where@@ -150,3 +151,7 @@    ErrorUnlessOne _ _ ('TypeStat '[] '[] _)     = ()++data HasTotalTypePSym :: Type -> (TyFun (Type -> Type) Bool)+type instance Eval (HasTotalTypePSym t) tt = HasTotalTypeP t tt+