[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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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}