@@ -16,17 +16,20 @@ module Ether.Internal
1616 , HandleSuper
1717 , HandleConstraint
1818 , Handle(..)
19+ , makeTupleInstancesHasLens
1920 ) where
2021
2122import Control.Applicative
2223import Data.Coerce
2324import Data.Functor.Identity
2425import Data.Kind
25−import Data.List as List
2626import Data.Tagged
27−import Data.Traversable
2827import 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 ()
3033
3134data TAGGED e t
3235
@@ -54,120 +57,12 @@ class
5457 where
5558 handling :: Monad m => (HandleConstraint eff p trans m => r) -> r
5659
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−
6360newtype ReifiedLens s t a b = Lens (Lens s t a b)
6461
6562type ReifiedLens' s a = ReifiedLens s s a a
6663
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−
7664view :: LensLike (Const a) s t a b -> s -> a
7765view l = coerce (l Const)
7866
7967over :: LensLike Identity s t a b -> (a -> b) -> s -> t
8068over = 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− [] ] ]