X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fiface%2FTcIface.lhs;h=156a1aa59fa38c45e2b5e92a6fb7b04ebd227615;hb=e4db45612e3efa59251239e1e0b8a0440783b966;hp=339eb60462835655c3106d258d14f6bdc48186d4;hpb=d51f42f602bf9a6d1b356c41228a534c88723f65;p=ghc-hetmet.git diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 339eb60..156a1aa 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -57,8 +57,10 @@ import ErrUtils import Maybes import SrcLoc import DynFlags -import Control.Monad +import Util +import FastString +import Control.Monad import Data.List import Data.Maybe \end{code} @@ -160,11 +162,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} %************************************************************************ @@ -288,13 +290,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} @@ -423,7 +425,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 +436,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 @@ -497,7 +499,7 @@ 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 spec = mapM do_item spec @@ -519,7 +521,7 @@ 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) $ + = 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,7 +529,7 @@ 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) $ +-- { tycon' <- forkM (ptext (sLit "Inst tycon") <+> ppr tycon) $ -- ^^^this line doesn't work, but vvv this does => CPP in Haskell = evil! = do tycon' <- forkM (text ("Inst tycon") <+> ppr tycon) $ tcIfaceTyCon tycon @@ -560,7 +562,7 @@ tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bnd ifRuleOrph = orph }) = 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 @@ -813,10 +815,8 @@ 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) @@ -1037,13 +1037,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 + other -> 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