b4f07fe · generic-lens

git.iko.soy/generic-lens

Type-changing constructor prism

commitb4f07fea81a2c14a37fdcf03c26480530fb18649 authorCsongor Kiss <kiss.csongor.kiss@gmail.com> dateFri 1 Dec 2017, 20:53 (9 years ago) parent4e50855

4 files changed+42−27

compare with master

unifiedsplit

src/Data/Generics/Internal/Lens.hs+14−10 src/Data/Generics/Sum/Any.hs+1−1 src/Data/Generics/Sum/Constructors.hs+13−5 src/Data/Generics/Sum/Internal/Constructors.hs+14−11

src/Data/Generics/Internal/Lens.hs+14−10

@@ -1,3 +1,4 @@

1+{-# LANGUAGE LambdaCase #-}

12{-# LANGUAGE GADTs #-}

23{-# LANGUAGE Rank2Types #-}

34{-# LANGUAGE TypeOperators #-}

@@ -32,8 +33,11 @@ type Lens s t a b

3233 = forall f. Functor f => (a -> f b) -> s -> f t

3334

3435-- | Type alias for prism

36+type Prism s t a b

37+ = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t)

38+

3539type Prism' s a

36− = forall p f. (Choice p, Applicative f) => p a (f a) -> p s (f s)

40+ = Prism s s a a

3741

3842type Iso' s a

3943 = forall p f. (Profunctor p, Functor f) => p a (f a) -> p s (f s)

@@ -74,21 +78,21 @@ second :: Lens ((a :*: b) x) ((a :*: b') x) (b x) (b' x)

7478second f (a :*: b)

7579 = fmap (a :*:) (f b)

7680

77−left :: Prism' ((a :+: b) x) (a x)

78−left = prism L1 $ \x -> case x of

79− L1 a -> Right a

80− R1 _ -> Left x

81+left :: Prism ((a :+: c) x) ((b :+: c) x) (a x) (b x)

82+left = prism L1 $ gsum Right (Left . R1)

83+

84+right :: Prism ((a :+: b) x) ((a :+: c) x) (b x) (c x)

85+right = prism R1 $ gsum (Left . L1) Right

8186

82−right :: Prism' ((a :+: b) x) (b x)

83−right = prism R1 $ \x -> case x of

84− L1 _ -> Left x

85− R1 a -> Right a

87+gsum :: (a x -> c) -> (b x -> c) -> ((a :+: b) x) -> c

88+gsum f _ (L1 x) = f x

89+gsum _ g (R1 y) = g y

8690

8791combine :: Lens' (s x) a -> Lens' (t x) a -> Lens' ((s :+: t) x) a

8892combine sa _ f (L1 s) = fmap (\a -> L1 (set sa a s)) (f (s ^. sa))

8993combine _ ta f (R1 t) = fmap (\a -> R1 (set ta a t)) (f (t ^. ta))

9094

91−prism :: (a -> s) -> (s -> Either s a) -> Prism' s a

95+prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b

9296prism bt seta = dimap seta (either pure (fmap bt)) . right'

9397

9498-- | A type and its generic representation are isomorphic

src/Data/Generics/Sum/Any.hs+1−1

@@ -80,7 +80,7 @@ class AsAny (sel :: k) a s | s sel k -> a where

8080 -- Just 2

8181 _As :: Prism' s a

8282

83−instance AsConstructor ctor a s => AsAny ctor a s where

83+instance AsConstructor ctor s s a a => AsAny ctor a s where

8484 _As = _Ctor @ctor

8585

8686instance AsType a s => AsAny a a s where

src/Data/Generics/Sum/Constructors.hs+13−5

@@ -38,6 +38,7 @@ import Data.Generics.Sum.Internal.Constructors

3838import Data.Kind (Constraint, Type)

3939import GHC.Generics (Generic (Rep))

4040import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))

41+import Data.Type.Bool (If)

4142

4243-- $setup

4344-- >>> :set -XTypeApplications

@@ -66,7 +67,7 @@ import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))

6667-- :}

6768

6869-- |Sums that have a constructor with a given name.

69−class AsConstructor (ctor :: Symbol) a s | s ctor -> a where

70+class AsConstructor (ctor :: Symbol) s t a b | s ctor -> a where

7071 -- |A prism that projects a named constructor from a sum. Compatible with the

7172 -- lens package's 'Control.Lens.Prism' type.

7273 --

@@ -81,18 +82,25 @@ class AsConstructor (ctor :: Symbol) a s | s ctor -> a where

8182 --

8283 -- >>> _Ctor @"Cat" # ("Garfield", 6) :: Animal

8384 -- Cat "Garfield" 6

84− _Ctor :: Prism' s a

85+ _Ctor :: Prism s t a b

8586

8687instance

8788 ( Generic s

8889 , ErrorUnless ctor s (HasCtorP ctor (Rep s))

89− , GAsConstructor ctor (Rep s) a

90− ) => AsConstructor ctor a s where

90+ , Generic t

91+ , s' ~ Proxied s

92+ , Generic s'

93+ , GAsConstructor' ctor (Rep s) a

94+ , GAsConstructor' ctor (Rep s') a'

95+ , GAsConstructor ctor (Rep s) (Rep t) a b

96+ , '(t', b') ~ If (IsParam a') '(Change s' (IndexOf a') b, P (IndexOf a') b) '(s', b)

97+ , t ~ UnProxied t'

98+ ) => AsConstructor ctor s t a b where

9199

92100 _Ctor = repIso . _GCtor @ctor

93101

94102-- See Note [Uncluttering type signatures]

95−instance {-# OVERLAPPING #-} AsConstructor ctor Void Void where

103+instance {-# OVERLAPPING #-} AsConstructor ctor Void Void Void Void where

96104 _Ctor = undefined

97105

98106type family ErrorUnless (ctor :: Symbol) (s :: Type) (contains :: Bool) :: Constraint where

src/Data/Generics/Sum/Internal/Constructors.hs+14−11

@@ -1,4 +1,5 @@

11{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE ConstraintKinds #-}

23{-# LANGUAGE DataKinds #-}

34{-# LANGUAGE FlexibleInstances #-}

45{-# LANGUAGE FunctionalDependencies #-}

@@ -25,39 +26,41 @@

2526

2627module Data.Generics.Sum.Internal.Constructors

2728 ( GAsConstructor (..)

29+ , GAsConstructor'

2830 ) where

2931

3032import Data.Generics.Internal.Families

3133import Data.Generics.Internal.HList

3234import Data.Generics.Internal.Lens

3335

34−import Data.Kind (Type)

3536import GHC.Generics

3637import GHC.TypeLits (Symbol)

3738

3839-- |As 'AsConstructor' but over generic representations as defined by

3940-- "GHC.Generics".

40−class GAsConstructor (ctor :: Symbol) (f :: Type -> Type) a | ctor f -> a where

41− _GCtor :: Prism' (f x) a

41+class GAsConstructor (ctor :: Symbol) s t a b | ctor s -> a, ctor t -> b where

42+ _GCtor :: Prism (s x) (t x) a b

43+

44+type GAsConstructor' ctor s a = GAsConstructor ctor s s a a

4245

4346instance

4447 ( GCollectible f as

4548 , ListTuple a as

46− ) => GAsConstructor ctor (M1 C ('MetaCons ctor fixity fields) f) a where

49+ ) => GAsConstructor ctor (M1 C ('MetaCons ctor fixity fields) f) (M1 C ('MetaCons ctor fixity fields) f) a a where

4750

4851 _GCtor = prism (M1 . gfromCollection . tupleToList) (Right . listToTuple @_ @as . gtoCollection . unM1)

4952

50−instance GSumAsConstructor ctor l r a (HasCtorP ctor l) => GAsConstructor ctor (l :+: r) a where

51− _GCtor = _GSumCtor @ctor @l @r @a @(HasCtorP ctor l)

53+instance GSumAsConstructor ctor (HasCtorP ctor l) l r l' r' a b => GAsConstructor ctor (l :+: r) (l' :+: r') a b where

54+ _GCtor = _GSumCtor @ctor @(HasCtorP ctor l)

5255

53−instance GAsConstructor ctor f a => GAsConstructor ctor (M1 D meta f) a where

56+instance GAsConstructor ctor f f' a b => GAsConstructor ctor (M1 D meta f) (M1 D meta f') a b where

5457 _GCtor = mIso . _GCtor @ctor

5558

56−class GSumAsConstructor (ctor :: Symbol) l r a (contains :: Bool) | ctor l r contains -> a where

57− _GSumCtor :: Prism' ((l :+: r) x) a

59+class GSumAsConstructor (ctor :: Symbol) (contains :: Bool) l r l' r' a b | ctor l r -> a, ctor l' r' -> b where

60+ _GSumCtor :: Prism ((l :+: r) x) ((l' :+: r') x) a b

5861

59−instance GAsConstructor ctor l a => GSumAsConstructor ctor l r a 'True where

62+instance GAsConstructor ctor l l' a b => GSumAsConstructor ctor 'True l r l' r a b where

6063 _GSumCtor = left . _GCtor @ctor

6164

62−instance GAsConstructor ctor r a => GSumAsConstructor ctor l r a 'False where

65+instance GAsConstructor ctor r r' a b => GSumAsConstructor ctor 'False l r l r' a b where

6366 _GSumCtor = right . _GCtor @ctor