X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSplice.lhs;h=778f6e2a1babed8b0d2dd1c91d80587a969bc590;hb=369d62baac8b930320ec1b604fb6625b14d0402d;hp=8ee43f5add75e7c0b4ec60a776db4325ce0d46c8;hpb=6f8ff0bbad3b9fa389c960ad1b5a267a1ae502f1;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index 8ee43f5..778f6e2 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -46,6 +46,7 @@ import TcIface import TypeRep import Name import NameEnv +import NameSet import PrelNames import HscTypes import OccName @@ -67,12 +68,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 @@ -284,7 +288,7 @@ The predicate we use is TcEnv.thTopLevelId. 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) +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 +304,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) @@ -336,9 +340,12 @@ tcBracket brack res_ty -- it again when we actually use it. ; pending_splices <- newMutVar [] ; lie_var <- getLIEVar + ; let brack_stage = Brack cur_stage pending_splices lie_var + + ; (meta_ty, lie) <- setStage brack_stage $ + getLIE $ + tc_bracket cur_stage brack - ; (meta_ty, lie) <- setStage (Brack cur_stage pending_splices lie_var) - (getLIE (tc_bracket cur_stage brack)) ; tcSimplifyBracket lie -- Make the expected type have the right shape @@ -379,6 +386,10 @@ 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) @@ -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 { @@ -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) @@ -657,15 +665,16 @@ runQuasiQuote :: Outputable 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 - -- -- 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 @@ -1061,26 +1070,35 @@ 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 @@ -1099,7 +1117,7 @@ reifyType :: TypeRep.Type -> TcM TH.Type 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 +1139,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" @@ -1148,15 +1166,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 +1221,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 +1231,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 +