Commit e4b0fab5 authored by simonpj's avatar simonpj

[project @ 2000-04-03 09:52:28 by simonpj]

* Make it so that recursive newtype declarations don't send
  GHC into an infinite loop.

	newtype T = MkT T

  This happened because Type.repType looked throught newtypes,
  and that never stopped!  Now TcTyDecls.mkNewTyConRep does the job
  more carefully, and the result is cached in the TyCon itself.


* Improve the handling of type signatures & pragmas.  Previously a
  mis-placed (say) SPECIALISE instance pragmas could be silently
  ignored.


Both these changes involved moving quite a lot of stuff between modules.
parent 1131cd79
......@@ -2,7 +2,8 @@ This module deals with printing C string literals
\begin{code}
module CStrings(
CLabelString, isCLabelString,
CLabelString, isCLabelString, pprCLabelString,
cSEP, pp_cSEP,
stringToC, charToC, pprFSInCStyle,
......@@ -19,6 +20,8 @@ import Outputable
\begin{code}
type CLabelString = FAST_STRING -- A C label, completely unencoded
pprCLabelString lbl = ptext lbl
isCLabelString :: CLabelString -> Bool -- Checks to see if this is a valid C label
isCLabelString lbl
= all ok (_UNPK_ lbl)
......
......@@ -38,7 +38,7 @@ import CmdLineOpts ( opt_SccProfilingOn, opt_EmitCExternDecls, opt_GranMacros )
import CostCentre ( pprCostCentreDecl, pprCostCentreStackDecl )
import Costs ( costs, addrModeCosts, CostRes(..), Side(..) )
import CStrings ( stringToC )
import CStrings ( stringToC, pprCLabelString )
import FiniteMap ( addToFM, emptyFM, lookupFM, FiniteMap )
import Literal ( Literal(..) )
import TyCon ( tyConDataCons )
......@@ -328,7 +328,7 @@ pprAbsC stmt@(CCallTypedef is_tdef (CCall op_str is_asm may_gc cconv) results ar
ccall_fun_ty =
case op_str of
DynamicTarget u -> ptext SLIT("_ccall_fun_ty") <> ppr u
StaticTarget x -> ptext x
StaticTarget x -> pprCLabelString x
ccall_res_ty =
case non_void_results of
......
......@@ -121,7 +121,6 @@ negatePrecedence = 6
data NewOrData
= NewType -- "newtype Blah ..."
| DataType -- "data Blah ..."
| EnumType -- Enumeration; all constructors are nullary
deriving( Eq ) -- Needed because Demand derives Eq
\end{code}
......
......@@ -14,6 +14,8 @@ module Name (
mkTopName, mkIPName,
mkDerivedName, mkGlobalName, mkKnownKeyGlobal,
mkWiredInIdName, mkWiredInTyConName,
mkUnboundName, isUnboundName,
maybeWiredInIdName, maybeWiredInTyConName,
isWiredInName, hashName,
......@@ -48,7 +50,7 @@ import RdrName ( RdrName, mkRdrQual, mkRdrUnqual, rdrNameOcc, rdrNameModule )
import CmdLineOpts ( opt_PprStyle_NoPrags, opt_OmitInterfacePragmas, opt_EnsureSplittableC )
import SrcLoc ( noSrcLoc, mkBuiltinSrcLoc, SrcLoc )
import Unique ( pprUnique, Unique, Uniquable(..), u2i )
import Unique ( pprUnique, Unique, Uniquable(..), unboundKey, u2i )
import Outputable
import GlaExts
\end{code}
......@@ -170,6 +172,16 @@ mkDerivedName :: (OccName -> OccName)
mkDerivedName f name uniq = name {n_uniq = uniq, n_occ = f (n_occ name)}
-- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly
-- during compiler debugging.
mkUnboundName :: RdrName -> Name
mkUnboundName rdr_name = mkLocalName unboundKey (rdrNameOcc rdr_name) noSrcLoc
isUnboundName :: Name -> Bool
isUnboundName name = getUnique name == unboundKey
\end{code}
\begin{code}
-- When we renumber/rename things, we need to be
-- able to change a Name's Unique to match the cached
-- one in the thing it's the name of. If you know what I mean.
......
......@@ -39,6 +39,7 @@ import TysWiredIn ( unitDataConId, stringTy,
unboxedPairDataCon,
mkUnboxedTupleTy, unboxedTupleCon
)
import CStrings ( CLabelString )
import Unique ( Unique )
import VarSet ( varSetElems )
import Outputable
......@@ -80,7 +81,7 @@ follows:
\end{verbatim}
\begin{code}
dsCCall :: FAST_STRING -- C routine to invoke
dsCCall :: CLabelString -- C routine to invoke
-> [CoreExpr] -- Arguments (desugared)
-> Bool -- True <=> might cause Haskell GC
-> Bool -- True <=> really a "_casm_"
......
......@@ -14,19 +14,21 @@ import {-# SOURCE #-} HsExpr ( pprExpr, HsExpr )
import {-# SOURCE #-} HsMatches ( pprMatches, Match, pprGRHSs, GRHSs )
-- friends:
import HsTypes ( HsType )
import HsTypes ( HsType, cmpHsType )
import HsImpExp ( IE(..), ieName )
import CoreSyn ( CoreExpr )
import PprCore () -- Instances for Outputable
--others:
import Id ( Id )
import NameSet ( NameSet, nameSetToList )
import Name ( Name, isUnboundName )
import NameSet ( NameSet, elemNameSet, nameSetToList )
import BasicTypes ( RecFlag(..), Fixity )
import Outputable
import Bag
import SrcLoc ( SrcLoc )
import Var ( TyVar )
import Util ( thenCmp )
\end{code}
%************************************************************************
......@@ -272,21 +274,45 @@ type DeprecTxt = FAST_STRING -- reason/explanation for deprecation
\end{code}
\begin{code}
okBindSig :: NameSet -> Sig Name -> Bool
okBindSig ns (ClassOpSig _ _ _ _ _) = False
okBindSig ns sig = sigForThisGroup ns sig
okClsDclSig :: NameSet -> Sig Name -> Bool
okClsDclSig ns (Sig _ _ _) = False
okClsDclSig ns sig = sigForThisGroup ns sig
okInstDclSig :: NameSet -> Sig Name -> Bool
okInstDclSig ns (Sig _ _ _) = False
okInstDclSig ns (FixSig _) = False
okInstDclSig ns (SpecInstSig _ _) = True
okInstDclSig ns sig = sigForThisGroup ns sig
sigForThisGroup ns sig
= case sigName sig of
Nothing -> False
Just n | isUnboundName n -> True -- Don't complain about an unbound name again
| otherwise -> n `elemNameSet` ns
sigsForMe :: (name -> Bool) -> [Sig name] -> [Sig name]
sigsForMe f sigs
= filter sig_for_me sigs
where
sig_for_me (Sig n _ _) = f n
sig_for_me (ClassOpSig n _ _ _ _) = f n
sig_for_me (SpecSig n _ _) = f n
sig_for_me (InlineSig n _ _) = f n
sig_for_me (NoInlineSig n _ _) = f n
sig_for_me (SpecInstSig _ _) = False
sig_for_me (FixSig (FixitySig n _ _)) = f n
sig_for_me
(DeprecSig (Deprecation (IEModuleContents _) _) _) = False
sig_for_me
(DeprecSig (Deprecation d _) _) = f (ieName d)
sig_for_me sig = case sigName sig of
Nothing -> False
Just n -> f n
sigName :: Sig name -> Maybe name
sigName (Sig n _ _) = Just n
sigName (ClassOpSig n _ _ _ _) = Just n
sigName (SpecSig n _ _) = Just n
sigName (InlineSig n _ _) = Just n
sigName (NoInlineSig n _ _) = Just n
sigName (FixSig (FixitySig n _ _)) = Just n
sigName (DeprecSig (Deprecation d _) _) = case d of
IEModuleContents _ -> Nothing
other -> Just (ieName d)
sigName other = Nothing
isFixitySig :: Sig name -> Bool
isFixitySig (FixSig _) = True
......@@ -306,6 +332,17 @@ isPragSig (DeprecSig _ _) = True
isPragSig other = False
\end{code}
\begin{code}
hsSigDoc (Sig _ _ loc) = (SLIT("type signature"),loc)
hsSigDoc (ClassOpSig _ _ _ _ loc) = (SLIT("class-method type signature"), loc)
hsSigDoc (SpecSig _ _ loc) = (SLIT("SPECIALISE pragma"),loc)
hsSigDoc (InlineSig _ _ loc) = (SLIT("INLINE pragma"),loc)
hsSigDoc (NoInlineSig _ _ loc) = (SLIT("NOINLINE pragma"),loc)
hsSigDoc (SpecInstSig _ loc) = (SLIT("SPECIALISE instance pragma"),loc)
hsSigDoc (FixSig (FixitySig _ _ loc)) = (SLIT("fixity declaration"), loc)
hsSigDoc (DeprecSig _ loc) = (SLIT("DEPRECATED pragma"), loc)
\end{code}
\begin{code}
instance (Outputable name) => Outputable (Sig name) where
ppr sig = ppr_sig sig
......@@ -349,3 +386,41 @@ ppr_phase Nothing = empty
ppr_phase (Just n) = int n
\end{code}
Checking for distinct signatures; oh, so boring
\begin{code}
cmpHsSig :: Sig Name -> Sig Name -> Ordering
cmpHsSig (Sig n1 _ _) (Sig n2 _ _) = n1 `compare` n2
cmpHsSig (DeprecSig (Deprecation ie1 _) _)
(DeprecSig (Deprecation ie2 _) _) = cmp_ie ie1 ie2
cmpHsSig (InlineSig n1 _ _) (InlineSig n2 _ _) = n1 `compare` n2
cmpHsSig (NoInlineSig n1 _ _) (NoInlineSig n2 _ _) = n1 `compare` n2
cmpHsSig (SpecInstSig ty1 _) (SpecInstSig ty2 _) = cmpHsType compare ty1 ty2
cmpHsSig (SpecSig n1 ty1 _) (SpecSig n2 ty2 _)
= -- may have many specialisations for one value;
-- but not ones that are exactly the same...
thenCmp (n1 `compare` n2) (cmpHsType compare ty1 ty2)
cmpHsSig other_1 other_2 -- Tags *must* be different
| (sig_tag other_1) _LT_ (sig_tag other_2) = LT
| otherwise = GT
cmp_ie :: IE Name -> IE Name -> Ordering
cmp_ie (IEVar n1 ) (IEVar n2 ) = n1 `compare` n2
cmp_ie (IEThingAbs n1 ) (IEThingAbs n2 ) = n1 `compare` n2
cmp_ie (IEThingAll n1 ) (IEThingAll n2 ) = n1 `compare` n2
-- Hmmm...
cmp_ie (IEThingWith n1 _) (IEThingWith n2 _) = n1 `compare` n2
cmp_ie (IEModuleContents _ ) (IEModuleContents _ ) = EQ
sig_tag (Sig n1 _ _) = (ILIT(1) :: FAST_INT)
sig_tag (SpecSig n1 _ _) = ILIT(2)
sig_tag (InlineSig n1 _ _) = ILIT(3)
sig_tag (NoInlineSig n1 _ _) = ILIT(4)
sig_tag (SpecInstSig _ _) = ILIT(5)
sig_tag (FixSig _) = ILIT(6)
sig_tag (DeprecSig _ _) = ILIT(7)
sig_tag _ = panic# "tag(RnBinds)"
\end{code}
......@@ -31,7 +31,7 @@ import Var ( TyVar )
-- others:
import PprType
import {-# SOURCE #-} FunDeps ( pprFundeps )
import CStrings ( CLabelString )
import CStrings ( CLabelString, pprCLabelString )
import Outputable
import SrcLoc ( SrcLoc )
import Util
......@@ -413,13 +413,11 @@ extNameStatic :: ExtName -> CLabelString
extNameStatic (ExtName f _) = f
extNameStatic Dynamic = panic "staticExtName: Dynamic - shouldn't ever happen."
instance Outputable ExtName where
ppr Dynamic = ptext SLIT("dynamic")
ppr (ExtName nm mb_mod) =
case mb_mod of { Nothing -> empty; Just m -> doubleQuotes (ptext m) } <+>
doubleQuotes (ptext nm)
doubleQuotes (pprCLabelString nm)
\end{code}
%************************************************************************
......
......@@ -23,6 +23,7 @@ import PprType ( pprType, pprParendType )
import Type ( Type )
import Var ( TyVar, Id )
import DataCon ( DataCon )
import CStrings ( CLabelString, pprCLabelString )
import SrcLoc ( SrcLoc )
\end{code}
......@@ -137,7 +138,7 @@ data HsExpr id pat
(HsExpr id pat) -- (typechecked, of course)
(ArithSeqInfo id pat)
| HsCCall FAST_STRING -- call into the C world; string is
| HsCCall CLabelString -- call into the C world; string is
[HsExpr id pat] -- the C function; exprs are the
-- arguments to pass.
Bool -- True <=> might cause Haskell
......@@ -337,8 +338,8 @@ ppr_expr (EAsPat v e) = ppr v <> char '@' <> pprParendExpr e
ppr_expr (HsCCall fun args _ is_asm result_ty)
= hang (if is_asm
then ptext SLIT("_casm_ ``") <> ptext fun <> ptext SLIT("''")
else ptext SLIT("_ccall_") <+> ptext fun)
then ptext SLIT("_casm_ ``") <> pprCLabelString fun <> ptext SLIT("''")
else ptext SLIT("_ccall_") <+> pprCLabelString fun)
4 (sep (map pprParendExpr args))
ppr_expr (HsSCC lbl expr)
......
......@@ -43,6 +43,7 @@ import Type ( Type, mkForAllTys, mkForAllTy, mkFunTy, mkFunTys, mkTyVarTys,
)
import Unique ( Unique, mkPrimOpIdUnique )
import BasicTypes ( Arity )
import CStrings ( CLabelString, pprCLabelString )
import PrelMods ( pREL_GHC, pREL_GHC_Name )
import Outputable
import Util ( assoc, zipWithEqual )
......@@ -2395,7 +2396,7 @@ data CCall
CallConv -- calling convention to use.
data CCallTarget
= StaticTarget FAST_STRING -- An "unboxed" ccall# to `fn'.
= StaticTarget CLabelString -- An "unboxed" ccall# to `fn'.
| DynamicTarget Unique -- First argument (an Addr#) is the function pointer
-- (unique is used to generate a 'typedef' to cast
-- the function pointer if compiling the ccall# down to
......@@ -2432,5 +2433,5 @@ pprCCallOp (CCall fun is_casm may_gc cconv)
ppr_fun = case fun of
DynamicTarget _ -> text "\"\""
StaticTarget fn -> ptext fn
StaticTarget fn -> pprCLabelString fn
\end{code}
......@@ -86,7 +86,7 @@ import Module ( Module, mkPrelModule )
import Name ( mkWiredInTyConName, mkWiredInIdName, mkSrcOccFS, mkWorkerOcc, dataName )
import DataCon ( DataCon, StrictnessMark(..), mkDataCon, dataConId )
import Var ( TyVar, tyVarKind )
import TyCon ( TyCon, ArgVrcs, mkAlgTyCon, mkSynTyCon, mkTupleTyCon )
import TyCon ( TyCon, AlgTyConFlavour(..), ArgVrcs, mkAlgTyCon, mkSynTyCon, mkTupleTyCon )
import BasicTypes ( Arity, NewOrData(..), RecFlag(..) )
import Type ( Type, mkTyConTy, mkTyConApp, mkSigmaTy, mkTyVarTys,
mkArrowKinds, boxedTypeKind, unboxedTypeKind,
......@@ -104,13 +104,12 @@ alpha_tyvar = [alphaTyVar]
alpha_ty = [alphaTy]
alpha_beta_tyvars = [alphaTyVar, betaTyVar]
pcRecDataTyCon, pcNonRecDataTyCon, pcNonRecNewTyCon
pcRecDataTyCon, pcNonRecDataTyCon
:: Unique{-TyConKey-} -> Module -> FAST_STRING
-> [TyVar] -> ArgVrcs -> [DataCon] -> TyCon
pcRecDataTyCon = pcTyCon DataType Recursive
pcNonRecDataTyCon = pcTyCon DataType NonRecursive
pcNonRecNewTyCon = pcTyCon NewType NonRecursive
pcRecDataTyCon = pcTyCon DataTyCon Recursive
pcNonRecDataTyCon = pcTyCon DataTyCon NonRecursive
pcTyCon new_or_data is_rec key mod str tyvars argvrcs cons
= tycon
......@@ -121,7 +120,6 @@ pcTyCon new_or_data is_rec key mod str tyvars argvrcs cons
argvrcs
cons
[] -- No derivings
Nothing -- Not a dictionary
new_or_data
is_rec
......@@ -157,6 +155,7 @@ pcDataCon wrap_key mod str tyvars context arg_tys tycon
wrap_id = mkDataConWrapId data_con
\end{code}
%************************************************************************
%* *
\subsection[TysWiredIn-tuples]{The tuple types}
......@@ -521,7 +520,7 @@ primitive counterpart.
\begin{code}
boolTy = mkTyConTy boolTyCon
boolTyCon = pcTyCon EnumType NonRecursive boolTyConKey
boolTyCon = pcTyCon EnumTyCon NonRecursive boolTyConKey
pREL_BASE SLIT("Bool") [] [] [falseDataCon, trueDataCon]
falseDataCon = pcDataCon falseDataConKey pREL_BASE SLIT("False") [] [] [] boolTyCon
......
......@@ -21,19 +21,19 @@ module RnBinds (
import {-# SOURCE #-} RnSource ( rnHsSigType )
import HsSyn
import HsBinds ( sigsForMe )
import HsBinds ( sigsForMe, cmpHsSig, sigName, hsSigDoc )
import RdrHsSyn
import RnHsSyn
import RnMonad
import RnExpr ( rnMatch, rnGRHSs, rnPat, checkPrecMatch )
import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, lookupGlobalOccRn,
import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, lookupGlobalOccRn, lookupOccRn,
warnUnusedLocalBinds, mapFvRn,
FreeVars, emptyFVs, plusFV, plusFVs, unitFV, addOneFV,
unknownNameErr
)
import CmdLineOpts ( opt_WarnMissingSigs )
import Digraph ( stronglyConnComp, SCC(..) )
import Name ( OccName, Name, nameOccName )
import Name ( OccName, Name, nameOccName, mkUnboundName, isUnboundName )
import NameSet
import RdrName ( RdrName, rdrNameOcc )
import BasicTypes ( RecFlag(..), TopLevelFlag(..) )
......@@ -173,24 +173,18 @@ rnTopMonoBinds EmptyMonoBinds sigs
rnTopMonoBinds mbinds sigs
= mapRn lookupBndrRn binder_rdr_names `thenRn` \ binder_names ->
renameSigs (okBindSig (mkNameSet binder_names)) sigs `thenRn` \ (siglist, sig_fvs) ->
let
binder_set = mkNameSet binder_names
binder_occ_fm = listToFM [(nameOccName x,x) | x <- binder_names]
type_sig_vars = [n | Sig n _ _ <- siglist]
un_sigd_binders | opt_WarnMissingSigs = binder_names `minusList` type_sig_vars
| otherwise = []
in
renameSigs opt_WarnMissingSigs binder_set
(lookupSigOccRn binder_occ_fm) sigs `thenRn` \ (siglist, sig_fvs) ->
mapRn_ (addWarnRn.missingSigWarn) un_sigd_binders `thenRn_`
rn_mono_binds siglist mbinds `thenRn` \ (final_binds, bind_fvs) ->
returnRn (final_binds, bind_fvs `plusFV` sig_fvs)
where
binder_rdr_names = map fst (bagToList (collectMonoBinders mbinds))
-- the names appearing in the sigs have to be bound by
-- this group's binders.
lookupSigOccRn binder_occ_fm rdr_name
= case lookupFM binder_occ_fm (rdrNameOcc rdr_name) of
Nothing -> failWithRn (mkUnboundName rdr_name)
(unknownNameErr rdr_name)
Just x -> returnRn x
\end{code}
%************************************************************************
......@@ -233,26 +227,15 @@ rnMonoBinds mbinds sigs thing_inside -- Non-empty monobinds
bindLocatedLocalsRn (text "a binding group") mbinders_w_srclocs
$ \ new_mbinders ->
let
binder_set = mkNameSet new_mbinders
binder_occ_fm = listToFM [(nameOccName x,x) | x <- new_mbinders]
-- Weed out the fixity declarations that do not
-- apply to any of the binders in this group.
(sigs_for_me, fixes_not_for_me) = partition forLocalBind sigs
forLocalBind (FixSig sig@(FixitySig name _ _ )) =
isJust (lookupFM binder_occ_fm (rdrNameOcc name))
forLocalBind _ = True
binder_set = mkNameSet new_mbinders
in
-- Rename the signatures
renameSigs False binder_set
(lookupSigOccRn binder_occ_fm) sigs_for_me `thenRn` \ (siglist, sig_fvs) ->
renameSigs (okBindSig binder_set) sigs `thenRn` \ (siglist, sig_fvs) ->
-- Report the fixity declarations in this group that
-- don't refer to any of the group's binders.
-- Then install the fixity declarations that do apply here
-- Notice that they scope over thing_inside too
mapRn_ (unknownSigErr) fixes_not_for_me `thenRn_`
let
fixity_sigs = [(name,sig) | FixSig sig@(FixitySig name _ _) <- siglist ]
in
......@@ -483,32 +466,29 @@ At the moment we don't gather free-var info from the types in
signatures. We'd only need this if we wanted to report unused tyvars.
\begin{code}
renameSigs :: Bool -- True => warn if (required) type signatures are missing.
-> NameSet -- Set of names bound in this group
-> (RdrName -> RnMS Name)
renameSigs :: (RenamedSig -> Bool) -- OK-sig predicate
-> [RdrNameSig]
-> RnMS ([RenamedSig], FreeVars) -- List of Sig constructors
-> RnMS ([RenamedSig], FreeVars)
renameSigs ok_sig [] = returnRn ([], emptyFVs) -- Common shortcut
renameSigs sigs_required binders lookup_occ_nm sigs
renameSigs ok_sig sigs
= -- Rename the signatures
mapFvRn (renameSig lookup_occ_nm) sigs `thenRn` \ (sigs', fvs) ->
mapFvRn renameSig sigs `thenRn` \ (sigs', fvs) ->
-- Check for (a) duplicate signatures
-- (b) signatures for things not in this group
-- (c) optionally, bindings with no signature
let
(goodies, dups) = removeDups cmp_sig (sigsForMe (not . isUnboundName) sigs')
not_this_group = sigsForMe (not . (`elemNameSet` binders)) goodies
type_sig_vars = [n | Sig n _ _ <- goodies]
un_sigd_binders | sigs_required = nameSetToList binders `minusList` type_sig_vars
| otherwise = []
in_scope = filter is_in_scope sigs'
is_in_scope sig = case sigName sig of
Just n -> not (isUnboundName n)
Nothing -> True
(not_dups, dups) = removeDups cmpHsSig in_scope
(goods, bads) = partition ok_sig not_dups
in
mapRn_ dupSigDeclErr dups `thenRn_`
mapRn_ unknownSigErr not_this_group `thenRn_`
mapRn_ (addWarnRn.missingSigWarn) un_sigd_binders `thenRn_`
returnRn (sigs', fvs)
-- bad ones and all:
-- we need bindings of *some* sort for every name
mapRn_ unknownSigErr bads `thenRn_`
mapRn_ dupSigDeclErr dups `thenRn_`
returnRn (goods, fvs)
-- We use lookupOccRn in the signatures, which is a little bit unsatisfactory
-- because this won't work for:
......@@ -519,43 +499,43 @@ renameSigs sigs_required binders lookup_occ_nm sigs
-- is in scope. (I'm assuming that Baz.op isn't in scope unqualified.)
-- Doesn't seem worth much trouble to sort this.
renameSig :: (RdrName -> RnMS Name) -> Sig RdrName -> RnMS (Sig Name, FreeVars)
renameSig :: Sig RdrName -> RnMS (Sig Name, FreeVars)
renameSig lookup_occ_nm (Sig v ty src_loc)
renameSig (Sig v ty src_loc)
= pushSrcLocRn src_loc $
lookup_occ_nm v `thenRn` \ new_v ->
lookupOccRn v `thenRn` \ new_v ->
rnHsSigType (quotes (ppr v)) ty `thenRn` \ (new_ty,fvs) ->
returnRn (Sig new_v new_ty src_loc, fvs `addOneFV` new_v)
renameSig _ (SpecInstSig ty src_loc)
renameSig (SpecInstSig ty src_loc)
= pushSrcLocRn src_loc $
rnHsSigType (text "A SPECIALISE instance pragma") ty `thenRn` \ (new_ty, fvs) ->
returnRn (SpecInstSig new_ty src_loc, fvs)
renameSig lookup_occ_nm (SpecSig v ty src_loc)
renameSig (SpecSig v ty src_loc)
= pushSrcLocRn src_loc $
lookup_occ_nm v `thenRn` \ new_v ->
lookupOccRn v `thenRn` \ new_v ->
rnHsSigType (quotes (ppr v)) ty `thenRn` \ (new_ty,fvs) ->
returnRn (SpecSig new_v new_ty src_loc, fvs `addOneFV` new_v)
renameSig lookup_occ_nm (FixSig (FixitySig v fix src_loc))
renameSig (FixSig (FixitySig v fix src_loc))
= pushSrcLocRn src_loc $
lookup_occ_nm v `thenRn` \ new_v ->
lookupOccRn v `thenRn` \ new_v ->
returnRn (FixSig (FixitySig new_v fix src_loc), unitFV new_v)
renameSig lookup_occ_nm (DeprecSig (Deprecation ie txt) src_loc)
renameSig (DeprecSig (Deprecation ie txt) src_loc)
= pushSrcLocRn src_loc $
renameIE lookup_occ_nm ie `thenRn` \ (new_ie, fvs) ->
renameIE lookupOccRn ie `thenRn` \ (new_ie, fvs) ->
returnRn (DeprecSig (Deprecation new_ie txt) src_loc, fvs)
renameSig lookup_occ_nm (InlineSig v p src_loc)
renameSig (InlineSig v p src_loc)
= pushSrcLocRn src_loc $
lookup_occ_nm v `thenRn` \ new_v ->
lookupOccRn v `thenRn` \ new_v ->
returnRn (InlineSig new_v p src_loc, unitFV new_v)
renameSig lookup_occ_nm (NoInlineSig v p src_loc)
renameSig (NoInlineSig v p src_loc)
= pushSrcLocRn src_loc $
lookup_occ_nm v `thenRn` \ new_v ->
lookupOccRn v `thenRn` \ new_v ->
returnRn (NoInlineSig new_v p src_loc, unitFV new_v)
\end{code}
......@@ -582,43 +562,6 @@ renameIE lookup_occ_nm (IEModuleContents m)
= returnRn (IEModuleContents m, emptyFVs)
\end{code}
Checking for distinct signatures; oh, so boring
\begin{code}
cmp_sig :: RenamedSig -> RenamedSig -> Ordering
cmp_sig (Sig n1 _ _) (Sig n2 _ _) = n1 `compare` n2
cmp_sig (DeprecSig (Deprecation ie1 _) _)
(DeprecSig (Deprecation ie2 _) _) = cmp_ie ie1 ie2
cmp_sig (InlineSig n1 _ _) (InlineSig n2 _ _) = n1 `compare` n2
cmp_sig (NoInlineSig n1 _ _) (NoInlineSig n2 _ _) = n1 `compare` n2
cmp_sig (SpecInstSig ty1 _) (SpecInstSig ty2 _) = cmpHsType compare ty1 ty2
cmp_sig (SpecSig n1 ty1 _) (SpecSig n2 ty2 _)
= -- may have many specialisations for one value;
-- but not ones that are exactly the same...
thenCmp (n1 `compare` n2) (cmpHsType compare ty1 ty2)
cmp_sig other_1 other_2 -- Tags *must* be different
| (sig_tag other_1) _LT_ (sig_tag other_2) = LT
| otherwise = GT
cmp_ie :: IE Name -> IE Name -> Ordering
cmp_ie (IEVar n1 ) (IEVar n2 ) = n1 `compare` n2
cmp_ie (IEThingAbs n1 ) (IEThingAbs n2 ) = n1 `compare` n2
cmp_ie (IEThingAll n1 ) (IEThingAll n2 ) = n1 `compare` n2
-- Hmmm...
cmp_ie (IEThingWith n1 _) (IEThingWith n2 _) = n1 `compare` n2
cmp_ie (IEModuleContents _ ) (IEModuleContents _ ) = EQ
sig_tag (Sig n1 _ _) = (ILIT(1) :: FAST_INT)
sig_tag (SpecSig n1 _ _) = ILIT(2)
sig_tag (InlineSig n1 _ _) = ILIT(3)
sig_tag (NoInlineSig n1 _ _) = ILIT(4)
sig_tag (SpecInstSig _ _) = ILIT(5)
sig_tag (FixSig _) = ILIT(6)
sig_tag (DeprecSig _ _) = ILIT(7)
sig_tag _ = panic# "tag(RnBinds)"
\end{code}
%************************************************************************
%* *
......@@ -632,24 +575,14 @@ dupSigDeclErr (sig:sigs)
addErrRn (sep [ptext SLIT("Duplicate") <+> ptext what_it_is <> colon,
ppr sig])
where
(what_it_is, loc) = sig_doc sig
(what_it_is, loc) = hsSigDoc sig
unknownSigErr sig
= pushSrcLocRn loc $
addErrRn (sep [ptext SLIT("Misplaced"),
ptext what_it_is <> colon,
addErrRn (sep [ptext SLIT("Misplaced") <+> ptext what_it_is <> colon,
ppr sig])
where
(what_it_is, loc) = sig_doc sig
sig_doc (Sig _ _ loc) = (SLIT("type signature"),loc)
sig_doc (ClassOpSig _ _ _ _ loc) = (SLIT("class-method type signature"), loc)
sig_doc (SpecSig _ _ loc) = (SLIT("SPECIALISE pragma"),loc)
sig_doc (InlineSig _ _ loc) = (SLIT("INLINE pragma"),loc)
sig_doc (NoInlineSig _ _ loc) = (SLIT("NOINLINE pragma"),loc)
sig_doc (SpecInstSig _ loc) = (SLIT("SPECIALISE instance pragma"),loc)
sig_doc (FixSig (FixitySig _ _ loc)) = (SLIT("fixity declaration"), loc)
sig_doc (DeprecSig _ loc) = (SLIT("DEPRECATED pragma"), loc)
(what_it_is, loc) = hsSigDoc sig
missingSigWarn var
= sep [ptext SLIT("definition but no type signature for"), quotes (ppr var)]
......
......@@ -21,7 +21,7 @@ import HsTypes ( getTyVarName, replaceTyVarName )
import RnMonad
import Name ( Name, Provenance(..), ExportFlag(..), NamedThing(..),
ImportReason(..), getSrcLoc,
mkLocalName, mkImportedLocalName, mkGlobalName,
mkLocalName, mkImportedLocalName, mkGlobalName, mkUnboundName,
mkIPName, isSystemName,
nameOccName, setNameModule, nameModule,
pprOccName, isLocallyDefined, nameUnique, nameOccName,
......
......@@ -39,7 +39,7 @@ import ErrUtils ( addShortErrLocLine, addShortWarnLocLine,
)
import Name ( Name, OccName, NamedThing(..),
isLocallyDefinedName, nameModule, nameOccName,
decode, mkLocalName
decode, mkLocalName, mkUnboundName
)
import Module ( Module, ModuleName, ModuleHiMap, SearchPath, WhereFrom,
mkModuleHiMaps, moduleName, mkVanillaModule, mkSearchPath
......@@ -431,14 +431,6 @@ emptyIfaces = Ifaces { iImpModInfo = emptyFM,
iDeprecs = emptyNameEnv
}
-- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly
-- during compiler debugging.
mkUnboundName :: RdrName -> Name
mkUnboundName rdr_name = mkLocalName unboundKey (rdrNameOcc rdr_name) noSrcLoc
isUnboundName :: Name -> Bool
isUnboundName name = getUnique name == unboundKey
builtins :: FiniteMap (ModuleName,OccName) Name
builtins =
bagToFM (
......
......@@ -200,15 +200,13 @@ rnDecl (TyClD (ClassDecl context cname tyvars fds sigs mbinds pragmas
let
-- First process the class op sigs, then the fixity sigs.
(op_sigs, non_op_sigs) = partition isClassOpSig sigs
(fix_sigs, non_sigs) = partition isFixitySig non_op_sigs
in
checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenRn_`
mapFvRn (rn_op cname' clas_tyvar_names fds') op_sigs `thenRn` \ (sigs', sig_fvs) ->
mapRn_ (unknownSigErr) non_sigs `thenRn_`
let
binders = mkNameSet [ nm | (ClassOpSig nm _ _ _ _) <- sigs' ]
in
renameSigs False binders lookupOccRn fix_sigs `thenRn` \ (fixs', fix_fvs) ->
renameSigs (okClsDclSig binders) non_op_sigs `thenRn` \ (non_ops', fix_fvs) ->