8fa3913 · typeable/ether

ether.cabal+18

compare with master

unifiedsplit

@@ -36,6 +36,24 @@ library

36 Ether.TagDispatch

37 Ether.Internal

38

39+ other-modules:

40+ Ether.Internal.Tags

41+ Ether.Internal.HasLens

42+ Ether.Internal.TH_Utils

43+ Ether.Internal.TH_TupleInstances

44+ Ether.Internal.TupleInstances_TagsK

45+ Ether.Internal.TupleInstances_Tags

46+ Ether.Internal.TupleInstances_HasLens

47+ Ether.Internal.TupleInstances_HasLens_1

48+ Ether.Internal.TupleInstances_HasLens_2

49+ Ether.Internal.TupleInstances_HasLens_3

50+ Ether.Internal.TupleInstances_HasLens_4

51+ Ether.Internal.TupleInstances_HasLens_5

52+ Ether.Internal.TupleInstances_HasLens_6

53+ Ether.Internal.TupleInstances_HasLens_7

54+ Ether.Internal.TupleInstances_HasLens_8

55+ Ether.Internal.TupleInstances_HasLens_9

56+

39 build-depends:

57 build-depends:

40 base >=4.9 && <4.11,

58 base >=4.9 && <4.11,

41 transformers >=0.5.2.0,

59 transformers >=0.5.2.0,

src/Ether/Internal.hs+6−111

@@ -22,11 +22,14 @@ import Control.Applicative

22import Data.Coerce

23import Data.Functor.Identity

24import Data.Kind

25−import Data.List as List

26import Data.Tagged

25import Data.Tagged

27−import Data.Traversable

28import GHC.Exts (Constraint)

26import GHC.Exts (Constraint)

29−import qualified Language.Haskell.TH as TH

27+

28+import Ether.Internal.HasLens

29+import Ether.Internal.Tags

30+import Ether.Internal.TupleInstances_Tags ()

31+import Ether.Internal.TupleInstances_TagsK ()

32+import Ether.Internal.TupleInstances_HasLens ()

30

33

31data TAGGED e t

34data TAGGED e t

32

35

@@ -54,120 +57,12 @@ class

54 where

57 where

55 handling :: Monad m => (HandleConstraint eff p trans m => r) -> r

58 handling :: Monad m => (HandleConstraint eff p trans m => r) -> r

56

59

57−type LensLike f s t a b = (a -> f b) -> s -> f t

58−

59−type Lens s t a b = forall f. Functor f => LensLike f s t a b

60−

61−type Lens' s a = Lens s s a a

62−

63newtype ReifiedLens s t a b = Lens (Lens s t a b)

60newtype ReifiedLens s t a b = Lens (Lens s t a b)

64

61

65type ReifiedLens' s a = ReifiedLens s s a a

62type ReifiedLens' s a = ReifiedLens s s a a

66

63

67−class HasLens tag outer inner | tag outer -> inner where

68− lensOf :: Lens' outer inner

69−

70−instance HasLens a a a where

71− lensOf = id

72−

73−instance HasLens t (Tagged t a) a where

74− lensOf = \f -> fmap coerce . f . coerce

75−

76view :: LensLike (Const a) s t a b -> s -> a

64view :: LensLike (Const a) s t a b -> s -> a

77view l = coerce (l Const)

65view l = coerce (l Const)

78

66

79over :: LensLike Identity s t a b -> (a -> b) -> s -> t

67over :: LensLike Identity s t a b -> (a -> b) -> s -> t

80over = coerce

68over = coerce

81−

82−data HList xs where

83− HNil :: HList '[]

84− HCons :: x -> HList xs -> HList (x ': xs)

85−

86−type KindOf (a :: k) = k

87−

88−type family TagsK (p :: Type) :: [Type]

89−type family Tags (p :: Type) :: HList (TagsK p)

90−

91−return []

92−

93−type instance TagsK () = '[]

94−type instance TagsK (Tagged t a) = '[KindOf t]

95−

96−do

97− let

98− tupCount = 62

99− varName k = TH.mkName ('a' : show k)

100− tagName k = TH.mkName ('t' : show k)

101− for [2..tupCount] $ \n -> do

102− let

103− tupTy = List.foldl' TH.AppT (TH.ConT (TH.tupleTypeName n)) $

104− (\k -> TH.ConT ''Tagged `TH.AppT`

105− TH.VarT (tagName k) `TH.AppT`

106− TH.VarT (varName k)) <$> [0..n-1]

107− tagsList = List.foldr

108− (\a b -> TH.PromotedConsT `TH.AppT` a `TH.AppT` b)

109− TH.PromotedNilT

110− (TH.AppT (TH.ConT ''KindOf) . TH.VarT . tagName <$> [0..n-1])

111− return $

112− TH.TySynInstD ''TagsK (TH.TySynEqn [tupTy] tagsList)

113−

114−return []

115−

116−type instance Tags () = 'HNil

117−type instance Tags (Tagged t a) = 'HCons t 'HNil

118−

119−do

120− let

121− tupCount = 62

122− varName k = TH.mkName ('a' : show k)

123− tagName k = TH.mkName ('t' : show k)

124− for [2..tupCount] $ \n -> do

125− let

126− tupTy = List.foldl' TH.AppT (TH.ConT (TH.tupleTypeName n)) $

127− (\k -> TH.ConT ''Tagged `TH.AppT`

128− TH.VarT (tagName k) `TH.AppT`

129− TH.VarT (varName k)) <$> [0..n-1]

130− tagsList = List.foldr

131− (\a b -> TH.PromotedT 'HCons `TH.AppT` a `TH.AppT` b)

132− (TH.PromotedT 'HNil)

133− (TH.VarT . tagName <$> [0..n-1])

134− return $

135− TH.TySynInstD ''Tags (TH.TySynEqn [tupTy] tagsList)

136−

137−do

138− let

139− tupCount = 62

140− varName k = TH.mkName ('a' : show k)

141− fmap List.concat $

142− for [2..tupCount] $ \n ->

143− for [0..n-1] $ \k -> do

144− let

145− tag = TH.mkName "tag"

146− prev = varName <$> [0..k-1]

147− cur = varName k

148− next = varName <$> [k+1..n-1]

149− tupTy = foldl TH.AppT (TH.ConT (TH.tupleTypeName n))

150− ( map TH.VarT prev ++

151− [TH.ConT ''Tagged `TH.AppT` TH.VarT tag `TH.AppT` TH.VarT cur] ++

152− map TH.VarT next )

153− let

154− cur' = TH.mkName "x"

155− f = TH.mkName "f"

156− return $

157− TH.InstanceD Nothing []

158− (TH.ConT ''HasLens `TH.AppT` TH.VarT tag `TH.AppT` tupTy `TH.AppT` TH.VarT cur)

159− [ TH.FunD 'lensOf

160− [ TH.Clause

161− [TH.VarP f, TH.TupP

162− ( map TH.VarP prev ++

163− [TH.ConP 'Tagged [TH.VarP cur]] ++

164− map TH.VarP next )]

165− (TH.NormalB $

166− TH.VarE 'fmap `TH.AppE`

167− (TH.LamE [TH.VarP cur']

168− (TH.TupE

169− ( map TH.VarE prev ++

170− [TH.ConE 'Tagged `TH.AppE` TH.VarE cur'] ++

171− map TH.VarE next ))) `TH.AppE`

172− (TH.VarE f `TH.AppE` TH.VarE cur) )

173− [] ] ]

src/Ether/Internal/HasLens.hsnew file+24

@@ -0,0 +1,24 @@

1+module Ether.Internal.HasLens

2+ ( LensLike

3+ , Lens

4+ , Lens'

5+ , HasLens(..)

6+ ) where

7+

8+import Data.Tagged

9+import Data.Coerce

10+

11+type LensLike f s t a b = (a -> f b) -> s -> f t

12+

13+type Lens s t a b = forall f. Functor f => LensLike f s t a b

14+

15+type Lens' s a = Lens s s a a

16+

17+class HasLens tag outer inner | tag outer -> inner where

18+ lensOf :: Lens' outer inner

19+

20+instance HasLens a a a where

21+ lensOf = id

22+

23+instance HasLens t (Tagged t a) a where

24+ lensOf = \f -> fmap coerce . f . coerce

src/Ether/Internal/TH_TupleInstances.hsnew file+79

@@ -0,0 +1,79 @@

1+module Ether.Internal.TH_TupleInstances

2+ ( makeTupleInstancesTagsK

3+ , makeTupleInstancesTags

4+ , makeTupleInstancesHasLens

5+ ) where

6+

7+import Data.Tagged

8+import Data.Traversable

9+import Data.List as List

10+import qualified Language.Haskell.TH as TH

11+

12+import Ether.Internal.HasLens

13+import Ether.Internal.Tags

14+import Ether.Internal.TH_Utils

15+

16+makeTupleInstancesTagsK :: TH.DecsQ

17+makeTupleInstancesTagsK = do

18+ for [2..tupCount] $ \n -> do

19+ let

20+ tupTy = List.foldl' TH.AppT (TH.ConT (TH.tupleTypeName n)) $

21+ (\k -> TH.ConT ''Tagged `TH.AppT`

22+ TH.VarT (tagName k) `TH.AppT`

23+ TH.VarT (varName k)) <$> [0..n-1]

24+ tagsList = List.foldr

25+ (\a b -> TH.PromotedConsT `TH.AppT` a `TH.AppT` b)

26+ TH.PromotedNilT

27+ (TH.AppT (TH.ConT ''KindOf) . TH.VarT . tagName <$> [0..n-1])

28+ return $

29+ TH.TySynInstD ''TagsK (TH.TySynEqn [tupTy] tagsList)

30+

31+makeTupleInstancesTags :: TH.DecsQ

32+makeTupleInstancesTags = do

33+ for [2..tupCount] $ \n -> do

34+ let

35+ tupTy = List.foldl' TH.AppT (TH.ConT (TH.tupleTypeName n)) $

36+ (\k -> TH.ConT ''Tagged `TH.AppT`

37+ TH.VarT (tagName k) `TH.AppT`

38+ TH.VarT (varName k)) <$> [0..n-1]

39+ tagsList = List.foldr

40+ (\a b -> TH.PromotedT 'HCons `TH.AppT` a `TH.AppT` b)

41+ (TH.PromotedT 'HNil)

42+ (TH.VarT . tagName <$> [0..n-1])

43+ return $

44+ TH.TySynInstD ''Tags (TH.TySynEqn [tupTy] tagsList)

45+

46+makeTupleInstancesHasLens :: [Int] -> TH.DecsQ

47+makeTupleInstancesHasLens range = List.concat <$> do

48+ for range $ \n ->

49+ for [0..n-1] $ \k -> do

50+ let

51+ tag = TH.mkName "tag"

52+ prev = varName <$> [0..k-1]

53+ cur = varName k

54+ next = varName <$> [k+1..n-1]

55+ tupTy = foldl TH.AppT (TH.ConT (TH.tupleTypeName n))

56+ ( map TH.VarT prev ++

57+ [TH.ConT ''Tagged `TH.AppT` TH.VarT tag `TH.AppT` TH.VarT cur] ++

58+ map TH.VarT next )

59+ let

60+ cur' = TH.mkName "x"

61+ f = TH.mkName "f"

62+ return $

63+ TH.InstanceD Nothing []

64+ (TH.ConT ''HasLens `TH.AppT` TH.VarT tag `TH.AppT` tupTy `TH.AppT` TH.VarT cur)

65+ [ TH.FunD 'lensOf

66+ [ TH.Clause

67+ [TH.VarP f, TH.TupP

68+ ( map TH.VarP prev ++

69+ [TH.ConP 'Tagged [TH.VarP cur]] ++

70+ map TH.VarP next )]

71+ (TH.NormalB $

72+ TH.VarE 'fmap `TH.AppE`

73+ (TH.LamE [TH.VarP cur']

74+ (TH.TupE

75+ ( map TH.VarE prev ++

76+ [TH.ConE 'Tagged `TH.AppE` TH.VarE cur'] ++

77+ map TH.VarE next ))) `TH.AppE`

78+ (TH.VarE f `TH.AppE` TH.VarE cur) )

79+ [] ] ]

src/Ether/Internal/TH_Utils.hsnew file+14

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

1+module Ether.Internal.TH_Utils

2+ ( tupCount

3+ , varName

4+ , tagName

5+ ) where

6+

7+import qualified Language.Haskell.TH as TH

8+

9+tupCount :: Int

10+tupCount = 62

11+

12+varName, tagName :: Int -> TH.Name

13+varName k = TH.mkName ('a' : show k)

14+tagName k = TH.mkName ('t' : show k)

src/Ether/Internal/Tags.hsnew file+18

@@ -0,0 +1,18 @@

1+module Ether.Internal.Tags

2+ ( Tags

3+ , TagsK

4+ , HList(..)

5+ , KindOf

6+ ) where

7+

8+import Data.Kind

9+

10+data HList xs where

11+ HNil :: HList '[]

12+ HCons :: x -> HList xs -> HList (x ': xs)

13+

14+type KindOf (a :: k) = k

15+

16+type family TagsK (p :: Type) :: [Type]

17+type family Tags (p :: Type) :: HList (TagsK p)

18+

src/Ether/Internal/TupleInstances_HasLens.hsnew file+11

@@ -0,0 +1,11 @@

1+module Ether.Internal.TupleInstances_HasLens () where

2+

3+import Ether.Internal.TupleInstances_HasLens_1 ()

4+import Ether.Internal.TupleInstances_HasLens_2 ()

5+import Ether.Internal.TupleInstances_HasLens_3 ()

6+import Ether.Internal.TupleInstances_HasLens_4 ()

7+import Ether.Internal.TupleInstances_HasLens_5 ()

8+import Ether.Internal.TupleInstances_HasLens_6 ()

9+import Ether.Internal.TupleInstances_HasLens_7 ()

10+import Ether.Internal.TupleInstances_HasLens_8 ()

11+import Ether.Internal.TupleInstances_HasLens_9 ()

src/Ether/Internal/TupleInstances_HasLens_1.hsnew file+7

@@ -0,0 +1,7 @@

1+{-# OPTIONS -fno-warn-orphans #-}

2+

3+module Ether.Internal.TupleInstances_HasLens_1 () where

4+

5+import Ether.Internal.TH_TupleInstances (makeTupleInstancesHasLens)

6+

7+makeTupleInstancesHasLens [2..20]

src/Ether/Internal/TupleInstances_HasLens_2.hsnew file+7

@@ -0,0 +1,7 @@

1+{-# OPTIONS -fno-warn-orphans #-}

2+

3+module Ether.Internal.TupleInstances_HasLens_2 () where

4+

5+import Ether.Internal.TH_TupleInstances (makeTupleInstancesHasLens)

6+

7+makeTupleInstancesHasLens [21..29]

src/Ether/Internal/TupleInstances_HasLens_3.hsnew file+7

@@ -0,0 +1,7 @@

1+{-# OPTIONS -fno-warn-orphans #-}

2+

3+module Ether.Internal.TupleInstances_HasLens_3 () where

4+

5+import Ether.Internal.TH_TupleInstances (makeTupleInstancesHasLens)

6+

7+makeTupleInstancesHasLens [30..36]

src/Ether/Internal/TupleInstances_HasLens_4.hsnew file+7

@@ -0,0 +1,7 @@

1+{-# OPTIONS -fno-warn-orphans #-}

2+

3+module Ether.Internal.TupleInstances_HasLens_4 () where

4+

5+import Ether.Internal.TH_TupleInstances (makeTupleInstancesHasLens)

6+

7+makeTupleInstancesHasLens [37..42]

src/Ether/Internal/TupleInstances_HasLens_5.hsnew file+7

@@ -0,0 +1,7 @@

1+{-# OPTIONS -fno-warn-orphans #-}

2+

3+module Ether.Internal.TupleInstances_HasLens_5 () where

4+

5+import Ether.Internal.TH_TupleInstances (makeTupleInstancesHasLens)

6+

7+makeTupleInstancesHasLens [43..47]

src/Ether/Internal/TupleInstances_HasLens_6.hsnew file+7

@@ -0,0 +1,7 @@

1+{-# OPTIONS -fno-warn-orphans #-}

2+

3+module Ether.Internal.TupleInstances_HasLens_6 () where

4+

5+import Ether.Internal.TH_TupleInstances (makeTupleInstancesHasLens)

6+

7+makeTupleInstancesHasLens [48..52]

src/Ether/Internal/TupleInstances_HasLens_7.hsnew file+7

@@ -0,0 +1,7 @@

1+{-# OPTIONS -fno-warn-orphans #-}

2+

3+module Ether.Internal.TupleInstances_HasLens_7 () where

4+

5+import Ether.Internal.TH_TupleInstances (makeTupleInstancesHasLens)

6+

7+makeTupleInstancesHasLens [53..56]

src/Ether/Internal/TupleInstances_HasLens_8.hsnew file+7

@@ -0,0 +1,7 @@

1+{-# OPTIONS -fno-warn-orphans #-}

2+

3+module Ether.Internal.TupleInstances_HasLens_8 () where

4+

5+import Ether.Internal.TH_TupleInstances (makeTupleInstancesHasLens)

6+

7+makeTupleInstancesHasLens [57..60]

src/Ether/Internal/TupleInstances_HasLens_9.hsnew file+7

@@ -0,0 +1,7 @@

1+{-# OPTIONS -fno-warn-orphans #-}

2+

3+module Ether.Internal.TupleInstances_HasLens_9 () where

4+

5+import Ether.Internal.TH_TupleInstances (makeTupleInstancesHasLens)

6+

7+makeTupleInstancesHasLens [61..62]

src/Ether/Internal/TupleInstances_Tags.hsnew file+13

@@ -0,0 +1,13 @@

1+module Ether.Internal.TupleInstances_Tags () where

2+

3+import Data.Tagged

4+

5+import Ether.Internal.Tags

6+import Ether.Internal.TupleInstances_TagsK ()

7+import Ether.Internal.TH_TupleInstances (makeTupleInstancesTags)

8+

9+type instance Tags () = 'HNil

10+type instance Tags (Tagged t a) = 'HCons t 'HNil

11+type instance Tags (Tagged t0 a, Tagged t1 b) = 'HCons t0 ('HCons t1 'HNil)

12+

13+makeTupleInstancesTags

src/Ether/Internal/TupleInstances_TagsK.hsnew file+12

@@ -0,0 +1,12 @@

1+module Ether.Internal.TupleInstances_TagsK () where

2+

3+import Data.Tagged

4+

5+import Ether.Internal.Tags

6+import Ether.Internal.TH_TupleInstances (makeTupleInstancesTagsK)

7+

8+type instance TagsK () = '[]

9+type instance TagsK (Tagged t a) = '[KindOf t]

10+type instance TagsK (Tagged t0 a, Tagged t1 b) = '[KindOf t0, KindOf t1]

11+

12+makeTupleInstancesTagsK