module Data.Comp.MultiParam.Derive.LiftSum
(
liftSum,
caseHD
) where
import Language.Haskell.TH hiding (Cxt)
import Data.Comp.Derive.Utils
import Data.Comp.MultiParam.Sum
import Data.Comp.MultiParam.Ops ((:+:)(..))
liftSum :: Name -> Q [Dec]
liftSum fname = do
ClassI (ClassD _ name targs _ decs) _ <- abstractNewtypeQ $ reify fname
let targs' = map tyVarBndrName $ tail targs
let f = mkName "f"
let g = mkName "g"
let cxt = [ClassP name (map VarT $ f : targs'),
ClassP name (map VarT $ g : targs')]
let tp = ConT name `AppT` ((ConT ''(:+:) `AppT` VarT f) `AppT` VarT g)
let complType = foldl (\a x -> a `AppT` VarT x) tp targs'
decs' <- sequence $ concatMap decl decs
return [InstanceD cxt complType decs']
where decl :: Dec -> [DecQ]
decl (SigD f _) = [funD f [clause f]]
decl _ = []
clause :: Name -> ClauseQ
clause f = do x <- newName "x"
b <- normalB [|caseHD $(varE f) $(varE f) $(varE x)|]
return $ Clause [VarP x] b []
caseHD :: (f a b i -> c) -> (g a b i -> c) -> (f :+: g) a b i -> c
caseHD f g x = case x of
Inl x -> f x
Inr x -> g x