diff options
| author | partain <unknown> | 1996-04-25 16:33:15 +0000 |
|---|---|---|
| committer | partain <unknown> | 1996-04-25 16:33:15 +0000 |
| commit | a77abe6a30ea2763cfa1c0ca83cdce9b7200ced2 (patch) | |
| tree | c73770e4b72adf7c1af3addeb69e5ef451373014 /ghc | |
| parent | 4250d64191132fd493985549eda5ca05b82a663f (diff) | |
| download | haskell-a77abe6a30ea2763cfa1c0ca83cdce9b7200ced2.tar.gz | |
[project @ 1996-04-25 16:31:20 by partain]
SLPJ 1.3 changes through 960425
Diffstat (limited to 'ghc')
47 files changed, 748 insertions, 707 deletions
diff --git a/ghc/compiler/Jmakefile b/ghc/compiler/Jmakefile index cd0bb3cd80..ae3ed276f8 100644 --- a/ghc/compiler/Jmakefile +++ b/ghc/compiler/Jmakefile @@ -154,7 +154,6 @@ typecheck/TcPat.lhs \ typecheck/TcSimplify.lhs \ typecheck/TcTyClsDecls.lhs \ typecheck/TcTyDecls.lhs \ -typecheck/Typecheck.lhs \ typecheck/Unify.lhs /* @@ -319,14 +318,10 @@ utils/Unpretty.lhs \ utils/Util.lhs #define MAIN_SRCS_LHS \ -main/MainMonad.lhs \ main/CmdLineOpts.lhs \ main/ErrUtils.lhs \ -main/Main.lhs - -/* main/MkIface.lhs \ -*/ +main/Main.lhs #define VBASICSRCS_LHS \ prelude/PrelMods.lhs \ @@ -587,7 +582,6 @@ compile(deSugar/MatchLit,lhs,) compile(main/CmdLineOpts,lhs,if_ghc(-fvia-C)) compile(main/ErrUtils,lhs,) compile(main/Main,lhs,if_ghc(-fvia-C)) -compile(main/MainMonad,lhs,) compile(main/MkIface,lhs,) #if GhcWithNativeCodeGen == YES @@ -718,7 +712,6 @@ compile(typecheck/TcPragmas,lhs,) compile(typecheck/TcSimplify,lhs,) compile(typecheck/TcTyClsDecls,lhs,) compile(typecheck/TcTyDecls,lhs,) -compile(typecheck/Typecheck,lhs,) compile(typecheck/Unify,lhs,) compile(types/Class,lhs,) diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 7815d7d0ba..a2b00f4919 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -97,7 +97,7 @@ import IdLoop -- for paranoia checking import TyLoop -- for paranoia checking import Bag -import Class ( getClassOpString, Class(..), GenClass, ClassOp(..), GenClassOp ) +import Class ( classOpString, Class(..), GenClass, ClassOp(..), GenClassOp ) import CStrings ( identToC, cSEP ) import IdInfo import Maybes ( maybeToBool ) @@ -1039,7 +1039,7 @@ getIdNamePieces show_uniqs id MethodSelId clas op -> case (moduleNamePair clas) of { (c_mod, c_name) -> - case (getClassOpString op) of { op_name -> + case (classOpString op) of { op_name -> if isPreludeDefined clas then [op_name] else [c_mod, c_name, op_name] @@ -1047,7 +1047,7 @@ getIdNamePieces show_uniqs id DefaultMethodId clas op _ -> case (moduleNamePair clas) of { (c_mod, c_name) -> - case (getClassOpString op) of { op_name -> + case (classOpString op) of { op_name -> if isPreludeDefined clas then [SLIT("defm"), op_name] else [SLIT("defm"), c_mod, c_name, op_name] }} @@ -1066,7 +1066,7 @@ getIdNamePieces show_uniqs id ConstMethodId c ty o _ _ -> case (moduleNamePair c) of { (c_mod, c_name) -> case (getTypeString ty) of { ty_bits -> - case (getClassOpString o) of { o_name -> + case (classOpString o) of { o_name -> case (if isPreludeDefined c then [c_name] else [c_mod, c_name]) of { c_bits -> @@ -1142,7 +1142,7 @@ getInstIdModule other = panic "Id:getInstIdModule" \begin{code} mkSuperDictSelId u c sc ty info = Id u ty (SuperDictSelId c sc) NoPragmaInfo info -mkMethodSelId u c op ty info = Id u ty (MethodSelId c op) NoPragmaInfo info +mkMethodSelId u c op ty info = Id u ty (MethodSelId c op) NoPragmaInfo info mkDefaultMethodId u c op gen ty info = Id u ty (DefaultMethodId c op gen) NoPragmaInfo info mkDictFunId u c ity full_ty from_here mod info @@ -1817,7 +1817,7 @@ instance NamedThing (GenId ty) where {- LATER: get (MethodSelId c op) = case (moduleOf (origName c)) of -- ToDo; better ??? - mod -> (mod, getClassOpString op) + mod -> (mod, classOpString op) get (SpecId unspec ty_maybes _) = BIND moduleNamePair unspec _TO_ (mod, unspec_nm) -> diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index 17f62d0453..f73b36a6e7 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -28,10 +28,12 @@ module Name ( mkTupNameStr, NamedThing(..), -- class - ExportFlag(..), isExported, + ExportFlag(..), + isExported{-overloaded-}, exportFlagOn{-not-}, nameUnique, nameOccName, + nameOrigName, nameExportFlag, nameSrcLoc, nameImportFlag, @@ -340,10 +342,10 @@ data ExportFlag | ExportAbs -- export abstractly (tycons/classes only) | NotExported -isExported a - = case (getExportFlag a) of - NotExported -> False - _ -> True +exportFlagOn NotExported = False +exportFlagOn _ = True + +isExported a = exportFlagOn (getExportFlag a) #ifdef USE_ATTACK_PRAGMAS {-# SPECIALIZE isExported :: Class -> Bool #-} @@ -400,17 +402,7 @@ as to canonicalize interfaces. [Regular @(<)@ should be used for fast comparison.] \begin{code} -a `ltLexical` b - = case (moduleNamePair a) of { (a_mod, a_name) -> - case (moduleNamePair b) of { (b_mod, b_name) -> - if isLocallyDefined a || isLocallyDefined b then - a_name < b_name -- can't compare module names - else - case _CMP_STRING_ a_mod b_mod of - LT_ -> True - EQ_ -> a_name < b_name - GT__ -> False - }} +a `ltLexical` b = origName a < origName b #ifdef USE_ATTACK_PRAGMAS {-# SPECIALIZE ltLexical :: Class -> Class -> Bool #-} diff --git a/ghc/compiler/basicTypes/UniqSupply.lhs b/ghc/compiler/basicTypes/UniqSupply.lhs index 47b54a82b3..d9ae896f2b 100644 --- a/ghc/compiler/basicTypes/UniqSupply.lhs +++ b/ghc/compiler/basicTypes/UniqSupply.lhs @@ -63,7 +63,7 @@ data UniqSupply \end{code} \begin{code} -mkSplitUniqSupply :: Char -> PrimIO UniqSupply +mkSplitUniqSupply :: Char -> IO UniqSupply splitUniqSupply :: UniqSupply -> (UniqSupply, UniqSupply) getUnique :: UniqSupply -> Unique @@ -97,7 +97,8 @@ mkSplitUniqSupply (MkChar c#) mk_unique = _ccall_ genSymZh `thenPrimIO` \ (W# u#) -> returnPrimIO (MkInt (w2i (mask# `or#` u#))) in - mk_supply# + mk_supply# `thenPrimIO` \ s -> + return s splitUniqSupply (MkSplitUniqSupply _ s1 s2) = (s1, s2) \end{code} diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs index dd36c0ef79..68f3975dab 100644 --- a/ghc/compiler/basicTypes/Unique.lhs +++ b/ghc/compiler/basicTypes/Unique.lhs @@ -120,6 +120,8 @@ module Unique ( recUpdErrorIdKey, irrefutPatErrorIdKey, nonExhaustiveGuardsErrorIdKey, + noDefaultMethodErrorIdKey, + nonExplicitMethodErrorIdKey, primIoTyConKey, ratioDataConKey, ratioTyConKey, @@ -568,12 +570,14 @@ recConErrorIdKey = mkPreludeMiscIdUnique 29 recUpdErrorIdKey = mkPreludeMiscIdUnique 30 irrefutPatErrorIdKey = mkPreludeMiscIdUnique 31 nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 32 +noDefaultMethodErrorIdKey = mkPreludeMiscIdUnique 33 +nonExplicitMethodErrorIdKey = mkPreludeMiscIdUnique 34 #ifdef GRAN -parLocalIdKey = mkPreludeMiscIdUnique 33 -parGlobalIdKey = mkPreludeMiscIdUnique 34 -noFollowIdKey = mkPreludeMiscIdUnique 35 -copyableIdKey = mkPreludeMiscIdUnique 36 +parLocalIdKey = mkPreludeMiscIdUnique 35 +parGlobalIdKey = mkPreludeMiscIdUnique 36 +noFollowIdKey = mkPreludeMiscIdUnique 37 +copyableIdKey = mkPreludeMiscIdUnique 38 #endif \end{code} diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index 4078820980..0e836879e3 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -277,10 +277,15 @@ lintCoreArg checkTyApp e ty a@(TyArg arg_ty) Nothing -> addErrL (mkTyAppMsg SLIT("Illegal") ty arg_ty e) `seqL` returnL Nothing Just (tyvar,body) -> - if (tyVarKind tyvar `isSubKindOf` typeKind arg_ty) then + let + tyvar_kind = tyVarKind tyvar + argty_kind = typeKind arg_ty + in + if (tyvar_kind `isSubKindOf` argty_kind + || argty_kind `isSubKindOf` tyvar_kind) then returnL(Just(instantiateTy [(tyvar,arg_ty)] body)) else - pprTrace "lintCoreArg:kinds:" (ppCat [ppr PprDebug (tyVarKind tyvar), ppr PprDebug (typeKind arg_ty)]) $ + pprTrace "lintCoreArg:kinds:" (ppCat [ppr PprDebug tyvar_kind, ppr PprDebug argty_kind]) $ addErrL (mkTyAppMsg SLIT("Kinds not right in") ty arg_ty e) `seqL` returnL Nothing lintCoreArg _ e ty (UsageArg u) diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs index 92668988fd..146b1f31c4 100644 --- a/ghc/compiler/coreSyn/CoreUnfold.lhs +++ b/ghc/compiler/coreSyn/CoreUnfold.lhs @@ -340,7 +340,7 @@ sizeExpr scc_s_OK bOMB_OUT_SIZE args expr size_alg_alt (con,args,rhs) = size_up rhs -- Don't charge for args, so that wrappers look cheap - (tycon, _, _) = getAppDataTyCon scrut_ty + (tycon, _, _) = _trace "getAppDataTyCon.CoreUnfold" $ getAppDataTyCon scrut_ty size_up_alts _ (PrimAlts alts deflt) = foldr (addSize . size_prim_alt) (size_up_deflt deflt) alts diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index 174f5053a8..d3afc57ce0 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -12,7 +12,6 @@ module CoreUtils ( substCoreExpr, substCoreBindings , mkCoreIfThenElse - , escErrorMsg -- ToDo: kill , argToExpr , unTagBinders, unTagBindersAlts , manifestlyWHNF, manifestlyBottom @@ -130,7 +129,8 @@ default_ty (BindDefault _ rhs) = coreExprType rhs \end{code} \begin{code} -applyTypeToArgs = panic "applyTypeToArgs" +applyTypeToArgs op_ty args + = foldl applyTy op_ty [ ty | TyArg ty <- args ] \end{code} %************************************************************************ @@ -151,23 +151,6 @@ mkCoreIfThenElse guard then_expr else_expr NoDefault ) \end{code} -\begin{code} -{- OLD: -mkErrorApp :: Id -> Type -> Id -> String -> CoreExpr - -mkErrorApp err_fun ty str_var error_msg - = Let (NonRec str_var (Lit (NoRepStr (_PK_ error_msg)))) ( - mkApp (Var err_fun) [] [ty] [VarArg str_var]) --} - -escErrorMsg = panic "CoreUtils.escErrorMsg: To Die" -{- OLD: -escErrorMsg [] = [] -escErrorMsg ('%':xs) = '%' : '%' : escErrorMsg xs -escErrorMsg (x:xs) = x : escErrorMsg xs --} -\end{code} - For making @Apps@ and @Lets@, we must take appropriate evasive action if the thing being bound has unboxed type. @mkCoApp@ requires a name supply to do its work. diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index 8e1c73d28d..2aff67f223 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -27,7 +27,7 @@ import Ubiq{-uitous-} import CoreSyn import CostCentre ( showCostCentre ) -import Id ( idType, getIdInfo, getIdStrictness, +import Id ( idType, getIdInfo, getIdStrictness, isTupleCon, nullIdEnv, DataCon(..), GenId{-instances-} ) import IdInfo ( ppIdInfo, StrictnessInfo(..) ) @@ -303,9 +303,14 @@ ppr_alts pe (AlgAlts alts deflt) = ppAboves [ ppAboves (map ppr_alt alts), ppr_default pe deflt ] where ppr_alt (con, params, expr) - = ppHang (ppCat [ppr_con con (pCon pe con), - ppInterleave ppSP (map (pMinBndr pe) params), - ppStr "->"]) + = ppHang (if isTupleCon con then + ppCat [ppParens (ppInterleave ppComma (map (pMinBndr pe) params)), + ppStr "->"] + else + ppCat [ppr_con con (pCon pe con), + ppInterleave ppSP (map (pMinBndr pe) params), + ppStr "->"] + ) 4 (ppr_expr pe expr) where ppr_con con pp_con diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs index b744e0e213..41813e44c5 100644 --- a/ghc/compiler/deSugar/DsBinds.lhs +++ b/ghc/compiler/deSugar/DsBinds.lhs @@ -37,7 +37,11 @@ import Type ( mkTyVarTys, mkForAllTys, splitSigmaTy, tyVarsOfType, tyVarsOfTypes ) import TyVar ( tyVarSetToList, GenTyVar{-instance Eq-} ) -import Util ( isIn, panic ) +import Util ( isIn, panic, pprTrace{-ToDo:rm-} ) +import PprCore--ToDo:rm +import PprType--ToDo:rm +import Usage--ToDo:rm +import Unique--ToDo:rm isDictTy = panic "DsBinds.isDictTy" \end{code} @@ -540,6 +544,8 @@ dsMonoBinds is_rec tyvars [] binder_subst (PatMonoBind pat grhss_and_binds locn) -- we can just use the rhs directly else -} + pprTrace "dsMonoBinds:PatMonoBind:" (ppr PprDebug body_expr) $ + mkSelectorBinds tyvars pat [(binder, binder_subst binder) | binder <- pat_binders] body_expr diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index 0e4afdc199..8f55239b2e 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -413,7 +413,7 @@ dsExpr (RecordUpdOut record_expr dicts rbinds) let rbinds' = panic "dsExpr:RecordUpdOut:rbinds'" in let record_ty = coreExprType record_expr' - (tycon, inst_tys, cons) = getAppDataTyCon record_ty + (tycon, inst_tys, cons) = _trace "getAppDataTyCon.DsExpr" $ getAppDataTyCon record_ty cons_to_upd = filter has_all_fields cons -- initial_args are passed to every constructor diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index 81edf598c0..eeb8f26fc4 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -40,10 +40,10 @@ import DsMonad import CoreUtils ( coreExprType, mkCoreIfThenElse ) import PprStyle ( PprStyle(..) ) -import PprType ( pprType{-ToDo:rm-} ) import PrelInfo ( stringTy, iRREFUT_PAT_ERROR_ID ) import Pretty ( ppShow ) import Id ( idType, dataConArgTys, mkTupleCon, + pprId{-ToDo:rm-}, DataCon(..), DictVar(..), Id(..), GenId ) import Literal ( Literal(..) ) import TyCon ( mkTupleTyCon ) @@ -52,6 +52,12 @@ import Type ( mkTyVarTys, mkRhoTy, mkForAllTys, mkFunTys, ) import UniqSet ( mkUniqSet, minusUniqSet, uniqSetToList, UniqSet(..) ) import Util ( panic, assertPanic, pprTrace{-ToDo:rm-} ) +import PprCore{-ToDo:rm-} +import PprType--ToDo:rm +import Pretty--ToDo:rm +import TyVar--ToDo:rm +import Unique--ToDo:rm +import Usage--ToDo:rm splitDictType = panic "DsUtils.splitDictType" \end{code} @@ -397,7 +403,9 @@ The general case: \begin{code} mkTupleBind tyvars dicts local_global_prs tuple_expr - = newSysLocalDs tuple_var_ty `thenDs` \ tuple_var -> + = pprTrace "mkTupleBind:\n" (ppAboves [ppCat (map (pprId PprShowAll) locals), ppCat (map (pprId PprShowAll) globals), {-ppr PprDebug local_tuple, pprType PprDebug res_ty,-} ppr PprDebug tuple_expr]) $ + + newSysLocalDs tuple_var_ty `thenDs` \ tuple_var -> zipWithDs (mk_selector (Var tuple_var)) local_global_prs diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index 4380041333..fd4bb5dfce 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -334,7 +334,7 @@ tidy1 v (RecPat con_id pat_ty rpats) match_result pats = map mk_pat tagged_arg_tys -- Boring stuff to find the arg-tys of the constructor - (_, inst_tys, _) = getAppDataTyCon pat_ty + (_, inst_tys, _) = _trace "getAppDataTyCon.Match" $ getAppDataTyCon pat_ty con_arg_tys' = dataConArgTys con_id inst_tys tagged_arg_tys = con_arg_tys' `zip` allFieldLabelTags diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index 68b1a878c9..324b811fdf 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -16,7 +16,8 @@ import Ubiq -- friends: import HsLoop ( nullMonoBinds, MonoBinds, Sig ) import HsPragmas ( DataPragmas, ClassPragmas, - InstancePragmas, ClassOpPragmas ) + InstancePragmas, ClassOpPragmas + ) import HsTypes -- others: @@ -167,8 +168,8 @@ data ConDecl name SrcLoc data BangType name - = Banged (MonoType name) - | Unbanged (MonoType name) + = Banged (PolyType name) -- PolyType: to allow Haskell extensions + | Unbanged (PolyType name) -- (MonoType only needed for straight Haskell) \end{code} \begin{code} @@ -186,8 +187,8 @@ instance (NamedThing name, Outputable name) => Outputable (ConDecl name) where where pp_field (n, ty) = ppCat [ppr sty n, ppPStr SLIT("::"), ppr_bang sty ty] -ppr_bang sty (Banged ty) = ppBeside (ppChar '!') (pprParendMonoType sty ty) -ppr_bang sty (Unbanged ty) = pprParendMonoType sty ty +ppr_bang sty (Banged ty) = ppBeside (ppChar '!') (pprParendPolyType sty ty) +ppr_bang sty (Unbanged ty) = pprParendPolyType sty ty \end{code} %************************************************************************ diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs index 9c29e81117..884ee9f8be 100644 --- a/ghc/compiler/hsSyn/HsTypes.lhs +++ b/ghc/compiler/hsSyn/HsTypes.lhs @@ -15,6 +15,7 @@ module HsTypes ( Context(..), ClassAssertion(..) #ifdef COMPILING_GHC + , pprParendPolyType , pprParendMonoType, pprContext , extractMonoTyNames, extractCtxtTyNames , cmpPolyType, cmpMonoType, cmpContext @@ -102,6 +103,8 @@ pprContext sty context instance (Outputable name) => Outputable (PolyType name) where ppr sty (HsPreForAllTy ctxt ty) = print_it sty ppNil ctxt ty + ppr sty (HsForAllTy [] ctxt ty) + = print_it sty ppNil ctxt ty ppr sty (HsForAllTy tvs ctxt ty) = print_it sty (ppBesides [ppStr "_forall_ ", interppSP sty tvs, ppStr " => "]) @@ -111,6 +114,9 @@ print_it sty pp_forall ctxt ty = ppCat [ifnotPprForUser sty pp_forall, -- print foralls unless PprForUser pprContext sty ctxt, ppr sty ty] +pprParendPolyType :: Outputable name => PprStyle -> PolyType name -> Pretty +pprParendPolyType sty ty = ppr sty ty -- ToDo: more later + instance (Outputable name) => Outputable (MonoType name) where ppr = pprMonoType diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index e47f359a23..8bbfa55c11 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -223,6 +223,8 @@ opt_ProduceC = lookup_str "-C=" opt_ProduceS = lookup_str "-S=" opt_ProduceHi = lookup_str "-hifile=" opt_ProduceHu = lookup_str "-hufile=" +opt_MyHi = lookup_str "-myhifile=" -- the ones produced last time +opt_MyHu = lookup_str "-myhufile=" -- for this module opt_EnsureSplittableC = lookup_str "-fglobalise-toplev-names=" opt_UnfoldingUseThreshold = lookup_int "-funfolding-use-threshold" opt_UnfoldingCreationThreshold = lookup_int "-funfolding-creation-threshold" @@ -232,6 +234,7 @@ opt_ReturnInRegsThreshold = lookup_int "-freturn-in-regs-threshold" opt_NoImplicitPrelude = lookup SLIT("-fno-implicit-prelude") opt_IgnoreIfacePragmas = lookup SLIT("-fignore-interface-pragmas") +opt_HuSuffix = case (lookup_str "-husuffix=") of { Nothing -> ".hu" ; Just x -> x } opt_HiSuffix = case (lookup_str "-hisuffix=") of { Nothing -> ".hi" ; Just x -> x } opt_SysHiSuffix = case (lookup_str "-syshisuffix=") of { Nothing -> ".hi" ; Just x -> x } diff --git a/ghc/compiler/main/ErrUtils.lhs b/ghc/compiler/main/ErrUtils.lhs index 89866b7728..e50ded59a7 100644 --- a/ghc/compiler/main/ErrUtils.lhs +++ b/ghc/compiler/main/ErrUtils.lhs @@ -11,7 +11,8 @@ module ErrUtils ( addErrLoc, addShortErrLocLine, dontAddErrLoc, - pprBagOfErrors + pprBagOfErrors, + ghcExit ) where import Ubiq{-uitous-} @@ -49,3 +50,12 @@ pprBagOfErrors sty bag_of_errors = let pretties = map ( \ e -> e sty ) (bagToList bag_of_errors) in ppAboves (map (\ p -> ppAbove ppSP p) pretties) \end{code} + +\begin{code} +ghcExit :: Int -> IO () + +ghcExit val + = if val /= 0 + then error "Compilation had errors\n" + else return () +\end{code} diff --git a/ghc/compiler/main/Main.lhs b/ghc/compiler/main/Main.lhs index b96f1a2e1d..ef89a619c4 100644 --- a/ghc/compiler/main/Main.lhs +++ b/ghc/compiler/main/Main.lhs @@ -10,14 +10,14 @@ module Main ( main ) where import Ubiq{-uitous-} -import PreludeGlaST ( thenPrimIO, _FILE{-instances-} ) -- ToDo: STOP using this... +import PreludeGlaST ( thenPrimIO, fopen, fclose, _FILE{-instance CCallable-} ) -import MainMonad import HsSyn import ReadPrefix ( rdModule ) import Rename ( renameModule ) -import Typecheck ( typecheckModule, InstInfo ) +import MkIface -- several functions +import TcModule ( typecheckModule ) import Desugar ( deSugar, DsMatchContext, pprDsWarnings ) import SimplCore ( core2core ) import CoreToStg ( topCoreBindsToStg ) @@ -31,12 +31,14 @@ import AbsCSyn ( absCNop, AbstractC ) import AbsCUtils ( flattenAbsC ) import Bag ( emptyBag, isEmptyBag ) import CmdLineOpts -import ErrUtils ( pprBagOfErrors ) +import ErrUtils ( pprBagOfErrors, ghcExit ) import Maybes ( maybeToBool, MaybeErr(..) ) import PrelInfo ( builtinNameInfo ) import RdrHsSyn ( getRawExportees ) import Specialise ( SpecialiseData(..) ) import StgSyn ( pprPlainStgBinding, GenStgBinding ) +import TcInstUtil ( InstInfo ) +import UniqSupply ( mkSplitUniqSupply ) import PprAbsC ( dumpRealC, writeRealC ) import PprCore ( pprCoreBinding ) @@ -49,16 +51,11 @@ import PprType ( GenType, GenTyVar ) -- instances import RnHsSyn ( RnName ) -- instances import TyVar ( GenTyVar ) -- instances import Unique ( Unique ) -- instances - -{- ---import MkIface ( mkInterface ) --} - \end{code} \begin{code} main - = readMn stdin `thenMn` \ input_pgm -> + = hGetContents stdin >>= \ input_pgm -> let cmd_line_info = classifyOpts in @@ -66,77 +63,73 @@ main \end{code} \begin{code} -doIt :: ([CoreToDo], [StgToDo]) -> String -> MainIO () +doIt :: ([CoreToDo], [StgToDo]) -> String -> IO () doIt (core_cmds, stg_cmds) input_pgm - = doDump opt_Verbose "Glasgow Haskell Compiler, version 1.3-xx" "" - `thenMn_` + = doDump opt_Verbose "Glasgow Haskell Compiler, version 1.01, for Haskell 1.3" "" >> -- ******* READER - show_pass "Reader" `thenMn_` - rdModule `thenMn` - - \ (mod_name, rdr_module) -> + show_pass "Reader" >> + rdModule >>= \ (mod_name, rdr_module) -> - let - -- reader things used much later - ds_mod_name = mod_name - if_mod_name = mod_name - co_mod_name = mod_name - st_mod_name = mod_name - cc_mod_name = mod_name - in doDump opt_D_dump_rdr "Reader:" - (pp_show (ppr pprStyle rdr_module)) `thenMn_` + (pp_show (ppr pprStyle rdr_module)) >> doDump opt_D_source_stats "\nSource Statistics:" - (pp_show (ppSourceStats rdr_module)) `thenMn_` + (pp_show (ppSourceStats rdr_module)) >> -- UniqueSupplies for later use (these are the only lower case uniques) - getSplitUniqSupplyMn 'r' `thenMn` \ rn_uniqs -> -- renamer - getSplitUniqSupplyMn 't' `thenMn` \ tc_uniqs -> -- typechecker - getSplitUniqSupplyMn 'd' `thenMn` \ ds_uniqs -> -- desugarer - getSplitUniqSupplyMn 's' `thenMn` \ sm_uniqs -> -- core-to-core simplifier - getSplitUniqSupplyMn 'c' `thenMn` \ c2s_uniqs -> -- core-to-stg - getSplitUniqSupplyMn 'g' `thenMn` \ st_uniqs -> -- stg-to-stg passes - getSplitUniqSupplyMn 'f' `thenMn` \ fl_uniqs -> -- absC flattener - getSplitUniqSupplyMn 'n' `thenMn` \ ncg_uniqs -> -- native-code generator + mkSplitUniqSupply 'r' >>= \ rn_uniqs -> -- renamer + mkSplitUniqSupply 't' >>= \ tc_uniqs -> -- typechecker + mkSplitUniqSupply 'd' >>= \ ds_uniqs -> -- desugarer + mkSplitUniqSupply 's' >>= \ sm_uniqs -> -- core-to-core simplifier + mkSplitUniqSupply 'c' >>= \ c2s_uniqs -> -- core-to-stg + mkSplitUniqSupply 'g' >>= \ st_uniqs -> -- stg-to-stg passes + mkSplitUniqSupply 'f' >>= \ fl_uniqs -> -- absC flattener + mkSplitUniqSupply 'n' >>= \ ncg_uniqs -> -- native-code generator -- ******* RENAMER - show_pass "Renamer" `thenMn_` + show_pass "Renamer" >> case builtinNameInfo of { (wiredin_fm, key_fm, idinfo_fm) -> - renameModule wiredin_fm key_fm rn_uniqs rdr_module `thenMn` + renameModule wiredin_fm key_fm rn_uniqs rdr_module >>= \ (rn_mod, rn_env, import_names, version_info, instance_modules, rn_errs_bag, rn_warns_bag) -> if (not (isEmptyBag rn_errs_bag)) then - writeMn stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle rn_errs_bag)) - `thenMn_` writeMn stderr "\n" `thenMn_` - writeMn stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle rn_warns_bag)) - `thenMn_` writeMn stderr "\n" `thenMn_` - exitMn 1 + hPutStr stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle rn_errs_bag)) + >> hPutStr stderr "\n" >> + hPutStr stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle rn_warns_bag)) + >> hPutStr stderr "\n" >> + ghcExit 1 else -- No renaming errors ... (if (isEmptyBag rn_warns_bag) then - returnMn () + return () else - writeMn stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle rn_warns_bag)) - `thenMn_` writeMn stderr "\n" - ) `thenMn_` + hPutStr stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle rn_warns_bag)) + >> hPutStr stderr "\n" + ) >> doDump opt_D_dump_rn "Renamer:" - (pp_show (ppr pprStyle rn_mod)) `thenMn_` - --- exitMn 0 -{- LATER ... -} + (pp_show (ppr pprStyle rn_mod)) >> + + -- Safely past renaming: we can start the interface file: + -- (the iface file is produced incrementally, as we have + -- the information that we need...; we use "iface<blah>") + -- "endIface" finishes the job. + startIface mod_name >>= \ if_handle -> + ifaceVersions if_handle version_info >> + ifaceExportList if_handle rn_mod >> + ifaceFixities if_handle rn_mod >> + ifaceInstanceModules if_handle instance_modules >> -- ******* TYPECHECKER - show_pass "TypeCheck" `thenMn_` + show_pass "TypeCheck" >> case (case (typecheckModule tc_uniqs {-idinfo_fm-} rn_env rn_mod) of Succeeded (stuff, warns) -> (emptyBag, warns, stuff) @@ -146,24 +139,24 @@ doIt (core_cmds, stg_cmds) input_pgm of { (tc_errs_bag, tc_warns_bag, tc_results) -> if (not (isEmptyBag tc_errs_bag)) then - writeMn stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle tc_errs_bag)) - `thenMn_` writeMn stderr "\n" `thenMn_` - writeMn stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle tc_warns_bag)) - `thenMn_` writeMn stderr "\n" `thenMn_` - exitMn 1 + hPutStr stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle tc_errs_bag)) + >> hPutStr stderr "\n" >> + hPutStr stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle tc_warns_bag)) + >> hPutStr stderr "\n" >> + ghcExit 1 else ( -- No typechecking errors ... (if (isEmptyBag tc_warns_bag) then - returnMn () + return () else - writeMn stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle tc_warns_bag)) - `thenMn_` writeMn stderr "\n" - ) `thenMn_` + hPutStr stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle tc_warns_bag)) + >> hPutStr stderr "\n" + ) >> case tc_results of { (typechecked_quint@(recsel_binds, class_binds, inst_binds, val_binds, const_binds), - interface_stuff@(_,_,_,_,_), -- @-pat just for strictness... + interface_stuff, (local_tycons,local_classes), pragma_tycon_specs, ddump_deriv) -> doDump opt_D_dump_tc "Typechecked:" @@ -172,87 +165,68 @@ doIt (core_cmds, stg_cmds) input_pgm ppr pprStyle class_binds, ppr pprStyle inst_binds, ppAboves (map (\ (i,e) -> ppr pprStyle (VarMonoBind i e)) const_binds), - ppr pprStyle val_binds])) `thenMn_` + ppr pprStyle val_binds])) >> doDump opt_D_dump_deriv "Derived instances:" - (pp_show (ddump_deriv pprStyle)) `thenMn_` + (pp_show (ddump_deriv pprStyle)) >> + + -- OK, now do the interface stuff that relies on typechecker output: + ifaceDecls if_handle interface_stuff >> + ifaceInstances if_handle interface_stuff >> -- ******* DESUGARER - show_pass "DeSugar" `thenMn_` + show_pass "DeSugar" >> let (desugared,ds_warnings) - = deSugar ds_uniqs ds_mod_name typechecked_quint + = deSugar ds_uniqs mod_name typechecked_quint in (if isEmptyBag ds_warnings then - returnMn () + return () else - writeMn stderr (ppShow pprCols (pprDsWarnings pprErrorsStyle ds_warnings)) - `thenMn_` writeMn stderr "\n" - ) `thenMn_` + hPutStr stderr (ppShow pprCols (pprDsWarnings pprErrorsStyle ds_warnings)) + >> hPutStr stderr "\n" + ) >> doDump opt_D_dump_ds "Desugared:" (pp_show (ppAboves (map (pprCoreBinding pprStyle) desugared))) - `thenMn_` + >> -- ******* CORE-TO-CORE SIMPLIFICATION (NB: I/O op) - core2core core_cmds co_mod_name pprStyle + core2core core_cmds mod_name pprStyle sm_uniqs local_tycons pragma_tycon_specs desugared - `thenMn` + >>= \ (simplified, inlinings_env, SpecData _ _ _ gen_tycons all_tycon_specs _ _ _) -> doDump opt_D_dump_simpl "Simplified:" (pp_show (ppAboves (map (pprCoreBinding pprStyle) simplified))) - `thenMn_` + >> -- ******* STG-TO-STG SIMPLIFICATION - show_pass "Core2Stg" `thenMn_` + show_pass "Core2Stg" >> let stg_binds = topCoreBindsToStg c2s_uniqs simplified in - show_pass "Stg2Stg" `thenMn_` - stg2stg stg_cmds st_mod_name pprStyle st_uniqs stg_binds - `thenMn` + show_pass "Stg2Stg" >> + stg2stg stg_cmds mod_name pprStyle st_uniqs stg_binds + >>= \ (stg_binds2, cost_centre_info) -> doDump opt_D_dump_stg "STG syntax:" (pp_show (ppAboves (map (pprPlainStgBinding pprStyle) stg_binds2))) - `thenMn_` - -{- LATER ... - -- ******* INTERFACE GENERATION (needs STG output) -{- let - mod_name = "_TestName_" - export_list_fns = (\ x -> False, \ x -> False) - inlinings_env = nullIdEnv - fixities = [] - if_global_ids = [] - if_ce = nullCE - if_tce = nullTCE - if_inst_info = emptyBag - in --} + >> - show_pass "Interface" `thenMn_` - let - mod_interface - = mkInterface if_mod_name export_list_fns - inlinings_env all_tycon_specs - interface_stuff - stg_binds2 - in - doOutput opt_ProduceHi ( \ file -> - ppAppendFile file 1000{-pprCols-} mod_interface ) - `thenMn_` --} + -- We are definitely done w/ interface-file stuff at this point: + -- (See comments near call to "startIface".) + endIface if_handle >> -- ******* "ABSTRACT", THEN "FLAT", THEN *REAL* C! - show_pass "CodeGen" `thenMn_` + show_pass "CodeGen" >> let - abstractC = codeGen cc_mod_name -- module name for CC labelling + abstractC = codeGen mod_name -- module name for CC labelling cost_centre_info import_names -- import names for CC registering gen_tycons -- type constructors generated locally @@ -262,10 +236,10 @@ doIt (core_cmds, stg_cmds) input_pgm flat_abstractC = flattenAbsC fl_uniqs abstractC in doDump opt_D_dump_absC "Abstract C:" - (dumpRealC abstractC) `thenMn_` + (dumpRealC abstractC) >> doDump opt_D_dump_flatC "Flat Abstract C:" - (dumpRealC flat_abstractC) `thenMn_` + (dumpRealC flat_abstractC) >> -- You can have C (c_output) or assembly-language (ncg_output), -- but not both. [Allowing for both gives a space leak on @@ -291,18 +265,14 @@ doIt (core_cmds, stg_cmds) input_pgm #endif in - doDump opt_D_dump_asm "" ncg_output_d `thenMn_` - doOutput opt_ProduceS ncg_output_w `thenMn_` - - doDump opt_D_dump_realC "" c_output_d `thenMn_` - doOutput opt_ProduceC c_output_w `thenMn_` - - exitMn 0 - } ) } + doDump opt_D_dump_asm "" ncg_output_d >> + doOutput opt_ProduceS ncg_output_w >> -{- LATER -} + doDump opt_D_dump_realC "" c_output_d >> + doOutput opt_ProduceC c_output_w >> - } + ghcExit 0 + } ) } } where ------------------------------------------------------------- -- ****** printing styles and column width: @@ -326,29 +296,29 @@ doIt (core_cmds, stg_cmds) input_pgm show_pass = if opt_D_show_passes - then \ what -> writeMn stderr ("*** "++what++":\n") - else \ what -> returnMn () + then \ what -> hPutStr stderr ("*** "++what++":\n") + else \ what -> return () doOutput switch io_action = case switch of - Nothing -> returnMn () + Nothing -> return () Just fname -> fopen fname "a+" `thenPrimIO` \ file -> if (file == ``NULL'') then error ("doOutput: failed to open:"++fname) else - io_action file `thenMn` \ () -> + io_action file >>= \ () -> fclose file `thenPrimIO` \ status -> if status == 0 - then returnMn () + then return () else error ("doOutput: closed failed: "{-++show status++" "-}++fname) doDump switch hdr string = if switch - then writeMn stderr hdr `thenMn_` - writeMn stderr ('\n': string) `thenMn_` - writeMn stderr "\n" - else returnMn () + then hPutStr stderr hdr >> + hPutStr stderr ('\n': string) >> + hPutStr stderr "\n" + else return () ppSourceStats (HsModule name version exports imports fixities typedecls typesigs diff --git a/ghc/compiler/main/MainMonad.lhs b/ghc/compiler/main/MainMonad.lhs deleted file mode 100644 index eae6adfc64..0000000000 --- a/ghc/compiler/main/MainMonad.lhs +++ /dev/null @@ -1,116 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996 -% -\section[MainMonad]{I/O monad used in @Main@ module of the compiler} - -\begin{code} -#include "HsVersions.h" - -module MainMonad ( - MainIO(..), - returnMn, - thenMn, - thenMn_, --- foldlMn, INLINEd at its two (important) uses... - readMn, - writeMn, - getArgsMn, - getSplitUniqSupplyMn, - exitMn, - fopen, fclose, fwrite, _FILE(..), - - UniqSupply - IF_ATTACK_PRAGMAS(COMMA getArgsPrimIO) - IF_ATTACK_PRAGMAS(COMMA appendFilePrimIO) - IF_ATTACK_PRAGMAS(COMMA appendChanPrimIO) - IF_ATTACK_PRAGMAS(COMMA readChanPrimIO) - IF_ATTACK_PRAGMAS(COMMA mkSplitUniqSupply) -- profiling only, really - ) where - -#if __HASKELL1__ >= 3 -import LibSystem -#endif - -import PreludeGlaST - -import Ubiq{-uitous-} - -import UniqSupply ( mkSplitUniqSupply, UniqSupply ) - -infixr 9 `thenMn` -- right-associative, please -infixr 9 `thenMn_` -\end{code} - -A value of type @MainIO a@ represents an I/O-performing computation -returning a value of type @a@. It is a function from the whole list -of responses-to-the-rest-of-the-program, to a triple consisting of: -\begin{enumerate} -\item -the value of type @a@; -\item -a function which prefixes the requests for the computation to -the front of a supplied list of requests; using a function here -avoids an expensive append operation in @thenMn@; -\item -the depleted list of responses. -\end{enumerate} - -\begin{code} -returnMn :: a -> MainIO a -thenMn :: MainIO a -> (a -> MainIO b) -> MainIO b -thenMn_ :: MainIO a -> MainIO b -> MainIO b - -#if __HASKELL1__ < 3 -readMn :: String{-channel-} -> MainIO String -writeMn :: String{-channel-} -> String -> MainIO () -#else -readMn :: Handle -> MainIO String -writeMn :: Handle -> String -> MainIO () -#endif - -getArgsMn :: MainIO [String] -getSplitUniqSupplyMn - :: Char -> MainIO UniqSupply -exitMn :: Int -> MainIO () - -{-# INLINE returnMn #-} -{-# INLINE thenMn #-} -{-# INLINE thenMn_ #-} - -exitMn val - = if val /= 0 - then error "Compilation had errors\n" - else returnMn () - -#if __HASKELL1__ < 3 - -type MainIO a = PrimIO a - -returnMn = returnPrimIO -thenMn = thenPrimIO -thenMn_ = seqPrimIO - -readMn chan = readChanPrimIO chan -writeMn chan str = appendChanPrimIO chan str -getArgsMn = getArgsPrimIO - -getSplitUniqSupplyMn char = mkSplitUniqSupply char - -#else {- 1.3 -} - -type MainIO a = IO a - -returnMn = return -thenMn = (>>=) -thenMn_ = (>>) - -readMn chan = hGetContents chan -writeMn chan str = hPutStr chan str -getArgsMn = getArgs - -getSplitUniqSupplyMn char - = mkSplitUniqSupply char `thenPrimIO` \ us -> - return us - -#endif {- 1.3 -} -\end{code} diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index a8af666c42..2ee4182edc 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -6,25 +6,218 @@ \begin{code} #include "HsVersions.h" -module MkIface ( mkInterface ) where - -import PrelInfo ( mkLiftTy, pRELUDE_BUILTIN ) -import HsSyn ( FixityDecl(..), RenamedFixityDecl(..), MonoBinds, - RenamedMonoBinds(..), Name, RenamedPat(..), Sig +module MkIface {-( mkInterface )-} where + +import Ubiq{-uitous-} + +import Bag ( emptyBag, snocBag, bagToList ) +import Class ( GenClass{-instance NamedThing-} ) +import CmdLineOpts ( opt_ProduceHi ) +import HsSyn +import Id ( GenId{-instance NamedThing/Outputable-} ) +import Name ( nameOrigName, exportFlagOn, nameExportFlag, ExportFlag(..), + ltLexical, isExported, + RdrName{-instance Outputable-} ) -import Type -import Bag -import FiniteMap -import Id -import IdInfo -- plenty from here -import Maybes ( catMaybes, Maybe(..) ) -import Outputable -import Pretty -import StgSyn -import TcInstDcls ( InstInfo(..) ) -import Util +import PprStyle ( PprStyle(..) ) +import PprType ( TyCon{-instance Outputable-}, GenClass{-ditto-} ) +import Pretty -- quite a bit +import RnHsSyn ( RenamedHsModule(..), RnName{-instance NamedThing-} ) +import RnIfaces ( VersionInfo(..) ) +import TcModule ( TcIfaceInfo(..) ) +import TcInstUtil ( InstInfo ) +import TyCon ( TyCon{-instance NamedThing-} ) +import Util ( sortLt, assertPanic ) + +ppSemid x = ppBeside (ppr PprInterface x) ppSemi -- micro util +\end{code} + +We have a function @startIface@ to open the output file and put +(something like) ``interface Foo N'' in it. It gives back a handle +for subsequent additions to the interface file. + +We then have one-function-per-block-of-interface-stuff, e.g., +@ifaceExportList@ produces the @__exports__@ section; it appends +to the handle provided by @startIface@. + +\begin{code} +startIface :: Module + -> IO (Maybe Handle) -- Nothing <=> don't do an interface +endIface :: Maybe Handle -> IO () +ifaceVersions + :: Maybe Handle + -> VersionInfo + -> IO () +ifaceExportList + :: Maybe Handle + -> RenamedHsModule + -> IO () +ifaceFixities + :: Maybe Handle + -> RenamedHsModule + -> IO () +ifaceInstanceModules + :: Maybe Handle + -> [Module] + -> IO () +ifaceDecls :: Maybe Handle + -> TcIfaceInfo -- info produced by typechecker, for interfaces + -> IO () +ifaceInstances + :: Maybe Handle + -> TcIfaceInfo -- as above + -> IO () +--ifacePragmas +\end{code} + +\begin{code} +startIface mod + = case opt_ProduceHi of + Nothing -> return Nothing -- not producing any .hi file + Just fn -> + openFile fn WriteMode >>= \ if_hdl -> + hPutStr if_hdl ("interface "++ _UNPK_ mod ++" 1\n") >> + return (Just if_hdl) + +endIface Nothing = return () +endIface (Just if_hdl) = hPutStr if_hdl "\n" >> hClose if_hdl \end{code} +\begin{code} +ifaceVersions Nothing{-no iface handle-} _ = return () + +ifaceVersions (Just if_hdl) version_info + = hPutStr if_hdl "__versions__\nFoo(1)" -- a stub, obviously +\end{code} + +\begin{code} +ifaceInstanceModules Nothing{-no iface handle-} _ = return () +ifaceInstanceModules (Just _) [] = return () + +ifaceInstanceModules (Just if_hdl) imods + = hPutStr if_hdl "\n__instance_modules__\n" >> + hPutStr if_hdl (ppShow 100 (ppCat (map ppPStr imods))) +\end{code} + +Export list: grab the Names of things that are marked Exported, sort +(so the interface file doesn't ``wobble'' from one compilation to the +next...), and print. Note that the ``module'' now contains all the +imported things that we are dealing with, thus including any entities +that we are re-exporting from somewhere else. +\begin{code} +ifaceExportList Nothing{-no iface handle-} _ = return () + +ifaceExportList (Just if_hdl) + (HsModule _ _ _ _ _ typedecls _ classdecls _ _ _ binds sigs _) + = let + name_flag_pairs :: Bag (Name, ExportFlag) + name_flag_pairs + = foldr from_ty + (foldr from_cls + (foldr from_sig + (from_binds binds emptyBag{-init accum-}) + sigs) + classdecls) + typedecls + + sorted_pairs = sortLt lexical_lt (bagToList name_flag_pairs) + + in + hPutStr if_hdl "\n__exports__\n" >> + hPutStr if_hdl (ppShow 100 (ppAboves (map pp_pair sorted_pairs))) + where + from_ty (TyData _ n _ _ _ _ _) acc = maybe_add acc n + from_ty (TyNew _ n _ _ _ _ _) acc = maybe_add acc n + from_ty (TySynonym n _ _ _) acc = maybe_add acc n + + from_cls (ClassDecl _ n _ _ _ _ _) acc = maybe_add acc n + + from_sig (Sig n _ _ _) acc = maybe_add acc n + + from_binds bs acc = maybe_add_list acc (collectTopLevelBinders bs) + + -------------- + maybe_add :: Bag (Name, ExportFlag) -> RnName -> Bag (Name, ExportFlag) + + maybe_add acc rn + | exportFlagOn ef = acc `snocBag` (n, ef) + | otherwise = acc + where + n = getName rn + ef = nameExportFlag n + + -------------- + maybe_add_list acc [] = acc + maybe_add_list acc (n:ns) = maybe_add (maybe_add_list acc ns) n + + -------------- + lexical_lt (n1,_) (n2,_) = nameOrigName n1 < nameOrigName n2 + + -------------- + pp_pair (n, ef) + = ppBeside (ppr PprInterface (nameOrigName n)) (pp_export ef) + where + pp_export ExportAll = ppPStr SLIT("(..)") + pp_export ExportAbs = ppNil +\end{code} + +\begin{code} +ifaceFixities Nothing{-no iface handle-} _ = return () + +ifaceFixities (Just if_hdl) (HsModule _ _ _ _ fixities _ _ _ _ _ _ _ _ _) + = if null fixities then + return () + else + hPutStr if_hdl "\n__fixities__\n" >> + hPutStr if_hdl (ppShow 100 (ppAboves (map ppSemid fixities))) +\end{code} + +\begin{code} +ifaceDecls Nothing{-no iface handle-} _ = return () + +ifaceDecls (Just if_hdl) (vals, tycons, classes, _) + = ASSERT(not (null vals && null tycons && null classes)) + let + exported_classes = filter isExported classes + exported_tycons = filter isExported tycons + exported_vals = filter isExported vals + + sorted_classes = sortLt ltLexical exported_classes + sorted_tycons = sortLt ltLexical exported_tycons + sorted_vals = sortLt ltLexical exported_vals + in + hPutStr if_hdl "\n__declarations__\n" >> + hPutStr if_hdl (ppShow 100 (ppAboves [ + ppAboves (map ppSemid sorted_classes), + ppAboves (map ppSemid sorted_tycons), + ppAboves (map ppSemid sorted_vals)])) +\end{code} + +\begin{code} +ifaceInstances Nothing{-no iface handle-} _ = return () + +ifaceInstances (Just if_hdl) (_, _, _, insts) + = return () +{- + let + exported_classes = filter isExported classes + exported_tycons = filter isExported tycons + exported_vals = filter isExported vals + + sorted_classes = sortLt ltLexical exported_classes + sorted_tycons = sortLt ltLexical exported_tycons + sorted_vals = sortLt ltLexical exported_vals + in + hPutStr if_hdl "\n__declarations__\n" >> + hPutStr if_hdl (ppShow 100 (ppAboves [ + ppAboves (map ppSemid sorted_classes), + ppAboves (map ppSemid sorted_tycons), + ppAboves (map ppSemid sorted_vals)])) +-} +\end{code} + +=== ALL OLD BELOW HERE ============== + %************************************************************************ %* * \subsection[main-MkIface]{Main routine for making interfaces} @@ -67,6 +260,7 @@ to \tr{make}. \end{enumerate} \begin{code} +{- OLD: to the end mkInterface :: FAST_STRING -> (FAST_STRING -> Bool, -- is something in export list, explicitly? FAST_STRING -> Bool) -- is a module among the "dotdot" exported modules? @@ -449,7 +643,7 @@ do_instance better_id_fn inline_env better_dfun_info = getIdInfo better_dfun better_constms = map better_id_fn constm_ids - class_op_strs = map getClassOpString (getClassOps clas) + class_op_strs = map classOpString (classOps clas) pragma_begin = ppCat [ppPStr SLIT("\t{-# GHC_PRAGMA"), pp_modname, ppPStr SLIT("{-dfun-}"), @@ -564,4 +758,5 @@ getMentionedTyConsAndClassesFromInstInfo (InstInfo clas _ ty _ dfun_theta _ _ _ case [ c | (c, _) <- dfun_theta ] of { theta_classes -> (ts, (cs `unionBags` listToBag theta_classes) `snocBag` clas) }} +OLD from the beginning -} \end{code} diff --git a/ghc/compiler/parser/UgenUtil.lhs b/ghc/compiler/parser/UgenUtil.lhs index 9244022946..860c33be3d 100644 --- a/ghc/compiler/parser/UgenUtil.lhs +++ b/ghc/compiler/parser/UgenUtil.lhs @@ -16,7 +16,6 @@ import PreludeGlaST import Ubiq -import MainMonad ( MainIO(..) ) import Name ( RdrName(..) ) import SrcLoc ( mkSrcLoc2, mkUnknownSrcLoc ) \end{code} @@ -35,7 +34,7 @@ thenUgn x y stuff = x stuff `thenPrimIO` \ z -> y z stuff -initUgn :: UgnM a -> MainIO a +initUgn :: UgnM a -> IO a initUgn action = action (SLIT(""),SLIT(""),mkUnknownSrcLoc) `thenPrimIO` \ result -> return result diff --git a/ghc/compiler/prelude/PrelVals.lhs b/ghc/compiler/prelude/PrelVals.lhs index 1f0fe9529b..83449fe3e7 100644 --- a/ghc/compiler/prelude/PrelVals.lhs +++ b/ghc/compiler/prelude/PrelVals.lhs @@ -83,6 +83,10 @@ iRREFUT_PAT_ERROR_ID = generic_ERROR_ID irrefutPatErrorIdKey SLIT("irrefutPatError#") nON_EXHAUSTIVE_GUARDS_ERROR_ID = generic_ERROR_ID nonExhaustiveGuardsErrorIdKey SLIT("nonExhaustiveGuardsError#") +nO_DEFAULT_METHOD_ERROR_ID + = generic_ERROR_ID noDefaultMethodErrorIdKey SLIT("noDefaultMethodError#") +nO_EXPLICIT_METHOD_ERROR_ID + = generic_ERROR_ID nonExplicitMethodErrorIdKey SLIT("noExplicitMethodError#") aBSENT_ERROR_ID = pc_bottoming_Id absentErrorIdKey pRELUDE_BUILTIN SLIT("absent#") diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs index fe5fce6a6e..0ea3f0aecd 100644 --- a/ghc/compiler/prelude/PrimOp.lhs +++ b/ghc/compiler/prelude/PrimOp.lhs @@ -1285,7 +1285,7 @@ primOpInfo ErrorIOPrimOp -- errorIO# :: PrimIO () -> State# RealWorld# primOpInfo (CCallOp _ _ _ arg_tys result_ty) = AlgResult SLIT("ccall#") [] arg_tys result_tycon tys_applied where - (result_tycon, tys_applied, _) = getAppDataTyCon result_ty + (result_tycon, tys_applied, _) = _trace "getAppDataTyCon.PrimOp" $ getAppDataTyCon result_ty \end{code} %************************************************************************ diff --git a/ghc/compiler/reader/ReadPrefix.lhs b/ghc/compiler/reader/ReadPrefix.lhs index 74cf5d8068..cb8be084cc 100644 --- a/ghc/compiler/reader/ReadPrefix.lhs +++ b/ghc/compiler/reader/ReadPrefix.lhs @@ -20,9 +20,8 @@ import RdrHsSyn import PrefixToHs import CmdLineOpts ( opt_CompilingPrelude ) -import ErrUtils ( addErrLoc ) +import ErrUtils ( addErrLoc, ghcExit ) import FiniteMap ( elemFM, FiniteMap ) -import MainMonad ( writeMn, exitMn, MainIO(..) ) import Name ( RdrName(..), isRdrLexCon ) import PprStyle ( PprStyle(..) ) import PrelMods ( fromPrelude ) @@ -84,8 +83,8 @@ cvFlag 1 = True %************************************************************************ \begin{code} -rdModule :: MainIO (Module, -- this module's name - RdrNameHsModule) -- the main goods +rdModule :: IO (Module, -- this module's name + RdrNameHsModule) -- the main goods rdModule = _ccall_ hspmain `thenPrimIO` \ pt -> -- call the Yacc parser! @@ -398,8 +397,8 @@ wlkPat pat (\sty -> ppInterleave ppSP (map (ppr sty) (lpat:lpats))) msg = ppShow 100 (err PprForUser) in - ioToUgnM (writeMn stderr msg) `thenUgn` \ _ -> - ioToUgnM (exitMn 1) `thenUgn` \ _ -> + ioToUgnM (hPutStr stderr msg) `thenUgn` \ _ -> + ioToUgnM (ghcExit 1) `thenUgn` \ _ -> returnUgn (error "ReadPrefix") ) `thenUgn` \ (n, arg_pats) -> @@ -790,9 +789,10 @@ rdBangType pt = rdU_ttype pt `thenUgn` \ ty -> wlkBangType ty wlkBangType :: U_ttype -> UgnM (BangType RdrName) -wlkBangType (U_tbang bty) = wlkMonoType bty `thenUgn` \ ty -> returnUgn (Banged ty) -wlkBangType uty = wlkMonoType uty `thenUgn` \ ty -> returnUgn (Unbanged ty) - +wlkBangType (U_tbang bty) = wlkMonoType bty `thenUgn` \ ty -> + returnUgn (Banged (HsPreForAllTy [] ty)) +wlkBangType uty = wlkMonoType uty `thenUgn` \ ty -> + returnUgn (Unbanged (HsPreForAllTy [] ty)) \end{code} %************************************************************************ diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y index a2e6eb6412..ee43188cff 100644 --- a/ghc/compiler/rename/ParseIface.y +++ b/ghc/compiler/rename/ParseIface.y @@ -137,13 +137,13 @@ fixities_part : FIXITIES_PART fixes { $2 } | { emptyFM } fixes :: { FixitiesMap } -fixes : fix { case $1 of (k,v) -> unitFM k v } - | fixes SEMI fix { case $3 of (k,v) -> addToFM $1 k v } +fixes : fix { case $1 of (k,v) -> unitFM k v } + | fixes fix { case $2 of (k,v) -> addToFM $1 k v } fix :: { (FAST_STRING, RdrNameFixityDecl) } -fix : INFIXL INTEGER qop { (de_qual $3, InfixL $3 (fromInteger $2)) } - | INFIXR INTEGER qop { (de_qual $3, InfixR $3 (fromInteger $2)) } - | INFIX INTEGER qop { (de_qual $3, InfixN $3 (fromInteger $2)) +fix : INFIXL INTEGER qop SEMI { (de_qual $3, InfixL $3 (fromInteger $2)) } + | INFIXR INTEGER qop SEMI { (de_qual $3, InfixR $3 (fromInteger $2)) } + | INFIX INTEGER qop SEMI { (de_qual $3, InfixN $3 (fromInteger $2)) -------------------------------------------------------------------------- } @@ -151,17 +151,17 @@ decls_part :: { (LocalTyDefsMap, LocalValDefsMap) } decls_part : DECLARATIONS_PART topdecls { $2 } topdecls :: { (LocalTyDefsMap, LocalValDefsMap) } -topdecls : topdecl { $1 } - | topdecls SEMI topdecl { case $1 of { (ts1, vs1) -> - case $3 of { (ts2, vs2) -> - (plusFM ts1 ts2, plusFM vs1 vs2)}} - } +topdecls : topdecl { $1 } + | topdecls topdecl { case $1 of { (ts1, vs1) -> + case $2 of { (ts2, vs2) -> + (plusFM ts1 ts2, plusFM vs1 vs2)}} + } topdecl :: { (LocalTyDefsMap, LocalValDefsMap) } -topdecl : typed { ($1, emptyFM) } - | datad { $1 } - | newtd { $1 } - | classd { $1 } +topdecl : typed SEMI { ($1, emptyFM) } + | datad SEMI { $1 } + | newtd SEMI { $1 } + | classd SEMI { $1 } | decl { case $1 of { (n, Sig qn ty _ loc) -> (emptyFM, unitFM n (ValSig qn loc ty)) } } @@ -186,11 +186,11 @@ cbody : WHERE OCURLY decls CCURLY { $3 } | { [] } decls :: { [(FAST_STRING, RdrNameSig)] } -decls : decl { [$1] } - | decls SEMI decl { $1 ++ [$3] } +decls : decl { [$1] } + | decls decl { $1 ++ [$2] } decl :: { (FAST_STRING, RdrNameSig) } -decl : var DCOLON ctype { (de_qual $1, Sig $1 $3 noGenPragmas mkIfaceSrcLoc) } +decl : var DCOLON ctype SEMI { (de_qual $1, Sig $1 $3 noGenPragmas mkIfaceSrcLoc) } context :: { RdrNameContext } context : OPAREN context_list CPAREN { reverse $2 } @@ -293,12 +293,12 @@ btyconapp : gtycon { ($1, []) } | btyconapp batype { case $1 of (tc,tys) -> (tc, tys ++ [$2]) } bbtype :: { RdrNameBangType } -bbtype : btype { Unbanged $1 } - | BANG atype { Banged $2 } +bbtype : btype { Unbanged (HsPreForAllTy [] $1) } + | BANG atype { Banged (HsPreForAllTy [] $2) } batype :: { RdrNameBangType } -batype : atype { Unbanged $1 } - | BANG atype { Banged $2 } +batype : atype { Unbanged (HsPreForAllTy [] $1) } + | BANG atype { Banged (HsPreForAllTy [] $2) } batypes :: { [RdrNameBangType] } batypes : batype { [$1] } @@ -309,8 +309,8 @@ fields : field { [$1] } | fields COMMA field { $1 ++ [$3] } field :: { ([RdrName], RdrNameBangType) } -field : var DCOLON type { ([$1], Unbanged $3) } - | var DCOLON BANG atype { ([$1], Banged $4) } +field : var DCOLON type { ([$1], Unbanged (HsPreForAllTy [] $3)) } + | var DCOLON BANG atype { ([$1], Banged (HsPreForAllTy [] $4)) } constr1 :: { (RdrName, RdrNameMonoType) } constr1 : gtycon atype { ($1, $2) } @@ -353,11 +353,11 @@ instances_part : INSTANCES_PART instdecls { $2 } instdecls :: { Bag RdrIfaceInst } instdecls : instd { unitBag $1 } - | instdecls SEMI instd { $1 `snocBag` $3 } + | instdecls instd { $1 `snocBag` $2 } instd :: { RdrIfaceInst } -instd : INSTANCE context DARROW gtycon restrict_inst { mk_inst $2 $4 $5 } - | INSTANCE gtycon general_inst { mk_inst [] $2 $3 } +instd : INSTANCE context DARROW gtycon restrict_inst SEMI { mk_inst $2 $4 $5 } + | INSTANCE gtycon general_inst SEMI { mk_inst [] $2 $3 } restrict_inst :: { RdrNameMonoType } restrict_inst : gtycon { MonoTyApp $1 [] } diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index a066cf054f..c5b881ac6f 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -32,7 +32,6 @@ import RnNames ( getGlobalNames, GlobalNameInfo(..) ) import RnSource ( rnSource ) import RnIfaces ( findHiFiles, rnIfaces, finalIfaceInfo, VersionInfo(..) ) import RnUtils ( RnEnv(..), extendGlobalRnEnv, emptyRnEnv, multipleOccWarn ) -import MainMonad import Bag ( isEmptyBag, unionBags, unionManyBags, bagToList, listToBag ) import CmdLineOpts ( opt_HiDirList, opt_SysHiDirList ) @@ -72,11 +71,11 @@ ToDo: Deal with instances (instance version, this module on instance list ???) renameModule b_names b_keys us input@(HsModule mod _ _ imports _ _ _ _ _ _ _ _ _ _) - = pprTrace "builtins:\n" (case b_names of { (builtin_ids, builtin_tcs) -> - ppAboves [ ppCat (map ppPStr (keysFM builtin_ids)) - , ppCat (map ppPStr (keysFM builtin_tcs)) - , ppCat (map ppPStr (keysFM b_keys)) - ]}) $ + = --pprTrace "builtins:\n" (case b_names of { (builtin_ids, builtin_tcs) -> + -- ppAboves [ ppCat (map ppPStr (keysFM builtin_ids)) + -- , ppCat (map ppPStr (keysFM builtin_tcs)) + -- , ppCat (map ppPStr (keysFM b_keys)) + -- ]}) $ findHiFiles opt_HiDirList opt_SysHiDirList >>= \ hi_files -> newVar (emptyFM, hi_files){-init iface cache-} `thenPrimIO` \ iface_cache -> diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 7b85d5d827..2d608011fa 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -354,12 +354,13 @@ rnConDecls tv_env con_decls returnRn (new_names, new_ty) rn_mono_ty = rnMonoType tv_env + rn_poly_ty = rnPolyType tv_env rn_bang_ty (Banged ty) - = rn_mono_ty ty `thenRn` \ new_ty -> + = rn_poly_ty ty `thenRn` \ new_ty -> returnRn (Banged new_ty) rn_bang_ty (Unbanged ty) - = rn_mono_ty ty `thenRn` \ new_ty -> + = rn_poly_ty ty `thenRn` \ new_ty -> returnRn (Unbanged new_ty) \end{code} diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index 1c99c714a2..eea04438f3 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -34,6 +34,7 @@ import CoreLint ( lintCoreBindings ) import CoreSyn import CoreUnfold import CoreUtils ( substCoreBindings, manifestlyWHNF ) +import ErrUtils ( ghcExit ) import FloatIn ( floatInwards ) import FloatOut ( floatOutwards ) import FoldrBuildWW ( mkFoldrBuildWW ) @@ -46,9 +47,6 @@ import Id ( idType, toplevelishId, idWantsToBeINLINEd, import IdInfo ( mkUnfolding ) import LiberateCase ( liberateCase ) import MagicUFs ( MagicUnfoldingFun ) -import MainMonad ( writeMn, exitMn, thenMn, thenMn_, returnMn, - MainIO(..) - ) import Maybes ( maybeToBool ) import Outputable ( Outputable(..){-instance * (,) -} ) import PprCore ( pprCoreBinding, GenCoreExpr{-instance Outputable-} ) @@ -85,7 +83,7 @@ core2core :: [CoreToDo] -- spec of what core-to-core passes to do -> [TyCon] -- local data tycons and tycon specialisations -> FiniteMap TyCon [(Bool, [Maybe Type])] -> [CoreBinding] -- input... - -> MainIO + -> IO ([CoreBinding], -- results: program, plus... IdEnv UnfoldingDetails, -- unfoldings to be exported from here SpecialiseData) -- specialisation data @@ -94,32 +92,32 @@ core2core core_todos module_name ppr_style us local_tycons tycon_specs binds = BSCC("Core2Core") if null core_todos then -- very rare, I suspect... -- well, we still must do some renumbering - returnMn ( + return ( (substCoreBindings nullIdEnv nullTyVarEnv binds us, nullIdEnv, init_specdata) ) else (if do_verbose_core2core then - writeMn stderr "VERBOSE CORE-TO-CORE:\n" - else returnMn ()) `thenMn_` + hPutStr stderr "VERBOSE CORE-TO-CORE:\n" + else return ()) >> -- better do the main business foldl_mn do_core_pass (binds, us, nullIdEnv, init_specdata, zeroSimplCount) core_todos - `thenMn` \ (processed_binds, _, inline_env, spec_data, simpl_stats) -> + >>= \ (processed_binds, _, inline_env, spec_data, simpl_stats) -> (if opt_D_simplifier_stats - then writeMn stderr ("\nSimplifier Stats:\n") - `thenMn_` - writeMn stderr (showSimplCount simpl_stats) - `thenMn_` - writeMn stderr "\n" - else returnMn () - ) `thenMn_` - - returnMn (processed_binds, inline_env, spec_data) + then hPutStr stderr ("\nSimplifier Stats:\n") + >> + hPutStr stderr (showSimplCount simpl_stats) + >> + hPutStr stderr "\n" + else return () + ) >> + + return (processed_binds, inline_env, spec_data) ESCC where init_specdata = initSpecData local_tycons tycon_specs @@ -146,7 +144,7 @@ core2core core_todos module_name ppr_style us local_tycons tycon_specs binds CoreDoSimplify simpl_sw_chkr -> BSCC("CoreSimplify") begin_pass ("Simplify" ++ if switchIsOn simpl_sw_chkr SimplDoFoldrBuild - then " (foldr/build)" else "") `thenMn_` + then " (foldr/build)" else "") >> case (simplifyPgm binds simpl_sw_chkr simpl_stats us1) of (p, it_cnt, simpl_stats2) -> end_pass False us2 p inline_env spec_data simpl_stats2 @@ -157,56 +155,56 @@ core2core core_todos module_name ppr_style us local_tycons tycon_specs binds CoreDoFoldrBuildWorkerWrapper -> BSCC("CoreDoFoldrBuildWorkerWrapper") - begin_pass "FBWW" `thenMn_` + begin_pass "FBWW" >> case (mkFoldrBuildWW us1 binds) of { binds2 -> end_pass False us2 binds2 inline_env spec_data simpl_stats "FBWW" } ESCC CoreDoFoldrBuildWWAnal -> BSCC("CoreDoFoldrBuildWWAnal") - begin_pass "AnalFBWW" `thenMn_` + begin_pass "AnalFBWW" >> case (analFBWW binds) of { binds2 -> end_pass False us2 binds2 inline_env spec_data simpl_stats "AnalFBWW" } ESCC CoreLiberateCase -> BSCC("LiberateCase") - begin_pass "LiberateCase" `thenMn_` + begin_pass "LiberateCase" >> case (liberateCase lib_case_threshold binds) of { binds2 -> end_pass False us2 binds2 inline_env spec_data simpl_stats "LiberateCase" } ESCC CoreDoCalcInlinings1 -- avoid inlinings w/ cost-centres -> BSCC("CoreInlinings1") - begin_pass "CalcInlinings" `thenMn_` + begin_pass "CalcInlinings" >> case (calcInlinings False inline_env binds) of { inline_env2 -> end_pass False us2 binds inline_env2 spec_data simpl_stats "CalcInlinings" } ESCC CoreDoCalcInlinings2 -- allow inlinings w/ cost-centres -> BSCC("CoreInlinings2") - begin_pass "CalcInlinings" `thenMn_` + begin_pass "CalcInlinings" >> case (calcInlinings True inline_env binds) of { inline_env2 -> end_pass False us2 binds inline_env2 spec_data simpl_stats "CalcInlinings" } ESCC CoreDoFloatInwards -> BSCC("FloatInwards") - begin_pass "FloatIn" `thenMn_` + begin_pass "FloatIn" >> case (floatInwards binds) of { binds2 -> end_pass False us2 binds2 inline_env spec_data simpl_stats "FloatIn" } ESCC CoreDoFullLaziness -> BSCC("CoreFloating") - begin_pass "FloatOut" `thenMn_` + begin_pass "FloatOut" >> case (floatOutwards us1 binds) of { binds2 -> end_pass False us2 binds2 inline_env spec_data simpl_stats "FloatOut" } ESCC CoreDoStaticArgs -> BSCC("CoreStaticArgs") - begin_pass "StaticArgs" `thenMn_` + begin_pass "StaticArgs" >> case (doStaticArgs binds us1) of { binds2 -> end_pass False us2 binds2 inline_env spec_data simpl_stats "StaticArgs" -- Binds really should be dependency-analysed for static- @@ -216,14 +214,14 @@ core2core core_todos module_name ppr_style us local_tycons tycon_specs binds CoreDoStrictness -> BSCC("CoreStranal") - begin_pass "StrAnal" `thenMn_` + begin_pass "StrAnal" >> case (saWwTopBinds us1 binds) of { binds2 -> end_pass False us2 binds2 inline_env spec_data simpl_stats "StrAnal" } ESCC CoreDoSpecialising -> BSCC("Specialise") - begin_pass "Specialise" `thenMn_` + begin_pass "Specialise" >> case (specProgram us1 binds spec_data) of { (p, spec_data2@(SpecData _ spec_noerrs _ _ _ spec_errs spec_warn spec_tyerrs)) -> @@ -231,16 +229,16 @@ core2core core_todos module_name ppr_style us local_tycons tycon_specs binds -- if we got errors, we die straight away (if not spec_noerrs || (opt_ShowImportSpecs && not (isEmptyBag spec_warn)) then - writeMn stderr (ppShow 1000 {-pprCols-} + hPutStr stderr (ppShow 1000 {-pprCols-} (pprSpecErrs module_name spec_errs spec_warn spec_tyerrs)) - `thenMn_` writeMn stderr "\n" + >> hPutStr stderr "\n" else - returnMn ()) `thenMn_` + return ()) >> (if not spec_noerrs then -- Stop here if specialisation errors occured - exitMn 1 + ghcExit 1 else - returnMn ()) `thenMn_` + return ()) >> end_pass False us2 p inline_env spec_data2 simpl_stats "Specialise" } @@ -251,7 +249,7 @@ core2core core_todos module_name ppr_style us local_tycons tycon_specs binds -> error "ERROR: CoreDoDeforest: not built into compiler\n" #else -> BSCC("Deforestation") - begin_pass "Deforestation" `thenMn_` + begin_pass "Deforestation" >> case (deforestProgram binds us1) of { binds2 -> end_pass False us2 binds2 inline_env spec_data simpl_stats "Deforestation" } @@ -260,7 +258,7 @@ core2core core_todos module_name ppr_style us local_tycons tycon_specs binds CoreDoAutoCostCentres -> BSCC("AutoSCCs") - begin_pass "AutoSCCs" `thenMn_` + begin_pass "AutoSCCs" >> case (addAutoCostCentres module_name binds) of { binds2 -> end_pass False us2 binds2 inline_env spec_data simpl_stats "AutoSCCs" } @@ -274,8 +272,8 @@ core2core core_todos module_name ppr_style us local_tycons tycon_specs binds begin_pass = if opt_D_show_passes - then \ what -> writeMn stderr ("*** Core2Core: "++what++"\n") - else \ what -> returnMn () + then \ what -> hPutStr stderr ("*** Core2Core: "++what++"\n") + else \ what -> return () end_pass print us2 binds2 inline_env2 spec_data2@(SpecData spec_done _ _ _ _ _ _ _) @@ -284,18 +282,18 @@ core2core core_todos module_name ppr_style us local_tycons tycon_specs binds (if (do_verbose_core2core && not print) || (print && not do_verbose_core2core) then - writeMn stderr ("\n*** "++what++":\n") - `thenMn_` - writeMn stderr (ppShow 1000 + hPutStr stderr ("\n*** "++what++":\n") + >> + hPutStr stderr (ppShow 1000 (ppAboves (map (pprCoreBinding ppr_style) binds2))) - `thenMn_` - writeMn stderr "\n" + >> + hPutStr stderr "\n" else - returnMn ()) `thenMn_` + return ()) >> let linted_binds = core_linter what spec_done binds2 in - returnMn + return (linted_binds, -- processed binds, possibly run thru CoreLint us2, -- UniqueSupply for the next guy inline_env2, -- possibly-updated inline env @@ -304,8 +302,8 @@ core2core core_todos module_name ppr_style us local_tycons tycon_specs binds ) -- here so it can be inlined... -foldl_mn f z [] = returnMn z -foldl_mn f z (x:xs) = f z x `thenMn` \ zz -> +foldl_mn f z [] = return z +foldl_mn f z (x:xs) = f z x >>= \ zz -> foldl_mn f zz xs \end{code} diff --git a/ghc/compiler/simplCore/SimplVar.lhs b/ghc/compiler/simplCore/SimplVar.lhs index 84555a7ef6..44319c7c2c 100644 --- a/ghc/compiler/simplCore/SimplVar.lhs +++ b/ghc/compiler/simplCore/SimplVar.lhs @@ -61,11 +61,11 @@ completeVar env var args -> ASSERT( null args ) returnSmpl (Lit lit) - ConForm con args + ConForm con con_args -- Always inline constructors. -- See comments before completeLetBinding -> ASSERT( null args ) - returnSmpl (Con con args) + returnSmpl (Con con con_args) GenForm txt_occ form_summary template guidance -> considerUnfolding env var args diff --git a/ghc/compiler/simplStg/SimplStg.lhs b/ghc/compiler/simplStg/SimplStg.lhs index 9b9cbf1f4f..437f888819 100644 --- a/ghc/compiler/simplStg/SimplStg.lhs +++ b/ghc/compiler/simplStg/SimplStg.lhs @@ -31,7 +31,6 @@ import Id ( nullIdEnv, lookupIdEnv, addOneToIdEnv, growIdEnvList, isNullIdEnv, IdEnv(..), GenId{-instance Eq/Outputable -} ) -import MainMonad ( writeMn, thenMn_, thenMn, returnMn, MainIO(..) ) import Maybes ( maybeToBool ) import Name ( isExported ) import PprType ( GenType{-instance Outputable-} ) @@ -48,7 +47,7 @@ stg2stg :: [StgToDo] -- spec of what stg-to-stg passes to do -> PprStyle -- printing style (for debugging only) -> UniqSupply -- a name supply -> [StgBinding] -- input... - -> MainIO + -> IO ([StgBinding], -- output program... ([CostCentre], -- local cost-centres that need to be decl'd [CostCentre])) -- "extern" cost-centres @@ -58,16 +57,16 @@ stg2stg stg_todos module_name ppr_style us binds case (splitUniqSupply us) of { (us4now, us4later) -> (if do_verbose_stg2stg then - writeMn stderr "VERBOSE STG-TO-STG:\n" `thenMn_` - writeMn stderr (ppShow 1000 + hPutStr stderr "VERBOSE STG-TO-STG:\n" >> + hPutStr stderr (ppShow 1000 (ppAbove (ppStr ("*** Core2Stg:")) (ppAboves (map (ppr ppr_style) (setStgVarInfo False binds))) )) - else returnMn ()) `thenMn_` + else return ()) >> -- Do the main business! foldl_mn do_stg_pass (binds, us4now, ([],[])) stg_todos - `thenMn` \ (processed_binds, _, cost_centres) -> + >>= \ (processed_binds, _, cost_centres) -> -- Do essential wind-up: part (a) is SatStgRhs -- Not optional, because correct arity information is used by @@ -102,7 +101,7 @@ stg2stg stg_todos module_name ppr_style us binds then no_ind_binds else snd (unlocaliseStgBinds unlocal_tag nullIdEnv no_ind_binds) in - returnMn (setStgVarInfo do_let_no_escapes binds_to_mangle, cost_centres) + return (setStgVarInfo do_let_no_escapes binds_to_mangle, cost_centres) }} ESCC where @@ -172,23 +171,23 @@ stg2stg stg_todos module_name ppr_style us binds end_pass us2 what ccs binds2 = -- report verbosely, if required (if do_verbose_stg2stg then - writeMn stderr (ppShow 1000 + hPutStr stderr (ppShow 1000 (ppAbove (ppStr ("*** "++what++":")) (ppAboves (map (ppr ppr_style) binds2)) )) - else returnMn ()) `thenMn_` + else return ()) >> let linted_binds = stg_linter what binds2 in - returnMn (linted_binds, us2, ccs) + return (linted_binds, us2, ccs) -- return: processed binds -- UniqueSupply for the next guy to use -- cost-centres to be declared/registered (specialised) -- add to description of what's happened (reverse order) -- here so it can be inlined... -foldl_mn f z [] = returnMn z -foldl_mn f z (x:xs) = f z x `thenMn` \ zz -> +foldl_mn f z [] = return z +foldl_mn f z (x:xs) = f z x >>= \ zz -> foldl_mn f zz xs \end{code} diff --git a/ghc/compiler/specialise/SpecUtils.lhs b/ghc/compiler/specialise/SpecUtils.lhs index 4ce7a2b40f..7bac0935f0 100644 --- a/ghc/compiler/specialise/SpecUtils.lhs +++ b/ghc/compiler/specialise/SpecUtils.lhs @@ -24,7 +24,7 @@ module SpecUtils ( import Ubiq{-uitous-} import Bag ( isEmptyBag, bagToList ) -import Class ( getClassOpString, GenClass{-instance NamedThing-} ) +import Class ( classOpString, GenClass{-instance NamedThing-} ) import FiniteMap ( emptyFM, addListToFM_C, plusFM_C, keysFM, lookupWithDefaultFM ) @@ -314,7 +314,7 @@ pp_idspec sty pp_mod (_, id, tys, is_err) = let Just (cls, clsty, clsop) = const_method_maybe (_, cls_str) = moduleNamePair cls - clsop_str = getClassOpString clsop + clsop_str = classOpString clsop in ppCat [pp_mod, ppStr "{-# SPECIALIZE", @@ -328,7 +328,7 @@ pp_idspec sty pp_mod (_, id, tys, is_err) = let Just (cls, clsop, _) = default_method_maybe (_, cls_str) = moduleNamePair cls - clsop_str = getClassOpString clsop + clsop_str = classOpString clsop in ppCat [pp_mod, ppStr "{- instance", diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index fd242812a5..d0615f6bf6 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -42,7 +42,7 @@ import TcType ( TcType(..), TcRhoType(..), TcMaybe, TcTyVarSet(..), tcInstType, tcInstTcType, zonkTcType ) import Bag ( emptyBag, unitBag, unionBags, unionManyBags, listToBag, consBag ) -import Class ( Class(..), GenClass, ClassInstEnv(..), getClassInstEnv ) +import Class ( Class(..), GenClass, ClassInstEnv(..), classInstEnv ) import Id ( GenId, idType, mkInstId ) import MatchEnv ( lookupMEnv, insertMEnv ) import Name ( mkLocalName, getLocalName, Name ) @@ -154,73 +154,72 @@ newDicts :: InstOrigin s -> [(Class, TcType s)] -> NF_TcM s (LIE s, [TcIdOcc s]) newDicts orig theta - = tcGetSrcLoc `thenNF_Tc` \ loc -> - tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs -> - let + = tcGetSrcLoc `thenNF_Tc` \ loc -> + tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs -> + let mk_dict u (clas, ty) = Dict u clas ty orig loc dicts = zipWithEqual mk_dict new_uniqs theta - in - returnNF_Tc (listToBag dicts, map instToId dicts) + in + returnNF_Tc (listToBag dicts, map instToId dicts) newDictsAtLoc orig loc theta -- Local function, similar to newDicts, -- but with slightly different interface - = tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs -> - let + = tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs -> + let mk_dict u (clas, ty) = Dict u clas ty orig loc dicts = zipWithEqual mk_dict new_uniqs theta - in - returnNF_Tc (dicts, map instToId dicts) + in + returnNF_Tc (dicts, map instToId dicts) newMethod :: InstOrigin s -> TcIdOcc s -> [TcType s] -> NF_TcM s (LIE s, TcIdOcc s) newMethod orig id tys - = -- Get the Id type and instantiate it at the specified types - (case id of - RealId id -> let (tyvars, rho) = splitForAllTy (idType id) - in tcInstType (tyvars `zipEqual` tys) rho - TcId id -> let (tyvars, rho) = splitForAllTy (idType id) - in tcInstTcType (tyvars `zipEqual` tys) rho - ) `thenNF_Tc` \ rho_ty -> - - -- Our friend does the rest - newMethodWithGivenTy orig id tys rho_ty + = -- Get the Id type and instantiate it at the specified types + (case id of + RealId id -> let (tyvars, rho) = splitForAllTy (idType id) + in tcInstType (tyvars `zipEqual` tys) rho + TcId id -> let (tyvars, rho) = splitForAllTy (idType id) + in tcInstTcType (tyvars `zipEqual` tys) rho + ) `thenNF_Tc` \ rho_ty -> + -- Our friend does the rest + newMethodWithGivenTy orig id tys rho_ty newMethodWithGivenTy orig id tys rho_ty - = tcGetSrcLoc `thenNF_Tc` \ loc -> - tcGetUnique `thenNF_Tc` \ new_uniq -> - let + = tcGetSrcLoc `thenNF_Tc` \ loc -> + tcGetUnique `thenNF_Tc` \ new_uniq -> + let meth_inst = Method new_uniq id tys rho_ty orig loc - in - returnNF_Tc (unitLIE meth_inst, instToId meth_inst) + in + returnNF_Tc (unitLIE meth_inst, instToId meth_inst) newMethodAtLoc :: InstOrigin s -> SrcLoc -> Id -> [TcType s] -> NF_TcM s (Inst s, TcIdOcc s) newMethodAtLoc orig loc real_id tys -- Local function, similar to newMethod but with -- slightly different interface - = -- Get the Id type and instantiate it at the specified types - let - (tyvars,rho) = splitForAllTy (idType real_id) - in - tcInstType (tyvars `zipEqual` tys) rho `thenNF_Tc` \ rho_ty -> - tcGetUnique `thenNF_Tc` \ new_uniq -> - let + = -- Get the Id type and instantiate it at the specified types + let + (tyvars,rho) = splitForAllTy (idType real_id) + in + tcInstType (tyvars `zipEqual` tys) rho `thenNF_Tc` \ rho_ty -> + tcGetUnique `thenNF_Tc` \ new_uniq -> + let meth_inst = Method new_uniq (RealId real_id) tys rho_ty orig loc - in - returnNF_Tc (meth_inst, instToId meth_inst) + in + returnNF_Tc (meth_inst, instToId meth_inst) newOverloadedLit :: InstOrigin s -> OverloadedLit -> TcType s -> NF_TcM s (LIE s, TcIdOcc s) newOverloadedLit orig lit ty - = tcGetSrcLoc `thenNF_Tc` \ loc -> - tcGetUnique `thenNF_Tc` \ new_uniq -> - let + = tcGetSrcLoc `thenNF_Tc` \ loc -> + tcGetUnique `thenNF_Tc` \ new_uniq -> + let lit_inst = LitInst new_uniq lit ty orig loc - in - returnNF_Tc (unitLIE lit_inst, instToId lit_inst) + in + returnNF_Tc (unitLIE lit_inst, instToId lit_inst) \end{code} @@ -473,7 +472,7 @@ ambiguous dictionaries. lookupClassInstAtSimpleType :: Class -> Type -> Maybe Id lookupClassInstAtSimpleType clas ty - = case (lookupMEnv matchTy (getClassInstEnv clas) ty) of + = case (lookupMEnv matchTy (classInstEnv clas) ty) of Nothing -> Nothing Just (dfun,_) -> ASSERT( null tyvars && null theta ) Just dfun @@ -499,7 +498,7 @@ mkInstSpecEnv :: Class -- class mkInstSpecEnv clas inst_ty inst_tvs inst_theta = mkSpecEnv (catMaybes (map maybe_spec_info matches)) where - matches = matchMEnv matchTy (getClassInstEnv clas) inst_ty + matches = matchMEnv matchTy (classInstEnv clas) inst_ty maybe_spec_info (_, match_info, MkInstTemplate dfun _ []) = Just (SpecInfo (map (assocMaybe match_info) inst_tvs) (length inst_theta) dfun) @@ -601,7 +600,7 @@ get_inst_env clas (DerivingOrigin inst_mapper _ _) = fst (inst_mapper clas) get_inst_env clas (InstanceSpecOrigin inst_mapper _ _) = fst (inst_mapper clas) -get_inst_env clas other_orig = getClassInstEnv clas +get_inst_env clas other_orig = classInstEnv clas pprOrigin :: PprStyle -> InstOrigin s -> Pretty diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index 330075da1a..df5924d5fe 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -35,14 +35,15 @@ import TcType ( TcType(..), TcTyVar(..), tcInstType, tcInstSigTyVars ) import TcKind ( TcKind ) import Bag ( foldBag ) -import Class ( GenClass, mkClass, mkClassOp, getClassBigSig, - getClassOps, getClassOpString, getClassOpLocalType ) -import CoreUtils ( escErrorMsg ) +import Class ( GenClass, mkClass, mkClassOp, classBigSig, + classOps, classOpString, classOpLocalType, + classOpTagByString + ) import Id ( mkSuperDictSelId, mkMethodSelId, mkDefaultMethodId, idType ) import IdInfo ( noIdInfo ) import Name ( isLocallyDefined, moduleNamePair, getLocalName ) -import PrelVals ( pAT_ERROR_ID ) +import PrelVals ( nO_DEFAULT_METHOD_ERROR_ID ) import PprStyle import Pretty import PprType ( GenType, GenTyVar, GenClassOp ) @@ -87,10 +88,11 @@ tcClassDecl1 rec_inst_mapper `thenTc` \ sig_stuff -> -- MAKE THE CLASS OBJECT ITSELF - tcGetUnique `thenNF_Tc` \ uniq -> +-- BOGUS: +-- tcGetUnique `thenNF_Tc` \ uniq -> let (ops, op_sel_ids, defm_ids) = unzip3 sig_stuff - clas = mkClass uniq (getName class_name) rec_tyvar + clas = mkClass (uniqueOf class_name) (getName class_name) rec_tyvar scs sc_sel_ids ops op_sel_ids defm_ids rec_class_inst_env in @@ -176,8 +178,9 @@ tcClassSig rec_clas rec_clas_tyvar rec_classop_spec_fn full_theta = (rec_clas, mkTyVarTy rec_clas_tyvar) : theta global_ty = mkSigmaTy full_tyvars full_theta tau local_ty = mkSigmaTy tyvars theta tau - class_op = mkClassOp (getLocalName op_name) - (panic "(getTagFromClassOpName op_name)TcClassDecl"{-(getTagFromClassOpName op_name)-}) + class_op_nm = getLocalName op_name + class_op = mkClassOp class_op_nm + (classOpTagByString rec_clas{-yeeps!-} class_op_nm) local_ty in @@ -259,7 +262,7 @@ tcClassDecl2 (ClassDecl context class_name tcLookupClass class_name `thenNF_Tc` \ (_, clas) -> let (tyvar, scs, sc_sel_ids, ops, op_sel_ids, defm_ids) - = getClassBigSig clas + = classBigSig clas in tcInstSigTyVars [tyvar] `thenNF_Tc` \ ([clas_tyvar], _, _) -> @@ -292,10 +295,10 @@ buildSelectors clas clas_tyvar clas_tc_tyvar scs sc_sel_ids ops op_sel_ids -- Make new Ids for the components of the dictionary let clas_tyvar_ty = mkTyVarTy clas_tc_tyvar - mk_op_ty = tcInstType [(clas_tyvar, clas_tyvar_ty)] . getClassOpLocalType + mk_op_ty = tcInstType [(clas_tyvar, clas_tyvar_ty)] . classOpLocalType in mapNF_Tc mk_op_ty ops `thenNF_Tc` \ op_tys -> - newLocalIds (map getClassOpString ops) op_tys `thenNF_Tc` \ method_ids -> + newLocalIds (map classOpString ops) op_tys `thenNF_Tc` \ method_ids -> newDicts ClassDeclOrigin [ (super_clas, clas_tyvar_ty) @@ -473,6 +476,7 @@ buildDefaultMethodBinds clas clas_tyvar = -- Deal with the method declarations themselves mapNF_Tc unZonkId default_method_ids `thenNF_Tc` \ tc_defm_ids -> processInstBinds + clas (makeClassDeclDefaultMethodRhs clas default_method_ids) [] -- No tyvars in scope for "this inst decl" emptyLIE -- No insts available @@ -501,21 +505,17 @@ makeClassDeclDefaultMethodRhs clas method_ids tag returnNF_Tc (mkHsTyLam tyvars ( mkHsDictLam dict_ids ( - HsApp (mkHsTyApp (HsVar (RealId pAT_ERROR_ID)) [tau]) + HsApp (mkHsTyApp (HsVar (RealId nO_DEFAULT_METHOD_ERROR_ID)) [tau]) (HsLitOut (HsString (_PK_ error_msg)) stringTy)))) where (clas_mod, clas_name) = moduleNamePair clas method_id = method_ids !! (tag-1) - class_op = (getClassOps clas) !! (tag-1) - - error_msg = "%D" -- => No default method for \" - ++ unencoded_part_of_msg + class_op = (classOps clas) !! (tag-1) - unencoded_part_of_msg = escErrorMsg ( - _UNPK_ clas_mod ++ "." ++ _UNPK_ clas_name ++ "." - ++ (ppShow 80 (ppr PprForUser class_op)) - ++ "\"" ) + error_msg = _UNPK_ clas_mod ++ "." ++ _UNPK_ clas_name ++ "." + ++ (ppShow 80 (ppr PprForUser class_op)) + ++ "\"" \end{code} diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index 6e29cc601e..b0791642cb 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -34,7 +34,7 @@ import RnUtils ( RnEnv(..) ) import RnBinds ( rnMethodBinds, rnTopBinds ) import Bag ( emptyBag{-ToDo:rm-}, Bag, isEmptyBag, unionBags, listToBag ) -import Class ( GenClass, getClassKey ) +import Class ( GenClass, classKey ) import CmdLineOpts ( opt_CompilingPrelude ) import ErrUtils ( pprBagOfErrors, addErrLoc, Error(..) ) import Id ( dataConSig, dataConArity ) @@ -281,7 +281,7 @@ makeDerivEqns chk_out :: [(Class, TyCon)] -> (Class, TyCon) -> TcM s () chk_out whole_deriving_list this_one@(clas, tycon) = let - clas_key = getClassKey clas + clas_key = classKey clas in -- Are things OK for deriving Enum (if appropriate)? @@ -563,7 +563,7 @@ gen_inst_info modname fixities deriver_rn_env (if from_here then mbinds else EmptyMonoBinds) from_here modname locn []) where - clas_key = getClassKey clas + clas_key = classKey clas clas_Name = let (mod, nm) = moduleNamePair clas in ClassName clas_key (mkPreludeCoreName mod nm) [] @@ -672,7 +672,7 @@ gen_taggery_Names eqns where is_in_eqns clas_key tycon [] = False is_in_eqns clas_key tycon ((c,t,_,_):eqns) - = (clas_key == getClassKey c && tycon == t) + = (clas_key == classKey c && tycon == t) || is_in_eqns clas_key tycon eqns \end{code} diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index 5d427a3e7a..a30ed69da2 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -32,7 +32,7 @@ import TcType ( TcType(..), TcMaybe, TcTyVar(..), TcTyVarSet(..), import TyVar ( mkTyVar, tyVarKind, unionTyVarSets, emptyTyVarSet ) import Type ( tyVarsOfTypes ) import TyCon ( TyCon, Arity(..), tyConKind, synTyConArity ) -import Class ( Class(..), GenClass, getClassSig ) +import Class ( Class(..), GenClass, classSig ) import TcMonad diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 2813277f57..6b2bec7a86 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -41,7 +41,7 @@ import TcType ( TcType(..), TcMaybe(..), newTyVarTy, zonkTcTyVars, zonkTcType ) import TcKind ( TcKind ) -import Class ( Class(..), getClassSig ) +import Class ( Class(..), classSig ) import FieldLabel ( fieldLabelName ) import Id ( Id(..), GenId, idType, dataConFieldLabels, dataConSig ) import Kind ( Kind, mkBoxedTypeKind, mkTypeKind, mkArrowKind ) @@ -394,7 +394,7 @@ tcExpr (RecordUpd record_expr rbinds) -- Check that the field names are plausible zonkTcType record_ty `thenNF_Tc` \ record_ty' -> let - (tycon, inst_tys, data_cons) = getAppDataTyCon record_ty' + (tycon, inst_tys, data_cons) = _trace "getAppDataTyCon.TcExpr" $ getAppDataTyCon record_ty' -- The record binds are non-empty (syntax); so at least one field -- label will have been unified with record_ty by tcRecordBinds; -- field labels must be of data type; hencd the getAppDataTyCon must succeed. diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index e910658c12..c45d8099dc 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -57,14 +57,15 @@ import CmdLineOpts ( opt_GlasgowExts, opt_CompilingPrelude, opt_OmitDefaultInstanceMethods, opt_SpecialiseOverloaded ) import Class ( GenClass, GenClassOp, - isCcallishClass, getClassBigSig, - getClassOps, getClassOpLocalType ) -import CoreUtils ( escErrorMsg ) + isCcallishClass, classBigSig, + classOps, classOpLocalType, + classOpTagByString + ) import Id ( GenId, idType, isDefaultMethodId_maybe ) import ListSetOps ( minusList ) import Maybes ( maybeToBool, expectJust ) import Name ( getLocalName, origName, nameOf ) -import PrelInfo ( pAT_ERROR_ID ) +import PrelVals ( nO_EXPLICIT_METHOD_ERROR_ID ) import PrelMods ( pRELUDE ) import PprType ( GenType, GenTyVar, GenClass, GenClassOp, TyCon, pprParendGenType @@ -358,7 +359,7 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_ty let (class_tyvar, super_classes, sc_sel_ids, - class_ops, op_sel_ids, defm_ids) = getClassBigSig clas + class_ops, op_sel_ids, defm_ids) = classBigSig clas in tcInstType tenv inst_ty `thenNF_Tc` \ inst_ty' -> tcInstTheta tenv dfun_theta `thenNF_Tc` \ dfun_theta' -> @@ -388,7 +389,7 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_ty else makeInstanceDeclDefaultMethodExpr origin meth_ids defm_ids inst_ty' this_dict_id in - processInstBinds mk_method_expr inst_tyvars' avail_insts meth_ids monobinds + processInstBinds clas mk_method_expr inst_tyvars' avail_insts meth_ids monobinds `thenTc` \ (insts_needed, method_mbinds) -> let -- Create the dict and method binds @@ -546,23 +547,20 @@ makeInstanceDeclNoDefaultExpr origin meth_ids defm_ids inst_ty clas inst_mod tag `thenNF_Tc_` returnNF_Tc (mkHsTyLam op_tyvars ( mkHsDictLam op_dicts ( - HsApp (mkHsTyApp (HsVar (RealId pAT_ERROR_ID)) [op_tau]) + HsApp (mkHsTyApp (HsVar (RealId nO_EXPLICIT_METHOD_ERROR_ID)) [op_tau]) (HsLitOut (HsString (_PK_ error_msg)) stringTy)))) where idx = tag - 1 meth_id = meth_ids !! idx - clas_op = (getClassOps clas) !! idx + clas_op = (classOps clas) !! idx defm_id = defm_ids !! idx (op_tyvars,op_theta,op_tau) = splitSigmaTy (tcIdType meth_id) Just (_, _, err_defm_ok) = isDefaultMethodId_maybe defm_id - error_msg = "%E" -- => No explicit method for \" - ++ escErrorMsg error_str - mod_str = case inst_mod of { Nothing -> pRELUDE; Just m -> m } - error_str = _UNPK_ mod_str ++ "." ++ _UNPK_ clas_name ++ "." + error_msg = _UNPK_ mod_str ++ "." ++ _UNPK_ clas_name ++ "." ++ (ppShow 80 (ppr PprForUser inst_ty)) ++ "." ++ (ppShow 80 (ppr PprForUser clas_op)) ++ "\"" @@ -588,7 +586,8 @@ do differs between instance and class decls. \begin{code} processInstBinds - :: (Int -> NF_TcM s (TcExpr s)) -- Function to make default method + :: Class + -> (Int -> NF_TcM s (TcExpr s)) -- Function to make default method -> [TcTyVar s] -- Tyvars for this instance decl -> LIE s -- available Insts -> [TcIdOcc s] -- Local method ids in tag order @@ -597,10 +596,10 @@ processInstBinds -> TcM s (LIE s, -- These are required TcMonoBinds s) -processInstBinds mk_default_method_rhs inst_tyvars avail_insts method_ids monobinds +processInstBinds clas mk_default_method_rhs inst_tyvars avail_insts method_ids monobinds = -- Process the explicitly-given method bindings - processInstBinds1 inst_tyvars avail_insts method_ids monobinds + processInstBinds1 clas inst_tyvars avail_insts method_ids monobinds `thenTc` \ (tags, insts_needed_in_methods, method_binds) -> -- Find the methods not handled, and make default method bindings for them. @@ -621,7 +620,8 @@ processInstBinds mk_default_method_rhs inst_tyvars avail_insts method_ids monobi \begin{code} processInstBinds1 - :: [TcTyVar s] -- Tyvars for this instance decl + :: Class + -> [TcTyVar s] -- Tyvars for this instance decl -> LIE s -- available Insts -> [TcIdOcc s] -- Local method ids in tag order (instance tyvars are free), -> RenamedMonoBinds @@ -629,13 +629,13 @@ processInstBinds1 LIE s, -- These are required TcMonoBinds s) -processInstBinds1 inst_tyvars avail_insts method_ids EmptyMonoBinds +processInstBinds1 clas inst_tyvars avail_insts method_ids EmptyMonoBinds = returnTc ([], emptyLIE, EmptyMonoBinds) -processInstBinds1 inst_tyvars avail_insts method_ids (AndMonoBinds mb1 mb2) - = processInstBinds1 inst_tyvars avail_insts method_ids mb1 +processInstBinds1 clas inst_tyvars avail_insts method_ids (AndMonoBinds mb1 mb2) + = processInstBinds1 clas inst_tyvars avail_insts method_ids mb1 `thenTc` \ (op_tags1,dicts1,method_binds1) -> - processInstBinds1 inst_tyvars avail_insts method_ids mb2 + processInstBinds1 clas inst_tyvars avail_insts method_ids mb2 `thenTc` \ (op_tags2,dicts2,method_binds2) -> returnTc (op_tags1 ++ op_tags2, dicts1 `unionBags` dicts2, @@ -643,7 +643,7 @@ processInstBinds1 inst_tyvars avail_insts method_ids (AndMonoBinds mb1 mb2) \end{code} \begin{code} -processInstBinds1 inst_tyvars avail_insts method_ids mbind +processInstBinds1 clas inst_tyvars avail_insts method_ids mbind = -- Find what class op is being defined here. The complication is -- that we could have a PatMonoBind or a FunMonoBind. If the @@ -662,7 +662,8 @@ processInstBinds1 inst_tyvars avail_insts method_ids mbind tcAddSrcLoc locn $ -- Make a method id for the method - let tag = panic "processInstBinds1:getTagFromClassOpName"{-getTagFromClassOpName op-} + let + tag = classOpTagByString clas occ method_id = method_ids !! (tag-1) method_ty = tcIdType method_id diff --git a/ghc/compiler/typecheck/TcInstUtil.lhs b/ghc/compiler/typecheck/TcInstUtil.lhs index 9d5a403d9d..599d53f2af 100644 --- a/ghc/compiler/typecheck/TcInstUtil.lhs +++ b/ghc/compiler/typecheck/TcInstUtil.lhs @@ -25,7 +25,7 @@ import Inst ( InstanceMapper(..) ) import Bag ( bagToList ) import Class ( GenClass, GenClassOp, ClassInstEnv(..), - getClassBigSig, getClassOps, getClassOpLocalType ) + classBigSig, classOps, classOpLocalType ) import CoreSyn ( GenCoreExpr(..), mkValLam, mkTyApp ) import Id ( GenId, mkDictFunId, mkConstMethodId, mkSysLocal ) import MatchEnv ( nullMEnv, insertMEnv ) @@ -128,7 +128,7 @@ mkInstanceRelatedIds from_here inst_mod inst_pragmas returnTc (dfun_id, dfun_theta, const_meth_ids) where - (class_tyvar, super_classes, _, class_ops, _, _) = getClassBigSig clas + (class_tyvar, super_classes, _, class_ops, _, _) = classBigSig clas tenv = [(class_tyvar, inst_ty)] super_class_theta = super_classes `zip` (repeat inst_ty) @@ -150,7 +150,7 @@ mkInstanceRelatedIds from_here inst_mod inst_pragmas from_here inst_mod id_info) ) where - op_ty = getClassOpLocalType op + op_ty = classOpLocalType op meth_ty = mkForAllTys inst_tyvars (instantiateTy tenv op_ty) {- LATER inline_me = isIn "mkInstanceRelatedIds" op ops_to_inline @@ -199,7 +199,7 @@ buildInstanceEnv :: [InstInfo] -- Non-empty, and all for same class buildInstanceEnv inst_infos@((InstInfo clas _ _ _ _ _ _ _ _ _ _ _) : _) = foldlTc addClassInstance - (nullMEnv, [(op, nullSpecEnv) | op <- getClassOps clas]) + (nullMEnv, [(op, nullSpecEnv) | op <- classOps clas]) inst_infos `thenTc` \ (class_inst_env, op_inst_envs) -> returnTc (clas, (class_inst_env, @@ -272,7 +272,7 @@ addClassInstance Failed (tys', rhs') -> panic "TcInstDecls:add_const_meth" Succeeded spec_env' -> spec_env' ) where - (local_tyvars, _) = splitForAllTy (getClassOpLocalType op) + (local_tyvars, _) = splitForAllTy (classOpLocalType op) local_tyvar_tys = mkTyVarTys local_tyvars rhs = mkValLam [dict] (mkTyApp (mkTyApp (Var meth_id) (mkTyVarTys inst_tyvars)) diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 9f2df4d2df..dccaab2a2e 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -7,10 +7,16 @@ #include "HsVersions.h" module TcModule ( - tcModule + typecheckModule, + TcResults(..), + TcResultBinds(..), + TcIfaceInfo(..), + TcLocalTyConsAndClasses(..), + TcSpecialiseRequests(..), + TcDDumpDeriv(..) ) where -import Ubiq +import Ubiq{-uitous-} import HsSyn ( HsModule(..), HsBinds(..), Bind, HsExpr, TyDecl, SpecDataSig, ClassDecl, InstDecl, @@ -37,6 +43,7 @@ import TcTyClsDecls ( tcTyAndClassDecls1 ) import Bag ( listToBag ) import Class ( GenClass ) +import ErrUtils ( Warning(..), Error(..) ) import Id ( GenId, isDataCon, isMethodSelId, idType ) import Maybes ( catMaybes ) import Name ( isExported, isLocallyDefined ) @@ -51,35 +58,64 @@ import UniqFM ( lookupUFM_Directly, lookupWithDefaultUFM_Directly, import Unique ( iOTyConKey, mainIdKey, mainPrimIOIdKey ) import Util - import FiniteMap ( emptyFM ) tycon_specs = emptyFM - - \end{code} +Outside-world interface: \begin{code} -tcModule :: RnEnv -- for renaming derivings - -> RenamedHsModule -- input - -> TcM s ((TypecheckedHsBinds, -- record selector binds - TypecheckedHsBinds, -- binds from class decls; does NOT - -- include default-methods bindings - TypecheckedHsBinds, -- binds from instance decls; INCLUDES - -- class default-methods binds - TypecheckedHsBinds, -- binds from value decls - - [(Id, TypecheckedHsExpr)]), -- constant instance binds - - ([RenamedFixityDecl], [Id], [TyCon], [Class], Bag InstInfo), - -- things for the interface generator - - ([TyCon], [Class]), - -- environments of info from this module only - - FiniteMap TyCon [(Bool, [Maybe Type])], - -- source tycon specialisation requests +-- Convenient type synonyms first: +type TcResults + = (TcResultBinds, + TcIfaceInfo, + TcLocalTyConsAndClasses, + TcSpecialiseRequests, + TcDDumpDeriv) + +type TcResultBinds + = (TypecheckedHsBinds, -- record selector binds + TypecheckedHsBinds, -- binds from class decls; does NOT + -- include default-methods bindings + TypecheckedHsBinds, -- binds from instance decls; INCLUDES + -- class default-methods binds + TypecheckedHsBinds, -- binds from value decls + + [(Id, TypecheckedHsExpr)]) -- constant instance binds + +type TcIfaceInfo -- things for the interface generator + = ([Id], [TyCon], [Class], Bag InstInfo) + +type TcLocalTyConsAndClasses -- things defined in this module + = ([TyCon], [Class]) + -- not sure the classes are used at all (ToDo) + +type TcSpecialiseRequests + = FiniteMap TyCon [(Bool, [Maybe Type])] + -- source tycon specialisation requests + +type TcDDumpDeriv + = PprStyle -> Pretty + +--------------- +typecheckModule + :: UniqSupply + -> RnEnv -- for renaming derivings + -> RenamedHsModule + -> MaybeErr + (TcResults, -- if all goes well... + Bag Warning) -- (we can still get warnings) + (Bag Error, -- if we had errors... + Bag Warning) + +typecheckModule us rn_env mod + = initTc us (tcModule rn_env mod) +\end{code} - PprStyle -> Pretty) -- -ddump-deriving info +The internal monster: +\begin{code} +tcModule :: RnEnv -- for renaming derivings + -> RenamedHsModule -- input + -> TcM s TcResults -- output tcModule rn_env (HsModule mod_name verion exports imports fixities @@ -194,7 +230,7 @@ tcModule rn_env (record_binds', cls_binds', inst_binds', val_binds', const_insts'), -- the next collection is just for mkInterface - (fixities, exported_ids', tycons, classes, inst_info), + (exported_ids', tycons, classes, inst_info), (local_tycons, local_classes), diff --git a/ghc/compiler/typecheck/TcPragmas.lhs b/ghc/compiler/typecheck/TcPragmas.lhs index 59153c52f3..cebb20dbbb 100644 --- a/ghc/compiler/typecheck/TcPragmas.lhs +++ b/ghc/compiler/typecheck/TcPragmas.lhs @@ -557,21 +557,21 @@ tc_unfolding e (ImpUnfolding guidance uf_core) clas = lookupCE rec_ce c super_clas = lookupCE rec_ce sc in - returnB_Tc (getSuperDictSelId clas super_clas) + returnB_Tc (classSuperDictSelId clas super_clas) tc_uf_Id lve (ClassOpUfId c op_name) = let clas = lookupCE rec_ce c op = lookup_class_op clas op_name in - returnB_Tc (getClassOpId clas op) + returnB_Tc (classOpId clas op) tc_uf_Id lve (DefaultMethodUfId c op_name) = let clas = lookupCE rec_ce c op = lookup_class_op clas op_name in - returnB_Tc (getDefaultMethodId clas op) + returnB_Tc (classDefaultMethodId clas op) tc_uf_Id lve uf_id@(DictFunUfId c ty) = tc_uf_type nullTVE ty `thenB_Tc` \ new_ty -> @@ -624,7 +624,7 @@ tc_unfolding e (ImpUnfolding guidance uf_core) --------------- lookup_class_op clas (ClassOpName _ _ _ tag) - = getClassOps clas !! (tag - 1) + = classOps clas !! (tag - 1) --------------------------------------------------------------------- tc_uf_type :: TVE -> UnfoldingType Name -> Baby_TcM Type diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index ff30d6f70d..044ddab73c 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -31,11 +31,13 @@ import Unify ( unifyTauTy ) import Bag ( Bag, unitBag, listToBag, foldBag, filterBag, emptyBag, bagToList, snocBag, consBag, unionBags, isEmptyBag ) import Class ( isNumericClass, isStandardClass, isCcallishClass, - isSuperClassOf, getSuperDictSelId ) + isSuperClassOf, classSuperDictSelId + ) import Id ( GenId ) import Maybes ( expectJust, firstJust, catMaybes, seqMaybe, maybeToBool, Maybe(..) ) import Outputable ( Outputable(..){-instance * []-} ) -import PprType ( GenType, GenTyVar ) +import PprStyle--ToDo:rm +import PprType ( GenType, GenTyVar, GenClass{-instance Outputable;ToDo:rm-} ) import Pretty import SrcLoc ( mkUnknownSrcLoc ) import Util @@ -271,7 +273,8 @@ tcSimplifyCheckThetas :: InstOrigin s -- context; for error msg -> [(Class, TauType)] -- Simplify this -> TcM s () -tcSimplifyCheckThetas = panic "tcSimplifyCheckThetas" +tcSimplifyCheckThetas x y = _trace "tcSimplifyCheckThetas: does nothing" $ + returnTc () {- LATER tcSimplifyCheckThetas origin theta @@ -489,7 +492,7 @@ trySC givens wanted@(Dict _ wanted_class wanted_ty wanted_orig loc) let mk_bind (dict,clas) dict_sub@(Dict _ dict_sub_class ty _ _) = ((dict_sub, dict_sub_class), - (instToId dict, DictApp (TyApp (HsVar (RealId (getSuperDictSelId dict_sub_class + (instToId dict, DictApp (TyApp (HsVar (RealId (classSuperDictSelId dict_sub_class clas))) [ty]) [instToId dict_sub])) @@ -698,15 +701,9 @@ all are standard; or all are CcallIsh. isStandardNumericDefaultable :: [Class] -> Bool isStandardNumericDefaultable classes - | any isNumericClass classes && all isStandardClass classes - = True - -isStandardNumericDefaultable classes - | all isCcallishClass classes - = True - -isStandardNumericDefaultable classes - = False + = --pprTrace "isStdNumeric:\n" (ppAboves [ppCat (map (ppr PprDebug) classes), ppCat (map (ppr PprDebug . isNumericClass) classes), ppCat (map (ppr PprDebug . isStandardClass) classes), ppCat (map (ppr PprDebug . isCcallishClass) classes)]) $ + (any isNumericClass classes && all isStandardClass classes) + || (all isCcallishClass classes) \end{code} diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index 0ff60b66c6..70c05648ea 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -30,7 +30,7 @@ import TcKind ( TcKind, newKindVars ) import TcTyDecls ( tcTyDecl, mkDataBinds ) import Bag -import Class ( Class(..), getClassSelIds ) +import Class ( Class(..), classSelIds ) import Digraph ( findSCCs, SCC(..) ) import Name ( getSrcLoc ) import PprStyle @@ -130,7 +130,7 @@ tcGroup inst_mapper decls tcSetEnv final_env $ tcExtendGlobalValEnv (concat data_ids_s) $ - tcExtendGlobalValEnv (concat (map getClassSelIds classes)) $ + tcExtendGlobalValEnv (concat (map classSelIds classes)) $ tcGetEnv `thenNF_Tc` \ really_final_env -> returnTc (really_final_env, foldr ThenBinds EmptyBinds binds) @@ -232,8 +232,8 @@ get_cons cons get_con (RecConDecl _ nbtys _) = unionManyUniqSets (map (get_bty.snd) nbtys) - get_bty (Banged ty) = get_ty ty - get_bty (Unbanged ty) = get_ty ty + get_bty (Banged ty) = get_pty ty + get_bty (Unbanged ty) = get_pty ty get_ty (MonoTyVar tv) = emptyUniqSet diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index f167f89d4c..38e25c9918 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -27,7 +27,7 @@ import TcHsSyn ( mkHsTyLam, mkHsDictLam, tcIdType, zonkId, TcHsBinds(..), TcIdOcc(..) ) import Inst ( newDicts, InstOrigin(..), Inst ) -import TcMonoType ( tcMonoTypeKind, tcMonoType, tcContext ) +import TcMonoType ( tcMonoTypeKind, tcMonoType, tcPolyType, tcContext ) import TcType ( tcInstTyVars, tcInstType, tcInstId ) import TcEnv ( tcLookupTyCon, tcLookupTyVar, tcLookupClass, newLocalId, newLocalIds @@ -382,16 +382,16 @@ tcConDecl tycon tyvars ctxt (RecConDecl name fields src_loc) returnTc data_con tcField (field_label_names, bty) - = tcMonoType (get_ty bty) `thenTc` \ field_ty -> + = tcPolyType (get_pty bty) `thenTc` \ field_ty -> returnTc [(name, field_ty, get_strictness bty) | name <- field_label_names] tcDataCon tycon tyvars ctxt name btys src_loc = tcAddSrcLoc src_loc $ let stricts = map get_strictness btys - tys = map get_ty btys + tys = map get_pty btys in - mapTc tcMonoType tys `thenTc` \ arg_tys -> + mapTc tcPolyType tys `thenTc` \ arg_tys -> let data_con = mkDataCon (getName name) stricts @@ -412,11 +412,11 @@ thinContext arg_tys ctxt arg_tyvars = tyVarsOfTypes arg_tys in_arg_tys (clas,ty) = getTyVar "tcDataCon" ty `elementOfTyVarSet` arg_tyvars -get_strictness (Banged ty) = MarkedStrict -get_strictness (Unbanged ty) = NotMarkedStrict +get_strictness (Banged _) = MarkedStrict +get_strictness (Unbanged _) = NotMarkedStrict -get_ty (Banged ty) = ty -get_ty (Unbanged ty) = ty +get_pty (Banged ty) = ty +get_pty (Unbanged ty) = ty \end{code} diff --git a/ghc/compiler/typecheck/Typecheck.lhs b/ghc/compiler/typecheck/Typecheck.lhs deleted file mode 100644 index f9e79c8c6e..0000000000 --- a/ghc/compiler/typecheck/Typecheck.lhs +++ /dev/null @@ -1,73 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 -% -\section[Typecheck]{Outside-world interfaces to the typechecker} - -\begin{code} -#include "HsVersions.h" - -module Typecheck ( - typecheckModule, InstInfo - ) where - -import Ubiq -import TcMonad -import TcModule ( tcModule ) -import TcInstUtil ( InstInfo ) - -import HsSyn -import RnHsSyn -import TcHsSyn - -import ErrUtils ( Warning(..), Error(..) ) -import Pretty -import RnUtils ( RnEnv(..) ) -import Maybes ( MaybeErr(..) ) -\end{code} - -The typechecker stuff lives inside a complicated world of @TcM@ -monadery. - -ToDo: Interfaces for interpreter ... - Typecheck an expression - Typecheck an interface - -\begin{code} -typecheckModule - :: UniqSupply -- name supply in - -> RnEnv -- renamer env (for doing derivings) - -> RenamedHsModule -- input module - - -> -- OUTPUTS ... - MaybeErr - -- SUCCESS ... - (((TypecheckedHsBinds, -- record selector definitions - TypecheckedHsBinds, -- binds from class decls; does NOT - -- include default-methods bindings - TypecheckedHsBinds, -- binds from instance decls; INCLUDES - -- class default-methods binds - TypecheckedHsBinds, -- binds from value decls - - [(Id, TypecheckedHsExpr)] -- constant instance binds - ), - - ([RenamedFixityDecl], [Id], [TyCon], [Class], Bag InstInfo), - -- things for the interface generator - - ([TyCon], [Class]), - -- environments of info from this module only - - FiniteMap TyCon [(Bool, [Maybe Type])], - -- source tycon specialisation requests - - PprStyle->Pretty), -- stuff to print for -ddump-deriving - - Bag Warning) -- pretty-print this to get warnings - - -- FAILURE ... - (Bag Error, -- pretty-print this to get errors - Bag Warning) -- pretty-print this to get warnings - -typecheckModule us rn_env mod - = initTc us (tcModule rn_env mod) -\end{code} diff --git a/ghc/compiler/types/Class.lhs b/ghc/compiler/types/Class.lhs index 73001e7488..e5db71fc2f 100644 --- a/ghc/compiler/types/Class.lhs +++ b/ghc/compiler/types/Class.lhs @@ -10,22 +10,21 @@ module Class ( GenClass(..), Class(..), mkClass, - getClassKey, getClassOps, getClassSelIds, - getSuperDictSelId, getClassOpId, getDefaultMethodId, - getClassSig, getClassBigSig, getClassInstEnv, + classKey, classOps, classSelIds, + classSuperDictSelId, classOpId, classDefaultMethodId, + classSig, classBigSig, classInstEnv, isSuperClassOf, + classOpTagByString, derivableClassKeys, cCallishClassKeys, isNumericClass, isStandardClass, isCcallishClass, GenClassOp(..), ClassOp(..), mkClassOp, - getClassOpTag, getClassOpString, - getClassOpLocalType, + classOpTag, classOpString, + classOpLocalType, ClassInstEnv(..) - - -- and to make the interface self-sufficient... ) where CHK_Ubiq() -- debugging consistency check @@ -37,10 +36,8 @@ import TyVar ( TyVar(..), GenTyVar ) import Usage ( GenUsage, Usage(..), UVar(..) ) import Maybes ( assocMaybe, Maybe ) ---import Name ( Name ) import Unique -- Keys for built-in classes ---import Outputable ( Outputable(..), NamedThing(..), ExportFlag ) -import Pretty ( Pretty(..), PrettyRep ) +import Pretty ( Pretty(..), ppCat{-ToDo:rm-}, ppPStr{-ditto-} ) import PprStyle ( PprStyle ) import SrcLoc ( SrcLoc ) import Util @@ -142,25 +139,25 @@ mkClass uniq full_name tyvar super_classes superdict_sels The rest of these functions are just simple selectors. \begin{code} -getClassKey (Class key _ _ _ _ _ _ _ _ _) = key -getClassOps (Class _ _ _ _ _ ops _ _ _ _) = ops -getClassSelIds (Class _ _ _ _ _ _ sels _ _ _) = sels - -getClassOpId (Class _ _ _ _ _ ops op_ids _ _ _) op - = op_ids !! (getClassOpTag op - 1) -getDefaultMethodId (Class _ _ _ _ _ ops _ defm_ids _ _) op - = defm_ids !! (getClassOpTag op - 1) -getSuperDictSelId (Class _ _ _ scs scsel_ids _ _ _ _ _) super_clas - = assoc "getSuperDictSelId" (scs `zip` scsel_ids) super_clas - -getClassSig :: GenClass t u -> (t, [GenClass t u], [GenClassOp (GenType t u)]) -getClassSig (Class _ _ tyvar super_classes _ ops _ _ _ _) +classKey (Class key _ _ _ _ _ _ _ _ _) = key +classOps (Class _ _ _ _ _ ops _ _ _ _) = ops +classSelIds (Class _ _ _ _ _ _ sels _ _ _) = sels + +classOpId (Class _ _ _ _ _ ops op_ids _ _ _) op + = op_ids !! (classOpTag op - 1) +classDefaultMethodId (Class _ _ _ _ _ ops _ defm_ids _ _) op + = defm_ids !! (classOpTag op - 1) +classSuperDictSelId (Class _ _ _ scs scsel_ids _ _ _ _ _) super_clas + = assoc "classSuperDictSelId" (scs `zip` scsel_ids) super_clas + +classSig :: GenClass t u -> (t, [GenClass t u], [GenClassOp (GenType t u)]) +classSig (Class _ _ tyvar super_classes _ ops _ _ _ _) = (tyvar, super_classes, ops) -getClassBigSig (Class _ _ tyvar super_classes sdsels ops sels defms _ _) +classBigSig (Class _ _ tyvar super_classes sdsels ops sels defms _ _) = (tyvar, super_classes, sdsels, ops, sels, defms) -getClassInstEnv (Class _ _ _ _ _ _ _ _ inst_env _) = inst_env +classInstEnv (Class _ _ _ _ _ _ _ _ inst_env _) = inst_env \end{code} @a `isSuperClassOf` b@ returns @Nothing@ if @a@ is not a superclass of @@ -189,7 +186,8 @@ because the list of ambiguous dictionaries hasn't been simplified. \begin{code} isNumericClass, isStandardClass :: Class -> Bool -isNumericClass (Class key _ _ _ _ _ _ _ _ _) = key `is_elem` numericClassKeys +isNumericClass (Class key _ _ _ _ _ _ _ _ _) = --pprTrace "isNum:" (ppCat (map pprUnique (key : numericClassKeys ))) $ + key `is_elem` numericClassKeys isStandardClass (Class key _ _ _ _ _ _ _ _ _) = key `is_elem` standardClassKeys isCcallishClass (Class key _ _ _ _ _ _ _ _ _) = key `is_elem` cCallishClassKeys is_elem = isIn "is_X_Class" @@ -301,14 +299,29 @@ object). Of course, the type of @op@ recorded in the GVE will be its mkClassOp :: FAST_STRING -> Int -> ty -> GenClassOp ty mkClassOp name tag ty = ClassOp name tag ty -getClassOpTag :: GenClassOp ty -> Int -getClassOpTag (ClassOp _ tag _) = tag +classOpTag :: GenClassOp ty -> Int +classOpTag (ClassOp _ tag _) = tag + +classOpString :: GenClassOp ty -> FAST_STRING +classOpString (ClassOp str _ _) = str + +classOpLocalType :: GenClassOp ty -> ty {-SigmaType-} +classOpLocalType (ClassOp _ _ ty) = ty +\end{code} -getClassOpString :: GenClassOp ty -> FAST_STRING -getClassOpString (ClassOp str _ _) = str +Rather unsavoury ways of getting ClassOp tags: +\begin{code} +classOpTagByString :: Class -> FAST_STRING -> Int -getClassOpLocalType :: GenClassOp ty -> ty {-SigmaType-} -getClassOpLocalType (ClassOp _ _ ty) = ty +classOpTagByString clas op + = go (map classOpString (classOps clas)) 1 + where + go (n:ns) tag = if n == op + then tag + else go ns (tag+1) +#ifdef DEBUG + go [] tag = pprPanic "classOpTagByString:" (ppCat (ppPStr op : map (ppPStr . classOpString) (classOps clas))) +#endif \end{code} %************************************************************************ diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs index 09dfc13b0e..0bcd209ae0 100644 --- a/ghc/compiler/types/TyCon.lhs +++ b/ghc/compiler/types/TyCon.lhs @@ -145,6 +145,7 @@ isBoxedTyCon = not . isPrimTyCon -- isDataTyCon returns False for @newtype@. -- Not sure about this decision yet. isDataTyCon (DataTyCon _ _ _ _ _ _ _ DataType) = True +isDataTyCon (TupleTyCon _ _ _) = True isDataTyCon other = False isSynTyCon (SynTyCon _ _ _ _ _ _) = True @@ -229,7 +230,7 @@ tyConFamilySize (TupleTyCon _ _ _) = 1 \begin{code} tyConDerivings :: TyCon -> [Class] tyConDerivings (DataTyCon _ _ _ _ _ _ derivs _) = derivs -tyConDerivings other = [] +tyConDerivings other = [] \end{code} \begin{code} @@ -317,11 +318,12 @@ instance Ord TyCon where _tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT } instance Uniquable TyCon where - uniqueOf (DataTyCon u _ _ _ _ _ _ _) = u - uniqueOf (PrimTyCon u _ _) = u - uniqueOf (SynTyCon u _ _ _ _ _) = u - uniqueOf tc@(SpecTyCon _ _) = panic "uniqueOf:SpecTyCon" - uniqueOf tc = uniqueOf (getName tc) + uniqueOf (DataTyCon u _ _ _ _ _ _ _) = u + uniqueOf (TupleTyCon u _ _) = u + uniqueOf (PrimTyCon u _ _) = u + uniqueOf (SynTyCon u _ _ _ _ _) = u + uniqueOf tc@(SpecTyCon _ _) = panic "uniqueOf:SpecTyCon" + uniqueOf tc = uniqueOf (getName tc) \end{code} \begin{code} diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index e1d303db7e..c094e1efa9 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -45,7 +45,7 @@ import PrelLoop -- for paranoia checking --import Util ( pprPanic ) -- friends: -import Class ( getClassSig, getClassOpLocalType, GenClass{-instances-} ) +import Class ( classSig, classOpLocalType, GenClass{-instances-} ) import Kind ( mkBoxedTypeKind, resultKind ) import TyCon ( mkFunTyCon, mkTupleTyCon, isFunTyCon, isPrimTyCon, isDataTyCon, isSynTyCon, tyConArity, tyConKind, tyConDataCons, getSynTyConDefn, TyCon ) @@ -147,12 +147,12 @@ expandTy (DictTy clas ty u) -- CCallable, CReturnable (and anything else -- *really weird* that the user writes). where - (tyvar, super_classes, ops) = getClassSig clas + (tyvar, super_classes, ops) = classSig clas super_dict_tys = map mk_super_ty super_classes class_op_tys = map mk_op_ty ops all_arg_tys = super_dict_tys ++ class_op_tys mk_super_ty sc = DictTy sc ty usageOmega - mk_op_ty op = instantiateTy [(tyvar,ty)] (getClassOpLocalType op) + mk_op_ty op = instantiateTy [(tyvar,ty)] (classOpLocalType op) expandTy ty = ty \end{code} |