packages feed

generic-lens 0.3.0.1 → 0.4.0.0

raw patch · 20 files changed

+718/−323 lines, 20 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

generic-lens.cabal view
@@ -1,5 +1,5 @@ name:                 generic-lens-version:              0.3.0.1+version:              0.4.0.0 synopsis:             Generic data-structure operations exposed as lenses. description:          This package uses the GHC 8 Generic representation to derive various operations on data structures with a lens interface, including structural subtype relationship between records and positional indexing into arbitrary product types. @@ -24,17 +24,27 @@                     , Data.Generics.Product.Positions                     , Data.Generics.Product.Subtype                     , Data.Generics.Product.Typed+                     , Data.Generics.Sum                     , Data.Generics.Sum.Any                     , Data.Generics.Sum.Constructors                     , Data.Generics.Sum.Typed-+                    , Data.Generics.Sum.Subtype                     , Data.Generics.Internal.Lens    other-modules:      Data.Generics.Internal.Families                     , Data.Generics.Internal.Families.Count                     , Data.Generics.Internal.Families.Has                     , Data.Generics.Internal.HList++                    , Data.Generics.Sum.Internal.Constructors+                    , Data.Generics.Sum.Internal.Typed+                    , Data.Generics.Sum.Internal.Subtype++                    , Data.Generics.Product.Internal.Fields+                    , Data.Generics.Product.Internal.Positions+                    , Data.Generics.Product.Internal.Subtype+                    , Data.Generics.Product.Internal.Typed    build-depends:      base        >= 4.9 && <= 5.0                     , profunctors >= 5.0 && <= 6.0
src/Data/Generics/Internal/Families/Count.hs view
@@ -20,10 +20,9 @@   , Count (..)   ) where -import GHC.Generics- import Data.Type.Bool     (If) import Data.Type.Equality (type (==))+import GHC.Generics import GHC.TypeLits       (TypeError, ErrorMessage (..))  import Data.Generics.Internal.HList
src/Data/Generics/Internal/Families/Has.hs view
@@ -21,10 +21,9 @@   , HasCtorP   ) where -import GHC.Generics- import Data.Type.Bool     (type (||), type (&&)) import Data.Type.Equality (type (==))+import GHC.Generics import GHC.TypeLits       (Symbol, TypeError, ErrorMessage (..))  import Data.Generics.Internal.HList
src/Data/Generics/Internal/HList.hs view
@@ -6,7 +6,6 @@ {-# LANGUAGE MultiParamTypeClasses  #-} {-# LANGUAGE PolyKinds              #-} {-# LANGUAGE ScopedTypeVariables    #-}-{-# LANGUAGE TypeApplications       #-} {-# LANGUAGE TypeFamilies           #-} {-# LANGUAGE TypeOperators          #-} {-# LANGUAGE UndecidableInstances   #-}
src/Data/Generics/Product/Fields.hs view
@@ -28,13 +28,11 @@      --  $example     HasField (..)--    -- *Internals-  , GHasField (..)   ) where  import Data.Generics.Internal.Families import Data.Generics.Internal.Lens+import Data.Generics.Product.Internal.Fields  import Data.Kind    (Constraint, Type) import GHC.Generics@@ -106,36 +104,3 @@    ErrorUnless _ _ 'True     = ()---- |As 'HasField' but over generic representations as defined by---  "GHC.Generics".-class GHasField (field :: Symbol) (f :: Type -> Type) a | field f -> a where-  gfield :: Lens' (f x) a--instance GProductHasField field l r a (HasTotalFieldP field l)-      => GHasField field (l :*: r) a where--  gfield = gproductField @field @_ @_ @_ @(HasTotalFieldP field l)--instance (GHasField field l a, GHasField field r a)-      =>  GHasField field (l :+: r) a where--  gfield = combine (gfield @field @l) (gfield @field @r)--instance GHasField field (S1 ('MetaSel ('Just field) upkd str infstr) (Rec0 a)) a where-  gfield = mIso . kIso--instance GHasField field f a => GHasField field (M1 D meta f) a where-  gfield = mIso . gfield @field--instance GHasField field f a => GHasField field (M1 C meta f) a where-  gfield = mIso . gfield @field--class GProductHasField (field :: Symbol) l r a (left :: Bool) | left field l r -> a where-  gproductField :: Lens' ((l :*: r) x) a--instance GHasField field l a => GProductHasField field l r a 'True where-  gproductField = first . gfield @field--instance GHasField field r a => GProductHasField field l r a 'False where-  gproductField = second . gfield @field
+ src/Data/Generics/Product/Internal/Fields.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE AllowAmbiguousTypes    #-}+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE KindSignatures         #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TypeApplications       #-}+{-# LANGUAGE TypeFamilies           #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE UndecidableInstances   #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Generics.Product.Internal.Fields+-- Copyright   :  (C) 2017 Csongor Kiss+-- License     :  BSD3+-- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Derive record field getters and setters generically.+--+-----------------------------------------------------------------------------++module Data.Generics.Product.Internal.Fields+  ( GHasField (..)+  ) where++import Data.Generics.Internal.Families+import Data.Generics.Internal.Lens++import Data.Kind    (Type)+import GHC.Generics+import GHC.TypeLits (Symbol)++-- |As 'HasField' but over generic representations as defined by+--  "GHC.Generics".+class GHasField (field :: Symbol) (f :: Type -> Type) a | field f -> a where+  gfield :: Lens' (f x) a++instance GProductHasField field l r a (HasTotalFieldP field l)+      => GHasField field (l :*: r) a where++  gfield = gproductField @field @_ @_ @_ @(HasTotalFieldP field l)++instance (GHasField field l a, GHasField field r a)+      =>  GHasField field (l :+: r) a where++  gfield = combine (gfield @field @l) (gfield @field @r)++instance GHasField field (S1 ('MetaSel ('Just field) upkd str infstr) (Rec0 a)) a where+  gfield = mIso . kIso++instance GHasField field f a => GHasField field (M1 D meta f) a where+  gfield = mIso . gfield @field++instance GHasField field f a => GHasField field (M1 C meta f) a where+  gfield = mIso . gfield @field++class GProductHasField (field :: Symbol) l r a (left :: Bool) | left field l r -> a where+  gproductField :: Lens' ((l :*: r) x) a++instance GHasField field l a => GProductHasField field l r a 'True where+  gproductField = first . gfield @field++instance GHasField field r a => GProductHasField field l r a 'False where+  gproductField = second . gfield @field
+ src/Data/Generics/Product/Internal/Positions.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE AllowAmbiguousTypes    #-}+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE KindSignatures         #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE PolyKinds              #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TypeApplications       #-}+{-# LANGUAGE TypeFamilies           #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE UndecidableInstances   #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Generics.Product.Internal.Positions+-- Copyright   :  (C) 2017 Csongor Kiss+-- License     :  BSD3+-- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Derive positional product type getters and setters generically.+--+-----------------------------------------------------------------------------++module Data.Generics.Product.Internal.Positions+  ( GHasPosition (..)+  , type (<?)+  , Size+  ) where++import Data.Generics.Internal.Lens++import Data.Kind      (Type)+import Data.Type.Bool (If, Not)+import GHC.Generics+import GHC.TypeLits   (type (<=?), type (+), Nat)++-- |As 'HasPosition' but over generic representations as defined by+--  "GHC.Generics".+class GHasPosition (offset :: Nat) (i :: Nat) (f :: Type -> Type) a | offset i f -> a where+  gposition :: Lens' (f x) a++instance GHasPosition i i (S1 meta (Rec0 a)) a where+  gposition = mIso . kIso++instance GHasPosition offset i f a => GHasPosition offset i (M1 D meta f) a where+  gposition = mIso . gposition @offset @i++instance GHasPosition offset i f a => GHasPosition offset i (M1 C meta f) a where+  gposition = mIso . gposition @offset @i++instance+  ( goLeft  ~ (i <? (offset + Size l))+  , offset' ~ (If goLeft offset (offset + Size l))+  , GProductHasPosition offset' i l r a goLeft+  ) => GHasPosition offset i (l :*: r) a where++  gposition = gproductPosition @offset' @i @_ @_ @_ @goLeft+++class GProductHasPosition (offset :: Nat) (i :: Nat) l r a (left :: Bool) | offset i l r left -> a where+  gproductPosition :: Lens' ((l :*: r) x) a++instance GHasPosition offset i l a => GProductHasPosition offset i l r a 'True where+  gproductPosition = first . gposition @offset @i++instance GHasPosition offset i r a => GProductHasPosition offset i l r a 'False where+  gproductPosition = second . gposition @offset @i++type family Size f :: Nat where+  Size (l :*: r)+    = Size l + Size r+  Size (l :+: r)+    = Min (Size l) (Size r)+  Size (D1 meta f)+    = Size f+  Size (C1 meta f)+    = Size f+  Size f+    = 1++--------------------------------------------------------------------------------++type x <? y = Not (y <=? x)+infixl 4 <?++type Min a b = If (a <? b) a b
+ src/Data/Generics/Product/Internal/Subtype.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE AllowAmbiguousTypes       #-}+{-# LANGUAGE DataKinds                 #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE MultiParamTypeClasses     #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE PolyKinds                 #-}+{-# LANGUAGE Rank2Types                #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE TypeApplications          #-}+{-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE TypeOperators             #-}+{-# LANGUAGE UndecidableInstances      #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Generics.Product.Internal.Subtype+-- Copyright   :  (C) 2017 Csongor Kiss+-- License     :  BSD3+-- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Structural subtype relationships between product types.+--+-----------------------------------------------------------------------------++module Data.Generics.Product.Internal.Subtype+  ( GUpcast (..)+  , GSmash (..)+  ) where++import Data.Generics.Internal.Families+import Data.Generics.Internal.Lens+import Data.Generics.Product.Internal.Fields++import Data.Kind (Type)+import GHC.Generics++--------------------------------------------------------------------------------+-- * Generic upcasting++class GUpcast (sub :: Type -> Type) (sup :: Type -> Type) where+  gupcast :: sub p -> sup p++instance (GUpcast sub a, GUpcast sub b) => GUpcast sub (a :*: b) where+  gupcast rep = gupcast rep :*: gupcast rep++instance+  GHasField field sub t+  => GUpcast sub (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) where++  gupcast r = M1 (K1 (r ^. gfield @field))++instance GUpcast sub sup => GUpcast sub (C1 c sup) where+  gupcast = M1 . gupcast++instance GUpcast sub sup => GUpcast sub (D1 c sup) where+  gupcast = M1 . gupcast++--------------------------------------------------------------------------------+-- * Generic smashing++class GSmash sub sup where+  gsmash :: sup p -> sub p -> sub p++instance (GSmash a sup, GSmash b sup) => GSmash (a :*: b) sup where+  gsmash rep (a :*: b) = gsmash rep a :*: gsmash rep b++instance+  ( leaf ~ (S1 ('MetaSel ('Just field) p f b) t)+  , GSmashLeaf leaf sup (HasTotalFieldP field sup)+  ) => GSmash (S1 ('MetaSel ('Just field) p f b) t) sup where++  gsmash = gsmashLeaf @_ @_ @(HasTotalFieldP field sup)++instance GSmash sub sup => GSmash (C1 c sub) sup where+  gsmash sup (M1 sub) = M1 (gsmash sup sub)++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+  gsmashLeaf :: sup p -> sub p -> sub p++instance+  GHasField field sup t+  => GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'True where+  gsmashLeaf sup _ = M1 (K1 (sup ^. gfield @field))++instance GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'False where+  gsmashLeaf _ = id
+ src/Data/Generics/Product/Internal/Typed.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE AllowAmbiguousTypes   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE KindSignatures        #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE UndecidableInstances  #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Generics.Product.Internal.Typed+-- Copyright   :  (C) 2017 Csongor Kiss+-- License     :  BSD3+-- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Derive record field getters and setters generically.+--+-----------------------------------------------------------------------------++module Data.Generics.Product.Internal.Typed+  ( GHasType (..)+  ) where++import Data.Generics.Internal.Families+import Data.Generics.Internal.Lens++import Data.Kind    (Type)+import GHC.Generics++-- |As 'HasType' but over generic representations as defined by+--  "GHC.Generics".+class GHasType (f :: Type -> Type) a where+  gtyped :: Lens' (f x) a++instance GProductHasType l r a (HasTotalTypeP a l)+      => GHasType (l :*: r) a where++  gtyped = gproductTyped @_ @_ @_ @(HasTotalTypeP a l)++instance (GHasType l a, GHasType r a) => GHasType (l :+: r) a where+  gtyped = combine (gtyped @l) (gtyped @r)++instance GHasType (K1 R a) a where+  gtyped f (K1 x) = fmap K1 (f x)++instance GHasType f a => GHasType (M1 m meta f) a where+  gtyped = mIso . gtyped++class GProductHasType l r a (contains :: Bool) where+  gproductTyped :: Lens' ((l :*: r) x) a++instance GHasType l a => GProductHasType l r a 'True where+  gproductTyped = first . gtyped++instance GHasType r a => GProductHasType l r a 'False where+  gproductTyped = second . gtyped
src/Data/Generics/Product/Positions.hs view
@@ -29,17 +29,15 @@      --  $example     HasPosition (..)--    -- *Internals-  , GHasPosition (..)   ) where  import Data.Generics.Internal.Lens+import Data.Generics.Product.Internal.Positions  import Data.Kind      (Constraint, Type)-import Data.Type.Bool (If, type (&&), Not)+import Data.Type.Bool (type (&&)) import GHC.Generics-import GHC.TypeLits   (type (<=?), type (+), Nat, TypeError, ErrorMessage(..))+import GHC.TypeLits   (type (<=?),  Nat, TypeError, ErrorMessage(..))  --  $example --  @@@ -108,54 +106,3 @@    ErrorUnless _ _ 'True     = ()---- |As 'HasPosition' but over generic representations as defined by---  "GHC.Generics".-class GHasPosition (offset :: Nat) (i :: Nat) (f :: Type -> Type) a | offset i f -> a where-  gposition :: Lens' (f x) a--instance GHasPosition i i (S1 meta (Rec0 a)) a where-  gposition = mIso . kIso--instance GHasPosition offset i f a => GHasPosition offset i (M1 D meta f) a where-  gposition = mIso . gposition @offset @i--instance GHasPosition offset i f a => GHasPosition offset i (M1 C meta f) a where-  gposition = mIso . gposition @offset @i--instance-  ( goLeft  ~ (i <? (offset + Size l))-  , offset' ~ (If goLeft offset (offset + Size l))-  , GProductHasPosition offset' i l r a goLeft-  ) => GHasPosition offset i (l :*: r) a where--  gposition = gproductPosition @offset' @i @_ @_ @_ @goLeft---class GProductHasPosition (offset :: Nat) (i :: Nat) l r a (left :: Bool) | offset i l r left -> a where-  gproductPosition :: Lens' ((l :*: r) x) a--instance GHasPosition offset i l a => GProductHasPosition offset i l r a 'True where-  gproductPosition = first . gposition @offset @i--instance GHasPosition offset i r a => GProductHasPosition offset i l r a 'False where-  gproductPosition = second . gposition @offset @i--type family Size f :: Nat where-  Size (l :*: r)-    = Size l + Size r-  Size (l :+: r)-    = Min (Size l) (Size r)-  Size (D1 meta f)-    = Size f-  Size (C1 meta f)-    = Size f-  Size f-    = 1------------------------------------------------------------------------------------type x <? y = Not (y <=? x)-infixl 4 <?--type Min a b = If (a <? b) a b
src/Data/Generics/Product/Subtype.hs view
@@ -21,53 +21,52 @@ -- Stability   :  experimental -- Portability :  non-portable ----- Structural subtype relationship between record types.------ The running example in this module is the following two types:------ @------   module Test where------   import GHC.Generics---   import Data.Generics.Record------   data Human = Human---     { name    :: String---     , age     :: Int---     , address :: String---     } deriving (Generic, Show)------   data Animal = Animal---     { name    :: String---     , age     :: Int---     } deriving (Generic, Show)------    human :: Human---    human = Human \"Tunyasz\" 50 \"London\"------ @+-- Structural subtype relationships between product types. -- -----------------------------------------------------------------------------+ module Data.Generics.Product.Subtype-  ( Subtype (..)+  ( -- *Lenses+    --+    --  $example+    Subtype (..)   ) where -import Data.Generics.Internal.Families import Data.Generics.Internal.Lens-import Data.Generics.Product.Fields+import Data.Generics.Product.Internal.Subtype -import Data.Kind (Type)-import GHC.Generics+import GHC.Generics (Generic (Rep, to, from) ) +--  $example+--  @+--     module Example where+--+--     import Data.Generics.Product+--     import GHC.Generics+--+--     data Human = Human+--       { name    :: String+--       , age     :: Int+--       , address :: String+--       } deriving (Generic, Show)+--+--     data Animal = Animal+--       { name    :: String+--       , age     :: Int+--       } deriving (Generic, Show)+--+--     human :: Human+--     human = Human \"Tunyasz\" 50 \"London\"+--  @+ -- |Structural subtype relationship -- -- @sub@ is a (structural) `subtype' of @sup@, if its fields are a subset of -- those of @sup@. -- class Subtype sup sub where-  -- | Structural subtype lens. Given a subtype relationship @sub :< sup@,-  --   we can focus on the @sub@ structure of @sup@.+  -- |Structural subtype lens. Given a subtype relationship @sub :< sup@,+  --  we can focus on the @sub@ structure of @sup@.   --   -- >>> human ^. super @Animal   -- Animal {name = "Tunyasz", age = 50}@@ -78,7 +77,7 @@   super f sub     = fmap (`smash` sub) (f (upcast sub)) -  -- | Cast the more specific subtype to the more general supertype+  -- |Cast the more specific subtype to the more general supertype   --   -- >>> upcast human :: Animal   -- Animal {name = "Tunyasz", age = 50}@@ -86,7 +85,7 @@   upcast :: sub -> sup   upcast s = s ^. super @sup -  -- | Plug a smaller structure into a larger one+  -- |Plug a smaller structure into a larger one   --   -- >>> smash (Animal "dog" 10) human   -- Human {name = "dog", age = 10, address = "London"}@@ -95,7 +94,6 @@    {-# MINIMAL super | smash, upcast #-} --- | Instances are created by the compiler instance   ( GSmash (Rep a) (Rep b)   , GUpcast (Rep a) (Rep b)@@ -104,58 +102,3 @@   ) => Subtype b a where     smash p b = to $ gsmash (from p) (from b)     upcast    = to . gupcast . from------------------------------------------------------------------------------------- * Generic upcasting---- | Upcast 'sub to 'sup' (generic rep)-class GUpcast (sub :: Type -> Type) (sup :: Type -> Type) where-  gupcast :: sub p -> sup p--instance (GUpcast sub a, GUpcast sub b) => GUpcast sub (a :*: b) where-  gupcast rep = gupcast rep :*: gupcast rep--instance-  GHasField field sub t-  => GUpcast sub (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) where--  gupcast r = M1 (K1 (r ^. gfield @field))--instance GUpcast sub sup => GUpcast sub (C1 c sup) where-  gupcast = M1 . gupcast--instance GUpcast sub sup => GUpcast sub (D1 c sup) where-  gupcast = M1 . gupcast------------------------------------------------------------------------------------- * Generic smashing--class GSmash sub sup where-  gsmash :: sup p -> sub p -> sub p--instance (GSmash a sup, GSmash b sup) => GSmash (a :*: b) sup where-  gsmash rep (a :*: b) = gsmash rep a :*: gsmash rep b--instance-  ( leaf ~ (S1 ('MetaSel ('Just field) p f b) t)-  , GSmashLeaf leaf sup (HasTotalFieldP field sup)-  ) => GSmash (S1 ('MetaSel ('Just field) p f b) t) sup where--  gsmash = gsmashLeaf @_ @_ @(HasTotalFieldP field sup)--instance GSmash sub sup => GSmash (C1 c sub) sup where-  gsmash sup (M1 sub) = M1 (gsmash sup sub)--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-  gsmashLeaf :: sup p -> sub p -> sub p--instance-  GHasField field sup t-  => GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'True where-  gsmashLeaf sup _ = M1 (K1 (sup ^. gfield @field))--instance GSmashLeaf (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) sup 'False where-  gsmashLeaf _ = id
src/Data/Generics/Product/Typed.hs view
@@ -28,16 +28,14 @@     --     --  $example     HasType (..)--    -- *Internals-  , GHasType (..)   ) where  import Data.Generics.Internal.Families import Data.Generics.Internal.Lens+import Data.Generics.Product.Internal.Typed  import Data.Kind    (Constraint, Type)-import GHC.Generics+import GHC.Generics (Generic (Rep)) import GHC.TypeLits (TypeError, ErrorMessage (..))  --  $example@@ -58,7 +56,7 @@ --    human = Human \"Tunyasz\" 50 \"London\" --  @ ---  | Records that have a field with a unique type.+-- |Records that have a field with a unique type. class HasType a s where   -- |A lens that focuses on a field with a unique type in its parent type.   --  Compatible with the lens package's 'Control.Lens.Lens' type.@@ -69,11 +67,11 @@   typed f t     = fmap (flip (setTyped @a) t) (f (getTyped @a t)) -  -- |Get field at type+  -- |Get field at type.   getTyped :: s -> a   getTyped s = s ^. typed @a -  -- |Set field at type+  -- |Set field at type.   setTyped :: a -> s -> s   setTyped = set (typed @a) @@ -107,31 +105,3 @@    ErrorUnlessOne _ _ 'One     = ()---- |As 'HasType' but over generic representations as defined by---  "GHC.Generics".-class GHasType (f :: Type -> Type) a where-  gtyped :: Lens' (f x) a--instance GProductHasType l r a (HasTotalTypeP a l)-      => GHasType (l :*: r) a where--  gtyped = gproductTyped @_ @_ @_ @(HasTotalTypeP a l)--instance (GHasType l a, GHasType r a) => GHasType (l :+: r) a where-  gtyped = combine (gtyped @l) (gtyped @r)--instance GHasType (K1 R a) a where-  gtyped f (K1 x) = fmap K1 (f x)--instance GHasType f a => GHasType (M1 m meta f) a where-  gtyped = mIso . gtyped--class GProductHasType l r a (contains :: Bool) where-  gproductTyped :: Lens' ((l :*: r) x) a--instance GHasType l a => GProductHasType l r a 'True where-  gproductTyped = first . gtyped--instance GHasType r a => GProductHasType l r a 'False where-  gproductTyped = second . gtyped
src/Data/Generics/Sum.hs view
@@ -20,9 +20,11 @@     AsAny (..)    , AsConstructor (..)+  , AsSubtype (..)   , AsType (..)   ) where  import Data.Generics.Sum.Any import Data.Generics.Sum.Constructors+import Data.Generics.Sum.Subtype import Data.Generics.Sum.Typed
src/Data/Generics/Sum/Any.hs view
@@ -41,7 +41,7 @@ -- --    data Animal --      = Dog Dog---      | Cat (Name, Age)+--      | Cat Name Age --      | Duck Age --      deriving (Generic, Show) --@@ -57,7 +57,7 @@ --    dog, cat, duck :: Animal -- --    dog = Dog (MkDog "Shep" 3)---    cat = Cat ("Mog", 5)+--    cat = Cat "Mog" 5 --    duck = Duck 2 --  @ @@ -73,10 +73,12 @@   --  Just (MkDog {name = "Shep", age = 3})   --  >>> dog ^? _As @"Cat"   --  Nothing+  --  >>> cat ^? _As @(Name, Age)+  --  Just ("Mog",5)   --  >>> cat ^? _As @"Cat"-  --  Just ("Mog", 5)+  --  Just ("Mog",5)   --  >>> _As @"Cat" # ("Garfield", 6) :: Animal-  --  Cat ("Garfield", 6)+  --  Cat ("Garfield",6)   --  >>> duck ^? _As @Age   --  Just 2   _As :: Prism' s a
src/Data/Generics/Sum/Constructors.hs view
@@ -31,11 +31,11 @@   ) where  import Data.Generics.Internal.Families-import Data.Generics.Internal.HList import Data.Generics.Internal.Lens+import Data.Generics.Sum.Internal.Constructors  import Data.Kind    (Constraint, Type)-import GHC.Generics+import GHC.Generics (Generic (Rep)) import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))  --  $example@@ -47,7 +47,7 @@ -- --    data Animal --      = Dog Dog---      | Cat (Name, Age)+--      | Cat Name Age --      | Duck Age --      deriving (Generic, Show) --@@ -63,7 +63,7 @@ --    dog, cat, duck :: Animal -- --    dog = Dog (MkDog "Shep" 3)---    cat = Cat ("Mog", 5)+--    cat = Cat "Mog" 5 --    duck = Duck 2 --  @ @@ -104,30 +104,3 @@    ErrorUnless _ _ 'True     = ()---- |As 'AsConstructor' but over generic representations as defined by---  "GHC.Generics".-class GAsConstructor (ctor :: Symbol) (f :: Type -> Type) a | ctor f -> a where-  _GCtor :: Prism' (f x) a--instance-  ( GCollectible f as-  , ListTuple a as-  ) => GAsConstructor ctor (M1 C ('MetaCons ctor fixity fields) f) a where--  _GCtor = prism (M1 . gfromCollection . tupleToList) (Right . listToTuple @_ @as . gtoCollection . unM1)--instance GSumAsConstructor ctor l r a (HasCtorP ctor l) => GAsConstructor ctor (l :+: r) a where-  _GCtor = _GSumCtor @ctor @l @r @a @(HasCtorP ctor l)--instance GAsConstructor ctor f a => GAsConstructor ctor (M1 D meta f) a where-  _GCtor = mIso . _GCtor @ctor--class GSumAsConstructor (ctor :: Symbol) l r a (contains :: Bool) | ctor l r contains -> a where-  _GSumCtor :: Prism' ((l :+: r) x) a--instance GAsConstructor ctor l a => GSumAsConstructor ctor l r a 'True where-  _GSumCtor = left . _GCtor @ctor--instance GAsConstructor ctor r a => GSumAsConstructor ctor l r a 'False where-  _GSumCtor = right . _GCtor @ctor
+ src/Data/Generics/Sum/Internal/Constructors.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE AllowAmbiguousTypes    #-}+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE KindSignatures         #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TypeApplications       #-}+{-# LANGUAGE TypeFamilies           #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE UndecidableInstances   #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Generics.Sum.Internal.Constructors+-- Copyright   :  (C) 2017 Csongor Kiss+-- License     :  BSD3+-- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Derive constructor-name-based prisms generically.+--+-----------------------------------------------------------------------------++module Data.Generics.Sum.Internal.Constructors+  ( GAsConstructor (..)+  ) where++import Data.Generics.Internal.Families+import Data.Generics.Internal.HList+import Data.Generics.Internal.Lens++import Data.Kind    (Type)+import GHC.Generics+import GHC.TypeLits (Symbol)++-- |As 'AsConstructor' but over generic representations as defined by+--  "GHC.Generics".+class GAsConstructor (ctor :: Symbol) (f :: Type -> Type) a | ctor f -> a where+  _GCtor :: Prism' (f x) a++instance+  ( GCollectible f as+  , ListTuple a as+  ) => GAsConstructor ctor (M1 C ('MetaCons ctor fixity fields) f) a where++  _GCtor = prism (M1 . gfromCollection . tupleToList) (Right . listToTuple @_ @as . gtoCollection . unM1)++instance GSumAsConstructor ctor l r a (HasCtorP ctor l) => GAsConstructor ctor (l :+: r) a where+  _GCtor = _GSumCtor @ctor @l @r @a @(HasCtorP ctor l)++instance GAsConstructor ctor f a => GAsConstructor ctor (M1 D meta f) a where+  _GCtor = mIso . _GCtor @ctor++class GSumAsConstructor (ctor :: Symbol) l r a (contains :: Bool) | ctor l r contains -> a where+  _GSumCtor :: Prism' ((l :+: r) x) a++instance GAsConstructor ctor l a => GSumAsConstructor ctor l r a 'True where+  _GSumCtor = left . _GCtor @ctor++instance GAsConstructor ctor r a => GSumAsConstructor ctor l r a 'False where+  _GSumCtor = right . _GCtor @ctor
+ src/Data/Generics/Sum/Internal/Subtype.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE KindSignatures        #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE TypeSynonymInstances  #-}+{-# LANGUAGE UndecidableInstances  #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Generics.Sum.Internal.Subtype+-- Copyright   :  (C) 2017 Csongor Kiss+-- License     :  BSD3+-- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Structural subtype relationships between sum types.+--+-----------------------------------------------------------------------------++module Data.Generics.Sum.Internal.Subtype+  ( GAsSubtype (..)+  ) where++import Data.Generics.Internal.HList+import Data.Generics.Sum.Internal.Typed++import Data.Kind+import GHC.Generics++-- |As 'AsSubtype' but over generic representations as defined by+--  "GHC.Generics".+class GAsSubtype (subf :: Type -> Type) (supf :: Type -> Type) where+  ginjectSub  :: subf x -> supf x+  gprojectSub :: supf x -> Either (supf x) (subf x)++instance+  ( GAsSubtype l supf+  , GAsSubtype r supf+  ) => GAsSubtype (l :+: r) supf where++  ginjectSub x = case x of+    L1 l -> ginjectSub l+    R1 r -> ginjectSub r+  gprojectSub x+    = case gprojectSub x of+        Left  _ -> fmap R1 (gprojectSub x)+        Right y -> Right (L1 y)++instance+  ( GAsType supf a+  , GCollectible subf as+  , ListTuple a as+  ) => GAsSubtype (C1 meta subf) supf where++  ginjectSub+    = ginjectTyped . listToTuple . gtoCollection . unM1+  gprojectSub+    = fmap (M1 . gfromCollection . tupleToList) . gprojectTyped++instance GAsType supf a => GAsSubtype (S1 meta (Rec0 a)) supf where+  ginjectSub+    = ginjectTyped @supf . unK1 . unM1+  gprojectSub+    = fmap (M1 . K1) . gprojectTyped @supf++instance GAsSubtype subf supf => GAsSubtype (D1 meta subf) supf where+  ginjectSub+    = ginjectSub . unM1+  gprojectSub+    = fmap M1 . gprojectSub
+ src/Data/Generics/Sum/Internal/Typed.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE AllowAmbiguousTypes    #-}+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE KindSignatures         #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TypeApplications       #-}+{-# LANGUAGE TypeFamilies           #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE UndecidableInstances   #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Generics.Sum.Internal.Typed+-- Copyright   :  (C) 2017 Csongor Kiss+-- License     :  BSD3+-- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Derive constructor-field-type-based prisms generically.+--+-----------------------------------------------------------------------------++module Data.Generics.Sum.Internal.Typed+  ( GAsType (..)+  ) where++import Data.Kind+import GHC.Generics++import Data.Generics.Internal.Families+import Data.Generics.Internal.HList+import Data.Generics.Internal.Lens++-- |As 'AsType' but over generic representations as defined by "GHC.Generics".+class GAsType (f :: Type -> Type) a where+  _GTyped :: Prism' (f x) a+  _GTyped = prism ginjectTyped gprojectTyped++  ginjectTyped  :: a -> f x+  gprojectTyped :: f x -> Either (f x) a++instance+  ( GCollectible f as+  , ListTuple a as+  ) => GAsType (M1 C meta f) a where++  ginjectTyped+    = M1 . gfromCollection . tupleToList+  gprojectTyped+    = Right . listToTuple . gtoCollection . unM1++instance GSumAsType (HasPartialTypeTupleP a l) l r a => GAsType (l :+: r) a where+  ginjectTyped+    = ginjectSumTyped @(HasPartialTypeTupleP a l) @l @r @a+  gprojectTyped+    = gprojectSumTyped @(HasPartialTypeTupleP a l) @l @r @a++instance GAsType f a => GAsType (M1 D meta f) a where+  ginjectTyped+    = M1 . ginjectTyped+  gprojectTyped+    = either (Left . M1) Right . gprojectTyped . unM1++class GSumAsType (contains :: Bool) l r a where+  _GSumTyped :: Prism' ((l :+: r) x) a+  _GSumTyped = prism (ginjectSumTyped  @contains) (gprojectSumTyped @contains)++  ginjectSumTyped  :: a -> (l :+: r) x+  gprojectSumTyped :: (l :+: r) x -> Either ((l :+: r) x) a++instance GAsType l a => GSumAsType 'True l r a where+  ginjectSumTyped+    = L1 . ginjectTyped+  gprojectSumTyped x+    = case x of+        L1 l -> either (Left . L1) Right (gprojectTyped l)+        R1 _ -> Left x++instance GAsType r a => GSumAsType 'False l r a where+  ginjectSumTyped+    = R1 . ginjectTyped+  gprojectSumTyped x+    = case x of+        R1 r -> either (Left . R1) Right (gprojectTyped r)+        L1 _ -> Left x
+ src/Data/Generics/Sum/Subtype.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE TypeSynonymInstances  #-}+{-# LANGUAGE UndecidableInstances  #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Generics.Sum.Subtype+-- Copyright   :  (C) 2017 Csongor Kiss+-- License     :  BSD3+-- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Structural subtype relationships between sum types.+--+-----------------------------------------------------------------------------++module Data.Generics.Sum.Subtype+  ( -- *Prisms+    --+    --  $example+    AsSubtype (..)+  ) where++import Data.Generics.Internal.Lens+import Data.Generics.Sum.Internal.Subtype++import GHC.Generics (Generic (Rep, to, from))++--  $example+--  @+--    module Example where+--+--    import Data.Generics.Sum+--    import GHC.Generics+--+--    data Animal+--      = Dog Dog+--      | Cat Name Age+--      | Duck Age+--      deriving (Generic, Show)+--+--    data FourLeggedAnimal+--      = Dog4 Dog+--      | Cat4 Name Age+--      deriving (Generic, Show)+--+--    data Dog = MkDog+--      { name :: Name+--      , age  :: Age+--      }+--      deriving (Generic, Show)+--+--    type Name = String+--    type Age  = Int+--+--    dog, cat, duck :: Animal+--+--    dog = Dog (MkDog "Shep" 3)+--    cat = Cat "Mog" 5+--    duck = Duck 2+--+--    dog4, cat4 :: FourLeggedAnimal+--+--    dog4 = Dog4 (MkDog "Snowy" 4)+--    cat4 = Cat4 "Garfield" 6+--  @++-- |Structural subtyping between sums. A sum 'Sub' is a subtype of another sum+--  'Sup' if a value of 'Sub' can be given (modulo naming of constructors)+--  whenever a value of 'Sup' is expected. In the running example for instance,+--  'FourLeggedAnimal` is a subtype of 'Animal' since a value of the former can+--  be given as a value of the latter (renaming 'Dog4' to 'Dog' and 'Cat4' to+--  'Cat').+class AsSubtype sub sup where+  -- |A prism that captures structural subtyping. Allows a substructure to be+  --  injected (upcast) into a superstructure or a superstructure to be downcast+  --  into a substructure (which may fail).+  --+  --  >>> _Sub # dog4 :: Animal+  --  Dog (MkDog {name = "Snowy", age = 4})+  --  >>> cat ^? _Sub :: Maybe FourLeggedAnimal+  --  Just (Cat4 "Mog" 5)+  --  >>> duck ^? _Sub :: Maybe FourLeggedAnimal+  --  Nothing+  _Sub :: Prism' sup sub+  _Sub = prism injectSub projectSub++  -- |Injects a subtype into a supertype (upcast).+  injectSub  :: sub -> sup++  -- |Projects a subtype from a supertype (downcast).+  projectSub :: sup -> Either sup sub++  {-# MINIMAL injectSub, projectSub #-}++instance+  ( Generic sub+  , Generic sup+  , GAsSubtype (Rep sub) (Rep sup)+  ) => AsSubtype sub sup where++  injectSub  = to . ginjectSub . from+  projectSub = either (Left . to) (Right . to) . gprojectSub . from
src/Data/Generics/Sum/Typed.hs view
@@ -2,17 +2,13 @@ {-# LANGUAGE DataKinds              #-} {-# LANGUAGE FlexibleContexts       #-} {-# LANGUAGE FlexibleInstances      #-}-{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE KindSignatures         #-} {-# LANGUAGE MultiParamTypeClasses  #-} {-# LANGUAGE ScopedTypeVariables    #-}-{-# LANGUAGE TypeApplications       #-} {-# LANGUAGE TypeFamilies           #-} {-# LANGUAGE TypeOperators          #-} {-# LANGUAGE UndecidableInstances   #-} -{-# LANGUAGE DeriveGeneric   #-}- ----------------------------------------------------------------------------- -- | -- Module      :  Data.Generics.Sum.Typed@@ -31,17 +27,14 @@     --     --  $example     AsType (..)--    -- *Internals-  , GAsType (..)   ) where  import Data.Kind import GHC.Generics import GHC.TypeLits (TypeError, ErrorMessage (..))+import Data.Generics.Sum.Internal.Typed  import Data.Generics.Internal.Families-import Data.Generics.Internal.HList import Data.Generics.Internal.Lens  --  $example@@ -69,7 +62,7 @@ --    dog, cat, duck :: Animal -- --    dog = Dog (MkDog "Shep" 3)---    cat = Cat ("Mog", 5)+--    cat = Cat "Mog" 5 --    duck = Duck 2 --  @ @@ -80,8 +73,10 @@   --   --  >>> dog ^? _Typed @Dog   --  Just (MkDog {name = "Shep", age = 3})-  --  >>> dog ^? _Typed @Cat+  --  >>> dog ^? _Typed @Age   --  Nothing+  --  >>> cat ^? _Typed @(Name, Age)+  --  Just ("Mog",5)   --  >>> duck ^? _Typed @Age   --  Just 2   _Typed :: Prism' s a@@ -114,56 +109,3 @@    ErrorUnlessOne _ _ 'One     = ()---- |As 'AsType' but over generic representations as defined by "GHC.Generics".-class GAsType (f :: Type -> Type) a where-  _GTyped :: Prism' (f x) a-  _GTyped = prism ginjectTyped gprojectTyped--  ginjectTyped  :: a -> f x-  gprojectTyped :: f x -> Either (f x) a--instance-  ( GCollectible f as-  , ListTuple a as-  ) => GAsType (M1 C meta f) a where--  ginjectTyped-    = M1 . gfromCollection . tupleToList-  gprojectTyped-    = Right . listToTuple @_ @as . gtoCollection . unM1--instance GSumAsType (HasPartialTypeTupleP a l) l r a => GAsType (l :+: r) a where-  ginjectTyped-    = ginjectSumTyped @(HasPartialTypeTupleP a l) @l @r @a-  gprojectTyped-    = gprojectSumTyped @(HasPartialTypeTupleP a l) @l @r @a--instance GAsType f a => GAsType (M1 D meta f) a where-  ginjectTyped-    = M1 . ginjectTyped-  gprojectTyped-    = either (Left . M1) Right . gprojectTyped . unM1--class GSumAsType (contains :: Bool) l r a where-  _GSumTyped :: Prism' ((l :+: r) x) a-  _GSumTyped = prism (ginjectSumTyped  @contains) (gprojectSumTyped @contains)--  ginjectSumTyped  :: a -> (l :+: r) x-  gprojectSumTyped :: (l :+: r) x -> Either ((l :+: r) x) a--instance GAsType l a => GSumAsType 'True l r a where-  ginjectSumTyped-    = L1 . ginjectTyped-  gprojectSumTyped-    = \x -> case x of-        L1 l -> either (Left . L1) Right (gprojectTyped l)-        R1 _ -> Left x--instance GAsType r a => GSumAsType 'False l r a where-  ginjectSumTyped-    = R1 . ginjectTyped-  gprojectSumTyped-    = \x -> case x of-        R1 r -> either (Left . R1) Right (gprojectTyped r)-        L1 _ -> Left x