X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FTcIface.lhs;h=32735a4e3621f10a7abe74ed6237370aff1a678f;hp=339eb60462835655c3106d258d14f6bdc48186d4;hb=1fa3580c54985d73178d1d396b897176a57cd7f3;hpb=d51f42f602bf9a6d1b356c41228a534c88723f65 diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 339eb60..32735a4 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -6,13 +6,6 @@ Type checking of type signatures in interface files \begin{code} -{-# OPTIONS -w #-} --- 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 --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - module TcIface ( tcImportDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface, tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules, @@ -57,8 +50,11 @@ import ErrUtils import Maybes import SrcLoc import DynFlags -import Control.Monad +import Util +import FastString +import BasicTypes (Arity) +import Control.Monad import Data.List import Data.Maybe \end{code} @@ -72,7 +68,7 @@ This module takes An IfaceDecl is populated with RdrNames, and these are not renamed to Names before typechecking, because there should be no scope errors etc. - -- For (b) consider: f = $(...h....) + -- For (b) consider: f = \$(...h....) -- where h is imported, and calls f via an hi-boot file. -- This is bad! But it is not seen as a staging error, because h -- is indeed imported. We don't want the type-checker to black-hole @@ -151,7 +147,7 @@ importDecl name ; mb_iface <- loadInterface nd_doc (nameModule name) ImportBySystem ; case mb_iface of { Failed err_msg -> return (Failed err_msg) ; - Succeeded iface -> do + Succeeded _ -> do -- Now look it up again; this time we should find it { eps <- getEps @@ -160,11 +156,11 @@ importDecl name Nothing -> return (Failed not_found_msg) }}} where - nd_doc = ptext SLIT("Need decl for") <+> ppr name - not_found_msg = hang (ptext SLIT("Can't find interface-file declaration for") <+> + nd_doc = ptext (sLit "Need decl for") <+> ppr name + not_found_msg = hang (ptext (sLit "Can't find interface-file declaration for") <+> pprNameSpace (occNameSpace (nameOccName name)) <+> ppr name) - 2 (vcat [ptext SLIT("Probable cause: bug in .hi-boot file, or inconsistent .hi file"), - ptext SLIT("Use -ddump-if-trace to get an idea of which file caused the error")]) + 2 (vcat [ptext (sLit "Probable cause: bug in .hi-boot file, or inconsistent .hi file"), + ptext (sLit "Use -ddump-if-trace to get an idea of which file caused the error")]) \end{code} %************************************************************************ @@ -262,7 +258,7 @@ tcHiBootIface hsc_src mod ; case lookupUFM hpt (moduleName mod) of Just info | mi_boot (hm_iface info) -> return (hm_details info) - other -> return emptyModDetails } + _ -> return emptyModDetails } else do -- OK, so we're in one-shot mode. @@ -288,13 +284,13 @@ tcHiBootIface hsc_src mod Succeeded (iface, _path) -> typecheckIface iface }}}} where - need = ptext SLIT("Need the hi-boot interface for") <+> ppr mod - <+> ptext SLIT("to compare against the Real Thing") + need = ptext (sLit "Need the hi-boot interface for") <+> ppr mod + <+> ptext (sLit "to compare against the Real Thing") - moduleLoop = ptext SLIT("Circular imports: module") <+> quotes (ppr mod) - <+> ptext SLIT("depends on itself") + moduleLoop = ptext (sLit "Circular imports: module") <+> quotes (ppr mod) + <+> ptext (sLit "depends on itself") - elaborate err = hang (ptext SLIT("Could not find hi-boot interface for") <+> + elaborate err = hang (ptext (sLit "Could not find hi-boot interface for") <+> quotes (ppr mod) <> colon) 4 err \end{code} @@ -358,16 +354,15 @@ tcIfaceDecl ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type, ifIdI = do { name <- lookupIfaceTop occ_name ; ty <- tcIfaceType iface_type ; info <- tcIdInfo ignore_prags name ty info - ; return (AnId (mkVanillaGlobal name ty info)) } - -tcIfaceDecl ignore_prags - (IfaceData {ifName = occ_name, - ifTyVars = tv_bndrs, - ifCtxt = ctxt, ifGadtSyntax = gadt_syn, - ifCons = rdr_cons, - ifRec = is_rec, - ifGeneric = want_generic, - ifFamInst = mb_family }) + ; return (AnId (mkVanillaGlobalWithInfo name ty info)) } + +tcIfaceDecl _ (IfaceData {ifName = occ_name, + ifTyVars = tv_bndrs, + ifCtxt = ctxt, ifGadtSyntax = gadt_syn, + ifCons = rdr_cons, + ifRec = is_rec, + ifGeneric = want_generic, + ifFamInst = mb_family }) = do { tc_name <- lookupIfaceTop occ_name ; bindIfaceTyVars tv_bndrs $ \ tyvars -> do @@ -389,25 +384,30 @@ tcIfaceDecl ignore_prags ; return (ATyCon tycon) }} -tcIfaceDecl ignore_prags - (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, - ifOpenSyn = isOpen, ifSynRhs = rdr_rhs_ty, - ifFamInst = mb_family}) +tcIfaceDecl _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, + ifSynRhs = mb_rhs_ty, + ifSynKind = kind, ifFamInst = mb_family}) = bindIfaceTyVars tv_bndrs $ \ tyvars -> do { tc_name <- lookupIfaceTop occ_name - ; rhs_tyki <- tcIfaceType rdr_rhs_ty - ; let rhs = if isOpen then OpenSynTyCon rhs_tyki Nothing - else SynonymTyCon rhs_tyki - ; famInst <- case mb_family of - Nothing -> return Nothing - Just (fam, tys) -> - do { famTyCon <- tcIfaceTyCon fam - ; insttys <- mapM tcIfaceType tys - ; return $ Just (famTyCon, insttys) - } - ; tycon <- buildSynTyCon tc_name tyvars rhs famInst + ; rhs_kind <- tcIfaceType kind -- Note [Synonym kind loop] + ; ~(rhs, fam) <- forkM (mk_doc tc_name) $ + do { rhs <- tc_syn_rhs rhs_kind mb_rhs_ty + ; fam <- tc_syn_fam mb_family + ; return (rhs, fam) } + ; tycon <- buildSynTyCon tc_name tyvars rhs rhs_kind fam ; return $ ATyCon tycon } + where + mk_doc n = ptext (sLit "Type syonym") <+> ppr n + tc_syn_rhs kind Nothing = return (OpenSynTyCon kind Nothing) + tc_syn_rhs _ (Just ty) = do { rhs_ty <- tcIfaceType ty + ; return (SynonymTyCon rhs_ty) } + tc_syn_fam Nothing + = return Nothing + tc_syn_fam (Just (fam, tys)) + = do { famTyCon <- tcIfaceTyCon fam + ; insttys <- mapM tcIfaceType tys + ; return $ Just (famTyCon, insttys) } tcIfaceDecl ignore_prags (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, @@ -423,7 +423,7 @@ tcIfaceDecl ignore_prags ; fds <- mapM tc_fd rdr_fds ; ats' <- mapM (tcIfaceDecl ignore_prags) rdr_ats ; let ats = zipWith setTyThingPoss ats' (map ifTyVars rdr_ats) - ; cls <- buildClass cls_name tyvars ctxt fds ats sigs tc_isrec + ; cls <- buildClass ignore_prags cls_name tyvars ctxt fds ats sigs tc_isrec ; return (AClass cls) } where tc_sig (IfaceClassOp occ dm rdr_ty) @@ -434,7 +434,7 @@ tcIfaceDecl ignore_prags -- it mentions unless it's necessray to do so ; return (op_name, dm, op_ty) } - mk_doc op_name op_ty = ptext SLIT("Class op") <+> sep [ppr op_name, ppr op_ty] + mk_doc op_name op_ty = ptext (sLit "Class op") <+> sep [ppr op_name, ppr op_ty] tc_fd (tvs1, tvs2) = do { tvs1' <- mapM tcIfaceTyVar tvs1 ; tvs2' <- mapM tcIfaceTyVar tvs2 @@ -453,12 +453,13 @@ tcIfaceDecl ignore_prags ATyCon (setTyConArgPoss tycon poss) setTyThingPoss _ _ = panic "TcIface.setTyThingPoss" -tcIfaceDecl ignore_prags (IfaceForeign {ifName = rdr_name, ifExtName = ext_name}) +tcIfaceDecl _ (IfaceForeign {ifName = rdr_name, ifExtName = ext_name}) = do { name <- lookupIfaceTop rdr_name ; return (ATyCon (mkForeignTyCon name ext_name liftedTypeKind 0)) } -tcIfaceDataCons tycon_name tycon tc_tyvars if_cons +tcIfaceDataCons :: Name -> TyCon -> [TyVar] -> IfaceConDecls -> IfL AlgTyConRhs +tcIfaceDataCons tycon_name tycon _ if_cons = case if_cons of IfAbstractTyCon -> return mkAbstractTyConRhs IfOpenDataTyCon -> return mkOpenDataTyConRhs @@ -497,8 +498,9 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons eq_spec theta arg_tys tycon } - mk_doc con_name = ptext SLIT("Constructor") <+> ppr con_name + mk_doc con_name = ptext (sLit "Constructor") <+> ppr con_name +tcIfaceEqSpec :: [(OccName, IfaceType)] -> IfL [(TyVar, Type)] tcIfaceEqSpec spec = mapM do_item spec where @@ -507,6 +509,23 @@ tcIfaceEqSpec spec ; return (tv,ty) } \end{code} +Note [Synonym kind loop] +~~~~~~~~~~~~~~~~~~~~~~~~ +Notice that we eagerly grab the *kind* from the interface file, but +build a forkM thunk for the *rhs* (and family stuff). To see why, +consider this (Trac #2412) + +M.hs: module M where { import X; data T = MkT S } +X.hs: module X where { import {-# SOURCE #-} M; type S = T } +M.hs-boot: module M where { data T } + +When kind-checking M.hs we need S's kind. But we do not want to +find S's kind from (typeKind S-rhs), because we don't want to look at +S-rhs yet! Since S is imported from X.hi, S gets just one chance to +be defined, and we must not do that until we've finished with M.T. + +Solution: record S's kind in the interface file; now we can safely +look at it. %************************************************************************ %* * @@ -517,9 +536,8 @@ tcIfaceEqSpec spec \begin{code} tcIfaceInst :: IfaceInst -> IfL Instance tcIfaceInst (IfaceInst { ifDFun = dfun_occ, ifOFlag = oflag, - ifInstCls = cls, ifInstTys = mb_tcs, - ifInstOrph = orph }) - = do { dfun <- forkM (ptext SLIT("Dict fun") <+> ppr dfun_occ) $ + ifInstCls = cls, ifInstTys = mb_tcs }) + = do { dfun <- forkM (ptext (sLit "Dict fun") <+> ppr dfun_occ) $ tcIfaceExtId dfun_occ ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs ; return (mkImportedInstance cls mb_tcs' dfun oflag) } @@ -527,8 +545,8 @@ tcIfaceInst (IfaceInst { ifDFun = dfun_occ, ifOFlag = oflag, tcIfaceFamInst :: IfaceFamInst -> IfL FamInst tcIfaceFamInst (IfaceFamInst { ifFamInstTyCon = tycon, ifFamInstFam = fam, ifFamInstTys = mb_tcs }) --- { tycon' <- forkM (ptext SLIT("Inst tycon") <+> ppr tycon) $ --- ^^^this line doesn't work, but vvv this does => CPP in Haskell = evil! +-- { tycon' <- forkM (ptext (sLit "Inst tycon") <+> ppr tycon) $ +-- the above line doesn't work, but this below does => CPP in Haskell = evil! = do tycon' <- forkM (text ("Inst tycon") <+> ppr tycon) $ tcIfaceTyCon tycon let mb_tcs' = map (fmap ifaceTyConName) mb_tcs @@ -556,11 +574,10 @@ tcIfaceRules ignore_prags if_rules tcIfaceRule :: IfaceRule -> IfL CoreRule tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs, - ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs, - ifRuleOrph = orph }) + ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs }) = do { ~(bndrs', args', rhs') <- -- Typecheck the payload lazily, in the hope it'll never be looked at - forkM (ptext SLIT("Rule") <+> ftext name) $ + forkM (ptext (sLit "Rule") <+> ftext name) $ bindIfaceBndrs bndrs $ \ bndrs' -> do { args' <- mapM tcIfaceExpr args ; rhs' <- tcIfaceExpr rhs @@ -583,9 +600,9 @@ tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bnd -- to write them out in coreRuleToIfaceRule ifTopFreeName :: IfaceExpr -> Maybe Name ifTopFreeName (IfaceType (IfaceTyConApp tc _ )) = Just (ifaceTyConName tc) - ifTopFreeName (IfaceApp f a) = ifTopFreeName f + ifTopFreeName (IfaceApp f _) = ifTopFreeName f ifTopFreeName (IfaceExt n) = Just n - ifTopFreeName other = Nothing + ifTopFreeName _ = Nothing \end{code} @@ -693,6 +710,7 @@ tcIfaceType (IfaceTyConApp tc ts) = do { tc' <- tcIfaceTyCon tc; ts' <- tcIfaceT tcIfaceType (IfaceForAllTy tv t) = bindIfaceTyVar tv $ \ tv' -> do { t' <- tcIfaceType t; return (ForAllTy tv' t') } tcIfaceType (IfacePredTy st) = do { st' <- tcIfacePredType st; return (PredTy st') } +tcIfaceTypes :: [IfaceType] -> IfL [Type] tcIfaceTypes tys = mapM tcIfaceType tys ----------------------------------------- @@ -798,6 +816,9 @@ tcIfaceExpr (IfaceNote note expr) = do IfaceCoreNote n -> return (Note (CoreNote n) expr') ------------------------- +tcIfaceAlt :: CoreExpr -> (TyCon, [Type]) + -> (IfaceConAlt, [FastString], IfaceExpr) + -> IfL (AltCon, [TyVar], CoreExpr) tcIfaceAlt _ _ (IfaceDefault, names, rhs) = ASSERT( null names ) do rhs' <- tcIfaceExpr rhs @@ -813,17 +834,17 @@ tcIfaceAlt _ _ (IfaceLitAlt lit, names, rhs) -- work them out. True enough, but its not that easy! tcIfaceAlt scrut (tycon, inst_tys) (IfaceDataAlt data_occ, arg_strs, rhs) = do { con <- tcIfaceDataCon data_occ -#ifdef DEBUG - ; when (not (con `elem` tyConDataCons tycon)) + ; when (debugIsOn && not (con `elem` tyConDataCons tycon)) (failIfM (ppr scrut $$ ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon))) -#endif ; tcIfaceDataAlt con inst_tys arg_strs rhs } -tcIfaceAlt _ (tycon, inst_tys) (IfaceTupleAlt boxity, arg_occs, rhs) +tcIfaceAlt _ (tycon, inst_tys) (IfaceTupleAlt _boxity, arg_occs, rhs) = ASSERT( isTupleTyCon tycon ) do { let [data_con] = tyConDataCons tycon ; tcIfaceDataAlt data_con inst_tys arg_occs rhs } +tcIfaceDataAlt :: DataCon -> [Type] -> [FastString] -> IfaceExpr + -> IfL (AltCon, [TyVar], CoreExpr) tcIfaceDataAlt con inst_tys arg_strs rhs = do { us <- newUniqueSupply ; let uniqs = uniqsFromSupply us @@ -880,6 +901,7 @@ tcIdInfo ignore_prags name ty info -- we start; default assumption is that it has CAFs init_info = vanillaIdInfo + tcPrag :: IdInfo -> IfaceInfoItem -> IfL IdInfo tcPrag info HsNoCafRefs = return (info `setCafInfo` NoCafRefs) tcPrag info (HsArity arity) = return (info `setArityInfo` arity) tcPrag info (HsStrictness str) = return (info `setAllStrictnessInfo` Just str) @@ -899,6 +921,7 @@ tcIdInfo ignore_prags name ty info \end{code} \begin{code} +tcWorkerInfo :: Type -> IdInfo -> Name -> Arity -> IfL IdInfo tcWorkerInfo ty info wkr arity = do { mb_wkr_id <- forkM_maybe doc (tcIfaceExtId wkr) @@ -979,14 +1002,14 @@ tcIfaceGlobal name { type_env <- setLclEnv () get_type_env -- yuk ; case lookupNameEnv type_env name of Just thing -> return thing - Nothing -> pprPanic "tcIfaceGlobal (local): not found:" + Nothing -> pprPanic "tcIfaceGlobal (local): not found:" (ppr name $$ ppr type_env) } - ; other -> do + ; _ -> do - { (eps,hpt) <- getEpsAndHpt - ; dflags <- getDOpts - ; case lookupType dflags hpt (eps_PTE eps) name of { + { hsc_env <- getTopEnv + ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name) + ; case mb_thing of { Just thing -> return thing ; Nothing -> do @@ -1037,13 +1060,11 @@ tcIfaceTyCon (IfaceTupTc bx ar) = tcWiredInTyCon (tupleTyCon bx ar) tcIfaceTyCon (IfaceTc name) = do { thing <- tcIfaceGlobal name ; return (check_tc (tyThingTyCon thing)) } where -#ifdef DEBUG - check_tc tc = case toIfaceTyCon tc of - IfaceTc _ -> tc - other -> pprTrace "check_tc" (ppr tc) tc -#else - check_tc tc = tc -#endif + check_tc tc + | debugIsOn = case toIfaceTyCon tc of + IfaceTc _ -> tc + _ -> pprTrace "check_tc" (ppr tc) tc + | otherwise = tc -- we should be okay just returning Kind constructors without extra loading tcIfaceTyCon IfaceLiftedTypeKindTc = return liftedTypeKindTyCon tcIfaceTyCon IfaceOpenTypeKindTc = return openTypeKindTyCon @@ -1066,13 +1087,13 @@ tcIfaceDataCon :: Name -> IfL DataCon tcIfaceDataCon name = do { thing <- tcIfaceGlobal name ; case thing of ADataCon dc -> return dc - other -> pprPanic "tcIfaceExtDC" (ppr name$$ ppr thing) } + _ -> pprPanic "tcIfaceExtDC" (ppr name$$ ppr thing) } tcIfaceExtId :: Name -> IfL Id tcIfaceExtId name = do { thing <- tcIfaceGlobal name ; case thing of AnId id -> return id - other -> pprPanic "tcIfaceExtId" (ppr name$$ ppr thing) } + _ -> pprPanic "tcIfaceExtId" (ppr name$$ ppr thing) } \end{code} %************************************************************************ @@ -1099,6 +1120,7 @@ bindIfaceBndrs (b:bs) thing_inside thing_inside (b':bs') ----------------------- +tcIfaceLetBndr :: IfaceLetBndr -> IfL Id tcIfaceLetBndr (IfLetBndr fs ty info) = do { name <- newIfaceName (mkVarOccFS fs) ; ty' <- tcIfaceType ty @@ -1125,13 +1147,13 @@ newExtCoreBndr (IfLetBndr var ty _) -- Ignoring IdInfo for now ----------------------- bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a bindIfaceTyVar (occ,kind) thing_inside - = do { name <- newIfaceName (mkTyVarOcc occ) + = do { name <- newIfaceName (mkTyVarOccFS occ) ; tyvar <- mk_iface_tyvar name kind ; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) } bindIfaceTyVars :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a bindIfaceTyVars bndrs thing_inside - = do { names <- newIfaceNames (map mkTyVarOcc occs) + = do { names <- newIfaceNames (map mkTyVarOccFS occs) ; tyvars <- zipWithM mk_iface_tyvar names kinds ; extendIfaceTyVarEnv tyvars (thing_inside tyvars) } where