72c8592 · generic-lens

git.iko.soy/generic-lens

Document sums and add uniqueness checking.

commit72c859278957001432cba98ac7300f848297e7e2 authorWill Jones <will@sacharissa.co.uk> dateMon 31 Jul 2017, 17:48 (9 years ago) parentf3cc231

6 files changed+241−27

compare with master

unifiedsplit

src/Data/Generics/Internal/Families/Count.hs+42−16 src/Data/Generics/Product/Fields.hs+3−3 src/Data/Generics/Product/Typed.hs+1−1 src/Data/Generics/Sum/Any.hs+63−1 src/Data/Generics/Sum/Constructors.hs+61−1 src/Data/Generics/Sum/Typed.hs+71−5

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

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

55{-# LANGUAGE UndecidableInstances #-}

77module Data.Generics.Internal.Families.Count

8− ( CountType

8+ ( CountTotalType

9+ , CountPartialType

910 , Count (..)

1011 ) where

1112

1213import GHC.Generics

1314import GHC.TypeLits

1415

15−type family CountType t f :: Count where

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

16+type family CountTotalType t f :: Count where

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

1718 = 'One

18− CountType t (l :*: r)

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

20− CountType t (l :+: r)

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

22− CountType t (S1 _ _)

19+ CountTotalType t (l :*: r)

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

21+ CountTotalType t (l :+: r)

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

23+ CountTotalType t (S1 _ _)

2324 = 'None

24− CountType t (C1 _ f)

25− = CountType t f

26− CountType t (D1 _ f)

27− = CountType t f

28− CountType t (Rec0 _)

25+ CountTotalType t (C1 _ f)

26+ = CountTotalType t f

27+ CountTotalType t (D1 _ f)

28+ = CountTotalType t f

29+ CountTotalType t (Rec0 _)

2930 = 'None

30− CountType t U1

31+ CountTotalType t U1

3132 = 'None

32− CountType t V1

33+ CountTotalType t V1

3334 = '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

3561 = TypeError

3662 ( 'ShowType f

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

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

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

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

5959-- @

6060

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

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

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

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

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

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

7171 field f s

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

7373

74− -- | Get 'field'

74+ -- |Get 'field'

7575 --

7676 -- >>> getField @"name" human

7777 -- "Tunyasz"

7878 getField :: s -> a

7979 getField s = s ^. field @field

8080

81− -- | Set 'field'

81+ -- |Set 'field'

8282 --

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

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

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

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

8181

8282instance

8383 ( Generic s

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

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

8585 , GHasType (Rep s) a

8686 ) => HasType a s where

8787

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

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

77{-# LANGUAGE TypeApplications #-}

88{-# LANGUAGE UndecidableInstances #-}

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+

1023module Data.Generics.Sum.Any

11− ( AsAny (..)

24+ ( -- *Prisms

25+ --

26+ -- $example

27+ AsAny (..)

1228 ) where

1329

1430import Data.Generics.Internal.Lens

1531import Data.Generics.Sum.Constructors

1632import Data.Generics.Sum.Typed

1733

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.

1864class 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

1981 _As :: Prism' s a

2082

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

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

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

1010{-# LANGUAGE TypeOperators #-}

1111{-# LANGUAGE UndecidableInstances #-}

1212

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+

1326module Data.Generics.Sum.Constructors

14− ( AsConstructor (..)

27+ ( -- *Prisms

28+

29+ -- $example

30+ AsConstructor (..)

1531

32+ -- *Internals

1633 , GAsConstructor (..)

1734 ) where

1835

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

2441import GHC.Generics

2542import GHC.TypeLits

2643

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.

2774class 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)

2886 _Ctor :: Prism' s a

2987

3088instance

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

47105 ErrorUnless _ _ 'True

48106 = ()

49107

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

109+-- "GHC.Generics".

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

51111 _GCtor :: Prism' (f x) a

52112

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

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

1111{-# LANGUAGE TypeOperators #-}

1212{-# LANGUAGE UndecidableInstances #-}

1313

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+

1427module Data.Generics.Sum.Typed

15− ( AsType (..)

28+ ( -- *Prisms

29+ --

30+ -- $example

31+ AsType (..)

1632

33+ -- *Internals

1734 , GAsType (..)

1835 ) where

1936

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

2542import GHC.Generics

2643import GHC.TypeLits

2744

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.

2875class 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

2985 _Typed :: Prism' s a

3086

3187instance

3288 ( Generic s

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

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

3490 , GAsType (Rep s) a

3591 ) => AsType a s where

3692

3793 _Typed = repIso . _GTyped

3894

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

40− ErrorUnless a s 'False

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

96+ ErrorUnlessOne a s 'None

4197 = TypeError

4298 ( 'Text "The type "

4399 ':<>: 'ShowType s

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

45101 ':<>: 'ShowType a

46102 )

47103

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

49114 = ()

50115

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

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

52118 _GTyped :: Prism' (f x) a

53119