From: sof Date: Sun, 18 May 1997 22:24:43 +0000 (+0000) Subject: [project @ 1997-05-18 22:23:06 by sof] X-Git-Tag: Approximately_1000_patches_recorded~631 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=d7acf5bf3863e8dd6ddd7e554276fb622d961ba4;p=ghc-hetmet.git [project @ 1997-05-18 22:23:06 by sof] New PP --- diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs index 2cda4e4..e43c29b 100644 --- a/ghc/compiler/typecheck/TcMonad.lhs +++ b/ghc/compiler/typecheck/TcMonad.lhs @@ -34,8 +34,10 @@ module TcMonad( -- For closure SYN_IE(MutableVar), -#if __GLASGOW_HASKELL__ >= 200 +#if __GLASGOW_HASKELL__ == 201 GHCbase.MutableArray +#elif __GLASGOW_HASKELL__ == 201 + GlaExts.MutableArray #else _MutableArray #endif @@ -64,6 +66,9 @@ import Unique ( Unique ) import Util import Pretty import PprStyle ( PprStyle(..) ) +#if __GLASGOW_HASKELL__ >= 202 +import Outputable +#endif infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenNF_Tc_` \end{code} @@ -485,8 +490,8 @@ mkTcErr :: SrcLoc -- Where -> TcError -- The complete error report mkTcErr locn ctxt msg sty - = ppHang (ppBesides [ppr PprForUser locn, ppPStr SLIT(": "), msg sty]) - 4 (ppAboves [msg sty | msg <- ctxt_to_use]) + = hang (hcat [ppr PprForUser locn, ptext SLIT(": "), msg sty]) + 4 (vcat [msg sty | msg <- ctxt_to_use]) where ctxt_to_use = if opt_PprStyle_All then @@ -500,15 +505,15 @@ mkTcErr locn ctxt msg sty takeAtMost n (x:xs) = x:takeAtMost (n-1) xs arityErr kind name n m sty - = ppBesides [ ppChar '`', ppr sty name, ppPStr SLIT("' should have "), - n_arguments, ppStr ", but has been given ", ppInt m, ppChar '.'] + = hsep [ ppr sty name, ptext SLIT("should have"), + n_arguments <> comma, text "but has been given", int m, char '.'] where errmsg = kind ++ " has too " ++ quantity ++ " arguments" quantity | m < n = "few" | otherwise = "many" - n_arguments | n == 0 = ppPStr SLIT("no arguments") - | n == 1 = ppPStr SLIT("1 argument") - | True = ppCat [ppInt n, ppPStr SLIT("arguments")] + n_arguments | n == 0 = ptext SLIT("no arguments") + | n == 1 = ptext SLIT("1 argument") + | True = hsep [int n, ptext SLIT("arguments")] \end{code} diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs index eb7fc82..00932cb 100644 --- a/ghc/compiler/typecheck/TcMonoType.lhs +++ b/ghc/compiler/typecheck/TcMonoType.lhs @@ -24,14 +24,19 @@ import Type ( GenType, SYN_IE(Type), SYN_IE(ThetaType), mkSigmaTy, mkDictTy ) import TyVar ( GenTyVar, SYN_IE(TyVar), mkTyVar ) +import Outputable import PrelInfo ( cCallishClassKeys ) import TyCon ( TyCon ) -import Name ( Name, OccName, isTvOcc ) +import Name ( Name, OccName, isTvOcc, getOccName ) import TysWiredIn ( mkListTy, mkTupleTy ) import Unique ( Unique ) import PprStyle import Pretty +import UniqFM ( Uniquable(..) ) import Util ( zipWithEqual, zipLazy, panic{-, pprPanic ToDo:rm-} ) + + + \end{code} @@ -208,5 +213,5 @@ Errors and contexts ~~~~~~~~~~~~~~~~~~~ \begin{code} naughtyCCallContextErr clas_name sty - = ppSep [ppPStr SLIT("Can't use class"), ppr sty clas_name, ppPStr SLIT("in a context")] + = sep [ptext SLIT("Can't use class"), ppr sty clas_name, ptext SLIT("in a context")] \end{code} diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index cb8fdd3..46836f4 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -30,7 +30,7 @@ import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists ) import Bag ( Bag ) import CmdLineOpts ( opt_IrrefutableTuples ) -import Id ( GenId, idType ) +import Id ( GenId, idType, SYN_IE(Id) ) import Kind ( Kind, mkBoxedTypeKind, mkTypeKind ) import Maybes ( maybeToBool ) import PprType ( GenType, GenTyVar ) @@ -47,6 +47,10 @@ import TysPrim ( charPrimTy, intPrimTy, floatPrimTy, import TysWiredIn ( charTy, stringTy, mkListTy, mkTupleTy, addrTy ) import Unique ( Unique, eqClassOpKey, geClassOpKey, minusClassOpKey ) import Util ( assertPanic, panic ) + +#if __GLASGOW_HASKELL__ >= 202 +import Outputable +#endif \end{code} \begin{code} @@ -61,7 +65,7 @@ tcPat :: RenamedPat -> TcM s (TcPat s, LIE s, TcType s) \begin{code} tcPat (VarPatIn name) - = tcLookupLocalValueOK ("tcPat1:"{-++ppShow 80 (ppr PprDebug name)-}) name `thenNF_Tc` \ id -> + = tcLookupLocalValueOK ("tcPat1:"{-++show (ppr PprDebug name)-}) name `thenNF_Tc` \ id -> returnTc (VarPat (TcId id), emptyLIE, idType id) tcPat (LazyPatIn pat) @@ -377,13 +381,13 @@ matchConArgTys con arg_tys Errors and contexts ~~~~~~~~~~~~~~~~~~~ \begin{code} -patCtxt pat sty = ppHang (ppPStr SLIT("In the pattern:")) 4 (ppr sty pat) +patCtxt pat sty = hang (ptext SLIT("In the pattern:")) 4 (ppr sty pat) recordLabel field_label sty - = ppHang (ppBesides [ppPStr SLIT("When matching record field"), ppr sty field_label]) - 4 (ppBesides [ppPStr SLIT("with its immediately enclosing constructor")]) + = hang (hcat [ptext SLIT("When matching record field"), ppr sty field_label]) + 4 (hcat [ptext SLIT("with its immediately enclosing constructor")]) recordRhs field_label pat sty - = ppHang (ppPStr SLIT("In the record field pattern")) - 4 (ppSep [ppr sty field_label, ppChar '=', ppr sty pat]) + = hang (ptext SLIT("In the record field pattern")) + 4 (sep [ppr sty field_label, char '=', ppr sty pat]) \end{code} diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index 2aa4ef5..c1d9ec6 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -17,7 +17,9 @@ IMP_Ubiq() import HsSyn ( MonoBinds(..), HsExpr(..), InPat, OutPat, HsLit, Match, HsBinds, HsType, ArithSeqInfo, Fixity, GRHSsAndBinds, Stmt, DoOrListComp, Fake ) -import TcHsSyn ( TcIdOcc(..), SYN_IE(TcIdBndr), SYN_IE(TcExpr), SYN_IE(TcMonoBinds) ) +import HsBinds ( andMonoBinds ) +import TcHsSyn ( TcIdOcc(..), SYN_IE(TcIdBndr), SYN_IE(TcExpr), + SYN_IE(TcMonoBinds), SYN_IE(TcDictBinds) ) import TcMonad import Inst ( lookupInst, lookupSimpleInst, @@ -43,7 +45,7 @@ import PrelInfo ( isNumericClass, isStandardClass, isCcallishClass ) import Maybes ( expectJust, firstJust, catMaybes, seqMaybe, maybeToBool ) import Outputable ( Outputable(..){-instance * []-} ) ---import PprStyle--ToDo:rm +import PprStyle import PprType ( GenType, GenTyVar ) import Pretty import SrcLoc ( noSrcLoc ) @@ -88,7 +90,7 @@ tcSimpl :: Bool -- True <=> simplify const insts -> LIE s -- Given; these constrain only local tyvars -> LIE s -- Wanted -> TcM s (LIE s, -- Free - [(TcIdOcc s,TcExpr s)], -- Bindings + TcMonoBinds s, -- Bindings LIE s) -- Remaining wanteds; no dups tcSimpl squash_consts global_tvs local_tvs givens wanteds @@ -138,7 +140,7 @@ tcSimpl squash_consts global_tvs local_tvs givens wanteds elimSCs givens locals `thenNF_Tc` \ (sc_binds, locals2) -> -- Finished - returnTc (globals, bagToList (sc_binds `unionBags` tycon_binds), locals2) + returnTc (globals, sc_binds `AndMonoBinds` tycon_binds, locals2) where is_ambiguous (Dict _ _ ty _ _) = not (getTyVar "is_ambiguous" ty `elementOfTyVarSet` local_tvs) @@ -156,7 +158,7 @@ tcSimplify :: TcTyVarSet s -- ``Local'' type variables -> LIE s -- Wanted -> TcM s (LIE s, -- Free - [(TcIdOcc s,TcExpr s)], -- Bindings + TcDictBinds s, -- Bindings LIE s) -- Remaining wanteds; no dups tcSimplify local_tvs wanteds @@ -173,8 +175,8 @@ tcSimplifyAndCheck :: TcTyVarSet s -- ``Local'' type variables; ASSERT is fixpoint -> LIE s -- Given -> LIE s -- Wanted - -> TcM s (LIE s, -- Free - [(TcIdOcc s,TcExpr s)]) -- Bindings + -> TcM s (LIE s, -- Free + TcDictBinds s) -- Bindings tcSimplifyAndCheck local_tvs givens wanteds = tcGetGlobalTyVars `thenNF_Tc` \ global_tvs -> @@ -192,7 +194,7 @@ is not overloaded. tcSimplifyRank2 :: TcTyVarSet s -- ``Local'' type variables; ASSERT is fixpoint -> LIE s -- Given -> TcM s (LIE s, -- Free - [(TcIdOcc s,TcExpr s)]) -- Bindings + TcDictBinds s) -- Bindings tcSimplifyRank2 local_tvs givens @@ -207,14 +209,14 @@ tcSimplifyRank2 local_tvs givens checkTc (isEmptyBag wanteds) (reduceErr wanteds) `thenTc_` - returnTc (free, bagToList dict_binds) + returnTc (free, dict_binds) \end{code} @tcSimplifyTop@ deals with constant @Insts@, using the standard simplification mechansim with the extra flag to say ``beat out constant insts''. \begin{code} -tcSimplifyTop :: LIE s -> TcM s [(TcIdOcc s, TcExpr s)] +tcSimplifyTop :: LIE s -> TcM s (TcDictBinds s) tcSimplifyTop dicts = tcSimpl True emptyTyVarSet emptyTyVarSet emptyBag dicts `thenTc` \ (_, binds, _) -> returnTc binds @@ -232,7 +234,7 @@ elimTyCons :: Bool -- True <=> Simplify const insts -> LIE s -- Given -> LIE s -- Wanted -> TcM s (LIE s, -- Free - Bag (TcIdOcc s, TcExpr s), -- Bindings + TcDictBinds s, -- Bindings LIE s -- Remaining wanteds; no dups; -- dicts only (no Methods) ) @@ -266,9 +268,9 @@ elimTyCons squash_consts is_free_tv givens wanteds returnTc (free,binds,irreds) where -- eTC :: LIE s -> [Inst s] --- -> TcM s (LIE s, LIE s, Bag (TcIdOcc s, TcExpr s), LIE s) +-- -> TcM s (LIE s, LIE s, TcDictBinds s, LIE s) - eTC givens [] = returnTc (givens, emptyBag, emptyBag, emptyBag) + eTC givens [] = returnTc (givens, emptyBag, EmptyMonoBinds, emptyBag) eTC givens (wanted:wanteds) -- Case 0: same as an existing inst @@ -277,8 +279,8 @@ elimTyCons squash_consts is_free_tv givens wanteds let -- Create a new binding iff it's needed this = expectJust "eTC" maybe_equiv - new_binds | instBindingRequired wanted = (instToId wanted, HsVar (instToId this)) - `consBag` binds + new_binds | instBindingRequired wanted = (VarMonoBind (instToId wanted) (HsVar (instToId this))) + `AndMonoBinds` binds | otherwise = binds in returnTc (givens1, frees, new_binds, irreds) @@ -320,12 +322,12 @@ elimTyCons squash_consts is_free_tv givens wanteds simplify_it simplify_always givens wanted wanteds -- Recover immediately on no-such-instance errors - = recoverTc (returnTc (wanted `consBag` givens, emptyLIE, emptyBag, emptyLIE)) + = recoverTc (returnTc (wanted `consBag` givens, emptyLIE, EmptyMonoBinds, emptyLIE)) (simplify_one simplify_always givens wanted) `thenTc` \ (givens1, frees1, binds1, irreds1) -> eTC givens1 wanteds `thenTc` \ (givens2, frees2, binds2, irreds2) -> returnTc (givens2, frees1 `plusLIE` frees2, - binds1 `unionBags` binds2, + binds1 `AndMonoBinds` binds2, irreds1 `plusLIE` irreds2) @@ -338,20 +340,20 @@ elimTyCons squash_consts is_free_tv givens wanteds | otherwise = -- An binding is required for this inst - lookupInst wanted `thenTc` \ (simpler_wanteds, bind@(_,rhs)) -> + lookupInst wanted `thenTc` \ (simpler_wanteds, bind@(VarMonoBind _ rhs)) -> if (not_var rhs && not simplify_always) then -- Ho ho! It isn't trivial to simplify "wanted", -- because the rhs isn't a simple variable. Unless the flag -- simplify_always is set, just give up now and -- just fling it out the top. - returnTc (wanted `consLIE` givens, unitLIE wanted, emptyBag, emptyLIE) + returnTc (wanted `consLIE` givens, unitLIE wanted, EmptyMonoBinds, emptyLIE) else -- Aha! Either it's easy, or simplify_always is True -- so we must do it right here. eTC givens simpler_wanteds `thenTc` \ (givens1, frees1, binds1, irreds1) -> returnTc (wanted `consLIE` givens1, frees1, - binds1 `snocBag` bind, + binds1 `AndMonoBinds` bind, irreds1) not_var :: TcExpr s -> Bool @@ -370,7 +372,7 @@ elimTyCons squash_consts is_free_tv givens wanteds elimSCs :: LIE s -- Given; no dups -> LIE s -- Wanted; no dups; all dictionaries, all -- constraining just a type variable - -> NF_TcM s (Bag (TcIdOcc s,TcExpr s), -- Bindings + -> NF_TcM s (TcDictBinds s, -- Bindings LIE s) -- Minimal wanted set elimSCs givens wanteds @@ -381,27 +383,27 @@ elimSCs givens wanteds elimSCs_help :: LIE s -- Given; no dups -> [Inst s] -- Wanted; no dups; - -> NF_TcM s (Bag (TcIdOcc s, TcExpr s), -- Bindings + -> NF_TcM s (TcDictBinds s, -- Bindings LIE s) -- Minimal wanted set -elimSCs_help given [] = returnNF_Tc (emptyBag, emptyLIE) +elimSCs_help given [] = returnNF_Tc (EmptyMonoBinds, emptyLIE) elimSCs_help givens (wanted:wanteds) = trySC givens wanted `thenNF_Tc` \ (givens1, binds1, irreds1) -> elimSCs_help givens1 wanteds `thenNF_Tc` \ (binds2, irreds2) -> - returnNF_Tc (binds1 `unionBags` binds2, irreds1 `plusLIE` irreds2) + returnNF_Tc (binds1 `AndMonoBinds` binds2, irreds1 `plusLIE` irreds2) trySC :: LIE s -- Givens -> Inst s -- Wanted -> NF_TcM s (LIE s, -- New givens, - Bag (TcIdOcc s,TcExpr s), -- Bindings + TcDictBinds s, -- Bindings LIE s) -- Irreducible wanted set trySC givens wanted@(Dict _ wanted_class wanted_ty wanted_orig loc) | not (maybeToBool maybe_best_subclass_chain) = -- No superclass relationship - returnNF_Tc ((wanted `consLIE` givens), emptyBag, unitLIE wanted) + returnNF_Tc ((wanted `consLIE` givens), EmptyMonoBinds, unitLIE wanted) | otherwise = -- There's a subclass relationship with a "given" @@ -418,14 +420,15 @@ 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 (classSuperDictSelId dict_sub_class + (VarMonoBind (instToId dict) + (DictApp (TyApp (HsVar (RealId (classSuperDictSelId dict_sub_class clas))) [ty]) - [instToId dict_sub])) + [instToId dict_sub]))) (_, new_binds) = mapAccumR mk_bind (wanted,wanted_class) (given : intermediates) in returnNF_Tc (wanted `consLIE` givens `plusLIE` listToBag intermediates, - listToBag new_binds, + andMonoBinds new_binds, emptyLIE) where @@ -576,9 +579,9 @@ bindInstsOfLocalFuns init_lie local_ids where bind_inst inst@(Method uniq (TcId id) tys rho orig loc) (insts, binds) | id `is_elem` local_ids - = lookupInst inst `thenTc` \ (dict_insts, (id,rhs)) -> + = lookupInst inst `thenTc` \ (dict_insts, bind) -> returnTc (listToBag dict_insts `plusLIE` insts, - VarMonoBind id rhs `AndMonoBinds` binds) + bind `AndMonoBinds` binds) bind_inst some_other_inst (insts, binds) -- Either not a method, or a method instance for an id not in local_ids @@ -710,13 +713,13 @@ now? \begin{code} genCantGenErr insts sty -- Can't generalise these Insts - = ppHang (ppPStr SLIT("Cannot generalise these overloadings (in a _ccall_):")) - 4 (ppAboves (map (ppr sty) (bagToList insts))) + = hang (ptext SLIT("Cannot generalise these overloadings (in a _ccall_):")) + 4 (vcat (map (ppr sty) (bagToList insts))) \end{code} \begin{code} ambigErr insts sty - = ppAboves (map (pprInst sty "Ambiguous overloading") insts) + = vcat (map (pprInst sty "Ambiguous overloading") insts) \end{code} @reduceErr@ complains if we can't express required dictionaries in @@ -724,7 +727,7 @@ terms of the signature. \begin{code} reduceErr insts sty - = ppAboves (map (pprInst sty "Context required by inferred type, but missing on a type signature") + = vcat (map (pprInst sty "Context required by inferred type, but missing on a type signature") (bagToList insts)) \end{code}