X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSplice.lhs;h=0d7ba6ab916d560b9ad7f411d8ca02f71d70211f;hp=8ee43f5add75e7c0b4ec60a776db4325ce0d46c8;hb=9ba922ee06b048774d7a82964867ff768a78126e;hpb=6f8ff0bbad3b9fa389c960ad1b5a267a1ae502f1 diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index 8ee43f5..0d7ba6a 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -44,8 +44,10 @@ import TcMType import TcHsType import TcIface import TypeRep +import InstEnv import Name import NameEnv +import NameSet import PrelNames import HscTypes import OccName @@ -67,12 +69,15 @@ import Serialized import ErrUtils import SrcLoc import Outputable +import Util ( dropList ) +import Data.List ( mapAccumL ) import Unique import Data.Maybe import BasicTypes import Panic import FastString import Exception +import Control.Monad ( when ) import qualified Language.Haskell.TH as TH -- THSyntax gives access to internal functions and data types @@ -281,10 +286,10 @@ The predicate we use is TcEnv.thTopLevelId. %************************************************************************ \begin{code} -tcBracket :: HsBracket Name -> BoxyRhoType -> TcM (LHsExpr TcId) +tcBracket :: HsBracket Name -> TcRhoType -> TcM (LHsExpr TcId) tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName] -tcSpliceExpr :: HsSplice Name -> BoxyRhoType -> TcM (HsExpr TcId) -kcSpliceType :: HsSplice Name -> TcM (HsType Name, TcKind) +tcSpliceExpr :: HsSplice Name -> TcRhoType -> TcM (HsExpr TcId) +kcSpliceType :: HsSplice Name -> FreeVars -> TcM (HsType Name, TcKind) -- None of these functions add constraints to the LIE lookupThName_maybe :: TH.Name -> TcM (Maybe Name) @@ -300,7 +305,7 @@ runAnnotation :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation 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) +kcSpliceType x fvs = pprPanic "Cant do kcSpliceType without GHCi" (ppr x) lookupThName_maybe n = pprPanic "Cant do lookupThName_maybe without GHCi" (ppr n) @@ -335,14 +340,17 @@ tcBracket brack res_ty -- but throw away the results. We'll type check -- it again when we actually use it. ; pending_splices <- newMutVar [] - ; lie_var <- getLIEVar + ; lie_var <- getConstraintVar + ; let brack_stage = Brack cur_stage pending_splices lie_var - ; (meta_ty, lie) <- setStage (Brack cur_stage pending_splices lie_var) - (getLIE (tc_bracket cur_stage brack)) - ; tcSimplifyBracket lie + ; (meta_ty, lie) <- setStage brack_stage $ + captureConstraints $ + tc_bracket cur_stage brack + + ; simplifyBracket lie -- Make the expected type have the right shape - ; _ <- boxyUnify meta_ty res_ty + ; _ <- unifyType meta_ty res_ty -- Return the original expression, not the type-decorated one ; pendings <- readMutVar pending_splices @@ -379,11 +387,15 @@ tc_bracket _ (DecBrG decls) = do { _ <- tcTopSrcDecls emptyModDetails decls -- Typecheck the declarations, dicarding the result -- We'll get all that stuff later, when we splice it in + + -- Top-level declarations in the bracket get unqualified names + -- See Note [Top-level Names in Template Haskell decl quotes] in RnNames + ; tcMetaTy decsQTyConName } -- Result type is Q [Dec] tc_bracket _ (PatBr pat) = do { any_ty <- newFlexiTyVarTy liftedTypeKind - ; _ <- tcPat ThPatQuote pat any_ty unitTy $ \_ -> + ; _ <- tcPat ThPatQuote pat any_ty $ return () ; tcMetaTy patQTyConName } -- Result type is PatQ (= Q Pat) @@ -421,10 +433,9 @@ tcSpliceExpr (HsSplice name expr) res_ty -- Here (h 4) :: Q Exp -- but $(h 4) :: forall a.a i.e. anything! - { _ <- unBox res_ty - ; meta_exp_ty <- tcMetaTy expQTyConName + { meta_exp_ty <- tcMetaTy expQTyConName ; expr' <- setStage pop_stage $ - setLIEVar lie_var $ + setConstraintVar lie_var $ tcMonoExpr expr meta_exp_ty -- Write the pending splice into the bucket @@ -434,7 +445,7 @@ tcSpliceExpr (HsSplice name expr) res_ty ; return (panic "tcSpliceExpr") -- The returned expression is ignored }}} -tcTopSplice :: LHsExpr Name -> BoxyRhoType -> TcM (HsExpr Id) +tcTopSplice :: LHsExpr Name -> TcRhoType -> TcM (HsExpr Id) -- Note [How top-level splices are handled] tcTopSplice expr res_ty = do { meta_exp_ty <- tcMetaTy expQTyConName @@ -476,13 +487,13 @@ tcTopSpliceExpr tc_action -- if the type checker fails! setStage Splice $ do { -- Typecheck the expression - (expr', lie) <- getLIE tc_action + (expr', lie) <- captureConstraints tc_action -- Solve the constraints - ; const_binds <- tcSimplifyTop lie + ; const_binds <- simplifyTop lie -- Zonk it and tie the knot of dictionary bindings - ; zonkTopLExpr (mkHsDictLet const_binds expr') } + ; zonkTopLExpr (mkHsDictLet (EvBinds const_binds) expr') } \end{code} @@ -495,7 +506,7 @@ tcTopSpliceExpr tc_action Very like splicing an expression, but we don't yet share code. \begin{code} -kcSpliceType (HsSplice name hs_expr) +kcSpliceType splice@(HsSplice name hs_expr) fvs = setSrcSpan (getLoc hs_expr) $ do { stage <- getStage ; case stage of { @@ -507,7 +518,7 @@ kcSpliceType (HsSplice name hs_expr) -- A splice inside brackets { meta_ty <- tcMetaTy typeQTyConName ; expr' <- setStage pop_level $ - setLIEVar lie_var $ + setConstraintVar lie_var $ tcMonoExpr hs_expr meta_ty -- Write the pending splice into the bucket @@ -518,11 +529,8 @@ kcSpliceType (HsSplice name hs_expr) -- Here (h 4) :: Q Type -- but $(h 4) :: a i.e. any type, of any kind - -- We return a HsSpliceTyOut, which serves to convey the kind to - -- the ensuing TcHsType.dsHsType, which makes up a non-committal - -- type variable of a suitable kind ; kind <- newKindVar - ; return (HsSpliceTyOut kind, kind) + ; return (HsSpliceTy splice fvs kind, kind) }}} kcTopSpliceType :: LHsExpr Name -> TcM (HsType Name, TcKind) @@ -656,23 +664,34 @@ runQuasiQuote :: Outputable hs_syn -> MetaOps th_syn hs_syn -> RnM hs_syn runQuasiQuote (HsQuasiQuote quoter q_span quote) quote_selector meta_ty meta_ops - = do { quoter' <- lookupOccRn quoter - -- If 'quoter' is not in scope, proceed no further - -- Otherwise lookupOcc adds an error messsage and returns - -- an "unubound name", which makes the subsequent attempt to - -- run the quote fail - -- + = do { -- Drop the leading "$" from the quoter name, if present + -- This is old-style syntax, now deprecated + -- NB: when removing this backward-compat, remove + -- the matching code in Lexer.x (around line 310) + let occ_str = occNameString (rdrNameOcc quoter) + ; quoter <- ASSERT( not (null occ_str) ) -- Lexer ensures this + if head occ_str /= '$' then return quoter + else do { addWarn (deprecatedDollar quoter) + ; return (mkRdrUnqual (mkVarOcc (tail occ_str))) } + + ; quoter' <- lookupOccRn quoter -- We use lookupOcc rather than lookupGlobalOcc because in the -- erroneous case of \x -> [x| ...|] we get a better error message -- (stage restriction rather than out of scope). + ; when (isUnboundName quoter') failM + -- If 'quoter' is not in scope, proceed no further + -- The error message was generated by lookupOccRn, but it then + -- succeeds with an "unbound name", which makes the subsequent + -- attempt to run the quote fail in a confusing way + -- Check that the quoter is not locally defined, otherwise the TH -- machinery will not be able to run the quasiquote. ; this_mod <- getModule ; let is_local = nameIsLocalOrFrom this_mod quoter' ; checkTc (not is_local) (quoteStageError quoter') - ; traceTc (text "runQQ" <+> ppr quoter <+> ppr is_local) + ; traceTc "runQQ" (ppr quoter <+> ppr is_local) -- Build the expression ; let quoterExpr = L q_span $! HsVar $! quoter' @@ -700,6 +719,12 @@ 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"))] + +deprecatedDollar :: RdrName -> SDoc +deprecatedDollar quoter + = hang (ptext (sLit "Deprecated syntax:")) + 2 (ptext (sLit "quasiquotes no longer need a dollar sign:") + <+> ppr quoter) \end{code} @@ -748,7 +773,7 @@ runMetaQ (MT { mt_show = show_th, mt_cvt = cvt }) expr where run_and_cvt expr_span hval = do { th_result <- TH.runQ hval - ; traceTc (text "Got TH result:" <+> text (show_th th_result)) + ; traceTc "Got TH result:" (text (show_th th_result)) ; return (cvt expr_span th_result) } runMetaE :: LHsExpr Id -- Of type (Q Exp) @@ -770,7 +795,7 @@ runMeta :: (Outputable hs_syn) -> LHsExpr Id -- Of type x; typically x = Q TH.Exp, or something like that -> TcM hs_syn -- Of type t runMeta show_code run_and_convert expr - = do { traceTc (text "About to run" <+> ppr expr) + = do { traceTc "About to run" (ppr expr) -- Desugar ; ds_expr <- initDsTc (dsLExpr expr) @@ -778,7 +803,7 @@ runMeta show_code run_and_convert expr ; hsc_env <- getTopEnv ; src_span <- getSrcSpanM ; either_hval <- tryM $ liftIO $ - HscMain.compileExpr hsc_env src_span ds_expr + HscMain.hscCompileCoreExpr hsc_env src_span ds_expr ; case either_hval of { Left exn -> failWithTc (mk_msg "compile and link" exn) ; Right hval -> do @@ -801,7 +826,7 @@ runMeta show_code run_and_convert expr do { mb_result <- run_and_convert expr_span (unsafeCoerce# hval) ; case mb_result of Left err -> failWithTc err - Right result -> do { traceTc (ptext (sLit "Got HsSyn result:") <+> ppr result) + Right result -> do { traceTc "Got HsSyn result:" (ppr result) ; return $! result } } ; case either_tval of @@ -866,6 +891,7 @@ instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where , TH.loc_end = (srcSpanEndLine l, srcSpanEndCol l) }) } qReify v = reify v + qClassInstances = lookupClassInstances -- For qRecover, discard error messages if -- the recovery action is chosen. Otherwise @@ -909,6 +935,33 @@ illegalBracket = ptext (sLit "Template Haskell brackets cannot be nested (withou %************************************************************************ %* * + Instance Testing +%* * +%************************************************************************ + +\begin{code} +lookupClassInstances :: TH.Name -> [TH.Type] -> TcM [TH.Name] +lookupClassInstances c ts + = do { loc <- getSrcSpanM + ; case convertToHsPred loc (TH.ClassP c ts) of + Left msg -> failWithTc msg + Right rdr_pred -> do + { rn_pred <- rnLPred doc rdr_pred -- Rename + ; kc_pred <- kcHsLPred rn_pred -- Kind check + ; ClassP cls tys <- dsHsLPred kc_pred -- Type check + + -- Now look up instances + ; inst_envs <- tcGetInstEnvs + ; let (matches, unifies) = lookupInstEnv inst_envs cls tys + dfuns = map is_dfun (map fst matches ++ unifies) + ; return (map reifyName dfuns) } } + where + doc = ptext (sLit "TcSplice.classInstances") +\end{code} + + +%************************************************************************ +%* * Reification %* * %************************************************************************ @@ -1011,9 +1064,9 @@ reifyThing (AGlobal (ADataCon dc)) (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 - -- though it may be incomplete +reifyThing (ATcId {tct_id = id}) + = do { ty1 <- zonkTcType (idType id) -- Make use of all the info we have, even + -- though it may be incomplete ; ty2 <- reifyType ty1 ; fix <- reifyFixity (idName id) ; return (TH.VarI (reifyName id) ty2 Nothing fix) } @@ -1032,7 +1085,7 @@ reifyTyCon tc = return (TH.PrimTyConI (reifyName tc) 2 False) | isPrimTyCon tc = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc)) - | isOpenTyCon tc + | isFamilyTyCon tc = let flavour = reifyFamFlavour tc tvs = tyConTyVars tc kind = tyConKind tc @@ -1061,33 +1114,45 @@ reifyTyCon tc ; return (TH.TyConI decl) } reifyDataCon :: [Type] -> DataCon -> TcM TH.Con +-- For GADTs etc, see Note [Reifying data constructors] reifyDataCon tys dc - | isVanillaDataCon dc - = do { arg_tys <- reifyTypes (dataConInstOrigArgTys dc tys) - ; let stricts = map reifyStrict (dataConStrictMarks dc) - fields = dataConFieldLabels dc - name = reifyName dc - [a1,a2] = arg_tys - [s1,s2] = stricts - ; ASSERT( length arg_tys == length stricts ) - if not (null fields) then - return (TH.RecC name (zip3 (map reifyName fields) stricts arg_tys)) - else - if dataConIsInfix dc then - ASSERT( length arg_tys == 2 ) - return (TH.InfixC (s1,a1) name (s2,a2)) - else - return (TH.NormalC name (stricts `zip` arg_tys)) } - | otherwise - = failWithTc (ptext (sLit "Can't reify a GADT data constructor:") - <+> quotes (ppr dc)) + = do { let (tvs, theta, arg_tys, _) = dataConSig dc + subst = mkTopTvSubst (tvs `zip` tys) -- Dicard ex_tvs + (subst', ex_tvs') = mapAccumL substTyVarBndr subst (dropList tys tvs) + theta' = substTheta subst' theta + arg_tys' = substTys subst' arg_tys + stricts = map reifyStrict (dataConStrictMarks dc) + fields = dataConFieldLabels dc + name = reifyName dc + + ; r_arg_tys <- reifyTypes arg_tys' + + ; let main_con | not (null fields) + = TH.RecC name (zip3 (map reifyName fields) stricts r_arg_tys) + | dataConIsInfix dc + = ASSERT( length arg_tys == 2 ) + TH.InfixC (s1,r_a1) name (s2,r_a2) + | otherwise + = TH.NormalC name (stricts `zip` r_arg_tys) + [r_a1, r_a2] = r_arg_tys + [s1, s2] = stricts + + ; ASSERT( length arg_tys == length stricts ) + if null ex_tvs' && null theta then + return main_con + else do + { cxt <- reifyCxt theta' + ; return (TH.ForallC (reifyTyVars ex_tvs') cxt main_con) } } ------------------------------ reifyClass :: Class -> TcM TH.Info reifyClass cls = do { cxt <- reifyCxt theta + ; inst_envs <- tcGetInstEnvs + ; insts <- mapM reifyClassInstance (InstEnv.classInstances inst_envs cls) ; ops <- mapM reify_op op_stuff - ; return (TH.ClassI $ TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) fds' ops) } + ; let dec = TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) fds' ops + ; return (TH.ClassI dec insts ) } where (tvs, fds, theta, _, _, op_stuff) = classExtraBigSig cls fds' = map reifyFunDep fds @@ -1095,11 +1160,26 @@ reifyClass cls ; return (TH.SigD (reifyName op) ty) } ------------------------------ +reifyClassInstance :: Instance -> TcM TH.ClassInstance +reifyClassInstance i + = do { cxt <- reifyCxt theta + ; thtypes <- reifyTypes types + ; return $ (TH.ClassInstance { + TH.ci_tvs = reifyTyVars tvs, + TH.ci_cxt = cxt, + TH.ci_tys = thtypes, + TH.ci_cls = reifyName cls, + TH.ci_dfun = reifyName (is_dfun i) }) } + where + (tvs, theta, cls, types) = instanceHead i + +------------------------------ reifyType :: TypeRep.Type -> TcM TH.Type +-- Monadic only because of failure reifyType ty@(ForAllTy _ _) = reify_for_all ty reifyType ty@(PredTy {} `FunTy` _) = reify_for_all ty -- Types like ((?x::Int) => Char -> Char) reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv)) -reifyType (TyConApp tc tys) = reify_tc_app (reifyName tc) tys -- Do not expand type synonyms here +reifyType (TyConApp tc tys) = reify_tc_app tc tys -- Do not expand type synonyms here reifyType (AppTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) } reifyType (FunTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) } reifyType ty@(PredTy {}) = pprPanic "reifyType PredTy" (ppr ty) @@ -1121,7 +1201,7 @@ reifyKind ki kis_rep = map reifyKind kis ki'_rep = reifyNonArrowKind ki' in - foldl TH.ArrowK ki'_rep kis_rep + foldr TH.ArrowK ki'_rep kis_rep where reifyNonArrowKind k | isLiftedTypeKind k = TH.StarK | otherwise = pprPanic "Exotic form of kind" @@ -1134,8 +1214,8 @@ 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 +reifyFamFlavour tc | isSynFamilyTyCon tc = TH.TypeFam + | isFamilyTyCon tc = TH.DataFam | otherwise = panic "TcSplice.reifyFamFlavour: not a type family" @@ -1148,15 +1228,21 @@ reifyTyVars = map reifyTyVar 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') } +reify_tc_app :: TyCon -> [TypeRep.Type] -> TcM TH.Type +reify_tc_app tc tys + = do { tys' <- reifyTypes tys + ; return (foldl TH.AppT r_tc tys') } + where + n_tys = length tys + r_tc | isTupleTyCon tc = TH.TupleT n_tys + | tc `hasKey` listTyConKey = TH.ListT + | otherwise = TH.ConT (reifyName tc) reifyPred :: TypeRep.PredType -> TcM TH.Pred reifyPred (ClassP cls tys) = do { tys' <- reifyTypes tys - ; return $ TH.ClassP (reifyName cls) tys' - } + ; return $ TH.ClassP (reifyName cls) tys' } + reifyPred p@(IParam _ _) = noTH (sLit "implicit parameters") (ppr p) reifyPred (EqPred ty1 ty2) = do { ty1' <- reifyType ty1 @@ -1197,10 +1283,9 @@ reifyFixity name conv_dir BasicTypes.InfixL = TH.InfixL conv_dir BasicTypes.InfixN = TH.InfixN -reifyStrict :: BasicTypes.StrictnessMark -> TH.Strict -reifyStrict MarkedStrict = TH.IsStrict -reifyStrict MarkedUnboxed = TH.IsStrict -reifyStrict NotMarkedStrict = TH.NotStrict +reifyStrict :: BasicTypes.HsBang -> TH.Strict +reifyStrict bang | isBanged bang = TH.IsStrict + | otherwise = TH.NotStrict ------------------------------ noTH :: LitString -> SDoc -> TcM a @@ -1208,3 +1293,19 @@ noTH s d = failWithTc (hsep [ptext (sLit "Can't represent") <+> ptext s <+> ptext (sLit "in Template Haskell:"), nest 2 d]) \end{code} + +Note [Reifying data constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Template Haskell syntax is rich enough to express even GADTs, +provided we do so in the equality-predicate form. So a GADT +like + + data T a where + MkT1 :: a -> T [a] + MkT2 :: T Int + +will appear in TH syntax like this + + data T a = forall b. (a ~ [b]) => MkT1 b + | (a ~ Int) => MkT2 +