generic-lens 1.0.0.2 → 1.1.0.0

raw patch · 46 files changed

+1121/−603 lines, 46 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +8/−0
• LICENSE +1/−1
• README.md +4/−1
• examples/doctest.hs +1/−0
• generic-lens.cabal +10/−6
• src/Data/GenericLens/Internal.hs +47/−0
• src/Data/Generics/Internal/Families.hs +1/−2
• src/Data/Generics/Internal/Families/Changing.hs +12/−5
• src/Data/Generics/Internal/Families/Collect.hs +2/−2
• src/Data/Generics/Internal/Families/Has.hs +38/−31
• src/Data/Generics/Internal/Profunctor/Iso.hs +8/−1
• src/Data/Generics/Internal/Profunctor/Lens.hs +1/−1
• src/Data/Generics/Internal/Profunctor/Prism.hs +7/−9
• src/Data/Generics/Internal/VL/Iso.hs +29/−2
• src/Data/Generics/Internal/VL/Lens.hs +5/−1
• src/Data/Generics/Internal/VL/Prism.hs +1/−1
• src/Data/Generics/Internal/VL/Traversal.hs +1/−1
• src/Data/Generics/Labels.hs +142/−0
• src/Data/Generics/Product.hs +3/−3
• src/Data/Generics/Product/Any.hs +1/−1
• src/Data/Generics/Product/Fields.hs +57/−17
• src/Data/Generics/Product/HList.hs +46/−0
• src/Data/Generics/Product/Internal/Constraints.hs +2/−7
• src/Data/Generics/Product/Internal/GLens.hs +14/−12
• src/Data/Generics/Product/Internal/HList.hs +329/−0
• src/Data/Generics/Product/Internal/List.hs +0/−337
• src/Data/Generics/Product/Internal/Positions.hs +6/−6
• src/Data/Generics/Product/Internal/Subtype.hs +5/−5
• src/Data/Generics/Product/List.hs +0/−78
• src/Data/Generics/Product/Positions.hs +63/−22
• src/Data/Generics/Product/Subtype.hs +1/−1
• src/Data/Generics/Product/Typed.hs +2/−2
• src/Data/Generics/Product/Types.hs +25/−3
• src/Data/Generics/Sum.hs +1/−1
• src/Data/Generics/Sum/Any.hs +1/−1
• src/Data/Generics/Sum/Constructors.hs +50/−15
• src/Data/Generics/Sum/Internal/Constructors.hs +6/−7
• src/Data/Generics/Sum/Internal/Subtype.hs +8/−8
• src/Data/Generics/Sum/Internal/Typed.hs +8/−8
• src/Data/Generics/Sum/Subtype.hs +1/−1
• src/Data/Generics/Sum/Typed.hs +2/−2
• src/Data/Generics/Wrapped.hs +104/−0
• test/Spec.hs +35/−2
• test/Test62.hs +20/−0
• test/Test63.hs +12/−0
• test/doctest.hs +1/−0

@@ -1,3 +1,11 @@+## 1.1.0.0+- Fix regression in type inference for polymorphic optics+- Add `HasField0`, `HasPosition0`, `AsConstructor0`, `HasField_`, `HasPositon_`, and `AsConstructor_` (Lysxia)+- `types` now supports Data.Word and Data.Int (Lysxia)+- Add `Wrapped` iso for newtypes (Isaac Elliott)+- Expose internals through Data.GenericLens.Internal+- Add labels for prisms (Daniel Winograd-Cort)+ ## 1.0.0.2 - Fix compile-time performance regression 

@@ -1,4 +1,4 @@-Copyright (c) 2017, Csongor Kiss+Copyright (c) 2018, Csongor Kiss  All rights reserved. 

@@ -16,6 +16,9 @@  Examples can be found in the `examples` and `tests` folders. +The library is described in the paper:+> Csongor Kiss, Matthew Pickering, and Nicolas Wu. 2018. Generic deriving of generic traversals. Proc. ACM Program. Lang. 2, ICFP, Article 85 (July 2018), 30 pages. DOI: https://doi.org/10.1145/3236780+ Table of contents ================= @@ -407,7 +410,7 @@ library is used to ensure (see [here](test/Spec.hs)) that everything gets inlined away. -TODO push benchmarks too+There is also a [benchmark suite](https://github.com/mpickering/generic-lens-benchmarks) with larger, real-world examples. # Contributors  + [Matthew Pickering](https://github.com/mpickering)

@@ -2,5 +2,6 @@ main   = doctest       [ "-iexamples"+      , "-isrc"       , "examples/Biscuits.hs"       ]

@@ -1,5 +1,5 @@ name:                 generic-lens-version:              1.0.0.2+version:              1.1.0.0 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. @@ -11,7 +11,7 @@ category:             Generics, Records, Lens build-type:           Simple cabal-version:        >= 1.10-Tested-With:          GHC == 8.0.2, GHC == 8.2.1+Tested-With:          GHC == 8.0.2, GHC == 8.2.1, GHC == 8.4.1, GHC == 8.4.3  extra-source-files:   ChangeLog.md                     , examples/StarWars.hs@@ -23,7 +23,8 @@   default:     False  library-  exposed-modules:    Data.Generics.Product+  exposed-modules:    Data.Generics.Wrapped+                    , Data.Generics.Product                     , Data.Generics.Product.Any                     , Data.Generics.Product.Fields                     , Data.Generics.Product.Param@@ -32,7 +33,8 @@                     , Data.Generics.Product.Typed                     , Data.Generics.Product.Types                     , Data.Generics.Product.Constraints-                    , Data.Generics.Product.List+                    , Data.Generics.Product.HList+                    , Data.Generics.Labels                     , Data.Generics.Internal.GenericN                      , Data.Generics.Sum@@ -48,6 +50,8 @@                     , Data.Generics.Internal.VL.Prism                     , Data.Generics.Internal.VL.Iso +                    , Data.GenericLens.Internal+   other-modules:      Data.Generics.Internal.Families                     , Data.Generics.Internal.Families.Changing                     , Data.Generics.Internal.Families.Collect@@ -63,7 +67,7 @@                     , Data.Generics.Product.Internal.Subtype                      , Data.Generics.Product.Internal.Constraints-                    , Data.Generics.Product.Internal.List+                    , Data.Generics.Product.Internal.HList    build-depends:      base        >= 4.9 && <= 5.0                     , profunctors >= 5.0 && <= 6.0@@ -97,7 +101,7 @@   type:               exitcode-stdio-1.0   hs-source-dirs:     test   main-is:            Spec.hs-  other-modules:      Util Test24 Test25 Test40+  other-modules:      Util Test24 Test25 Test40 Test62 Test63    build-depends:      base          >= 4.9 && <= 5.0                     , generic-lens

@@ -0,0 +1,47 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.GenericLens.Internal+-- Copyright   :  (C) 2018 Csongor Kiss+-- License     :  BSD3+-- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+--+-- The library internals are exposed through this module. Please keep+-- in mind that everything here is subject to change irrespective of+-- the the version numbers.+-----------------------------------------------------------------------------++module Data.GenericLens.Internal+  ( module Data.Generics.Internal.Families+  , module Data.Generics.Internal.Families.Changing+  , module Data.Generics.Internal.Families.Collect+  , module Data.Generics.Internal.Families.Has+  , module Data.Generics.Internal.Void++  , module Data.Generics.Sum.Internal.Constructors+  , module Data.Generics.Sum.Internal.Typed+  , module Data.Generics.Sum.Internal.Subtype++  , module Data.Generics.Product.Internal.Positions+  , module Data.Generics.Product.Internal.GLens+  , module Data.Generics.Product.Internal.Subtype+  , module Data.Generics.Product.Internal.Constraints+  , module Data.Generics.Product.Internal.HList+  ) where++import Data.Generics.Internal.Families+import Data.Generics.Internal.Families.Changing+import Data.Generics.Internal.Families.Collect+import Data.Generics.Internal.Families.Has+import Data.Generics.Internal.Void++import Data.Generics.Sum.Internal.Constructors+import Data.Generics.Sum.Internal.Typed+import Data.Generics.Sum.Internal.Subtype++import Data.Generics.Product.Internal.Positions+import Data.Generics.Product.Internal.GLens+import Data.Generics.Product.Internal.Subtype+import Data.Generics.Product.Internal.Constraints+import Data.Generics.Product.Internal.HList

@@ -9,7 +9,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Generics.Internal.Families--- Copyright   :  (C) 2017 Csongor Kiss+-- Copyright   :  (C) 2018 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental@@ -27,7 +27,6 @@  import GHC.TypeLits (ErrorMessage (..), Symbol) --- * Stuff type family ShowSymbols (ctors :: [Symbol]) :: ErrorMessage where   ShowSymbols '[]     = 'Text ""

@@ -9,13 +9,14 @@ {-# LANGUAGE UndecidableInstances   #-}  module Data.Generics.Internal.Families.Changing-  ( Proxied+  ( Indexed   , Infer   , PTag (..)   , P   , LookupParam   , ArgAt   , ArgCount+  , UnifyHead   ) where  import GHC.TypeLits (Nat, type (-), type (+), TypeError, ErrorMessage (..))@@ -55,11 +56,11 @@ data PTag = PTag type family P :: Nat -> k -> PTag -> k -type Proxied t = Proxied' t 0+type Indexed t = Indexed' t 0 -type family Proxied' (t :: k) (next :: Nat) :: k where-  Proxied' (t (a :: j) :: k) next = (Proxied' t (next + 1)) (P next a 'PTag)-  Proxied' t _ = t+type family Indexed' (t :: k) (next :: Nat) :: k where+  Indexed' (t (a :: j) :: k) next = (Indexed' t (next + 1)) (P next a 'PTag)+  Indexed' t _ = t  data Sub where   Sub :: Nat -> k -> Sub@@ -152,3 +153,9 @@ -- However, for some reason, this violates the functional dependencies on 8.2.2. -- Therefore, when using a newer version of the compiler, the original constraints -- are used, as the expression size is smaller under 8.2.2.++-- | Ensure that the types @a@ and @b@ are both applications of the same+-- constructor. The arguments may be different.+class UnifyHead (a :: k) (b :: k)+instance {-# OVERLAPPING #-} (gb ~ g b, UnifyHead f g) => UnifyHead (f a) gb+instance (a ~ b) => UnifyHead a b

@@ -7,7 +7,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Generics.Internal.Families.Collect--- Copyright   :  (C) 2017 Csongor Kiss+-- Copyright   :  (C) 2018 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental@@ -28,7 +28,7 @@ import GHC.Generics import GHC.TypeLits       (Symbol, CmpSymbol) -import Data.Generics.Product.Internal.List (type (++))+import Data.Generics.Product.Internal.HList (type (++)) import Data.Generics.Internal.Families.Has (GTypes)  data TypeStat

@@ -7,7 +7,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Generics.Internal.Families.Has--- Copyright   :  (C) 2017 Csongor Kiss+-- Copyright   :  (C) 2018 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental@@ -24,77 +24,84 @@   , GTypes   ) where -import Data.Type.Bool     (type (||), type (&&))+import Data.Type.Bool     (type (||)) import Data.Type.Equality (type (==)) import GHC.Generics import GHC.TypeLits (Symbol, Nat) import Data.Kind (Type) -import Data.Generics.Product.Internal.List+import Data.Generics.Product.Internal.HList  -- 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+type family Both (m1 :: Maybe a) (m2 :: Maybe a) :: Maybe a where+  Both ('Just a) ('Just a) = 'Just a++type family Alt (m1 :: Maybe a) (m2 :: Maybe a) :: Maybe a where+  Alt ('Just a) _ = 'Just a+  Alt _ b = b++type family HasTotalFieldP (field :: Symbol) f :: Maybe Type where+  HasTotalFieldP field (S1 ('MetaSel ('Just field) _ _ _) (Rec0 t))+    = 'Just t   HasTotalFieldP field (l :*: r)-    = HasTotalFieldP field l || HasTotalFieldP field r+    = Alt (HasTotalFieldP field l) (HasTotalFieldP field r)   HasTotalFieldP field (l :+: r)-    = HasTotalFieldP field l && HasTotalFieldP field r+    = Both (HasTotalFieldP field l) (HasTotalFieldP field r)   HasTotalFieldP field (S1 _ _)-    = 'False+    = 'Nothing   HasTotalFieldP field (C1 _ f)     = HasTotalFieldP field f   HasTotalFieldP field (D1 _ f)     = HasTotalFieldP field f   HasTotalFieldP field (K1 _ _)-    = 'False+    = 'Nothing   HasTotalFieldP field U1-    = 'False+    = 'Nothing   HasTotalFieldP field V1-    = 'False+    = 'Nothing -type family HasTotalTypeP (typ :: Type) f :: Bool where+type family HasTotalTypeP (typ :: Type) f :: Maybe Type where   HasTotalTypeP typ (S1 _ (K1 _ typ))-    = 'True+    = 'Just typ   HasTotalTypeP typ (l :*: r)-    = HasTotalTypeP typ l || HasTotalTypeP typ r+    = Alt (HasTotalTypeP typ l) (HasTotalTypeP typ r)   HasTotalTypeP typ (l :+: r)-    = HasTotalTypeP typ l && HasTotalTypeP typ r+    = Both (HasTotalTypeP typ l) (HasTotalTypeP typ r)   HasTotalTypeP typ (S1 _ _)-    = 'False+    = 'Nothing   HasTotalTypeP typ (C1 _ f)     = HasTotalTypeP typ f   HasTotalTypeP typ (D1 _ f)     = HasTotalTypeP typ f   HasTotalTypeP typ (K1 _ _)-    = 'False+    = 'Nothing   HasTotalTypeP typ U1-    = 'False+    = 'Nothing   HasTotalTypeP typ V1-    = 'False+    = 'Nothing  data Pos (p :: Nat) -type family HasTotalPositionP (pos :: Nat) f :: Bool where-  HasTotalPositionP pos (S1 _ (K1 (Pos pos) _))-    = 'True+type family HasTotalPositionP (pos :: Nat) f :: Maybe Type where+  HasTotalPositionP pos (S1 _ (K1 (Pos pos) t))+    = 'Just t   HasTotalPositionP pos (l :*: r)-    = HasTotalPositionP pos l || HasTotalPositionP pos r+    = Alt (HasTotalPositionP pos l) (HasTotalPositionP pos r)   HasTotalPositionP pos (l :+: r)-    = HasTotalPositionP pos l && HasTotalPositionP pos r+    = Both (HasTotalPositionP pos l) (HasTotalPositionP pos r)   HasTotalPositionP pos (S1 _ _)-    = 'False+    = 'Nothing   HasTotalPositionP pos (C1 _ f)     = HasTotalPositionP pos f   HasTotalPositionP pos (D1 _ f)     = HasTotalPositionP pos f   HasTotalPositionP pos (K1 _ _)-    = 'False+    = 'Nothing   HasTotalPositionP pos U1-    = 'False+    = 'Nothing   HasTotalPositionP pos V1-    = 'False+    = 'Nothing  type family HasPartialTypeP a f :: Bool where   HasPartialTypeP t (l :+: r)@@ -116,11 +123,11 @@   HasCtorP ctor _     = 'False -type family GTypes (rep :: Type -> Type) :: [((), Type)] where+type family GTypes (rep :: Type -> Type) :: [Type] where   GTypes (l :*: r)     = GTypes l ++ GTypes r   GTypes (K1 _ a)-    = '[ '( '(), a)]+    = '[ a]   GTypes (M1 _ m a)     = GTypes a   GTypes U1 = '[]

@@ -1,3 +1,4 @@+{-# LANGUAGE TupleSections #-} {-# LANGUAGE GADTs                     #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE Rank2Types                #-}@@ -9,7 +10,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Generics.Internal.Profunctor.Iso--- Copyright   :  (C) 2017 Csongor Kiss+-- Copyright   :  (C) 2018 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental@@ -26,6 +27,8 @@ import Data.Coerce import Data.Generics.Internal.GenericN (Rec (..)) +import qualified Data.Generics.Internal.VL.Iso as VL+ type Iso s t a b   = forall p. (Profunctor p) => p a b -> p s t @@ -73,6 +76,10 @@ iso :: (s -> a) -> (b -> t) -> Iso s t a b iso = dimap {-# INLINE iso #-}++iso2isovl :: Iso s t a b -> VL.Iso s t a b+iso2isovl _iso = withIso _iso VL.iso+{-# INLINE iso2isovl #-}  withIso :: Iso s t a b -> ((s -> a) -> (b -> t) -> r) -> r withIso ai k = case ai (Exchange id id) of

@@ -10,7 +10,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Generics.Internal.Profunctor.Lens--- Copyright   :  (C) 2017 Csongor Kiss+-- Copyright   :  (C) 2018 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental

@@ -10,7 +10,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Generics.Internal.Profunctor.Prism--- Copyright   :  (C) 2017 Csongor Kiss+-- Copyright   :  (C) 2018 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental@@ -21,6 +21,7 @@ ----------------------------------------------------------------------------- module Data.Generics.Internal.Profunctor.Prism where +import Data.Bifunctor         (bimap) import Data.Profunctor        (Choice(..), Profunctor(..)) import Data.Tagged import Data.Profunctor.Unsafe ((#.), (.#))@@ -44,12 +45,12 @@ prism bt seta eta = dimap seta (either id bt) (right' eta)  _Left :: Prism (Either a c) (Either b c) a b-_Left = prism Left $ either Right (Left . Right)+_Left = left'  _Right :: Prism (Either c a) (Either c b) a b-_Right = prism Right $ either (Left . Left) Right+_Right = right' -prismPRavel :: (Market a b a b -> Market a b s t) -> Prism s t a b+prismPRavel :: APrism s t a b -> Prism s t a b prismPRavel l pab = (prism2prismp $ l idPrism) pab  build :: (Tagged b b -> Tagged t t) -> b -> t@@ -65,9 +66,7 @@ without' k =   withPrism k  $ \bt _ k' ->   withPrism k' $ \dt setc ->-    prism (foldEither bt dt) $ \s -> fmap Right (setc s)-  where foldEither _ g (Right r) = g r-        foldEither f _ (Left l) = f l+    prism (either bt dt) $ \s -> fmap Right (setc s) {-# INLINE without' #-}  withPrism :: APrism s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r@@ -85,8 +84,7 @@ gsum _ g (R1 y) =  g y  plus :: (a -> b) -> (c -> d) -> Either a c -> Either b d-plus f _ (Left x) = Left (f x)-plus _ g (Right y) = Right (g y)+plus = bimap  -------------------------------------------------------------------------------- -- Market

@@ -9,7 +9,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Generics.Internal.VL.Iso--- Copyright   :  (C) 2017 Csongor Kiss+-- Copyright   :  (C) 2018 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental@@ -20,15 +20,42 @@ ----------------------------------------------------------------------------- module Data.Generics.Internal.VL.Iso where -import Data.Profunctor        (Profunctor(..))+import Data.Coerce (coerce)+import Data.Functor.Identity (Identity(..))+import Data.Profunctor (Profunctor(..)) import GHC.Generics import Data.Generics.Internal.GenericN (Rec (..)) +data Exchange a b s t = Exchange (s -> a) (b -> t)++instance Functor (Exchange a b s) where+  fmap f (Exchange sa bt) = Exchange sa (f . bt)+  {-# INLINE fmap #-}++instance Profunctor (Exchange a b) where+  dimap f g (Exchange sa bt) = Exchange (sa . f) (g . bt)+  {-# INLINE dimap #-}+  lmap f (Exchange sa bt) = Exchange (sa . f) bt+  {-# INLINE lmap #-}+  rmap f (Exchange sa bt) = Exchange sa (f . bt)+  {-# INLINE rmap #-}+ type Iso' s a   = forall p f. (Profunctor p, Functor f) => p a (f a) -> p s (f s)  type Iso s t a b   = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t)++fromIso :: Iso s t a b -> Iso b a t s+fromIso l = withIso l $ \ sa bt -> iso bt sa+{-# inline fromIso #-}++-- | Extract the two functions, one from @s -> a@ and+-- one from @b -> t@ that characterize an 'Iso'.+withIso :: Iso s t a b -> ((s -> a) -> (b -> t) -> r) -> r+withIso ai k = case ai (Exchange id Identity) of+  Exchange sa bt -> k sa (coerce bt)+{-# inline withIso #-}  -- | A type and its generic representation are isomorphic repIso :: (Generic a, Generic b) => Iso a b (Rep a x) (Rep b x)

@@ -10,7 +10,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Generics.Internal.VL.Lens--- Copyright   :  (C) 2017 Csongor Kiss+-- Copyright   :  (C) 2018 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental@@ -22,6 +22,7 @@ module Data.Generics.Internal.VL.Lens where  import Control.Applicative    (Const(..))+import Data.Coerce            (coerce) import Data.Functor.Identity  (Identity(..)) import Data.Generics.Internal.Profunctor.Lens (ALens (..), idLens) @@ -46,6 +47,9 @@  set :: Lens s t a b -> b -> s -> t set l x = l .~ x++over :: ((a -> Identity b) -> s -> Identity t) -> (a -> b) -> s -> t+over = coerce  lens2lensvl :: ALens a b s t -> Lens s t a b lens2lensvl (ALens _get _set) =

@@ -9,7 +9,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Generics.Internal.VL.Prism--- Copyright   :  (C) 2017 Csongor Kiss+-- Copyright   :  (C) 2018 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental

@@ -11,7 +11,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Generics.Internal.VL.Traversal--- Copyright   :  (C) 2017 Csongor Kiss+-- Copyright   :  (C) 2018 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental

@@ -0,0 +1,142 @@+{-# LANGUAGE AllowAmbiguousTypes    #-}+{-# LANGUAGE CPP                    #-}+{-# LANGUAGE ConstraintKinds        #-}+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE PolyKinds              #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TypeApplications       #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE TypeFamilies           #-}+{-# LANGUAGE UndecidableInstances   #-}+{-# OPTIONS_GHC -Wno-orphans        #-}++--------------------------------------------------------------------------------+-- |+-- Module      : Data.Generics.Labels+-- Copyright   : (C) 2018 Csongor Kiss+-- License     : BSD3+-- Maintainer  : Csongor Kiss <kiss.csongor.kiss@gmail.com>+-- Stability   : experimental+-- Portability : non-portable+--+-- Provides an (orphan) IsLabel instance for field lenses and constructor prisms.+-- Use at your own risk.+--------------------------------------------------------------------------------++module Data.Generics.Labels+  ( -- * Orphan IsLabel Instance+    -- $sec1+    Field(..)+  , Field'+  , Constructor(..)+  , Constructor'+  ) where++import Data.Generics.Product+import Data.Generics.Sum+import Data.Generics.Internal.VL.Lens  (Lens)+import Data.Generics.Internal.VL.Prism (Prism)++import Data.Profunctor    (Choice)+import Data.Type.Bool     (type (&&))+import Data.Type.Equality (type (==))++import GHC.OverloadedLabels+import GHC.TypeLits++-- $sec1+-- An instance for creating lenses and prisms with @#identifiers@ from the+-- @OverloadedLabels@ extension.  Note that since overloaded labels do not+-- support symbols starting with capital letters, all prisms (which come from+-- constructor names, which are capitalized) must be prefixed with an underscore+-- (e.g. @#_ConstructorName@).+--+-- Morally:+--+-- @+-- instance (HasField name s t a b) => IsLabel name (Lens s t a b) where ...+-- @+-- and+--+-- @+-- instance (AsConstructor name s t a b) => IsLabel name (Prism s t a b) where ...+-- @+--+-- Remember:+--+-- @+-- type Lens = forall f. Functor f => (a -> f b) -> s -> f t+--+-- type Prism s t a b = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t)+-- @+--+-- The orphan instance is unavoidable if we want to work with+-- lenses-as-functions (as opposed to a 'ReifiedLens'-like newtype).++-- | 'Field' is morally the same as 'HasField', but it is constructed from an+-- incoherent combination of 'HasField' and 'HasField''.  In this way, it can be+-- seamlessly used in the 'IsLabel' instance even when dealing with data types+-- that don't have 'Field' instances (like data instances).+class Field name s t a b | s name -> a, t name -> b, s name b -> t, t name a -> s where+  fieldLens :: Lens s t a b++type Field' name s a = Field name s s a a++instance {-# INCOHERENT #-} HasField name s t a b => Field name s t a b where+  fieldLens = field @name++instance {-# INCOHERENT #-} HasField' name s a => Field name s s a a where+  fieldLens = field' @name++-- | 'Constructor' is morally the same as 'AsConstructor', but it is constructed from an+-- incoherent combination of 'AsConstructor' and 'AsConstructor''.  In this way, it can be+-- seamlessly used in the 'IsLabel' instance even when dealing with data types+-- that don't have 'Constructor' instances (like data instances).+class Constructor name s t a b | name s -> a, name t -> b where+  constructorPrism :: Prism s t a b++type Constructor' name s a = Constructor name s s a a++instance {-# INCOHERENT #-} AsConstructor name s t a b => Constructor name s t a b where+  constructorPrism = _Ctor @name++instance {-# INCOHERENT #-} AsConstructor' name s a => Constructor name s s a a where+  constructorPrism = _Ctor' @name++type family BeginsWithCapital (name :: Symbol) :: Bool where+  BeginsWithCapital name = CmpSymbol "_@" name == 'LT && CmpSymbol "_[" name == 'GT++instance ( capital ~ BeginsWithCapital name+         , IsLabelHelper capital name p f s t a b+         , pafb ~ p a (f b), psft ~ p s (f t)) => IsLabel name (pafb -> psft) where+#if __GLASGOW_HASKELL__ >= 802+  fromLabel = labelOutput @capital @name @p @f+#else+  fromLabel _ = labelOutput @capital @name @p @f+#endif++-- | This helper class allows us to customize the output type of the lens to be+-- either 'Prism' or 'Lens' (by choosing appropriate @p@ and @f@) as well as to+-- choose between whether we're dealing with a lens or a prism.  The choice is+-- made by whether the @capital@ argument is true or false, which is determined by+-- whether the symbol starts with an underscore followed by a capital letter+-- (a check done in the 'IsLabel' instance above).  If so, then we're dealing+-- with a constructor name, which should be a prism, and otherwise, it's a field+-- name, so we have a lens.+class IsLabelHelper capital name p f s t a b where+  labelOutput :: p a (f b) -> p s (f t)++instance (Functor f, Field name s t a b) => IsLabelHelper 'False name (->) f s t a b where+  labelOutput = fieldLens @name++#if __GLASGOW_HASKELL__ >= 802+instance ( Applicative f, Choice p, Constructor name s t a b+         , name' ~ AppendSymbol "_" name) => IsLabelHelper 'True name' p f s t a b where+  labelOutput = constructorPrism @name+#else+instance (TypeError ('Text "Labels for Prisms require at least GHC 8.2"), Choice p) => IsLabelHelper 'True name' p f s t a b where+  labelOutput = undefined+#endif

@@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Generics.Product--- Copyright   :  (C) 2017 Csongor Kiss+-- Copyright   :  (C) 2018 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental@@ -22,7 +22,7 @@   , module Data.Generics.Product.Positions   , module Data.Generics.Product.Subtype   , module Data.Generics.Product.Typed-  , module Data.Generics.Product.List+  , module Data.Generics.Product.HList   -- *Traversals   , module Data.Generics.Product.Types   , module Data.Generics.Product.Param@@ -37,4 +37,4 @@ import Data.Generics.Product.Types import Data.Generics.Product.Constraints import Data.Generics.Product.Param-import Data.Generics.Product.List+import Data.Generics.Product.HList

@@ -12,7 +12,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Generics.Product.Any--- Copyright   :  (C) 2017 Csongor Kiss+-- Copyright   :  (C) 2018 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental

@@ -16,7 +16,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Generics.Product.Fields--- Copyright   :  (C) 2017 Csongor Kiss+-- Copyright   :  (C) 2018 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental@@ -32,6 +32,7 @@     -- $setup     HasField (..)   , HasField' (..)+  , HasField_ (..)    , getField   , setField@@ -111,9 +112,30 @@   --  ...   field :: VL.Lens s t a b +-- |Records that have a field with a given name.+--+-- This is meant to be more general than 'HasField', but that is not quite the+-- case due to the lack of functional dependencies.+--+-- The types @s@ and @t@ must be applications of the same type constructor.+-- In contrast, 'HasField' also requires the parameters of that type constructor+-- to have representational roles.+--+-- One use case of 'HasField_' over 'HasField' is for records defined with+-- @data instance@.+class HasField_ (field :: Symbol) s t a b where+  field_ :: VL.Lens s t a b+ class HasField' (field :: Symbol) s a | s field -> a where   field' :: VL.Lens s s a a +-- |Records that have a field with a given name.+--+-- This class gives the minimal constraints needed to define this lens.+-- For common uses, see 'HasField'.+class HasField0 (field :: Symbol) s t a b where+  field0 :: VL.Lens s t a b+ -- | -- >>> getField @"age" human -- 50@@ -133,31 +155,49 @@   ) => HasField' field s a where   field' f s = VL.ravel (repLens . glens @(HasTotalFieldPSym field)) f s +class (~~) (a :: k) (b :: k) | a -> b, b -> a+instance (a ~ b) => (~~) a b+ instance  -- see Note [Changing type parameters]   ( Generic s-  , ErrorUnless field s (CollectField field (Rep s))   , Generic t-  -- see Note [CPP in instance constraints]-#if __GLASGOW_HASKELL__ < 802-  , '(s', t') ~ '(Proxied s, Proxied t)-#else-  , s' ~ Proxied s-  , t' ~ Proxied t-#endif-  , Generic s'-  , Generic t'-  , GLens' (HasTotalFieldPSym field) (Rep s') a'-  , GLens' (HasTotalFieldPSym field) (Rep t') b'+  , ErrorUnless field s (CollectField field (Rep s))+  , HasTotalFieldP field (Rep s) ~~ 'Just a+  , HasTotalFieldP field (Rep t) ~~ 'Just b+  , HasTotalFieldP field (Rep (Indexed s)) ~~ 'Just a'+  , HasTotalFieldP field (Rep (Indexed t)) ~~ 'Just b'+  , t ~~ Infer s a' b+  , s ~~ Infer t b' a   , 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 . glens @(HasTotalFieldPSym field)) f s+  field f s = field0 @field f s  -- -- See Note [Uncluttering type signatures] instance {-# OVERLAPPING #-} HasField f (Void1 a) (Void1 b) a b where   field = undefined +instance+  ( Generic s+  , Generic t+  , ErrorUnless field s (CollectField field (Rep s))+  , HasTotalFieldP field (Rep s) ~~ 'Just a+  , HasTotalFieldP field (Rep t) ~~ 'Just b+  , UnifyHead s t+  , UnifyHead t s+  , GLens  (HasTotalFieldPSym field) (Rep s) (Rep t) a b+  ) => HasField_ field s t a b where+  field_ f s = field0 @field f s++instance {-# OVERLAPPING #-} HasField_ f (Void1 a) (Void1 b) a b where+  field_ = undefined++instance+  ( Generic s+  , Generic t+  , GLens  (HasTotalFieldPSym field) (Rep s) (Rep t) a b+  ) => HasField0 field s t a b where+  field0 = VL.ravel (repLens . glens @(HasTotalFieldPSym field))+ type family ErrorUnless (field :: Symbol) (s :: Type) (stat :: TypeStat) :: Constraint where   ErrorUnless field s ('TypeStat _ _ '[])     = TypeError@@ -180,5 +220,5 @@   ErrorUnless _ _ ('TypeStat '[] '[] _)     = () -data HasTotalFieldPSym :: Symbol -> (TyFun (Type -> Type) Bool)+data HasTotalFieldPSym :: Symbol -> (TyFun (Type -> Type) (Maybe Type)) type instance Eval (HasTotalFieldPSym sym) tt = HasTotalFieldP sym tt

@@ -0,0 +1,46 @@+{-# LANGUAGE AllowAmbiguousTypes    #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MonoLocalBinds         #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TypeInType             #-}+{-# LANGUAGE UndecidableInstances   #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Generics.Product.HList+-- Copyright   :  (C) 2018 Csongor Kiss+-- License     :  BSD3+-- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Derive an isomorphism between a product type and a flat HList.+--+-----------------------------------------------------------------------------++module Data.Generics.Product.HList+  ( IsList (..)+  ) where++import Data.Generics.Product.Internal.HList+import Data.Kind+import GHC.Generics+import Data.Generics.Internal.VL.Iso (Iso)+import Data.Generics.Internal.Profunctor.Iso (repIso, iso2isovl)++class IsList+  (f :: Type)+  (g :: Type)+  (as :: [Type])+  (bs :: [Type]) | f -> as, g -> bs where+  list  :: Iso f g (HList as) (HList bs)++instance+  ( Generic f+  , Generic g+  , GIsList (Rep f) (Rep g) as bs+  ) => IsList f g as bs where+  list = iso2isovl (repIso . glist)+  {-# INLINE list #-}

@@ -15,7 +15,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Generics.Product.Internal.Constraints--- Copyright   :  (C) 2017 Csongor Kiss+-- Copyright   :  (C) 2018 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental@@ -31,13 +31,13 @@   (     GHasConstraints (..)   , GHasConstraints' (..)-  , HList (..)   ) where  import Data.Kind (Type, Constraint) import GHC.Generics import Data.Generics.Internal.VL.Iso import Data.Generics.Internal.VL.Traversal+import Data.Generics.Product.Internal.HList  -- | Constrained traversal. class GHasConstraints' (c :: * -> Constraint) (f :: * -> *) where@@ -116,11 +116,6 @@ -}  ----------------------------------------------------------------------------------data HList (ts :: [Type]) where-  HNil :: HList '[]-  (:>) :: a -> HList as -> HList (a ': as)-infixr 5 :>  -- >>> :kind! Functions '[Int, Char, Bool] Maybe -- '[Int -> Maybe Int, Char -> Maybe Char, Bool -> Maybe Bool]

@@ -17,7 +17,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Generics.Product.Internal.GLens--- Copyright   :  (C) 2017 Csongor Kiss+-- Copyright   :  (C) 2018 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental@@ -40,11 +40,13 @@ import Data.Kind    (Type) import GHC.Generics +type Pred = TyFun (Type -> Type) (Maybe Type)+ 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+class GLens (pred :: Pred) (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@@ -52,7 +54,7 @@ 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+  glens = gproductLens @(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@@ -63,17 +65,17 @@   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+instance (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+class GProductLens (left :: Maybe Type) (pred :: Pred) l r l' r' a b | pred l r -> a, pred l' r' -> b where+  gproductLens :: 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 l l' a b => GProductLens ('Just x) pred l r l' r a b where+  gproductLens = first . glens @pred+  {-# INLINE gproductLens #-} -instance GLens pred r r' a b => GProductLens 'False pred l r l r' a b where-  gproductField = second . glens @pred-  {-# INLINE gproductField #-}+instance GLens pred r r' a b => GProductLens 'Nothing pred l r l r' a b where+  gproductLens = second . glens @pred+  {-# INLINE gproductLens #-}

@@ -0,0 +1,329 @@+{-# LANGUAGE AllowAmbiguousTypes    #-}+{-# LANGUAGE CPP                    #-}+{-# LANGUAGE ConstraintKinds        #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs                  #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TupleSections          #-}+{-# 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.HList+-- Copyright   :  (C) 2018 Csongor Kiss+-- License     :  BSD3+-- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Derive an isomorphism between a product type and a flat HList.+--+-----------------------------------------------------------------------------++module Data.Generics.Product.Internal.HList+  ( GIsList(..)+  , IndexList (..)+  , HList (..)+  , type (++)+  , Elem+  , ListTuple (..)+  , TupleToList+  ) where++#if __GLASGOW_HASKELL__ < 804+import Data.Semigroup+#endif+import GHC.TypeLits++import Data.Kind    (Type)+import GHC.Generics+import Data.Profunctor+import Data.Generics.Internal.Profunctor.Lens+import Data.Generics.Internal.Profunctor.Iso++data HList (as :: [Type]) where+  Nil :: HList '[]+  (:>) :: a -> HList as -> HList (a ': as)++infixr 5 :>++type family ((as :: [k]) ++ (bs :: [k])) :: [k] where+  '[]       ++ bs = bs+  (a ': as) ++ bs = a ': as ++ bs++instance Semigroup (HList '[]) where+  _ <> _ = Nil++instance Monoid (HList '[]) where+  mempty  = Nil+  mappend _ _ = Nil++instance (Semigroup a, Semigroup (HList as)) => Semigroup (HList (a ': as)) where+  (x :> xs) <> (y :> ys) = (x <> y) :> (xs <> ys)++instance (Monoid a, Monoid (HList as)) => Monoid (HList (a ': as)) where+  mempty = mempty :> mempty+  mappend (x :> xs) (y :> ys) = mappend x y :> mappend xs ys++class Elem (as :: [(k, Type)]) (key :: k) (i :: Nat) a | as key -> i a+instance {-# OVERLAPPING #-} pos ~ 0 => Elem (a ': xs) key pos a+instance (Elem xs key i a, pos ~ (i + 1)) => Elem (x ': xs) key pos a++class GIsList+  (f :: Type -> Type)+  (g :: Type -> Type)+  (as :: [Type])+  (bs :: [Type]) | f -> as, g -> bs, bs f -> g, as g -> f where++  glist :: Iso (f x) (g x) (HList as) (HList bs)++  -- We define this reversed version, otherwise uses of `fromIso glist` are not+  -- properly inlined by GHC 8.0.2.+  -- This is not actually used.+  glistR :: Iso (HList bs) (HList as) (g x) (f x)+  glistR = fromIso glist++instance+  ( GIsList l l' as as'+  , GIsList r r' bs bs'+  , Appending as bs cs as' bs' cs'+  , cs ~ (as ++ bs)+  , cs' ~ (as' ++ bs')+  ) => GIsList (l :*: r) (l' :*: r') cs cs' where++  glist = prodIso . pairing glist glist . appending+  {-# INLINE glist #-}++instance GIsList f g as bs => GIsList (M1 t meta f) (M1 t meta g) as bs where+  glist = mIso . glist+  {-# INLINE glist #-}++instance GIsList (Rec0 a) (Rec0 b) '[a] '[b] where+  glist = kIso . singleton+  {-# INLINE glist #-}++instance GIsList U1 U1 '[] '[] where+  glist = iso (const Nil) (const U1)+  {-# INLINE glist #-}++--------------------------------------------------------------------------------+-- | as ++ bs === cs+class Appending as bs cs as' bs' cs'+  | as bs cs cs'   -> as' bs'+  , as' bs' cs cs' -> as bs+  , as bs          -> cs+  , as' bs'        -> cs'+  where+  appending :: Iso (HList as, HList bs) (HList as', HList bs') (HList cs) (HList cs')++-- | [] ++ bs === bs+instance Appending '[] bs bs '[] bs' bs' where+  appending = iso snd (Nil,)++-- | (a : as) ++ bs === (a : cs)+instance+  Appending as bs cs as' bs' cs' -- as ++ bs == cs+  => Appending (a ': as) bs (a ': cs) (a' ': as') bs' (a' ': cs') where+  appending+    = pairing (fromIso consing) id -- ((a, as), bs)+    . assoc3                       -- (a, (as, bs))+    . pairing id appending         -- (a, cs)+    . consing                      -- (a : cs)++singleton :: Iso a b (HList '[a]) (HList '[ b])+singleton = iso (:> Nil) (\(x :> _) -> x)++consing :: Iso (a, HList as) (b, HList bs) (HList (a ': as)) (HList (b ': bs))+consing = iso (\(x, xs) -> x :> xs) (\(x :> xs) -> (x, xs))++--------------------------------------------------------------------------------+class IndexList (i :: Nat) as bs a b | i as -> a, i bs -> b, i as b -> bs, i bs a -> as where+  point :: Lens (HList as) (HList bs) a b++instance {-# OVERLAPPING #-}+  ( as ~ (a ': as')+  , bs ~ (b ': as')+  ) => IndexList 0 as bs a b where+  point = lens (\(x :> xs) -> (xs, x)) (\(xs, x') -> x' :> xs)+  {-# INLINE point #-}++instance+  ( IndexList (n - 1) as' bs' a b+  , as ~ (x ': as')+  , bs ~ (x ': bs')+  ) => IndexList n as bs a b where+  point = fromIso consing . alongside id (point @(n-1)) . second'+  {-# INLINE point #-}++--------------------------------------------------------------------------------+-- * Convert tuples to/from HLists++class ListTuple (tuple :: Type) (as :: [Type]) | as -> tuple where+  type ListToTuple as :: Type+  tupled :: Iso' (HList as) tuple+  tupled = iso listToTuple tupleToList++  tupleToList :: tuple -> HList as+  listToTuple :: HList as -> tuple++instance ListTuple () '[] where+  type ListToTuple '[] = ()+  tupleToList _ = Nil+  listToTuple _ = ()++instance ListTuple a '[a] where+  type ListToTuple '[a] = a+  tupleToList a+    = a :> Nil+  listToTuple (a :> Nil)+    = a++instance ListTuple (a, b) '[a, b] where+  type ListToTuple '[a, b] = (a, b)+  tupleToList (a, b)+    = a :> b :> Nil+  listToTuple (a :> b :> Nil)+    = (a, b)++instance ListTuple (a, b, c) '[a, b, c] where+  type ListToTuple '[a, b, c] = (a, b, c)+  tupleToList (a, b, c)+    = a :> b :> c :> Nil+  listToTuple (a :> b :> c :> Nil)+    = (a, b, c)++instance ListTuple (a, b, c, d) '[a, b, c, d] where+  type ListToTuple '[a, b, c, d] = (a, b, c, d)+  tupleToList (a, b, c, d)+    = a :> b :> c :> d:> Nil+  listToTuple (a :> b :> c :> d :> Nil)+    = (a, b, c, d)++instance ListTuple (a, b, c, d, e) '[a, b, c, d, e] where+  type ListToTuple '[a, b, c, d, e] = (a, b, c, d, e)+  tupleToList (a, b, c, d, e)+    = a :> b :> c :> d:> e :> Nil+  listToTuple (a :> b :> c :> d :> e :> Nil)+    = (a, b, c, d, e)++instance ListTuple (a, b, c, d, e, f) '[a, b, c, d, e, f] where+  type ListToTuple '[a, b, c, d, e, f] = (a, b, c, d, e, f)+  tupleToList (a, b, c, d, e, f)+    = a :> b :> c :> d:> e :> f :> Nil+  listToTuple (a :> b :> c :> d :> e :> f :> Nil)+    = (a, b, c, d, e, f)++instance ListTuple (a, b, c, d, e, f, g) '[a, b, c, d, e, f, g] where+  type ListToTuple '[a, b, c, d, e, f, g] = (a, b, c, d, e, f, g)+  tupleToList (a, b, c, d, e, f, g)+    = a :> b :> c :> d:> e :> f :> g :> Nil+  listToTuple (a :> b :> c :> d :> e :> f :> g :> Nil)+    = (a, b, c, d, e, f, g)++instance ListTuple (a, b, c, d, e, f, g, h) '[a, b, c, d, e, f, g, h] where+  type ListToTuple '[a, b, c, d, e, f, g, h] = (a, b, c, d, e, f, g, h)+  tupleToList (a, b, c, d, e, f, g, h)+    = a :> b :> c :> d:> e :> f :> g :> h :> Nil+  listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> Nil)+    = (a, b, c, d, e, f, g, h)++instance ListTuple (a, b, c, d, e, f, g, h, j) '[a, b, c, d, e, f, g, h, j] where+  type ListToTuple '[a, b, c, d, e, f, g, h, j] = (a, b, c, d, e, f, g, h, j)+  tupleToList (a, b, c, d, e, f, g, h, j)+    = a :> b :> c :> d:> e :> f :> g :> h :> j :> Nil+  listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> Nil)+    = (a, b, c, d, e, f, g, h, j)++instance ListTuple (a, b, c, d, e, f, g, h, j, k) '[a, b, c, d, e, f, g, h, j, k] where+  type ListToTuple '[a, b, c, d, e, f, g, h, j, k] = (a, b, c, d, e, f, g, h, j, k)+  tupleToList (a, b, c, d, e, f, g, h, j, k)+    = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> Nil+  listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> Nil)+    = (a, b, c, d, e, f, g, h, j, k)++instance ListTuple (a, b, c, d, e, f, g, h, j, k, l) '[a, b, c, d, e, f, g, h, j, k, l] where+  type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l] = (a, b, c, d, e, f, g, h, j, k, l)+  tupleToList (a, b, c, d, e, f, g, h, j, k, l)+    = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> Nil+  listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> Nil)+    = (a, b, c, d, e, f, g, h, j, k, l)++instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m) '[a, b, c, d, e, f, g, h, j, k, l, m] where+  type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l, m] = (a, b, c, d, e, f, g, h, j, k, l, m)+  tupleToList (a, b, c, d, e, f, g, h, j, k, l, m)+    = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> Nil+  listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> Nil)+    = (a, b, c, d, e, f, g, h, j, k, l, m)++instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n) '[a, b, c, d, e, f, g, h, j, k, l, m, n] where+  type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l, m, n] = (a, b, c, d, e, f, g, h, j, k, l, m, n)+  tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n)+    = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> Nil+  listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> Nil)+    = (a, b, c, d, e, f, g, h, j, k, l, m, n)++instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o) '[a, b, c, d, e, f, g, h, j, k, l, m, n, o] where+  type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l, m, n, o] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o)+  tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o)+    = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> Nil+  listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> Nil)+    = (a, b, c, d, e, f, g, h, j, k, l, m, n, o)++instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p) '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p] where+  type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)+  tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)+    = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> Nil+  listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> Nil)+    = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)++instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q) '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q] where+  type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)+  tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)+    = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> Nil+  listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> Nil)+    = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)++instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r) '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r] where+  type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)+  tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)+    = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> Nil+  listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> Nil)+    = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)++instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s) '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s] where+  type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)+  tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)+    = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> s :> Nil+  listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> s :> Nil)+    = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)++type family TupleToList a where+  TupleToList () = '[]+  TupleToList (a, b) = '[a, b]+  TupleToList (a, b, c) = '[a, b, c]+  TupleToList (a, b, c, d) = '[a, b, c, d]+  TupleToList (a, b, c, d, e) = '[a, b, c, d, e]+  TupleToList (a, b, c, d, e, f) = '[a, b, c, d, e, f]+  TupleToList (a, b, c, d, e, f, g) = '[a, b, c, d, e, f, g]+  TupleToList (a, b, c, d, e, f, g, h) = '[a, b, c, d, e, f, g, h]+  TupleToList (a, b, c, d, e, f, g, h, j) = '[a, b, c, d, e, f, g, h, j]+  TupleToList (a, b, c, d, e, f, g, h, j, k) = '[a, b, c, d, e, f, g, h, j, k]+  TupleToList (a, b, c, d, e, f, g, h, j, k, l) = '[a, b, c, d, e, f, g, h, j, k, l]+  TupleToList (a, b, c, d, e, f, g, h, j, k, l, m) = '[a, b, c, d, e, f, g, h, j, k, l, m]+  TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n) = '[a, b, c, d, e, f, g, h, j, k, l, m, n]+  TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o) = '[a, b, c, d, e, f, g, h, j, k, l, m, n, o]+  TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p) = '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p]+  TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q) = '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q]+  TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r) = '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r]+  TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s) = '[a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s]+  TupleToList a = '[a]

@@ -1,337 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes    #-}-{-# LANGUAGE CPP                    #-}-{-# LANGUAGE ConstraintKinds        #-}-{-# LANGUAGE FlexibleInstances      #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE GADTs                  #-}-{-# LANGUAGE ScopedTypeVariables    #-}-{-# LANGUAGE TupleSections          #-}-{-# 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.List--- Copyright   :  (C) 2017 Csongor Kiss--- License     :  BSD3--- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com>--- Stability   :  experimental--- Portability :  non-portable------ Derive an isomorphism between a product type and a flat HList.-----------------------------------------------------------------------------------module Data.Generics.Product.Internal.List-  ( GIsList (..)-  , IndexList (..)-  , List (..)-  , type (++)-  , Elem-  , ListTuple (..)-  , TupleToList-  ) where--#if __GLASGOW_HASKELL__ < 804-import Data.Semigroup-#endif-import GHC.TypeLits--import Data.Kind    (Type)-import GHC.Generics-import Data.Profunctor-import Data.Generics.Internal.Profunctor.Lens-import Data.Generics.Internal.Profunctor.Iso--data List (as :: [(m, Type)]) where-  Nil :: List '[]-  (:>) :: a -> List as -> List ('(s, a) ': as)--infixr 5 :>--type family ((as :: [k]) ++ (bs :: [k])) :: [k] where-  '[]       ++ bs = bs-  (a ': as) ++ bs = a ': as ++ bs--instance Semigroup (List '[]) where-  _ <> _ = Nil--instance Monoid (List '[]) where-  mempty  = Nil-  mappend _ _ = Nil--instance (Semigroup a, Semigroup (List as)) => Semigroup (List ('(k, a) ': as)) where-  (x :> xs) <> (y :> ys) = (x <> y) :> (xs <> ys)--instance (Monoid a, Monoid (List as)) => Monoid (List ('(k, a) ': as)) where-  mempty = mempty :> mempty-  mappend (x :> xs) (y :> ys) = mappend x y :> mappend xs ys--class Elem (as :: [(k, Type)]) (key :: k) (i :: Nat) a | as key -> i a-instance {-# OVERLAPPING #-} pos ~ 0 => Elem ('(key, a) ': xs) key pos a-instance (Elem xs key i a, pos ~ (i + 1)) => Elem (x ': xs) key pos a--class GIsList-  (m :: Type)-  (f :: Type -> Type)-  (g :: Type -> Type)-  (as :: [(m, Type)])-  (bs :: [(m, Type)]) | m f -> as, m g -> bs, bs f -> g, as g -> f where--  glist :: Iso (f x) (g x) (List as) (List bs)--  -- We define this reversed version, otherwise uses of `fromIso glist` are not-  -- properly inlined by GHC 8.0.2.-  -- This is not actually used.-  glistR :: Iso (List bs) (List as) (g x) (f x)-  glistR = fromIso (glist @m)--instance-  ( GIsList m l l' as as'-  , GIsList m r r' bs bs'-  , Appending List as bs cs as' bs' cs'-  , cs ~ (as ++ bs)-  , cs' ~ (as' ++ bs')-  ) => GIsList m (l :*: r) (l' :*: r') cs cs' where--  glist = prodIso . pairing (glist @m) (glist @m) . appending-  {-# INLINE glist #-}--instance GIsList m f g as bs => GIsList m (M1 t meta f) (M1 t meta g) as bs where-  glist = mIso . glist @m-  {-# INLINE glist #-}--instance {-# OVERLAPS #-}-  GIsList Symbol-          (S1 ('MetaSel ('Just field) u s i) (Rec0 a))-          (S1 ('MetaSel ('Just field) u s i) (Rec0 b))-          '[ '(field, a)] '[ '(field, b)] where-  glist = mIso . kIso . singleton-  {-# INLINE glist #-}--instance GIsList Type (Rec0 a) (Rec0 a) '[ '(a, a)] '[ '(a, a)] where-  glist = kIso . singleton-  {-# INLINE glist #-}--instance GIsList () (Rec0 a) (Rec0 b) '[ '( '(), a)] '[ '( '(), b)] where-  glist = kIso . singleton-  {-# INLINE glist #-}--instance GIsList m U1 U1 '[] '[] where-  glist = iso (const Nil) (const U1)-  {-# INLINE glist #-}------------------------------------------------------------------------------------- | as ++ bs === cs-class Appending f (as :: [k]) bs cs (as' :: [k]) bs' cs' | as bs cs cs' -> as' bs', as' bs' cs cs' -> as bs, as bs -> cs, as' bs' -> cs' where-  appending :: Iso (f as, f bs) (f as', f bs') (f cs) (f cs')---- | [] ++ bs === bs-instance Appending List '[] bs bs '[] bs' bs' where-  appending = iso (\(_, b) -> b) (Nil,)---- | (a : as) ++ bs === (a : cs)-instance-  Appending List as bs cs as' bs' cs' -- as ++ bs == cs-  => Appending List ('(f, a) ': as) bs ('(f, a) ': cs) ('(f, a') ': as') bs' ('(f, a') ': cs') where-  appending-    = pairing (fromIso consing) id -- ((a, as), bs)-    . assoc3                       -- (a, (as, bs))-    . pairing id appending         -- (a, cs)-    . consing                      -- (a : cs)--singleton :: Iso a b (List '[ '(field, a)]) (List '[ '(field, b)])-singleton = iso (:> Nil) (\(x :> _) -> x)--consing :: Iso (a, List as) (b, List bs) (List ('(f, a) ': as)) (List ('(f, b) ': bs))-consing = iso (\(x, xs) -> x :> xs) (\(x :> xs) -> (x, xs))-----------------------------------------------------------------------------------class IndexList (i :: Nat) as bs a b | i as -> a, i bs -> b, i as b -> bs, i bs a -> as where-  point :: Lens (List as) (List bs) a b--instance {-# OVERLAPPING #-}-  ( as ~ ('(f, a) ': as')-  , bs ~ ('(f, b) ': as')-  ) => IndexList 0 as bs a b where-  point = lens (\(x :> xs) -> (xs, x)) (\(xs, x') -> x' :> xs)-  {-# INLINE point #-}--instance-  ( IndexList (n - 1) as' bs' a b-  , as ~ ('(f, x) ': as')-  , bs ~ ('(f, x) ': bs')-  ) => IndexList n as bs a b where-  point = fromIso consing . alongside id (point @(n-1)) . second'-  {-# INLINE point #-}------------------------------------------------------------------------------------- * Convert tuples to/from HLists--class ListTuple (tuple :: Type) (as :: [(k, Type)]) | as -> tuple where-  type ListToTuple as :: Type-  tupled :: Iso' (List as) tuple-  tupled = iso listToTuple tupleToList--  tupleToList :: tuple -> List as-  listToTuple :: List as -> tuple--instance ListTuple () '[] where-  type ListToTuple '[] = ()-  tupleToList _ = Nil-  listToTuple _ = ()--instance ListTuple a '[ '(fa, a)] where-  type ListToTuple '[ '(fa, a)] = a-  tupleToList a-    = a :> Nil-  listToTuple (a :> Nil)-    = a--instance ListTuple (a, b) '[ '(fa, a), '(fb, b)] where-  type ListToTuple '[ '(fa, a), '(fb, b)] = (a, b)-  tupleToList (a, b)-    = a :> b :> Nil-  listToTuple (a :> b :> Nil)-    = (a, b)--instance ListTuple (a, b, c) '[ '(fa, a), '(fb, b), '(fc, c)] where-  type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c)] = (a, b, c)-  tupleToList (a, b, c)-    = a :> b :> c :> Nil-  listToTuple (a :> b :> c :> Nil)-    = (a, b, c)--instance ListTuple (a, b, c, d) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d)] where-  type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d)] = (a, b, c, d)-  tupleToList (a, b, c, d)-    = a :> b :> c :> d:> Nil-  listToTuple (a :> b :> c :> d :> Nil)-    = (a, b, c, d)--instance ListTuple (a, b, c, d, e) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e)] where-  type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e)] = (a, b, c, d, e)-  tupleToList (a, b, c, d, e)-    = a :> b :> c :> d:> e :> Nil-  listToTuple (a :> b :> c :> d :> e :> Nil)-    = (a, b, c, d, e)--instance ListTuple (a, b, c, d, e, f) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f)] where-  type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f)] = (a, b, c, d, e, f)-  tupleToList (a, b, c, d, e, f)-    = a :> b :> c :> d:> e :> f :> Nil-  listToTuple (a :> b :> c :> d :> e :> f :> Nil)-    = (a, b, c, d, e, f)--instance ListTuple (a, b, c, d, e, f, g) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g)] where-  type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g)] = (a, b, c, d, e, f, g)-  tupleToList (a, b, c, d, e, f, g)-    = a :> b :> c :> d:> e :> f :> g :> Nil-  listToTuple (a :> b :> c :> d :> e :> f :> g :> Nil)-    = (a, b, c, d, e, f, g)--instance ListTuple (a, b, c, d, e, f, g, h) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h)] where-  type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h)] = (a, b, c, d, e, f, g, h)-  tupleToList (a, b, c, d, e, f, g, h)-    = a :> b :> c :> d:> e :> f :> g :> h :> Nil-  listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> Nil)-    = (a, b, c, d, e, f, g, h)--instance ListTuple (a, b, c, d, e, f, g, h, j) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j)] where-  type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j)] = (a, b, c, d, e, f, g, h, j)-  tupleToList (a, b, c, d, e, f, g, h, j)-    = a :> b :> c :> d:> e :> f :> g :> h :> j :> Nil-  listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> Nil)-    = (a, b, c, d, e, f, g, h, j)--instance ListTuple (a, b, c, d, e, f, g, h, j, k) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k)] where-  type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k)] = (a, b, c, d, e, f, g, h, j, k)-  tupleToList (a, b, c, d, e, f, g, h, j, k)-    = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> Nil-  listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> Nil)-    = (a, b, c, d, e, f, g, h, j, k)--instance ListTuple (a, b, c, d, e, f, g, h, j, k, l) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l)] where-  type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l)] = (a, b, c, d, e, f, g, h, j, k, l)-  tupleToList (a, b, c, d, e, f, g, h, j, k, l)-    = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> Nil-  listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> Nil)-    = (a, b, c, d, e, f, g, h, j, k, l)--instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m)] where-  type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m)] = (a, b, c, d, e, f, g, h, j, k, l, m)-  tupleToList (a, b, c, d, e, f, g, h, j, k, l, m)-    = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> Nil-  listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> Nil)-    = (a, b, c, d, e, f, g, h, j, k, l, m)--instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n)] where-  type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n)] = (a, b, c, d, e, f, g, h, j, k, l, m, n)-  tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n)-    = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> Nil-  listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> Nil)-    = (a, b, c, d, e, f, g, h, j, k, l, m, n)--instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o)] where-  type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o)] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o)-  tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o)-    = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> Nil-  listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> Nil)-    = (a, b, c, d, e, f, g, h, j, k, l, m, n, o)--instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p)] where-  type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p)] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)-  tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)-    = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> Nil-  listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> Nil)-    = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p)--instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q)] where-  type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q)] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)-  tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)-    = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> Nil-  listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> Nil)-    = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q)--instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q), '(fr, r)] where-  type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q), '(fr, r)] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)-  tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)-    = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> Nil-  listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> Nil)-    = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r)--instance ListTuple (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s) '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q), '(fr, r), '(fs, s)] where-  type ListToTuple '[ '(fa, a), '(fb, b), '(fc, c), '(fd, d), '(fe, e), '(ff, f), '(fg, g), '(fh, h), '(fj, j), '(fk, k), '(fl, l), '(fm, m), '(fn, n), '(fo, o), '(fp, p), '(fq, q), '(fr, r), '(fs, s)] = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)-  tupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)-    = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> s :> Nil-  listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> m :> n :> o :> p :> q :> r :> s :> Nil)-    = (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s)--type family TupleToList a where-  TupleToList () = '[]-  TupleToList (a, b) = '[ '( '(), a), '( '(), b)]-  TupleToList (a, b, c) = '[ '( '(), a), '( '(), b), '( '(), c)]-  TupleToList (a, b, c, d) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d)]-  TupleToList (a, b, c, d, e) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e)]-  TupleToList (a, b, c, d, e, f) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f)]-  TupleToList (a, b, c, d, e, f, g) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g)]-  TupleToList (a, b, c, d, e, f, g, h) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h)]-  TupleToList (a, b, c, d, e, f, g, h, j) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j)]-  TupleToList (a, b, c, d, e, f, g, h, j, k) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k)]-  TupleToList (a, b, c, d, e, f, g, h, j, k, l) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l)]-  TupleToList (a, b, c, d, e, f, g, h, j, k, l, m) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l), '( '(), m)]-  TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l), '( '(), m), '( '(), n)]-  TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l), '( '(), m), '( '(), n), '( '(), o)]-  TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l), '( '(), m), '( '(), n), '( '(), o), '( '(), p)]-  TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l), '( '(), m), '( '(), n), '( '(), o), '( '(), p), '( '(), q)]-  TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l), '( '(), m), '( '(), n), '( '(), o), '( '(), p), '( '(), q), '( '(), r)]-  TupleToList (a, b, c, d, e, f, g, h, j, k, l, m, n, o, p, q, r, s) = '[ '( '(), a), '( '(), b), '( '(), c), '( '(), d), '( '(), e), '( '(), f), '( '(), g), '( '(), h), '( '(), j), '( '(), k), '( '(), l), '( '(), m), '( '(), n), '( '(), o), '( '(), p), '( '(), q), '( '(), r), '( '(), s)]-  TupleToList a = '[ '( '(), a)]

@@ -17,7 +17,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Generics.Product.Internal.Positions--- Copyright   :  (C) 2017 Csongor Kiss+-- Copyright   :  (C) 2018 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental@@ -40,7 +40,7 @@ import GHC.TypeLits   (type (<=?), type (+), Nat)  -- | Alias for the kind of the generic rep-type G k = k -> Type+type G = Type -> Type  -------------------------------------------------------------------------------- @@ -50,7 +50,7 @@ -- 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+type family CRep (a :: Type) :: G where   CRep rep = Fst (Traverse (Rep rep) 1)  -- | The actual traversal.@@ -58,7 +58,7 @@ -- 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+type family Traverse (a :: G) (n :: Nat) :: (G, Nat) where   Traverse (M1 mt m s) n     = Traverse1 (M1 mt m) (Traverse s n)   Traverse (l :+: r) n@@ -70,12 +70,12 @@   Traverse U1 n     = '(U1, n) -type family Traverse1 (w :: G k -> G k) (z :: (G k, Nat)) :: (G k, Nat) where+type family Traverse1 (w :: G -> G) (z :: (G, Nat)) :: (G, 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+type family TraverseProd (c :: G -> G -> G) (a :: (G, Nat)) (r :: G) :: (G, Nat) where   TraverseProd w '(i, n) r = Traverse1 (w i) (Traverse r n)  --------------------------------------------------------------------------------

@@ -16,7 +16,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Generics.Product.Internal.Subtype--- Copyright   :  (C) 2017 Csongor Kiss+-- Copyright   :  (C) 2018 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental@@ -82,16 +82,16 @@ instance GSmash sub sup => GSmash (D1 c sub) sup where   gsmash sup (M1 sub) = M1 (gsmash sup sub) -class GSmashLeaf sub sup (w :: Bool) where+class GSmashLeaf sub sup (w :: Maybe Type) where   gsmashLeaf :: sup p -> sub p -> sub p  instance   GLens' (HasTotalFieldPSym field) sup t-  => GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'True where+  => GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup ('Just t) where   gsmashLeaf sup _ = M1 (K1 (view (glens @(HasTotalFieldPSym field)) sup)) -instance GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'False where+instance GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'Nothing where   gsmashLeaf _ = id -data HasTotalFieldPSym :: Symbol -> (TyFun (Type -> Type) Bool)+data HasTotalFieldPSym :: Symbol -> (TyFun (Type -> Type) (Maybe Type)) type instance Eval (HasTotalFieldPSym sym) tt = HasTotalFieldP sym tt

@@ -1,78 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes    #-}-{-# LANGUAGE FlexibleContexts       #-}-{-# LANGUAGE FlexibleInstances      #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE MonoLocalBinds         #-}-{-# LANGUAGE ScopedTypeVariables    #-}-{-# LANGUAGE TypeApplications       #-}-{-# LANGUAGE TypeInType             #-}-{-# LANGUAGE UndecidableInstances   #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Generics.Product.List--- Copyright   :  (C) 2017 Csongor Kiss--- License     :  BSD3--- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com>--- Stability   :  experimental--- Portability :  non-portable------ Derive an isomorphism between a product type and a flat HList.-----------------------------------------------------------------------------------module Data.Generics.Product.List-  ( IsList (..)-  , IsRecord-  , IsRecord'-  ) where--import Data.Generics.Product.Internal.List-import Data.Kind-import GHC.Generics-import GHC.TypeLits-import Data.Generics.Internal.Profunctor.Iso--class IsList-  (m :: Type)-  (f :: Type)-  (g :: Type)-  (as :: [(m, Type)])-  (bs :: [(m, Type)]) | m f -> as, m g -> bs where-  list  :: Iso f g (List as) (List bs)--instance-  ( Generic f-  , Generic g-  , GIsList m (Rep f) (Rep g) as bs-  ) => IsList m f g as bs where-  list = repIso . glist @m-  {-# INLINE list #-}--class IsList Symbol f g as bs => IsRecord f g (as :: [(Symbol, Type)]) (bs :: [(Symbol, Type)]) | f -> as, g -> bs-instance IsList Symbol f g as bs => IsRecord f g as bs--class IsRecord f f as as => IsRecord' f (as :: [(Symbol, Type)]) | f -> as-instance IsRecord f f as as => IsRecord' f as---- example (TODO: move elsewhere)---class PrintRecord (rl :: [(Symbol, Type)]) where---  printRecord' :: List rl -> String------instance PrintRecord '[] where---  printRecord' _ = ""------instance (KnownSymbol field, Show a, PrintRecord xs) => PrintRecord ('(field, a) ': xs) where---  printRecord' (x :> xs) = show x ++ ", " ++ printRecord' xs------printRecord :: (IsRecord' rec rl, PrintRecord rl) => rec -> String---printRecord rec = printRecord' (rec ^. list)------data MyRecord = MyRecord---  { field1 :: Int---  , field2 :: String---  , field3 :: Bool---  } deriving Generic------ >>> printRecord (MyRecord 10 "hello" False)--- "10, \"hello\", False, "

@@ -19,7 +19,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Generics.Product.Positions--- Copyright   :  (C) 2017 Csongor Kiss+-- Copyright   :  (C) 2018 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental@@ -35,6 +35,8 @@     -- $setup     HasPosition (..)   , HasPosition' (..)+  , HasPosition_ (..)+  , HasPosition0 (..)    , getPosition   , setPosition@@ -93,9 +95,25 @@   --  ...   position :: VL.Lens s t a b +class HasPosition_ (i :: Nat) s t a b where+  position_ :: VL.Lens s t a b++-- |Records that have a field at a given position.+--+-- The difference between 'HasPosition' and 'HasPosition_' is similar to the+-- one between 'Data.Generics.Product.Fields.HasField' and+-- 'Data.Generics.Product.Fields.HasField_'.+-- See 'Data.Generics.Product.Fields.HasField_'. class HasPosition' (i :: Nat) s a | s i -> a where   position' :: VL.Lens s s a a +-- |Records that have a field at a given position.+--+-- This class gives the minimal constraints needed to define this lens.+-- For common uses, see 'HasPosition'.+class HasPosition0 (i :: Nat) s t a b where+  position0 :: VL.Lens s t a b+ getPosition :: forall i s a. HasPosition' i s a => s -> a getPosition s = s ^. position' @i @@ -112,31 +130,27 @@   position' f s = VL.ravel (repLens . coerced @cs @cs . glens @(HasTotalPositionPSym i)) f s   {-# INLINE position' #-} +-- this is to 'hide' the equality constraints which interfere with inlining+-- pre 8.4.3+class (~~) (a :: k) (b :: k) | a -> b, b -> a+instance (a ~ b) => (~~) a b+ instance  -- see Note [Changing type parameters]   ( Generic s-  , ErrorUnless i s (0 <? i && i <=? Size (Rep s))   , Generic t-  -- see Note [CPP in instance constraints]-#if __GLASGOW_HASKELL__ < 802-  , '(s', t') ~ '(Proxied s, Proxied t)-#else-  , s' ~ Proxied s-  , t' ~ Proxied t-#endif-  , Generic s'-  , Generic t'-  , 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-  , s ~ Infer t b' a-  , Coercible cs (Rep s)-  , Coercible ct (Rep t)+  , ErrorUnless i s (0 <? i && i <=? Size (Rep s))+  , GLens (HasTotalPositionPSym i) (CRep s) (CRep t) a b+  , HasTotalPositionP i (CRep s) ~~ 'Just a+  , HasTotalPositionP i (CRep t) ~~ 'Just b+  , HasTotalPositionP i (CRep (Indexed s)) ~~ 'Just a'+  , HasTotalPositionP i (CRep (Indexed t)) ~~ 'Just b'+  , t ~~ Infer s a' b+  , s ~~ Infer t b' a+  , Coercible (CRep s) (Rep s)+  , Coercible (CRep t) (Rep t)   ) => HasPosition i s t a b where -  position = VL.ravel (repLens . coerced @cs @ct . glens @(HasTotalPositionPSym i))+  position = position0 @i   {-# INLINE position #-}  -- We wouldn't need the universal 'x' here if we could express above that@@ -151,6 +165,33 @@ instance {-# OVERLAPPING #-} HasPosition f (Void1 a) (Void1 b) a b where   position = undefined +instance+  ( Generic s+  , Generic t+  , ErrorUnless i s (0 <? i && i <=? Size (Rep s))+  , GLens (HasTotalPositionPSym i) (CRep s) (CRep t) a b+  , UnifyHead s t+  , UnifyHead t s+  , Coercible (CRep s) (Rep s)+  , Coercible (CRep t) (Rep t)+  ) => HasPosition_ i s t a b where++  position_ = position0 @i+  {-# INLINE position_ #-}++instance {-# OVERLAPPING #-} HasPosition_ f (Void1 a) (Void1 b) a b where+  position_ = undefined++instance+  ( Generic s+  , Generic t+  , GLens (HasTotalPositionPSym i) (CRep s) (CRep t) a b+  , Coercible (CRep s) (Rep s)+  , Coercible (CRep t) (Rep t)+  ) => HasPosition0 i s t a b where+  position0 = VL.ravel (repLens . coerced @(CRep s) @(CRep t) . glens @(HasTotalPositionPSym i))+  {-# INLINE position0 #-}+ type family ErrorUnless (i :: Nat) (s :: Type) (hasP :: Bool) :: Constraint where   ErrorUnless i s 'False     = TypeError@@ -163,5 +204,5 @@   ErrorUnless _ _ 'True     = () -data HasTotalPositionPSym  :: Nat -> (TyFun (Type -> Type) Bool)+data HasTotalPositionPSym  :: Nat -> (TyFun (Type -> Type) (Maybe Type)) type instance Eval (HasTotalPositionPSym t) tt = HasTotalPositionP t tt

@@ -15,7 +15,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Generics.Product.Subtype--- Copyright   :  (C) 2017 Csongor Kiss+-- Copyright   :  (C) 2018 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental

@@ -14,7 +14,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Generics.Product.Typed--- Copyright   :  (C) 2017 Csongor Kiss+-- Copyright   :  (C) 2018 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental@@ -152,6 +152,6 @@   ErrorUnlessOne _ _ ('TypeStat '[] '[] _)     = () -data HasTotalTypePSym :: Type -> (TyFun (Type -> Type) Bool)+data HasTotalTypePSym :: Type -> (TyFun (Type -> Type) (Maybe Type)) type instance Eval (HasTotalTypePSym t) tt = HasTotalTypeP t tt 

@@ -16,7 +16,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Generics.Product.Types--- Copyright   :  (C) 2017 Csongor Kiss+-- Copyright   :  (C) 2018 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental@@ -32,9 +32,13 @@     --  $example     HasTypes   , types++  , Interesting   ) where  import Data.Kind+import Data.Int (Int8, Int16, Int32, Int64)+import Data.Word (Word, Word8, Word16, Word32, Word64)  import GHC.Generics import Data.Generics.Internal.VL.Traversal@@ -76,9 +80,18 @@ instance {-# OVERLAPPING #-} HasTypes Char a instance {-# OVERLAPPING #-} HasTypes Double a instance {-# OVERLAPPING #-} HasTypes Float a-instance {-# OVERLAPPING #-} HasTypes Int a instance {-# OVERLAPPING #-} HasTypes Integer a instance {-# OVERLAPPING #-} HasTypes Ordering a+instance {-# OVERLAPPING #-} HasTypes Int a+instance {-# OVERLAPPING #-} HasTypes Int8 a+instance {-# OVERLAPPING #-} HasTypes Int16 a+instance {-# OVERLAPPING #-} HasTypes Int32 a+instance {-# OVERLAPPING #-} HasTypes Int64 a+instance {-# OVERLAPPING #-} HasTypes Word a+instance {-# OVERLAPPING #-} HasTypes Word8 a+instance {-# OVERLAPPING #-} HasTypes Word16 a+instance {-# OVERLAPPING #-} HasTypes Word32 a+instance {-# OVERLAPPING #-} HasTypes Word64 a  -------------------------------------------------------------------------------- @@ -135,8 +148,17 @@   Interesting' (Rec0 Char)     _ seen = '(seen ,'False)   Interesting' (Rec0 Double)   _ seen = '(seen ,'False)   Interesting' (Rec0 Float)    _ seen = '(seen ,'False)-  Interesting' (Rec0 Int)      _ seen = '(seen ,'False)   Interesting' (Rec0 Integer)  _ seen = '(seen ,'False)+  Interesting' (Rec0 Int)      _ seen = '(seen ,'False)+  Interesting' (Rec0 Int8)     _ seen = '(seen ,'False)+  Interesting' (Rec0 Int16)    _ seen = '(seen ,'False)+  Interesting' (Rec0 Int32)    _ seen = '(seen ,'False)+  Interesting' (Rec0 Int64)    _ seen = '(seen ,'False)+  Interesting' (Rec0 Word)     _ seen = '(seen ,'False)+  Interesting' (Rec0 Word8)    _ seen = '(seen ,'False)+  Interesting' (Rec0 Word16)   _ seen = '(seen ,'False)+  Interesting' (Rec0 Word32)   _ seen = '(seen ,'False)+  Interesting' (Rec0 Word64)   _ seen = '(seen ,'False)   Interesting' (Rec0 r) t seen     = InterestingUnless (Elem r seen) (Rep r) t r seen   Interesting' _ _ seen

@@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Generics.Sum--- Copyright   :  (C) 2017 Csongor Kiss+-- Copyright   :  (C) 2018 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental

@@ -11,7 +11,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Generics.Sum.Any--- Copyright   :  (C) 2017 Csongor Kiss+-- Copyright   :  (C) 2018 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental

@@ -15,7 +15,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Generics.Sum.Constructors--- Copyright   :  (C) 2017 Csongor Kiss+-- Copyright   :  (C) 2018 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental@@ -30,7 +30,9 @@      -- $setup     AsConstructor (..)+  , AsConstructor_ (..)   , AsConstructor' (..)+  , AsConstructor0 (..)   ) where  import Data.Generics.Internal.Families@@ -103,9 +105,25 @@   --  ...   _Ctor :: Prism s t a b +-- |Sums that have a constructor with a given name.+--+-- The difference between 'HasConstructor' and 'HasConstructor_' is similar to+-- the one between 'Data.Generics.Product.Fields.HasField' and+-- 'Data.Generics.Product.Fields.HasField_'.+-- See 'Data.Generics.Product.Fields.HasField_'.+class AsConstructor_ (ctor :: Symbol) s t a b where+  _Ctor_ :: Prism s t a b+ class AsConstructor' (ctor :: Symbol) s a | ctor s -> a where   _Ctor' :: Prism s s a a +-- |Sums that have a constructor with a given name.+--+-- This class gives the minimal constraints needed to define this prism.+-- For common uses, see 'HasConstructor'.+class AsConstructor0 (ctor :: Symbol) s t a b where+  _Ctor0 :: Prism s t a b+ instance   ( Generic s   , ErrorUnless ctor s (HasCtorP ctor (Rep s))@@ -116,31 +134,48 @@  instance   ( Generic s-  , ErrorUnless ctor s (HasCtorP ctor (Rep s))   , Generic t-  -- see Note [CPP in instance constraints]-#if __GLASGOW_HASKELL__ < 802-  , '(s', t') ~ '(Proxied s, Proxied t)-#else-  , s' ~ Proxied s-  , t' ~ Proxied t-#endif-  , Generic s'-  , Generic t'-  , GAsConstructor' ctor (Rep s) a-  , GAsConstructor' ctor (Rep s') a'+  , ErrorUnless ctor s (HasCtorP ctor (Rep s))+  , GAsConstructor' ctor (Rep s) a -- TODO: add a test similar to #62 for prisms+  , GAsConstructor' ctor (Rep (Indexed s)) a'   , GAsConstructor ctor (Rep s) (Rep t) a b   , t ~ Infer s a' b-  , GAsConstructor' ctor (Rep t') b'+  , GAsConstructor' ctor (Rep (Indexed t)) b'   , s ~ Infer t b' a   ) => AsConstructor ctor s t a b where -  _Ctor eta = prismRavel (prismPRavel (repIso . _GCtor @ctor)) eta+  _Ctor = _Ctor0 @ctor   {-# INLINE[2] _Ctor #-}  -- See Note [Uncluttering type signatures] instance {-# OVERLAPPING #-} AsConstructor ctor (Void1 a) (Void1 b) a b where   _Ctor = undefined++instance+  ( Generic s+  , Generic t+  , ErrorUnless ctor s (HasCtorP ctor (Rep s))+  , GAsConstructor' ctor (Rep s) a -- TODO: add a test similar to #62 for prisms+  , GAsConstructor' ctor (Rep (Indexed s)) a'+  , GAsConstructor ctor (Rep s) (Rep t) a b+  , GAsConstructor' ctor (Rep (Indexed t)) b'+  , UnifyHead s t+  , UnifyHead t s+  ) => AsConstructor_ ctor s t a b where++  _Ctor_ = _Ctor0 @ctor+  {-# INLINE[2] _Ctor_ #-}++instance {-# OVERLAPPING #-} AsConstructor_ ctor (Void1 a) (Void1 b) a b where+  _Ctor_ = undefined++instance+  ( Generic s+  , Generic t+  , GAsConstructor ctor (Rep s) (Rep t) a b+  ) => AsConstructor0 ctor s t a b where+  _Ctor0 = prismRavel (prismPRavel (repIso . _GCtor @ctor))+  {-# INLINE[2] _Ctor0 #-}  type family ErrorUnless (ctor :: Symbol) (s :: Type) (contains :: Bool) :: Constraint where   ErrorUnless ctor s 'False

@@ -14,7 +14,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Generics.Sum.Internal.Constructors--- Copyright   :  (C) 2017 Csongor Kiss+-- Copyright   :  (C) 2018 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental@@ -30,11 +30,11 @@   ) where  import Data.Generics.Internal.Families-import Data.Generics.Product.Internal.List+import Data.Generics.Product.Internal.HList+import Data.Profunctor (Profunctor(..))  import GHC.Generics import GHC.TypeLits (Symbol)-import Data.Kind import Data.Generics.Internal.Profunctor.Lens import Data.Generics.Internal.Profunctor.Iso import Data.Generics.Internal.Profunctor.Prism@@ -47,15 +47,14 @@ type GAsConstructor' ctor s a = GAsConstructor ctor s s a a  instance-  ( GIsList Type f f as as-  , GIsList Type g g bs bs+  ( GIsList f f as as+  , GIsList g g bs bs   , ListTuple a as   , ListTuple b bs   ) => GAsConstructor ctor (M1 C ('MetaCons ctor fixity fields) f) (M1 C ('MetaCons ctor fixity fields) g) a b where -  _GCtor = prism (M1 . view (fromIso (glist @Type)) . tupleToList) (Right . listToTuple . view (glist @Type) . unM1)+  _GCtor = dimap (listToTuple . view glist . unM1) (M1 . view (fromIso glist) . tupleToList)   {-# INLINE[0] _GCtor #-}-  instance GSumAsConstructor ctor (HasCtorP ctor l) l r l' r' a b => GAsConstructor ctor (l :+: r) (l' :+: r') a b where   _GCtor = _GSumCtor @ctor @(HasCtorP ctor l)

@@ -14,7 +14,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Generics.Sum.Internal.Subtype--- Copyright   :  (C) 2017 Csongor Kiss+-- Copyright   :  (C) 2018 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental@@ -28,7 +28,7 @@   ( GAsSubtype (..)   ) where -import Data.Generics.Product.Internal.List+import Data.Generics.Product.Internal.HList import Data.Generics.Sum.Internal.Typed  import Data.Kind@@ -46,7 +46,7 @@   ( GSplash sub sup   , GDowncast sub sup   ) => GAsSubtype sub sup where-  _GSub f = (prism _GSplash _GDowncast) f+  _GSub f = prism _GSplash _GDowncast f   {-# INLINE[0] _GSub #-}  --------------------------------------------------------------------------------@@ -60,10 +60,10 @@   {-# INLINE[0] _GSplash #-}  instance-  ( GIsList () subf subf as as+  ( GIsList subf subf as as   , GAsType supf as   ) => GSplash (C1 meta subf) supf where-  _GSplash p = build ((_GTyped . fromIso (glist @()) . fromIso mIso)) p+  _GSplash p = build (_GTyped . fromIso (mIso . glist)) p   {-# INLINE[0] _GSplash #-}  instance GSplash sub sup => GSplash (D1 c sub) sup where@@ -76,7 +76,7 @@   _GDowncast :: sup x -> Either (sup x) (sub x)  instance-  ( GIsList () sup sup as as+  ( GIsList sup sup as as   , GDowncastC (HasPartialTypeP as sub) sub sup   ) => GDowncast sub (C1 m sup) where   _GDowncast (M1 m) = case _GDowncastC @(HasPartialTypeP as sub) m of@@ -108,8 +108,8 @@  instance   ( GAsType sub subl-  , GIsList () sup sup subl subl+  , GIsList sup sup subl subl   ) => GDowncastC 'True sub sup where-  _GDowncastC sup = Right (build (_GTyped . fromIso (glist @())) sup)+  _GDowncastC sup = Right (build (_GTyped . fromIso glist) sup)   {-# INLINE[0] _GDowncastC #-} 

@@ -13,7 +13,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Generics.Sum.Internal.Typed--- Copyright   :  (C) 2017 Csongor Kiss+-- Copyright   :  (C) 2018 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental@@ -32,13 +32,13 @@ import Data.Tagged  import Data.Generics.Internal.Families-import Data.Generics.Product.Internal.List+import Data.Generics.Product.Internal.HList import Data.Generics.Internal.Profunctor.Iso import Data.Generics.Internal.Profunctor.Prism  -- |As 'AsType' but over generic representations as defined by "GHC.Generics".-class GAsType (f :: Type -> Type) (as :: [((), Type)]) where-  _GTyped :: Prism (f x) (f x) (List as) (List as)+class GAsType (f :: Type -> Type) (as :: [Type]) where+  _GTyped :: Prism (f x) (f x) (HList as) (HList as) -- We create this specialised version as we use it in the subtype prism -- If we don't create it, the opportunity for specialisation is only -- created after specialisation happens, I think a late specialisation pass@@ -47,9 +47,9 @@   instance-  ( GIsList () f f as as+  ( GIsList f f as as   ) => GAsType (M1 C meta f) as where-  _GTyped = mIso . glist @()+  _GTyped = mIso . glist   {-# INLINE[0] _GTyped #-}  instance GSumAsType (HasPartialTypeP a l) l r a => GAsType (l :+: r) a where@@ -60,8 +60,8 @@   _GTyped = mIso . _GTyped   {-# INLINE[0] _GTyped #-} -class GSumAsType (contains :: Bool) l r (a :: [((), Type)]) where-  _GSumTyped :: Prism ((l :+: r) x) ((l :+: r) x) (List a) (List a)+class GSumAsType (contains :: Bool) l r (a :: [Type]) where+  _GSumTyped :: Prism ((l :+: r) x) ((l :+: r) x) (HList a) (HList a)  instance GAsType l a => GSumAsType 'True l r a where   _GSumTyped = left . _GTyped

@@ -11,7 +11,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Generics.Sum.Subtype--- Copyright   :  (C) 2017 Csongor Kiss+-- Copyright   :  (C) 2018 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental

@@ -13,7 +13,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Generics.Sum.Typed--- Copyright   :  (C) 2017 Csongor Kiss+-- Copyright   :  (C) 2018 Csongor Kiss -- License     :  BSD3 -- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com> -- Stability   :  experimental@@ -37,7 +37,7 @@  import Data.Generics.Internal.Families import Data.Generics.Internal.Void-import Data.Generics.Product.Internal.List+import Data.Generics.Product.Internal.HList import Data.Generics.Internal.VL.Prism import Data.Generics.Internal.Profunctor.Iso import Data.Generics.Internal.Profunctor.Prism (prismPRavel)

@@ -0,0 +1,104 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE TypeApplications #-}+{-# language ConstraintKinds #-}+{-# language DataKinds #-}+{-# language FlexibleContexts #-}+{-# language FlexibleInstances #-}+{-# language FunctionalDependencies #-}+{-# language MultiParamTypeClasses #-}+{-# language ScopedTypeVariables #-}+{-# language TypeFamilies #-}+{-# language TypeOperators #-}+{-# language UndecidableInstances #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Generics.Wrapped+-- Copyright   :  (C) 2018 Csongor Kiss+-- License     :  BSD3+-- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Derive an isomorphism between a newtype and its wrapped type.+--+-----------------------------------------------------------------------------++module Data.Generics.Wrapped+  ( Wrapped (..)+  , wrappedTo+  , wrappedFrom+  , _Unwrapped+  , _Wrapped+  )+where++import Control.Applicative    (Const(..))+import Data.Generics.Internal.Profunctor.Iso++import qualified Data.Generics.Internal.VL.Iso as VL+import Data.Generics.Internal.Families.Changing ( UnifyHead )++import Data.Kind (Constraint)+import GHC.Generics+import GHC.TypeLits++type family ErrorUnlessOnlyOne a b :: Constraint where+  ErrorUnlessOnlyOne t (M1 i k a) = ErrorUnlessOnlyOne t a+  ErrorUnlessOnlyOne t (K1 i a) = ()+  ErrorUnlessOnlyOne t a =+    TypeError ('ShowType t ':<>: 'Text " is not a single-constructor, single-field datatype")++-- | @since 1.1.0.0+_Unwrapped :: Wrapped s t a b => VL.Iso s t a b+_Unwrapped = wrappedIso+{-# inline _Unwrapped #-}++-- | @since 1.1.0.0+_Wrapped :: Wrapped s t a b => VL.Iso b a t s+_Wrapped = VL.fromIso wrappedIso+{-# inline _Wrapped #-}++-- TODO: move this into doctets++-- newtype FlippedEither a b = FlippedEither (Either b a)+--   deriving Generic++-- test :: (a -> c) -> FlippedEither a b -> FlippedEither c b+-- test f = over wrappedIso (fmap f)++class GWrapped s t a b | s -> a, t -> b, s b -> t, t a -> s where+  gWrapped :: Iso (s x) (t x) a b++instance GWrapped s t a b => GWrapped (M1 i k s) (M1 i k t) a b where+  gWrapped = mIso . gWrapped++instance (a ~ c, b ~ d) => GWrapped (K1 i a) (K1 i b) c d where+  gWrapped = kIso++-- | @since 1.1.0.0+class Wrapped s t a b | s -> a, t -> b where+  -- | @since 1.1.0.0+  wrappedIso :: VL.Iso s t a b++-- | @since 1.1.0.0+wrappedTo :: forall s t a b. Wrapped s t a b => s -> a+wrappedTo a = view (wrappedIso @s @t @a @b) a+  where view l s = getConst (l Const s)+{-# INLINE wrappedTo #-}++-- | @since 1.1.0.0+wrappedFrom :: forall s t a b. Wrapped s t a b => b -> t+wrappedFrom a = view (VL.fromIso (wrappedIso @s @t @a @b)) a+  where view l s = getConst (l Const s)+{-# INLINE wrappedFrom #-}++instance+  ( Generic s+  , Generic t+  , GWrapped (Rep s) (Rep t) a b+  , UnifyHead s t+  , UnifyHead t s+  ) => Wrapped s t a b where+  wrappedIso = iso2isovl (repIso . gWrapped)+  {-# INLINE wrappedIso #-}

@@ -2,6 +2,7 @@ {-# OPTIONS_GHC -dsuppress-all #-}  {-# LANGUAGE AllowAmbiguousTypes             #-}+{-# LANGUAGE CPP                             #-} {-# LANGUAGE DataKinds                       #-} {-# LANGUAGE DeriveGeneric                   #-} {-# LANGUAGE DuplicateRecordFields           #-}@@ -10,6 +11,7 @@ {-# LANGUAGE ScopedTypeVariables             #-} {-# LANGUAGE TypeApplications                #-} {-# LANGUAGE TemplateHaskell                 #-}+{-# LANGUAGE OverloadedLabels                #-}  module Main where @@ -23,6 +25,9 @@ import Data.Generics.Internal.VL.Lens import Data.Generics.Internal.VL.Prism import Data.Generics.Internal.VL.Traversal+import Control.Lens (_1, (+~))+import Data.Function ((&))+import Data.Generics.Labels ()  -- This is sufficient at we only want to test that they typecheck import Test24 ()@@ -178,24 +183,33 @@ fieldALensName :: Lens' Record Int fieldALensName = field @"fieldA" +fieldALensName_ :: Lens' Record Int+fieldALensName_ = field_ @"fieldA"+ fieldALensType :: Lens' Record Int fieldALensType = typed @Int  fieldALensPos :: Lens' Record Int fieldALensPos = position @1 +fieldALensPos_ :: Lens' Record Int+fieldALensPos_ = position_ @1+ subtypeLensGeneric :: Lens' Record Record2 subtypeLensGeneric = super  typeChangingGeneric :: Lens (Record3 a) (Record3 b) a b-typeChangingGeneric = field @"fieldA"+typeChangingGeneric = #fieldA  typeChangingGenericPos :: Lens (Record3 a) (Record3 b) a b typeChangingGenericPos = position @1  typeChangingGenericCompose :: Lens (Record3 (Record3 a)) (Record3 (Record3 b)) a b-typeChangingGenericCompose = field @"fieldA" . field @"fieldA"+typeChangingGenericCompose = #fieldA . #fieldA +typeChangingGenericCompose_ :: Lens (Record3 (Record3 a)) (Record3 (Record3 b)) a b+typeChangingGenericCompose_ = field_ @"fieldA" . field_ @"fieldA"+ sum1PrismB :: Prism Sum1 Sum1 Int Int sum1PrismB = _Ctor @"B" @@ -214,15 +228,24 @@ sum2TypePrismChar :: Prism Sum2 Sum2 Char Char sum2TypePrismChar = _Typed @Char +data SumOfProducts =+    RecA { _foo :: Int, valA :: String }+  | RecB { _foo :: Int, valB :: Bool }+  | RecC { _foo :: Int }+  deriving (Show, Eq, Generic)+ tests :: Test tests = TestList $ map mkHUnitTest   [ $(inspectTest $ 'fieldALensManual          === 'fieldALensName)+  , $(inspectTest $ 'fieldALensManual          === 'fieldALensName_)   , $(inspectTest $ 'fieldALensManual          === 'fieldALensType)   , $(inspectTest $ 'fieldALensManual          === 'fieldALensPos)+  , $(inspectTest $ 'fieldALensManual          === 'fieldALensPos_)   , $(inspectTest $ 'subtypeLensManual         === 'subtypeLensGeneric)   , $(inspectTest $ 'typeChangingManual        === 'typeChangingGeneric)   , $(inspectTest $ 'typeChangingManual        === 'typeChangingGenericPos)   , $(inspectTest $ 'typeChangingManualCompose === 'typeChangingGenericCompose)+  , $(inspectTest $ 'typeChangingManualCompose === 'typeChangingGenericCompose_)   , $(inspectTest $ 'sum1PrismManual           === 'sum1PrismB)   , $(inspectTest $ 'subtypePrismManual        === 'subtypePrismGeneric)   , $(inspectTest $ 'sum2PrismManualChar       === 'sum2TypePrismChar)@@ -235,6 +258,16 @@   -- TODO [1.0.0.0]: these tests pass with the new implementation --  , $(inspectTest $ 'sum3Param1Manual          === 'sum3Param1Derived) --  , $(inspectTest $ 'sum3Param2Manual          === 'sum3Param2Derived)+  ] +++  -- Tests for overloaded labels+  [ (valLabel ^. #_foo        ) ~=?  3+  , (valLabel &  #_foo +~ 10  ) ~=? RecB 13 True+#if __GLASGOW_HASKELL__ >= 802+  , (valLabel ^? #_RecB       ) ~=? Just (3, True)+  , (valLabel ^? #_RecB . _1  ) ~=? Just 3+  , (valLabel ^? #_RecC       ) ~=? Nothing+#endif   ]+  where valLabel = RecB 3 True   -- TODO: add test for traversals over multiple types

@@ -0,0 +1,20 @@+{-# LANGUAGE DataKinds, DeriveGeneric, TypeApplications #-}+module Test62 (example, example_) where+import Data.Generics.Product (field, field_, position, position_)+import Data.Generics.Internal.VL.Lens (set)+import GHC.Generics (Generic)++data Foo a = Foo { bar :: Bar a } deriving Generic+data Bar a = Bar { x :: a, y :: a } deriving Generic++example :: Foo ()+example =+  set (field @"bar" . position @1) ()+  . set (position @1 . field @"y") ()+  $ Foo{ bar = Bar{ x = (), y = () } }++example_ :: Foo ()+example_ =+  set (field_ @"bar" . position_ @1) ()+  . set (position_ @1 . field_ @"y") ()+  $ Foo{ bar = Bar{ x = (), y = () } }

@@ -0,0 +1,12 @@+{-# LANGUAGE DataKinds, DeriveGeneric, TypeApplications #-}+module Test63 (example) where+import Data.Generics.Product (types)+import Data.Generics.Internal.VL.Lens (over)+import Data.Word (Word32)+import GHC.Generics (Generic)++data Record = Record {field1 :: Word32, field2 :: Int}+    deriving (Generic, Show)++example :: Record+example = over (types @Int) (+1) (Record 0 0)

@@ -4,4 +4,5 @@       [ "-isrc"       , "src/Data/Generics/Product.hs"       , "src/Data/Generics/Sum.hs"+      , "src/Data/Generics/Labels.hs"       ]