b4f07fe · generic-lens

git.iko.soy/generic-lens

on master help sign in

Type-changing constructor prism

b4f07feCsongor Kiss9 years ago

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

compare with master

unifiedsplit

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

1+{-# LANGUAGE LambdaCase #-}

1{-# LANGUAGE GADTs #-}

2{-# LANGUAGE GADTs #-}

2{-# LANGUAGE Rank2Types #-}

3{-# LANGUAGE Rank2Types #-}

3{-# LANGUAGE TypeOperators #-}

4{-# LANGUAGE TypeOperators #-}

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

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

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

34-- | Type alias for prism

35-- | 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+

35type Prism' s a

39type 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

38type Iso' s a

42type Iso' s a

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

43 = 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)

74second f (a :*: b)

78second f (a :*: b)

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

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

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

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

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

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

79− L1 a -> Right a

83+

80− R1 _ -> Left x

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

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

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

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

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

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

84− L1 _ -> Left x

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

85− R1 a -> Right a

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

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

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

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

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

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

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

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

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

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

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

98-- | 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

80 -- Just 2

81 _As :: Prism' s a

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

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

84 _As = _Ctor @ctor

86instance 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

38import Data.Kind (Constraint, Type)

39import GHC.Generics (Generic (Rep))

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

41+import Data.Type.Bool (If)

42-- $setup

43-- $setup

43-- >>> :set -XTypeApplications

44-- >>> :set -XTypeApplications

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

66-- :}

67-- :}

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

69-- |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

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

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

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

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

72 --

73 --

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

81 --

82 --

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

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

83 -- Cat "Garfield" 6

84 -- Cat "Garfield" 6

84− _Ctor :: Prism' s a

85+ _Ctor :: Prism s t a b

86instance

87instance

87 ( Generic s

88 ( Generic s

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

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

90+ , Generic t

91+ , s' ~ Proxied s

92+ , Generic s'

93+ , GAsConstructor' ctor (Rep s) a

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

89− , 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'

90− ) => AsConstructor ctor a s where

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

92 _Ctor = repIso . _GCtor @ctor

100 _Ctor = repIso . _GCtor @ctor

101

94-- See Note [Uncluttering type signatures]

102-- See Note [Uncluttering type signatures]

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

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

96 _Ctor = undefined

104 _Ctor = undefined

105

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

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

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

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

1{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE ConstraintKinds #-}

2{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE FunctionalDependencies #-}

5{-# LANGUAGE FunctionalDependencies #-}

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

26module Data.Generics.Sum.Internal.Constructors

27module Data.Generics.Sum.Internal.Constructors

27 ( GAsConstructor (..)

28 ( GAsConstructor (..)

29+ , GAsConstructor'

28 ) where

30 ) where

30import Data.Generics.Internal.Families

32import Data.Generics.Internal.Families

31import Data.Generics.Internal.HList

33import Data.Generics.Internal.HList

32import Data.Generics.Internal.Lens

34import Data.Generics.Internal.Lens

34−import Data.Kind (Type)

35import GHC.Generics

36import GHC.Generics

36import GHC.TypeLits (Symbol)

37import GHC.TypeLits (Symbol)

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

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

39-- "GHC.Generics".

40-- "GHC.Generics".

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

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

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

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

43+

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

43instance

46instance

44 ( GCollectible f as

47 ( GCollectible f as

45 , ListTuple a as

48 , 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

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

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

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

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

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

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

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

54 _GCtor = mIso . _GCtor @ctor

57 _GCtor = mIso . _GCtor @ctor

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

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

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

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

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

60 _GSumCtor = left . _GCtor @ctor

63 _GSumCtor = left . _GCtor @ctor

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

63 _GSumCtor = right . _GCtor @ctor

66 _GSumCtor = right . _GCtor @ctor