b40212a · typeable/ether

19 ) where

20

21import Control.Applicative

22−import Control.Monad

23import Data.Coerce

22import Data.Coerce

24import Data.Functor.Identity

23import Data.Functor.Identity

25import Data.Kind

24import Data.Kind

72 lensOf = id

71 lensOf = id

73 {-# INLINE lensOf #-}

72 {-# INLINE lensOf #-}

74

73

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

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

76+

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

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

76view l = coerce (l Const)

78view l = coerce (l Const)

77{-# INLINE view #-}

79{-# INLINE view #-}

93

95

94type instance TagsK () = '[]

96type instance TagsK () = '[]

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

97type 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)

97

116

98return []

117return []

99

118

100type instance Tags () = 'HNil

119type instance Tags () = 'HNil

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

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

102−type instance Tags (Tagged t0 a, Tagged t1 b) = 'HCons t0 ('HCons t1 'HNil)

103

121

104do

122do

105 let

123 let

106 tupCount = 62

124 tupCount = 62

107− names = [1..] >>= flip replicateM ['a'..'z']

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

108− varNames <- traverse TH.newName (take tupCount names)

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

109− fmap List.concat $

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

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

128+ let

116− (cur:rest) = varNames'

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

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

118− ( TH.ConT ''Tagged `TH.AppT` TH.VarT tag `TH.AppT` TH.VarT cur :

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

119− map TH.VarT rest )

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

120− tupTy' = foldl TH.AppT (TH.ConT (TH.tupleTypeName (n-1)))

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)

121− (map TH.VarT rest)

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

122− return $

137+ return $

123− TH.TySynInstD ''TagsK (TH.TySynEqn [tupTy]

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

124− ( TH.PromotedConsT `TH.AppT` (TH.ConT ''KindOf `TH.AppT` TH.VarT tag) `TH.AppT`

139+

125− (TH.ConT ''TagsK `TH.AppT` tupTy') ))

126− return tagsInstances

127do

140do

128 let

141 let

129 tupCount = 62

142 tupCount = 62

130− names = [1..] >>= flip replicateM ['a'..'z']

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

131− varNames <- traverse TH.newName (take tupCount names)

132 fmap List.concat $

144 fmap List.concat $

133− for (List.drop 2 (List.inits varNames)) $

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

134− \varNames' -> do

135− let n = List.length varNames'

136− tagsInstances <- for [() | n > 2] $ \() -> do

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

147+ let

137− tag <- TH.newName "tag"

148+ tag = TH.mkName "tag"

138− let

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

139− (cur:rest) = varNames'

150+ cur = varName k

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

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

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))

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

155− ( map TH.VarT prev ++

153+ ( map TH.VarT prev ++

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

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

157− map TH.VarT next )

155+ map TH.VarT next )

156+ let

158− cur' <- TH.newName "x"

157+ cur' = TH.mkName "x"

159− f <- TH.newName "f"

158+ f = TH.mkName "f"

160− return $

159+ return $

161− TH.InstanceD Nothing []

160+ TH.InstanceD Nothing []

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

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

163− [ TH.FunD 'lensOf

162+ [ TH.FunD 'lensOf

164− [ TH.Clause

163+ [ TH.Clause

165− [TH.VarP f, TH.TupP

164+ [TH.VarP f, TH.TupP

166− ( map TH.VarP prev ++

165+ ( map TH.VarP prev ++

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

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

168− map TH.VarP next )]

167+ map TH.VarP next )]

169− (TH.NormalB $

168+ (TH.NormalB $

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

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

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

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

172− (TH.TupE

171+ (TH.TupE

173− ( map TH.VarE prev ++

172+ ( map TH.VarE prev ++

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

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

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

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

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

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

177− [] ],

176+ [] ],

178− TH.PragmaD (TH.InlineP 'lensOf TH.Inline TH.FunLike TH.AllPhases) ]

177+ TH.PragmaD (TH.InlineP 'lensOf TH.Inline TH.FunLike TH.AllPhases) ]

179− return $ tagsInstances ++ hasLensInstances