@@ -19,7 +19,6 @@ module Ether.Internal
1919 ) where
2020
2121import Control.Applicative
22−import Control.Monad
2322import Data.Coerce
2423import Data.Functor.Identity
2524import Data.Kind
@@ -72,6 +71,9 @@ instance HasLens a a a where
7271 lensOf = id
7372 {-# INLINE lensOf #-}
7473
74+instance HasLens t (Tagged t a) a where
75+ lensOf = \f -> fmap coerce . f . coerce
76+
7577view :: LensLike (Const a) s t a b -> s -> a
7678view l = coerce (l Const)
7779{-# INLINE view #-}
@@ -93,87 +95,83 @@ return []
9395
9496type instance TagsK () = '[]
9597type instance TagsK (Tagged t a) = '[KindOf t]
96−type instance TagsK (Tagged t0 a, Tagged t1 b) = '[KindOf t0, KindOf t1]
98+
99+do
100+ let
101+ tupCount = 62
102+ varName k = TH.mkName ('a' : show k)
103+ tagName k = TH.mkName ('t' : show k)
104+ for [2..tupCount] $ \n -> do
105+ let
106+ tupTy = List.foldl' TH.AppT (TH.ConT (TH.tupleTypeName n)) $
107+ (\k -> TH.ConT ''Tagged `TH.AppT`
108+ TH.VarT (tagName k) `TH.AppT`
109+ TH.VarT (varName k)) <$> [0..n-1]
110+ tagsList = List.foldr
111+ (\a b -> TH.PromotedConsT `TH.AppT` a `TH.AppT` b)
112+ TH.PromotedNilT
113+ (TH.AppT (TH.ConT ''KindOf) . TH.VarT . tagName <$> [0..n-1])
114+ return $
115+ TH.TySynInstD ''TagsK (TH.TySynEqn [tupTy] tagsList)
97116
98117return []
99118
100119type instance Tags () = 'HNil
101120type instance Tags (Tagged t a) = 'HCons t 'HNil
102−type instance Tags (Tagged t0 a, Tagged t1 b) = 'HCons t0 ('HCons t1 'HNil)
103121
104122do
105123 let
106124 tupCount = 62
107− names = [1..] >>= flip replicateM ['a'..'z']
108− varNames <- traverse TH.newName (take tupCount names)
109− fmap List.concat $
110− for (List.drop 2 (List.inits varNames)) $
111− \varNames' -> do
112− let n = List.length varNames'
113− tagsInstances <- for [() | n > 2] $ \() -> do
114− tag <- TH.newName "tag"
115− let
116− (cur:rest) = varNames'
117− tupTy = foldl TH.AppT (TH.ConT (TH.tupleTypeName n))
118− ( TH.ConT ''Tagged `TH.AppT` TH.VarT tag `TH.AppT` TH.VarT cur :
119− map TH.VarT rest )
120− tupTy' = foldl TH.AppT (TH.ConT (TH.tupleTypeName (n-1)))
121− (map TH.VarT rest)
122− return $
123− TH.TySynInstD ''TagsK (TH.TySynEqn [tupTy]
124− ( TH.PromotedConsT `TH.AppT` (TH.ConT ''KindOf `TH.AppT` TH.VarT tag) `TH.AppT`
125− (TH.ConT ''TagsK `TH.AppT` tupTy') ))
126− return tagsInstances
125+ varName k = TH.mkName ('a' : show k)
126+ tagName k = TH.mkName ('t' : show k)
127+ for [2..tupCount] $ \n -> do
128+ let
129+ tupTy = List.foldl' TH.AppT (TH.ConT (TH.tupleTypeName n)) $
130+ (\k -> TH.ConT ''Tagged `TH.AppT`
131+ TH.VarT (tagName k) `TH.AppT`
132+ TH.VarT (varName k)) <$> [0..n-1]
133+ tagsList = List.foldr
134+ (\a b -> TH.PromotedT 'HCons `TH.AppT` a `TH.AppT` b)
135+ (TH.PromotedT 'HNil)
136+ (TH.VarT . tagName <$> [0..n-1])
137+ return $
138+ TH.TySynInstD ''Tags (TH.TySynEqn [tupTy] tagsList)
139+
127140do
128141 let
129142 tupCount = 62
130− names = [1..] >>= flip replicateM ['a'..'z']
131− varNames <- traverse TH.newName (take tupCount names)
143+ varName k = TH.mkName ('a' : show k)
132144 fmap List.concat $
133− for (List.drop 2 (List.inits varNames)) $
134− \varNames' -> do
135− let n = List.length varNames'
136− tagsInstances <- for [() | n > 2] $ \() -> do
137− tag <- TH.newName "tag"
138− let
139− (cur:rest) = varNames'
140− tupTy = foldl TH.AppT (TH.ConT (TH.tupleTypeName n))
141− ( TH.ConT ''Tagged `TH.AppT` TH.VarT tag `TH.AppT` TH.VarT cur :
142− map TH.VarT rest )
143− tupTy' = foldl TH.AppT (TH.ConT (TH.tupleTypeName (n-1)))
144− (map TH.VarT rest)
145− tagsInst =
146− TH.TySynInstD ''Tags (TH.TySynEqn [tupTy]
147− ( TH.PromotedT 'HCons `TH.AppT` TH.VarT tag `TH.AppT`
148− (TH.ConT ''Tags `TH.AppT` tupTy') ))
149− return tagsInst
150− hasLensInstances <- for [0..n-1] $ \k -> do
151− tag <- TH.newName "tag"
152− let
153− (prev, cur:next) = List.splitAt k varNames'
154− tupTy = foldl TH.AppT (TH.ConT (TH.tupleTypeName n))
155− ( map TH.VarT prev ++
156− [TH.ConT ''Tagged `TH.AppT` TH.VarT tag `TH.AppT` TH.VarT cur] ++
157− map TH.VarT next )
158− cur' <- TH.newName "x"
159− f <- TH.newName "f"
160− return $
161− TH.InstanceD Nothing []
162− (TH.ConT ''HasLens `TH.AppT` TH.VarT tag `TH.AppT` tupTy `TH.AppT` TH.VarT cur)
163− [ TH.FunD 'lensOf
164− [ TH.Clause
165− [TH.VarP f, TH.TupP
166− ( map TH.VarP prev ++
167− [TH.ConP 'Tagged [TH.VarP cur]] ++
168− map TH.VarP next )]
169− (TH.NormalB $
170− TH.VarE 'fmap `TH.AppE`
171− (TH.LamE [TH.VarP cur']
172− (TH.TupE
173− ( map TH.VarE prev ++
174− [TH.ConE 'Tagged `TH.AppE` TH.VarE cur'] ++
175− map TH.VarE next ))) `TH.AppE`
176− (TH.VarE f `TH.AppE` TH.VarE cur) )
177− [] ],
178− TH.PragmaD (TH.InlineP 'lensOf TH.Inline TH.FunLike TH.AllPhases) ]
179− return $ tagsInstances ++ hasLensInstances
145+ for [2..tupCount] $ \n ->
146+ for [0..n-1] $ \k -> do
147+ let
148+ tag = TH.mkName "tag"
149+ prev = varName <$> [0..k-1]
150+ cur = varName k
151+ next = varName <$> [k+1..n-1]
152+ tupTy = foldl TH.AppT (TH.ConT (TH.tupleTypeName n))
153+ ( map TH.VarT prev ++
154+ [TH.ConT ''Tagged `TH.AppT` TH.VarT tag `TH.AppT` TH.VarT cur] ++
155+ map TH.VarT next )
156+ let
157+ cur' = TH.mkName "x"
158+ f = TH.mkName "f"
159+ return $
160+ TH.InstanceD Nothing []
161+ (TH.ConT ''HasLens `TH.AppT` TH.VarT tag `TH.AppT` tupTy `TH.AppT` TH.VarT cur)
162+ [ TH.FunD 'lensOf
163+ [ TH.Clause
164+ [TH.VarP f, TH.TupP
165+ ( map TH.VarP prev ++
166+ [TH.ConP 'Tagged [TH.VarP cur]] ++
167+ map TH.VarP next )]
168+ (TH.NormalB $
169+ TH.VarE 'fmap `TH.AppE`
170+ (TH.LamE [TH.VarP cur']
171+ (TH.TupE
172+ ( map TH.VarE prev ++
173+ [TH.ConE 'Tagged `TH.AppE` TH.VarE cur'] ++
174+ map TH.VarE next ))) `TH.AppE`
175+ (TH.VarE f `TH.AppE` TH.VarE cur) )
176+ [] ],
177+ TH.PragmaD (TH.InlineP 'lensOf TH.Inline TH.FunLike TH.AllPhases) ]