module Test.Target.TH where
import Control.Monad
import qualified Language.Haskell.TH as TH
type Error = forall a. String -> a
monomorphic :: TH.Name -> TH.ExpQ
monomorphic t = do
ty0 <- fmap infoType (TH.reify t)
let err msg = error $ msg ++ ": " ++ TH.pprint ty0
(polys, ctx, ty) <- deconstructType err ty0
case polys of
[] -> return (TH.VarE t)
_ -> do
integer <- [t| Integer |]
ty' <- monomorphiseType err integer ty
return (TH.SigE (TH.VarE t) ty')
infoType :: TH.Info -> TH.Type
infoType (TH.ClassOpI _ ty _ _) = ty
infoType (TH.DataConI _ ty _ _) = ty
infoType (TH.VarI _ ty _ _) = ty
deconstructType :: Error -> TH.Type -> TH.Q ([TH.Name], TH.Cxt, TH.Type)
deconstructType err ty0@(TH.ForallT xs ctx ty) = do
let plain (TH.PlainTV _) = True
plain _ = False
unless (all plain xs) $ err "Higher-kinded type variables in type"
return (map (\(TH.PlainTV x) -> x) xs, ctx, ty)
deconstructType _ ty = return ([], [], ty)
monomorphiseType :: Error -> TH.Type -> TH.Type -> TH.TypeQ
monomorphiseType err mono ty@(TH.VarT n) = return mono
monomorphiseType err mono (TH.AppT t1 t2) = liftM2 TH.AppT (monomorphiseType err mono t1) (monomorphiseType err mono t2)
monomorphiseType err mono ty@(TH.ForallT _ _ _) = err $ "Higher-ranked type"
monomorphiseType err mono ty = return ty