X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSplice.lhs;h=650c0b40dad6b2889f3bcd005f087fe898ec5384;hb=5479f1a02fae9141c02a7873c57af80323b0fc0d;hp=a1411d2a2b7e43a3b5097ee4c574d0880dac9271;hpb=af0a8d54223ffaa965fc419c88a11877266d5bf0;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index a1411d2..650c0b4 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -6,7 +6,7 @@ TcSplice: Template Haskell splices \begin{code} -{-# OPTIONS -w #-} +{-# OPTIONS -fno-warn-unused-imports -fno-warn-unused-binds #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and fix -- any warnings in the module. See @@ -14,7 +14,8 @@ TcSplice: Template Haskell splices -- for details module TcSplice( tcSpliceExpr, tcSpliceDecls, tcBracket, - runQuasiQuoteExpr, runQuasiQuotePat ) where + lookupThName_maybe, + runQuasiQuoteExpr, runQuasiQuotePat, runAnnotation ) where #include "HsVersions.h" @@ -41,13 +42,15 @@ import TcIface import TypeRep import Name import NameEnv +import PrelNames import HscTypes import OccName import Var import Module +import Annotations import TcRnMonad -import IfaceEnv import Class +import Inst import TyCon import DataCon import Id @@ -56,24 +59,28 @@ import TysWiredIn import DsMeta import DsExpr import DsMonad hiding (Splice) +import Serialized import ErrUtils import SrcLoc import Outputable import Unique -import DynFlags -import PackageConfig import Maybe import BasicTypes import Panic import FastString +import Exception import qualified Language.Haskell.TH as TH -- THSyntax gives access to internal functions and data types import qualified Language.Haskell.TH.Syntax as TH +#ifdef GHCI +-- Because GHC.Desugar might not be in the base library of the bootstrapping compiler +import GHC.Desugar ( AnnotationWrapper(..) ) +#endif + import GHC.Exts ( unsafeCoerce#, Int#, Int(..) ) -import Control.Monad ( liftM ) -import qualified Control.Exception as Exception( userErrors ) +import System.IO.Error \end{code} Note [Template Haskell levels] @@ -161,20 +168,29 @@ The predicate we use is TcEnv.thTopLevelId. %************************************************************************ \begin{code} +tcBracket :: HsBracket Name -> BoxyRhoType -> TcM (LHsExpr TcId) tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName] tcSpliceExpr :: HsSplice Name -> BoxyRhoType -> TcM (HsExpr TcId) kcSpliceType :: HsSplice Name -> TcM (HsType Name, TcKind) -- None of these functions add constraints to the LIE +lookupThName_maybe :: TH.Name -> TcM (Maybe Name) + runQuasiQuoteExpr :: HsQuasiQuote Name -> TcM (LHsExpr RdrName) runQuasiQuotePat :: HsQuasiQuote Name -> TcM (LPat RdrName) +runAnnotation :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation #ifndef GHCI -tcSpliceExpr n e ty = pprPanic "Cant do tcSpliceExpr without GHCi" (ppr e) -tcSpliceDecls e = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr e) +tcBracket x _ = pprPanic "Cant do tcBracket without GHCi" (ppr x) +tcSpliceExpr e = pprPanic "Cant do tcSpliceExpr without GHCi" (ppr e) +tcSpliceDecls x = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr x) +kcSpliceType x = pprPanic "Cant do kcSpliceType without GHCi" (ppr x) + +lookupThName_maybe n = pprPanic "Cant do lookupThName_maybe without GHCi" (ppr n) -runQuasiQuoteExpr q = pprPanic "Cant do runQuasiQuoteExpr without GHCi" (ppr q) -runQuasiQuotePat q = pprPanic "Cant do runQuasiQuotePat without GHCi" (ppr q) +runQuasiQuoteExpr q = pprPanic "Cant do runQuasiQuoteExpr without GHCi" (ppr q) +runQuasiQuotePat q = pprPanic "Cant do runQuasiQuotePat without GHCi" (ppr q) +runAnnotation _ q = pprPanic "Cant do runAnnotation without GHCi" (ppr q) #else \end{code} @@ -197,7 +213,6 @@ Desugared: f = do { s7 <- g Int 3 ; return (ConE "Data.Maybe.Just" s7) } \begin{code} -tcBracket :: HsBracket Name -> BoxyRhoType -> TcM (LHsExpr TcId) tcBracket brack res_ty = do level <- getStage case bracketOK level of { @@ -234,23 +249,23 @@ tc_bracket use_lvl (VarBr name) -- Note [Quoting names] | otherwise -> do { checkTc (use_lvl == bind_lvl) (quotedNameStageErr name) } - other -> pprPanic "th_bracket" (ppr name) + _ -> pprPanic "th_bracket" (ppr name) ; tcMetaTy nameTyConName -- Result type is Var (not Q-monadic) } -tc_bracket use_lvl (ExpBr expr) +tc_bracket _ (ExpBr expr) = do { any_ty <- newFlexiTyVarTy liftedTypeKind ; tcMonoExpr expr any_ty ; tcMetaTy expQTyConName } -- Result type is Expr (= Q Exp) -tc_bracket use_lvl (TypBr typ) +tc_bracket _ (TypBr typ) = do { tcHsSigType ExprSigCtxt typ ; tcMetaTy typeQTyConName } -- Result type is Type (= Q Typ) -tc_bracket use_lvl (DecBr decls) +tc_bracket _ (DecBr decls) = do { tcTopSrcDecls emptyModDetails decls -- Typecheck the declarations, dicarding the result -- We'll get all that stuff later, when we splice it in @@ -261,9 +276,10 @@ tc_bracket use_lvl (DecBr decls) -- Result type is Q [Dec] } -tc_bracket use_lvl (PatBr _) +tc_bracket _ (PatBr _) = failWithTc (ptext (sLit "Tempate Haskell pattern brackets are not supported yet")) +quotedNameStageErr :: Name -> SDoc quotedNameStageErr v = sep [ ptext (sLit "Stage error: the non-top-level quoted name") <+> ppr (VarBr v) , ptext (sLit "must be used at the same stage at which is is bound")] @@ -285,7 +301,7 @@ tcSpliceExpr (HsSplice name expr) res_ty Just next_level -> case level of { - Comp -> do { e <- tcTopSplice expr res_ty + Comp _ -> do { e <- tcTopSplice expr res_ty ; return (unLoc e) } ; Brack _ ps_var lie_var -> do @@ -307,6 +323,8 @@ tcSpliceExpr (HsSplice name expr) res_ty writeMutVar ps_var ((name,expr') : ps) return (panic "tcSpliceExpr") -- The returned expression is ignored + + ; Splice {} -> panic "tcSpliceExpr Splice" }} -- tcTopSplice used to have this: @@ -334,7 +352,7 @@ tcTopSplice expr res_ty = do -- Rename it, but bale out if there are errors -- otherwise the type checker just gives more spurious errors - (exp3, fvs) <- checkNoErrs (rnLExpr expr2) + (exp3, _fvs) <- checkNoErrs (rnLExpr expr2) tcMonoExpr exp3 res_ty @@ -342,23 +360,73 @@ tcTopSplice expr res_ty = do tcTopSpliceExpr :: LHsExpr Name -> TcType -> TcM (LHsExpr Id) -- Type check an expression that is the body of a top-level splice -- (the caller will compile and run it) -tcTopSpliceExpr expr meta_ty - = checkNoErrs $ -- checkNoErrs: must not try to run the thing - -- if the type checker fails! +tcTopSpliceExpr expr meta_ty + = checkNoErrs $ -- checkNoErrs: must not try to run the thing + -- if the type checker fails! + do { (expr', const_binds) <- tcSimplifyStagedExpr topSpliceStage $ + (recordThUse >> tcMonoExpr expr meta_ty) + -- Zonk it and tie the knot of dictionary bindings + ; zonkTopLExpr (mkHsDictLet const_binds expr') } +\end{code} - setStage topSpliceStage $ do - - do { recordThUse -- Record that TH is used (for pkg depdendency) +%************************************************************************ +%* * + Annotations +%* * +%************************************************************************ - -- Typecheck the expression - ; (expr', lie) <- getLIE (tcMonoExpr expr meta_ty) - - -- Solve the constraints - ; const_binds <- tcSimplifyTop lie - - -- And zonk it - ; zonkTopLExpr (mkHsDictLet const_binds expr') } +\begin{code} +runAnnotation target expr = do + expr_ty <- newFlexiTyVarTy liftedTypeKind + + -- Find the classes we want instances for in order to call toAnnotationWrapper + data_class <- tcLookupClass dataClassName + + -- Check the instances we require live in another module (we want to execute it..) + -- and check identifiers live in other modules using TH stage checks. tcSimplifyStagedExpr + -- also resolves the LIE constraints to detect e.g. instance ambiguity + ((wrapper, expr'), const_binds) <- tcSimplifyStagedExpr topAnnStage $ do + expr' <- tcPolyExprNC expr expr_ty + -- By instantiating the call >here< it gets registered in the + -- LIE consulted by tcSimplifyStagedExpr + -- and hence ensures the appropriate dictionary is bound by const_binds + wrapper <- instCall AnnOrigin [expr_ty] [mkClassPred data_class [expr_ty]] + return (wrapper, expr') + + -- We manually wrap the typechecked expression in a call to toAnnotationWrapper + loc <- getSrcSpanM + to_annotation_wrapper_id <- tcLookupId toAnnotationWrapperName + let specialised_to_annotation_wrapper_expr = L loc (HsWrap wrapper (HsVar to_annotation_wrapper_id)) + wrapped_expr' = mkHsDictLet const_binds $ + L loc (HsApp specialised_to_annotation_wrapper_expr expr') + + -- If we have type checking problems then potentially zonking + -- (and certainly compilation) may fail. Give up NOW! + failIfErrsM + + -- Zonk the type variables out of that raw expression. Note that + -- in particular we don't call recordThUse, since we don't + -- necessarily use any code or definitions from that package. + zonked_wrapped_expr' <- zonkTopLExpr wrapped_expr' + + -- Run the appropriately wrapped expression to get the value of + -- the annotation and its dictionaries. The return value is of + -- type AnnotationWrapper by construction, so this conversion is + -- safe + flip runMetaAW zonked_wrapped_expr' $ \annotation_wrapper -> + case annotation_wrapper of + AnnotationWrapper value | let serialized = toSerialized serializeWithData value -> + -- Got the value and dictionaries: build the serialized value and + -- call it a day. We ensure that we seq the entire serialized value + -- in order that any errors in the user-written code for the + -- annotation are exposed at this point. This is also why we are + -- doing all this stuff inside the context of runMeta: it has the + -- facilities to deal with user error in a meta-level expression + seqSerialized serialized `seq` Annotation { + ann_target = target, + ann_value = serialized + } \end{code} @@ -393,7 +461,7 @@ runQuasiQuote :: Outputable hs_syn -> Name -- Name of th_syn type -> (SrcSpan -> th_syn -> Either Message hs_syn) -> TcM hs_syn -runQuasiQuote (HsQuasiQuote name quoter q_span quote) quote_selector desc meta_ty convert +runQuasiQuote (HsQuasiQuote _name quoter q_span quote) quote_selector desc meta_ty convert = do { -- Check that the quoter is not locally defined, otherwise the TH -- machinery will not be able to run the quasiquote. ; this_mod <- getModule @@ -418,7 +486,7 @@ runQuasiQuote (HsQuasiQuote name quoter q_span quote) quote_selector desc meta_t -- Run the expression ; traceTc (text "About to run" <+> ppr zonked_q_expr) - ; result <- runMeta convert zonked_q_expr + ; result <- runMetaQ convert zonked_q_expr ; traceTc (text "Got result" <+> ppr result) ; showSplice desc zonked_q_expr (ppr result) ; return result @@ -430,6 +498,7 @@ runQuasiQuoteExpr quasiquote runQuasiQuotePat quasiquote = runQuasiQuote quasiquote quotePatName "pattern" patQTyConName convertToPat +quoteStageError :: Name -> SDoc quoteStageError quoter = sep [ptext (sLit "GHC stage restriction:") <+> ppr quoter, nest 2 (ptext (sLit "is used in a quasiquote, and must be imported, not defined locally"))] @@ -453,7 +522,7 @@ kcSpliceType (HsSplice name hs_expr) Just next_level -> do { case level of { - Comp -> do { (t,k) <- kcTopSpliceType hs_expr + Comp _ -> do { (t,k) <- kcTopSpliceType hs_expr ; return (unLoc t, k) } ; Brack _ ps_var lie_var -> do @@ -472,7 +541,9 @@ kcSpliceType (HsSplice name hs_expr) -- but $(h 4) :: forall a.a i.e. any kind ; kind <- newKindVar ; return (panic "kcSpliceType", kind) -- The returned type is ignored - }}}}} + } + ; Splice {} -> panic "kcSpliceType Splice" + }}}} kcTopSpliceType :: LHsExpr Name -> TcM (LHsType Name, TcKind) kcTopSpliceType expr @@ -494,7 +565,7 @@ kcTopSpliceType expr ; 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} %************************************************************************ @@ -522,12 +593,6 @@ tcSpliceDecls expr zonked_q_expr (ppr (getLoc expr) $$ (vcat (map ppr decls))) ; return decls } - - where handleErrors :: [Either a Message] -> TcM [a] - handleErrors [] = return [] - handleErrors (Left x:xs) = liftM (x:) (handleErrors xs) - handleErrors (Right m:xs) = do addErrTc m - handleErrors xs \end{code} @@ -538,30 +603,49 @@ tcSpliceDecls expr %************************************************************************ \begin{code} +runMetaAW :: (AnnotationWrapper -> output) + -> LHsExpr Id -- Of type AnnotationWrapper + -> TcM output +runMetaAW k = runMeta False (\_ -> return . Right . k) + -- We turn off showing the code in meta-level exceptions because doing so exposes + -- the toAnnotationWrapper function that we slap around the users code + +runQThen :: (SrcSpan -> input -> Either Message output) + -> SrcSpan + -> TH.Q input + -> TcM (Either Message output) +runQThen f expr_span what = TH.runQ what >>= (return . f expr_span) + +runMetaQ :: (SrcSpan -> input -> Either Message output) + -> LHsExpr Id + -> TcM output +runMetaQ = runMeta True . runQThen + runMetaE :: (SrcSpan -> TH.Exp -> Either Message (LHsExpr RdrName)) -> LHsExpr Id -- Of type (Q Exp) -> TcM (LHsExpr RdrName) -runMetaE = runMeta +runMetaE = runMetaQ runMetaP :: (SrcSpan -> TH.Pat -> Either Message (Pat RdrName)) -> LHsExpr Id -- Of type (Q Pat) -> TcM (Pat RdrName) -runMetaP = runMeta +runMetaP = runMetaQ runMetaT :: (SrcSpan -> TH.Type -> Either Message (LHsType RdrName)) -> LHsExpr Id -- Of type (Q Type) -> TcM (LHsType RdrName) -runMetaT = runMeta +runMetaT = runMetaQ runMetaD :: (SrcSpan -> [TH.Dec] -> Either Message [LHsDecl RdrName]) -> LHsExpr Id -- Of type Q [Dec] -> TcM [LHsDecl RdrName] -runMetaD = runMeta +runMetaD = runMetaQ -runMeta :: (SrcSpan -> th_syn -> Either Message hs_syn) +runMeta :: Bool -- Whether code should be printed in the exception message + -> (SrcSpan -> input -> TcM (Either Message output)) -> LHsExpr Id -- Of type X - -> TcM hs_syn -- Of type t -runMeta convert expr + -> TcM output -- Of type t +runMeta show_code run_and_convert expr = do { -- Desugar ds_expr <- initDsTc (dsLExpr expr) -- Compile and link it; might fail if linking fails @@ -588,22 +672,23 @@ runMeta convert expr ; either_tval <- tryAllM $ setSrcSpan expr_span $ -- Set the span so that qLocation can -- see where this splice is - do { th_syn <- TH.runQ (unsafeCoerce# hval) - ; case convert expr_span th_syn of + do { mb_result <- run_and_convert expr_span (unsafeCoerce# hval) + ; case mb_result of Left err -> failWithTc err - Right hs_syn -> return hs_syn } + Right result -> return $! result } ; case either_tval of Right v -> return v - Left exn | Just s <- Exception.userErrors exn - , s == "IOEnv failure" - -> failM -- Error already in Tc monad - | otherwise -> failWithTc (mk_msg "run" exn) -- Exception + Left se -> + case fromException se of + Just IOEnvFailure -> + failM -- Error already in Tc monad + _ -> failWithTc (mk_msg "run" se) -- Exception }}} where mk_msg s exn = vcat [text "Exception when trying to" <+> text s <+> text "compile-time code:", nest 2 (text (Panic.showException exn)), - nest 2 (text "Code:" <+> ppr expr)] + if show_code then nest 2 (text "Code:" <+> ppr expr) else empty] \end{code} Note [Exceptions in TH] @@ -627,11 +712,10 @@ like that. Here's how it's processed: * The TcM monad is an instance of Quasi (see TcSplice), and it implements (qReport True s) by using addErr to add an error message to the bag of errors. - The 'fail' in TcM raises a UserError, with the uninteresting string - "IOEnv failure" + The 'fail' in TcM raises an IOEnvFailure exception * So, when running a splice, we catch all exceptions; then for - - a UserError "IOEnv failure", we assume the error is already + - an IOEnvFailure exception, we assume the error is already in the error-bag (above) - other errors, we add an error to the bag and then fail @@ -687,9 +771,11 @@ showSplice what before after = do text "======>", nest 2 after])]) +illegalBracket :: ThStage -> SDoc illegalBracket level = ptext (sLit "Illegal bracket at level") <+> ppr level +illegalSplice :: ThStage -> SDoc illegalSplice level = ptext (sLit "Illegal splice at level") <+> ppr level @@ -718,29 +804,28 @@ reify th_name ppr_ns (TH.Name _ (TH.NameG TH.DataName _pkg _mod)) = text "data" ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc" ppr_ns (TH.Name _ (TH.NameG TH.VarName _pkg _mod)) = text "var" + ppr_ns _ = panic "reify/ppr_ns" lookupThName :: TH.Name -> TcM Name -lookupThName th_name@(TH.Name occ flavour) - = do { let rdr_name = thRdrName guessed_ns occ_str flavour - - -- Repeat much of lookupOccRn, becase we want - -- to report errors in a TH-relevant way - ; rdr_env <- getLocalRdrEnv - ; case lookupLocalRdrEnv rdr_env rdr_name of - Just name -> return name - Nothing | not (isSrcRdrName rdr_name) -- Exact, Orig - -> lookupImportedName rdr_name - | otherwise -- Unqual, Qual - -> do { mb_name <- lookupSrcOcc_maybe rdr_name - ; case mb_name of - Just name -> return name - Nothing -> failWithTc (notInScope th_name) } - } +lookupThName th_name = do + mb_name <- lookupThName_maybe th_name + case mb_name of + Nothing -> failWithTc (notInScope th_name) + Just name -> return name + +lookupThName_maybe th_name + = do { names <- mapMaybeM lookup (thRdrNameGuesses th_name) + -- Pick the first that works + -- E.g. reify (mkName "A") will pick the class A in preference to the data constructor A + ; return (listToMaybe names) } where - -- guessed_ns is the name space guessed from looking at the TH name - guessed_ns | isLexCon (mkFastString occ_str) = OccName.dataName - | otherwise = OccName.varName - occ_str = TH.occString occ + lookup rdr_name + = do { -- Repeat much of lookupOccRn, becase we want + -- to report errors in a TH-relevant way + ; rdr_env <- getLocalRdrEnv + ; case lookupLocalRdrEnv rdr_env rdr_name of + Just name -> return (Just name) + Nothing -> lookupGlobalOccRn_maybe rdr_name } tcLookupTh :: Name -> TcM TcTyThing -- This is a specialised version of TcEnv.tcLookup; specialised mainly in that @@ -787,9 +872,9 @@ reifyThing (AGlobal (AnId id)) = 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) - other -> return (TH.VarI v ty Nothing fix) + _ -> return (TH.VarI v ty Nothing fix) } reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc @@ -798,7 +883,9 @@ reifyThing (AGlobal (ADataCon dc)) = 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 @@ -812,16 +899,31 @@ reifyThing (ATyVar tv ty) ; ty2 <- reifyType ty1 ; return (TH.TyVarI (reifyName tv) ty2) } +reifyThing (AThing {}) = panic "reifyThing AThing" + ------------------------------ 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 + kind = tyConKind tc + kind' + | isLiftedTypeKind kind = Nothing + | otherwise = Just $ reifyKind kind + in + return (TH.TyConI $ + TH.FamilyD flavour (reifyName tc) (reifyTyVars tvs) kind') | 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) @@ -831,7 +933,7 @@ reifyTyCon 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 @@ -853,7 +955,7 @@ reifyDataCon tys dc 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)) ------------------------------ @@ -879,22 +981,59 @@ reifyType ty@(ForAllTy _ _) = do { cxt' <- reifyCxt cxt; ; return (TH.ForallT (reifyTyVars tvs) cxt' tau') } where (tvs, cxt, tau) = tcSplitSigmaTy ty +reifyType (PredTy {}) = panic "reifyType PredTy" + +reifyTypes :: [Type] -> TcM [TH.Type] reifyTypes = mapM reifyType + +reifyKind :: Kind -> TH.Kind +reifyKind ki + = let (kis, ki') = splitKindFunTys ki + kis_rep = map reifyKind kis + ki'_rep = reifyNonArrowKind ki' + in + foldl TH.ArrowK ki'_rep kis_rep + where + reifyNonArrowKind k | isLiftedTypeKind k = TH.StarK + | otherwise = pprPanic "Exotic form of kind" + (ppr k) + +reifyCxt :: [PredType] -> TcM [TH.Pred] reifyCxt = mapM reifyPred reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys) -reifyTyVars :: [TyVar] -> [TH.Name] -reifyTyVars = map reifyName +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.TyVarBndr] +reifyTyVars = map reifyTyVar + where + reifyTyVar tv | isLiftedTypeKind kind = TH.PlainTV name + | otherwise = TH.KindedTV name (reifyKind kind) + where + kind = tyVarKind tv + name = reifyName tv reify_tc_app :: TH.Name -> [TypeRep.Type] -> TcM TH.Type 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 ty1 ty2) + = do { ty1' <- reifyType ty1 + ; ty2' <- reifyType ty2 + ; return $ TH.EqualP ty1' ty2' + } ------------------------------ @@ -908,7 +1047,7 @@ reifyName thing -- have free variables, we may need to generate NameL's for them. where name = getName thing - mod = nameModule name + mod = ASSERT( isExternalName name ) nameModule name pkg_str = packageIdString (modulePackageId mod) mod_str = moduleNameString (moduleName mod) occ_str = occNameString occ