diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2017, Csongor Kiss +Copyright (c) 2018, Csongor Kiss All rights reserved. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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) diff --git a/examples/doctest.hs b/examples/doctest.hs --- a/examples/doctest.hs +++ b/examples/doctest.hs @@ -2,5 +2,6 @@ main = doctest [ "-iexamples" + , "-isrc" , "examples/Biscuits.hs" ] diff --git a/generic-lens.cabal b/generic-lens.cabal --- a/generic-lens.cabal +++ b/generic-lens.cabal @@ -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 diff --git a/src/Data/GenericLens/Internal.hs b/src/Data/GenericLens/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/GenericLens/Internal.hs @@ -0,0 +1,47 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.GenericLens.Internal +-- Copyright : (C) 2018 Csongor Kiss +-- License : BSD3 +-- Maintainer : Csongor Kiss +-- 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 diff --git a/src/Data/Generics/Internal/Families.hs b/src/Data/Generics/Internal/Families.hs --- a/src/Data/Generics/Internal/Families.hs +++ b/src/Data/Generics/Internal/Families.hs @@ -9,7 +9,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Internal.Families --- Copyright : (C) 2017 Csongor Kiss +-- Copyright : (C) 2018 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- Stability : experimental @@ -27,7 +27,6 @@ import GHC.TypeLits (ErrorMessage (..), Symbol) --- * Stuff type family ShowSymbols (ctors :: [Symbol]) :: ErrorMessage where ShowSymbols '[] = 'Text "" diff --git a/src/Data/Generics/Internal/Families/Changing.hs b/src/Data/Generics/Internal/Families/Changing.hs --- a/src/Data/Generics/Internal/Families/Changing.hs +++ b/src/Data/Generics/Internal/Families/Changing.hs @@ -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 diff --git a/src/Data/Generics/Internal/Families/Collect.hs b/src/Data/Generics/Internal/Families/Collect.hs --- a/src/Data/Generics/Internal/Families/Collect.hs +++ b/src/Data/Generics/Internal/Families/Collect.hs @@ -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 -- 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 diff --git a/src/Data/Generics/Internal/Families/Has.hs b/src/Data/Generics/Internal/Families/Has.hs --- a/src/Data/Generics/Internal/Families/Has.hs +++ b/src/Data/Generics/Internal/Families/Has.hs @@ -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 -- 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 = '[] diff --git a/src/Data/Generics/Internal/Profunctor/Iso.hs b/src/Data/Generics/Internal/Profunctor/Iso.hs --- a/src/Data/Generics/Internal/Profunctor/Iso.hs +++ b/src/Data/Generics/Internal/Profunctor/Iso.hs @@ -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 -- 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 diff --git a/src/Data/Generics/Internal/Profunctor/Lens.hs b/src/Data/Generics/Internal/Profunctor/Lens.hs --- a/src/Data/Generics/Internal/Profunctor/Lens.hs +++ b/src/Data/Generics/Internal/Profunctor/Lens.hs @@ -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 -- Stability : experimental diff --git a/src/Data/Generics/Internal/Profunctor/Prism.hs b/src/Data/Generics/Internal/Profunctor/Prism.hs --- a/src/Data/Generics/Internal/Profunctor/Prism.hs +++ b/src/Data/Generics/Internal/Profunctor/Prism.hs @@ -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 -- 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 diff --git a/src/Data/Generics/Internal/VL/Iso.hs b/src/Data/Generics/Internal/VL/Iso.hs --- a/src/Data/Generics/Internal/VL/Iso.hs +++ b/src/Data/Generics/Internal/VL/Iso.hs @@ -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 -- 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) diff --git a/src/Data/Generics/Internal/VL/Lens.hs b/src/Data/Generics/Internal/VL/Lens.hs --- a/src/Data/Generics/Internal/VL/Lens.hs +++ b/src/Data/Generics/Internal/VL/Lens.hs @@ -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 -- 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) = diff --git a/src/Data/Generics/Internal/VL/Prism.hs b/src/Data/Generics/Internal/VL/Prism.hs --- a/src/Data/Generics/Internal/VL/Prism.hs +++ b/src/Data/Generics/Internal/VL/Prism.hs @@ -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 -- Stability : experimental diff --git a/src/Data/Generics/Internal/VL/Traversal.hs b/src/Data/Generics/Internal/VL/Traversal.hs --- a/src/Data/Generics/Internal/VL/Traversal.hs +++ b/src/Data/Generics/Internal/VL/Traversal.hs @@ -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 -- Stability : experimental diff --git a/src/Data/Generics/Labels.hs b/src/Data/Generics/Labels.hs new file mode 100644 --- /dev/null +++ b/src/Data/Generics/Labels.hs @@ -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 +-- 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 diff --git a/src/Data/Generics/Product.hs b/src/Data/Generics/Product.hs --- a/src/Data/Generics/Product.hs +++ b/src/Data/Generics/Product.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Product --- Copyright : (C) 2017 Csongor Kiss +-- Copyright : (C) 2018 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- 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 diff --git a/src/Data/Generics/Product/Any.hs b/src/Data/Generics/Product/Any.hs --- a/src/Data/Generics/Product/Any.hs +++ b/src/Data/Generics/Product/Any.hs @@ -12,7 +12,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Product.Any --- Copyright : (C) 2017 Csongor Kiss +-- Copyright : (C) 2018 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- Stability : experimental diff --git a/src/Data/Generics/Product/Fields.hs b/src/Data/Generics/Product/Fields.hs --- a/src/Data/Generics/Product/Fields.hs +++ b/src/Data/Generics/Product/Fields.hs @@ -16,7 +16,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Product.Fields --- Copyright : (C) 2017 Csongor Kiss +-- Copyright : (C) 2018 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- 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 diff --git a/src/Data/Generics/Product/HList.hs b/src/Data/Generics/Product/HList.hs new file mode 100644 --- /dev/null +++ b/src/Data/Generics/Product/HList.hs @@ -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 +-- 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 #-} diff --git a/src/Data/Generics/Product/Internal/Constraints.hs b/src/Data/Generics/Product/Internal/Constraints.hs --- a/src/Data/Generics/Product/Internal/Constraints.hs +++ b/src/Data/Generics/Product/Internal/Constraints.hs @@ -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 -- 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] diff --git a/src/Data/Generics/Product/Internal/GLens.hs b/src/Data/Generics/Product/Internal/GLens.hs --- a/src/Data/Generics/Product/Internal/GLens.hs +++ b/src/Data/Generics/Product/Internal/GLens.hs @@ -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 -- 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 #-} diff --git a/src/Data/Generics/Product/Internal/HList.hs b/src/Data/Generics/Product/Internal/HList.hs new file mode 100644 --- /dev/null +++ b/src/Data/Generics/Product/Internal/HList.hs @@ -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 +-- 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] diff --git a/src/Data/Generics/Product/Internal/List.hs b/src/Data/Generics/Product/Internal/List.hs deleted file mode 100644 --- a/src/Data/Generics/Product/Internal/List.hs +++ /dev/null @@ -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 --- 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)] diff --git a/src/Data/Generics/Product/Internal/Positions.hs b/src/Data/Generics/Product/Internal/Positions.hs --- a/src/Data/Generics/Product/Internal/Positions.hs +++ b/src/Data/Generics/Product/Internal/Positions.hs @@ -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 -- 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) -------------------------------------------------------------------------------- diff --git a/src/Data/Generics/Product/Internal/Subtype.hs b/src/Data/Generics/Product/Internal/Subtype.hs --- a/src/Data/Generics/Product/Internal/Subtype.hs +++ b/src/Data/Generics/Product/Internal/Subtype.hs @@ -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 -- 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 diff --git a/src/Data/Generics/Product/List.hs b/src/Data/Generics/Product/List.hs deleted file mode 100644 --- a/src/Data/Generics/Product/List.hs +++ /dev/null @@ -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 --- 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, " diff --git a/src/Data/Generics/Product/Positions.hs b/src/Data/Generics/Product/Positions.hs --- a/src/Data/Generics/Product/Positions.hs +++ b/src/Data/Generics/Product/Positions.hs @@ -19,7 +19,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Product.Positions --- Copyright : (C) 2017 Csongor Kiss +-- Copyright : (C) 2018 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- 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 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 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 diff --git a/src/Data/Generics/Product/Subtype.hs b/src/Data/Generics/Product/Subtype.hs --- a/src/Data/Generics/Product/Subtype.hs +++ b/src/Data/Generics/Product/Subtype.hs @@ -15,7 +15,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Product.Subtype --- Copyright : (C) 2017 Csongor Kiss +-- Copyright : (C) 2018 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- Stability : experimental diff --git a/src/Data/Generics/Product/Typed.hs b/src/Data/Generics/Product/Typed.hs --- a/src/Data/Generics/Product/Typed.hs +++ b/src/Data/Generics/Product/Typed.hs @@ -14,7 +14,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Product.Typed --- Copyright : (C) 2017 Csongor Kiss +-- Copyright : (C) 2018 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- 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 diff --git a/src/Data/Generics/Product/Types.hs b/src/Data/Generics/Product/Types.hs --- a/src/Data/Generics/Product/Types.hs +++ b/src/Data/Generics/Product/Types.hs @@ -16,7 +16,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Product.Types --- Copyright : (C) 2017 Csongor Kiss +-- Copyright : (C) 2018 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- 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 diff --git a/src/Data/Generics/Sum.hs b/src/Data/Generics/Sum.hs --- a/src/Data/Generics/Sum.hs +++ b/src/Data/Generics/Sum.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Sum --- Copyright : (C) 2017 Csongor Kiss +-- Copyright : (C) 2018 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- Stability : experimental diff --git a/src/Data/Generics/Sum/Any.hs b/src/Data/Generics/Sum/Any.hs --- a/src/Data/Generics/Sum/Any.hs +++ b/src/Data/Generics/Sum/Any.hs @@ -11,7 +11,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Sum.Any --- Copyright : (C) 2017 Csongor Kiss +-- Copyright : (C) 2018 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- Stability : experimental diff --git a/src/Data/Generics/Sum/Constructors.hs b/src/Data/Generics/Sum/Constructors.hs --- a/src/Data/Generics/Sum/Constructors.hs +++ b/src/Data/Generics/Sum/Constructors.hs @@ -15,7 +15,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Sum.Constructors --- Copyright : (C) 2017 Csongor Kiss +-- Copyright : (C) 2018 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- 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 diff --git a/src/Data/Generics/Sum/Internal/Constructors.hs b/src/Data/Generics/Sum/Internal/Constructors.hs --- a/src/Data/Generics/Sum/Internal/Constructors.hs +++ b/src/Data/Generics/Sum/Internal/Constructors.hs @@ -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 -- 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) diff --git a/src/Data/Generics/Sum/Internal/Subtype.hs b/src/Data/Generics/Sum/Internal/Subtype.hs --- a/src/Data/Generics/Sum/Internal/Subtype.hs +++ b/src/Data/Generics/Sum/Internal/Subtype.hs @@ -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 -- 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 #-} diff --git a/src/Data/Generics/Sum/Internal/Typed.hs b/src/Data/Generics/Sum/Internal/Typed.hs --- a/src/Data/Generics/Sum/Internal/Typed.hs +++ b/src/Data/Generics/Sum/Internal/Typed.hs @@ -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 -- 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 diff --git a/src/Data/Generics/Sum/Subtype.hs b/src/Data/Generics/Sum/Subtype.hs --- a/src/Data/Generics/Sum/Subtype.hs +++ b/src/Data/Generics/Sum/Subtype.hs @@ -11,7 +11,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Sum.Subtype --- Copyright : (C) 2017 Csongor Kiss +-- Copyright : (C) 2018 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- Stability : experimental diff --git a/src/Data/Generics/Sum/Typed.hs b/src/Data/Generics/Sum/Typed.hs --- a/src/Data/Generics/Sum/Typed.hs +++ b/src/Data/Generics/Sum/Typed.hs @@ -13,7 +13,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Sum.Typed --- Copyright : (C) 2017 Csongor Kiss +-- Copyright : (C) 2018 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- 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) diff --git a/src/Data/Generics/Wrapped.hs b/src/Data/Generics/Wrapped.hs new file mode 100644 --- /dev/null +++ b/src/Data/Generics/Wrapped.hs @@ -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 +-- 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 #-} diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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 diff --git a/test/Test62.hs b/test/Test62.hs new file mode 100644 --- /dev/null +++ b/test/Test62.hs @@ -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 = () } } diff --git a/test/Test63.hs b/test/Test63.hs new file mode 100644 --- /dev/null +++ b/test/Test63.hs @@ -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) diff --git a/test/doctest.hs b/test/doctest.hs --- a/test/doctest.hs +++ b/test/doctest.hs @@ -4,4 +4,5 @@ [ "-isrc" , "src/Data/Generics/Product.hs" , "src/Data/Generics/Sum.hs" + , "src/Data/Generics/Labels.hs" ]