579888b · generic-lens

git.iko.soy/generic-lens

on master help sign in

Add prisms focusing on a constructor by name

579888bCsongor Kiss9 years ago

examples/Examples.hs+19−17

compare with master

unifiedsplit

@@ -5,12 +5,20 @@

5{-# LANGUAGE TypeApplications #-}

6{-# LANGUAGE UndecidableInstances #-}

8+{-# OPTIONS_GHC -fno-warn-unused-imports #-}

8module Examples where

10module Examples where

10import GHC.Generics

12import GHC.Generics

11import Data.Generics.Record

13import Data.Generics.Record

12import Data.Generics.Product

14import Data.Generics.Product

13−import Control.Lens

15+--import Control.Lens

16+

17+data Animal = Animal

18+ { name :: String

19+ , age :: Int

20+ , eats :: String

21+ } deriving (Show, Generic)

15data Human = Human

23data Human = Human

16 { name :: String

24 { name :: String

@@ -19,24 +27,18 @@ data Human = Human

19 , eats :: String

27 , eats :: String

20 } deriving (Show, Generic)

28 } deriving (Show, Generic)

22−human :: Human

30+data Living

31+ = Animal' { name :: String, eats :: String, age :: Int }

23−human = Human { name = "Tunyasz", age = 10, address = "London", eats = "Bread" }

32+ | Human' { name :: String, age :: Int, address :: String, eats :: String }

33+ deriving (Show, Generic)

25−data Animal = Animal

35+toby :: Human

26− { name :: String

36+toby = Human { name = "Toby", age = 10, address = "London", eats = "Bread" }

27− , age :: Int

28− , eats :: String

29− } deriving (Show, Generic)

31growUp :: Animal -> Animal

38growUp :: Animal -> Animal

32−growUp (Animal name age _) = Animal name (age + 10) "raw meat"

39+growUp (Animal n a _) = Animal n (a + 10) "raw meat"

34−data WildAnimal = WildAnimal

35− { name :: String

36− , age :: Int

37− , eats :: String

38− , hunts :: Animal

39− } deriving (Show, Generic)

41+data MyRecord = MyRecord { field1 :: Int, field2 :: String } deriving Generic

41−raiseByWolves :: Human -> Human

43+--g :: Subtype s MyRecord => s -> String

42−raiseByWolves human = human & super %~ growUp

44+--g s = s ^. super @MyRecord . label @"field2"

generic-lens.cabal+3

@@ -24,6 +24,7 @@ build-type: Simple

24-- README.

25extra-source-files: ChangeLog.md

26 , examples/StarWars.hs

27+ , examples/Examples.hs

27 , README.md

28 , README.md

29-- Constraint on the version of Cabal needed to build this package.

30-- Constraint on the version of Cabal needed to build this package.

@@ -37,6 +38,7 @@ library

37 , Data.Generics.Record.HasField

38 , Data.Generics.Record.HasField

38 , Data.Generics.Product.HasFieldAt

39 , Data.Generics.Product.HasFieldAt

39 , Data.Generics.Internal.Lens

40 , Data.Generics.Internal.Lens

41+ , Data.Generics.Sum.HasConstructor

41 other-modules: Data.Generics.Record.Internal.Contains

43 other-modules: Data.Generics.Record.Internal.Contains

@@ -54,6 +56,7 @@ library

55 -- Other library packages from which modules are imported.

57 -- Other library packages from which modules are imported.

56 build-depends: base >= 4.9 && <= 5.0

58 build-depends: base >= 4.9 && <= 5.0

59+ , profunctors >= 5.0 && <= 6.0

58 -- Directories containing source files.

61 -- Directories containing source files.

59 hs-source-dirs: src

62 hs-source-dirs: src

src/Data/Generics/Internal/Lens.hs+40−4

@@ -17,6 +17,7 @@ module Data.Generics.Internal.Lens where

18import Control.Applicative ( Const (..) )

19import GHC.Generics ( (:*:) (..), Generic (..), M1 (..), Rep, (:+:) (..) )

20+import Data.Profunctor ( Choice (right'), Profunctor (dimap) )

21-- | Identity functor

22-- | Identity functor

22newtype Identity a

23newtype Identity a

@@ -31,6 +32,14 @@ instance Functor Identity where

31type Lens' s a

32type Lens' s a

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

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

35+-- | Type alias for prism

36+type Prism' s a

37+ = forall p f. (Choice p, Applicative f) => p a (f a) -> p s (f s)

38+

39+

40+type Iso' s a

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

42+

34-- | Getting

43-- | Getting

35(^.) :: s -> ((a -> Const a a) -> s -> Const a s) -> a

44(^.) :: s -> ((a -> Const a a) -> s -> Const a s) -> a

36s ^. l = getConst (l Const s)

45s ^. l = getConst (l Const s)

@@ -51,14 +60,41 @@ second :: Lens' ((a :*: b) x) (b x)

51second f (a :*: b)

60second f (a :*: b)

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

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

63+left :: Prism' ((a :+: b) x) (a x)

64+left = prism L1 $ \x -> case x of

65+ L1 a -> Right a

66+ R1 _ -> Left x

67+

68+right :: Prism' ((a :+: b) x) (b x)

69+right = prism R1 $ \x -> case x of

70+ L1 _ -> Left x

71+ R1 a -> Right a

72+

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

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

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

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

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

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

77+prism :: (a -> s) -> (s -> Either s a) -> Prism' s a

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

79+

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

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

59−repIso :: Generic a => Lens' a (Rep a x)

81+repIso :: Generic a => Iso' a (Rep a x)

60−repIso a = fmap to . a . from

82+repIso = dimap from (fmap to)

62-- | 'M1' is just a wrapper around `f p`

84-- | 'M1' is just a wrapper around `f p`

63−lensM :: Lens' (M1 i c f p) (f p)

85+mIso :: Iso' (M1 i c f p) (f p)

64−lensM f (M1 x) = fmap M1 (f x)

86+mIso = dimap unM1 (fmap M1)

87+

88+sumIso :: Iso' ((a :+: b) x) (Either (a x) (b x))

89+sumIso = dimap f (fmap t)

90+ where f (L1 x) = Left x

91+ f (R1 x) = Right x

92+ t (Left x) = L1 x

93+ t (Right x) = R1 x

94+

95+_Left :: Prism' (Either a c) a

96+_Left = prism Left $ either Right (Left . Right)

97+

98+_Right :: Prism' (Either c a) a

99+_Right = prism Right $ either (Left . Left) Right

100+

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

@@ -166,11 +166,11 @@ instance GHasFieldAt offset index (K1 R a) a where

166 gItemAt f (K1 x) = fmap K1 (f x)

167

168instance GHasFieldAt n n (S1 ('MetaSel m p f b) (Rec0 a)) a where

169− gItemAt = lensM . gItemAt @n @n

169+ gItemAt = mIso . gItemAt @n @n

170

171instance GHasFieldAt offset index s a => GHasFieldAt offset index (M1 D c s) a where

172− gItemAt = lensM . gItemAt @offset @index

172+ gItemAt = mIso . gItemAt @offset @index

173

174instance GHasFieldAt offset index s a => GHasFieldAt offset index (M1 C c s) a where

175− gItemAt = lensM . gItemAt @offset @index

175+ gItemAt = mIso . gItemAt @offset @index

176

src/Data/Generics/Record/HasField.hs+14−14

@@ -1,14 +1,14 @@

1−{-# LANGUAGE AllowAmbiguousTypes #-}

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE FunctionalDependencies #-}

5−{-# LANGUAGE PolyKinds #-}

5+{-# LANGUAGE PolyKinds #-}

6−{-# LANGUAGE Rank2Types #-}

6+{-# LANGUAGE Rank2Types #-}

7−{-# LANGUAGE ScopedTypeVariables #-}

7+{-# LANGUAGE ScopedTypeVariables #-}

8−{-# LANGUAGE TypeApplications #-}

8+{-# LANGUAGE TypeApplications #-}

9−{-# LANGUAGE TypeFamilies #-}

9+{-# LANGUAGE TypeFamilies #-}

10−{-# LANGUAGE TypeOperators #-}

10+{-# LANGUAGE TypeOperators #-}

11−{-# LANGUAGE UndecidableInstances #-}

11+{-# LANGUAGE UndecidableInstances #-}

13-----------------------------------------------------------------------------

14-- |

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

94-- field.

95instance

96 ( Generic s

97− , Contains field (Rep s) ~ 'Just a -- this is needed for the fundep for some reason

97+ , Contains field (Rep s) ~ 'Just a -- this is needed for the fundep

98 , GHasField field (Rep s) a

99 ) => HasField field a s where

100 label = repIso . glabel @field

@@ -122,13 +122,13 @@ instance (GHasField field s a, GHasField field s' a) => GHasField field (s :+: s

122 glabel = combine (glabel @field @s) (glabel @field @s')

123

124instance GHasField field (S1 ('MetaSel ('Just field) p f b) (Rec0 a)) a where

125− glabel = lensM . glabel @field

125+ glabel = mIso . glabel @field

126

127instance GHasField field (K1 R a) a where

128 glabel f (K1 x) = fmap K1 (f x)

129

130instance GHasField field s a => GHasField field (M1 D c s) a where

131− glabel = lensM . glabel @field

131+ glabel = mIso . glabel @field

132

133instance GHasField field s a => GHasField field (M1 C c s) a where

134− glabel = lensM . glabel @field

134+ glabel = mIso . glabel @field

src/Data/Generics/Record/Subtype.hs+12−12

@@ -1,14 +1,14 @@

1−{-# LANGUAGE AllowAmbiguousTypes #-}

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE FlexibleInstances #-}

4−{-# LANGUAGE FunctionalDependencies #-}

4+{-# LANGUAGE MultiParamTypeClasses #-}

5−{-# LANGUAGE PolyKinds #-}

5+{-# LANGUAGE PolyKinds #-}

6−{-# LANGUAGE Rank2Types #-}

6+{-# LANGUAGE Rank2Types #-}

7−{-# LANGUAGE ScopedTypeVariables #-}

7+{-# LANGUAGE ScopedTypeVariables #-}

8−{-# LANGUAGE TypeApplications #-}

8+{-# LANGUAGE TypeApplications #-}

9−{-# LANGUAGE TypeFamilies #-}

9+{-# LANGUAGE TypeFamilies #-}

10−{-# LANGUAGE TypeOperators #-}

10+{-# LANGUAGE TypeOperators #-}

11−{-# LANGUAGE UndecidableInstances #-}

11+{-# LANGUAGE UndecidableInstances #-}

13-----------------------------------------------------------------------------

14-- |

@@ -92,7 +92,7 @@ instance (GSmash (Rep a) (Rep b), GUpcast (Rep a) (Rep b), Generic a, Generic b)

92-- >>> set (super @Animal) (Animal "dog" 10) human

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

94super :: forall sup sub. Subtype sub sup => Lens' sub sup

95−super f sub = fmap (flip smash sub) (f (upcast sub))

95+super f sub = fmap (`smash` sub) (f (upcast sub))

97--------------------------------------------------------------------------------

98-- * Generic upcasting

src/Data/Generics/Sum.hsnew file+5

@@ -0,0 +1,5 @@

1+module Data.Generics.Sum

2+ ( module HasConstructor

3+ ) where

5+import Data.Generics.Sum.HasConstructor as HasConstructor

src/Data/Generics/Sum/HasConstructor.hsnew file+205

@@ -0,0 +1,205 @@

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE FlexibleInstances #-}

4+{-# LANGUAGE FunctionalDependencies #-}

5+{-# LANGUAGE GADTs #-}

6+{-# LANGUAGE InstanceSigs #-}

7+{-# LANGUAGE PolyKinds #-}

8+{-# LANGUAGE Rank2Types #-}

9+{-# LANGUAGE ScopedTypeVariables #-}

10+{-# LANGUAGE TypeApplications #-}

11+{-# LANGUAGE TypeFamilies #-}

12+{-# LANGUAGE TypeOperators #-}

13+{-# LANGUAGE UndecidableInstances #-}

14+

15+{-# LANGUAGE DeriveGeneric #-}

16+-----------------------------------------------------------------------------

17+-- |

18+-- Module : Data.Generics.Sum.HasConstructor

20+-- License : BSD3

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

22+-- Stability : experimental

23+-- Portability : non-portable

24+--

25+-- Derive prisms generically

26+--

27+-- TODO: add examples

28+-----------------------------------------------------------------------------

29+

30+module Data.Generics.Sum.HasConstructor where

31+

32+import Data.Generics.Internal.Lens

33+

34+import GHC.TypeLits (Symbol, TypeError, ErrorMessage (..))

35+import Data.Kind (Type, Constraint)

36+import GHC.Generics

37+

38+class HasConstructor (con :: Symbol) a s | s con -> a where

39+ is :: Prism' s a

40+

41+instance

42+ ( Generic s

43+ , ErrorUnless (ContainsC con (Rep s)) con s

44+ , GHasConstructor con (Rep s) a

45+ ) => HasConstructor con a s where

46+ is = repIso . gconstruct @con

47+

48+type family ErrorUnless (contains :: Bool) (con :: Symbol) (s :: *) :: Constraint where

49+ ErrorUnless 'False con s

50+ = TypeError ( 'ShowType s

51+ ':<>: 'Text " has no constructor with name "

52+ ':<>: 'ShowType con)

53+ ErrorUnless _ _ _

54+ = ()

55+

56+data HList (xs :: [Type]) where

57+ Nil :: HList '[]

58+ (:>) :: x -> HList xs -> HList (x ': xs)

59+

60+infixr 5 :>

61+

62+append :: HList xs -> HList ys -> HList (xs ++ ys)

63+append Nil ys = ys

64+append (x :> xs) ys = x :> (xs `append` ys)

65+

66+class AsList (tup :: *) (xs :: [*]) | xs -> tup where

67+ asList :: tup -> HList xs

68+ asTuple :: HList xs -> tup

69+

70+instance AsList a '[a] where

71+ asList a

72+ = a :> Nil

73+

74+ asTuple (a :> Nil)

75+ = a

76+

77+instance AsList (a, b) '[a, b] where

78+ asList (a, b)

79+ = a :> b :> Nil

80+

81+ asTuple (a :> b :> Nil)

82+ = (a, b)

83+

84+instance AsList (a, b, c) '[a, b, c] where

85+ asList (a, b, c)

86+ = a :> b :> c :> Nil

87+

88+ asTuple (a :> b :> c :> Nil)

89+ = (a, b, c)

90+

91+instance AsList (a, b, c, d) '[a, b, c, d] where

92+ asList (a, b, c, d)

93+ = a :> b :> c :> d :> Nil

94+

95+ asTuple (a :> b :> c :> d :> Nil)

96+ = (a, b, c, d)

97+

98+instance AsList (a, b, c, d, e) '[a, b, c, d, e] where

99+ asList (a, b, c, d, e)

100+ = a :> b :> c :> d :> e :> Nil

101+

102+ asTuple (a :> b :> c :> d :> e :> Nil)

103+ = (a, b, c, d, e)

104+

105+instance AsList (a, b, c, d, e, f) '[a, b, c, d, e, f] where

106+ asList (a, b, c, d, e, f)

107+ = a :> b :> c :> d :> e :> f :> Nil

108+

109+ asTuple (a :> b :> c :> d :> e :> f :> Nil)

110+ = (a, b, c, d, e, f)

111+

112+instance AsList (a, b, c, d, e, f, g) '[a, b, c, d, e, f, g] where

113+ asList (a, b, c, d, e, f, g)

114+ = a :> b :> c :> d :> e :> f :> g :> Nil

115+

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

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

118+

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

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

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

122+

123+ asTuple (a :> b :> c :> d :> e :> f :> g :> h :> Nil)

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

125+

126+type family ((xs :: [k]) ++ (ys :: [k])) :: [k] where

127+ '[] ++ ys = ys

128+ (x ': xs) ++ ys = x ': xs ++ ys

129+

130+class GHasConstructor (con :: Symbol) (s :: Type -> Type) a | con s -> a where

131+ gconstruct :: Prism' (s x) a

132+

133+instance GHasConstructor con s a => GHasConstructor con (M1 D c s) a where

134+ gconstruct = mIso . gconstruct @con

135+

136+instance (GCollect s xs, AsList a xs) => GHasConstructor con (M1 C ('MetaCons con f n) s) a where

137+ gconstruct = prism (M1 . gto . asList) (Right . asTuple @_ @xs . gfrom . unM1)

138+

139+instance (GHasConstructor con s a) => GHasConstructor con (M1 S m s) a where

140+ gconstruct = mIso . gconstruct @con

141+

142+class GHasConstructorSum (con :: Symbol) l r a (p :: Bool) | con l r p -> a where

143+ gconstructSum :: Prism' ((l :+: r) x) a

144+

145+instance GHasConstructor con l a => GHasConstructorSum con l r a 'True where

146+ gconstructSum = left . gconstruct @con

147+

148+instance GHasConstructor con r a => GHasConstructorSum con l r a 'False where

149+ gconstructSum = right . gconstruct @con

150+

151+instance GHasConstructorSum con l r a (ContainsC con l) => GHasConstructor con (l :+: r) a where

152+ gconstruct = gconstructSum @con @l @r @a @(ContainsC con l)

153+

154+class Partition xs ys zs | xs ys -> zs, xs zs -> ys where

155+ partition :: HList zs -> (HList xs, HList ys)

156+

157+instance Partition '[] xs xs where

158+ partition xs = (Nil, xs)

159+

160+instance Partition xs ys zs => Partition (x ': xs) ys (x ': zs) where

161+ partition (x :> xs) = (x :> xs', ys')

162+ where (xs', ys') = partition xs

163+

164+class GCollect (s :: Type -> Type) (xs :: [Type]) | s -> xs where

165+ gfrom :: s x -> HList xs

166+ gto :: HList xs -> s x

167+

168+instance (GCollect a as, GCollect b bs, xs ~ (as ++ bs), Partition as bs xs) => GCollect (a :*: b) xs where

169+ gfrom (a :*: b) = gfrom a `append` gfrom b

170+ gto xs = gto l :*: gto r

171+ where (l, r) = partition @as @bs xs

172+

173+instance GCollect (K1 R a) '[a] where

174+ gfrom (K1 x) = x :> Nil

175+ gto (x :> Nil) = K1 x

176+

177+instance GCollect s a => GCollect (M1 S c s) a where

178+ gfrom (M1 x) = gfrom x

179+ gto x = M1 $ gto x

180+

181+instance GCollect s a => GCollect (M1 D c s) a where

182+ gfrom (M1 x) = gfrom x

183+ gto x = M1 $ gto x

184+

185+instance GCollect s a => GCollect (M1 C c s) a where

186+ gfrom (M1 x) = gfrom x

187+ gto x = M1 $ gto x

188+

189+--------------------------------------------------------------------------------

190+

191+type family ContainsC (cname :: Symbol) f :: Bool where

192+ ContainsC cname (C1 ('MetaCons cname _ _) _)

193+ = 'True

194+ ContainsC cname (f :+: g)

195+ = ContainsC cname f || ContainsC cname g

196+ ContainsC cname (D1 m f)

197+ = ContainsC cname f

198+ ContainsC cname _

199+ = 'False

200+

201+-- | Type-level alternative

202+type family (a :: Bool) || (b :: Bool) :: Bool where

203+ 'True || _ = 'True

204+ 'False || b = b

205+