7665edc · generic-lens

src/Data/Generics/Internal/Families/Count.hs+1−2

compare with master

unifiedsplit

@@ -20,10 +20,9 @@ module Data.Generics.Internal.Families.Count

20 , Count (..)

21 ) where

22

23−import GHC.Generics

24−

25import Data.Type.Bool (If)

23import Data.Type.Bool (If)

26import Data.Type.Equality (type (==))

24import Data.Type.Equality (type (==))

25+import GHC.Generics

27import GHC.TypeLits (TypeError, ErrorMessage (..))

26import GHC.TypeLits (TypeError, ErrorMessage (..))

28

27

29import Data.Generics.Internal.HList

28import Data.Generics.Internal.HList

src/Data/Generics/Internal/Families/Has.hs+1−2

@@ -21,10 +21,9 @@ module Data.Generics.Internal.Families.Has

21 , HasCtorP

22 ) where

23

24−import GHC.Generics

25−

26import Data.Type.Bool (type (||), type (&&))

24import Data.Type.Bool (type (||), type (&&))

27import Data.Type.Equality (type (==))

25import Data.Type.Equality (type (==))

26+import GHC.Generics

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

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

29

28

30import Data.Generics.Internal.HList

29import Data.Generics.Internal.HList

src/Data/Generics/Product/Subtype.hs+32−33

@@ -21,36 +21,15 @@

21-- Stability : experimental

22-- Portability : non-portable

23--

24−-- Structural subtype relationship between record types.

24+-- Structural subtype relationships between product types.

25−--

26−-- The running example in this module is the following two types:

27−--

28−-- @

29−--

30−-- module Test where

31−--

32−-- import GHC.Generics

33−-- import Data.Generics.Record

34−--

35−-- data Human = Human

36−-- { name :: String

37−-- , age :: Int

38−-- , address :: String

39−-- } deriving (Generic, Show)

40−--

41−-- data Animal = Animal

42−-- { name :: String

43−-- , age :: Int

44−-- } deriving (Generic, Show)

45−--

46−-- human :: Human

47−-- human = Human \"Tunyasz\" 50 \"London\"

48−--

49−-- @

50--

25--

51-----------------------------------------------------------------------------

26-----------------------------------------------------------------------------

27+

52module Data.Generics.Product.Subtype

28module Data.Generics.Product.Subtype

29+ ( -- *Lenses

30+ --

31+ -- $example

53− ( Subtype (..)

32+ Subtype (..)

54 ) where

33 ) where

55

34

56import Data.Generics.Internal.Families

35import Data.Generics.Internal.Families

@@ -60,14 +39,36 @@ import Data.Generics.Product.Fields

60import Data.Kind (Type)

39import Data.Kind (Type)

61import GHC.Generics

40import GHC.Generics

62

41

42+-- $example

43+-- @

44+-- module Example where

45+--

46+-- import Data.Generics.Product

47+-- import GHC.Generics

48+--

49+-- data Human = Human

50+-- { name :: String

51+-- , age :: Int

52+-- , address :: String

53+-- } deriving (Generic, Show)

54+--

55+-- data Animal = Animal

56+-- { name :: String

57+-- , age :: Int

58+-- } deriving (Generic, Show)

59+--

60+-- human :: Human

61+-- human = Human \"Tunyasz\" 50 \"London\"

62+-- @

63+

63-- |Structural subtype relationship

64-- |Structural subtype relationship

64--

65--

65-- @sub@ is a (structural) `subtype' of @sup@, if its fields are a subset of

66-- @sub@ is a (structural) `subtype' of @sup@, if its fields are a subset of

66-- those of @sup@.

67-- those of @sup@.

67--

68--

68class Subtype sup sub where

69class Subtype sup sub where

69− -- | Structural subtype lens. Given a subtype relationship @sub :< sup@,

70+ -- |Structural subtype lens. Given a subtype relationship @sub :< sup@,

70− -- we can focus on the @sub@ structure of @sup@.

71+ -- we can focus on the @sub@ structure of @sup@.

71 --

72 --

72 -- >>> human ^. super @Animal

73 -- >>> human ^. super @Animal

73 -- Animal {name = "Tunyasz", age = 50}

74 -- Animal {name = "Tunyasz", age = 50}

@@ -78,7 +79,7 @@ class Subtype sup sub where

78 super f sub

79 super f sub

79 = fmap (`smash` sub) (f (upcast sub))

80 = fmap (`smash` sub) (f (upcast sub))

80

81

81− -- | Cast the more specific subtype to the more general supertype

82+ -- |Cast the more specific subtype to the more general supertype

82 --

83 --

83 -- >>> upcast human :: Animal

84 -- >>> upcast human :: Animal

84 -- Animal {name = "Tunyasz", age = 50}

85 -- Animal {name = "Tunyasz", age = 50}

@@ -86,7 +87,7 @@ class Subtype sup sub where

86 upcast :: sub -> sup

87 upcast :: sub -> sup

87 upcast s = s ^. super @sup

88 upcast s = s ^. super @sup

88

89

89− -- | Plug a smaller structure into a larger one

90+ -- |Plug a smaller structure into a larger one

90 --

91 --

91 -- >>> smash (Animal "dog" 10) human

92 -- >>> smash (Animal "dog" 10) human

92 -- Human {name = "dog", age = 10, address = "London"}

93 -- Human {name = "dog", age = 10, address = "London"}

@@ -95,7 +96,6 @@ class Subtype sup sub where

95

96

96 {-# MINIMAL super | smash, upcast #-}

97 {-# MINIMAL super | smash, upcast #-}

97

98

98−-- | Instances are created by the compiler

99instance

100 ( GSmash (Rep a) (Rep b)

101 , GUpcast (Rep a) (Rep b)

@@ -108,7 +108,6 @@ instance

108--------------------------------------------------------------------------------

109-- * Generic upcasting

110

111−-- | Upcast 'sub to 'sup' (generic rep)

112class GUpcast (sub :: Type -> Type) (sup :: Type -> Type) where

111class GUpcast (sub :: Type -> Type) (sup :: Type -> Type) where

113 gupcast :: sub p -> sup p

112 gupcast :: sub p -> sup p

114

113

src/Data/Generics/Product/Typed.hs+3−3

@@ -58,7 +58,7 @@ import GHC.TypeLits (TypeError, ErrorMessage (..))

58-- human = Human \"Tunyasz\" 50 \"London\"

59-- @

60

61−-- | Records that have a field with a unique type.

61+-- |Records that have a field with a unique type.

62class HasType a s where

63 -- |A lens that focuses on a field with a unique type in its parent type.

64 -- Compatible with the lens package's 'Control.Lens.Lens' type.

@@ -69,11 +69,11 @@ class HasType a s where

69 typed f t

70 = fmap (flip (setTyped @a) t) (f (getTyped @a t))

71

72− -- |Get field at type

72+ -- |Get field at type.

73 getTyped :: s -> a

74 getTyped s = s ^. typed @a

75

76− -- |Set field at type

76+ -- |Set field at type.

77 setTyped :: a -> s -> s

78 setTyped = set (typed @a)

79

src/Data/Generics/Sum/Any.hs+6−4

@@ -41,7 +41,7 @@ import Data.Generics.Sum.Typed

41--

42-- data Animal

43-- = Dog Dog

44−-- | Cat (Name, Age)

44+-- | Cat Name Age

45-- | Duck Age

46-- deriving (Generic, Show)

47--

@@ -57,7 +57,7 @@ import Data.Generics.Sum.Typed

57-- dog, cat, duck :: Animal

58--

59-- dog = Dog (MkDog "Shep" 3)

60−-- cat = Cat ("Mog", 5)

60+-- cat = Cat "Mog" 5

61-- duck = Duck 2

62-- @

63

@@ -73,10 +73,12 @@ class AsAny (sel :: k) a s | s sel k -> a where

73 -- Just (MkDog {name = "Shep", age = 3})

74 -- >>> dog ^? _As @"Cat"

75 -- Nothing

76+ -- >>> cat ^? _As @(Name, Age)

77+ -- Just ("Mog",5)

76 -- >>> cat ^? _As @"Cat"

78 -- >>> cat ^? _As @"Cat"

77− -- Just ("Mog", 5)

79+ -- Just ("Mog",5)

78 -- >>> _As @"Cat" # ("Garfield", 6) :: Animal

80 -- >>> _As @"Cat" # ("Garfield", 6) :: Animal

79− -- Cat ("Garfield", 6)

81+ -- Cat ("Garfield",6)

80 -- >>> duck ^? _As @Age

82 -- >>> duck ^? _As @Age

81 -- Just 2

83 -- Just 2

82 _As :: Prism' s a

84 _As :: Prism' s a

src/Data/Generics/Sum/Constructors.hs+2−2

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

47--

48-- data Animal

49-- = Dog Dog

50−-- | Cat (Name, Age)

50+-- | Cat Name Age

51-- | Duck Age

52-- deriving (Generic, Show)

53--

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

63-- dog, cat, duck :: Animal

64--

65-- dog = Dog (MkDog "Shep" 3)

66−-- cat = Cat ("Mog", 5)

66+-- cat = Cat "Mog" 5

67-- duck = Duck 2

68-- @

69

src/Data/Generics/Sum/Subtype.hsnew file+154

@@ -0,0 +1,154 @@

1+{-# LANGUAGE FlexibleContexts #-}

2+{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE KindSignatures #-}

4+{-# LANGUAGE MultiParamTypeClasses #-}

5+{-# LANGUAGE ScopedTypeVariables #-}

6+{-# LANGUAGE TypeApplications #-}

7+{-# LANGUAGE TypeOperators #-}

8+{-# LANGUAGE TypeSynonymInstances #-}

9+{-# LANGUAGE UndecidableInstances #-}

10+

11+-----------------------------------------------------------------------------

12+-- |

13+-- Module : Data.Generics.Sum.Subtype

15+-- License : BSD3

16+-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>

17+-- Stability : experimental

18+-- Portability : non-portable

19+--

20+-- Structural subtype relationships between sum types.

21+--

22+-----------------------------------------------------------------------------

23+

24+module Data.Generics.Sum.Subtype

25+ ( -- *Prisms

26+ --

27+ -- $example

28+ AsSubtype (..)

29+ ) where

30+

31+import Data.Generics.Internal.HList

32+import Data.Generics.Internal.Lens

33+import Data.Generics.Sum.Typed

34+

35+import Data.Kind

36+import GHC.Generics

37+

38+-- $example

39+-- @

40+-- module Example where

41+--

42+-- import Data.Generics.Sum

43+-- import GHC.Generics

44+--

45+-- data Animal

46+-- = Dog Dog

47+-- | Cat Name Age

48+-- | Duck Age

49+-- deriving (Generic, Show)

50+--

51+-- data FourLeggedAnimal

52+-- = Dog4 Dog

53+-- | Cat4 Name Age

54+-- deriving (Generic, Show)

55+--

56+-- data Dog = MkDog

57+-- { name :: Name

58+-- , age :: Age

59+-- }

60+-- deriving (Generic, Show)

61+--

62+-- type Name = String

63+-- type Age = Int

64+--

65+-- dog, cat, duck :: Animal

66+--

67+-- dog = Dog (MkDog "Shep" 3)

68+-- cat = Cat "Mog" 5

69+-- duck = Duck 2

70+--

71+-- dog4, cat4 :: FourLeggedAnimal

72+--

73+-- dog4 = Dog4 (MkDog "Snowy" 4)

74+-- cat4 = Cat4 "Garfield" 6

75+-- @

76+

77+-- |Structural subtyping between sums. A sum 'Sub' is a subtype of another sum

78+-- 'Sup' if a value of 'Sub' can be given (modulo naming of constructors)

79+-- whenever a value of 'Sup' is expected. In the running example for instance,

80+-- 'FourLeggedAnimal` is a subtype of 'Animal' since a value of the former can

81+-- be given as a value of the latter (renaming 'Dog4' to 'Dog' and 'Cat4' to

82+-- 'Cat').

83+class AsSubtype sub sup where

84+ -- |A prism that captures structural subtyping. Allows a substructure to be

85+ -- injected (upcast) into a superstructure or a superstructure to be downcast

86+ -- into a substructure (which may fail).

87+ --

88+ -- >>> _Sub # dog4 :: Animal

89+ -- Dog (MkDog {name = "Snowy", age = 4})

90+ -- >>> cat ^? _Sub :: Maybe FourLeggedAnimal

91+ -- Just (Cat4 "Mog" 5)

92+ -- >>> duck ^? _Sub :: Maybe FourLeggedAnimal

93+ -- Nothing

94+ _Sub :: Prism' sup sub

95+ _Sub = prism injectSub projectSub

96+

97+ -- |Injects a subtype into a supertype (upcast).

98+ injectSub :: sub -> sup

99+

100+ -- |Projects a subtype from a supertype (downcast).

101+ projectSub :: sup -> Either sup sub

102+

103+ {-# MINIMAL injectSub, projectSub #-}

104+

105+instance

106+ ( Generic sub

107+ , Generic sup

108+ , GAsSubtype (Rep sub) (Rep sup)

109+ ) => AsSubtype sub sup where

110+

111+ injectSub = to . ginjectSub . from

112+ projectSub = either (Left . to) (Right . to) . gprojectSub . from

113+

114+-- |As 'AsSubtype' but over generic representations as defined by

115+-- "GHC.Generics".

116+class GAsSubtype (subf :: Type -> Type) (supf :: Type -> Type) where

117+ ginjectSub :: subf x -> supf x

118+ gprojectSub :: supf x -> Either (supf x) (subf x)

119+

120+instance

121+ ( GAsSubtype l supf

122+ , GAsSubtype r supf

123+ ) => GAsSubtype (l :+: r) supf where

124+

125+ ginjectSub x = case x of

126+ L1 l -> ginjectSub l

127+ R1 r -> ginjectSub r

128+ gprojectSub x

129+ = case gprojectSub x of

130+ Left _ -> fmap R1 (gprojectSub x)

131+ Right y -> Right (L1 y)

132+

133+instance

134+ ( GAsType supf a

135+ , GCollectible subf as

136+ , ListTuple a as

137+ ) => GAsSubtype (C1 meta subf) supf where

138+

139+ ginjectSub

140+ = ginjectTyped . listToTuple . gtoCollection . unM1

141+ gprojectSub

142+ = fmap (M1 . gfromCollection . tupleToList) . gprojectTyped

143+

144+instance GAsType supf a => GAsSubtype (S1 meta (Rec0 a)) supf where

145+ ginjectSub

146+ = ginjectTyped @supf . unK1 . unM1

147+ gprojectSub

148+ = fmap (M1 . K1) . gprojectTyped @supf

149+

150+instance GAsSubtype subf supf => GAsSubtype (D1 meta subf) supf where

151+ ginjectSub

152+ = ginjectSub . unM1

153+ gprojectSub

154+ = fmap M1 . gprojectSub

src/Data/Generics/Sum/Typed.hs+5−3

@@ -69,7 +69,7 @@ import Data.Generics.Internal.Lens

69-- dog, cat, duck :: Animal

70--

71-- dog = Dog (MkDog "Shep" 3)

72−-- cat = Cat ("Mog", 5)

72+-- cat = Cat "Mog" 5

73-- duck = Duck 2

74-- @

75

@@ -80,8 +80,10 @@ class AsType a s where

80 --

81 -- >>> dog ^? _Typed @Dog

82 -- Just (MkDog {name = "Shep", age = 3})

83− -- >>> dog ^? _Typed @Cat

83+ -- >>> dog ^? _Typed @Age

84 -- Nothing

85+ -- >>> cat ^? _Typed @(Name, Age)

86+ -- Just ("Mog",5)

85 -- >>> duck ^? _Typed @Age

87 -- >>> duck ^? _Typed @Age

86 -- Just 2

88 -- Just 2

87 _Typed :: Prism' s a

89 _Typed :: Prism' s a

@@ -131,7 +133,7 @@ instance

131 ginjectTyped

133 ginjectTyped

132 = M1 . gfromCollection . tupleToList

134 = M1 . gfromCollection . tupleToList

133 gprojectTyped

135 gprojectTyped

134− = Right . listToTuple @_ @as . gtoCollection . unM1

136+ = Right . listToTuple . gtoCollection . unM1

135

137

136instance GSumAsType (HasPartialTypeTupleP a l) l r a => GAsType (l :+: r) a where

138instance GSumAsType (HasPartialTypeTupleP a l) l r a => GAsType (l :+: r) a where

137 ginjectTyped

139 ginjectTyped