138fbd9 · generic-lens

git.iko.soy/generic-lens

on master help sign in

Fix _Typed prism for multiple arities

138fbd9Csongor Kiss9 years ago

README.md+3−3

compare with master

unifiedsplit

@@ -175,10 +175,10 @@ type Name = String

175type Age = Int

176

177data Dog = MkDog { name :: Name, age :: Age } deriving (Generic, Show)

178−data Animal = Dog Dog | Cat (Name, Age) | Duck Age deriving (Generic, Show)

178+data Animal = Dog Dog | Cat Name Age | Duck Age deriving (Generic, Show)

179

180shep = Dog (MkDog "Shep" 4)

181−mog = Cat ("Mog", 5)

181+mog = Cat "Mog" 5

182donald = Duck 4

183```

184

@@ -193,7 +193,7 @@ Nothing

193Just ("Mog",5)

194

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

196−Cat ("Garfield",6)

196+Cat "Garfield" 6

197

198>>> donald ^? _Ctor @"Giraffe"

199error:

src/Data/Generics/Internal/Families/Count.hs+9−19

@@ -22,6 +22,9 @@ module Data.Generics.Internal.Families.Count

23import GHC.Generics

24import GHC.TypeLits

25+import Data.Type.Bool (If)

26+

27+import Data.Generics.Internal.HList

26type family CountTotalType t f :: Count where

29type family CountTotalType t f :: Count where

27 CountTotalType t (S1 _ (Rec0 t))

30 CountTotalType t (S1 _ (Rec0 t))

@@ -49,29 +52,16 @@ type family CountTotalType t f :: Count where

49 )

52 )

51type family CountPartialType t f :: Count where

54type family CountPartialType t f :: Count where

52− CountPartialType t (S1 _ (Rec0 t))

53− = 'One

54− CountPartialType t (l :*: r)

55− = CountPartialType t l <|> CountPartialType t r

56 CountPartialType t (l :+: r)

55 CountPartialType t (l :+: r)

57 = CountPartialType t l <|> CountPartialType t r

56 = CountPartialType t l <|> CountPartialType t r

58− CountPartialType t (S1 _ _)

57+ CountPartialType t (C1 m f)

59− = 'None

58+ = If (Equals t (ListToTuple (GCollect f))) 'One 'None

60− CountPartialType t (C1 _ f)

61− = CountPartialType t f

62 CountPartialType t (D1 _ f)

59 CountPartialType t (D1 _ f)

63 = CountPartialType t f

60 = CountPartialType t f

64− CountPartialType t (Rec0 _)

61+

65− = 'None

62+type family Equals a b where

66− CountPartialType t U1

63+ Equals a a = 'True

67− = 'None

64+ Equals _ _ = 'False

68− CountPartialType t V1

69− = 'None

70− CountPartialType t f

71− = TypeError

72− ( 'ShowType f

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

74− )

76data Count

66data Count

77 = None

67 = None

src/Data/Generics/Internal/Families/Has.hs+13−24

@@ -17,7 +17,7 @@

17module Data.Generics.Internal.Families.Has

18 ( HasTotalFieldP

19 , HasTotalTypeP

20− , HasPartialTypeP

20+ , HasPartialTypeTupleP

21 , HasCtorP

22 ) where

@@ -25,6 +25,8 @@ import Data.Type.Bool (type (||), type (&&))

25import GHC.Generics

26import GHC.TypeLits

28+import Data.Generics.Internal.HList

29+

28type family HasTotalFieldP (field :: Symbol) f :: Bool where

30type family HasTotalFieldP (field :: Symbol) f :: Bool where

29 HasTotalFieldP field (S1 ('MetaSel ('Just field) _ _ _) _)

31 HasTotalFieldP field (S1 ('MetaSel ('Just field) _ _ _) _)

30 = 'True

32 = 'True

@@ -75,30 +77,17 @@ type family HasTotalTypeP a f :: Bool where

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

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

76 )

78 )

78−type family HasPartialTypeP a f :: Bool where

80+type family HasPartialTypeTupleP a f :: Bool where

79− HasPartialTypeP t (S1 meta (Rec0 t))

81+ HasPartialTypeTupleP t (l :+: r)

80− = 'True

82+ = HasPartialTypeTupleP t l || HasPartialTypeTupleP t r

81− HasPartialTypeP t (l :*: r)

83+ HasPartialTypeTupleP t (C1 m f)

82− = HasPartialTypeP t l || HasPartialTypeP t r

84+ = Equals t (ListToTuple (GCollect f))

83− HasPartialTypeP t (l :+: r)

85+ HasPartialTypeTupleP t _

84− = HasPartialTypeP t l || HasPartialTypeP t r

85− HasPartialTypeP t (S1 _ _)

86− = 'False

87− HasPartialTypeP t (C1 m f)

88− = HasPartialTypeP t f

89− HasPartialTypeP t (D1 m f)

90− = HasPartialTypeP t f

91− HasPartialTypeP t (Rec0 _)

92− = 'False

93− HasPartialTypeP t U1

94− = 'False

95− HasPartialTypeP t V1

96 = 'False

86 = 'False

97− HasPartialTypeP t f

87+

98− = TypeError

88+type family Equals a b where

99− ( 'ShowType f

89+ Equals a a = 'True

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

90+ Equals _ _ = 'False

101− )

102

103type family HasCtorP (ctor :: Symbol) f :: Bool where

92type family HasCtorP (ctor :: Symbol) f :: Bool where

104 HasCtorP ctor (C1 ('MetaCons ctor _ _) _)

93 HasCtorP ctor (C1 ('MetaCons ctor _ _) _)

src/Data/Generics/Internal/HList.hs+19−1

@@ -67,74 +67,87 @@ instance Splittable as bs cs => Splittable (a ': as) bs (a ': cs) where

67-- * Convert tuples to/from HLists

69class ListTuple (tuple :: Type) (as :: [Type]) | as -> tuple where

70+ type ListToTuple as :: Type

70 tupleToList :: tuple -> HList as

71 tupleToList :: tuple -> HList as

71 listToTuple :: HList as -> tuple

72 listToTuple :: HList as -> tuple

73instance ListTuple () '[] where

74instance ListTuple () '[] where

75+ type ListToTuple '[] = ()

74 tupleToList _ = Nil

76 tupleToList _ = Nil

75 listToTuple _ = ()

77 listToTuple _ = ()

77instance ListTuple a '[a] where

79instance ListTuple a '[a] where

80+ type ListToTuple '[a] = a

78 tupleToList a

81 tupleToList a

79 = a :> Nil

82 = a :> Nil

80 listToTuple (a :> Nil)

83 listToTuple (a :> Nil)

81 = a

84 = a

83instance ListTuple (a, b) '[a, b] where

86instance ListTuple (a, b) '[a, b] where

87+ type ListToTuple '[a, b] = (a, b)

84 tupleToList (a, b)

88 tupleToList (a, b)

85 = a :> b :> Nil

89 = a :> b :> Nil

86 listToTuple (a :> b :> Nil)

90 listToTuple (a :> b :> Nil)

87 = (a, b)

91 = (a, b)

89instance ListTuple (a, b, c) '[a, b, c] where

93instance ListTuple (a, b, c) '[a, b, c] where

94+ type ListToTuple '[a, b, c] = (a, b, c)

90 tupleToList (a, b, c)

95 tupleToList (a, b, c)

91 = a :> b :> c :> Nil

96 = a :> b :> c :> Nil

92 listToTuple (a :> b :> c :> Nil)

97 listToTuple (a :> b :> c :> Nil)

93 = (a, b, c)

98 = (a, b, c)

95instance ListTuple (a, b, c, d) '[a, b, c, d] where

100instance ListTuple (a, b, c, d) '[a, b, c, d] where

101+ type ListToTuple '[a, b, c, d] = (a, b, c, d)

96 tupleToList (a, b, c, d)

102 tupleToList (a, b, c, d)

97 = a :> b :> c :> d:> Nil

103 = a :> b :> c :> d:> Nil

98 listToTuple (a :> b :> c :> d :> Nil)

104 listToTuple (a :> b :> c :> d :> Nil)

99 = (a, b, c, d)

105 = (a, b, c, d)

100

106

101instance ListTuple (a, b, c, d, e) '[a, b, c, d, e] where

107instance ListTuple (a, b, c, d, e) '[a, b, c, d, e] where

108+ type ListToTuple '[a, b, c, d, e] = (a, b, c, d, e)

102 tupleToList (a, b, c, d, e)

109 tupleToList (a, b, c, d, e)

103 = a :> b :> c :> d:> e :> Nil

110 = a :> b :> c :> d:> e :> Nil

104 listToTuple (a :> b :> c :> d :> e :> Nil)

111 listToTuple (a :> b :> c :> d :> e :> Nil)

105 = (a, b, c, d, e)

112 = (a, b, c, d, e)

106

113

107instance ListTuple (a, b, c, d, e, f) '[a, b, c, d, e, f] where

114instance ListTuple (a, b, c, d, e, f) '[a, b, c, d, e, f] where

115+ type ListToTuple '[a, b, c, d, e, f] = (a, b, c, d, e, f)

108 tupleToList (a, b, c, d, e, f)

116 tupleToList (a, b, c, d, e, f)

109 = a :> b :> c :> d:> e :> f :> Nil

117 = a :> b :> c :> d:> e :> f :> Nil

110 listToTuple (a :> b :> c :> d :> e :> f :> Nil)

118 listToTuple (a :> b :> c :> d :> e :> f :> Nil)

111 = (a, b, c, d, e, f)

119 = (a, b, c, d, e, f)

112

120

113instance ListTuple (a, b, c, d, e, f, g) '[a, b, c, d, e, f, g] where

121instance ListTuple (a, b, c, d, e, f, g) '[a, b, c, d, e, f, g] where

122+ type ListToTuple '[a, b, c, d, e, f, g] = (a, b, c, d, e, f, g)

114 tupleToList (a, b, c, d, e, f, g)

123 tupleToList (a, b, c, d, e, f, g)

115 = a :> b :> c :> d:> e :> f :> g :> Nil

124 = a :> b :> c :> d:> e :> f :> g :> Nil

116 listToTuple (a :> b :> c :> d :> e :> f :> g :> Nil)

125 listToTuple (a :> b :> c :> d :> e :> f :> g :> Nil)

117 = (a, b, c, d, e, f, g)

126 = (a, b, c, d, e, f, g)

118

127

119instance ListTuple (a, b, c, d, e, f, g, h) '[a, b, c, d, e, f, g, h] where

128instance ListTuple (a, b, c, d, e, f, g, h) '[a, b, c, d, e, f, g, h] where

129+ type ListToTuple '[a, b, c, d, e, f, g, h] = (a, b, c, d, e, f, g, h)

120 tupleToList (a, b, c, d, e, f, g, h)

130 tupleToList (a, b, c, d, e, f, g, h)

121 = a :> b :> c :> d:> e :> f :> g :> h :> Nil

131 = a :> b :> c :> d:> e :> f :> g :> h :> Nil

122 listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> Nil)

132 listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> Nil)

123 = (a, b, c, d, e, f, g, h)

133 = (a, b, c, d, e, f, g, h)

124

134

125instance ListTuple (a, b, c, d, e, f, g, h, j) '[a, b, c, d, e, f, g, h, j] where

135instance ListTuple (a, b, c, d, e, f, g, h, j) '[a, b, c, d, e, f, g, h, j] where

136+ type ListToTuple '[a, b, c, d, e, f, g, h, j] = (a, b, c, d, e, f, g, h, j)

126 tupleToList (a, b, c, d, e, f, g, h, j)

137 tupleToList (a, b, c, d, e, f, g, h, j)

127 = a :> b :> c :> d:> e :> f :> g :> h :> j :> Nil

138 = a :> b :> c :> d:> e :> f :> g :> h :> j :> Nil

128 listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> Nil)

139 listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> Nil)

129 = (a, b, c, d, e, f, g, h, j)

140 = (a, b, c, d, e, f, g, h, j)

130

141

131instance ListTuple (a, b, c, d, e, f, g, h, j, k) '[a, b, c, d, e, f, g, h, j, k] where

142instance ListTuple (a, b, c, d, e, f, g, h, j, k) '[a, b, c, d, e, f, g, h, j, k] where

143+ type ListToTuple '[a, b, c, d, e, f, g, h, j, k] = (a, b, c, d, e, f, g, h, j, k)

132 tupleToList (a, b, c, d, e, f, g, h, j, k)

144 tupleToList (a, b, c, d, e, f, g, h, j, k)

133 = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> Nil

145 = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> Nil

134 listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> Nil)

146 listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> Nil)

135 = (a, b, c, d, e, f, g, h, j, k)

147 = (a, b, c, d, e, f, g, h, j, k)

136

148

137instance ListTuple (a, b, c, d, e, f, g, h, j, k, l) '[a, b, c, d, e, f, g, h, j, k, l] where

149instance ListTuple (a, b, c, d, e, f, g, h, j, k, l) '[a, b, c, d, e, f, g, h, j, k, l] where

150+ type ListToTuple '[a, b, c, d, e, f, g, h, j, k, l] = (a, b, c, d, e, f, g, h, j, k, l)

138 tupleToList (a, b, c, d, e, f, g, h, j, k, l)

151 tupleToList (a, b, c, d, e, f, g, h, j, k, l)

139 = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> Nil

152 = a :> b :> c :> d:> e :> f :> g :> h :> j :> k :> l :> Nil

140 listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> Nil)

153 listToTuple (a :> b :> c :> d :> e :> f :> g :> h :> j :> k :> l :> Nil)

@@ -143,6 +156,7 @@ instance ListTuple (a, b, c, d, e, f, g, h, j, k, l) '[a, b, c, d, e, f, g, h, j

143--------------------------------------------------------------------------------

156--------------------------------------------------------------------------------

144

157

145class GCollectible (f :: Type -> Type) (as :: [Type]) | f -> as where

158class GCollectible (f :: Type -> Type) (as :: [Type]) | f -> as where

159+ type GCollect f :: [Type]

146 gtoCollection :: f x -> HList as

160 gtoCollection :: f x -> HList as

147 gfromCollection :: HList as -> f x

161 gfromCollection :: HList as -> f x

148

162

@@ -152,6 +166,7 @@ instance

152 , cs ~ (as ++ bs)

166 , cs ~ (as ++ bs)

153 , Splittable as bs cs

167 , Splittable as bs cs

154 ) => GCollectible (l :*: r) cs where

168 ) => GCollectible (l :*: r) cs where

169+ type GCollect (l :*: r) = GCollect l ++ GCollect r

155

170

156 gtoCollection (l :*: r)

171 gtoCollection (l :*: r)

157 = gtoCollection l `append` gtoCollection r

172 = gtoCollection l `append` gtoCollection r

@@ -160,14 +175,17 @@ instance

160 = gfromCollection as :*: gfromCollection bs

175 = gfromCollection as :*: gfromCollection bs

161 where (as, bs) = split cs

176 where (as, bs) = split cs

162

177

163−instance GCollectible (K1 R a) '[a] where

178+instance GCollectible (Rec0 a) '[a] where

179+ type GCollect (Rec0 a) = '[a]

164 gtoCollection = (:> Nil) . unK1

180 gtoCollection = (:> Nil) . unK1

165 gfromCollection = K1 . head'

181 gfromCollection = K1 . head'

166

182

167instance GCollectible U1 '[] where

183instance GCollectible U1 '[] where

184+ type GCollect U1 = '[]

168 gtoCollection U1 = Nil

185 gtoCollection U1 = Nil

169 gfromCollection Nil = U1

186 gfromCollection Nil = U1

170

187

171instance GCollectible f as => GCollectible (M1 m meta f) as where

188instance GCollectible f as => GCollectible (M1 m meta f) as where

189+ type GCollect (M1 m meta f) = GCollect f

172 gtoCollection = gtoCollection . unM1

190 gtoCollection = gtoCollection . unM1

173 gfromCollection = M1 . gfromCollection

191 gfromCollection = M1 . gfromCollection

src/Data/Generics/Sum/Constructors.hs−3

@@ -123,9 +123,6 @@ instance GSumAsConstructor ctor l r a (HasCtorP ctor l) => GAsConstructor ctor (

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

124 _GCtor = mIso . _GCtor @ctor

125

126−instance GAsConstructor ctor f a => GAsConstructor ctor (M1 S meta f) a where

127− _GCtor = mIso . _GCtor @ctor

128−

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

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

130 _GSumCtor :: Prism' ((l :+: r) x) a

127 _GSumCtor :: Prism' ((l :+: r) x) a

131

128

src/Data/Generics/Sum/Typed.hs+43−16

@@ -11,6 +11,8 @@

11{-# LANGUAGE TypeOperators #-}

12{-# LANGUAGE UndecidableInstances #-}

14+{-# LANGUAGE DeriveGeneric #-}

15+

14-----------------------------------------------------------------------------

16-----------------------------------------------------------------------------

15-- |

17-- |

16-- Module : Data.Generics.Sum.Typed

18-- Module : Data.Generics.Sum.Typed

@@ -51,7 +53,7 @@ import GHC.TypeLits

51--

53--

52-- data Animal

54-- data Animal

53-- = Dog Dog

55-- = Dog Dog

54−-- | Cat (Name, Age)

56+-- | Cat Name Age

55-- | Duck Age

57-- | Duck Age

56-- deriving (Generic, Show)

58-- deriving (Generic, Show)

57--

59--

@@ -116,27 +118,52 @@ type family ErrorUnlessOne (a :: Type) (s :: Type) (count :: Count) :: Constrain

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

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

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

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

118 _GTyped :: Prism' (f x) a

120 _GTyped :: Prism' (f x) a

121+ _GTyped = prism ginjectTyped gprojectTyped

122+

123+ ginjectTyped :: a -> f x

124+ gprojectTyped :: f x -> Either (f x) a

119

125

120instance

126instance

121− ( GCollectible f '[a]

127+ ( GCollectible f as

128+ , ListTuple a as

122 ) => GAsType (M1 C meta f) a where

129 ) => GAsType (M1 C meta f) a where

123

130

131+ ginjectTyped

132+ = M1 . gfromCollection . tupleToList

133+ gprojectTyped

124− _GTyped = prism (M1 . gfromCollection . tupleToList) (Right . listToTuple @_ @'[a] . gtoCollection . unM1)

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

125

135

126−instance GSumAsType l r a (HasPartialTypeP a l) => GAsType (l :+: r) a where

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

127− _GTyped = _GSumTyped @l @r @a @(HasPartialTypeP a l)

137+ ginjectTyped

138+ = ginjectSumTyped @(HasPartialTypeTupleP a l) @l @r @a

139+ gprojectTyped

140+ = gprojectSumTyped @(HasPartialTypeTupleP a l) @l @r @a

128

141

129instance GAsType f a => GAsType (M1 D meta f) a where

142instance GAsType f a => GAsType (M1 D meta f) a where

130− _GTyped = mIso . _GTyped

143+ ginjectTyped

131−

144+ = M1 . ginjectTyped

132−instance GAsType f a => GAsType (M1 S meta f) a where

145+ gprojectTyped

133− _GTyped = mIso . _GTyped

146+ = either (Left . M1) Right . gprojectTyped . unM1

134

147

135−class GSumAsType l r a (contains :: Bool) where

148+class GSumAsType (contains :: Bool) l r a where

136 _GSumTyped :: Prism' ((l :+: r) x) a

149 _GSumTyped :: Prism' ((l :+: r) x) a

137−

150+ _GSumTyped = prism (ginjectSumTyped @contains) (gprojectSumTyped @contains)

138−instance GAsType l a => GSumAsType l r a 'True where

151+

139− _GSumTyped = left . _GTyped

152+ ginjectSumTyped :: a -> (l :+: r) x

140−

153+ gprojectSumTyped :: (l :+: r) x -> Either ((l :+: r) x) a

154+

155+instance GAsType l a => GSumAsType 'True l r a where

156+ ginjectSumTyped

157+ = L1 . ginjectTyped

158+ gprojectSumTyped

159+ = \x -> case x of

160+ L1 l -> either (Left . L1) Right (gprojectTyped l)

161+ R1 _ -> Left x

162+

141−instance GAsType r a => GSumAsType l r a 'False where

163+instance GAsType r a => GSumAsType 'False l r a where

142− _GSumTyped = right . _GTyped

164+ ginjectSumTyped

165+ = R1 . ginjectTyped

166+ gprojectSumTyped

167+ = \x -> case x of

168+ R1 r -> either (Left . R1) Right (gprojectTyped r)

169+ L1 _ -> Left x