X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSplice.lhs;h=bbb76a4a235a3dd4e8d6da933d515aaaf4f542f5;hb=c7fa9243867d49177c9ebc7923588488dbd3a369;hp=e0b5f3dcc9601b935ec53f6f2c21a19363b7f5bb;hpb=3517c53d8a66149dcc3f971cf0577719e99d6d70;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index e0b5f3d..bbb76a4 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -13,7 +13,7 @@ TcSplice: Template Haskell splices -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings -- for details -module TcSplice( tcSpliceExpr, tcSpliceDecls, tcBracket, +module TcSplice( kcSpliceType, tcSpliceExpr, tcSpliceDecls, tcBracket, lookupThName_maybe, runQuasiQuoteExpr, runQuasiQuotePat, runAnnotation ) where @@ -213,30 +213,31 @@ Desugared: f = do { s7 <- g Int 3 ; return (ConE "Data.Maybe.Just" s7) } \begin{code} -tcBracket brack res_ty = do - level <- getStage - case bracketOK level of { - Nothing -> failWithTc (illegalBracket level) ; - Just next_level -> do +tcBracket brack res_ty + = addErrCtxt (hang (ptext (sLit "In the Template Haskell quotation")) + 2 (ppr brack)) $ + do { level <- getStage + ; case bracketOK level of { + Nothing -> failWithTc (illegalBracket level) ; + Just next_level -> do { -- Typecheck expr to make sure it is valid, -- but throw away the results. We'll type check -- it again when we actually use it. - recordThUse - pending_splices <- newMutVar [] - lie_var <- getLIEVar + recordThUse + ; pending_splices <- newMutVar [] + ; lie_var <- getLIEVar - (meta_ty, lie) <- setStage (Brack next_level pending_splices lie_var) - (getLIE (tc_bracket next_level brack)) - tcSimplifyBracket lie + ; (meta_ty, lie) <- setStage (Brack next_level pending_splices lie_var) + (getLIE (tc_bracket next_level brack)) + ; tcSimplifyBracket lie -- Make the expected type have the right shape - boxyUnify meta_ty res_ty + ; _ <- boxyUnify meta_ty res_ty -- Return the original expression, not the type-decorated one - pendings <- readMutVar pending_splices - return (noLoc (HsBracketOut brack pendings)) - } + ; pendings <- readMutVar pending_splices + ; return (noLoc (HsBracketOut brack pendings)) }}} tc_bracket :: ThLevel -> HsBracket Name -> TcM TcType tc_bracket use_lvl (VarBr name) -- Note [Quoting names] @@ -256,17 +257,17 @@ tc_bracket use_lvl (VarBr name) -- Note [Quoting names] tc_bracket _ (ExpBr expr) = do { any_ty <- newFlexiTyVarTy liftedTypeKind - ; tcMonoExpr expr any_ty + ; _ <- tcMonoExprNC expr any_ty -- NC for no context; tcBracket does that ; tcMetaTy expQTyConName } -- Result type is Expr (= Q Exp) tc_bracket _ (TypBr typ) - = do { tcHsSigType ExprSigCtxt typ + = do { _ <- tcHsSigTypeNC ThBrackCtxt typ ; tcMetaTy typeQTyConName } -- Result type is Type (= Q Typ) tc_bracket _ (DecBr decls) - = do { tcTopSrcDecls emptyModDetails decls + = do { _ <- tcTopSrcDecls emptyModDetails decls -- Typecheck the declarations, dicarding the result -- We'll get all that stuff later, when we splice it in @@ -311,7 +312,7 @@ tcSpliceExpr (HsSplice name expr) res_ty -- Here (h 4) :: Q Exp -- but $(h 4) :: forall a.a i.e. anything! - unBox res_ty + _ <- unBox res_ty meta_exp_ty <- tcMetaTy expQTyConName expr' <- setStage (Splice next_level) ( setLIEVar lie_var $ @@ -347,8 +348,7 @@ tcTopSplice expr res_ty = do traceTc (text "Got result" <+> ppr expr2) - showSplice "expression" - zonked_q_expr (ppr expr2) + showSplice "expression" expr (ppr expr2) -- Rename it, but bale out if there are errors -- otherwise the type checker just gives more spurious errors @@ -488,7 +488,7 @@ runQuasiQuote (HsQuasiQuote _name quoter q_span quote) quote_selector desc meta_ ; traceTc (text "About to run" <+> ppr zonked_q_expr) ; result <- runMetaQ convert zonked_q_expr ; traceTc (text "Got result" <+> ppr result) - ; showSplice desc zonked_q_expr (ppr result) + ; showSplice desc quoteExpr (ppr result) ; return result } @@ -558,7 +558,7 @@ kcTopSpliceType expr ; traceTc (text "Got result" <+> ppr hs_ty2) - ; showSplice "type" zonked_q_expr (ppr hs_ty2) + ; showSplice "type" expr (ppr hs_ty2) -- Rename it, but bale out if there are errors -- otherwise the type checker just gives more spurious errors @@ -590,7 +590,7 @@ tcSpliceDecls expr ; traceTc (text "Got result" <+> vcat (map ppr decls)) ; showSplice "declarations" - zonked_q_expr + expr (ppr (getLoc expr) $$ (vcat (map ppr decls))) ; return decls } \end{code} @@ -763,13 +763,18 @@ instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where %************************************************************************ \begin{code} -showSplice :: String -> LHsExpr Id -> SDoc -> TcM () -showSplice what before after = do - loc <- getSrcSpanM - traceSplice (vcat [ppr loc <> colon <+> text "Splicing" <+> text what, - nest 2 (sep [nest 2 (ppr before), - text "======>", - nest 2 after])]) +showSplice :: String -> LHsExpr Name -> SDoc -> TcM () +-- Note that 'before' is *renamed* but not *typechecked* +-- Reason (a) less typechecking crap +-- (b) data constructors after type checking have been +-- changed to their *wrappers*, and that makes them +-- print always fully qualified +showSplice what before after + = do { loc <- getSrcSpanM + ; traceSplice (vcat [ppr loc <> colon <+> text "Splicing" <+> text what, + nest 2 (sep [nest 2 (ppr before), + text "======>", + nest 2 after])]) } illegalBracket :: ThStage -> SDoc illegalBracket level @@ -911,9 +916,13 @@ reifyTyCon 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)) + TH.FamilyD flavour (reifyName tc) (reifyTyVars tvs) kind') | isSynTyCon tc = do { let (tvs, rhs) = synTyConDefn tc ; rhs' <- reifyType rhs @@ -982,6 +991,18 @@ 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 @@ -994,8 +1015,14 @@ reifyFamFlavour tc | isOpenSynTyCon tc = TH.TypeFam | otherwise = panic "TcSplice.reifyFamFlavour: not a type family" -reifyTyVars :: [TyVar] -> [TH.Name] -reifyTyVars = map reifyName +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