Skip to content
GitLab
Commit d7acf5bf authored by sof's avatar sof
Browse files

[project @ 1997-05-18 22:23:06 by sof] 

New PP
parent e3beda58
Hide whitespace changes
Inline Side-by-side
ghc/compiler/typecheck/TcMonad.lhs
View file @ d7acf5bf
......@@ -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}
ghc/compiler/typecheck/TcMonoType.lhs
View file @ d7acf5bf
......@@ -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}
ghc/compiler/typecheck/TcPat.lhs
View file @ d7acf5bf
......@@ -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}
ghc/compiler/typecheck/TcSimplify.lhs
View file @ d7acf5bf
......@@ -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}
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment