module Ether.Internal.TH_TupleInstances
( makeTupleInstancesTagsK
, makeTupleInstancesTags
, makeTupleInstancesHasLens
) where
import Data.Tagged
import Data.Traversable
import Data.List as List
import qualified Language.Haskell.TH as TH
import Ether.Internal.HasLens
import Ether.Internal.Tags
import Ether.Internal.TH_Utils
makeTupleInstancesTagsK :: TH.DecsQ
makeTupleInstancesTagsK = do
for [2..tupCount] $ \n -> do
let
tupTy = List.foldl' TH.AppT (TH.ConT (TH.tupleTypeName n)) $
(\k -> TH.ConT ''Tagged `TH.AppT`
TH.VarT (tagName k) `TH.AppT`
TH.VarT (varName k)) <$> [0..n1]
tagsList = List.foldr
(\a b -> TH.PromotedConsT `TH.AppT` a `TH.AppT` b)
TH.PromotedNilT
(TH.AppT (TH.ConT ''KindOf) . TH.VarT . tagName <$> [0..n1])
return $
TH.TySynInstD ''TagsK (TH.TySynEqn [tupTy] tagsList)
makeTupleInstancesTags :: TH.DecsQ
makeTupleInstancesTags = do
for [2..tupCount] $ \n -> do
let
tupTy = List.foldl' TH.AppT (TH.ConT (TH.tupleTypeName n)) $
(\k -> TH.ConT ''Tagged `TH.AppT`
TH.VarT (tagName k) `TH.AppT`
TH.VarT (varName k)) <$> [0..n1]
tagsList = List.foldr
(\a b -> TH.PromotedT 'HCons `TH.AppT` a `TH.AppT` b)
(TH.PromotedT 'HNil)
(TH.VarT . tagName <$> [0..n1])
return $
TH.TySynInstD ''Tags (TH.TySynEqn [tupTy] tagsList)
makeTupleInstancesHasLens :: [Int] -> TH.DecsQ
makeTupleInstancesHasLens range = List.concat <$> do
for range $ \n ->
for [0..n1] $ \k -> do
let
tag = TH.mkName "tag"
prev = varName <$> [0..k1]
cur = varName k
next = varName <$> [k+1..n1]
tupTy = foldl TH.AppT (TH.ConT (TH.tupleTypeName n))
( map TH.VarT prev ++
[TH.ConT ''Tagged `TH.AppT` TH.VarT tag `TH.AppT` TH.VarT cur] ++
map TH.VarT next )
let
cur' = TH.mkName "x"
f = TH.mkName "f"
return $
TH.InstanceD Nothing []
(TH.ConT ''HasLens `TH.AppT` TH.VarT tag `TH.AppT` tupTy `TH.AppT` TH.VarT cur)
[ TH.FunD 'lensOf
[ TH.Clause
[TH.VarP f, TH.TupP
( map TH.VarP prev ++
[TH.ConP 'Tagged [TH.VarP cur]] ++
map TH.VarP next )]
(TH.NormalB $
TH.VarE 'fmap `TH.AppE`
(TH.LamE [TH.VarP cur']
(TH.TupE
( map TH.VarE prev ++
[TH.ConE 'Tagged `TH.AppE` TH.VarE cur'] ++
map TH.VarE next ))) `TH.AppE`
(TH.VarE f `TH.AppE` TH.VarE cur) )
[] ] ]