git.iko.soy/typeable/ether
on master help sign in
Merge pull request #34 from int-index/mod-split
663d125Vladislav Zavialov
ether.cabal+24
compare with master
unifiedsplit
@@ -24,6 +24,20 @@ source-repository head
24 location: git@github.com:int-index/ether.git
24 location: git@github.com:int-index/ether.git
25
25
26
26
27+flag disable-tup-instances
28+
29+ description:
30+ Disable auto-generated 'HasLens' instances for tuples. The reason one
31+ might want to do this is to reduce the size of .hi-files, as well as the
32+ time and memory GHC needs to build Ether. To recover flattening with
33+ tuples, use 'Ether.Internal.makeTupleInstancesHasLens' at specific tuple
34+ sizes you need in your application.
35+
36+ This is a build-time performance hack, enable this flag at your own risk.
37+
38+ default: False
39+ manual: True
40+
27library
41library
28
42
29 exposed-modules:
43 exposed-modules:
@@ -36,6 +50,13 @@ library
36 Ether.TagDispatch
50 Ether.TagDispatch
37 Ether.Internal
51 Ether.Internal
38
52
53+ other-modules:
54+ Ether.Internal.Tags
55+ Ether.Internal.HasLens
56+ Ether.Internal.TH_Utils
57+ Ether.Internal.TH_TupleInstances
58+ Ether.Internal.TupleInstances
59+
39 build-depends:
60 build-depends:
40 base >=4.9 && <4.11,
61 base >=4.9 && <4.11,
41 transformers >=0.5.2.0,
62 transformers >=0.5.2.0,
@@ -84,6 +105,9 @@ library
84 ghc-options:
105 ghc-options:
85 -Wall -O2
106 -Wall -O2
86
107
108+ if flag(disable-tup-instances)
109+ cpp-options: -DDISABLE_TUP_INSTANCES
110+
87test-suite regression
111test-suite regression
88
112
89 build-depends:
113 build-depends:
src/Ether/Internal.hs+6−111
@@ -16,17 +16,20 @@ module Ether.Internal
16 , HandleSuper
16 , HandleSuper
17 , HandleConstraint
17 , HandleConstraint
18 , Handle(..)
18 , Handle(..)
19+ , makeTupleInstancesHasLens
19 ) where
20 ) where
20
21
21import Control.Applicative
22import Control.Applicative
22import Data.Coerce
23import Data.Coerce
23import Data.Functor.Identity
24import Data.Functor.Identity
24import Data.Kind
25import Data.Kind
25−import Data.List as List
26import Data.Tagged
26import Data.Tagged
27−import Data.Traversable
28import GHC.Exts (Constraint)
27import GHC.Exts (Constraint)
29−import qualified Language.Haskell.TH as TH
28+
29+import Ether.Internal.HasLens
30+import Ether.Internal.Tags
31+import Ether.Internal.TH_TupleInstances (makeTupleInstancesHasLens)
32+import Ether.Internal.TupleInstances ()
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.hsnew file+24
@@ -0,0 +1,24 @@
1+{-# OPTIONS -fno-warn-orphans #-}
2+{-# LANGUAGE CPP #-}
3+
4+module Ether.Internal.TupleInstances () where
5+
6+import Data.Tagged
7+import Ether.Internal.Tags
8+import Ether.Internal.TH_TupleInstances
9+
10+type instance TagsK () = '[]
11+type instance TagsK (Tagged t a) = '[KindOf t]
12+type instance TagsK (Tagged t0 a, Tagged t1 b) = '[KindOf t0, KindOf t1]
13+
14+makeTupleInstancesTagsK
15+
16+type instance Tags () = 'HNil
17+type instance Tags (Tagged t a) = 'HCons t 'HNil
18+type instance Tags (Tagged t0 a, Tagged t1 b) = 'HCons t0 ('HCons t1 'HNil)
19+
20+makeTupleInstancesTags
21+
22+#ifndef DISABLE_TUP_INSTANCES
23+makeTupleInstancesHasLens [2..62]
24+#endif