import Outputable
import Util ( dropList )
import Data.List ( mapAccumL )
+import Pair
import Unique
import Data.Maybe
import BasicTypes
}
tc_bracket _ (ExpBr expr)
- = do { any_ty <- newFlexiTyVarTy liftedTypeKind
+ = do { any_ty <- newFlexiTyVarTy openTypeKind
; _ <- tcMonoExprNC expr any_ty -- NC for no context; tcBracket does that
; tcMetaTy expQTyConName }
-- Result type is ExpQ (= Q Exp)
; tcMetaTy decsQTyConName } -- Result type is Q [Dec]
tc_bracket _ (PatBr pat)
- = do { any_ty <- newFlexiTyVarTy liftedTypeKind
+ = do { any_ty <- newFlexiTyVarTy openTypeKind
; _ <- tcPat ThPatQuote pat any_ty $
return ()
; tcMetaTy patQTyConName }
_ -> return (TH.VarI v ty Nothing fix)
}
-reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc
-reifyThing (AGlobal (AClass cls)) = reifyClass cls
+reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc
+reifyThing (AGlobal (ACoAxiom ax)) = reifyAxiom ax
+reifyThing (AGlobal (AClass cls)) = reifyClass cls
reifyThing (AGlobal (ADataCon dc))
= do { let name = dataConName dc
; ty <- reifyType (idType (dataConWrapId dc))
reifyThing (AThing {}) = panic "reifyThing AThing"
------------------------------
+reifyAxiom :: CoAxiom -> TcM TH.Info
+reifyAxiom ax@(CoAxiom { co_ax_lhs = lhs, co_ax_rhs = rhs })
+ | Just (tc, args) <- tcSplitTyConApp_maybe lhs
+ = do { args' <- mapM reifyType args
+ ; rhs' <- reifyType rhs
+ ; return (TH.TyConI $ TH.TySynInstD (reifyName tc) args' rhs') }
+ | otherwise
+ = failWith (ptext (sLit "Can't reify the axiom") <+> ppr ax
+ <+> dcolon <+> pprEqPred (Pair lhs rhs))
+
reifyTyCon :: TyCon -> TcM TH.Info
reifyTyCon tc
| isFunTyCon tc
= return (TH.PrimTyConI (reifyName tc) 2 False)
+
| isPrimTyCon tc
= return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc))
+
| isFamilyTyCon tc
= let flavour = reifyFamFlavour tc
tvs = tyConTyVars tc
in
return (TH.TyConI $
TH.FamilyD flavour (reifyName tc) (reifyTyVars tvs) kind')
+
| isSynTyCon tc
= do { let (tvs, rhs) = synTyConDefn tc
; rhs' <- reifyType rhs
TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs')
}
-reifyTyCon tc
+ | otherwise
= do { cxt <- reifyCxt (tyConStupidTheta tc)
; let tvs = tyConTyVars tc
; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons tc)