Commit 38db2293 authored by simonpj's avatar simonpj

[project @ 1997-06-20 00:33:36 by simonpj]

More small changes to 2.04
parent 9c267396
......@@ -14,7 +14,7 @@ import Name --( Name{-instance Eq/Outputable-}, nameUnique )
import Type ( SYN_IE(Type) )
import Outputable
import UniqFM ( Uniquable(..) )
import Unique ( Uniquable(..) )
\end{code}
\begin{code}
......
......@@ -203,7 +203,8 @@ import UniqFM
import UniqSet -- practically all of it
import Unique ( getBuiltinUniques, pprUnique, showUnique,
incrUnique,
Unique{-instance Ord3-}
Unique{-instance Ord3-},
Uniquable(..)
)
import Outputable ( ifPprDebug, Outputable(..), PprStyle(..) )
import Util {- ( mapAccumL, nOfThem, zipEqual, assoc,
......
......@@ -72,10 +72,10 @@ import Pretty
import Lex ( isLexSym, isLexConId )
import SrcLoc ( noSrcLoc, SrcLoc )
import Usage ( SYN_IE(UVar), SYN_IE(Usage) )
import Unique ( pprUnique, showUnique, Unique )
import Unique ( pprUnique, showUnique, Unique, Uniquable(..) )
import UniqSet ( UniqSet(..), emptyUniqSet, unitUniqSet, unionUniqSets, uniqSetToList, isEmptyUniqSet,
unionManyUniqSets, minusUniqSet, mkUniqSet, elementOfUniqSet, addListToUniqSet, addOneToUniqSet )
import UniqFM ( UniqFM, Uniquable(..) )
import UniqFM ( UniqFM )
import Util --( cmpPString, panic, assertPanic {-, pprTrace ToDo:rm-} )
\end{code}
......
_interface_ Unique 1
_exports_
Unique Unique mkUniqueGrimily;
Unique Unique Uniquable(uniqueOf) mkUniqueGrimily;
_declarations_
1 data Unique;
1 mkUniqueGrimily _:_ GHC.Int# -> Unique.Unique ;;
1 class Uniquable a where {uniqueOf :: a -> Unique};
......@@ -21,7 +21,7 @@ Haskell).
--<mkdependHS:friends> UniqSupply
module Unique (
Unique,
Unique, Uniquable(..),
u2i, -- hack: used in UniqFM
pprUnique, pprUnique10, showUnique,
......@@ -236,10 +236,6 @@ import PrelBase ( Char(..) )
IMP_Ubiq(){-uitous-}
#if __GLASGOW_HASKELL__ >= 202
import {-# SOURCE #-} UniqFM ( Uniquable(..) )
#endif
import Outputable
import Pretty
import Util
......@@ -255,9 +251,14 @@ The @Chars@ are ``tag letters'' that identify the @UniqueSupply@.
Fast comparison is everything on @Uniques@:
\begin{code}
u2i :: Unique -> FAST_INT
data Unique = MkUnique Int#
class Uniquable a where
uniqueOf :: a -> Unique
\end{code}
\begin{code}
u2i :: Unique -> FAST_INT
u2i (MkUnique i) = i
\end{code}
......
......@@ -53,8 +53,7 @@ import Outputable ( PprStyle(..) )
import Pretty ( Doc )
import PrimRep ( PrimRep )
import StgSyn ( SYN_IE(StgArg), SYN_IE(StgLiveVars), GenStgArg(..) )
import Unique ( Unique )
import UniqFM ( Uniquable(..) )
import Unique ( Unique, Uniquable(..) )
import Util ( zipWithEqual, panic )
\end{code}
......
......@@ -73,8 +73,7 @@ import Type ( typePrimRep,
maybeAppSpecDataTyConExpandingDicts,
SYN_IE(Type)
)
import Unique ( Unique )
import UniqFM ( Uniquable(..) )
import Unique ( Unique, Uniquable(..) )
import Util ( sortLt, isIn, isn'tIn, zipEqual,
pprError, panic, assertPanic
)
......
......@@ -38,8 +38,7 @@ import PrelVals ( nON_EXHAUSTIVE_GUARDS_ERROR_ID )
import Outputable ( PprStyle(..) )
import SrcLoc ( SrcLoc{-instance-} )
import Type ( SYN_IE(Type) )
import Unique ( Unique, otherwiseIdKey )
import UniqFM ( Uniquable(..) )
import Unique ( Unique, otherwiseIdKey, Uniquable(..) )
import Util ( panic )
\end{code}
......
......@@ -196,17 +196,17 @@ ppr_monobind sty (AndMonoBinds binds1 binds2)
= ($$) (ppr_monobind sty binds1) (ppr_monobind sty binds2)
ppr_monobind sty (PatMonoBind pat grhss_n_binds locn)
= hang (ppr sty pat) 4 (pprGRHSsAndBinds sty False grhss_n_binds)
= sep [ppr sty pat, nest 4 (pprGRHSsAndBinds sty False grhss_n_binds)]
ppr_monobind sty (FunMonoBind fun inf matches locn)
= pprMatches sty (False, ppr sty fun) matches
-- ToDo: print infix if appropriate
ppr_monobind sty (VarMonoBind name expr)
= hang (hsep [ppr sty name, equals]) 4 (pprExpr sty expr)
= sep [ppr sty name <+> equals, nest 4 (pprExpr sty expr)]
ppr_monobind sty (CoreMonoBind name expr)
= hang (hsep [ppr sty name, equals]) 4 (ppr sty expr)
= sep [ppr sty name <+> equals, nest 4 (ppr sty expr)]
ppr_monobind sty (AbsBinds tyvars dictvars exports val_binds)
= ($$) (sep [ptext SLIT("AbsBinds"),
......
......@@ -118,7 +118,7 @@ ppr_forall sty ctxt_prec tvs ctxt ty
pprContext :: (Outputable name) => PprStyle -> (Context name) -> Doc
pprContext sty [] = empty
pprContext sty context
= hsep [braces (hsep (punctuate comma (map ppr_assert context)))]
= pprQuote sty $ \ sty -> parens (hsep (punctuate comma (map ppr_assert context)))
where
ppr_assert (clas, ty) = hsep [ppr sty clas, ppr sty ty]
\end{code}
......
......@@ -77,10 +77,9 @@ import Stix ( sStLitLbl, StixTree(..), StixReg(..),
CodeSegment
)
import Unique ( mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3,
Unique{-instance Ord3-}
Unique{-instance Ord3-}, Uniquable(..)
)
import UniqSupply ( getUnique, returnUs, thenUs, SYN_IE(UniqSM) )
import UniqFM ( Uniquable(..) )
import Util ( panic, Ord3(..) )
\end{code}
......
......@@ -60,7 +60,7 @@ import TyCon ( tyConDataCons, mkFunTyCon, TyCon )
import Type
import Bag
import Unique -- *Key stuff
import UniqFM ( UniqFM, listToUFM, Uniquable(..) )
import UniqFM ( UniqFM, listToUFM )
import Util ( isIn )
\end{code}
......
......@@ -30,8 +30,8 @@ import TyCon ( TyCon )
import TysWiredIn ( tupleTyCon, listTyCon, charTyCon, intTyCon )
import FiniteMap
import Outputable
import Unique ( Unique, unboundKey )
import UniqFM ( Uniquable(..), listToUFM, plusUFM_C )
import Unique ( Unique, Uniquable(..), unboundKey )
import UniqFM ( listToUFM, plusUFM_C )
import Maybes ( maybeToBool )
import UniqSupply
import SrcLoc ( SrcLoc, noSrcLoc )
......
......@@ -143,17 +143,27 @@ rnPat (RecPatIn con rpats)
************************************************************************
\begin{code}
rnMatch :: RdrNameMatch -> RnMS s (RenamedMatch, FreeVars)
rnMatch, rnMatch1 :: RdrNameMatch -> RnMS s (RenamedMatch, FreeVars)
rnMatch (PatMatch pat match)
= bindLocalsRn "pattern" binders $ \ new_binders ->
rnPat pat `thenRn` \ pat' ->
rnMatch match `thenRn` \ (match', fvMatch) ->
returnRn (PatMatch pat' match', fvMatch `minusNameSet` mkNameSet new_binders)
-- The only tricky bit here is that we want to do a single
-- bindLocalsRn for all the matches together, so that we spot
-- the repeated variable in
-- f x x = 1
rnMatch match
= bindLocalsRn "pattern" (get_binders match) $ \ new_binders ->
rnMatch1 match `thenRn` \ (match', fvs) ->
returnRn (match', fvs `minusNameSet` mkNameSet new_binders)
where
binders = collectPatBinders pat
get_binders (GRHSMatch _) = []
get_binders (PatMatch pat match) = collectPatBinders pat ++ get_binders match
rnMatch1 (PatMatch pat match)
= rnPat pat `thenRn` \ pat' ->
rnMatch1 match `thenRn` \ (match', fvs) ->
returnRn (PatMatch pat' match', fvs)
rnMatch (GRHSMatch grhss_and_binds)
rnMatch1 (GRHSMatch grhss_and_binds)
= rnGRHSsAndBinds grhss_and_binds `thenRn` \ (grhss_and_binds', fvs) ->
returnRn (GRHSMatch grhss_and_binds', fvs)
\end{code}
......
......@@ -51,7 +51,7 @@ import PrelInfo ( derivingOccurrences, evalClass_RDR, numClass_RDR, allClass_NA
import ListSetOps ( unionLists, minusList )
import Maybes ( maybeToBool, catMaybes )
import Bag ( emptyBag, unitBag, consBag, unionManyBags, unionBags, listToBag, bagToList )
import Outputable ( PprStyle(..), Outputable(..){-instances-} )
import Outputable ( PprStyle(..), Outputable(..){-instances-}, pprQuote )
import Pretty
import SrcLoc ( SrcLoc )
import Unique ( Unique )
......@@ -705,17 +705,17 @@ classTyVarNotInOpTyErr clas_tyvar sig sty
ptext SLIT("does not appear in method signature")])
4 (ppr sty sig)
dupClassAssertWarn ctxt dups sty
= hang (hcat [ptext SLIT("Duplicate class assertion `"),
ppr sty dups,
ptext SLIT("' in context:")])
4 (ppr sty ctxt)
dupClassAssertWarn ctxt ((clas,ty) : dups) sty
= hang (hcat [ptext SLIT("Duplicated class assertion"),
pprQuote sty $ \ sty -> ppr sty clas <+> ppr sty ty,
ptext SLIT("in context:")])
4 (pprContext sty ctxt)
badDataCon name sty
= hsep [ptext SLIT("Illegal data constructor name:"), ppr sty name]
= hsep [ptext SLIT("Illegal data constructor name"), ppr sty name]
allOfNonTyVar ty sty
= hsep [ptext SLIT("`All' applied to a non-type variable:"), ppr sty ty]
= hsep [ptext SLIT("`All' applied to a non-type variable"), ppr sty ty]
ctxtErr1 doc tyvars sty
= hsep [ptext SLIT("Context constrains in-scope type variable(s)"),
......
......@@ -64,8 +64,7 @@ import Specialise
import SpecUtils ( pprSpecErrs )
import StrictAnal ( saWwTopBinds )
import TyVar ( nullTyVarEnv, GenTyVar{-instance Eq-} )
import Unique ( integerTyConKey, ratioTyConKey, Unique{-instance Eq-} )
import UniqFM ( Uniquable(..) )
import Unique ( integerTyConKey, ratioTyConKey, Unique{-instance Eq-}, Uniquable(..) )
import UniqSupply ( splitUniqSupply, getUnique, UniqSupply )
import Util ( mapAccumL, assertPanic, panic{-ToDo:rm-}, pprTrace, pprPanic )
import SrcLoc ( noSrcLoc )
......
......@@ -83,9 +83,8 @@ import TyVar ( nullTyVarEnv, addOneToTyVarEnv, growTyVarEnvList,
SYN_IE(TyVarEnv), GenTyVar{-instance Eq-} ,
SYN_IE(TyVar)
)
import Unique ( Unique{-instance Outputable-} )
import UniqFM ( addToUFM_C, ufmToList, Uniquable(..)
)
import Unique ( Unique{-instance Outputable-}, Uniquable(..) )
import UniqFM ( addToUFM_C, ufmToList )
import Usage ( SYN_IE(UVar), GenUsage{-instances-} )
import Util ( SYN_IE(Eager), appEager, returnEager, runEager,
zipEqual, thenCmp, cmpList, panic, panic#, assertPanic, Ord3(..) )
......
......@@ -61,8 +61,7 @@ import Type ( mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy,
)
import TysWiredIn ( stringTy )
import TyVar ( unitTyVarSet, GenTyVar, SYN_IE(TyVar) )
import Unique ( Unique )
import UniqFM ( Uniquable(..) )
import Unique ( Unique, Uniquable(..) )
import Util
......
......@@ -52,7 +52,7 @@ import Name ( Name, OccName(..), getSrcLoc, occNameString,
NamedThing(..)
)
import Pretty
import Unique ( pprUnique10{-, pprUnique ToDo:rm-}, Unique )
import Unique ( pprUnique10{-, pprUnique ToDo:rm-}, Unique, Uniquable(..) )
import UniqFM
import Util ( zipEqual, zipWithEqual, zipWith3Equal, zipLazy,
panic, pprPanic, pprTrace
......
......@@ -86,16 +86,15 @@ import Pretty
import TyCon ( isSynTyCon, isDataTyCon, derivedClasses )
import Type ( GenType(..), SYN_IE(ThetaType), mkTyVarTys, isPrimType,
splitSigmaTy, splitAppTys, isTyVarTy, matchTy, mkSigmaTy,
getTyCon_maybe, maybeAppTyCon, SYN_IE(Type),
getTyCon_maybe, maybeAppTyCon, SYN_IE(Type), getTyVar,
maybeBoxedPrimType, maybeAppDataTyCon, splitRhoTy, eqTy
)
import TyVar ( GenTyVar, SYN_IE(GenTyVarSet), tyVarSetToList,
mkTyVarSet, unionTyVarSets, SYN_IE(TyVar) )
import TysPrim ( byteArrayPrimTyCon, mutableByteArrayPrimTyCon )
import TysWiredIn ( stringTy )
import Unique ( Unique, cCallableClassKey, cReturnableClassKey )
import UniqFM ( Uniquable(..) )
import Util ( zipEqual, panic, pprPanic, pprTrace
import Unique ( Unique, cCallableClassKey, cReturnableClassKey, Uniquable(..) )
import Util ( zipEqual, panic, pprPanic, pprTrace, removeDups, Ord3(..),
#if __GLASGOW_HASKELL__ < 202
, trace
#endif
......@@ -665,8 +664,9 @@ scrutiniseInstanceType dfun_name clas inst_tau
= returnTc (inst_tycon,arg_tys)
-- TYVARS CHECK
| not (all isTyVarTy arg_tys ||
opt_GlasgowExts)
| not (opt_GlasgowExts ||
(all isTyVarTy arg_tys && null tyvar_dups)
)
= failTc (instTypeErr inst_tau)
-- DERIVING CHECK
......@@ -692,6 +692,7 @@ scrutiniseInstanceType dfun_name clas inst_tau
(possible_tycon, arg_tys) = splitAppTys inst_tau
inst_tycon_maybe = getTyCon_maybe possible_tycon
inst_tycon = expectJust "tcInstDecls1:inst_tycon" inst_tycon_maybe
(_, tyvar_dups) = removeDups cmp (map (getTyVar "tcInstDecls1:getTyVarTy") arg_tys)
-- These conditions come directly from what the DsCCall is capable of.
-- Totally grotesque. Green card should solve this.
......@@ -727,11 +728,11 @@ creturnable_type ty = maybeToBool (maybeBoxedPrimType ty) ||
instTypeErr ty sty
= case ty of
SynTy tc _ _ -> hcat [ptext SLIT("The type synonym `"), ppr sty tc, rest_of_msg]
TyVarTy tv -> hcat [ptext SLIT("The type variable `"), ppr sty tv, rest_of_msg]
other -> hcat [ptext SLIT("The type `"), ppr sty ty, rest_of_msg]
SynTy tc _ _ -> hsep [ptext SLIT("The type synonym"), ppr sty tc, rest_of_msg]
TyVarTy tv -> hsep [ptext SLIT("The type variable"), ppr sty tv, rest_of_msg]
other -> hsep [ptext SLIT("The type"), ppr sty ty, rest_of_msg]
where
rest_of_msg = ptext SLIT("' cannot be used as an instance type.")
rest_of_msg = ptext SLIT("cannot be used as an instance type")
instBndrErr bndr clas sty
= hsep [ptext SLIT("Class"), ppr sty clas, ptext SLIT("does not have a method"), ppr sty bndr]
......
......@@ -29,9 +29,8 @@ import PrelInfo ( cCallishClassKeys )
import TyCon ( TyCon )
import Name ( Name, OccName, isTvOcc, getOccName )
import TysWiredIn ( mkListTy, mkTupleTy )
import Unique ( Unique )
import Unique ( Unique, Uniquable(..) )
import Pretty
import UniqFM ( Uniquable(..) )
import Util ( zipWithEqual, zipLazy, panic{-, pprPanic ToDo:rm-} )
......
......@@ -64,7 +64,7 @@ tcPat :: RenamedPat -> TcM s (TcPat s, LIE s, TcType s)
\begin{code}
tcPat (VarPatIn name)
= tcLookupLocalValueOK ("tcPat1:"{-++show (ppr PprDebug name)-}) name `thenNF_Tc` \ id ->
= tcLookupLocalValueOK "tcPat1:" name `thenNF_Tc` \ id ->
returnTc (VarPat (TcId id), emptyLIE, idType id)
tcPat (LazyPatIn pat)
......
......@@ -42,8 +42,7 @@ import UniqSet ( SYN_IE(UniqSet), emptyUniqSet,
unionManyUniqSets, uniqSetToList )
import SrcLoc ( SrcLoc )
import TyCon ( TyCon, SYN_IE(Arity) )
import Unique ( Unique )
import UniqFM ( Uniquable(..) )
import Unique ( Unique, Uniquable(..) )
import Util ( panic{-, pprTrace-} )
\end{code}
......
......@@ -48,7 +48,6 @@ import Maybes ( assocMaybe )
import Name ( changeUnique, Name, OccName, occNameString )
import Outputable
import Unique -- Keys for built-in classes
import UniqFM ( Uniquable(..) )
import Pretty ( Doc, hsep, ptext )
import SrcLoc ( SrcLoc )
import Util
......
......@@ -54,9 +54,8 @@ import Outputable ( PprStyle(..), codeStyle, userStyle, ifaceStyle,
ifPprShowAll, interpp'SP, Outputable(..) )
import PprEnv
import Pretty
import UniqFM ( addToUFM_Directly, lookupUFM_Directly{-, ufmToList ToDo:rm-},
Uniquable(..) )
import Unique --TEMP: ( pprUnique10, pprUnique, incrUnique, listTyConKey )
import UniqFM ( addToUFM_Directly, lookupUFM_Directly )
import Unique ( Uniquable(..), pprUnique10, pprUnique, incrUnique, listTyConKey )
import Util
\end{code}
......
......@@ -49,10 +49,9 @@ IMPORT_DELOOPER(TyLoop) ( SYN_IE(Type), GenType,
--LATER: specMaybeTysSuffix
)
#else
import {-# SOURCE #-} Type ( Type )
import {-# SOURCE #-} Type ( Type, splitSigmaTy, splitFunTy )
import {-# SOURCE #-} Class ( Class )
import {-# SOURCE #-} Id ( Id, isNullaryDataCon, idType )
import {-# SOURCE #-} Type ( splitSigmaTy, splitFunTy )
import {-# SOURCE #-} TysWiredIn ( tupleCon )
#endif
......@@ -63,8 +62,7 @@ import Kind ( Kind, mkBoxedTypeKind, mkArrowKind, resultKind, argKind )
import Maybes
import Name ( Name, nameUnique, mkWiredInTyConName, NamedThing(getName) )
import Unique ( Unique, funTyConKey )
import UniqFM ( Uniquable(..) )
import Unique ( Unique, funTyConKey, Uniquable(..) )
import Pretty ( Doc )
import PrimRep ( PrimRep(..) )
import PrelMods ( gHC__, pREL_TUP, pREL_BASE )
......
......@@ -38,8 +38,7 @@ import Name ( mkSysLocalName, changeUnique, Name, NamedThing(..) )
import Pretty ( Doc, (<>), ptext )
import Outputable ( PprStyle(..), Outputable(..) )
import SrcLoc ( noSrcLoc, SrcLoc )
import Unique ( showUnique, mkAlphaTyVarUnique, Unique )
import UniqFM ( Uniquable(..) )
import Unique ( showUnique, mkAlphaTyVarUnique, Unique, Uniquable(..) )
import Util ( panic, Ord3(..) )
\end{code}
......
......@@ -74,7 +74,6 @@ import Name ( NamedThing(..),
import Maybes ( maybeToBool, assocMaybe )
import PrimRep ( PrimRep(..) )
import Unique -- quite a few *Keys
import UniqFM ( Uniquable(..) )
import Util ( thenCmp, zipEqual, assoc,
panic, panic#, assertPanic, pprPanic,
Ord3(..){-instances-}
......
......@@ -53,8 +53,7 @@ import IOBase
import IOHandle
import ST
import STBase
import {-# SOURCE #-} Unique ( mkUniqueGrimily, Unique )
import {-# SOURCE #-} UniqFM ( Uniquable(..) )
import {-# SOURCE #-} Unique ( mkUniqueGrimily, Unique, Uniquable(..) )
#if __GLASGOW_HASKELL__ == 202
import PrelBase ( Char (..) )
#endif
......
......@@ -418,7 +418,7 @@ hcat = foldr (<>) empty
hsep = foldr (<+>) empty
vcat = foldr ($$) empty
hang d1 n d2 = d1 $$ (nest n d2)
hang d1 n d2 = sep [d1, nest n d2]
punctuate p [] = []
punctuate p (d:ds) = go d ds
......
......@@ -3,7 +3,6 @@ Things which are ubiquitous in the GHC compiler.
\begin{code}
interface Ubiq where
--import PreludePS(_PackedString)
import FastString(FastString)
import BasicTypes ( Module(..), Arity(..) )
......
......@@ -21,7 +21,6 @@ Basically, the things need to be in class @Uniquable@, and we use the
module UniqFM (
UniqFM, -- abstract type
Uniquable(..), -- class to go with it
emptyUFM,
unitUFM,
......@@ -64,7 +63,7 @@ import {-# SOURCE #-} Name
# endif
#endif
import Unique ( Unique, u2i, mkUniqueGrimily )
import Unique ( Uniquable(..), Unique, u2i, mkUniqueGrimily )
import Util
import Pretty ( Doc )
import Outputable ( PprStyle, Outputable(..) )
......@@ -207,9 +206,6 @@ data UniqFM ele
(UniqFM ele)
(UniqFM ele)
class Uniquable a where
uniqueOf :: a -> Unique
-- for debugging only :-)
{-
instance Text (UniqFM a) where
......
......@@ -28,7 +28,7 @@ import {-# SOURCE #-} Name
import Maybes ( maybeToBool )
import UniqFM
import Unique ( Unique )
import Unique ( Unique, Uniquable(..) )
import SrcLoc ( SrcLoc )
import Outputable ( PprStyle, Outputable(..) )
import Pretty ( Doc )
......
Markdown is supported
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