; let doc = ptext (sLit "In the spliced type") <+> ppr hs_ty2
; hs_ty3 <- checkNoErrs (rnLHsType doc hs_ty2)
- ; kcHsType hs_ty3 }
+ ; kcLHsType hs_ty3 }
\end{code}
%************************************************************************
; rdr_env <- getLocalRdrEnv
; case lookupLocalRdrEnv rdr_env rdr_name of
Just name -> return (Just name)
- Nothing | not (isSrcRdrName rdr_name) -- Exact, Orig
- -> do { name <- lookupImportedName rdr_name
- ; return (Just name) }
- | otherwise -- Unqual, Qual
- -> lookupSrcOcc_maybe rdr_name }
+ Nothing -> lookupGlobalOccRn_maybe rdr_name }
tcLookupTh :: Name -> TcM TcTyThing
-- This is a specialised version of TcEnv.tcLookup; specialised mainly in that
= do { ty <- reifyType (idType id)
; fix <- reifyFixity (idName id)
; let v = reifyName id
- ; case globalIdDetails id of
+ ; case idDetails id of
ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls) fix)
_ -> return (TH.VarI v ty Nothing fix)
}
= do { let name = dataConName dc
; ty <- reifyType (idType (dataConWrapId dc))
; fix <- reifyFixity name
- ; return (TH.DataConI (reifyName name) ty (reifyName (dataConTyCon dc)) fix) }
+ ; return (TH.DataConI (reifyName name) ty
+ (reifyName (dataConOrigTyCon dc)) fix)
+ }
reifyThing (ATcId {tct_id = id, tct_type = ty})
= do { ty1 <- zonkTcType ty -- Make use of all the info we have, even
------------------------------
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))
+ | isFunTyCon tc
+ = return (TH.PrimTyConI (reifyName tc) 2 False)
+ | isPrimTyCon tc
+ = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc))
+ | isOpenTyCon tc
+ = let flavour = reifyFamFlavour tc
+ tvs = tyConTyVars tc
+ in
+ return (TH.TyConI $
+ TH.FamilyD flavour (reifyName tc) (reifyTyVars tvs))
| isSynTyCon tc
= do { let (tvs, rhs) = synTyConDefn tc
; rhs' <- reifyType rhs
; return (TH.TyConI $
- TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') }
+ TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs')
+ }
reifyTyCon tc
= do { cxt <- reifyCxt (tyConStupidTheta tc)
r_tvs = reifyTyVars tvs
deriv = [] -- Don't know about deriving
decl | isNewTyCon tc = TH.NewtypeD cxt name r_tvs (head cons) deriv
- | otherwise = TH.DataD cxt name r_tvs cons deriv
+ | otherwise = TH.DataD cxt name r_tvs cons deriv
; return (TH.TyConI decl) }
reifyDataCon :: [Type] -> DataCon -> TcM TH.Con
else
return (TH.NormalC name (stricts `zip` arg_tys)) }
| otherwise
- = failWithTc (ptext (sLit "Can't reify a non-Haskell-98 data constructor:")
+ = failWithTc (ptext (sLit "Can't reify a GADT data constructor:")
<+> quotes (ppr dc))
------------------------------
reifyTypes :: [Type] -> TcM [TH.Type]
reifyTypes = mapM reifyType
-reifyCxt :: [PredType] -> TcM [TH.Type]
+
+reifyCxt :: [PredType] -> TcM [TH.Pred]
reifyCxt = mapM reifyPred
reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep
reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys)
+reifyFamFlavour :: TyCon -> TH.FamFlavour
+reifyFamFlavour tc | isOpenSynTyCon tc = TH.TypeFam
+ | isOpenTyCon tc = TH.DataFam
+ | otherwise
+ = panic "TcSplice.reifyFamFlavour: not a type family"
+
reifyTyVars :: [TyVar] -> [TH.Name]
reifyTyVars = map reifyName
reify_tc_app tc tys = do { tys' <- reifyTypes tys
; return (foldl TH.AppT (TH.ConT tc) tys') }
-reifyPred :: TypeRep.PredType -> TcM TH.Type
-reifyPred (ClassP cls tys) = reify_tc_app (reifyName cls) tys
+reifyPred :: TypeRep.PredType -> TcM TH.Pred
+reifyPred (ClassP cls tys)
+ = do { tys' <- reifyTypes tys
+ ; return $ TH.ClassP (reifyName cls) tys'
+ }
reifyPred p@(IParam _ _) = noTH (sLit "implicit parameters") (ppr p)
-reifyPred (EqPred {}) = panic "reifyPred EqPred"
+reifyPred (EqPred ty1 ty2)
+ = do { ty1' <- reifyType ty1
+ ; ty2' <- reifyType ty2
+ ; return $ TH.EqualP ty1' ty2'
+ }
------------------------------