72c8592 · generic-lens

src/Data/Generics/Internal/Families/Count.hs+42−16

compare with master

unifiedsplit

@@ -5,33 +5,59 @@

5{-# LANGUAGE UndecidableInstances #-}

6

7module Data.Generics.Internal.Families.Count

8− ( CountType

8+ ( CountTotalType

9+ , CountPartialType

9 , Count (..)

10 , Count (..)

10 ) where

11 ) where

11

12

12import GHC.Generics

13import GHC.Generics

13import GHC.TypeLits

14import GHC.TypeLits

14

15

15−type family CountType t f :: Count where

16+type family CountTotalType t f :: Count where

16− CountType t (S1 _ (Rec0 t))

17+ CountTotalType t (S1 _ (Rec0 t))

17 = 'One

18 = 'One

18− CountType t (l :*: r)

19+ CountTotalType t (l :*: r)

19− = CountType t l <|> CountType t r

20+ = CountTotalType t l <|> CountTotalType t r

20− CountType t (l :+: r)

21+ CountTotalType t (l :+: r)

21− = CountType t l <&> CountType t r

22+ = CountTotalType t l <&> CountTotalType t r

22− CountType t (S1 _ _)

23+ CountTotalType t (S1 _ _)

23 = 'None

24 = 'None

24− CountType t (C1 _ f)

25+ CountTotalType t (C1 _ f)

25− = CountType t f

26+ = CountTotalType t f

26− CountType t (D1 _ f)

27+ CountTotalType t (D1 _ f)

27− = CountType t f

28+ = CountTotalType t f

28− CountType t (Rec0 _)

29+ CountTotalType t (Rec0 _)

29 = 'None

30 = 'None

30− CountType t U1

31+ CountTotalType t U1

31 = 'None

32 = 'None

32− CountType t V1

33+ CountTotalType t V1

33 = 'None

34 = 'None

34− CountType t f

35+ CountTotalType t f

36+ = TypeError

37+ ( 'ShowType f

38+ ':<>: 'Text " is not a valid GHC.Generics representation type"

39+ )

40+

41+type family CountPartialType t f :: Count where

42+ CountPartialType t (S1 _ (Rec0 t))

43+ = 'One

44+ CountPartialType t (l :*: r)

45+ = CountPartialType t l <|> CountPartialType t r

46+ CountPartialType t (l :+: r)

47+ = CountPartialType t l <|> CountPartialType t r

48+ CountPartialType t (S1 _ _)

49+ = 'None

50+ CountPartialType t (C1 _ f)

51+ = CountPartialType t f

52+ CountPartialType t (D1 _ f)

53+ = CountPartialType t f

54+ CountPartialType t (Rec0 _)

55+ = 'None

56+ CountPartialType t U1

57+ = 'None

58+ CountPartialType t V1

59+ = 'None

60+ CountPartialType t f

35 = TypeError

61 = TypeError

36 ( 'ShowType f

62 ( 'ShowType f

37 ':<>: 'Text " is not a valid GHC.Generics representation type"

63 ':<>: 'Text " is not a valid GHC.Generics representation type"

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

@@ -58,7 +58,7 @@ import GHC.TypeLits

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

59-- @

60

61−-- | Records that have a field with a given name.

61+-- |Records that have a field with a given name.

62class HasField (field :: Symbol) a s | s field -> a where

63 -- |A lens that focuses on a field with a given name. Compatible with the

64 -- lens package's 'Control.Lens.Lens' type.

@@ -71,14 +71,14 @@ class HasField (field :: Symbol) a s | s field -> a where

71 field f s

72 = fmap (flip (setField @field) s) (f (getField @field s))

73

74− -- | Get 'field'

74+ -- |Get 'field'

75 --

76 -- >>> getField @"name" human

77 -- "Tunyasz"

78 getField :: s -> a

79 getField s = s ^. field @field

80

81− -- | Set 'field'

81+ -- |Set 'field'

82 --

83 -- >>> setField @"age" (setField @"name" "Tamas" human) 30

84 -- Human {name = "Tamas", age = 30, address = "London"}

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

@@ -81,7 +81,7 @@ class HasType a s where

81

82instance

83 ( Generic s

84− , ErrorUnlessOne a s (CountType a (Rep s))

84+ , ErrorUnlessOne a s (CountTotalType a (Rep s))

85 , GHasType (Rep s) a

86 ) => HasType a s where

87

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

@@ -7,15 +7,77 @@

7{-# LANGUAGE TypeApplications #-}

8{-# LANGUAGE UndecidableInstances #-}

9

10+-----------------------------------------------------------------------------

11+-- |

12+-- Module : Data.Generics.Product.Any

14+-- License : BSD3

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

16+-- Stability : experimental

17+-- Portability : non-portable

18+--

19+-- Derive a variety of prisms generically.

20+--

21+-----------------------------------------------------------------------------

22+

10module Data.Generics.Sum.Any

23module Data.Generics.Sum.Any

24+ ( -- *Prisms

25+ --

26+ -- $example

11− ( AsAny (..)

27+ AsAny (..)

12 ) where

28 ) where

13

29

14import Data.Generics.Internal.Lens

30import Data.Generics.Internal.Lens

15import Data.Generics.Sum.Constructors

31import Data.Generics.Sum.Constructors

16import Data.Generics.Sum.Typed

32import Data.Generics.Sum.Typed

17

33

34+-- $example

35+-- @

36+-- module Example where

37+--

38+-- import Data.Generics.Sum

39+-- import GHC.Generics

40+--

41+-- data Animal

42+-- = Dog Dog

43+-- | Cat (Name, Age)

44+-- | Duck Age

45+-- deriving (Generic, Show)

46+--

47+-- data Dog = MkDog

48+-- { name :: Name

49+-- , age :: Age

50+-- }

51+-- deriving (Generic, Show)

52+--

53+-- type Name = String

54+-- type Age = Int

55+--

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

57+--

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

59+-- cat = Cat ("Mog", 5)

60+-- duck = Duck 2

61+-- @

62+

63+-- |Sums that have generic prisms.

18class AsAny (sel :: k) a s | s sel k -> a where

64class AsAny (sel :: k) a s | s sel k -> a where

65+ -- |A prism that projects a sum as identified by some selector. Currently

66+ -- supported selectors are constructor names and unique types. Compatible

67+ -- with the lens package's 'Control.Lens.Prism' type.

68+ --

69+ -- >>> dog ^? _As @"Dog"

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

71+ -- >>> dog ^? _As @Dog

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

73+ -- >>> dog ^? _As @"Cat"

74+ -- Nothing

75+ -- >>> cat ^? _As @"Cat"

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

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

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

79+ -- >>> duck ^? _As @Age

80+ -- Just 2

19 _As :: Prism' s a

81 _As :: Prism' s a

20

82

21instance AsConstructor ctor a s => AsAny ctor a s where

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

src/Data/Generics/Sum/Constructors.hs+61−1

@@ -10,9 +10,26 @@

10{-# LANGUAGE TypeOperators #-}

11{-# LANGUAGE UndecidableInstances #-}

12

13+-----------------------------------------------------------------------------

14+-- |

15+-- Module : Data.Generics.Product.Any

17+-- License : BSD3

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

19+-- Stability : experimental

20+-- Portability : non-portable

21+--

22+-- Derive constructor-name-based prisms generically.

23+--

24+-----------------------------------------------------------------------------

25+

13module Data.Generics.Sum.Constructors

26module Data.Generics.Sum.Constructors

27+ ( -- *Prisms

28+

29+ -- $example

14− ( AsConstructor (..)

30+ AsConstructor (..)

15

31

32+ -- *Internals

16 , GAsConstructor (..)

33 , GAsConstructor (..)

17 ) where

34 ) where

18

35

@@ -24,7 +41,48 @@ import Data.Kind

24import GHC.Generics

41import GHC.Generics

25import GHC.TypeLits

42import GHC.TypeLits

26

43

44+-- $example

45+-- @

46+-- module Example where

47+--

48+-- import Data.Generics.Sum

49+-- import GHC.Generics

50+--

51+-- data Animal

52+-- = Dog Dog

53+-- | Cat (Name, Age)

54+-- | Duck Age

55+-- deriving (Generic, Show)

56+--

57+-- data Dog = MkDog

58+-- { name :: Name

59+-- , age :: Age

60+-- }

61+-- deriving (Generic, Show)

62+--

63+-- type Name = String

64+-- type Age = Int

65+--

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

67+--

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

69+-- cat = Cat ("Mog", 5)

70+-- duck = Duck 2

71+-- @

72+

73+-- |Sums that have a constructor with a given name.

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

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

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

76+ -- lens package's 'Control.Lens.Prism' type.

77+ --

78+ -- >>> dog ^? _Ctor @"Dog"

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

80+ -- >>> dog ^? _Ctor @"Cat"

81+ -- Nothing

82+ -- >>> cat ^? _Ctor @"Cat"

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

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

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

28 _Ctor :: Prism' s a

86 _Ctor :: Prism' s a

29

87

30instance

88instance

@@ -47,6 +105,8 @@ type family ErrorUnless (ctor :: Symbol) (s :: Type) (contains :: Bool) :: Const

47 ErrorUnless _ _ 'True

105 ErrorUnless _ _ 'True

48 = ()

106 = ()

49

107

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

109+-- "GHC.Generics".

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

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

51 _GCtor :: Prism' (f x) a

111 _GCtor :: Prism' (f x) a

52

112

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

@@ -11,9 +11,26 @@

11{-# LANGUAGE TypeOperators #-}

12{-# LANGUAGE UndecidableInstances #-}

13

14+-----------------------------------------------------------------------------

15+-- |

16+-- Module : Data.Generics.Product.Any

18+-- License : BSD3

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

20+-- Stability : experimental

21+-- Portability : non-portable

22+--

23+-- Derive constructor-field-type-based prisms generically.

24+--

25+-----------------------------------------------------------------------------

26+

14module Data.Generics.Sum.Typed

27module Data.Generics.Sum.Typed

28+ ( -- *Prisms

29+ --

30+ -- $example

15− ( AsType (..)

31+ AsType (..)

16

32

33+ -- *Internals

17 , GAsType (..)

34 , GAsType (..)

18 ) where

35 ) where

19

36

@@ -25,19 +42,58 @@ import Data.Kind

25import GHC.Generics

42import GHC.Generics

26import GHC.TypeLits

43import GHC.TypeLits

27

44

45+-- $example

46+-- @

47+-- module Example where

48+--

49+-- import Data.Generics.Sum

50+-- import GHC.Generics

51+--

52+-- data Animal

53+-- = Dog Dog

54+-- | Cat (Name, Age)

55+-- | Duck Age

56+-- deriving (Generic, Show)

57+--

58+-- data Dog = MkDog

59+-- { name :: Name

60+-- , age :: Age

61+-- }

62+-- deriving (Generic, Show)

63+--

64+-- type Name = String

65+-- type Age = Int

66+--

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

68+--

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

70+-- cat = Cat ("Mog", 5)

71+-- duck = Duck 2

72+-- @

73+

74+-- |Sums that have a constructor with a field of the given type.

28class AsType a s where

75class AsType a s where

76+ -- |A prism that projects a constructor uniquely identifiable by the type of

77+ -- its field. Compatible with the lens package's 'Control.Lens.Prism' type.

78+ --

79+ -- >>> dog ^? _Typed @Dog

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

81+ -- >>> dog ^? _Typed @Cat

82+ -- Nothing

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

84+ -- Just 2

29 _Typed :: Prism' s a

85 _Typed :: Prism' s a

30

86

31instance

87instance

32 ( Generic s

88 ( Generic s

33− , ErrorUnless a s (HasPartialTypeP a (Rep s))

89+ , ErrorUnlessOne a s (CountPartialType a (Rep s))

34 , GAsType (Rep s) a

90 , GAsType (Rep s) a

35 ) => AsType a s where

91 ) => AsType a s where

36

92

37 _Typed = repIso . _GTyped

93 _Typed = repIso . _GTyped

38

94

39−type family ErrorUnless (a :: Type) (s :: Type) (contains :: Bool) :: Constraint where

95+type family ErrorUnlessOne (a :: Type) (s :: Type) (count :: Count) :: Constraint where

40− ErrorUnless a s 'False

96+ ErrorUnlessOne a s 'None

41 = TypeError

97 = TypeError

42 ( 'Text "The type "

98 ( 'Text "The type "

43 ':<>: 'ShowType s

99 ':<>: 'ShowType s

@@ -45,9 +101,19 @@ type family ErrorUnless (a :: Type) (s :: Type) (contains :: Bool) :: Constraint

45 ':<>: 'ShowType a

101 ':<>: 'ShowType a

46 )

102 )

47

103

48− ErrorUnless _ _ 'True

104+ ErrorUnlessOne a s 'Multiple

105+ = TypeError

106+ ( 'Text "The type "

107+ ':<>: 'ShowType s

108+ ':<>: 'Text " contains multiple constructors whose fields are of type "

109+ ':<>: 'ShowType a

110+ ':<>: 'Text "; the choice of constructor is thus ambiguous"

111+ )

112+

113+ ErrorUnlessOne _ _ 'One

49 = ()

114 = ()

50

115

116+-- |As 'AsType' but over generic representations as defined by "GHC.Generics".

51class GAsType (f :: Type -> Type) a where

117class GAsType (f :: Type -> Type) a where

52 _GTyped :: Prism' (f x) a

118 _GTyped :: Prism' (f x) a

53

119