diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,12 @@ +## 1.2.0.0 +- Add `HasTypesUsing` and `HasTypesCustom` for custom traversals (Lysxia) +- Improve type errors when no Generic instance is defined +- `types` now supports Text by default + +### Breaking API changes +- `HasType` now includes a reflexive case so that every type 'contains' itself (Matt Parsons) +- `AsSubtype` and `Subtype` now include a reflexive case so that every type is a subtype of itself + ## 1.1.0.0 - Fix regression in type inference for polymorphic optics - Add `HasField0`, `HasPosition0`, `AsConstructor0`, `HasField_`, `HasPositon_`, and `AsConstructor_` (Lysxia) diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2018, Csongor Kiss +Copyright (c) 2019, Csongor Kiss All rights reserved. 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.1.0.0 +version: 1.2.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. @@ -56,6 +56,7 @@ , Data.Generics.Internal.Families.Changing , Data.Generics.Internal.Families.Collect , Data.Generics.Internal.Families.Has + , Data.Generics.Internal.Errors , Data.Generics.Internal.Void , Data.Generics.Sum.Internal.Constructors @@ -69,9 +70,10 @@ , Data.Generics.Product.Internal.Constraints , Data.Generics.Product.Internal.HList - build-depends: base >= 4.9 && <= 5.0 - , profunctors >= 5.0 && <= 6.0 - , tagged >= 0.8 && <= 0.9 + build-depends: base >= 4.9 && < 5.0 + , profunctors >= 5.0 && < 6.0 + , tagged >= 0.8 && < 1 + , text >= 1.2 && < 1.3 hs-source-dirs: src default-language: Haskell2010 @@ -101,7 +103,7 @@ type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Spec.hs - other-modules: Util Test24 Test25 Test40 Test62 Test63 + other-modules: Util Test24 Test25 Test40 Test62 Test63 CustomChildren build-depends: base >= 4.9 && <= 5.0 , generic-lens diff --git a/src/Data/GenericLens/Internal.hs b/src/Data/GenericLens/Internal.hs --- a/src/Data/GenericLens/Internal.hs +++ b/src/Data/GenericLens/Internal.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.GenericLens.Internal --- Copyright : (C) 2018 Csongor Kiss +-- Copyright : (C) 2019 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- Stability : experimental @@ -18,6 +18,7 @@ , module Data.Generics.Internal.Families.Collect , module Data.Generics.Internal.Families.Has , module Data.Generics.Internal.Void + , module Data.Generics.Internal.Errors , module Data.Generics.Sum.Internal.Constructors , module Data.Generics.Sum.Internal.Typed @@ -28,6 +29,14 @@ , module Data.Generics.Product.Internal.Subtype , module Data.Generics.Product.Internal.Constraints , module Data.Generics.Product.Internal.HList + + , module Data.Generics.Internal.GenericN + + -- * van Laarhoven optics + , module Data.Generics.Internal.VL.Iso + , module Data.Generics.Internal.VL.Lens + , module Data.Generics.Internal.VL.Prism + , module Data.Generics.Internal.VL.Traversal ) where import Data.Generics.Internal.Families @@ -35,6 +44,7 @@ import Data.Generics.Internal.Families.Collect import Data.Generics.Internal.Families.Has import Data.Generics.Internal.Void +import Data.Generics.Internal.Errors import Data.Generics.Sum.Internal.Constructors import Data.Generics.Sum.Internal.Typed @@ -45,3 +55,10 @@ import Data.Generics.Product.Internal.Subtype import Data.Generics.Product.Internal.Constraints import Data.Generics.Product.Internal.HList + +import Data.Generics.Internal.GenericN + +import Data.Generics.Internal.VL.Iso +import Data.Generics.Internal.VL.Lens +import Data.Generics.Internal.VL.Prism +import Data.Generics.Internal.VL.Traversal diff --git a/src/Data/Generics/Internal/Errors.hs b/src/Data/Generics/Internal/Errors.hs new file mode 100644 --- /dev/null +++ b/src/Data/Generics/Internal/Errors.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE KindSignatures #-} + +------------------------------------------------------------------------------- +---- | +---- Module : Data.Generics.Internal.Errors +---- Copyright : (C) 2019 Csongor Kiss +---- License : BSD3 +---- Maintainer : Csongor Kiss +---- Stability : experimental +---- Portability : non-portable +---- +---- Provide more legible type errors as described in +---- (https://kcsongor.github.io/report-stuck-families/)[this blog post]. +------------------------------------------------------------------------------- + +module Data.Generics.Internal.Errors + ( NoGeneric + , Defined + , Defined_list + + , QuoteType + , PrettyError + ) where + +import GHC.Generics +import GHC.TypeLits +import Data.Kind + +type family NoGeneric (a :: Type) (ctxt :: [ErrorMessage]) :: Constraint where + NoGeneric a ctxt = PrettyError ('Text "No instance for " ':<>: QuoteType (Generic a) + ': ctxt) +type family PrettyError (ctxt :: [ErrorMessage]) :: k where + PrettyError '[] = TypeError ('Text "") + PrettyError (c ': cs) = TypeError ('Text "| " ':<>: c ':$$: PrettyLines cs) + +type family PrettyLines (ctxt :: [ErrorMessage]) :: ErrorMessage where + PrettyLines '[] = 'Text "" + PrettyLines (c ': cs) = 'Text "| " ':<>: c ':$$: PrettyLines cs + +type family Defined (break :: Type -> Type) (err :: Constraint) (a :: k) :: k where + Defined Void1 _ _ = Any + Defined _ _ k = k + +type family Defined_list (break :: [*]) (err :: Constraint) (a :: k) :: k where + Defined_list '[Void] _ _ = Any + Defined_list _ _ k = k + +data Void1 a +data Void +type family Any :: k + +type family QuoteType (typ :: k) :: ErrorMessage where + QuoteType typ = 'Text "‘" ':<>: 'ShowType typ ':<>: 'Text "’" 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) 2018 Csongor Kiss +-- Copyright : (C) 2019 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- Stability : experimental 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) 2018 Csongor Kiss +-- Copyright : (C) 2019 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- Stability : experimental 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) 2018 Csongor Kiss +-- Copyright : (C) 2019 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- Stability : experimental diff --git a/src/Data/Generics/Internal/GenericN.hs b/src/Data/Generics/Internal/GenericN.hs --- a/src/Data/Generics/Internal/GenericN.hs +++ b/src/Data/Generics/Internal/GenericN.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -11,9 +12,9 @@ -------------------------------------------------------------------------------- -- | -- Module : Data.Generics.Internal.GenericN --- Copyright : (C) 2018 Csongor Kiss --- Maintainer : Csongor Kiss +-- Copyright : (C) 2019 Csongor Kiss -- License : BSD3 +-- Maintainer : Csongor Kiss -- Stability : experimental -- Portability : non-portable -- 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 @@ +{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NoMonomorphismRestriction #-} @@ -10,7 +11,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Internal.Profunctor.Iso --- Copyright : (C) 2018 Csongor Kiss +-- Copyright : (C) 2019 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- Stability : experimental 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 @@ -1,3 +1,4 @@ +{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE Rank2Types #-} @@ -10,7 +11,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Internal.Profunctor.Lens --- Copyright : (C) 2018 Csongor Kiss +-- Copyright : (C) 2019 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 @@ -1,3 +1,4 @@ +{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoMonomorphismRestriction #-} @@ -10,7 +11,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Internal.Profunctor.Prism --- Copyright : (C) 2018 Csongor Kiss +-- Copyright : (C) 2019 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- Stability : experimental 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 @@ -1,3 +1,4 @@ +{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE Rank2Types #-} @@ -9,7 +10,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Internal.VL.Iso --- Copyright : (C) 2018 Csongor Kiss +-- Copyright : (C) 2019 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- Stability : experimental 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 @@ -1,3 +1,4 @@ +{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE Rank2Types #-} @@ -10,7 +11,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Internal.VL.Lens --- Copyright : (C) 2018 Csongor Kiss +-- Copyright : (C) 2019 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- Stability : experimental 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 @@ -1,3 +1,4 @@ +{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE Rank2Types #-} @@ -9,7 +10,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Internal.VL.Prism --- Copyright : (C) 2018 Csongor Kiss +-- Copyright : (C) 2019 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 @@ -1,3 +1,4 @@ +{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE GADTs #-} @@ -11,7 +12,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Internal.VL.Traversal --- Copyright : (C) 2018 Csongor Kiss +-- Copyright : (C) 2019 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- Stability : experimental diff --git a/src/Data/Generics/Labels.hs b/src/Data/Generics/Labels.hs --- a/src/Data/Generics/Labels.hs +++ b/src/Data/Generics/Labels.hs @@ -16,7 +16,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Data.Generics.Labels --- Copyright : (C) 2018 Csongor Kiss +-- Copyright : (C) 2019 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- Stability : experimental 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) 2018 Csongor Kiss +-- Copyright : (C) 2019 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- Stability : experimental 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) 2018 Csongor Kiss +-- Copyright : (C) 2019 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- Stability : experimental diff --git a/src/Data/Generics/Product/Constraints.hs b/src/Data/Generics/Product/Constraints.hs --- a/src/Data/Generics/Product/Constraints.hs +++ b/src/Data/Generics/Product/Constraints.hs @@ -11,7 +11,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Product.Constraints --- Copyright : (C) 2018 Csongor Kiss +-- Copyright : (C) 2019 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) 2018 Csongor Kiss +-- Copyright : (C) 2019 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- Stability : experimental @@ -47,6 +47,7 @@ import GHC.Generics import GHC.TypeLits (Symbol, ErrorMessage(..), TypeError) import Data.Generics.Internal.Profunctor.Lens as P +import Data.Generics.Internal.Errors -- $setup -- == /Running example:/ @@ -152,39 +153,47 @@ ( Generic s , ErrorUnless field s (CollectField field (Rep s)) , GLens' (HasTotalFieldPSym field) (Rep s) a + , Defined (Rep s) + (NoGeneric s '[ 'Text "arising from a generic lens focusing on the " + ':<>: QuoteType field ':<>: 'Text " field of type " ':<>: QuoteType a + , 'Text "in " ':<>: QuoteType s]) + (() :: Constraint) ) => HasField' field s a where - field' f s = VL.ravel (repLens . glens @(HasTotalFieldPSym field)) f s + field' f s = field0 @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 - , Generic t - , ErrorUnless field s (CollectField field (Rep s)) - , HasTotalFieldP field (Rep s) ~~ 'Just a + ( 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 + , HasField0 field s t a b ) => HasField field s t a b where field f s = field0 @field f s --- -- See Note [Uncluttering type signatures] +-- | See Note [Uncluttering type signatures] +#if __GLASGOW_HASKELL__ < 804 +-- >>> :t field +-- field +-- :: (HasField field s t a b, Functor f) => (a -> f b) -> s -> f t +#else +-- >>> :t field +-- field +-- :: (Functor f, HasField field s t a b) => (a -> f b) -> s -> f t +#endif 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 s) ~~ 'Just a , HasTotalFieldP field (Rep t) ~~ 'Just b , UnifyHead s t , UnifyHead t s - , GLens (HasTotalFieldPSym field) (Rep s) (Rep t) a b + , HasField0 field s t a b ) => HasField_ field s t a b where field_ f s = field0 @field f s @@ -195,8 +204,15 @@ ( Generic s , Generic t , GLens (HasTotalFieldPSym field) (Rep s) (Rep t) a b + , ErrorUnless field s (CollectField field (Rep s)) + , Defined (Rep s) + (NoGeneric s '[ 'Text "arising from a generic lens focusing on the " + ':<>: QuoteType field ':<>: 'Text " field of type " ':<>: QuoteType a + , 'Text "in " ':<>: QuoteType s]) + (() :: Constraint) ) => HasField0 field s t a b where field0 = VL.ravel (repLens . glens @(HasTotalFieldPSym field)) + {-# INLINE field0 #-} type family ErrorUnless (field :: Symbol) (s :: Type) (stat :: TypeStat) :: Constraint where ErrorUnless field s ('TypeStat _ _ '[]) diff --git a/src/Data/Generics/Product/HList.hs b/src/Data/Generics/Product/HList.hs --- a/src/Data/Generics/Product/HList.hs +++ b/src/Data/Generics/Product/HList.hs @@ -10,7 +10,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Product.HList --- Copyright : (C) 2018 Csongor Kiss +-- Copyright : (C) 2019 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- Stability : experimental 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) 2018 Csongor Kiss +-- Copyright : (C) 2019 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- Stability : experimental 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) 2018 Csongor Kiss +-- Copyright : (C) 2019 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- Stability : experimental diff --git a/src/Data/Generics/Product/Internal/HList.hs b/src/Data/Generics/Product/Internal/HList.hs --- a/src/Data/Generics/Product/Internal/HList.hs +++ b/src/Data/Generics/Product/Internal/HList.hs @@ -20,7 +20,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Product.Internal.HList --- Copyright : (C) 2018 Csongor Kiss +-- Copyright : (C) 2019 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- Stability : experimental 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) 2018 Csongor Kiss +-- Copyright : (C) 2019 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- Stability : experimental 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) 2018 Csongor Kiss +-- Copyright : (C) 2019 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- Stability : experimental diff --git a/src/Data/Generics/Product/Param.hs b/src/Data/Generics/Product/Param.hs --- a/src/Data/Generics/Product/Param.hs +++ b/src/Data/Generics/Product/Param.hs @@ -15,13 +15,13 @@ -------------------------------------------------------------------------------- -- | -- Module : Data.Generics.Product.Param --- Copyright : (C) 2018 Csongor Kiss --- Maintainer : Csongor Kiss +-- Copyright : (C) 2019 Csongor Kiss -- License : BSD3 +-- Maintainer : Csongor Kiss -- Stability : experimental -- Portability : non-portable -- --- Derive traversal over type parameters +-- Derive traversals over type parameters -- -------------------------------------------------------------------------------- @@ -39,6 +39,7 @@ import Data.Kind import Data.Generics.Internal.VL.Iso import Data.Generics.Internal.GenericN +import Data.Generics.Internal.Errors class HasParam (p :: Nat) s t a b | p t a -> s, p s b -> t, p s -> a, p t -> b where param :: Applicative g => (a -> g b) -> s -> g t @@ -47,6 +48,12 @@ ( GenericN s , GenericN t -- TODO: merge the old 'Changing' code with 'GenericN' + , Defined (Rep s) + (NoGeneric s + '[ 'Text "arising from a generic traversal of the type parameter at position " ':<>: QuoteType n + , 'Text "of type " ':<>: QuoteType a ':<>: 'Text " in " ':<>: QuoteType s + ]) + (() :: Constraint) , s ~ Infer t (P n b 'PTag) a , t ~ Infer s (P n a 'PTag) b , Error ((ArgCount s) <=? n) n (ArgCount s) s 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) 2018 Csongor Kiss +-- Copyright : (C) 2019 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- Stability : experimental @@ -47,6 +47,7 @@ import Data.Generics.Internal.Families import Data.Generics.Product.Internal.Positions import Data.Generics.Product.Internal.GLens +import Data.Generics.Internal.Errors import Data.Kind (Constraint, Type) import Data.Type.Bool (type (&&)) @@ -114,9 +115,15 @@ class HasPosition0 (i :: Nat) s t a b where position0 :: VL.Lens s t a b +-- | +-- >>> getPosition @2 human +-- 50 getPosition :: forall i s a. HasPosition' i s a => s -> a getPosition s = s ^. position' @i +-- | +-- >>> setPosition @2 60 human +-- Human {name = "Tunyasz", age = 60, address = "London"} setPosition :: forall i s a. HasPosition' i s a => a -> s -> s setPosition = VL.set (position' @i) @@ -126,6 +133,12 @@ , cs ~ CRep s , Coercible (Rep s) cs , GLens' (HasTotalPositionPSym i) cs a + , Defined (Rep s) + (NoGeneric s '[ 'Text "arising from a generic lens focusing on the field at" + , 'Text "position " ':<>: QuoteType i ':<>: 'Text " of type " ':<>: QuoteType a + ':<>: 'Text " in " ':<>: QuoteType s + ]) + (() :: Constraint) ) => HasPosition' i s a where position' f s = VL.ravel (repLens . coerced @cs @cs . glens @(HasTotalPositionPSym i)) f s {-# INLINE position' #-} @@ -136,10 +149,7 @@ instance (a ~ b) => (~~) a b instance -- see Note [Changing type parameters] - ( Generic s - , Generic t - , ErrorUnless i s (0 HasPosition i s t a b where position = position0 @i @@ -161,19 +172,26 @@ coerced = coerce {-# INLINE coerced #-} --- See Note [Uncluttering type signatures] +-- | See Note [Uncluttering type signatures] +#if __GLASGOW_HASKELL__ < 804 +-- >>> :t position +-- position +-- :: (HasPosition i s t a b, Functor f) => (a -> f b) -> s -> f t +#else +-- >>> :t position +-- position +-- :: (Functor f, HasPosition i s t a b) => (a -> f b) -> s -> f t +#endif 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 @@ -188,6 +206,12 @@ , GLens (HasTotalPositionPSym i) (CRep s) (CRep t) a b , Coercible (CRep s) (Rep s) , Coercible (CRep t) (Rep t) + , Defined (Rep s) + (NoGeneric s '[ 'Text "arising from a generic lens focusing on the field at" + , 'Text "position " ':<>: QuoteType i ':<>: 'Text " of type " ':<>: QuoteType a + ':<>: 'Text " in " ':<>: QuoteType s + ]) + (() :: Constraint) ) => HasPosition0 i s t a b where position0 = VL.ravel (repLens . coerced @(CRep s) @(CRep t) . glens @(HasTotalPositionPSym i)) {-# INLINE position0 #-} 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} @@ -15,7 +16,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Product.Subtype --- Copyright : (C) 2018 Csongor Kiss +-- Copyright : (C) 2019 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- Stability : experimental @@ -41,6 +42,7 @@ import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..)) import Data.Kind (Type, Constraint) import Data.Generics.Internal.Profunctor.Lens hiding (set) +import Data.Generics.Internal.Errors -- $setup -- == /Running example:/ @@ -113,14 +115,52 @@ , Generic b , GSmash (Rep a) (Rep b) , GUpcast (Rep a) (Rep b) - , ErrorUnless b a (CollectFieldsOrdered (Rep b) \\ CollectFieldsOrdered (Rep a)) + , CustomError a b ) => Subtype b a where smash p b = to $ gsmash (from p) (from b) upcast = to . gupcast . from --- See Note [Uncluttering type signatures] +type family CustomError a b :: Constraint where + CustomError a b = + ( ErrorUnless b a (CollectFieldsOrdered (Rep b) \\ CollectFieldsOrdered (Rep a)) + , Defined (Rep a) + (NoGeneric a '[ 'Text "arising from a generic lens focusing on " ':<>: QuoteType b + , 'Text "as a supertype of " ':<>: QuoteType a + ]) + (() :: Constraint) + , Defined (Rep b) + (NoGeneric b '[ 'Text "arising from a generic lens focusing on " ':<>: QuoteType b + , 'Text "as a supertype of " ':<>: QuoteType a + ]) + (() :: Constraint) + ) + +instance {-# OVERLAPPING #-} Subtype a a where + super = id + +-- | See Note [Uncluttering type signatures] +#if __GLASGOW_HASKELL__ < 804 +-- >>> :t super +-- super +-- :: (Subtype sup sub, Functor f) => (sup -> f sup) -> sub -> f sub +#else +-- >>> :t super +-- super +-- :: (Functor f, Subtype sup sub) => (sup -> f sup) -> sub -> f sub +#endif instance {-# OVERLAPPING #-} Subtype a Void where super = undefined + +-- | See Note [Uncluttering type signatures] +#if __GLASGOW_HASKELL__ < 804 +-- >>> :t super @Int +-- super @Int +-- :: (Subtype Int sub, Functor f) => (Int -> f Int) -> sub -> f sub +#else +-- >>> :t super @Int +-- super @Int +-- :: (Functor f, Subtype Int sub) => (Int -> f Int) -> sub -> f sub +#endif instance {-# OVERLAPPING #-} Subtype Void a where super = undefined 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} @@ -14,7 +15,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Product.Typed --- Copyright : (C) 2018 Csongor Kiss +-- Copyright : (C) 2019 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- Stability : experimental @@ -40,6 +41,7 @@ import GHC.Generics (Generic (Rep)) import GHC.TypeLits (TypeError, ErrorMessage (..)) import Data.Generics.Internal.Profunctor.Lens +import Data.Generics.Internal.Errors -- $setup -- == /Running example:/ @@ -111,12 +113,31 @@ instance ( Generic s , ErrorUnlessOne a s (CollectTotalType a (Rep s)) + , Defined (Rep s) + (NoGeneric s '[ 'Text "arising from a generic lens focusing on a field of type " ':<>: QuoteType a]) + (() :: Constraint) , GLens (HasTotalTypePSym a) (Rep s) (Rep s) a a ) => HasType a s where typed f s = VL.ravel (repLens . glens @(HasTotalTypePSym a)) f s --- See Note [Uncluttering type signatures] +instance {-# OVERLAPPING #-} HasType a a where + getTyped = id + {-# INLINE getTyped #-} + + setTyped a _ = a + {-# INLINE setTyped #-} + +-- | See Note [Uncluttering type signatures] +#if __GLASGOW_HASKELL__ < 804 +-- >>> :t typed +-- typed :: (HasType a s, Functor f) => (a -> f a) -> s -> f s +#else +-- >>> :t typed +-- typed :: (Functor f, HasType a s) => (a -> f a) -> s -> f s +#endif +-- +-- Note that this might not longer be needed given the above 'HasType a a' instance. instance {-# OVERLAPPING #-} HasType a Void where typed = undefined 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) 2018 Csongor Kiss +-- Copyright : (C) 2019 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- Stability : experimental @@ -29,22 +29,65 @@ module Data.Generics.Product.Types ( -- *Traversals -- - -- $example + -- $setup HasTypes , types - , Interesting + -- * Custom traversal strategies + -- $custom + , Children + , ChGeneric + + , HasTypesUsing + , typesUsing + + , HasTypesCustom (typesCustom) + ) where import Data.Kind import Data.Int (Int8, Int16, Int32, Int64) import Data.Word (Word, Word8, Word16, Word32, Word64) +import qualified Data.Text as T import GHC.Generics +import GHC.TypeLits import Data.Generics.Internal.VL.Traversal +import Data.Generics.Internal.Errors +-- $setup +-- == /Running example:/ +-- +-- >>> :set -XTypeApplications +-- >>> :set -XDeriveGeneric +-- >>> :set -XScopedTypeVariables +-- >>> import GHC.Generics +-- >>> :m +Data.Generics.Internal.VL.Traversal +-- >>> :m +Data.Generics.Internal.VL.Lens +-- >>> :{ +-- data WTree a w +-- = Leaf a +-- | Fork (WTree a w) (WTree a w) +-- | WithWeight (WTree a w) w +-- deriving (Generic, Show) +-- :} + +-------------------------------------------------------------------------------- +-- HasTypes +-------------------------------------------------------------------------------- + -- TODO [1.0.0.0]: use type-changing variant internally +-- | Traverse all types in the given structure. +-- +-- For example, to update all 'String's in a @WTree (Maybe String) String@, we can write +-- +-- >>> myTree = WithWeight (Fork (Leaf (Just "hello")) (Leaf Nothing)) "world" +-- >>> over (types @String) (++ "!") myTree +-- WithWeight (Fork (Leaf (Just "hello!")) (Leaf Nothing)) "world!" +-- +-- The traversal is /deep/, which means that not just the immediate +-- children are visited, but all nested values too. types :: forall a s. HasTypes s a => Traversal' s a types = types_ @s @a {-# INLINE types #-} @@ -57,129 +100,268 @@ {-# INLINE types_ #-} instance - ( HasTypes' (Interesting s a) s a + ( HasTypesUsing ChGeneric s a ) => HasTypes s a where - types_ = types' @(Interesting s a) + types_ = typesUsing_ @ChGeneric {-# INLINE types_ #-} -class HasTypes' (t :: Bool) s a where - types' :: Traversal' s a +-------------------------------------------------------------------------------- +data Void +instance {-# OVERLAPPING #-} HasTypes Void a where + types_ _ = pure -instance - ( GHasTypes (Rep s) a +instance {-# OVERLAPPING #-} HasTypes s Void where + types_ _ = pure + +instance {-# OVERLAPPING #-} HasTypesUsing ch Void a where + typesUsing_ _ = pure + +instance {-# OVERLAPPING #-} HasTypesUsing ch s Void where + typesUsing_ _ = pure +-------------------------------------------------------------------------------- + +-------------------------------------------------------------------------------- +-- HasTypesUsing +-------------------------------------------------------------------------------- + +-- $custom +-- +-- The default traversal strategy 'types' recurses into each node of the type +-- using the 'Generic' instance for the nodes. However, in general not all +-- nodes will have a 'Generic' instance. For example: +-- +-- >>> data Opaque = Opaque String deriving Show +-- >>> myTree = WithWeight (Fork (Leaf (Opaque "foo")) (Leaf (Opaque "bar"))) False +-- >>> over (types @String) (++ "!") myTree +-- ... +-- ... | No instance for ‘Generic Opaque’ +-- ... | arising from a generic traversal. +-- ... | Either derive the instance, or define a custom traversal using ‘HasTypesCustom’ +-- ... +-- +-- In these cases, we can define a custom traversal strategy to override the +-- generic behaviour for certain types. +-- For a self-contained example, see the CustomChildren module in the tests directory. + +-- | The children of a type are the types of its fields. +-- The 'Children' type family maps a type @a@ to its set of children. +-- +-- This type family is parameterized by a symbol @ch@ (that can be declared as +-- an empty data type). +-- The symbol 'ChGeneric' provides a default definition. You can create new +-- symbols to override the set of children of abstract, non-generic types. +-- +-- The following example declares a @Custom@ symbol to redefine 'Children' +-- for some abstract types from the @time@ library. +-- +-- @ +-- data Custom +-- type instance 'Children' Custom a = ChildrenCustom a +-- +-- type family ChildrenCustom (a :: Type) where +-- ChildrenCustom DiffTime = '[] +-- ChildrenCustom NominalDiffTime = '[] +-- -- Add more custom mappings here. +-- +-- ChildrenCustom a = Children ChGeneric a +-- @ +-- +-- To use this definition, replace 'types' with @'typesUsing' \@Custom@. +type family Children (ch :: Type) (a :: Type) :: [Type] + +-- | @since 1.2.0.0 +typesUsing :: forall ch a s. HasTypesUsing ch s a => Traversal' s a +typesUsing = typesUsing_ @ch @s @a +{-# INLINE typesUsing #-} + +-- | @since 1.2.0.0 +class HasTypesUsing (ch :: Type) s a where + typesUsing_ :: Traversal' s a + +instance {-# OVERLAPPABLE #-} + ( HasTypesOpt ch (Interesting ch a s) s a + ) => HasTypesUsing ch s a where + typesUsing_ = typesOpt @ch @(Interesting ch a s) + {-# INLINE typesUsing_ #-} + +-- TODO: should this instance be incoherent? +instance {-# OVERLAPPABLE #-} HasTypesUsing ch a a where + typesUsing_ = id + +-- | By adding instances to this class, we can override the default +-- behaviour in an ad-hoc manner. +-- For example: +-- +-- @ +-- instance HasTypesCustom Custom Opaque String where +-- typesCustom f (Opaque str) = Opaque <$> f str +-- @ +-- +-- @since 1.2.0.0 +class HasTypesCustom (ch :: Type) s a where + -- | This function should never be used directly, only to override + -- the default traversal behaviour. To actually use the custom + -- traversal strategy, see 'typesUsing'. This is because 'typesUsing' does + -- additional optimisations, like ensuring that nodes with no relevant members will + -- not be traversed at runtime. + typesCustom :: Traversal' s a + +instance {-# OVERLAPPABLE #-} + ( GHasTypes ch (Rep s) a , Generic s - ) => HasTypes' 'True s a where - types' f s = to <$> gtypes_ f (from s) + -- if there's no Generic instance here, it means we got through the + -- Children check by a user-defined custom strategy. + -- Therefore, we can ignore the missing Generic instance, and + -- instead report a missing HasTypesCustom instance + , Defined (Rep s) + (PrettyError '[ 'Text "No instance " ':<>: QuoteType (HasTypesCustom ch s a)]) + (() :: Constraint) + ) => HasTypesCustom ch s a where + typesCustom f s = to <$> gtypes_ @ch f (from s) --{-# INLINE types' #-} -instance HasTypes' 'False s a where - types' _ = pure - --{-# INLINE types' #-} -instance {-# OVERLAPPING #-} HasTypes Bool a -instance {-# OVERLAPPING #-} HasTypes Char a -instance {-# OVERLAPPING #-} HasTypes Double a -instance {-# OVERLAPPING #-} HasTypes Float 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 +-- | The default definition of 'Children'. +-- Primitive types from core libraries have no children, and other types are +-- assumed to be 'Generic'. +data ChGeneric +type instance Children ChGeneric a = ChildrenDefault a +type family ChildrenDefault (a :: Type) :: [Type] where + ChildrenDefault Char = '[] + ChildrenDefault Double = '[] + ChildrenDefault Float = '[] + ChildrenDefault Integer = '[] + ChildrenDefault Int = '[] + ChildrenDefault Int8 = '[] + ChildrenDefault Int16 = '[] + ChildrenDefault Int32 = '[] + ChildrenDefault Int64 = '[] + ChildrenDefault Word = '[] + ChildrenDefault Word8 = '[] + ChildrenDefault Word16 = '[] + ChildrenDefault Word32 = '[] + ChildrenDefault Word64 = '[] + ChildrenDefault T.Text = '[] + ChildrenDefault a + = Defined (Rep a) + (NoGeneric a + '[ 'Text "arising from a generic traversal." + , 'Text "Either derive the instance, or define a custom traversal using " ':<>: QuoteType HasTypesCustom + ]) + (ChildrenGeneric (Rep a) '[]) + +type family ChildrenGeneric (f :: k -> Type) (cs :: [Type]) :: [Type] where + ChildrenGeneric (M1 _ _ f) cs = ChildrenGeneric f cs + ChildrenGeneric (l :*: r) cs = ChildrenGeneric l (ChildrenGeneric r cs) + ChildrenGeneric (l :+: r) cs = ChildrenGeneric l (ChildrenGeneric r cs) + ChildrenGeneric (Rec0 a) cs = a ': cs + ChildrenGeneric _ cs = cs + -------------------------------------------------------------------------------- +-- Internals +-------------------------------------------------------------------------------- +-- TODO: these should never leak out in error messages -class GHasTypes s a where +class HasTypesOpt (ch :: Type) (t :: Bool) s a where + typesOpt :: Traversal' s a + +instance HasTypesCustom ch s a => HasTypesOpt ch 'True s a where + typesOpt = typesCustom @ch + +instance HasTypesOpt ch 'False s a where + typesOpt _ = pure + --{-# INLINE typesOpt #-} + +-------------------------------------------------------------------------------- + +class GHasTypes ch s a where gtypes_ :: Traversal' (s x) a instance - ( GHasTypes l a - , GHasTypes r a - ) => GHasTypes (l :*: r) a where - gtypes_ f (l :*: r) = (:*:) <$> gtypes_ f l <*> gtypes_ f r + ( GHasTypes ch l a + , GHasTypes ch r a + ) => GHasTypes ch (l :*: r) a where + gtypes_ f (l :*: r) = (:*:) <$> gtypes_ @ch f l <*> gtypes_ @ch f r {-# INLINE gtypes_ #-} instance - ( GHasTypes l a - , GHasTypes r a - ) => GHasTypes (l :+: r) a where - gtypes_ f (L1 l) = L1 <$> gtypes_ f l - gtypes_ f (R1 r) = R1 <$> gtypes_ f r + ( GHasTypes ch l a + , GHasTypes ch r a + ) => GHasTypes ch (l :+: r) a where + gtypes_ f (L1 l) = L1 <$> gtypes_ @ch f l + gtypes_ f (R1 r) = R1 <$> gtypes_ @ch f r {-# INLINE gtypes_ #-} -instance (GHasTypes s a) => GHasTypes (M1 m meta s) a where - gtypes_ f (M1 s) = M1 <$> gtypes_ f s +instance (GHasTypes ch s a) => GHasTypes ch (M1 m meta s) a where + gtypes_ f (M1 s) = M1 <$> gtypes_ @ch f s {-# INLINE gtypes_ #-} -instance {-# OVERLAPPING #-} GHasTypes (Rec0 a) a where - gtypes_ f (K1 x) = K1 <$> f x +-- | In the recursive case, we invoke 'HasTypesUsing' again, using the +-- same strategy +instance HasTypesUsing ch b a => GHasTypes ch (Rec0 b) a where + gtypes_ f (K1 x) = K1 <$> typesUsing_ @ch @b @a f x {-# INLINE gtypes_ #-} -instance HasTypes b a => GHasTypes (Rec0 b) a where - gtypes_ f (K1 x) = K1 <$> types_ @_ @a f x +-- | The default instance for 'HasTypes' acts as a synonym for +-- 'HasTypesUsing ChGeneric', so in most cases this instance should +-- behave the same as the one above. +-- However, there might be overlapping instances defined for +-- 'HasTypes' directly, in which case we want to prefer those +-- instances (even though the custom instances should always be added to 'HasTypesCustom') +instance {-# OVERLAPPING #-} HasTypes b a => GHasTypes ChGeneric (Rec0 b) a where + gtypes_ f (K1 x) = K1 <$> types_ @b @a f x {-# INLINE gtypes_ #-} -instance GHasTypes U1 a where +instance GHasTypes ch U1 a where gtypes_ _ _ = pure U1 {-# INLINE gtypes_ #-} -instance GHasTypes V1 a where +instance GHasTypes ch V1 a where gtypes_ _ = pure {-# INLINE gtypes_ #-} -type Interesting f a = Snd (Interesting' (Rep f) a '[f]) +type Interesting (ch :: Type) (a :: Type) (t :: Type) + = Defined_list (Children ch t) (NoChildren ch t) + (IsNothing (Interesting' ch a '[t] (Children ch t))) -type family Interesting' f (a :: Type) (seen :: [Type]) :: ([Type], Bool) where - Interesting' (M1 _ m f) t seen - = Interesting' f t seen - -- The result of the left branch is passed on to the right branch in order to avoid duplicate work - Interesting' (l :*: r) t seen - = InterestingOr (Interesting' l t seen) r t - Interesting' (l :+: r) t seen - = InterestingOr (Interesting' l t seen) r t - Interesting' (Rec0 t) t seen - = '(seen, 'True) - Interesting' (Rec0 Char) _ seen = '(seen ,'False) - Interesting' (Rec0 Double) _ seen = '(seen ,'False) - Interesting' (Rec0 Float) _ 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 - = '(seen, 'False) +type family NoChildren (ch :: Type) (a :: Type) :: Constraint where + NoChildren ch a = PrettyError + '[ 'Text "No type family instance for " ':<>: QuoteType (Children ch a) + , 'Text "arising from a traversal over " ':<>: QuoteType a + , 'Text "with custom strategy " ':<>: QuoteType ch + ] + +type family Interesting' (ch :: Type) (a :: Type) (seen :: [Type]) (ts :: [Type]) :: Maybe [Type] where + Interesting' ch _ seen '[] = 'Just seen + Interesting' ch a seen (t ': ts) = + InterestingOr ch a (InterestingUnless ch a seen t (Elem t seen)) ts + -- Short circuit --- Note: we only insert 'r' to the seen list if it's not already there (which is precisely when `s` is 'False) -type family InterestingUnless (s :: Bool) f (a :: Type) (r :: Type) (seen :: [Type]) :: ([Type], Bool) where - InterestingUnless 'True _ _ _ seen = '(seen, 'False) - InterestingUnless 'False f a r seen = Interesting' f a (r ': seen) +-- Note: we only insert 't' to the seen list if it's not already there (which is precisely when `s` is 'False) +type family InterestingUnless + (ch :: Type) (a :: Type) (seen :: [Type]) (t :: Type) (alreadySeen :: Bool) :: + Maybe [Type] where + InterestingUnless ch a seen a _ = 'Nothing + InterestingUnless ch a seen t 'True = 'Just seen + InterestingUnless ch a seen t 'False + = Defined_list (Children ch t) (NoChildren ch t) + (Interesting' ch a (t ': seen) (Children ch t)) -- Short circuit -type family InterestingOr (b :: ([Type], Bool)) r t :: ([Type], Bool) where - InterestingOr '(seen, 'True) _ _ = '(seen, 'True) - InterestingOr '(seen, 'False) r t = Interesting' r t seen +type family InterestingOr + (ch :: Type) (a :: Type) (seen' :: Maybe [Type]) (ts :: [Type]) :: + Maybe [Type] where + InterestingOr ch a 'Nothing _ = 'Nothing + InterestingOr ch a ('Just seen) ts = Interesting' ch a seen ts type family Elem a as where Elem a (a ': _) = 'True Elem a (_ ': as) = Elem a as Elem a '[] = 'False -type family Snd a where - Snd '(_, b) = b +type family IsNothing a where + IsNothing ('Just _) = 'False + IsNothing 'Nothing = 'True 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) 2018 Csongor Kiss +-- Copyright : (C) 2019 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) 2018 Csongor Kiss +-- Copyright : (C) 2019 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) 2018 Csongor Kiss +-- Copyright : (C) 2019 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- Stability : experimental @@ -45,6 +45,7 @@ import Data.Generics.Internal.VL.Prism import Data.Generics.Internal.Profunctor.Iso import Data.Generics.Internal.Profunctor.Prism (prismPRavel) +import Data.Generics.Internal.Errors -- $setup -- == /Running example:/ @@ -70,7 +71,7 @@ -- , age :: Age -- , fieldA :: a -- } --- deriving (Generic, Show) +-- deriving Show -- type Name = String -- type Age = Int -- dog, cat, duck :: Animal Int @@ -128,39 +129,55 @@ ( Generic s , ErrorUnless ctor s (HasCtorP ctor (Rep s)) , GAsConstructor' ctor (Rep s) a + , Defined (Rep s) + (NoGeneric s '[ 'Text "arising from a generic prism focusing on the " + ':<>: QuoteType ctor ':<>: 'Text " constructor of type " ':<>: QuoteType a + , 'Text "in " ':<>: QuoteType s]) + (() :: Constraint) ) => AsConstructor' ctor s a where _Ctor' eta = prismRavel (prismPRavel (repIso . _GCtor @ctor)) eta {-# INLINE[2] _Ctor' #-} instance - ( Generic s - , Generic t - , ErrorUnless ctor s (HasCtorP ctor (Rep s)) + ( 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 (Indexed t)) b' , s ~ Infer t b' a + , AsConstructor0 ctor s t a b ) => AsConstructor ctor s t a b where _Ctor = _Ctor0 @ctor {-# INLINE[2] _Ctor #-} --- See Note [Uncluttering type signatures] +-- | See Note [Uncluttering type signatures] +#if __GLASGOW_HASKELL__ < 804 +-- >>> :t _Ctor +-- _Ctor +-- :: (Applicative f, Data.Profunctor.Choice.Choice p, +-- AsConstructor ctor s t a b) => +-- p a (f b) -> p s (f t) +#else +-- >>> :t _Ctor +-- _Ctor +-- :: (AsConstructor ctor s t a b, Data.Profunctor.Choice.Choice p, +-- Applicative f) => +-- p a (f b) -> p s (f t) +#endif 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)) + ( 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 + , AsConstructor0 ctor s t a b ) => AsConstructor_ ctor s t a b where _Ctor_ = _Ctor0 @ctor @@ -173,6 +190,11 @@ ( Generic s , Generic t , GAsConstructor ctor (Rep s) (Rep t) a b + , Defined (Rep s) + (NoGeneric s '[ 'Text "arising from a generic prism focusing on the " + ':<>: QuoteType ctor ':<>: 'Text " constructor of type " ':<>: QuoteType a + , 'Text "in " ':<>: QuoteType s]) + (() :: Constraint) ) => AsConstructor0 ctor s t a b where _Ctor0 = prismRavel (prismPRavel (repIso . _GCtor @ctor)) {-# INLINE[2] _Ctor0 #-} 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) 2018 Csongor Kiss +-- Copyright : (C) 2019 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- Stability : experimental 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) 2018 Csongor Kiss +-- Copyright : (C) 2019 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- Stability : experimental 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) 2018 Csongor Kiss +-- Copyright : (C) 2019 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- Stability : experimental 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MonoLocalBinds #-} @@ -11,7 +12,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Sum.Subtype --- Copyright : (C) 2018 Csongor Kiss +-- Copyright : (C) 2019 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- Stability : experimental @@ -113,10 +114,45 @@ _Sub f = prismRavel (repIso . _GSub . fromIso repIso) f {-# INLINE[2] _Sub #-} --- See Note [Uncluttering type signatures] +-- | Reflexive case +-- >>> _Sub # dog :: Animal +-- Dog (MkDog {name = "Shep", age = 3}) +instance {-# OVERLAPPING #-} AsSubtype a a where + _Sub = id + {-# INLINE[2] _Sub #-} + +-- | See Note [Uncluttering type signatures] +#if __GLASGOW_HASKELL__ < 804 +-- >>> :t _Sub +--_Sub +-- :: (Applicative f, Data.Profunctor.Choice.Choice p, +-- AsSubtype sub sup) => +-- p sub (f sub) -> p sup (f sup) +-- >>> :t _Sub +#else +--_Sub +-- :: (AsSubtype sub sup, Data.Profunctor.Choice.Choice p, +-- Applicative f) => +-- p sub (f sub) -> p sup (f sup) +#endif instance {-# OVERLAPPING #-} AsSubtype a Void where injectSub = undefined projectSub = undefined + +-- | See Note [Uncluttering type signatures] +#if __GLASGOW_HASKELL__ < 804 +-- >>> :t _Sub @Int +-- _Sub @Int +-- :: (Applicative f, Data.Profunctor.Choice.Choice p, +-- AsSubtype Int sup) => +-- p Int (f Int) -> p sup (f sup) +#else +-- >>> :t _Sub @Int +-- _Sub @Int +-- :: (AsSubtype Int sup, Data.Profunctor.Choice.Choice p, +-- Applicative f) => +-- p Int (f Int) -> p sup (f sup) +#endif instance {-# OVERLAPPING #-} AsSubtype Void a where injectSub = undefined projectSub = undefined 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} @@ -13,7 +14,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Sum.Typed --- Copyright : (C) 2018 Csongor Kiss +-- Copyright : (C) 2019 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- Stability : experimental @@ -34,6 +35,7 @@ import GHC.Generics import GHC.TypeLits (TypeError, ErrorMessage (..), Symbol) import Data.Generics.Sum.Internal.Typed +import Data.Generics.Internal.Errors import Data.Generics.Internal.Families import Data.Generics.Internal.Void @@ -109,16 +111,45 @@ , as ~ TupleToList a , ListTuple a as , GAsType (Rep s) as + , Defined (Rep s) + (NoGeneric s '[ 'Text "arising from a generic prism focusing on a constructor of type " ':<>: QuoteType a]) + (() :: Constraint) ) => AsType a s where _Typed eta = prismRavel (prismPRavel (repIso . _GTyped @_ @as . tupled)) eta {-# INLINE[2] _Typed #-} --- See Note [Uncluttering type signatures] +-- | See Note [Uncluttering type signatures] +#if __GLASGOW_HASKELL__ < 804 +-- >>> :t _Typed +-- _Typed +-- :: (Applicative f, Data.Profunctor.Choice.Choice p, AsType a s) => +-- p a (f a) -> p s (f s) +#else +-- >>> :t _Typed +-- _Typed +-- :: (AsType a s, Data.Profunctor.Choice.Choice p, Applicative f) => +-- p a (f a) -> p s (f s) +#endif instance {-# OVERLAPPING #-} AsType a Void where _Typed = undefined injectTyped = undefined projectTyped = undefined + +-- | See Note [Uncluttering type signatures] +#if __GLASGOW_HASKELL__ < 804 +-- >>> :t _Typed @Int +-- _Typed @Int +-- :: (Applicative f, Data.Profunctor.Choice.Choice p, +-- AsType Int s) => +-- p Int (f Int) -> p s (f s) +#else +-- >>> :t _Typed @Int +-- _Typed @Int +-- :: (AsType Int s, Data.Profunctor.Choice.Choice p, +-- Applicative f) => +-- p Int (f Int) -> p s (f s) +#endif instance {-# OVERLAPPING #-} AsType Void a where _Typed = undefined injectTyped = undefined diff --git a/src/Data/Generics/Wrapped.hs b/src/Data/Generics/Wrapped.hs --- a/src/Data/Generics/Wrapped.hs +++ b/src/Data/Generics/Wrapped.hs @@ -14,7 +14,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Wrapped --- Copyright : (C) 2018 Csongor Kiss +-- Copyright : (C) 2019 Csongor Kiss -- License : BSD3 -- Maintainer : Csongor Kiss -- Stability : experimental diff --git a/test/CustomChildren.hs b/test/CustomChildren.hs new file mode 100644 --- /dev/null +++ b/test/CustomChildren.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module CustomChildren + ( customTypesTest + ) where + +import GHC.Generics +import Data.Generics.Product +import Test.HUnit +import Data.Generics.Internal.VL.Lens +import Data.Generics.Labels () +import Data.Kind + +-- Opaque has no Generic instance +data Opaque = Opaque String + deriving (Show, Eq) + +-- Hide does have a Generic instance, but we want to hide its contents +-- from the traversal +data Hide = Hide String + deriving (Show, Generic, Eq) + +-- We first define a symbol for the custom traversal +data Custom + +type instance Children Custom a = ChildrenCustom a + +type family ChildrenCustom (a :: Type) where + ChildrenCustom Opaque = '[String] -- here we state explicitly that Opaque contains a String + ChildrenCustom Hide = '[] -- and hide the contents of Hide + ChildrenCustom a = Children ChGeneric a -- for the rest, we defer to the generic children + +-- We define the traversal of Opaque like so: +instance HasTypesCustom Custom Opaque String where + typesCustom f (Opaque str) = Opaque <$> f str + +customTypesTest1 :: Test +customTypesTest1 + = TestCase (assertEqual "foo" (over (typesUsing @Custom @String) (++ "!") original) expected) + where original = (Opaque "foo", Hide "bar") + expected = (Opaque "foo!", Hide "bar") -- only Opaque's String gets modified + +customTypesTest2 :: Test +customTypesTest2 + = TestCase (assertEqual "foo" (over (typesUsing @Custom @String) (++ "!") original) expected) + where original = Opaque "foo" + expected = Opaque "foo!" + +customTypesTest3 :: Test +customTypesTest3 + = TestCase (assertEqual "foo" (over (typesUsing @Custom @String) (++ "!") original) expected) + where original = Hide "foo" + expected = Hide "foo" + +customTypesTest :: Test +customTypesTest = TestList [customTypesTest1, customTypesTest2, customTypesTest3] diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -33,6 +33,8 @@ import Test24 () import Test25 () +import CustomChildren (customTypesTest) + main :: IO () main = do res <- runTestTT tests @@ -267,6 +269,7 @@ , (valLabel ^? #_RecB . _1 ) ~=? Just 3 , (valLabel ^? #_RecC ) ~=? Nothing #endif + , customTypesTest ] where valLabel = RecB 3 True