@@ -16,20 +16,17 @@ module Ether.Internal
1616 , HandleSuper
1717 , HandleConstraint
1818 , Handle(..)
19− , makeTupleInstancesHasLens
2019 ) where
2120
2221import Control.Applicative
2322import Data.Coerce
2423import Data.Functor.Identity
2524import Data.Kind
25+import Data.List as List
2626import Data.Tagged
27+import Data.Traversable
2728import GHC.Exts (Constraint)
28−
29−import Ether.Internal.HasLens
30−import Ether.Internal.Tags
31−import Ether.Internal.TH_TupleInstances (makeTupleInstancesHasLens)
32−import Ether.Internal.TupleInstances ()
29+import qualified Language.Haskell.TH as TH
3330
3431data TAGGED e t
3532
@@ -57,12 +54,120 @@ class
5754 where
5855 handling :: Monad m => (HandleConstraint eff p trans m => r) -> r
5956
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+
6063newtype ReifiedLens s t a b = Lens (Lens s t a b)
6164
6265type ReifiedLens' s a = ReifiedLens s s a a
6366
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+
6476view :: LensLike (Const a) s t a b -> s -> a
6577view l = coerce (l Const)
6678
6779over :: LensLike Identity s t a b -> (a -> b) -> s -> t
6880over = 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+ [] ] ]