X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcSplice.lhs;h=31dfd3141aceab76bf17d4fea054de3cc8bc9aa3;hb=ff845ab59d1d465d874d3908fd0cdd61b8594da2;hp=5b901b78c0fee9786b3116eddf4c722e41391c6f;hpb=f714e6b642fd614a9971717045ae47c3d871275e;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcSplice.lhs b/ghc/compiler/typecheck/TcSplice.lhs index 5b901b7..31dfd31 100644 --- a/ghc/compiler/typecheck/TcSplice.lhs +++ b/ghc/compiler/typecheck/TcSplice.lhs @@ -13,9 +13,9 @@ import TcRnDriver ( tcTopSrcDecls ) -- These imports are the reason that TcSplice -- is very high up the module hierarchy -import qualified Language.Haskell.TH.THSyntax as TH -import qualified Language.Haskell.TH.THLib as TH +import qualified Language.Haskell.TH as TH -- THSyntax gives access to internal functions and data types +import qualified Language.Haskell.TH.Syntax as TH import HsSyn ( HsBracket(..), HsExpr(..), HsSplice(..), LHsExpr, LHsDecl, HsType, LHsType ) @@ -29,21 +29,26 @@ import TcHsSyn ( mkHsLet, zonkTopLExpr ) import TcSimplify ( tcSimplifyTop, tcSimplifyBracket ) import TcUnify ( Expected, zapExpectedTo, zapExpectedType ) import TcType ( TcType, TcKind, liftedTypeKind, mkAppTy, tcSplitSigmaTy ) -import TcEnv ( spliceOK, tcMetaTy, bracketOK, tcLookup ) -import TcMType ( newTyVarTy, newKindVar, UserTypeCtxt(ExprSigCtxt), zonkTcType, zonkTcTyVar ) +import TcEnv ( spliceOK, tcMetaTy, bracketOK ) +import TcMType ( newTyFlexiVarTy, newKindVar, UserTypeCtxt(ExprSigCtxt), zonkTcType, zonkTcTyVar ) import TcHsType ( tcHsSigType, kcHsType ) +import TcIface ( tcImportDecl ) import TypeRep ( Type(..), PredType(..), TyThing(..) ) -- For reification -import Name ( Name, NamedThing(..), nameOccName, nameModule, isExternalName, mkInternalName ) +import Name ( Name, NamedThing(..), nameOccName, nameModule, isExternalName, + mkInternalName, nameIsLocalOrFrom ) +import NameEnv ( lookupNameEnv ) +import HscTypes ( lookupType, ExternalPackageState(..) ) import OccName import Var ( Id, TyVar, idType ) import Module ( moduleUserString, mkModuleName ) import TcRnMonad import IfaceEnv ( lookupOrig ) - -import Class ( Class, classBigSig ) -import TyCon ( TyCon, tyConTheta, tyConTyVars, getSynTyConDefn, isSynTyCon, isNewTyCon, tyConDataCons ) +import Class ( Class, classExtraBigSig ) +import TyCon ( TyCon, AlgTyConRhs(..), tyConTyVars, getSynTyConDefn, + isSynTyCon, isNewTyCon, tyConDataCons, algTyConRhs ) import DataCon ( DataCon, dataConTyCon, dataConOrigArgTys, dataConStrictMarks, - dataConName, dataConFieldLabels, dataConWrapId ) + dataConName, dataConFieldLabels, dataConWrapId, dataConIsInfix, + isVanillaDataCon ) import Id ( idName, globalIdDetails ) import IdInfo ( GlobalIdDetails(..) ) import TysWiredIn ( mkListTy ) @@ -59,6 +64,11 @@ import FastString ( LitString ) import GHC.Base ( unsafeCoerce#, Int#, Int(..) ) -- Should have a better home in the module hierarchy import Monad ( liftM ) +import Maybes ( orElse ) + +#ifdef GHCI +import FastString ( mkFastString ) +#endif \end{code} @@ -96,6 +106,7 @@ tcBracket brack res_ty -- 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 `thenM_` newMutVar [] `thenM` \ pending_splices -> getLIEVar `thenM` \ lie_var -> @@ -118,8 +129,8 @@ tc_bracket (VarBr v) -- Result type is Var (not Q-monadic) tc_bracket (ExpBr expr) - = newTyVarTy liftedTypeKind `thenM` \ any_ty -> - tcCheckRho expr any_ty `thenM_` + = newTyFlexiVarTy liftedTypeKind `thenM` \ any_ty -> + tcCheckRho expr any_ty `thenM_` tcMetaTy expQTyConName -- Result type is Expr (= Q Exp) @@ -129,7 +140,7 @@ tc_bracket (TypBr typ) -- Result type is Type (= Q Typ) tc_bracket (DecBr decls) - = tcTopSrcDecls decls `thenM_` + = tcTopSrcDecls [{- no boot-names -}] decls `thenM_` -- Typecheck the declarations, dicarding the result -- We'll get all that stuff later, when we splice it in @@ -148,15 +159,15 @@ tc_bracket (DecBr decls) \begin{code} tcSpliceExpr (HsSplice name expr) res_ty - = addSrcSpan (getLoc expr) $ + = setSrcSpan (getLoc expr) $ getStage `thenM` \ level -> case spliceOK level of { Nothing -> failWithTc (illegalSplice level) ; Just next_level -> case level of { - Comp -> do { e <- tcTopSplice expr res_ty ; - returnM (unLoc e) }; + Comp -> do { e <- tcTopSplice expr res_ty + ; returnM (unLoc e) } ; Brack _ ps_var lie_var -> -- A splice inside brackets @@ -222,16 +233,19 @@ tcTopSpliceExpr expr meta_ty = checkNoErrs $ -- checkNoErrs: must not try to run the thing -- if the type checker fails! - setStage topSpliceStage $ + setStage topSpliceStage $ do - -- Typecheck the expression - getLIE (tcCheckRho expr meta_ty) `thenM` \ (expr', lie) -> + + do { recordThUse -- Record that TH is used (for pkg depdendency) + -- Typecheck the expression + ; (expr', lie) <- getLIE (tcCheckRho expr meta_ty) + -- Solve the constraints - tcSimplifyTop lie `thenM` \ const_binds -> + ; const_binds <- tcSimplifyTop lie -- And zonk it - zonkTopLExpr (mkHsLet const_binds expr') + ; zonkTopLExpr (mkHsLet const_binds expr') } \end{code} @@ -245,7 +259,7 @@ Very like splicing an expression, but we don't yet share code. \begin{code} kcSpliceType (HsSplice name hs_expr) - = addSrcSpan (getLoc hs_expr) $ do + = setSrcSpan (getLoc hs_expr) $ do { level <- getStage ; case spliceOK level of { Nothing -> failWithTc (illegalSplice level) ; @@ -353,7 +367,7 @@ runMetaD :: LHsExpr Id -- Of type Q [Dec] -> TcM [TH.Dec] -- Of type [Dec] runMetaD e = runMeta e -runMeta :: LHsExpr Id -- Of type X +runMeta :: LHsExpr Id -- Of type X -> TcM t -- Of type t runMeta expr = do { hsc_env <- getTopEnv @@ -434,7 +448,7 @@ illegalSplice level reify :: TH.Name -> TcM TH.Info reify th_name = do { name <- lookupThName th_name - ; thing <- tcLookup name + ; thing <- tcLookupTh name -- ToDo: this tcLookup could fail, which would give a -- rather unhelpful error message ; reifyThing thing @@ -473,14 +487,44 @@ lookupThName (TH.Name occ (TH.NameU uniq)) bogus_ns = OccName.varName -- Not yet recorded in the TH name -- but only the unique matters +tcLookupTh :: Name -> TcM TcTyThing +-- This is a specialised version of TcEnv.tcLookup; specialised mainly in that +-- it gives a reify-related error message on failure, whereas in the normal +-- tcLookup, failure is a bug. +tcLookupTh name + = do { (gbl_env, lcl_env) <- getEnvs + ; case lookupNameEnv (tcl_env lcl_env) name of + Just thing -> returnM thing + Nothing -> do + { if nameIsLocalOrFrom (tcg_mod gbl_env) name + then -- It's defined in this module + case lookupNameEnv (tcg_type_env gbl_env) name of + Just thing -> return (AGlobal thing) + Nothing -> failWithTc (notInEnv name) + + else do -- It's imported + { (eps,hpt) <- getEpsAndHpt + ; case lookupType hpt (eps_PTE eps) name of + Just thing -> return (AGlobal thing) + Nothing -> do { traceIf (text "tcLookupGlobal" <+> ppr name) + ; thing <- initIfaceTcRn (tcImportDecl name) + ; return (AGlobal thing) } + -- Imported names should always be findable; + -- if not, we fail hard in tcImportDecl + }}} + mk_uniq :: Int# -> Unique mk_uniq u = mkUniqueGrimily (I# u) notInScope :: TH.Name -> SDoc -notInScope th_name = quotes (text (show (TH.pprName th_name))) <+> +notInScope th_name = quotes (text (TH.pprint th_name)) <+> ptext SLIT("is not in scope at a reify") -- Ugh! Rather an indirect way to display the name +notInEnv :: Name -> SDoc +notInEnv name = quotes (ppr name) <+> + ptext SLIT("is not in the type environment at a reify") + ------------------------------ reifyThing :: TcTyThing -> TcM TH.Info -- The only reason this is monadic is for error reporting, @@ -524,37 +568,50 @@ reifyTyCon tc ; rhs' <- reifyType rhs ; return (TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') } - | isNewTyCon tc - = do { cxt <- reifyCxt (tyConTheta tc) - ; con <- reifyDataCon (head (tyConDataCons tc)) - ; return (TH.NewtypeD cxt (reifyName tc) (reifyTyVars (tyConTyVars tc)) - con [{- Don't know about deriving -}]) } - - | otherwise -- Algebraic - = do { cxt <- reifyCxt (tyConTheta tc) - ; cons <- mapM reifyDataCon (tyConDataCons tc) - ; return (TH.DataD cxt (reifyName tc) (reifyTyVars (tyConTyVars tc)) - cons [{- Don't know about deriving -}]) } +reifyTyCon tc + = case algTyConRhs tc of + NewTyCon data_con _ _ + -> do { con <- reifyDataCon data_con + ; return (TH.NewtypeD [] (reifyName tc) (reifyTyVars (tyConTyVars tc)) + con [{- Don't know about deriving -}]) } + + DataTyCon mb_cxt cons _ + -> do { cxt <- reifyCxt (mb_cxt `orElse` []) + ; cons <- mapM reifyDataCon (tyConDataCons tc) + ; return (TH.DataD cxt (reifyName tc) (reifyTyVars (tyConTyVars tc)) + cons [{- Don't know about deriving -}]) } reifyDataCon :: DataCon -> TcM TH.Con reifyDataCon dc + | isVanillaDataCon dc = do { arg_tys <- reifyTypes (dataConOrigArgTys dc) ; let stricts = map reifyStrict (dataConStrictMarks dc) fields = dataConFieldLabels dc - ; if null fields then - return (TH.NormalC (reifyName dc) (stricts `zip` arg_tys)) + 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 (s1,a2)) else - return (TH.RecC (reifyName dc) (zip3 (map reifyName fields) stricts arg_tys)) } - -- NB: we don't remember whether the constructor was declared in an infix way + return (TH.NormalC name (stricts `zip` arg_tys)) } + | otherwise + = failWithTc (ptext SLIT("Can't reify a non-Haskell-98 data constructor:") + <+> quotes (ppr dc)) ------------------------------ reifyClass :: Class -> TcM TH.Dec reifyClass cls = do { cxt <- reifyCxt theta ; ops <- mapM reify_op op_stuff - ; return (TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) ops) } + ; return (TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) fds' ops) } where - (tvs, theta, _, op_stuff) = classBigSig cls + (tvs, fds, theta, _, op_stuff) = classExtraBigSig cls + fds' = map reifyFunDep fds reify_op (op, _) = do { ty <- reifyType (idType op) ; return (TH.SigD (reifyName op) ty) } @@ -562,7 +619,6 @@ reifyClass cls reifyType :: TypeRep.Type -> TcM TH.Type reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv)) reifyType (TyConApp tc tys) = reify_tc_app (reifyName tc) tys -reifyType (NewTcApp tc tys) = reify_tc_app (reifyName tc) tys reifyType (NoteTy _ ty) = reifyType ty 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) } @@ -574,6 +630,9 @@ reifyType ty@(ForAllTy _ _) = do { cxt' <- reifyCxt cxt; reifyTypes = mapM reifyType 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