git.iko.soy/typeable/ether
on 0.5 help sign in
typeable/ether/src/Ether/Internal.hs
179 lines 5.4 kB history raw
1module Ether.Internal
2 ( Tagged(..)
3 , TagsK
4 , Tags
5 , HasLens(..)
6 , LensLike
7 , Lens
8 , Lens'
9 , ReifiedLens(..)
10 , ReifiedLens'
11 , view
12 , over
13 , HList(..)
14 , KindOf
15 , TAGGED
16 , HandleSuper
17 , HandleConstraint
18 , Handle(..)
19 ) where
21import Control.Applicative
22import Control.Monad
23import Data.Coerce
24import Data.Functor.Identity
25import Data.Kind
26import Data.List as List
27import Data.Tagged
28import Data.Traversable
29import GHC.Exts (Constraint)
30import qualified Language.Haskell.TH as TH
32data TAGGED e t
34type K_Monad = Type -> Type
36type K_Trans = K_Monad -> K_Monad
38type family
39 HandleSuper
40 (eff :: keff)
41 (p :: kp)
42 (trans :: K_Trans)
43 :: Constraint
45type family
46 HandleConstraint
47 (eff :: keff)
48 (p :: kp)
49 (trans :: K_Trans) (m :: K_Monad)
50 :: Constraint
52class
53 HandleSuper eff p trans =>
54 Handle eff p (trans :: K_Trans) | eff trans -> p
55 where
56 handling :: Monad m => (HandleConstraint eff p trans m => r) -> r
58type LensLike f s t a b = (a -> f b) -> s -> f t
60type Lens s t a b = forall f. Functor f => LensLike f s t a b
62type Lens' s a = Lens s s a a
64newtype ReifiedLens s t a b = Lens (Lens s t a b)
66type ReifiedLens' s a = ReifiedLens s s a a
68class HasLens tag outer inner | tag outer -> inner where
69 lensOf :: Lens' outer inner
71instance HasLens a a a where
72 lensOf = id
73 {-# INLINE lensOf #-}
75view :: LensLike (Const a) s t a b -> s -> a
76view l = coerce (l Const)
77{-# INLINE view #-}
79over :: LensLike Identity s t a b -> (a -> b) -> s -> t
80over = coerce
81{-# INLINE over #-}
83data HList xs where
84 HNil :: HList '[]
85 HCons :: x -> HList xs -> HList (x ': xs)
87type KindOf (a :: k) = k
89type family TagsK (p :: Type) :: [Type]
90type family Tags (p :: Type) :: HList (TagsK p)
92return []
94type instance TagsK () = '[]
95type instance TagsK (Tagged t a) = '[KindOf t]
96type instance TagsK (Tagged t0 a, Tagged t1 b) = '[KindOf t0, KindOf t1]
98return []
100type instance Tags () = 'HNil
101type instance Tags (Tagged t a) = 'HCons t 'HNil
102type instance Tags (Tagged t0 a, Tagged t1 b) = 'HCons t0 ('HCons t1 'HNil)
104do
105 let
106 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
127do
128 let
129 tupCount = 62
130 names = [1..] >>= flip replicateM ['a'..'z']
131 varNames <- traverse TH.newName (take tupCount names)
132 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