then
CoreSyn
then
- IdInfo (loop CoreSyn.CoreRules etc, loop CoreUnfold.Unfolding)
+ IdInfo (CoreSyn.Unfolding, CoreSyn.CoreRules)
then
Id (lots from IdInfo)
then
CoreFVs, PprCore
then
CoreUtils (PprCore.pprCoreExpr, CoreFVs.exprFreeVars,
- loop CoreUnfold.isEvaldUnfolding CoreUnfold.maybeUnfoldingTemplate)
+ CoreSyn.isEvaldUnfolding CoreSyn.maybeUnfoldingTemplate)
then
OccurAnal (CoreUtils.exprIsTrivial)
then
\begin{code}
module BasicTypes(
- Version,
+ Version, bumpVersion, initialVersion, bogusVersion,
Arity,
TopLevelFlag(..), isTopLevel, isNotTopLevel,
+ Boxity(..), isBoxed, tupleParens,
+
OccInfo(..), seqOccInfo, isFragileOccInfo, isLoopBreaker,
+
InsideLam, insideLam, notInsideLam,
OneBranch, oneBranch, notOneBranch
\begin{code}
type Version = Int
+
+bogusVersion :: Version -- Shouldn't look at these
+bogusVersion = error "bogusVersion"
+
+bumpVersion :: Version -> Version
+bumpVersion v = v+1
+
+initialVersion :: Version
+initialVersion = 1
\end{code}
%************************************************************************
%* *
+\subsection[Top-level/local]{Top-level/not-top level flag}
+%* *
+%************************************************************************
+
+\begin{code}
+data Boxity
+ = Boxed
+ | Unboxed
+ deriving( Eq )
+
+isBoxed :: Boxity -> Bool
+isBoxed Boxed = True
+isBoxed Unboxed = False
+
+tupleParens :: Boxity -> SDoc -> SDoc
+tupleParens Boxed p = parens p
+tupleParens Unboxed p = ptext SLIT("(#") <+> p <+> ptext SLIT("#)")
+\end{code}
+
+
+%************************************************************************
+%* *
\subsection[Recursive/Non-Recursive]{Recursive/Non-Recursive flag}
%* *
%************************************************************************
import Type ( Type, ThetaType, TauType, ClassContext,
mkForAllTys, mkFunTys, mkTyConApp,
mkTyVarTys, mkDictTys,
- splitAlgTyConApp_maybe, classesToPreds
+ splitTyConApp_maybe, classesToPreds
)
-import TyCon ( TyCon, tyConDataCons, isDataTyCon, isProductTyCon,
+import TyCon ( TyCon, tyConDataCons, tyConDataConsIfAvailable, isDataTyCon, isProductTyCon,
isTupleTyCon, isUnboxedTupleTyCon, isRecursiveTyCon )
import Class ( classTyCon )
import Name ( Name, NamedThing(..), nameUnique, isLocallyDefined )
dcRepArgTys :: [Type], -- Final, representation argument types, after unboxing and flattening,
-- and including existential dictionaries
- dcTyCon :: TyCon, -- Result tycon
+ dcTyCon :: TyCon, -- Result tycon
-- Now the strictness annotations and field labels of the constructor
dcUserStricts :: [StrictnessMark],
[Type]) -- Its *representation* arg types
-- Returns (Just ...) for any
+ -- concrete (i.e. constructors visible)
-- single-constructor
-- not existentially quantified
-- type whether a data type or a new type
-- it through till someone finds it's important.
splitProductType_maybe ty
- = case splitAlgTyConApp_maybe ty of
- Just (tycon,ty_args,[data_con])
- | isProductTyCon tycon -- Includes check for non-existential
+ = case splitTyConApp_maybe ty of
+ Just (tycon,ty_args)
+ | isProductTyCon tycon -- Includes check for non-existential,
+ -- and for constructors visible
-> Just (tycon, ty_args, data_con, dataConArgTys data_con ty_args)
+ where
+ data_con = head (tyConDataConsIfAvailable tycon)
other -> Nothing
splitProductType str ty
wwLazy = WwLazy False
wwStrict = WwStrict
wwUnpackData xs = WwUnpack DataType False xs
-wwUnpackNew x = WwUnpack NewType False [x]
+wwUnpackNew x = ASSERT( isStrict x) -- Invariant
+ WwUnpack NewType False [x]
wwPrim = WwPrim
wwEnum = WwEnum
%************************************************************************
\begin{code}
+isLazy :: Demand -> Bool
+ -- Even a demand of (WwUnpack NewType _ _) is strict
+ -- We don't create such a thing unless the demand inside is strict
+isLazy (WwLazy _) = True
+isLazy _ = False
+
isStrict :: Demand -> Bool
-isStrict (WwUnpack NewType _ ds) = isStrict (head ds)
-isStrict (WwUnpack other _ _) = True
-isStrict WwStrict = True
-isStrict WwEnum = True
-isStrict WwPrim = True
-isStrict _ = False
+isStrict d = not (isLazy d)
isPrim :: Demand -> Bool
isPrim WwPrim = True
isPrim other = False
\end{code}
-\begin{code}
-isLazy :: Demand -> Bool
-isLazy (WwLazy False) = True -- NB "Absent" args do *not* count!
-isLazy _ = False -- (as they imply a worker)
-\end{code}
-
%************************************************************************
%* *
-- BUT NB: f = \x y. error "urk"
-- will have info SI [SS] True
-- but still (f) and (f 2) are not bot; only (f 3 2) is bot
+ deriving( Eq )
-- NOTA BENE: if the arg demands are, say, [S,L], this means that
-- (f bot) is not necy bot, only (f bot x) is bot
mkStrictnessInfo :: ([Demand], Bool) -> StrictnessInfo
mkStrictnessInfo (xs, is_bot)
- | all isLazy xs && not is_bot = NoStrictnessInfo -- Uninteresting
- | otherwise = StrictnessInfo xs is_bot
+ | all totally_boring xs && not is_bot = NoStrictnessInfo -- Uninteresting
+ | otherwise = StrictnessInfo xs is_bot
+ where
+ totally_boring (WwLazy False) = True
+ totally_boring other = False
noStrictnessInfo = NoStrictnessInfo
appIsBottom (StrictnessInfo ds bot) n = bot && (n >= length ds)
appIsBottom NoStrictnessInfo n = False
-ppStrictnessInfo NoStrictnessInfo = empty
-ppStrictnessInfo (StrictnessInfo wrapper_args bot)
- = hsep [ptext SLIT("__S"), pprDemands wrapper_args bot]
+ppStrictnessInfo NoStrictnessInfo = empty
+ppStrictnessInfo (StrictnessInfo wrapper_args bot) = hsep [pprDemands wrapper_args bot]
\end{code}
import PrimRep ( PrimRep )
import PrimOp ( PrimOp, primOpIsCheap )
import TysPrim ( statePrimTyCon )
-import FieldLabel ( FieldLabel(..) )
+import FieldLabel ( FieldLabel )
import SrcLoc ( SrcLoc )
import Unique ( Unique, mkBuiltinUnique, getBuiltinUniques )
import Outputable
-- functions in the module being compiled. Their arity
-- might increase later in the compilation process, if
-- an extra lambda floats up to the binding site.
+ deriving( Eq )
seqArity :: ArityInfo -> ()
seqArity a = arityLowerBound a `seq` ()
= NoInlinePragInfo
| IMustNotBeINLINEd Bool -- True <=> came from an INLINE prag, False <=> came from a NOINLINE prag
(Maybe Int) -- Phase number from pragma, if any
+ deriving( Eq )
-- The True, Nothing case doesn't need to be recorded
-- SEE COMMENTS WITH CoreUnfold.blackListed on the
( Literal(..) -- Exported to ParseIface
, mkMachInt, mkMachWord
, mkMachInt64, mkMachWord64
- , isLitLitLit
+ , isLitLitLit, maybeLitLit
, literalType, literalPrimRep
, hashLiteral
import Ratio ( numerator, denominator )
import FastString ( uniqueOfFS )
import Char ( ord, chr )
-
-#if __GLASGOW_HASKELL__ >= 404
-import GlaExts ( fromInt )
-#endif
\end{code}
\begin{code}
isLitLitLit (MachLitLit _ _) = True
isLitLitLit _ = False
+
+maybeLitLit (MachLitLit s t) = Just (s,t)
+maybeLitLit _ = Nothing
\end{code}
Types
intPrimTy, realWorldStatePrimTy
)
import TysWiredIn ( boolTy, charTy, mkListTy )
-import PrelMods ( pREL_ERR, pREL_GHC )
+import PrelNames ( pREL_ERR, pREL_GHC )
import PrelRules ( primOpRule )
import Rules ( addRule )
import Type ( Type, ClassContext, mkDictTy, mkDictTys, mkTyConApp, mkTyVarTys,
import Module ( Module )
import CoreUtils ( exprType, mkInlineMe )
import CoreUnfold ( mkTopUnfolding, mkCompulsoryUnfolding, mkOtherCon )
+import Literal ( Literal(..) )
import Subst ( mkTopTyVarSubst, substClasses )
import TyCon ( TyCon, isNewTyCon, tyConTyVars, tyConDataCons, isDataTyCon,
tyConTheta, isProductTyCon, isUnboxedTupleTyCon )
primOpSig, mkPrimOpIdName,
CCall, pprCCallOp
)
-import Demand ( wwStrict, wwPrim )
+import Demand ( wwStrict, wwPrim, mkStrictnessInfo )
import DataCon ( DataCon, StrictnessMark(..),
dataConFieldLabels, dataConRepArity, dataConTyCon,
dataConArgTys, dataConRepType, dataConRepStrictness,
arity = dataConRepArity data_con
- strict_info = StrictnessInfo (dataConRepStrictness data_con) False
+ strict_info = mkStrictnessInfo (dataConRepStrictness data_con, False)
cpr_info | isProductTyCon tycon &&
not (isUnboxedTupleTyCon tycon) &&
unN = /\a -> \n:N -> coerce (a->a) n
\begin{code}
-mkRecordSelId tycon field_label
- -- Assumes that all fields with the same field label
- -- have the same type
+mkRecordSelId tycon field_label unpack_id
+ -- Assumes that all fields with the same field label have the same type
+ --
+ -- Annoyingly, we have to pass in the unpackCString# Id, because
+ -- we can't conjure it up out of thin air
= sel_id
where
sel_id = mkId (fieldLabelName field_label) selector_ty info
field_lbls = dataConFieldLabels data_con
maybe_the_arg_id = assocMaybe (field_lbls `zip` arg_ids) field_label
- error_expr = mkApps (Var rEC_SEL_ERROR_ID) [Type (unUsgTy field_tau), mkStringLit full_msg]
+ error_expr = mkApps (Var rEC_SEL_ERROR_ID) [Type (unUsgTy field_tau), err_string]
-- preserves invariant that type args are *not* usage-annotated on top. KSW 1999-04.
+ err_string = App (Var unpack_id) (Lit (MachStr (_PK_ full_msg)))
full_msg = showSDoc (sep [text "No match in record selector", ppr sel_id])
\end{code}
ToDo: unify with mkRecordSelId.
\begin{code}
+mkDictSelId :: Name -> Class -> Id
mkDictSelId name clas
= sel_id
where
Representing modules and their flavours.
+
+Notes on DLLs
+~~~~~~~~~~~~~
+When compiling module A, which imports module B, we need to
+know whether B will be in the same DLL as A.
+ If it's in the same DLL, we refer to B_f_closure
+ If it isn't, we refer to _imp__B_f_closure
+When compiling A, we record in B's Module value whether it's
+in a different DLL, by setting the DLL flag.
+
+
+
+
\begin{code}
module Module
(
%************************************************************************
%* *
-\subsection{System/user module}
-%* *
-%************************************************************************
-
-We also track whether an imported module is from a 'system-ish' place. In this case
-we don't record the fact that this module depends on it, nor usages of things
-inside it.
-
-Apr 00: We want to record dependencies on all modules other than
-prelude modules else STG Hugs gets confused because it uses this
-info to know what modules to link. (Compiled GHC uses command line
-options to specify this.)
-
-\begin{code}
-data ModFlavour = PrelMod -- A Prelude module
- | UserMod -- Not library-ish
-\end{code}
-
-
-%************************************************************************
-%* *
\subsection{Where from}
%* *
%************************************************************************
pack_info | pack_name == opt_InPackage = ThisPackage
| otherwise = AnotherPackage pack_name
+
mkVanillaModule :: ModuleName -> Module
mkVanillaModule name = Module name ThisPackage
-- Used temporarily when we first come across Foo.x in an interface
nameUnique, setNameUnique, setNameProvenance, getNameProvenance, setNameImportReason,
tidyTopName,
- nameOccName, nameModule, setNameOcc, nameRdrName, setNameModule,
+ nameOccName, nameModule, setNameOcc, nameRdrName, setNameModule, toRdrName,
isUserExportedName, isUserImportedName, isUserImportedExplicitlyName,
maybeUserImportedFrom,
isSystemName, isLocalName, isGlobalName, isExternallyVisibleName,
+ -- Environment
+ NameEnv,
+ emptyNameEnv, unitNameEnv, nameEnvElts,
+ addToNameEnv_C, addToNameEnv, addListToNameEnv,
+ plusNameEnv, plusNameEnv_C, extendNameEnv,
+ lookupNameEnv, delFromNameEnv, elemNameEnv,
+
-- Provenance
Provenance(..), ImportReason(..), pprProvenance,
import CmdLineOpts ( opt_Static, opt_PprStyle_NoPrags, opt_OmitInterfacePragmas, opt_EnsureSplittableC )
import SrcLoc ( noSrcLoc, mkBuiltinSrcLoc, SrcLoc )
-import Unique ( pprUnique, Unique, Uniquable(..), unboundKey, u2i )
+import Unique ( pprUnique, Unique, Uniquable(..), hasKey, unboundKey, u2i )
+import UniqFM
import Outputable
import GlaExts
\end{code}
mkUnboundName rdr_name = mkLocalName unboundKey (rdrNameOcc rdr_name) noSrcLoc
isUnboundName :: Name -> Bool
-isUnboundName name = getUnique name == unboundKey
+isUnboundName name = name `hasKey` unboundKey
\end{code}
\begin{code}
nameSortModule (WiredInTyCon mod _) = mod
nameRdrName :: Name -> RdrName
+-- Makes a qualified name for top-level (Global) names, whether locally defined or not
+-- and an unqualified name just for Locals
nameRdrName (Name { n_sort = Local, n_occ = occ }) = mkRdrUnqual occ
nameRdrName (Name { n_sort = sort, n_occ = occ }) = mkRdrQual (moduleName (nameSortModule sort)) occ
isExternallyVisibleName name = isGlobalName name
hasBetterProv :: Name -> Name -> Bool
-hasBetterProv name1 name2
- = case n_prov name1 of
- LocalDef _ _ -> True
- SystemProv -> False
- NonLocalDef _ _ -> case n_prov name2 of
- LocalDef _ _ -> False
- other -> True
+-- Choose
+-- a local thing over an imported thing
+-- a user-imported thing over a non-user-imported thing
+-- an explicitly-imported thing over an implicitly imported thing
+hasBetterProv n1 n2
+ = case (n_prov n1, n_prov n2) of
+ (LocalDef _ _, _ ) -> True
+ (NonLocalDef (UserImport _ _ True) _, _ ) -> True
+ (NonLocalDef (UserImport _ _ _ ) _, NonLocalDef ImplicitImport _) -> True
+ other -> False
isSystemName (Name {n_prov = SystemProv}) = True
isSystemName other = False
%************************************************************************
%* *
+\subsection{Name environment}
+%* *
+%************************************************************************
+
+\begin{code}
+type NameEnv a = UniqFM a -- Domain is Name
+
+emptyNameEnv :: NameEnv a
+nameEnvElts :: NameEnv a -> [a]
+addToNameEnv_C :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a
+addToNameEnv :: NameEnv a -> Name -> a -> NameEnv a
+addListToNameEnv :: NameEnv a -> [(Name,a)] -> NameEnv a
+plusNameEnv :: NameEnv a -> NameEnv a -> NameEnv a
+plusNameEnv_C :: (a->a->a) -> NameEnv a -> NameEnv a -> NameEnv a
+extendNameEnv :: NameEnv a -> [(Name,a)] -> NameEnv a
+lookupNameEnv :: NameEnv a -> Name -> Maybe a
+delFromNameEnv :: NameEnv a -> Name -> NameEnv a
+elemNameEnv :: Name -> NameEnv a -> Bool
+unitNameEnv :: Name -> a -> NameEnv a
+
+emptyNameEnv = emptyUFM
+nameEnvElts = eltsUFM
+addToNameEnv_C = addToUFM_C
+addToNameEnv = addToUFM
+addListToNameEnv = addListToUFM
+plusNameEnv = plusUFM
+plusNameEnv_C = plusUFM_C
+extendNameEnv = addListToUFM
+lookupNameEnv = lookupUFM
+delFromNameEnv = delFromUFM
+elemNameEnv = elemUFM
+unitNameEnv = unitUFM
+\end{code}
+
+
+%************************************************************************
+%* *
\subsection{Pretty printing}
%* *
%************************************************************************
pprEncodedFS fs
= getPprStyle $ \ sty ->
if userStyle sty then
- text (decode (_UNPK_ fs))
+ let
+ s = decode (_UNPK_ fs)
+ c = head s
+ in
+ if startsVarSym c || startsConSym c then
+ parens (text s)
+ else
+ text s
else
ptext fs
\end{code}
isLexConId cs -- Prefix type or data constructors
| _NULL_ cs = False -- e.g. "Foo", "[]", "(,)"
| cs == SLIT("[]") = True
- | c == '(' = True -- (), (,), (,,), ...
- | otherwise = isUpper c || isUpperISO c
- where
- c = _HEAD_ cs
+ | otherwise = startsConId (_HEAD_ cs)
isLexVarId cs -- Ordinary prefix identifiers
| _NULL_ cs = False -- e.g. "x", "_x"
- | otherwise = isLower c || isLowerISO c || c == '_'
- where
- c = _HEAD_ cs
+ | otherwise = startsVarId (_HEAD_ cs)
isLexConSym cs -- Infix type or data constructors
| _NULL_ cs = False -- e.g. ":-:", ":", "->"
- | otherwise = c == ':'
- || cs == SLIT("->")
- where
- c = _HEAD_ cs
+ | cs == SLIT("->") = True
+ | otherwise = startsConSym (_HEAD_ cs)
isLexVarSym cs -- Infix identifiers
| _NULL_ cs = False -- e.g. "+"
- | otherwise = isSymbolASCII c
- || isSymbolISO c
- where
- c = _HEAD_ cs
+ | otherwise = startsVarSym (_HEAD_ cs)
-------------
+startsVarSym, startsVarId, startsConSym, startsConId :: Char -> Bool
+startsVarSym c = isSymbolASCII c || isSymbolISO c -- Infix Ids
+startsConSym c = c == ':' -- Infix data constructors
+startsVarId c = isLower c || isLowerISO c || c == '_' -- Ordinary Ids
+startsConId c = isUpper c || isUpperISO c || c == '(' -- Ordinary type constructors and data constructors
+
+
isSymbolASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-"
isSymbolISO c = ord c `elem` (0xd7 : 0xf7 : [0xa1 .. 0xbf])
isUpperISO (C# c#) = c# `geChar#` '\xc0'# && c# `leChar#` '\xde'# && c# `neChar#` '\xd7'#
-- Destruction
rdrNameModule, rdrNameOcc, setRdrNameOcc,
- isRdrDataCon, isRdrTyVar, isQual, isUnqual
+ isRdrDataCon, isRdrTyVar, isQual, isUnqual,
+
+ -- Environment
+ RdrNameEnv,
+ emptyRdrEnv, lookupRdrEnv, addListToRdrEnv, rdrEnvElts,
+ extendRdrEnv, rdrEnvToList,
+
+ -- Printing; instance Outputable RdrName
+ pprUnqualRdrName
) where
#include "HsVersions.h"
import Module ( ModuleName, pprModuleName,
mkSysModuleFS, mkSrcModuleFS
)
+import FiniteMap
import Outputable
import Util ( thenCmp )
\end{code}
instance Outputable RdrName where
ppr (RdrName qual occ) = pp_qual qual <> ppr occ
where
- pp_qual Unqual = empty
- pp_qual (Qual mod) = pprModuleName mod <> dot
+ pp_qual Unqual = empty
+ pp_qual (Qual mod) = pprModuleName mod <> dot
+
+pprUnqualRdrName (RdrName qual occ) = ppr occ
instance Eq RdrName where
a == b = case (a `compare` b) of { EQ -> True; _ -> False }
+%************************************************************************
+%* *
+\subsection{Environment}
+%* *
+%************************************************************************
+
+\begin{code}
+type RdrNameEnv a = FiniteMap RdrName a
+
+emptyRdrEnv :: RdrNameEnv a
+lookupRdrEnv :: RdrNameEnv a -> RdrName -> Maybe a
+addListToRdrEnv :: RdrNameEnv a -> [(RdrName,a)] -> RdrNameEnv a
+extendRdrEnv :: RdrNameEnv a -> RdrName -> a -> RdrNameEnv a
+rdrEnvToList :: RdrNameEnv a -> [(RdrName, a)]
+rdrEnvElts :: RdrNameEnv a -> [a]
+
+emptyRdrEnv = emptyFM
+lookupRdrEnv = lookupFM
+addListToRdrEnv = addListToFM
+rdrEnvElts = eltsFM
+extendRdrEnv = addToFM
+rdrEnvToList = fmToList
+\end{code}
\begin{code}
module Unique (
- Unique, Uniquable(..),
+ Unique, Uniquable(..), hasKey,
u2i, -- hack: used in UniqFM
pprUnique, pprUnique10,
initTyVarUnique,
initTidyUniques,
- isTupleKey,
+ isTupleKey,
-- now all the built-in Uniques (and functions to make them)
-- [the Oh-So-Wonderful Haskell module system wins again...]
mkAlphaTyVarUnique,
mkPrimOpIdUnique,
mkTupleDataConUnique,
- mkUbxTupleDataConUnique,
mkTupleTyConUnique,
- mkUbxTupleTyConUnique,
getBuiltinUniques, mkBuiltinUnique,
mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3,
#include "HsVersions.h"
+import BasicTypes ( Boxity(..) )
import FastString ( FastString, uniqueOfFS )
import GlaExts
import ST
class Uniquable a where
getUnique :: a -> Unique
+hasKey :: Uniquable a => a -> Unique -> Bool
+x `hasKey` k = getUnique x == k
+
instance Uniquable FastString where
getUnique fs = mkUniqueGrimily (uniqueOfFS fs)
mkPreludeClassUnique i = mkUnique '2' i
mkPreludeTyConUnique i = mkUnique '3' i
-mkTupleTyConUnique a = mkUnique '4' a
-mkUbxTupleTyConUnique a = mkUnique '5' a
+mkTupleTyConUnique Boxed a = mkUnique '4' a
+mkTupleTyConUnique Unboxed a = mkUnique '5' a
-- Data constructor keys occupy *two* slots. The first is used for the
-- data constructor itself and its wrapper function (the function that
-- representation).
mkPreludeDataConUnique i = mkUnique '6' (2*i) -- Must be alphabetic
-mkTupleDataConUnique a = mkUnique '7' (2*a) -- ditto (*may* be used in C labels)
-mkUbxTupleDataConUnique a = mkUnique '8' (2*a)
+mkTupleDataConUnique Boxed a = mkUnique '7' (2*a) -- ditto (*may* be used in C labels)
+mkTupleDataConUnique Unboxed a = mkUnique '8' (2*a)
-- This one is used for a tiresome reason
-- to improve a consistency-checking error check in the renamer
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgCase.lhs,v 1.41 2000/04/13 20:41:30 panne Exp $
+% $Id: CgCase.lhs,v 1.42 2000/05/25 12:41:15 simonpj Exp $
%
%********************************************************
%* *
)
import TyCon ( TyCon, isEnumerationTyCon, isUnboxedTupleTyCon,
isNewTyCon, isAlgTyCon, isFunTyCon, isPrimTyCon,
- tyConDataCons, tyConFamilySize )
+ )
import Type ( Type, typePrimRep, splitAlgTyConApp,
splitTyConApp_maybe, repType )
import PprType ( {- instance Outputable Type -} )
%
% (c) The GRASP Project, Glasgow University, 1992-1998
%
-% $Id: CgRetConv.lhs,v 1.21 2000/04/05 16:25:51 simonpj Exp $
+% $Id: CgRetConv.lhs,v 1.22 2000/05/25 12:41:15 simonpj Exp $
%
\section[CgRetConv]{Return conventions for the code generator}
import DataCon ( DataCon )
import PrimOp ( PrimOp{-instance Outputable-} )
import PrimRep ( isFloatingRep, PrimRep(..), is64BitRep )
-import TyCon ( TyCon, tyConDataCons, tyConFamilySize )
+import TyCon ( TyCon, tyConFamilySize )
import Type ( Type, typePrimRep, isUnLiftedType )
import Util ( isn'tIn )
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: ClosureInfo.lhs,v 1.41 2000/04/05 15:17:38 simonmar Exp $
+% $Id: ClosureInfo.lhs,v 1.42 2000/05/25 12:41:15 simonpj Exp $
%
\section[ClosureInfo]{Data structures which describe closures}
opt_SMP )
import Id ( Id, idType, idArityInfo )
import DataCon ( DataCon, dataConTag, fIRST_TAG, dataConTyCon,
- isNullaryDataCon, isTupleCon, dataConName
+ isNullaryDataCon, dataConName
)
+import TyCon ( isBoxedTupleTyCon )
import IdInfo ( ArityInfo(..) )
import Name ( Name, isExternallyVisibleName, nameUnique,
getOccName )
mkConLFInfo con
= -- the isNullaryDataCon will do this: ASSERT(isDataCon con)
- (if isTupleCon con then LFTuple else LFCon) con (isNullaryDataCon con)
+ (if isBoxedTupleTyCon (dataConTyCon con) then LFTuple else LFCon)
+ con (isNullaryDataCon con)
mkSelectorLFInfo rhs_ty offset updatable
= LFThunk rhs_ty NotTopLevel False updatable (SelectorThunk offset)
module CoreFVs (
exprFreeVars, exprsFreeVars,
exprSomeFreeVars, exprsSomeFreeVars,
- idRuleVars, idFreeVars, ruleSomeFreeVars, ruleSomeLhsFreeVars,
+ idRuleVars, idFreeVars,
+ ruleSomeFreeVars, ruleSomeLhsFreeVars, ruleRhsFreeVars,
+
+ mustHaveLocalBinding,
CoreExprWithFVs, CoreBindWithFVs, freeVars, freeVarsOf,
) where
#include "HsVersions.h"
import CoreSyn
-import Id ( Id, idFreeTyVars, idSpecialisation )
+import Id ( Id, idFreeTyVars, mayHaveNoBinding, idSpecialisation )
import VarSet
import Var ( Var, isId )
import Name ( isLocallyDefined )
import Type ( tyVarsOfType, Type )
import Util ( mapAndUnzip )
+import Outputable
+\end{code}
+
+%************************************************************************
+%* *
+\section{Utilities}
+%* *
+%************************************************************************
+
+\begin{code}
+mustHaveLocalBinding :: Var -> Bool
+-- True <=> the variable must have a binding in this module
+mustHaveLocalBinding v
+ | isId v = isLocallyDefined v && not (mayHaveNoBinding v)
+ | otherwise = True -- TyVars etc must
\end{code}
+
%************************************************************************
%* *
\section{Finding the free variables of an expression}
-- is a little weird. The reason is that the former is more efficient,
-- but the latter is more fine grained, and a makes a difference when
-- a variable mentions itself one of its own rule RHSs
-oneVar :: Var -> FV
+oneVar :: Id -> FV
oneVar var fv_cand in_scope
- = foldVarSet add_rule_var var_itself_set (idRuleVars var)
+ = ASSERT( isId var )
+ foldVarSet add_rule_var var_itself_set (idRuleVars var)
where
var_itself_set | keep_it fv_cand in_scope var = unitVarSet var
| otherwise = emptyVarSet
\begin{code}
idRuleVars ::Id -> VarSet
-idRuleVars id = rulesRhsFreeVars (idSpecialisation id)
+idRuleVars id = ASSERT( isId id) rulesRhsFreeVars (idSpecialisation id)
idFreeVars :: Id -> VarSet
-idFreeVars id = idRuleVars id `unionVarSet` idFreeTyVars id
+idFreeVars id = ASSERT( isId id) idRuleVars id `unionVarSet` idFreeTyVars id
rulesSomeFreeVars :: InterestingVarFun -> CoreRules -> VarSet
rulesSomeFreeVars interesting (Rules rules _)
= foldr (unionVarSet . ruleSomeFreeVars interesting) emptyVarSet rules
+ruleRhsFreeVars :: CoreRule -> VarSet
+ruleRhsFreeVars (BuiltinRule _) = noFVs
+ruleRhsFreeVars (Rule str tpl_vars tpl_args rhs)
+ = rule_fvs isLocallyDefined emptyVarSet
+ where
+ rule_fvs = addBndrs tpl_vars (expr_fvs rhs)
+
ruleSomeFreeVars :: InterestingVarFun -> CoreRule -> VarSet
ruleSomeFreeVars interesting (BuiltinRule _) = noFVs
ruleSomeFreeVars interesting (Rule _ tpl_vars tpl_args rhs)
import CmdLineOpts ( opt_D_show_passes, opt_DoCoreLinting, opt_PprStyle_Debug )
import CoreSyn
-import CoreFVs ( idFreeVars )
+import CoreFVs ( idFreeVars, mustHaveLocalBinding )
import CoreUtils ( exprOkForSpeculation, coreBindsSize )
import Bag
import Literal ( Literal, literalType )
import DataCon ( DataCon, dataConRepType )
-import Id ( mayHaveNoBinding, isDeadBinder )
+import Id ( isDeadBinder )
import Var ( Var, Id, TyVar, idType, tyVarKind, isTyVar, isId )
import VarSet
import Subst ( mkTyVarSubst, substTy )
checkInScope :: SDoc -> Var -> LintM ()
checkInScope loc_msg var loc scope errs
- | isLocallyDefined var
- && not (var `elemVarSet` scope)
- && not (isId var && mayHaveNoBinding var)
- -- Micro-hack here... Class decls generate applications of their
- -- dictionary constructor, but don't generate a binding for the
- -- constructor (since it would never be used). After a single round
- -- of simplification, these dictionary constructors have been
- -- inlined (from their UnfoldInfo) to CoCons. Just between
- -- desugaring and simplfication, though, they appear as naked, unbound
- -- variables as the function in an application.
- -- The hack here simply doesn't check for out-of-scope-ness for
- -- data constructors (at least, in a function position).
- -- Ditto primitive Ids
+ | mustHaveLocalBinding var && not (var `elemVarSet` scope)
= (Nothing, addErr errs (hsep [ppr var, loc_msg]) loc)
| otherwise
= (Nothing,errs)
mkLets, mkLams,
mkApps, mkTyApps, mkValApps, mkVarApps,
mkLit, mkIntLitInt, mkIntLit,
- mkStringLit, mkStringLitFS, mkConApp,
+ mkConApp,
varToCoreExpr,
bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, isTyVar, isId,
CoreRules(..), -- Representation needed by friends
CoreRule(..), -- CoreSubst, CoreTidy, CoreFVs, PprCore only
RuleName,
- emptyCoreRules, isEmptyCoreRules, rulesRhsFreeVars, rulesRules
+ emptyCoreRules, isEmptyCoreRules, rulesRhsFreeVars, rulesRules,
+ isBuiltinRule
) where
#include "HsVersions.h"
import Literal ( Literal(MachStr), mkMachInt )
import PrimOp ( PrimOp )
import DataCon ( DataCon, dataConId )
-import ThinAir ( unpackCStringId, unpackCString2Id )
import VarSet
import Outputable
\end{code}
= Rules [CoreRule]
VarSet -- Locally-defined free vars of RHSs
+emptyCoreRules :: CoreRules
+emptyCoreRules = Rules [] emptyVarSet
+
+isEmptyCoreRules :: CoreRules -> Bool
+isEmptyCoreRules (Rules rs _) = null rs
+
+rulesRhsFreeVars :: CoreRules -> VarSet
+rulesRhsFreeVars (Rules _ fvs) = fvs
+
+rulesRules :: CoreRules -> [CoreRule]
+rulesRules (Rules rules _) = rules
+\end{code}
+
+\begin{code}
type RuleName = FAST_STRING
data CoreRule
-- and suchlike. It has no free variables.
([CoreExpr] -> Maybe (RuleName, CoreExpr))
-emptyCoreRules :: CoreRules
-emptyCoreRules = Rules [] emptyVarSet
-
-isEmptyCoreRules :: CoreRules -> Bool
-isEmptyCoreRules (Rules rs _) = null rs
-
-rulesRhsFreeVars :: CoreRules -> VarSet
-rulesRhsFreeVars (Rules _ fvs) = fvs
-
-rulesRules :: CoreRules -> [CoreRule]
-rulesRules (Rules rules _) = rules
+isBuiltinRule (BuiltinRule _) = True
+isBuiltinRule _ = False
\end{code}
mkLit :: Literal -> Expr b
mkIntLit :: Integer -> Expr b
mkIntLitInt :: Int -> Expr b
-mkStringLit :: String -> Expr b -- Makes a [Char] literal
-mkStringLitFS :: FAST_STRING -> Expr b -- Makes a [Char] literal
mkConApp :: DataCon -> [Arg b] -> Expr b
mkLets :: [Bind b] -> Expr b -> Expr b
mkLams :: [b] -> Expr b -> Expr b
mkIntLit n = Lit (mkMachInt n)
mkIntLitInt n = Lit (mkMachInt (toInteger n))
-mkStringLit str = mkStringLitFS (_PK_ str)
-
-mkStringLitFS str
- | any is_NUL (_UNPK_ str)
- = -- Must cater for NULs in literal string
- mkApps (Var unpackCString2Id)
- [Lit (MachStr str),
- mkIntLitInt (_LENGTH_ str)]
-
- | otherwise
- = -- No NULs in the string
- App (Var unpackCStringId) (Lit (MachStr str))
-
- where
- is_NUL c = c == '\0'
-
varToCoreExpr :: CoreBndr -> Expr b
varToCoreExpr v | isId v = Var v
| otherwise = Type (mkTyVarTy v)
import OccurAnal ( occurAnalyseGlobalExpr )
import BinderInfo ( )
import CoreUtils ( exprIsValue, exprIsCheap, exprIsBottom, exprIsTrivial )
-import Id ( Id, idType, idFlavour, idUnique, isId, idWorkerInfo,
+import Id ( Id, idType, idFlavour, isId, idWorkerInfo,
idSpecialisation, idInlinePragma, idUnfolding,
isPrimOpId_maybe
)
import IdInfo ( ArityInfo(..), InlinePragInfo(..), OccInfo(..), IdFlavour(..), CprInfo(..),
insideLam, workerExists, isNeverInlinePrag
)
-import TyCon ( tyConFamilySize )
import Type ( splitFunTy_maybe, isUnLiftedType )
-import Unique ( Unique, buildIdKey, augmentIdKey )
+import Unique ( Unique, buildIdKey, augmentIdKey, hasKey )
import Maybes ( maybeToBool )
import Bag
import List ( maximumBy )
-- Also if the function is a constant Id (constr or primop)
-- compute discounts specially
size_up_fun (Var fun) args
- | idUnique fun == buildIdKey = buildSize
- | idUnique fun == augmentIdKey = augmentSize
+ | fun `hasKey` buildIdKey = buildSize
+ | fun `hasKey` augmentIdKey = augmentSize
| otherwise
= case idFlavour fun of
DataConId dc -> conSizeN (valArgCount args)
\begin{code}
module CoreUtils (
- exprType, coreAltsType,
-
-- Construction
mkNote, mkInlineMe, mkSCC, mkCoerce,
bindNonRec, mkIfThenElse, mkAltExpr,
+ -- Properties of expressions
+ exprType, coreAltsType, exprArity,
exprIsBottom, exprIsDupable, exprIsTrivial, exprIsCheap,
exprIsValue,exprOkForSpeculation, exprIsBig,
- exprArity, exprIsConApp_maybe,
-
+ exprIsConApp_maybe,
idAppIsBottom, idAppIsCheap,
+ -- Expr transformation
etaReduceExpr, exprEtaExpandArity,
-- Size
applications. Note that primop Ids aren't considered
trivial unless
-
@exprIsBottom@ is true of expressions that are guaranteed to diverge
\begin{code}
module PprCore (
- pprCoreExpr, pprParendExpr, pprIfaceUnfolding,
+ pprCoreExpr, pprParendExpr,
+ pprCoreBinding, pprCoreBindings, pprIdBndr,
pprCoreBinding, pprCoreBindings,
pprCoreRules, pprCoreRule
) where
cprInfo, ppCprInfo, lbvarInfo,
workerInfo, ppWorkerInfo
)
-import DataCon ( isTupleCon, isUnboxedTupleCon )
+import DataCon ( dataConTyCon )
+import TyCon ( tupleTyConBoxity, isTupleTyCon )
import PprType ( pprParendType, pprTyVarBndr )
+import BasicTypes ( tupleParens )
import PprEnv
import Outputable
\end{code}
pprCoreBinding = pprTopBind pprCoreEnv
pprCoreExpr = ppr_noparend_expr pprCoreEnv
pprParendExpr = ppr_parend_expr pprCoreEnv
+pprArg = ppr_arg pprCoreEnv
pprCoreEnv = initCoreEnv pprCoreBinder
\end{code}
Printer for unfoldings in interfaces
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
-pprIfaceUnfolding :: CoreExpr -> SDoc
-pprIfaceUnfolding = ppr_parend_expr pprIfaceEnv
- -- Notice that it's parenthesised
-
-pprIfaceArg = ppr_arg pprIfaceEnv
-
-pprIfaceEnv = initCoreEnv pprIfaceBinder
-\end{code}
-
-\begin{code}
instance Outputable b => Outputable (Bind b) where
ppr bind = ppr_bind pprGenericEnv bind
Var f -> case isDataConId_maybe f of
-- Notice that we print the *worker*
-- for tuples in paren'd format.
- Just dc | saturated && isTupleCon dc -> parens pp_tup_args
- | saturated && isUnboxedTupleCon dc -> text "(#" <+> pp_tup_args <+> text "#)"
- other -> add_par (hang (pOcc pe f) 4 pp_args)
- where
- saturated = length val_args == idArity f
+ Just dc | saturated && isTupleTyCon tc
+ -> tupleParens (tupleTyConBoxity tc) pp_tup_args
+ where
+ tc = dataConTyCon dc
+ saturated = length val_args == idArity f
+
+ other -> add_par (hang (pOcc pe f) 4 pp_args)
other -> add_par (hang (ppr_parend_expr pe fun) 4 pp_args)
}
add_par (ppr u <+> ppr_noparend_expr pe expr)
ppr_case_pat pe con@(DataAlt dc) args
- | isTupleCon dc
- = parens (hsep (punctuate comma (map ppr_bndr args))) <+> arrow
- | isUnboxedTupleCon dc
- = hsep [text "(# " <>
- hsep (punctuate comma (map ppr_bndr args)) <>
- text " #)",
- arrow]
+ | isTupleTyCon tc
+ = tupleParens (tupleTyConBoxity tc) (hsep (punctuate comma (map ppr_bndr args))) <+> arrow
where
ppr_bndr = pBndr pe CaseBind
+ tc = dataConTyCon dc
ppr_case_pat pe con args
= ppr con <+> hsep (map ppr_bndr args) <+> arrow
= vcat [sig, pragmas, ppr binder]
where
sig = pprTypedBinder binder
- pragmas = ppIdInfo (idInfo binder)
+ pragmas = ppIdInfo binder (idInfo binder)
-- Lambda bound type variables are preceded by "@"
pprCoreBinder LambdaBind bndr = pprTypedBinder bndr
-- Case bound things don't get a signature or a herald
pprCoreBinder CaseBind bndr = pprUntypedBinder bndr
--- Used for printing interface-file unfoldings
-pprIfaceBinder CaseBind binder = pprUntypedBinder binder
-pprIfaceBinder other binder = pprTypedBinder binder
-
pprUntypedBinder binder
| isTyVar binder = ptext SLIT("@") <+> pprTyVarBndr binder
| otherwise = pprIdBndr binder
\begin{code}
-ppIdInfo :: IdInfo -> SDoc
-ppIdInfo info
+ppIdInfo :: Id -> IdInfo -> SDoc
+ppIdInfo b info
= hsep [
ppFlavourInfo (flavourInfo info),
ppArityInfo a,
ppStrictnessInfo s,
ppCafInfo c,
ppCprInfo m,
- pprIfaceCoreRules p
+ pprCoreRules b p
-- Inline pragma, occ, demand, lbvar info
-- printed out with all binders (when debug is on);
-- see PprCore.pprIdBndr
\begin{code}
pprCoreRules :: Id -> CoreRules -> SDoc
-pprCoreRules var (Rules rules _) = vcat (map (pprCoreRule (Just var)) rules)
+pprCoreRules var (Rules rules _) = vcat (map (pprCoreRule (ppr var)) rules)
-pprIfaceCoreRules :: CoreRules -> SDoc
-pprIfaceCoreRules (Rules rules _) = vcat (map (pprCoreRule Nothing) rules)
-
-pprCoreRule :: Maybe Id -> CoreRule -> SDoc
-pprCoreRule maybe_fn (BuiltinRule _)
+pprCoreRule :: SDoc -> CoreRule -> SDoc
+pprCoreRule pp_fn (BuiltinRule _)
= ifPprDebug (ptext SLIT("A built in rule"))
-pprCoreRule maybe_fn (Rule name tpl_vars tpl_args rhs)
+pprCoreRule pp_fn (Rule name tpl_vars tpl_args rhs)
= doubleQuotes (ptext name) <+>
sep [
ptext SLIT("__forall") <+> braces (sep (map pprTypedBinder tpl_vars)),
- nest 4 (pp_fn <+> sep (map pprIfaceArg tpl_args)),
- nest 4 (ptext SLIT("=") <+> pprIfaceUnfolding rhs)
+ nest 4 (pp_fn <+> sep (map pprArg tpl_args)),
+ nest 4 (ptext SLIT("=") <+> pprCoreExpr rhs)
] <+> semi
- where
- pp_fn = case maybe_fn of
- Just id -> ppr id
- Nothing -> empty -- Interface file
\end{code}
CoreRules(..), CoreRule(..),
emptyCoreRules, isEmptyCoreRules, seqRules
)
-import CoreFVs ( exprFreeVars )
+import CoreFVs ( exprFreeVars, mustHaveLocalBinding )
import TypeRep ( Type(..), TyNote(..),
) -- friend
import Type ( ThetaType, PredType(..), ClassContext,
import VarEnv
import Var ( setVarUnique, isId )
import Id ( idType, setIdType, idOccInfo, zapFragileIdInfo )
-import Name ( isLocallyDefined )
import IdInfo ( IdInfo, isFragileOccInfo,
specInfo, setSpecInfo,
WorkerInfo(..), workerExists, workerInfo, setWorkerInfo, WorkerInfo
= case lookupVarEnv in_scope v of
Just v' | v == v' -> v' -- Reached a fixed point
| otherwise -> lookupInScope in_scope v'
- Nothing -> v
+ Nothing -> WARN( mustHaveLocalBinding v, ppr v )
+ v
isInScope :: Var -> Subst -> Bool
isInScope v (Subst in_scope _) = v `elemVarEnv` in_scope
tidyLitPat
)
import Id ( idType )
-import DataCon ( DataCon, isTupleCon, isUnboxedTupleCon, dataConArgTys,
+import DataCon ( DataCon, dataConTyCon, dataConArgTys,
dataConSourceArity, dataConFieldLabels )
import Name ( Name, mkLocalName, getOccName, isDataSymOcc, getName, mkSrcVarOcc )
import Type ( Type, splitAlgTyConApp, mkTyVarTys,
- isUnboxedType, splitTyConApp_maybe
+ splitTyConApp_maybe
)
import TysWiredIn ( nilDataCon, consDataCon,
- mkListTy,
- mkTupleTy, tupleCon,
- mkUnboxedTupleTy, unboxedTupleCon
+ mkListTy, mkTupleTy, tupleCon
)
import Unique ( unboundKey )
-import TyCon ( tyConDataCons )
+import TyCon ( tyConDataCons, tupleTyConBoxity, isTupleTyCon )
+import BasicTypes ( Boxity(..) )
import SrcLoc ( noSrcLoc )
import UniqSet
import Outputable
fixity = panic "Check.make_con: Guessing fixity"
make_con (ConPat id _ _ _ pats) (ps,constraints)
- | isTupleCon id = (TuplePatIn pats_con True : rest_pats, constraints)
- | isUnboxedTupleCon id = (TuplePatIn pats_con False : rest_pats, constraints)
- | otherwise = (ConPatIn name pats_con : rest_pats, constraints)
+ | isTupleTyCon tc = (TuplePatIn pats_con (tupleTyConBoxity tc) : rest_pats, constraints)
+ | otherwise = (ConPatIn name pats_con : rest_pats, constraints)
where num_args = length pats
name = getName id
pats_con = take num_args ps
rest_pats = drop num_args ps
+ tc = dataConTyCon id
make_whole_con :: DataCon -> WarningPat
where list_ty = mkListTy ty
-simplify_pat (TuplePat ps True) = ConPat (tupleCon arity)
- (mkTupleTy arity (map outPatType ps)) [] []
- (map simplify_pat ps)
- where
- arity = length ps
-
-simplify_pat (TuplePat ps False)
- = ConPat (unboxedTupleCon arity)
- (mkUnboxedTupleTy arity (map outPatType ps)) [] []
+simplify_pat (TuplePat ps boxity)
+ = ConPat (tupleCon boxity arity)
+ (mkTupleTy boxity arity (map outPatType ps)) [] []
(map simplify_pat ps)
where
arity = length ps
simplify_pat (DictPat dicts methods) =
case num_of_d_and_ms of
- 0 -> simplify_pat (TuplePat [] True)
+ 0 -> simplify_pat (TuplePat [] Boxed)
1 -> simplify_pat (head dict_and_method_pats)
- _ -> simplify_pat (TuplePat dict_and_method_pats True)
+ _ -> simplify_pat (TuplePat dict_and_method_pats Boxed)
where
num_of_d_and_ms = length dicts + length methods
dict_and_method_pats = map VarPat (dicts ++ methods)
import CmdLineOpts ( opt_D_dump_ds )
import HsSyn ( MonoBinds, RuleDecl(..), RuleBndr(..), HsExpr(..), HsBinds(..), MonoBinds(..) )
-import HsCore ( UfRuleBody(..) )
import TcHsSyn ( TypecheckedMonoBinds, TypecheckedForeignDecl, TypecheckedRuleDecl )
import TcModule ( TcResults(..) )
import CoreSyn
dsProgram mod_name all_binds rules fo_decls
= dsMonoBinds auto_scc all_binds [] `thenDs` \ core_prs ->
dsForeigns mod_name fo_decls `thenDs` \ (fi_binds, fe_binds, h_code, c_code) ->
- mapDs dsRule rules `thenDs` \ rules' ->
- let
- ds_binds = fi_binds ++ [Rec core_prs] ++ fe_binds
- fe_binders = bindersOfBinds fe_binds
+ let
+ ds_binds = fi_binds ++ [Rec core_prs] ++ fe_binds
+ fe_binders = bindersOfBinds fe_binds
+ local_binders = mkVarSet (bindersOfBinds ds_binds)
in
+ mapDs (dsRule local_binders) rules `thenDs` \ rules' ->
returnDs (ds_binds, rules', h_code, c_code, fe_binders)
where
auto_scc | opt_SccProfilingOn = TopLevel
%************************************************************************
\begin{code}
-dsRule :: TypecheckedRuleDecl -> DsM ProtoCoreRule
-dsRule (IfaceRuleDecl fn (CoreRuleBody name all_vars args rhs) loc)
- = returnDs (ProtoCoreRule False {- non-local -} fn
- (Rule name all_vars args rhs))
+dsRule :: IdSet -> TypecheckedRuleDecl -> DsM ProtoCoreRule
+dsRule in_scope (IfaceRuleOut fn rule)
+ = returnDs (ProtoCoreRule False {- non-local -} fn rule)
-dsRule (RuleDecl name sig_tvs vars lhs rhs loc)
+dsRule in_scope (HsRule name sig_tvs vars lhs rhs loc)
= putSrcLocDs loc $
ds_lhs all_vars lhs `thenDs` \ (fn, args) ->
dsExpr rhs `thenDs` \ core_rhs ->
returnDs (ProtoCoreRule True {- local -} fn
- (Rule name all_vars args core_rhs))
+ (Rule name tpl_vars args core_rhs))
where
- all_vars = sig_tvs ++ [var | RuleBndr var <- vars]
+ tpl_vars = sig_tvs ++ [var | RuleBndr var <- vars]
+ all_vars = in_scope `unionVarSet` mkVarSet tpl_vars
ds_lhs all_vars lhs
= let
-- Note recursion here... substitution won't terminate
-- if there is genuine recursion... which there isn't
- subst = mkSubst (mkVarSet all_vars) subst_env
+ subst = mkSubst all_vars subst_env
body'' = substExpr subst body'
in
import CallConv
import Type ( isUnLiftedType, splitAlgTyConApp_maybe, mkFunTys,
splitTyConApp_maybe, tyVarsOfType, mkForAllTys,
- isNewType, repType, isUnLiftedType, mkFunTy,
+ isNewType, repType, isUnLiftedType, mkFunTy, mkTyConApp,
Type
)
import PprType ( {- instance Outputable Type -} )
byteArrayPrimTyCon, mutableByteArrayPrimTyCon, intPrimTy
)
import TysWiredIn ( unitDataConId, stringTy,
- unboxedPairDataCon,
- mkUnboxedTupleTy, unboxedTupleCon,
+ unboxedSingletonDataCon, unboxedPairDataCon,
+ unboxedSingletonTyCon, unboxedPairTyCon,
+ mkTupleTy, tupleCon,
boolTy, trueDataCon, falseDataCon, trueDataConId, falseDataConId,
unitTy
)
import Literal ( mkMachInt )
import CStrings ( CLabelString )
-import Unique ( Unique, Uniquable(..), ioTyConKey )
+import Unique ( Unique, Uniquable(..), hasKey, ioTyConKey )
import VarSet ( varSetElems )
import Outputable
\end{code}
= case splitAlgTyConApp_maybe result_ty of
-- The result is IO t, so wrap the result in an IO constructor
- Just (io_tycon, [io_res_ty], [io_data_con]) | getUnique io_tycon == ioTyConKey
+ Just (io_tycon, [io_res_ty], [io_data_con]) | io_tycon `hasKey` ioTyConKey
-> mk_alt return_result
(resultWrapper io_res_ty) `thenDs` \ (ccall_res_ty, the_alt) ->
newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id ->
newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id ->
let
the_rhs = return_result (Var state_id) (wrap_result (panic "boxResult"))
- ccall_res_ty = mkUnboxedTupleTy 1 [realWorldStatePrimTy]
- the_alt = (DataAlt (unboxedTupleCon 1), [state_id], the_rhs)
+ ccall_res_ty = mkTyConApp unboxedSingletonTyCon [realWorldStatePrimTy]
+ the_alt = (DataAlt unboxedSingletonDataCon, [state_id], the_rhs)
in
returnDs (ccall_res_ty, the_alt)
newSysLocalDs prim_res_ty `thenDs` \ result_id ->
let
the_rhs = return_result (Var state_id) (wrap_result (Var result_id))
- ccall_res_ty = mkUnboxedTupleTy 2 [realWorldStatePrimTy, prim_res_ty]
+ ccall_res_ty = mkTyConApp unboxedPairTyCon [realWorldStatePrimTy, prim_res_ty]
the_alt = (DataAlt unboxedPairDataCon, [state_id, result_id], the_rhs)
in
returnDs (ccall_res_ty, the_alt)
import DsGRHSs ( dsGuarded )
import DsCCall ( dsCCall, resultWrapper )
import DsListComp ( dsListComp )
-import DsUtils ( mkErrorAppDs, mkDsLets, mkConsExpr, mkNilExpr )
+import DsUtils ( mkErrorAppDs, mkDsLets, mkStringLit, mkStringLitFS,
+ mkConsExpr, mkNilExpr
+ )
import Match ( matchWrapper, matchSimply )
import CostCentre ( mkUserCC )
import FieldLabel ( FieldLabel )
import Id ( Id, idType, recordSelectorFieldLabel )
+import PrelInfo ( rEC_CON_ERROR_ID, rEC_UPD_ERROR_ID, iRREFUT_PAT_ERROR_ID )
import DataCon ( DataCon, dataConWrapId, dataConTyCon, dataConArgTys, dataConFieldLabels )
-import PrelInfo ( rEC_CON_ERROR_ID, rEC_UPD_ERROR_ID, iRREFUT_PAT_ERROR_ID, addr2IntegerId )
import TyCon ( isNewTyCon )
import DataCon ( isExistentialDataCon )
import Literal ( Literal(..), inIntRange )
isNotUsgTy, unUsgTy,
splitAppTy, isUnLiftedType, Type
)
-import TysWiredIn ( tupleCon, unboxedTupleCon,
+import TysWiredIn ( tupleCon,
listTyCon, mkListTy,
charDataCon, charTy, stringTy,
smallIntegerDataCon, isIntegerTy
)
-import BasicTypes ( RecFlag(..) )
+import BasicTypes ( RecFlag(..), Boxity(..) )
import Maybes ( maybeToBool )
-import Unique ( Uniquable(..), ratioTyConKey )
+import Unique ( Uniquable(..), hasKey, ratioTyConKey, addr2IntegerIdKey )
import Util ( zipEqual, zipWithEqual )
import Outputable
-- "_" => build (\ c n -> c 'c' n) -- LATER
dsExpr (HsLitOut (HsString str) _)
- = returnDs (mkStringLitFS str)
+ = mkStringLitFS str
dsExpr (HsLitOut (HsLitLit str) ty)
= ASSERT( maybeToBool maybe_ty )
Just rep_ty = maybe_ty
dsExpr (HsLitOut (HsInt i) ty)
- = returnDs (mkIntegerLit i)
+ = mkIntegerLit i
dsExpr (HsLitOut (HsFrac r) ty)
- = returnDs (mkConApp ratio_data_con [Type integer_ty,
- mkIntegerLit (numerator r),
- mkIntegerLit (denominator r)])
+ = mkIntegerLit (numerator r) `thenDs` \ num ->
+ mkIntegerLit (denominator r) `thenDs` \ denom ->
+ returnDs (mkConApp ratio_data_con [Type integer_ty, num, denom])
where
(ratio_data_con, integer_ty)
= case (splitAlgTyConApp_maybe ty) of
Just (tycon, [i_ty], [con])
- -> ASSERT(isIntegerTy i_ty && getUnique tycon == ratioTyConKey)
+ -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
(con, i_ty)
_ -> (panic "ratio_data_con", panic "integer_ty")
-
-- others where we know what to do:
dsExpr (HsLitOut (HsIntPrim i) _)
returnDs (Case core_discrim bndr alts)
_ -> panic ("dsExpr: tuple pattern:\n" ++ showSDoc (ppr matching_code))
where
- ubx_tuple_match (Match _ [TuplePat ps False{-unboxed-}] _ _) = True
+ ubx_tuple_match (Match _ [TuplePat ps Unboxed] _ _) = True
ubx_tuple_match _ = False
dsExpr (HsCase discrim matches src_loc)
ASSERT( isNotUsgTy ty )
returnDs (mkConsExpr ty core_x core_xs)
-dsExpr (ExplicitTuple expr_list boxed)
+dsExpr (ExplicitTuple expr_list boxity)
= mapDs dsExpr expr_list `thenDs` \ core_exprs ->
- returnDs (mkConApp ((if boxed
- then tupleCon
- else unboxedTupleCon) (length expr_list))
- (map (Type . unUsgTy . exprType) core_exprs ++ core_exprs))
+ returnDs (mkConApp (tupleCon boxity (length expr_list))
+ (map (Type . unUsgTy . exprType) core_exprs ++ core_exprs))
-- the above unUsgTy is *required* -- KSW 1999-04-07
dsExpr (ArithSeqOut expr (From from))
= do_expr expr locn `thenDs` \ expr2 ->
go stmts `thenDs` \ rest ->
let msg = ASSERT( isNotUsgTy b_ty )
- "Pattern match failure in do expression, " ++ showSDoc (ppr locn) in
+ "Pattern match failure in do expression, " ++ showSDoc (ppr locn)
+ in
+ mkStringLit msg `thenDs` \ core_msg ->
returnDs (mkIfThenElse expr2
rest
(App (App (Var fail_id)
(Type b_ty))
- (mkStringLit msg)))
+ core_msg))
go (ExprStmt expr locn : stmts)
= do_expr expr locn `thenDs` \ expr2 ->
\end{code}
\begin{code}
-mkIntegerLit :: Integer -> CoreExpr
+mkIntegerLit :: Integer -> DsM CoreExpr
mkIntegerLit i
| inIntRange i -- Small enough, so start from an Int
- = mkConApp smallIntegerDataCon [mkIntLit i]
+ = returnDs (mkConApp smallIntegerDataCon [mkIntLit i])
| otherwise -- Big, so start from a string
- = App (Var addr2IntegerId) (Lit (MachStr (_PK_ (show i))))
+ = dsLookupGlobalValue addr2IntegerIdKey `thenDs` \ addr2IntegerId ->
+ returnDs (App (Var addr2IntegerId) (Lit (MachStr (_PK_ (show i)))))
\end{code}
mkForeignExportOcc, isLocalName,
NamedThing(..), Provenance(..), ExportFlag(..)
)
-import PrelInfo ( deRefStablePtr_NAME, returnIO_NAME, bindIO_NAME, makeStablePtr_NAME )
import Type ( unUsgTy,
splitTyConApp_maybe, splitFunTys, splitForAllTys,
Type, mkFunTys, mkForAllTys, mkTyConApp,
import Var ( TyVar )
import TysPrim ( realWorldStatePrimTy, addrPrimTy )
import TysWiredIn ( unitTy, addrTy, stablePtrTyCon,
- unboxedTupleCon, addrDataCon
+ addrDataCon
)
-import Unique
+import Unique ( Uniquable(..), hasKey,
+ ioTyConKey, deRefStablePtrIdKey, returnIOIdKey,
+ bindIOIdKey, makeStablePtrIdKey
+ )
import Maybes ( maybeToBool )
import Outputable
\end{code}
-- If it's plain t, return (\x.returnIO x, IO t, t)
(case splitTyConApp_maybe orig_res_ty of
Just (ioTyCon, [res_ty])
- -> ASSERT( getUnique ioTyCon == ioTyConKey )
+ -> ASSERT( ioTyCon `hasKey` ioTyConKey )
-- The function already returns IO t
returnDs (\body -> body, orig_res_ty, res_ty)
other -> -- The function returns t, so wrap the call in returnIO
- dsLookupGlobalValue returnIO_NAME `thenDs` \ retIOId ->
+ dsLookupGlobalValue returnIOIdKey `thenDs` \ retIOId ->
returnDs (\body -> mkApps (Var retIOId) [Type orig_res_ty, body],
funResultTy (applyTy (idType retIOId) orig_res_ty),
-- We don't have ioTyCon conveniently to hand
(if isDyn then
newSysLocalDs stbl_ptr_ty `thenDs` \ stbl_ptr ->
newSysLocalDs stbl_ptr_to_ty `thenDs` \ stbl_value ->
- dsLookupGlobalValue deRefStablePtr_NAME `thenDs` \ deRefStablePtrId ->
+ dsLookupGlobalValue deRefStablePtrIdKey `thenDs` \ deRefStablePtrId ->
+ dsLookupGlobalValue bindIOIdKey `thenDs` \ bindIOId ->
let
the_deref_app = mkApps (Var deRefStablePtrId)
[ Type stbl_ptr_to_ty, Var stbl_ptr ]
- in
- dsLookupGlobalValue bindIO_NAME `thenDs` \ bindIOId ->
- let
+
stbl_app cont = mkApps (Var bindIOId)
[ Type stbl_ptr_to_ty
, Type res_ty
dsFExport i export_ty mod_name fe_ext_name cconv True
`thenDs` \ (fe@(NonRec fe_helper fe_expr), h_code, c_code) ->
newSysLocalDs arg_ty `thenDs` \ cback ->
- dsLookupGlobalValue makeStablePtr_NAME `thenDs` \ makeStablePtrId ->
+ dsLookupGlobalValue makeStablePtrIdKey `thenDs` \ makeStablePtrId ->
let
mk_stbl_ptr_app = mkApps (Var makeStablePtrId) [ Type arg_ty, Var cback ]
in
- dsLookupGlobalValue bindIO_NAME `thenDs` \ bindIOId ->
+ dsLookupGlobalValue bindIOIdKey `thenDs` \ bindIOId ->
newSysLocalDs (mkTyConApp stablePtrTyCon [arg_ty]) `thenDs` \ stbl_value ->
let
stbl_app cont ret_ty
import DsMonad
import DsUtils
import PrelInfo ( nON_EXHAUSTIVE_GUARDS_ERROR_ID )
-import Unique ( otherwiseIdKey, trueDataConKey, Uniquable(..) )
+import Unique ( otherwiseIdKey, trueDataConKey, hasKey, Uniquable(..) )
import Outputable
\end{code}
-- Turn an "otherwise" guard is a no-op
matchGuard (GuardStmt (HsVar v) _ : stmts) ctx
- | uniq == otherwiseIdKey
- || uniq == trueDataConKey
+ | v `hasKey` otherwiseIdKey
+ || v `hasKey` trueDataConKey
= matchGuard stmts ctx
- where
- uniq = getUnique v
matchGuard (GuardStmt expr locn : stmts) ctx
= matchGuard stmts ctx `thenDs` \ match_result ->
\begin{verbatim}
f x | p <- e', let C y# = e, f y# = r1
| otherwise = r2
-\end{verbatim}
\ No newline at end of file
+\end{verbatim}
import Id ( idType, Id )
import Type ( Type )
-import TysWiredIn ( mkListTy, mkTupleTy, mkUnboxedTupleTy, unitTy )
+import TysWiredIn ( mkListTy, mkTupleTy, unitTy )
+import BasicTypes ( Boxity(..) )
import Panic ( panic )
\end{code}
outPatType (AsPat var pat) = idType var
outPatType (ConPat _ ty _ _ _) = ty
outPatType (ListPat ty _) = mkListTy ty
-outPatType (TuplePat pats True) = mkTupleTy (length pats) (map outPatType pats)
-outPatType (TuplePat pats False)= mkUnboxedTupleTy (length pats) (map outPatType pats)
+outPatType (TuplePat pats box) = mkTupleTy box (length pats) (map outPatType pats)
outPatType (RecPat _ ty _ _ _) = ty
outPatType (LitPat lit ty) = ty
outPatType (NPat lit ty _) = ty
outPatType (DictPat ds ms) = case (length ds_ms) of
0 -> unitTy
1 -> idType (head ds_ms)
- n -> mkTupleTy n (map idType ds_ms)
+ n -> mkTupleTy Boxed n (map idType ds_ms)
where
ds_ms = ds ++ ms
\end{code}
import CoreUtils ( exprType, mkIfThenElse )
import Id ( idType )
import Var ( Id, TyVar )
-import PrelInfo ( foldrId, buildId )
import Type ( mkTyVarTy, mkForAllTy, mkFunTys, mkFunTy, Type )
import TysPrim ( alphaTyVar, alphaTy )
import TysWiredIn ( nilDataCon, consDataCon, listTyCon )
import Match ( matchSimply )
+import Unique ( foldrIdKey, buildIdKey )
import Outputable
\end{code}
n_ty = mkTyVarTy n_tyvar
c_ty = mkFunTys [elt_ty, n_ty] n_ty
in
- newSysLocalsDs [c_ty,n_ty] `thenDs` \ [c, n] ->
+ newSysLocalsDs [c_ty,n_ty] `thenDs` \ [c, n] ->
- dfListComp c n quals `thenDs` \ result ->
+ dfListComp c n quals `thenDs` \ result ->
- returnDs (Var buildId `App` Type elt_ty
- `App` mkLams [n_tyvar, c, n] result)
+ dsLookupGlobalValue buildIdKey `thenDs` \ build_id ->
+ returnDs (Var build_id `App` Type elt_ty
+ `App` mkLams [n_tyvar, c, n] result)
\end{code}
%************************************************************************
matchSimply (Var x) ListCompMatch pat core_rest (Var b) `thenDs` \ core_expr ->
-- now build the outermost foldr, and return
+ dsLookupGlobalValue foldrIdKey `thenDs` \ foldr_id ->
returnDs (
- Var foldrId `App` Type x_ty
- `App` Type b_ty
- `App` mkLams [x, b] core_expr
- `App` Var n_id
- `App` core_list1
+ Var foldr_id `App` Type x_ty
+ `App` Type b_ty
+ `App` mkLams [x, b] core_expr
+ `App` Var n_id
+ `App` core_list1
)
\end{code}
import UniqSupply ( initUs_, splitUniqSupply, uniqFromSupply, uniqsFromSupply,
UniqSM, UniqSupply )
import Unique ( Unique )
-import UniqFM ( lookupWithDefaultUFM )
+import UniqFM ( lookupWithDefaultUFM_Directly )
import Util ( zipWithEqual )
infixr 9 `thenDs`
\end{code}
\begin{code}
-dsLookupGlobalValue :: Name -> DsM Id
-dsLookupGlobalValue name us genv loc mod warns
- = case maybeWiredInIdName name of
- Just id -> (id, warns)
- Nothing -> (lookupWithDefaultUFM genv def name, warns)
+dsLookupGlobalValue :: Unique -> DsM Id
+dsLookupGlobalValue key us genv loc mod warns
+ = (lookupWithDefaultUFM_Directly genv def key, warns)
where
- def = pprPanic "tcLookupGlobalValue:" (ppr name)
+ def = pprPanic "tcLookupGlobalValue:" (ppr key)
\end{code}
mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult,
mkErrorAppDs, mkNilExpr, mkConsExpr,
+ mkStringLit, mkStringLitFS,
mkSelectorBinds, mkTupleExpr, mkTupleSelector,
import CoreUtils ( exprType, mkIfThenElse )
import PrelInfo ( iRREFUT_PAT_ERROR_ID )
import Id ( idType, Id, mkWildId )
-import Literal ( Literal )
+import Literal ( Literal(..) )
import TyCon ( isNewTyCon, tyConDataCons )
import DataCon ( DataCon, StrictnessMark, maybeMarkedUnboxed,
dataConStrictMarks, dataConId, splitProductType_maybe
addrTy, addrDataCon,
wordTy, wordDataCon
)
+import BasicTypes ( Boxity(..) )
import UniqSet ( mkUniqSet, minusUniqSet, isEmptyUniqSet, UniqSet )
+import Unique ( unpackCStringIdKey, unpackCString2IdKey )
import Outputable
\end{code}
let
full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg])
in
- returnDs (mkApps (Var err_id) [(Type . unUsgTy) ty, mkStringLit full_msg])
+ mkStringLit full_msg `thenDs` \ core_msg ->
+ returnDs (mkApps (Var err_id) [(Type . unUsgTy) ty, core_msg])
-- unUsgTy *required* -- KSW 1999-04-07
+
+mkStringLit :: String -> DsM CoreExpr
+mkStringLit str = mkStringLitFS (_PK_ str)
+
+mkStringLitFS :: FAST_STRING -> DsM CoreExpr
+mkStringLitFS str
+ | any is_NUL (_UNPK_ str)
+ = -- Must cater for NULs in literal string
+ dsLookupGlobalValue unpackCString2IdKey `thenDs` \ unpack_id ->
+ returnDs (mkApps (Var unpack_id)
+ [Lit (MachStr str),
+ mkIntLitInt (_LENGTH_ str)])
+
+ | otherwise
+ = -- No NULs in the string
+ dsLookupGlobalValue unpackCStringIdKey `thenDs` \ unpack_id ->
+ returnDs (App (Var unpack_id) (Lit (MachStr str)))
+
+ where
+ is_NUL c = c == '\0'
\end{code}
%************************************************************************
let
full_msg = showSDoc (hcat [ppr src_loc, text "|", ppr pat])
in
+ mkStringLit full_msg `thenDs` \ core_msg ->
mapDs (mk_bind val_var msg_var) binders `thenDs` \ binds ->
returnDs ( (val_var, val_expr) :
- (msg_var, mkStringLit full_msg) :
+ (msg_var, core_msg) :
binds )
binder_ty = idType bndr_var
error_expr = mkApps (Var iRREFUT_PAT_ERROR_ID) [Type binder_ty, Var msg_var]
- is_simple_pat (TuplePat ps True{-boxed-}) = all is_triv_pat ps
+ is_simple_pat (TuplePat ps Boxed) = all is_triv_pat ps
is_simple_pat (ConPat _ _ _ _ ps) = all is_triv_pat ps
is_simple_pat (VarPat _) = True
is_simple_pat (RecPat _ _ _ _ ps) = and [is_triv_pat p | (_,p,_) <- ps]
mkTupleExpr [] = Var unitDataConId
mkTupleExpr [id] = Var id
-mkTupleExpr ids = mkConApp (tupleCon (length ids))
+mkTupleExpr ids = mkConApp (tupleCon Boxed (length ids))
(map (Type . unUsgTy . idType) ids ++ [ Var i | i <- ids ])
\end{code}
mkTupleSelector vars the_var scrut_var scrut
= ASSERT( not (null vars) )
- Case scrut scrut_var [(DataAlt (tupleCon (length vars)), vars, Var the_var)]
+ Case scrut scrut_var [(DataAlt (tupleCon Boxed (length vars)), vars, Var the_var)]
\end{code}
charTy, charDataCon, intTy, intDataCon,
floatTy, floatDataCon, doubleTy, tupleCon,
doubleDataCon, addrTy,
- addrDataCon, wordTy, wordDataCon,
- mkUnboxedTupleTy, unboxedTupleCon
+ addrDataCon, wordTy, wordDataCon
)
+import BasicTypes ( Boxity(..) )
import UniqSet
import ErrUtils ( addErrLocHdrLine, dontAddErrLoc )
import Outputable
(ConPat nilDataCon list_ty [] [] [])
pats
-tidy1 v (TuplePat pats True{-boxed-}) match_result
+tidy1 v (TuplePat pats boxity) match_result
= returnDs (tuple_ConPat, match_result)
where
arity = length pats
tuple_ConPat
- = ConPat (tupleCon arity)
- (mkTupleTy arity (map outPatType pats)) [] []
- pats
-
-tidy1 v (TuplePat pats False{-unboxed-}) match_result
- = returnDs (tuple_ConPat, match_result)
- where
- arity = length pats
- tuple_ConPat
- = ConPat (unboxedTupleCon arity)
- (mkUnboxedTupleTy arity (map outPatType pats)) [] []
+ = ConPat (tupleCon boxity arity)
+ (mkTupleTy boxity arity (map outPatType pats)) [] []
pats
tidy1 v (DictPat dicts methods) match_result
= case num_of_d_and_ms of
- 0 -> tidy1 v (TuplePat [] True) match_result
+ 0 -> tidy1 v (TuplePat [] Boxed) match_result
1 -> tidy1 v (head dict_and_method_pats) match_result
- _ -> tidy1 v (TuplePat dict_and_method_pats True) match_result
+ _ -> tidy1 v (TuplePat dict_and_method_pats Boxed) match_result
where
num_of_d_and_ms = length dicts + length methods
dict_and_method_pats = map VarPat (dicts ++ methods)
import {-# SOURCE #-} HsMatches ( pprMatches, Match, pprGRHSs, GRHSs )
-- friends:
-import HsTypes ( HsType, cmpHsType )
+import HsTypes ( HsType )
import HsImpExp ( IE(..), ieName )
import CoreSyn ( CoreExpr )
import PprCore () -- Instances for Outputable
| FixSig (FixitySig name) -- Fixity declaration
- | DeprecSig (Deprecation name) -- DEPRECATED
- SrcLoc
-
-data FixitySig name = FixitySig name Fixity SrcLoc
--- We use exported entities for things to deprecate. Cunning trick (hack?):
--- `IEModuleContents undefined' is used for module deprecation.
-data Deprecation name = Deprecation (IE name) DeprecTxt
+data FixitySig name = FixitySig name Fixity SrcLoc
-type DeprecTxt = FAST_STRING -- reason/explanation for deprecation
+instance Eq name => Eq (FixitySig name) where
+ (FixitySig n1 f1 _) == (FixitySig n2 f2 _) = n1==n2 && f1==f2
\end{code}
\begin{code}
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 = 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 (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
isPragSig (InlineSig _ _ _) = True
isPragSig (NoInlineSig _ _ _) = True
isPragSig (SpecInstSig _ _) = True
-isPragSig (DeprecSig _ _) = True
isPragSig other = False
\end{code}
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}
ppr_sig (Sig var ty _)
= sep [ppr var <+> dcolon, nest 4 (ppr ty)]
-ppr_sig (ClassOpSig var _ _ ty _)
- = sep [ppr var <+> dcolon, nest 4 (ppr ty)]
+ppr_sig (ClassOpSig var _ dm ty _)
+ = sep [ppr var <+> pp_dm <+> dcolon, nest 4 (ppr ty)]
+ where
+ pp_dm = if dm then equals else empty -- Default-method indicator
ppr_sig (SpecSig var ty _)
= sep [ hsep [text "{-# SPECIALIZE", ppr var, dcolon],
ppr_sig (FixSig fix_sig) = ppr fix_sig
-ppr_sig (DeprecSig deprec _) = ppr deprec
instance Outputable name => Outputable (FixitySig name) where
ppr (FixitySig name fixity loc) = sep [ppr fixity, ppr name]
-instance Outputable name => Outputable (Deprecation name) where
- ppr (Deprecation (IEModuleContents _) txt)
- = hsep [text "{-# DEPRECATED", doubleQuotes (ppr txt), text "#-}"]
- ppr (Deprecation thing txt)
- = hsep [text "{-# DEPRECATED", ppr thing, doubleQuotes (ppr txt), text "#-}"]
-
ppr_phase :: Maybe Int -> SDoc
ppr_phase Nothing = empty
ppr_phase (Just n) = int n
\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 _)
+eqHsSig :: Sig Name -> Sig Name -> Bool
+eqHsSig (Sig n1 _ _) (Sig n2 _ _) = n1 == n2
+eqHsSig (InlineSig n1 _ _) (InlineSig n2 _ _) = n1 == n2
+eqHsSig (NoInlineSig n1 _ _) (NoInlineSig n2 _ _) = n1 == n2
+
+eqHsSig (SpecInstSig ty1 _) (SpecInstSig ty2 _) = ty1 == ty2
+eqHsSig (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)"
+ (n1 == n2) && (ty1 == ty2)
+
+eqHsSig other_1 other_2 = False
\end{code}
module HsCore (
UfExpr(..), UfAlt, UfBinder(..), UfNote(..),
UfBinding(..), UfConAlt(..),
- HsIdInfo(..), HsStrictnessInfo(..),
- IfaceSig(..), UfRuleBody(..)
+ HsIdInfo(..),
+ IfaceSig(..),
+
+ eq_ufExpr, eq_ufBinders, pprUfExpr,
+
+ toUfExpr, toUfBndr
) where
#include "HsVersions.h"
-- friends:
-import HsTypes ( HsType, pprParendHsType )
+import HsTypes ( HsType, pprParendHsType, pprHsTyVarBndr, toHsType,
+ HsTupCon(..), hsTupParens,
+ emptyEqHsEnv, extendEqHsEnv, eqListBy,
+ eq_hsType, eq_hsVar, eq_hsVars
+ )
-- others:
-import IdInfo ( ArityInfo, UpdateInfo, InlinePragInfo )
-import CoreSyn ( CoreBndr, CoreExpr )
-import Demand ( Demand )
-import Literal ( Literal )
+import Id ( idArity, idType, isDataConId_maybe, isPrimOpId_maybe )
+import Var ( varType, isId )
+import IdInfo ( ArityInfo, UpdateInfo, InlinePragInfo,
+ pprInlinePragInfo, ppArityInfo, ppStrictnessInfo
+ )
+import RdrName ( RdrName )
+import Name ( Name, toRdrName )
+import CoreSyn
+import CostCentre ( pprCostCentreCore )
+import PrimOp ( PrimOp(CCallOp) )
+import Demand ( Demand, StrictnessInfo )
+import Literal ( Literal, maybeLitLit )
import PrimOp ( CCall, pprCCallOp )
-import Type ( Kind )
-import PprType ( {- instance Outputable Type -} )
+import DataCon ( dataConTyCon )
+import TyCon ( isTupleTyCon, tupleTyConBoxity )
+import Type ( Type, Kind )
import CostCentre
import SrcLoc ( SrcLoc )
+import BasicTypes ( Arity )
import Outputable
\end{code}
data UfExpr name
= UfVar name
| UfType (HsType name)
- | UfTuple name [UfExpr name] -- Type arguments omitted
- | UfLam (UfBinder name) (UfExpr name)
- | UfApp (UfExpr name) (UfExpr name)
+ | UfTuple (HsTupCon name) [UfExpr name] -- Type arguments omitted
+ | UfLam (UfBinder name) (UfExpr name)
+ | UfApp (UfExpr name) (UfExpr name)
| UfCase (UfExpr name) name [UfAlt name]
| UfLet (UfBinding name) (UfExpr name)
| UfNote (UfNote name) (UfExpr name)
data UfConAlt name = UfDefault
| UfDataAlt name
+ | UfTupleAlt (HsTupCon name)
| UfLitAlt Literal
| UfLitLitAlt FAST_STRING (HsType name)
%************************************************************************
%* *
-\subsection[HsCore-print]{Printing Core unfoldings}
+\subsection{Converting from Core to UfCore}
%* *
%************************************************************************
\begin{code}
-instance Outputable name => Outputable (UfExpr name) where
- ppr (UfVar v) = ppr v
- ppr (UfLit l) = ppr l
+toUfExpr :: CoreExpr -> UfExpr RdrName
+toUfExpr (Var v) = toUfVar v
+toUfExpr (Lit l) = case maybeLitLit l of
+ Just (s,ty) -> UfLitLit s (toHsType ty)
+ Nothing -> UfLit l
+toUfExpr (Type ty) = UfType (toHsType ty)
+toUfExpr (Lam x b) = UfLam (toUfBndr x) (toUfExpr b)
+toUfExpr (App f a) = toUfApp f [a]
+toUfExpr (Case s x as) = UfCase (toUfExpr s) (toRdrName x) (map toUfAlt as)
+toUfExpr (Let b e) = UfLet (toUfBind b) (toUfExpr e)
+toUfExpr (Note n e) = UfNote (toUfNote n) (toUfExpr e)
+
+---------------------
+toUfNote (SCC cc) = UfSCC cc
+toUfNote (Coerce t1 _) = UfCoerce (toHsType t1)
+toUfNote InlineCall = UfInlineCall
+toUfNote InlineMe = UfInlineMe
+
+---------------------
+toUfBind (NonRec b r) = UfNonRec (toUfBndr b) (toUfExpr r)
+toUfBind (Rec prs) = UfRec [(toUfBndr b, toUfExpr r) | (b,r) <- prs]
+
+---------------------
+toUfAlt (c,bs,r) = (toUfCon c, map toRdrName bs, toUfExpr r)
+
+---------------------
+toUfCon (DataAlt dc) | isTupleTyCon tc = UfTupleAlt (HsTupCon (toRdrName dc) (tupleTyConBoxity tc))
+ | otherwise = UfDataAlt (toRdrName dc)
+ where
+ tc = dataConTyCon dc
+
+toUfCon (LitAlt l) = case maybeLitLit l of
+ Just (s,ty) -> UfLitLitAlt s (toHsType ty)
+ Nothing -> UfLitAlt l
+toUfCon DEFAULT = UfDefault
+
+---------------------
+toUfBndr x | isId x = UfValBinder (toRdrName x) (toHsType (varType x))
+ | otherwise = UfTyBinder (toRdrName x) (varType x)
+
+---------------------
+toUfApp (App f a) as = toUfApp f (a:as)
+toUfApp (Var v) as
+ = case isDataConId_maybe v of
+ -- We convert the *worker* for tuples into UfTuples
+ Just dc | isTupleTyCon tc && saturated -> UfTuple (HsTupCon (toRdrName dc) (tupleTyConBoxity tc)) tup_args
+ where
+ val_args = dropWhile isTypeArg as
+ saturated = length val_args == idArity v
+ tup_args = map toUfExpr val_args
+ tc = dataConTyCon dc
+ ;
+
+ other -> mkUfApps (toUfVar v) as
+
+toUfApp e as = mkUfApps (toUfExpr e) as
+
+mkUfApps = foldl (\f a -> UfApp f (toUfExpr a))
+
+---------------------
+toUfVar v = case isPrimOpId_maybe v of
+ -- Ccalls has special syntax
+ Just (CCallOp cc) -> UfCCall cc (toHsType (idType v))
+ other -> UfVar (toRdrName v)
+\end{code}
- ppr (UfLitLit l ty) = ppr l
- ppr (UfCCall cc ty) = pprCCallOp cc
- ppr (UfType ty) = char '@' <+> pprParendHsType ty
+%************************************************************************
+%* *
+\subsection[HsCore-print]{Printing Core unfoldings}
+%* *
+%************************************************************************
- ppr (UfTuple c as) = parens (hsep (punctuate comma (map ppr as)))
+\begin{code}
+instance Outputable name => Outputable (UfExpr name) where
+ ppr e = pprUfExpr noParens e
+
+noParens :: SDoc -> SDoc
+noParens pp = pp
+
+pprUfExpr :: Outputable name => (SDoc -> SDoc) -> UfExpr name -> SDoc
+ -- The function adds parens in context that need
+ -- an atomic value (e.g. function args)
+
+pprUfExpr add_par (UfVar v) = ppr v
+pprUfExpr add_par (UfLit l) = ppr l
+pprUfExpr add_par (UfLitLit l ty) = ppr l
+pprUfExpr add_par (UfCCall cc ty) = braces (pprCCallOp cc <+> ppr ty)
+pprUfExpr add_par (UfType ty) = char '@' <+> pprParendHsType ty
+pprUfExpr add_par (UfLam b body) = add_par (hsep [char '\\', ppr b, ptext SLIT("->"), pprUfExpr noParens body])
+pprUfExpr add_par (UfApp fun arg) = add_par (pprUfExpr noParens fun <+> pprUfExpr parens arg)
+pprUfExpr add_par (UfTuple c as) = hsTupParens c (interpp'SP as)
+
+pprUfExpr add_par (UfCase scrut bndr alts)
+ = add_par (hsep [ptext SLIT("case"), pprUfExpr noParens scrut, ptext SLIT("of"), ppr bndr,
+ braces (hsep (map pp_alt alts))])
+ where
+ pp_alt (UfTupleAlt tup_con, bs, rhs) = hsTupParens tup_con (interpp'SP bs) <+> ppr_rhs rhs
+ pp_alt (c, bs, rhs) = ppr c <+> interppSP bs <+> ppr_rhs rhs
- ppr (UfLam b body)
- = hsep [char '\\', ppr b, ptext SLIT("->"), ppr body]
+ ppr_rhs rhs = ptext SLIT("->") <+> pprUfExpr noParens rhs <> semi
- ppr (UfApp fun arg) = ppr fun <+> ppr arg
+pprUfExpr add_par (UfLet (UfNonRec b rhs) body)
+ = add_par (hsep [ptext SLIT("let"),
+ braces (ppr b <+> equals <+> pprUfExpr noParens rhs),
+ ptext SLIT("in"), pprUfExpr noParens body])
- ppr (UfCase scrut bndr alts)
- = hsep [ptext SLIT("case"), ppr scrut, ptext SLIT("of"), ppr bndr,
- braces (hsep (punctuate semi (map pp_alt alts)))]
+pprUfExpr add_par (UfLet (UfRec pairs) body)
+ = add_par (hsep [ptext SLIT("__letrec"), braces (hsep (map pp_pair pairs)),
+ ptext SLIT("in"), pprUfExpr noParens body])
where
- pp_alt (c,bs,rhs) = hsep [ppr c, ppr bs, ppr_arrow, ppr rhs]
-
- ppr_arrow = ptext SLIT("->")
+ pp_pair (b,rhs) = ppr b <+> equals <+> pprUfExpr noParens rhs <> semi
- ppr (UfLet (UfNonRec b rhs) body)
- = hsep [ptext SLIT("let"), ppr b, equals, ppr rhs, ptext SLIT("in"), ppr body]
- ppr (UfLet (UfRec pairs) body)
- = hsep [ptext SLIT("letrec"), braces (hsep (punctuate semi (map pp_pair pairs))), ptext SLIT("in"), ppr body]
- where
- pp_pair (b,rhs) = hsep [ppr b, equals, ppr rhs]
+pprUfExpr add_par (UfNote note body) = add_par (ppr note <+> pprUfExpr parens body)
- ppr (UfNote note body)
- = hsep [ptext SLIT("_NOTE_ [ToDo]>"), ppr body]
+instance Outputable name => Outputable (UfNote name) where
+ ppr (UfSCC cc) = pprCostCentreCore cc
+ ppr (UfCoerce ty) = ptext SLIT("__coerce") <+> pprParendHsType ty
+ ppr UfInlineCall = ptext SLIT("__inline_call")
+ ppr UfInlineMe = ptext SLIT("__inline_me")
instance Outputable name => Outputable (UfConAlt name) where
- ppr UfDefault = text "DEFAULT"
+ ppr UfDefault = text "__DEFAULT"
ppr (UfLitAlt l) = ppr l
ppr (UfLitLitAlt l ty) = ppr l
ppr (UfDataAlt d) = ppr d
instance Outputable name => Outputable (UfBinder name) where
- ppr (UfValBinder name ty) = hsep [ppr name, dcolon, ppr ty]
- ppr (UfTyBinder name kind) = hsep [ppr name, dcolon, ppr kind]
+ ppr (UfValBinder name ty) = hsep [ppr name, dcolon, pprParendHsType ty]
+ ppr (UfTyBinder name kind) = char '@' <+> pprHsTyVarBndr name kind
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection[HsCore-print]{Equality, for interface file checking
+%* *
+%************************************************************************
+
+\begin{code}
+instance Ord name => Eq (UfExpr name) where
+ (==) a b = eq_ufExpr emptyEqHsEnv a b
+
+-----------------
+eq_ufBinder env (UfValBinder n1 t1) (UfValBinder n2 t2) k
+ = eq_hsType env t1 t2 && k (extendEqHsEnv env n1 n2)
+eq_ufBinder env (UfTyBinder n1 k1) (UfTyBinder n2 k2) k
+ = k1==k2 && k (extendEqHsEnv env n1 n2)
+eq_ufBinder _ _ _ _ = False
+
+-----------------
+eq_ufBinders env [] [] k = k env
+eq_ufBinders env (b1:bs1) (b2:bs2) k = eq_ufBinder env b1 b2 (\env -> eq_ufBinders env bs1 bs2 k)
+eq_ufBinders env _ _ _ = False
+
+-----------------
+eq_ufExpr env (UfVar v1) (UfVar v2) = eq_hsVar env v1 v2
+eq_ufExpr env (UfLit l1) (UfLit l2) = l1 == l2
+eq_ufExpr env (UfLitLit l1 ty1) (UfLitLit l2 ty2) = l1==l2 && eq_hsType env ty1 ty2
+eq_ufExpr env (UfCCall c1 ty1) (UfCCall c2 ty2) = c1==c2 && eq_hsType env ty1 ty2
+eq_ufExpr env (UfType ty1) (UfType ty2) = eq_hsType env ty1 ty2
+eq_ufExpr env (UfTuple n1 as1) (UfTuple n2 as2) = n1==n2 && eqListBy (eq_ufExpr env) as1 as2
+eq_ufExpr env (UfLam b1 body1) (UfLam b2 body2) = eq_ufBinder env b1 b2 (\env -> eq_ufExpr env body1 body2)
+eq_ufExpr env (UfApp f1 a1) (UfApp f2 a2) = eq_ufExpr env f1 f2 && eq_ufExpr env a1 a2
+
+eq_ufExpr env (UfCase s1 b1 as1) (UfCase s2 b2 as2)
+ = eq_ufExpr env s1 s2 &&
+ eqListBy (eq_ufAlt (extendEqHsEnv env b1 b2)) as1 as2
+ where
+ eq_ufAlt env (c1,bs1,r1) (c2,bs2,r2)
+ = eq_ufConAlt env c1 c2 && eq_hsVars env bs1 bs2 (\env -> eq_ufExpr env r1 r2)
+
+eq_ufExpr env (UfLet (UfNonRec b1 r1) x1) (UfLet (UfNonRec b2 r2) x2)
+ = eq_ufExpr env r1 r2 && eq_ufBinder env b1 b2 (\env -> eq_ufExpr env x1 x2)
+
+eq_ufExpr env (UfLet (UfRec as1) x1) (UfLet (UfRec as2) x2)
+ = eq_ufBinders env bs1 bs2 (\env -> eqListBy (eq_ufExpr env) rs1 rs2 && eq_ufExpr env x1 x2)
+ where
+ (bs1,rs1) = unzip as1
+ (bs2,rs2) = unzip as2
+
+eq_ufExpr env (UfNote n1 r1) (UfNote n2 r2)
+ = eq_ufNote n1 n2 && eq_ufExpr env r1 r2
+ where
+ eq_ufNote (UfSCC c1) (UfSCC c2) = c1==c2
+ eq_ufNote (UfCoerce t1) (UfCoerce t2) = eq_hsType env t1 t2
+ eq_ufNote UfInlineCall UfInlineCall = True
+ eq_ufNote UfInlineMe UfInlineMe = True
+ eq_ufNote _ _ = False
+
+eq_ufExpr env _ _ = False
+
+-----------------
+eq_ufConAlt env UfDefault UfDefault = True
+eq_ufConAlt env (UfDataAlt n1) (UfDataAlt n2) = n1==n2
+eq_ufConAlt env (UfTupleAlt c1) (UfTupleAlt c2) = c1==c2
+eq_ufConAlt env (UfLitAlt l1) (UfLitAlt l2) = l1==l2
+eq_ufConAlt env (UfLitLitAlt s1 t1) (UfLitLitAlt s2 t2) = s1==s2 && eq_hsType env t1 t2
+eq_ufConAlt env _ _ = False
\end{code}
%************************************************************************
\begin{code}
-data IfaceSig name
- = IfaceSig name
- (HsType name)
- [HsIdInfo name]
- SrcLoc
+data IfaceSig name = IfaceSig name (HsType name) [HsIdInfo name] SrcLoc
+
+instance Ord name => Eq (IfaceSig name) where
+ (==) (IfaceSig n1 t1 i1 _) (IfaceSig n2 t2 i2 _) = n1==n2 && t1==t2 && i1==i2
instance (Outputable name) => Outputable (IfaceSig name) where
- ppr (IfaceSig var ty info _)
- = hang (hsep [ppr var, dcolon])
- 4 (ppr ty $$ ifPprDebug (vcat (map ppr info)))
+ ppr (IfaceSig var ty info _) = hsep [ppr var, dcolon, ppr ty, pprHsIdInfo info]
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Rules in interface files}
+%* *
+%************************************************************************
+
+\begin{code}
+pprHsIdInfo [] = empty
+pprHsIdInfo info = ptext SLIT("{-##") <+> hsep (map ppr info) <+> ptext SLIT("##-}")
data HsIdInfo name
= HsArity ArityInfo
- | HsStrictness HsStrictnessInfo
+ | HsStrictness StrictnessInfo
| HsUnfold InlinePragInfo (UfExpr name)
| HsUpdate UpdateInfo
- | HsSpecialise (UfRuleBody name)
| HsNoCafRefs
| HsCprInfo
| HsWorker name -- Worker, if any
+ deriving( Eq )
+-- NB: Specialisations and rules come in separately and are
+-- only later attached to the Id. Partial reason: some are orphans.
instance Outputable name => Outputable (HsIdInfo name) where
- ppr (HsUnfold _ unf) = ptext (SLIT("Unfolding:")) <+> ppr unf
- ppr other = empty -- Havn't got around to this yet
-
-data HsStrictnessInfo
- = HsStrictnessInfo ([Demand], Bool)
- | HsBottom
+ ppr (HsUnfold prag unf) = ptext SLIT("__U") <> pprInlinePragInfo prag <+> parens (ppr unf)
+ ppr (HsArity arity) = ppArityInfo arity
+ ppr (HsStrictness str) = ptext SLIT("__S") <+> ppStrictnessInfo str
+ ppr HsNoCafRefs = ptext SLIT("__C")
+ ppr HsCprInfo = ptext SLIT("__M")
+ ppr (HsWorker w) = ptext SLIT("__P") <+> ppr w
\end{code}
-
-%************************************************************************
-%* *
-\subsection{Rules in interface files}
-%* *
-%************************************************************************
-
-\begin{code}
-data UfRuleBody name = UfRuleBody FAST_STRING [UfBinder name] [UfExpr name] (UfExpr name) -- Pre typecheck
- | CoreRuleBody FAST_STRING [CoreBndr] [CoreExpr] CoreExpr -- Post typecheck
-\end{code}
ExtName(..), isDynamicExtName, extNameStatic,
ConDecl(..), ConDetails(..), BangType(..),
IfaceSig(..), SpecDataSig(..),
- hsDeclName, tyClDeclName, isClassDecl, isSynDecl, isDataDecl, countTyClDecls
+ DeprecDecl(..), DeprecTxt,
+ hsDeclName, tyClDeclName, isClassDecl, isSynDecl, isDataDecl, countTyClDecls, toHsRule
) where
#include "HsVersions.h"
-- friends:
-import HsBinds ( HsBinds, MonoBinds, Sig, FixitySig(..), nullMonoBinds )
+import HsBinds ( HsBinds, MonoBinds, Sig(..), FixitySig(..), nullMonoBinds )
import HsExpr ( HsExpr )
import HsPragmas ( DataPragmas, ClassPragmas )
+import HsImpExp ( IE(..) )
import HsTypes
-import HsCore ( UfExpr, UfBinder, IfaceSig(..), UfRuleBody )
+import PprCore ( pprCoreRule )
+import HsCore ( UfExpr(UfVar), UfBinder, IfaceSig(..), eq_ufBinders, eq_ufExpr, pprUfExpr, toUfExpr, toUfBndr )
+import CoreSyn ( CoreRule(..) )
import BasicTypes ( Fixity, NewOrData(..) )
import CallConv ( CallConv, pprCallConv )
-import Var ( TyVar )
+import Var ( TyVar, Id )
+import Name ( toRdrName )
-- others:
import PprType
-import {-# SOURCE #-} FunDeps ( pprFundeps )
+import FunDeps ( pprFundeps )
+import Class ( FunDep )
import CStrings ( CLabelString, pprCLabelString )
import Outputable
-import SrcLoc ( SrcLoc )
+import SrcLoc ( SrcLoc, noSrcLoc )
import Util
\end{code}
| ForD (ForeignDecl name)
| SigD (IfaceSig name)
| FixD (FixitySig name)
+ | DeprecD (DeprecDecl name)
| RuleD (RuleDecl name pat)
-- NB: all top-level fixity decls are contained EITHER
hsDeclName :: (Outputable name, Outputable pat)
=> HsDecl name pat -> name
#endif
-hsDeclName (TyClD decl) = tyClDeclName decl
-hsDeclName (SigD (IfaceSig name _ _ _)) = name
-hsDeclName (InstD (InstDecl _ _ _ name _)) = name
-hsDeclName (ForD (ForeignDecl name _ _ _ _ _)) = name
-hsDeclName (FixD (FixitySig name _ _)) = name
+hsDeclName (TyClD decl) = tyClDeclName decl
+hsDeclName (SigD (IfaceSig name _ _ _)) = name
+hsDeclName (InstD (InstDecl _ _ _ name _)) = name
+hsDeclName (ForD (ForeignDecl name _ _ _ _ _)) = name
+hsDeclName (FixD (FixitySig name _ _)) = name
-- Others don't make sense
#ifdef DEBUG
hsDeclName x = pprPanic "HsDecls.hsDeclName" (ppr x)
#endif
tyClDeclName :: TyClDecl name pat -> name
-tyClDeclName (TyData _ _ name _ _ _ _ _) = name
+tyClDeclName (TyData _ _ name _ _ _ _ _ _) = name
tyClDeclName (TySynonym name _ _ _) = name
tyClDeclName (ClassDecl _ name _ _ _ _ _ _ _ _ _ _) = name
\end{code}
ppr (ForD fd) = ppr fd
ppr (FixD fd) = ppr fd
ppr (RuleD rd) = ppr rd
+ ppr (DeprecD dd) = ppr dd
+\end{code}
+
+\begin{code}
+instance Ord name => Eq (HsDecl name pat) where
+ -- Used only when comparing interfaces,
+ -- at which time only signature and type/class decls
+ (SigD s1) == (SigD s2) = s1 == s2
+ (TyClD d1) == (TyClD d2) = d1 == d2
\end{code}
= TyData NewOrData
(HsContext name) -- context
name -- type constructor
- [HsTyVar name] -- type variables
+ [HsTyVarBndr name] -- type variables
[ConDecl name] -- data constructors (empty if abstract)
+ Int -- Number of data constructors (valid even if type is abstract)
(Maybe [name]) -- derivings; Nothing => not specified
-- (i.e., derive default); Just [] => derive
-- *nothing*; Just <list> => as you would
SrcLoc
| TySynonym name -- type constructor
- [HsTyVar name] -- type variables
+ [HsTyVarBndr name] -- type variables
(HsType name) -- synonym expansion
SrcLoc
| ClassDecl (HsContext name) -- context...
name -- name of the class
- [HsTyVar name] -- the class type variables
- [([name], [name])] -- functional dependencies
+ [HsTyVarBndr name] -- the class type variables
+ [FunDep name] -- functional dependencies
[Sig name] -- methods' signatures
(MonoBinds name pat) -- default methods
(ClassPragmas name)
-- and superclass selectors for this class.
-- These are filled in as the ClassDecl is made.
SrcLoc
+
+instance Ord name => Eq (TyClDecl name pat) where
+ -- Used only when building interface files
+ (==) (TyData nd1 cxt1 n1 tvs1 cons1 _ _ _ _)
+ (TyData nd2 cxt2 n2 tvs2 cons2 _ _ _ _)
+ = n1 == n2 &&
+ nd1 == nd2 &&
+ eqWithHsTyVars tvs1 tvs2 (\ env ->
+ eq_hsContext env cxt1 cxt2 &&
+ eqListBy (eq_ConDecl env) cons1 cons2
+ )
+
+ (==) (TySynonym n1 tvs1 ty1 _)
+ (TySynonym n2 tvs2 ty2 _)
+ = n1 == n2 &&
+ eqWithHsTyVars tvs1 tvs2 (\ env -> eq_hsType env ty1 ty2)
+
+ (==) (ClassDecl cxt1 n1 tvs1 fds1 sigs1 _ _ _ _ _ _ _)
+ (ClassDecl cxt2 n2 tvs2 fds2 sigs2 _ _ _ _ _ _ _)
+ = n1 == n2 &&
+ eqWithHsTyVars tvs1 tvs2 (\ env ->
+ eq_hsContext env cxt1 cxt2 &&
+ eqListBy (eq_hsFD env) fds1 fds2 &&
+ eqListBy (eq_cls_sig env) sigs1 sigs2
+ )
+
+eq_hsFD env (ns1,ms1) (ns2,ms2)
+ = eqListBy (eq_hsVar env) ns1 ns2 && eqListBy (eq_hsVar env) ms1 ms2
+
+eq_cls_sig env (ClassOpSig n1 _ b1 ty1 _) (ClassOpSig n2 _ b2 ty2 _)
+ = n1==n2 && b1==b2 && eq_hsType env ty1 ty2
\end{code}
\begin{code}
-- class, data, newtype, synonym decls
countTyClDecls decls
= (length [() | ClassDecl _ _ _ _ _ _ _ _ _ _ _ _ <- decls],
- length [() | TyData DataType _ _ _ _ _ _ _ <- decls],
- length [() | TyData NewType _ _ _ _ _ _ _ <- decls],
+ length [() | TyData DataType _ _ _ _ _ _ _ _ <- decls],
+ length [() | TyData NewType _ _ _ _ _ _ _ _ <- decls],
length [() | TySynonym _ _ _ _ <- decls])
isDataDecl, isSynDecl, isClassDecl :: TyClDecl name pat -> Bool
isSynDecl (TySynonym _ _ _ _) = True
isSynDecl other = False
-isDataDecl (TyData _ _ _ _ _ _ _ _) = True
-isDataDecl other = False
+isDataDecl (TyData _ _ _ _ _ _ _ _ _) = True
+isDataDecl other = False
isClassDecl (ClassDecl _ _ _ _ _ _ _ _ _ _ _ _) = True
isClassDecl other = False
=> Outputable (TyClDecl name pat) where
ppr (TySynonym tycon tyvars mono_ty src_loc)
- = hang (pp_decl_head SLIT("type") empty tycon tyvars)
+ = hang (ptext SLIT("type") <+> pp_decl_head [] tycon tyvars <+> equals)
4 (ppr mono_ty)
- ppr (TyData new_or_data context tycon tyvars condecls derivings pragmas src_loc)
+ ppr (TyData new_or_data context tycon tyvars condecls ncons derivings pragmas src_loc)
= pp_tydecl
- (pp_decl_head keyword (pprHsContext context) tycon tyvars)
- (pp_condecls condecls)
+ (ptext keyword <+> pp_decl_head context tycon tyvars <+> equals)
+ (pp_condecls condecls ncons)
derivings
where
keyword = case new_or_data of
| otherwise -- Laid out
= sep [hsep [top_matter, ptext SLIT("where {")],
- nest 4 (vcat [sep (map ppr_sig sigs),
- ppr methods,
- char '}'])]
+ nest 4 (sep [sep (map ppr_sig sigs), pp_methods, char '}'])]
where
- top_matter = hsep [ptext SLIT("class"), pprHsContext context,
- ppr clas, hsep (map (ppr) tyvars), pprFundeps fds]
+ top_matter = ptext SLIT("class") <+> pp_decl_head context clas tyvars <+> pprFundeps fds
ppr_sig sig = ppr sig <> semi
+ pp_methods = getPprStyle $ \ sty ->
+ if ifaceStyle sty then empty else ppr methods
+
+pp_decl_head :: Outputable name => HsContext name -> name -> [HsTyVarBndr name] -> SDoc
+pp_decl_head context thing tyvars = hsep [pprHsContext context, ppr thing, interppSP tyvars]
-pp_decl_head str pp_context tycon tyvars
- = hsep [ptext str, pp_context, ppr tycon,
- interppSP tyvars, ptext SLIT("=")]
-
-pp_condecls [] = empty -- Curious!
-pp_condecls (c:cs) = sep (ppr c : map (\ c -> ptext SLIT("|") <+> ppr c) cs)
+pp_condecls [] ncons = ptext SLIT("{- abstract with") <+> int ncons <+> ptext SLIT("constructors -}")
+pp_condecls (c:cs) ncons = sep (ppr c : map (\ c -> ptext SLIT("|") <+> ppr c) cs)
pp_tydecl pp_head pp_decl_rhs derivings
= hang pp_head 4 (sep [
name -- Name of the constructor's 'worker Id'
-- Filled in as the ConDecl is built
- [HsTyVar name] -- Existentially quantified type variables
+ [HsTyVarBndr name] -- Existentially quantified type variables
(HsContext name) -- ...and context
-- If both are empty then there are no existentials
= Banged (HsType name) -- HsType: to allow Haskell extensions
| Unbanged (HsType name) -- (MonoType only needed for straight Haskell)
| Unpacked (HsType name) -- Field is strict and to be unpacked if poss.
+
+
+eq_ConDecl env (ConDecl n1 _ tvs1 cxt1 cds1 _)
+ (ConDecl n2 _ tvs2 cxt2 cds2 _)
+ = n1 == n2 &&
+ (eqWithHsTyVars tvs1 tvs2 $ \ env ->
+ eq_hsContext env cxt1 cxt2 &&
+ eq_ConDetails env cds1 cds2)
+
+eq_ConDetails env (VanillaCon bts1) (VanillaCon bts2)
+ = eqListBy (eq_btype env) bts1 bts2
+eq_ConDetails env (InfixCon bta1 btb1) (InfixCon bta2 btb2)
+ = eq_btype env bta1 bta2 && eq_btype env btb1 btb2
+eq_ConDetails env (RecCon fs1) (RecCon fs2)
+ = eqListBy (eq_fld env) fs1 fs2
+eq_ConDetails env (NewCon t1 mn1) (NewCon t2 mn2)
+ = eq_hsType env t1 t2 && mn1 == mn2
+eq_ConDetails env _ _ = False
+
+eq_fld env (ns1,bt1) (ns2, bt2) = ns1==ns2 && eq_btype env bt1 bt2
+
+eq_btype env (Banged t1) (Banged t2) = eq_hsType env t1 t2
+eq_btype env (Unbanged t1) (Unbanged t2) = eq_hsType env t1 t2
+eq_btype env (Unpacked t1) (Unpacked t2) = eq_hsType env t1 t2
\end{code}
\begin{code}
instance (Outputable name) => Outputable (ConDecl name) where
ppr (ConDecl con _ tvs cxt con_details loc)
- = sep [pprForAll tvs, pprHsContext cxt, ppr_con_details con con_details]
+ = sep [pprHsForAll tvs cxt, ppr_con_details con con_details]
ppr_con_details con (InfixCon ty1 ty2)
= hsep [ppr_bang ty1, ppr con, ppr_bang ty2]
ppr (InstDecl inst_ty binds uprags dfun_name src_loc)
= getPprStyle $ \ sty ->
- if ifaceStyle sty || (nullMonoBinds binds && null uprags) then
- hsep [ptext SLIT("instance"), ppr inst_ty]
+ if ifaceStyle sty then
+ hsep [ptext SLIT("instance"), ppr inst_ty, equals, ppr dfun_name]
else
vcat [hsep [ptext SLIT("instance"), ppr inst_ty, ptext SLIT("where")],
nest 4 (ppr uprags),
nest 4 (ppr binds) ]
\end{code}
+\begin{code}
+instance Ord name => Eq (InstDecl name pat) where
+ -- Used for interface comparison only, so don't compare bindings
+ (==) (InstDecl inst_ty1 _ _ dfun1 _) (InstDecl inst_ty2 _ _ dfun2 _)
+ = inst_ty1 == inst_ty2 && dfun1 == dfun2
+\end{code}
+
%************************************************************************
%* *
\begin{code}
data RuleDecl name pat
- = RuleDecl
+ = HsRule -- Source rule
FAST_STRING -- Rule name
[name] -- Forall'd tyvars, filled in by the renamer with
-- tyvars mentioned in sigs; then filled out by typechecker
(HsExpr name pat) -- RHS
SrcLoc
- | IfaceRuleDecl -- One that's come in from an interface file
- name
- (UfRuleBody name)
+ | IfaceRule -- One that's come in from an interface file; pre-typecheck
+ FAST_STRING
+ [UfBinder name] -- Tyvars and term vars
+ name -- Head of lhs
+ [UfExpr name] -- Args of LHS
+ (UfExpr name) -- Pre typecheck
SrcLoc
+ | IfaceRuleOut -- Post typecheck
+ name -- Head of LHS
+ CoreRule
+
+
data RuleBndr name
= RuleBndr name
| RuleBndrSig name (HsType name)
+instance Ord name => Eq (RuleDecl name pat) where
+ -- Works for IfaceRules only; used when comparing interface file versions
+ (IfaceRule n1 bs1 f1 es1 rhs1 _) == (IfaceRule n2 bs2 f2 es2 rhs2 _)
+ = n1==n2 && f1 == f2 &&
+ eq_ufBinders emptyEqHsEnv bs1 bs2 (\env ->
+ eqListBy (eq_ufExpr env) (rhs1:es1) (rhs2:es2))
+
instance (Outputable name, Outputable pat)
=> Outputable (RuleDecl name pat) where
- ppr (RuleDecl name tvs ns lhs rhs loc)
+ ppr (HsRule name tvs ns lhs rhs loc)
= sep [text "{-# RULES" <+> doubleQuotes (ptext name),
pp_forall, ppr lhs, equals <+> ppr rhs,
text "#-}" ]
| otherwise = text "forall" <+>
fsep (map ppr tvs ++ map ppr ns)
<> dot
- ppr (IfaceRuleDecl var body loc) = text "An imported rule..."
+
+ ppr (IfaceRule name tpl_vars fn tpl_args rhs loc)
+ = hsep [ doubleQuotes (ptext name),
+ ptext SLIT("__forall") <+> braces (interppSP tpl_vars),
+ ppr fn <+> sep (map (pprUfExpr parens) tpl_args),
+ ptext SLIT("=") <+> ppr rhs
+ ] <+> semi
+
+ ppr (IfaceRuleOut fn rule) = pprCoreRule (ppr fn) rule
instance Outputable name => Outputable (RuleBndr name) where
ppr (RuleBndr name) = ppr name
ppr (RuleBndrSig name ty) = ppr name <> dcolon <> ppr ty
+
+toHsRule id (BuiltinRule _)
+ = pprTrace "toHsRule: builtin" (ppr id) (bogusIfaceRule id)
+
+toHsRule id (Rule name bndrs args rhs)
+ = IfaceRule name (map toUfBndr bndrs) (toRdrName id)
+ (map toUfExpr args) (toUfExpr rhs) noSrcLoc
+
+bogusIfaceRule id
+ = IfaceRule SLIT("bogus") [] (toRdrName id) [] (UfVar (toRdrName id)) noSrcLoc
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection[DeprecDecl]{Deprecations}
+%* *
+%************************************************************************
+
+We use exported entities for things to deprecate. Cunning trick (hack?):
+`IEModuleContents undefined' is used for module deprecation.
+
+\begin{code}
+data DeprecDecl name = Deprecation (IE name) DeprecTxt SrcLoc
+
+type DeprecTxt = FAST_STRING -- reason/explanation for deprecation
+
+instance Outputable name => Outputable (DeprecDecl name) where
+ ppr (Deprecation (IEModuleContents _) txt _)
+ = hsep [text "{-# DEPRECATED", doubleQuotes (ppr txt), text "#-}"]
+ ppr (Deprecation thing txt _)
+ = hsep [text "{-# DEPRECATED", ppr thing, doubleQuotes (ppr txt), text "#-}"]
\end{code}
import Var ( TyVar, Id )
import DataCon ( DataCon )
import CStrings ( CLabelString, pprCLabelString )
+import BasicTypes ( Boxity, tupleParens )
import SrcLoc ( SrcLoc )
\end{code}
-- NB: Unit is ExplicitTuple []
-- for tuples, we can get the types
-- direct from the components
- Bool -- boxed?
+ Boxity
-- Record construction
= hcat [ brackets (fsep (punctuate comma (map ppr_expr exprs))),
ifNotPprForUser ((<>) space (parens (pprType ty))) ]
-ppr_expr (ExplicitTuple exprs True)
- = parens (sep (punctuate comma (map ppr_expr exprs)))
-
-ppr_expr (ExplicitTuple exprs False)
- = ptext SLIT("(#") <> sep (punctuate comma (map ppr_expr exprs)) <> ptext SLIT("#)")
+ppr_expr (ExplicitTuple exprs boxity)
+ = tupleParens boxity (sep (punctuate comma (map ppr_expr exprs)))
ppr_expr (RecordCon con_id rbinds)
= pp_rbinds (ppr con_id) rbinds
ieName (IEThingAbs n) = n
ieName (IEThingWith n _) = n
ieName (IEThingAll n) = n
+
+ieNames :: IE a -> [a]
+ieNames (IEVar n ) = [n]
+ieNames (IEThingAbs n ) = [n]
+ieNames (IEThingAll n ) = [n]
+ieNames (IEThingWith n ns) = n:ns
+ieNames (IEModuleContents _ ) = []
\end{code}
\begin{code}
-- Friends
import HsExpr ( HsExpr, Stmt(..) )
import HsBinds ( HsBinds(..), nullBinds )
-import HsTypes ( HsTyVar, HsType )
+import HsTypes ( HsTyVarBndr, HsType )
-- Others
import Type ( Type )
\begin{code}
data Match id pat
= Match
- [HsTyVar id] -- Tyvars wrt which this match is universally quantified
+ [HsTyVarBndr id] -- Tyvars wrt which this match is universally quantified
-- emtpy after typechecking
[pat] -- The patterns
(Maybe (HsType id)) -- A type signature for the result of the match
import HsBasic ( HsLit )
import HsExpr ( HsExpr )
import HsTypes ( HsType )
-import BasicTypes ( Fixity )
+import BasicTypes ( Fixity, Boxity, tupleParens )
-- others:
import Var ( Id, TyVar )
| ListPatIn [InPat name] -- syntactic list
-- must have >= 1 elements
- | TuplePatIn [InPat name] Bool -- tuple (boxed?)
+ | TuplePatIn [InPat name] Boxity -- tuple (boxed?)
| RecPatIn name -- record
[(name, InPat name, Bool)] -- True <=> source used punning
[OutPat id]
| TuplePat [OutPat id] -- tuple
- Bool -- boxed?
+ Boxity
-- UnitPat is TuplePat []
| ConPat DataCon
pprInPat (ListPatIn pats)
= brackets (interpp'SP pats)
-pprInPat (TuplePatIn pats False)
- = text "(#" <> (interpp'SP pats) <> text "#)"
-pprInPat (TuplePatIn pats True)
- = parens (interpp'SP pats)
+pprInPat (TuplePatIn pats boxity)
+ = tupleParens boxity (interpp'SP pats)
pprInPat (NPlusKPatIn n k)
= parens (hcat [ppr n, char '+', ppr k])
hsep [ppr p1, ppr name, ppr p2]
_ -> hsep [ppr name, interppSP tyvars, interppSP dicts, interppSP pats]
-pprOutPat (ListPat ty pats)
- = brackets (interpp'SP pats)
-pprOutPat (TuplePat pats boxed@True)
- = parens (interpp'SP pats)
-pprOutPat (TuplePat pats unboxed@False)
- = text "(#" <> (interpp'SP pats) <> text "#)"
+pprOutPat (ListPat ty pats) = brackets (interpp'SP pats)
+pprOutPat (TuplePat pats boxity) = tupleParens boxity (interpp'SP pats)
pprOutPat (RecPat con ty tvs dicts rpats)
= hsep [ppr con, interppSP tvs, interppSP dicts, braces (hsep (punctuate comma (map (pp_rpat) rpats)))]
\begin{code}
module HsTypes (
- HsType(..), MonoUsageAnn(..), HsTyVar(..),
- HsContext, HsClassAssertion, HsPred(..)
+ HsType(..), HsUsageAnn(..), HsTyVarBndr(..),
+ , HsContext, HsPred(..)
+ , HsTupCon(..), hsTupParens, mkHsTupCon,
- , mkHsForAllTy, mkHsUsForAllTy
+ , mkHsForAllTy, mkHsUsForAllTy, mkHsDictTy, mkHsIParamTy
, getTyVarName, replaceTyVarName
- , pprParendHsType
- , pprForAll, pprHsContext, pprHsClassAssertion, pprHsPred
- , cmpHsType, cmpHsTypes, cmpHsContext, cmpHsPred
+
+ -- Printing
+ , pprParendHsType, pprHsForAll, pprHsContext, pprHsTyVarBndr
+
+ -- Equality over Hs things
+ , EqHsEnv, emptyEqHsEnv, extendEqHsEnv,
+ , eqWithHsTyVars, eq_hsVar, eq_hsVars, eq_hsType, eq_hsContext, eqListBy
+
+ -- Converting from Type to HsType
+ , toHsType, toHsTyVar, toHsTyVars, toHsContext, toHsFDs
) where
#include "HsVersions.h"
-import Type ( Kind, UsageAnn(..) )
-import PprType ( {- instance Outputable Kind -} )
+import Class ( FunDep )
+import Type ( Type, Kind, PredType(..), UsageAnn(..), ClassContext,
+ getTyVar_maybe, splitFunTy_maybe, splitAppTy_maybe,
+ splitTyConApp_maybe, splitPredTy_maybe,
+ splitUsgTy, splitSigmaTy, unUsgTy, boxedTypeKind
+ )
+import TypeRep ( Type(..), TyNote(..) ) -- toHsType sees the representation
+import TyCon ( isTupleTyCon, tupleTyConBoxity, tyConArity, tyConClass_maybe )
+import PrelInfo ( mkTupConRdrName )
+import RdrName ( RdrName )
+import Name ( toRdrName )
+import OccName ( NameSpace )
+import Var ( TyVar, tyVarKind )
+import PprType ( {- instance Outputable Kind -}, pprParendKind )
+import BasicTypes ( Arity, Boxity(..), tupleParens )
+import Unique ( hasKey, listTyConKey, Uniquable(..) )
+import Maybes ( maybeToBool )
+import FiniteMap
import Outputable
-import Util ( thenCmp, cmpList )
\end{code}
This is the syntax for types as seen in type signatures.
\begin{code}
type HsContext name = [HsPred name]
-type HsClassAssertion name = (name, [HsType name])
--- The type is usually a type variable, but it
--- doesn't have to be when reading interface files
-data HsPred name =
- HsPClass name [HsType name]
- | HsPIParam name (HsType name)
+
+data HsPred name = HsPClass name [HsType name]
+ | HsPIParam name (HsType name)
data HsType name
- = HsForAllTy (Maybe [HsTyVar name]) -- Nothing for implicitly quantified signatures
- (HsContext name)
- (HsType name)
+ = HsForAllTy (Maybe [HsTyVarBndr name]) -- Nothing for implicitly quantified signatures
+ (HsContext name)
+ (HsType name)
- | MonoTyVar name -- Type variable
+ | HsTyVar name -- Type variable
- | MonoTyApp (HsType name)
+ | HsAppTy (HsType name)
(HsType name)
- | MonoFunTy (HsType name) -- function type
+ | HsFunTy (HsType name) -- function type
(HsType name)
- | MonoListTy (HsType name) -- Element type
-
- | MonoTupleTy [HsType name] -- Element types (length gives arity)
- Bool -- boxed?
+ | HsListTy (HsType name) -- Element type
- | MonoIParamTy name (HsType name)
+ | HsTupleTy (HsTupCon name)
+ [HsType name] -- Element types (length gives arity)
-- these next two are only used in interfaces
- | MonoDictTy name -- Class
- [HsType name]
+ | HsPredTy (HsPred name)
- | MonoUsgTy (MonoUsageAnn name)
+ | HsUsgTy (HsUsageAnn name)
(HsType name)
- | MonoUsgForAllTy name
+ | HsUsgForAllTy name
(HsType name)
-data MonoUsageAnn name
- = MonoUsOnce
- | MonoUsMany
- | MonoUsVar name
+data HsUsageAnn name
+ = HsUsOnce
+ | HsUsMany
+ | HsUsVar name
+-----------------------
+data HsTupCon name = HsTupCon name Boxity
+
+instance Eq name => Eq (HsTupCon name) where
+ (HsTupCon _ b1) == (HsTupCon _ b2) = b1==b2
+
+mkHsTupCon :: NameSpace -> Boxity -> [a] -> HsTupCon RdrName
+mkHsTupCon space boxity args = HsTupCon (mkTupConRdrName space boxity (length args)) boxity
+
+hsTupParens :: HsTupCon name -> SDoc -> SDoc
+hsTupParens (HsTupCon _ b) p = tupleParens b p
+
+-----------------------
-- Combine adjacent for-alls.
-- The following awkward situation can happen otherwise:
-- f :: forall a. ((Num a) => Int)
(Just tvs1) `plus` (Just tvs2) = Just (tvs1 ++ tvs2)
mkHsForAllTy tvs ctxt ty = HsForAllTy tvs ctxt ty
-mkHsUsForAllTy uvs ty = foldr (\ uv ty -> MonoUsgForAllTy uv ty)
+mkHsUsForAllTy uvs ty = foldr (\ uv ty -> HsUsgForAllTy uv ty)
ty uvs
-data HsTyVar name
+mkHsDictTy cls tys = HsPredTy (HsPClass cls tys)
+mkHsIParamTy v ty = HsPredTy (HsPIParam v ty)
+
+data HsTyVarBndr name
= UserTyVar name
| IfaceTyVar name Kind
-- *** NOTA BENE *** A "monotype" in a pragma can have
getTyVarName (UserTyVar n) = n
getTyVarName (IfaceTyVar n _) = n
-replaceTyVarName :: HsTyVar name1 -> name2 -> HsTyVar name2
+replaceTyVarName :: HsTyVarBndr name1 -> name2 -> HsTyVarBndr name2
replaceTyVarName (UserTyVar n) n' = UserTyVar n'
replaceTyVarName (IfaceTyVar n k) n' = IfaceTyVar n' k
\end{code}
%************************************************************************
\begin{code}
-
instance (Outputable name) => Outputable (HsType name) where
ppr ty = pprHsType ty
-instance (Outputable name) => Outputable (HsTyVar name) where
+instance (Outputable name) => Outputable (HsTyVarBndr name) where
ppr (UserTyVar name) = ppr name
- ppr (IfaceTyVar name kind) = hsep [ppr name, dcolon, ppr kind]
+ ppr (IfaceTyVar name kind) = pprHsTyVarBndr name kind
+
+instance Outputable name => Outputable (HsPred name) where
+ ppr (HsPClass clas tys) = ppr clas <+> hsep (map pprParendHsType tys)
+ ppr (HsPIParam n ty) = hsep [{- char '?' <> -} ppr n, text "::", ppr ty]
--- Better to see those for-alls
--- pprForAll [] = empty
-pprForAll tvs = ptext SLIT("forall") <+> interppSP tvs <> ptext SLIT(".")
+pprHsTyVarBndr :: Outputable name => name -> Kind -> SDoc
+pprHsTyVarBndr name kind | kind == boxedTypeKind = ppr name
+ | otherwise = hsep [ppr name, dcolon, pprParendKind kind]
+
+pprHsForAll [] [] = empty
+pprHsForAll tvs cxt = ptext SLIT("__forall") <+> interppSP tvs <+> ppr_context cxt <+> ptext SLIT("=>")
pprHsContext :: (Outputable name) => HsContext name -> SDoc
-pprHsContext [] = empty
-pprHsContext context = parens (hsep (punctuate comma (map pprHsPred context))) <+> ptext SLIT("=>")
-
-pprHsClassAssertion :: (Outputable name) => HsClassAssertion name -> SDoc
-pprHsClassAssertion (clas, tys)
- = ppr clas <+> hsep (map pprParendHsType tys)
-
-pprHsPred :: (Outputable name) => HsPred name -> SDoc
-pprHsPred (HsPClass clas tys)
- = ppr clas <+> hsep (map pprParendHsType tys)
-pprHsPred (HsPIParam n ty)
- = hsep [{- char '?' <> -} ppr n, text "::", ppr ty]
+pprHsContext [] = empty
+pprHsContext cxt = ppr_context cxt <+> ptext SLIT("=>")
+
+ppr_context [] = empty
+ppr_context cxt = parens (interpp'SP cxt)
\end{code}
\begin{code}
ppr_mono_ty ctxt_prec (HsForAllTy maybe_tvs ctxt ty)
= maybeParen (ctxt_prec >= pREC_FUN) $
- sep [pp_tvs, pprHsContext ctxt, pprHsType ty]
+ sep [pp_header, pprHsType ty]
where
- pp_tvs = case maybe_tvs of
- Just tvs -> pprForAll tvs
- Nothing -> text "{- implicit forall -}"
+ pp_header = case maybe_tvs of
+ Just tvs -> pprHsForAll tvs ctxt
+ Nothing -> pprHsContext ctxt
-ppr_mono_ty ctxt_prec (MonoTyVar name)
+ppr_mono_ty ctxt_prec (HsTyVar name)
= ppr name
-ppr_mono_ty ctxt_prec (MonoFunTy ty1 ty2)
+ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2)
= let p1 = ppr_mono_ty pREC_FUN ty1
p2 = ppr_mono_ty pREC_TOP ty2
in
maybeParen (ctxt_prec >= pREC_FUN)
(sep [p1, (<>) (ptext SLIT("-> ")) p2])
-ppr_mono_ty ctxt_prec (MonoTupleTy tys True)
- = parens (sep (punctuate comma (map ppr tys)))
-ppr_mono_ty ctxt_prec (MonoTupleTy tys False)
- = ptext SLIT("(#") <> sep (punctuate comma (map ppr tys)) <> ptext SLIT("#)")
+ppr_mono_ty ctxt_prec (HsTupleTy con tys) = hsTupParens con (interpp'SP tys)
+ppr_mono_ty ctxt_prec (HsListTy ty) = brackets (ppr_mono_ty pREC_TOP ty)
-ppr_mono_ty ctxt_prec (MonoListTy ty)
- = brackets (ppr_mono_ty pREC_TOP ty)
-
-ppr_mono_ty ctxt_prec (MonoTyApp fun_ty arg_ty)
+ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty)
= maybeParen (ctxt_prec >= pREC_CON)
(hsep [ppr_mono_ty pREC_FUN fun_ty, ppr_mono_ty pREC_CON arg_ty])
-ppr_mono_ty ctxt_prec (MonoIParamTy n ty)
- = hsep [{- char '?' <> -} ppr n, text "::", ppr_mono_ty pREC_TOP ty]
-
-ppr_mono_ty ctxt_prec (MonoDictTy clas tys)
- = ppr clas <+> hsep (map (ppr_mono_ty pREC_CON) tys)
-
-ppr_mono_ty ctxt_prec ty@(MonoUsgForAllTy _ _)
+ppr_mono_ty ctxt_prec (HsPredTy pred)
= maybeParen (ctxt_prec >= pREC_FUN) $
+ braces (ppr pred)
+
+ppr_mono_ty ctxt_prec ty@(HsUsgForAllTy _ _)
+ =
sep [ ptext SLIT("__fuall") <+> brackets pp_uvars <+> ptext SLIT("=>"),
ppr_mono_ty pREC_TOP sigma
]
(uvars,sigma) = split [] ty
pp_uvars = interppSP uvars
- split uvs (MonoUsgForAllTy uv ty') = split (uv:uvs) ty'
+ split uvs (HsUsgForAllTy uv ty') = split (uv:uvs) ty'
split uvs ty' = (reverse uvs,ty')
-ppr_mono_ty ctxt_prec (MonoUsgTy u ty)
+ppr_mono_ty ctxt_prec (HsUsgTy u ty)
= maybeParen (ctxt_prec >= pREC_CON) $
ptext SLIT("__u") <+> pp_ua <+> ppr_mono_ty pREC_CON ty
where
pp_ua = case u of
- MonoUsOnce -> ptext SLIT("-")
- MonoUsMany -> ptext SLIT("!")
- MonoUsVar uv -> ppr uv
+ HsUsOnce -> ptext SLIT("-")
+ HsUsMany -> ptext SLIT("!")
+ HsUsVar uv -> ppr uv
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Converting from Type to HsType}
+%* *
+%************************************************************************
+
+@toHsType@ converts from a Type to a HsType, making the latter look as
+user-friendly as possible. Notably, it uses synonyms where possible, and
+expresses overloaded functions using the '=>' context part of a HsForAllTy.
+
+\begin{code}
+toHsTyVar :: TyVar -> HsTyVarBndr RdrName
+toHsTyVar tv = IfaceTyVar (toRdrName tv) (tyVarKind tv)
+
+toHsTyVars tvs = map toHsTyVar tvs
+
+toHsType :: Type -> HsType RdrName
+toHsType ty = toHsType' (unUsgTy ty)
+ -- For now we just discard the usage
+-- = case splitUsgTy ty of
+-- (usg, tau) -> HsUsgTy (toHsUsg usg) (toHsType' tau)
+
+toHsType' :: Type -> HsType RdrName
+-- Called after the usage is stripped off
+-- This function knows the representation of types
+toHsType' (TyVarTy tv) = HsTyVar (toRdrName tv)
+toHsType' (FunTy arg res) = HsFunTy (toHsType arg) (toHsType res)
+toHsType' (AppTy fun arg) = HsAppTy (toHsType fun) (toHsType arg)
+
+toHsType' (NoteTy (SynNote ty) _) = toHsType ty -- Use synonyms if possible!!
+toHsType' (NoteTy _ ty) = toHsType ty
+
+toHsType' ty@(TyConApp tc tys) -- Must be saturated because toHsType's arg is of kind *
+ | not saturated = generic_case
+ | isTupleTyCon tc = HsTupleTy (HsTupCon (toRdrName tc) (tupleTyConBoxity tc)) tys'
+ | tc `hasKey` listTyConKey = HsListTy (head tys')
+ | maybeToBool maybe_class = HsPredTy (HsPClass (toRdrName clas) tys')
+ | otherwise = generic_case
+ where
+ generic_case = foldl HsAppTy (HsTyVar (toRdrName tc)) tys'
+ maybe_class = tyConClass_maybe tc
+ Just clas = maybe_class
+ tys' = map toHsType tys
+ saturated = length tys == tyConArity tc
+
+toHsType' ty@(ForAllTy _ _) = case splitSigmaTy ty of
+ (tvs, preds, tau) -> HsForAllTy (Just (map toHsTyVar tvs))
+ (map toHsPred preds)
+ (toHsType tau)
+
+
+toHsPred (Class cls tys) = HsPClass (toRdrName cls) (map toHsType tys)
+toHsPred (IParam n ty) = HsPIParam (toRdrName n) (toHsType ty)
+
+toHsContext :: ClassContext -> HsContext RdrName
+toHsContext cxt = [HsPClass (toRdrName cls) (map toHsType tys) | (cls,tys) <- cxt]
+
+toHsUsg UsOnce = HsUsOnce
+toHsUsg UsMany = HsUsMany
+toHsUsg (UsVar v) = HsUsVar (toRdrName v)
+
+toHsFDs :: [FunDep TyVar] -> [FunDep RdrName]
+toHsFDs fds = [(map toRdrName ns, map toRdrName ms) | (ns,ms) <- fds]
\end{code}
%* *
%************************************************************************
+\begin{code}
+instance Ord a => Eq (HsType a) where
+ -- The Ord is needed because we keep a
+ -- finite map of variables to variables
+ (==) a b = eq_hsType emptyEqHsEnv a b
+
+instance Ord a => Eq (HsPred a) where
+ (==) a b = eq_hsPred emptyEqHsEnv a b
+
+eqWithHsTyVars :: Ord name =>
+ [HsTyVarBndr name] -> [HsTyVarBndr name]
+ -> (EqHsEnv name -> Bool) -> Bool
+eqWithHsTyVars = eq_hsTyVars emptyEqHsEnv
+\end{code}
+
+\begin{code}
+type EqHsEnv n = FiniteMap n n
+-- Tracks the mapping from L-variables to R-variables
+
+eq_hsVar :: Ord n => EqHsEnv n -> n -> n -> Bool
+eq_hsVar env n1 n2 = case lookupFM env n1 of
+ Just n1 -> n1 == n2
+ Nothing -> n1 == n2
+
+extendEqHsEnv env n1 n2
+ | n1 == n2 = env
+ | otherwise = addToFM env n1 n2
+
+emptyEqHsEnv :: EqHsEnv n
+emptyEqHsEnv = emptyFM
+\end{code}
+
We do define a specialised equality for these \tr{*Type} types; used
-in checking interfaces. Most any other use is likely to be {\em
-wrong}, so be careful!
+in checking interfaces.
\begin{code}
-cmpHsTyVar :: (a -> a -> Ordering) -> HsTyVar a -> HsTyVar a -> Ordering
-cmpHsType :: (a -> a -> Ordering) -> HsType a -> HsType a -> Ordering
-cmpHsTypes :: (a -> a -> Ordering) -> [HsType a] -> [HsType a] -> Ordering
-cmpHsContext :: (a -> a -> Ordering) -> HsContext a -> HsContext a -> Ordering
-cmpHsPred :: (a -> a -> Ordering) -> HsPred a -> HsPred a -> Ordering
+-------------------
+eq_hsTyVars env [] [] k = k env
+eq_hsTyVars env (tv1:tvs1) (tv2:tvs2) k = eq_hsTyVar env tv1 tv2 $ \ env ->
+ eq_hsTyVars env tvs1 tvs2 k
+eq_hsTyVars env _ _ _ = False
+
+eq_hsTyVar env (UserTyVar v1) (UserTyVar v2) k = k (extendEqHsEnv env v1 v2)
+eq_hsTyVar env (IfaceTyVar v1 k1) (IfaceTyVar v2 k2) k = k1 == k2 && k (extendEqHsEnv env v1 v2)
+eq_hsTyVar env _ _ _ = False
+
+eq_hsVars env [] [] k = k env
+eq_hsVars env (v1:bs1) (v2:bs2) k = eq_hsVars (extendEqHsEnv env v1 v2) bs1 bs2 k
+eq_hsVars env _ _ _ = False
+\end{code}
-cmpHsTyVar cmp (UserTyVar v1) (UserTyVar v2) = v1 `cmp` v2
-cmpHsTyVar cmp (IfaceTyVar v1 _) (IfaceTyVar v2 _) = v1 `cmp` v2
-cmpHsTyVar cmp (UserTyVar _) other = LT
-cmpHsTyVar cmp other1 other2 = GT
+\begin{code}
+-------------------
+eq_hsTypes env = eqListBy (eq_hsType env)
-cmpHsTypes cmp [] [] = EQ
-cmpHsTypes cmp [] tys2 = LT
-cmpHsTypes cmp tys1 [] = GT
-cmpHsTypes cmp (ty1:tys1) (ty2:tys2) = cmpHsType cmp ty1 ty2 `thenCmp` cmpHsTypes cmp tys1 tys2
+-------------------
+eq_hsType env (HsForAllTy tvs1 c1 t1) (HsForAllTy tvs2 c2 t2)
+ = eq_tvs tvs1 tvs2 $ \env ->
+ eq_hsContext env c1 c2 &&
+ eq_hsType env t1 t2
+ where
+ eq_tvs Nothing (Just _) k = False
+ eq_tvs Nothing Nothing k = k env
+ eq_tvs (Just _) Nothing k = False
+ eq_tvs (Just tvs1) (Just tvs2) k = eq_hsTyVars env tvs1 tvs2 k
-cmpHsType cmp (HsForAllTy tvs1 c1 t1) (HsForAllTy tvs2 c2 t2)
- = cmpMaybe (cmpList (cmpHsTyVar cmp)) tvs1 tvs2 `thenCmp`
- cmpHsContext cmp c1 c2 `thenCmp`
- cmpHsType cmp t1 t2
+eq_hsType env (HsTyVar n1) (HsTyVar n2)
+ = eq_hsVar env n1 n2
-cmpHsType cmp (MonoTyVar n1) (MonoTyVar n2)
- = cmp n1 n2
+eq_hsType env (HsTupleTy c1 tys1) (HsTupleTy c2 tys2)
+ = (c1 == c2) && eq_hsTypes env tys1 tys2
-cmpHsType cmp (MonoTupleTy tys1 b1) (MonoTupleTy tys2 b2)
- = (b1 `compare` b2) `thenCmp` cmpHsTypes cmp tys1 tys2
+eq_hsType env (HsListTy ty1) (HsListTy ty2)
+ = eq_hsType env ty1 ty2
-cmpHsType cmp (MonoListTy ty1) (MonoListTy ty2)
- = cmpHsType cmp ty1 ty2
+eq_hsType env (HsAppTy fun_ty1 arg_ty1) (HsAppTy fun_ty2 arg_ty2)
+ = eq_hsType env fun_ty1 fun_ty2 && eq_hsType env arg_ty1 arg_ty2
-cmpHsType cmp (MonoTyApp fun_ty1 arg_ty1) (MonoTyApp fun_ty2 arg_ty2)
- = cmpHsType cmp fun_ty1 fun_ty2 `thenCmp` cmpHsType cmp arg_ty1 arg_ty2
+eq_hsType env (HsFunTy a1 b1) (HsFunTy a2 b2)
+ = eq_hsType env a1 a2 && eq_hsType env b1 b2
-cmpHsType cmp (MonoFunTy a1 b1) (MonoFunTy a2 b2)
- = cmpHsType cmp a1 a2 `thenCmp` cmpHsType cmp b1 b2
+eq_hsType env (HsPredTy p1) (HsPredTy p2)
+ = eq_hsPred env p1 p2
-cmpHsType cmp (MonoDictTy c1 tys1) (MonoDictTy c2 tys2)
- = cmp c1 c2 `thenCmp` cmpHsTypes cmp tys1 tys2
+eq_hsType env (HsUsgTy u1 ty1) (HsUsgTy u2 ty2)
+ = eqUsg u1 u2 && eq_hsType env ty1 ty2
-cmpHsType cmp (MonoUsgTy u1 ty1) (MonoUsgTy u2 ty2)
- = cmpUsg cmp u1 u2 `thenCmp` cmpHsType cmp ty1 ty2
+eq_hsType env ty1 ty2 = False
-cmpHsType cmp ty1 ty2 -- tags must be different
- = let tag1 = tag ty1
- tag2 = tag ty2
- in
- if tag1 _LT_ tag2 then LT else GT
- where
- tag (MonoTyVar n1) = (ILIT(1) :: FAST_INT)
- tag (MonoTupleTy tys1 _) = ILIT(2)
- tag (MonoListTy ty1) = ILIT(3)
- tag (MonoTyApp tc1 tys1) = ILIT(4)
- tag (MonoFunTy a1 b1) = ILIT(5)
- tag (MonoDictTy c1 tys1) = ILIT(6)
- tag (MonoUsgTy c1 ty1) = ILIT(7)
- tag (MonoUsgForAllTy uv1 ty1) = ILIT(8)
- tag (HsForAllTy _ _ _) = ILIT(9)
-------------------
-cmpHsContext cmp a b
- = cmpList (cmpHsPred cmp) a b
-
-cmpHsPred cmp (HsPClass c1 tys1) (HsPClass c2 tys2)
- = cmp c1 c2 `thenCmp` cmpHsTypes cmp tys1 tys2
-cmpHsPred cmp (HsPIParam n1 ty1) (HsPIParam n2 ty2)
- = cmp n1 n2 `thenCmp` cmpHsType cmp ty1 ty2
-cmpHsPred cmp (HsPClass _ _) (HsPIParam _ _) = LT
-cmpHsPred cmp _ _ = GT
-
-cmpUsg cmp MonoUsOnce MonoUsOnce = EQ
-cmpUsg cmp MonoUsMany MonoUsMany = EQ
-cmpUsg cmp (MonoUsVar u1) (MonoUsVar u2) = cmp u1 u2
-
-cmpUsg cmp ua1 ua2 -- tags must be different
- = let tag1 = tag ua1
- tag2 = tag ua2
- in
- if tag1 _LT_ tag2 then LT else GT
- where
- tag MonoUsOnce = (ILIT(1) :: FAST_INT)
- tag MonoUsMany = ILIT(2)
- tag (MonoUsVar _) = ILIT(3)
-
--- Should be in Maybes, I guess
-cmpMaybe cmp Nothing Nothing = EQ
-cmpMaybe cmp Nothing (Just x) = LT
-cmpMaybe cmp (Just x) Nothing = GT
-cmpMaybe cmp (Just x) (Just y) = x `cmp` y
+eq_hsContext env a b = eqListBy (eq_hsPred env) a b
+
+-------------------
+eq_hsPred env (HsPClass c1 tys1) (HsPClass c2 tys2)
+ = c1 == c2 && eq_hsTypes env tys1 tys2
+eq_hsPred env (HsPIParam n1 ty1) (HsPIParam n2 ty2)
+ = n1 == n2 && eq_hsType env ty1 ty2
+eq_hsPred env _ _ = False
+
+-------------------
+eqUsg HsUsOnce HsUsOnce = True
+eqUsg HsUsMany HsUsMany = True
+eqUsg (HsUsVar u1) (HsUsVar u2) = u1 == u2
+eqUsg _ _ = False
+
+-------------------
+eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool
+eqListBy eq [] [] = True
+eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys
+eqListBy eq xs ys = False
\end{code}
opt_ProduceExportCStubs,
opt_ProduceExportHStubs,
opt_ProduceHi,
+ opt_NoPruneTyDecls,
opt_NoPruneDecls,
opt_ReportCompile,
opt_SourceUnchanged,
opt_ReportCompile = lookUp SLIT("-freport-compile")
opt_NoPruneDecls = lookUp SLIT("-fno-prune-decls")
+opt_NoPruneTyDecls = lookUp SLIT("-fno-prune-tydecls")
opt_SourceUnchanged = lookUp SLIT("-fsource-unchanged")
opt_Static = lookUp SLIT("-static")
opt_Unregisterised = lookUp SLIT("-funregisterised")
import Maybes ( maybeToBool )
import ErrUtils ( doIfSet, dumpIfSet )
import Outputable
-import IO
+import IO ( IOMode(..), hClose, openFile )
\end{code}
#else /* OMIT_NATIVE_CODEGEN */
- = do hPutStrLn stderr "This compiler was built without a native code generator"
- hPutStrLn stderr "Use -fvia-C instead"
+ = pprPanic "This compiler was built without a native code generator"
+ (text "Use -fvia-C instead")
#endif
\end{code}
iNT64_SIZE = (INT64_SIZE :: Int)
\end{code}
-The version of the interface file format we're
-using:
+The version of the interface file format we're using. It's propagated
+here by a devious route from ghc/mk/version.mk. See comments
+there for what it means.
\begin{code}
interfaceFileFormatVersion :: Int
import SrcLoc ( mkSrcLoc )
import Rename ( renameModule )
-import RnMonad ( InterfaceDetails(..) )
-import MkIface ( startIface, ifaceDecls, endIface )
+import MkIface ( writeIface )
import TcModule ( TcResults(..), typecheckModule )
import Desugar ( deSugar )
import SimplCore ( core2core )
reportCompile mod_name "Compilation NOT required!" >>
return ();
- Just (this_mod, rn_mod, iface_file_stuff@(InterfaceDetails _ _ _ deprecations),
- rn_name_supply, imported_modules) ->
+ Just (this_mod, rn_mod,
+ old_iface, new_iface,
+ rn_name_supply, fixity_env,
+ imported_modules) ->
-- Oh well, we've got to recompile for real
- -------------------------- Start interface file ----------------
- -- Safely past renaming: we can start the interface file:
- -- (the iface file is produced incrementally, as we have
- -- the information that we need...; we use "iface<blah>")
- -- "endIface" finishes the job.
- startIface this_mod iface_file_stuff >>= \ if_handle ->
-
-
-------------------------- Typechecking ----------------
show_pass "TypeCheck" >>
_scc_ "TypeCheck"
typecheckModule tc_uniqs rn_name_supply
- iface_file_stuff rn_mod >>= \ maybe_tc_stuff ->
+ fixity_env rn_mod >>= \ maybe_tc_stuff ->
case maybe_tc_stuff of {
Nothing -> ghcExit 1; -- Type checker failed
tidyCorePgm tidy_uniqs this_mod
simplified orphan_rules >>= \ (tidy_binds, tidy_orphan_rules) ->
+ coreBindsSize tidy_binds `seq`
+-- TEMP: the above call zaps some space usage allocated by the
+-- simplifier, which for reasons I don't understand, persists
+-- thoroughout code generation
+
+
-------------------------- Convert to STG code -------------------------------
show_pass "Core2Stg" >>
let
final_ids = collectFinalStgBinders (map fst stg_binds2)
in
- coreBindsSize tidy_binds `seq`
--- TEMP: the above call zaps some space usage allocated by the
--- simplifier, which for reasons I don't understand, persists
--- thoroughout code generation
-
- ifaceDecls if_handle local_tycons local_classes inst_info
- final_ids tidy_binds tidy_orphan_rules deprecations >>
- endIface if_handle >>
- -- We are definitely done w/ interface-file stuff at this point:
- -- (See comments near call to "startIface".)
+ writeIface this_mod old_iface new_iface
+ local_tycons local_classes inst_info
+ final_ids tidy_binds tidy_orphan_rules >>
-------------------------- Code generation -------------------------------
spec_info (Just (False, _)) = (0,0,0,0,1,0)
spec_info (Just (True, _)) = (0,0,0,0,0,1)
- data_info (TyData _ _ _ _ constrs derivs _ _)
- = (length constrs, case derivs of {Nothing -> 0; Just ds -> length ds})
+ data_info (TyData _ _ _ _ _ nconstrs derivs _ _)
+ = (nconstrs, case derivs of {Nothing -> 0; Just ds -> length ds})
data_info other = (0,0)
class_info (ClassDecl _ _ _ _ meth_sigs def_meths _ _ _ _ _ _)
\section[MkIface]{Print an interface for a module}
\begin{code}
-module MkIface (
- startIface, endIface, ifaceDecls
- ) where
+module MkIface ( writeIface ) where
#include "HsVersions.h"
hClose, hPutStrLn, IOMode(..) )
import HsSyn
-import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..),
- OccInfo, isLoopBreaker
+import HsCore ( HsIdInfo(..), toUfExpr )
+import RdrHsSyn ( RdrNameRuleDecl )
+import HsPragmas ( DataPragmas(..), ClassPragmas(..) )
+import HsTypes ( toHsTyVars )
+import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..),
+ Version, bumpVersion, initialVersion, isLoopBreaker
)
import RnMonad
import RnEnv ( availName )
import Var ( isId )
import VarSet
import DataCon ( StrictnessMark(..), dataConSig, dataConFieldLabels, dataConStrictMarks )
-import IdInfo ( IdInfo, StrictnessInfo(..), ArityInfo, InlinePragInfo(..), inlinePragInfo,
- arityInfo, ppArityInfo, arityLowerBound,
- strictnessInfo, ppStrictnessInfo, isBottomingStrictness,
- cafInfo, ppCafInfo, specInfo,
- cprInfo, ppCprInfo, pprInlinePragInfo,
+import IdInfo ( IdInfo, StrictnessInfo(..), ArityInfo(..), InlinePragInfo(..),
+ CprInfo(..), CafInfo(..),
+ inlinePragInfo, arityInfo, arityLowerBound,
+ strictnessInfo, isBottomingStrictness,
+ cafInfo, specInfo, cprInfo,
occInfo, isNeverInlinePrag,
- workerExists, workerInfo, ppWorkerInfo, WorkerInfo(..)
+ workerExists, workerInfo, WorkerInfo(..)
)
-import CoreSyn ( CoreExpr, CoreBind, Bind(..), rulesRules, rulesRhsFreeVars )
+import CoreSyn ( CoreExpr, CoreBind, Bind(..), isBuiltinRule, rulesRules, rulesRhsFreeVars )
import CoreFVs ( exprSomeFreeVars, ruleSomeLhsFreeVars, ruleSomeFreeVars )
import CoreUnfold ( okToUnfoldInHiFile, couldBeSmallEnoughToInline )
import Module ( moduleString, pprModule, pprModuleName )
-import Name ( isLocallyDefined, isWiredInName, nameRdrName, nameModule,
+import RdrName ( RdrName )
+import Name ( isLocallyDefined, isWiredInName, toRdrName, nameModule,
Name, NamedThing(..)
)
import OccName ( OccName, pprOccName )
import TyCon ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon,
- tyConTheta, tyConTyVars, tyConDataCons
+ tyConTheta, tyConTyVars, tyConDataCons, tyConFamilySize
)
import Class ( Class, classExtraBigSig )
import FieldLabel ( fieldLabelName, fieldLabelType )
)
import PprType
-import PprCore ( pprIfaceUnfolding, pprCoreRule )
import FunDeps ( pprFundeps )
import Rules ( pprProtoCoreRule, ProtoCoreRule(..) )
import UniqFM ( lookupUFM, listToUFM )
import UniqSet ( uniqSetToList )
import Util ( sortLt, mapAccumL )
+import SrcLoc ( noSrcLoc )
import Bag
import Outputable
\end{code}
-We have a function @startIface@ to open the output file and put
-(something like) ``interface Foo'' in it. It gives back a handle
-for subsequent additions to the interface file.
-We then have one-function-per-block-of-interface-stuff, e.g.,
-@ifaceExportList@ produces the @__exports__@ section; it appends
-to the handle provided by @startIface@.
-
-NOTE: ALWAYS remember that ghc-iface.lprl rewrites the interface file,
-so you have to keep it in synch with the code below. Otherwise you'll
-lose the happiest years of your life, believe me... -- SUP
+%************************************************************************
+%* *
+\subsection{Write a new interface file}
+%* *
+%************************************************************************
\begin{code}
-startIface :: Module -> InterfaceDetails
- -> IO (Maybe Handle) -- Nothing <=> don't do an interface
+writeIface this_mod old_iface new_iface
+ local_tycons local_classes inst_info
+ final_ids tidy_binds tidy_orphan_rules
+ = case opt_ProduceHi of {
+ Nothing -> return () ; -- not producing any .hi file
+
+ Just filename ->
+
+ case checkIface old_iface full_new_iface of {
+ Nothing -> do { putStrLn "Interface file unchanged" ;
+ return () } ; -- No need to update .hi file
+
+ Just final_iface ->
+
+ do let mod_vers_unchanged = case old_iface of
+ Just iface -> pi_vers iface == pi_vers final_iface
+ Nothing -> False
+ if mod_vers_unchanged
+ then putStrLn "Module version unchanged, but usages differ; hence need new hi file"
+ else return ()
+
+ if_hdl <- openFile filename WriteMode
+ printForIface if_hdl (pprIface final_iface)
+ hClose if_hdl
+ }}
+ where
+ full_new_iface = completeIface new_iface local_tycons local_classes
+ inst_info final_ids tidy_binds
+ tidy_orphan_rules
+\end{code}
-ifaceDecls :: Maybe Handle
- -> [TyCon] -> [Class]
- -> Bag InstInfo
- -> [Id] -- Ids used at code-gen time; they have better pragma info!
- -> [CoreBind] -- In dependency order, later depend on earlier
- -> [ProtoCoreRule] -- Rules
- -> [Deprecation Name]
- -> IO ()
-endIface :: Maybe Handle -> IO ()
-\end{code}
+%************************************************************************
+%* *
+\subsection{Checking if the new interface is up to date
+%* *
+%************************************************************************
\begin{code}
-startIface mod (InterfaceDetails has_orphans import_usages (ExportEnv avails fixities _) _)
- = case opt_ProduceHi of
- Nothing -> return Nothing ; -- not producing any .hi file
-
- Just fn -> do
- if_hdl <- openFile fn WriteMode
- hPutStr if_hdl ("__interface \"" ++ show opt_InPackage ++ "\" " ++ moduleString mod)
- hPutStr if_hdl (' ' : orphan_indicator)
- hPutStrLn if_hdl " where"
- ifaceExports if_hdl avails
- ifaceImports if_hdl import_usages
- ifaceFixities if_hdl fixities
- return (Just if_hdl)
+checkIface :: Maybe ParsedIface -- The old interface, read from M.hi
+ -> ParsedIface -- The new interface; but with all version numbers = 1
+ -> Maybe ParsedIface -- Nothing => no change; no need to write new Iface
+ -- Just pi => Here is the new interface to write
+ -- with correct version numbers
+
+-- NB: the fixities, declarations, rules are all assumed
+-- to be sorted by increasing order of hsDeclName, so that
+-- we can compare for equality
+
+checkIface Nothing new_iface
+-- No old interface, so definitely write a new one!
+ = Just new_iface
+
+checkIface (Just iface) new_iface
+ | no_output_change && no_usage_change
+ = Nothing
+
+ | otherwise -- Add updated version numbers
+ =
+{- pprTrace "checkIface" (
+ vcat [ppr no_decl_changed <+> ppr no_export_change <+> ppr no_usage_change,
+ text "--------",
+ vcat (map ppr (pi_decls iface)),
+ text "--------",
+ vcat (map ppr (pi_decls new_iface))
+ ]) $
+-}
+ Just (new_iface { pi_vers = new_mod_vers,
+ pi_fixity = (new_fixity_vers, new_fixities),
+ pi_rules = (new_rules_vers, new_rules),
+ pi_decls = final_decls
+ })
+
where
- orphan_indicator | has_orphans = " !"
- | otherwise = ""
+ no_usage_change = pi_usages iface == pi_usages new_iface
+
+ no_output_change = no_decl_changed &&
+ new_fixity_vers == fixity_vers &&
+ new_rules_vers == rules_vers &&
+ no_export_change
+
+ no_export_change = pi_exports iface == pi_exports new_iface
+
+ new_mod_vers | no_output_change = mod_vers
+ | otherwise = bumpVersion mod_vers
+
+ mod_vers = pi_vers iface
+
+ (fixity_vers, fixities) = pi_fixity iface
+ (_, new_fixities) = pi_fixity new_iface
+ new_fixity_vers | fixities == new_fixities = fixity_vers
+ | otherwise = bumpVersion fixity_vers
+
+ (rules_vers, rules) = pi_rules iface
+ (_, new_rules) = pi_rules new_iface
+ new_rules_vers | rules == new_rules = rules_vers
+ | otherwise = bumpVersion rules_vers
+
+ (no_decl_changed, final_decls) = merge_decls True [] (pi_decls iface) (pi_decls new_iface)
+
+ -- Fill in the version number on the new declarations
+ -- by looking at the old declarations.
+ -- Set the flag if anything changes.
+ -- Assumes that the decls are sorted by hsDeclName
+ merge_decls ok_so_far acc [] [] = (ok_so_far, reverse acc)
+ merge_decls ok_so_far acc old [] = (False, reverse acc)
+ merge_decls ok_so_far acc [] (nvd:nvds) = merge_decls False (nvd:acc) [] nvds
+ merge_decls ok_so_far acc (vd@(v,d):vds) (nvd@(_,nd):nvds)
+ = case d_name `compare` nd_name of
+ LT -> merge_decls False acc vds (nvd:nvds)
+ GT -> merge_decls False (nvd:acc) (vd:vds) nvds
+ EQ | d == nd -> merge_decls ok_so_far (vd:acc) vds nvds
+ | otherwise -> merge_decls False ((bumpVersion v, nd):acc) vds nvds
+ where
+ d_name = hsDeclName d
+ nd_name = hsDeclName nd
+\end{code}
+
+
+
+%************************************************************************
+%* *
+\subsection{Printing the interface}
+%* *
+%************************************************************************
-endIface Nothing = return ()
-endIface (Just if_hdl) = hPutStr if_hdl "\n" >> hClose if_hdl
+\begin{code}
+pprIface (ParsedIface { pi_mod = mod, pi_vers = mod_vers, pi_orphan = orphan,
+ pi_usages = usages, pi_exports = exports,
+ pi_fixity = (fix_vers, fixities),
+ pi_insts = insts, pi_decls = decls,
+ pi_rules = (rule_vers, rules), pi_deprecs = deprecs })
+ = vcat [ ptext SLIT("__interface")
+ <+> doubleQuotes (ptext opt_InPackage)
+ <+> ppr mod <+> ppr mod_vers <+> pp_sub_vers
+ <+> (if orphan then char '!' else empty)
+ <+> int opt_HiVersion
+ <+> ptext SLIT("where")
+ , vcat (map pprExport exports)
+ , vcat (map pprUsage usages)
+ , pprFixities fixities
+ , vcat [ppr i <+> semi | i <- insts]
+ , vcat [ppr_vers v <+> ppr d <> semi | (v,d) <- decls]
+ , pprRules rules
+ , pprDeprecs deprecs
+ ]
+ where
+ ppr_vers v | v == initialVersion = empty
+ | otherwise = int v
+ pp_sub_vers
+ | fix_vers == initialVersion && rule_vers == initialVersion = empty
+ | otherwise = brackets (ppr fix_vers <+> ppr rule_vers)
\end{code}
+When printing export lists, we print like this:
+ Avail f f
+ AvailTC C [C, x, y] C(x,y)
+ AvailTC C [x, y] C!(x,y) -- Exporting x, y but not C
\begin{code}
-ifaceDecls Nothing tycons classes inst_info final_ids simplified rules _ = return ()
-ifaceDecls (Just hdl)
- tycons classes
- inst_infos
- final_ids
- binds
- orphan_rules -- Rules defined locally for an Id that is *not* defined locally
- deprecations
- | null_decls = return ()
- -- You could have a module with just (re-)exports/instances in it
- | otherwise
- = ifaceClasses hdl classes >>
- ifaceInstances hdl inst_infos >>= \ inst_ids ->
- ifaceTyCons hdl tycons >>
- ifaceBinds hdl (inst_ids `unionVarSet` orphan_rule_ids)
- final_ids binds >>= \ emitted_ids ->
- ifaceRules hdl orphan_rules emitted_ids >>
- ifaceDeprecations hdl deprecations
+pprExport :: ExportItem -> SDoc
+pprExport (mod, items)
+ = hsep [ ptext SLIT("__export "), ppr mod, hsep (map upp_avail items) ] <> semi
where
- orphan_rule_ids = unionVarSets [ ruleSomeFreeVars interestingId rule
- | ProtoCoreRule _ _ rule <- orphan_rules]
-
- null_decls = null binds &&
- null tycons &&
- null classes &&
- isEmptyBag inst_infos &&
- null orphan_rules &&
- null deprecations
+ upp_avail :: RdrAvailInfo -> SDoc
+ upp_avail (Avail name) = pprOccName name
+ upp_avail (AvailTC name []) = empty
+ upp_avail (AvailTC name ns) = hcat [pprOccName name, bang, upp_export ns']
+ where
+ bang | name `elem` ns = empty
+ | otherwise = char '|'
+ ns' = filter (/= name) ns
+
+ upp_export [] = empty
+ upp_export names = braces (hsep (map pprOccName names))
\end{code}
+
\begin{code}
-ifaceImports :: Handle -> VersionInfo Name -> IO ()
-ifaceImports if_hdl import_usages
- = hPutCol if_hdl upp_uses (sortLt lt_imp_vers import_usages)
+pprUsage :: ImportVersion OccName -> SDoc
+pprUsage (m, has_orphans, is_boot, whats_imported)
+ = hsep [ptext SLIT("import"), pprModuleName m,
+ pp_orphan, pp_boot,
+ upp_import_versions whats_imported
+ ] <> semi
where
- upp_uses (m, mv, has_orphans, is_boot, whats_imported)
- = hsep [ptext SLIT("import"), pprModuleName m,
- int mv, pp_orphan, pp_boot,
- upp_import_versions whats_imported
- ] <> semi
- where
- pp_orphan | has_orphans = ptext SLIT("!")
- | otherwise = empty
- pp_boot | is_boot = ptext SLIT("@")
- | otherwise = empty
+ pp_orphan | has_orphans = char '!'
+ | otherwise = empty
+ pp_boot | is_boot = char '@'
+ | otherwise = empty
-- Importing the whole module is indicated by an empty list
- upp_import_versions Everything = empty
-
- -- For imported versions we do print the version number
- upp_import_versions (Specifically nvs)
- = dcolon <+> hsep [ hsep [ppr_unqual_name n, int v] | (n,v) <- sort_versions nvs ]
-
-{- SUP: What's this??
-ifaceModuleDeps if_hdl [] = return ()
-ifaceModuleDeps if_hdl mod_deps
- = let
- lines = map ppr_mod_dep mod_deps
- ppr_mod_dep (mod, contains_orphans)
- | contains_orphans = pprModuleName mod <+> ptext SLIT("!")
- | otherwise = pprModuleName mod
- in
- printForIface if_hdl (ptext SLIT("__depends") <+> vcat lines <> ptext SLIT(" ;")) >>
- hPutStr if_hdl "\n"
--}
+ upp_import_versions NothingAtAll = empty
+ upp_import_versions (Everything v) = dcolon <+> int v
+ upp_import_versions (Specifically vm vf vr nvs)
+ = dcolon <+> int vm <+> int vf <+> int vr <+> hsep [ ppr n <+> int v | (n,v) <- nvs ]
+\end{code}
-ifaceExports :: Handle -> Avails -> IO ()
-ifaceExports if_hdl [] = return ()
-ifaceExports if_hdl avails
- = hPutCol if_hdl do_one_module (fmToList export_fm)
- where
- -- Sort them into groups by module
- export_fm :: FiniteMap Module [AvailInfo]
- export_fm = foldr insert emptyFM avails
-
- insert avail efm = addToFM_C (++) efm mod [avail]
- where
- mod = nameModule (availName avail)
-
- -- Print one module's worth of stuff
- do_one_module :: (Module, [AvailInfo]) -> SDoc
- do_one_module (mod_name, avails@(avail1:_))
- = ptext SLIT("__export ") <>
- hsep [pprModule mod_name,
- hsep (map upp_avail (sortLt lt_avail avails))
- ] <> semi
-
-ifaceFixities :: Handle -> Fixities -> IO ()
-ifaceFixities if_hdl [] = return ()
-ifaceFixities if_hdl fixities
- = hPutCol if_hdl upp_fixity fixities
-
-ifaceRules :: Handle -> [ProtoCoreRule] -> IdSet -> IO ()
-ifaceRules if_hdl rules emitted
- | opt_OmitInterfacePragmas -- Don't emit rules if we are suppressing
- -- interface pragmas
- || (null orphan_rule_pretties && null local_id_pretties)
- = return ()
- | otherwise
- = printForIface if_hdl (vcat [
- ptext SLIT("{-## __R"),
- vcat orphan_rule_pretties,
- vcat local_id_pretties,
- ptext SLIT("##-}")
- ])
- where
- orphan_rule_pretties = [ pprCoreRule (Just fn) rule
- | ProtoCoreRule _ fn rule <- rules
- ]
- local_id_pretties = [ pprCoreRule (Just fn) rule
- | fn <- varSetElems emitted,
- rule <- rulesRules (idSpecialisation fn),
- all (`elemVarSet` emitted) (varSetElems (ruleSomeLhsFreeVars interestingId rule))
- -- Spit out a rule only if all its lhs free vars are emitted
- -- This is a good reason not to do it when we emit the Id itself
- ]
-
-ifaceDeprecations :: Handle -> [Deprecation Name] -> IO ()
-ifaceDeprecations if_hdl [] = return ()
-ifaceDeprecations if_hdl deprecations
- = printForIface if_hdl (vcat [
- ptext SLIT("{-## __D"),
- vcat [ pprIE ie <+> doubleQuotes (ppr txt) <> semi | Deprecation ie txt <- deprecations ],
- ptext SLIT("##-}")
- ])
+
+\begin{code}
+pprFixities [] = empty
+pprFixities fixes = hsep (map ppr fixes) <> semi
+
+pprRules [] = empty
+pprRules rules = hsep [ptext SLIT("{-## __R"), hsep (map ppr rules), ptext SLIT("##-}")]
+
+pprDeprecs [] = empty
+pprDeprecs deps = hsep [ ptext SLIT("{-## __D"), guts, ptext SLIT("##-}")]
+ where
+ guts = hsep [ ppr ie <+> doubleQuotes (ppr txt) <> semi
+ | Deprecation ie txt _ <- deps ]
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Completing the new interface}
+%* *
+%************************************************************************
+
+\begin{code}
+completeIface new_iface local_tycons local_classes
+ inst_info final_ids tidy_binds
+ tidy_orphan_rules
+ = new_iface { pi_decls = [(initialVersion,d) | d <- sortLt lt_decl all_decls],
+ pi_insts = sortLt lt_inst_decl inst_dcls,
+ pi_rules = (initialVersion, rule_dcls)
+ }
where
- pprIE (IEVar n ) = ppr n
- pprIE (IEThingAbs n ) = ppr n
- pprIE (IEThingAll n ) = hcat [ppr n, text "(..)"]
- pprIE (IEThingWith n ns) = ppr n <> parens (hcat (punctuate comma (map ppr ns)))
- pprIE (IEModuleContents _ ) = empty
+ all_decls = cls_dcls ++ ty_dcls ++ bagToList val_dcls
+ (inst_dcls, inst_ids) = ifaceInstances inst_info
+ cls_dcls = map ifaceClass local_classes
+ ty_dcls = map ifaceTyCon (filter (not . isWiredInName . getName) local_tycons)
+
+ (val_dcls, emitted_ids) = ifaceBinds (inst_ids `unionVarSet` orphan_rule_ids)
+ final_ids tidy_binds
+
+ rule_dcls | opt_OmitInterfacePragmas = []
+ | otherwise = ifaceRules tidy_orphan_rules emitted_ids
+
+ orphan_rule_ids = unionVarSets [ ruleSomeFreeVars interestingId rule
+ | ProtoCoreRule _ _ rule <- tidy_orphan_rules]
+
+lt_inst_decl (InstDecl _ _ _ dfun_id1 _) (InstDecl _ _ _ dfun_id2 _)
+ = dfun_id1 < dfun_id2
+ -- The dfuns are assigned names df1, df2, etc,
+ -- in order of original textual
+ -- occurrence, and this makes as good a sort order as any
+
+lt_decl d1 d2 = hsDeclName d1 < hsDeclName d2
\end{code}
+
%************************************************************************
%* *
-\subsection{Instance declarations}
+\subsection{Completion stuff}
%* *
%************************************************************************
+\begin{code}
+ifaceRules :: [ProtoCoreRule] -> IdSet -> [RdrNameRuleDecl]
+ifaceRules rules emitted
+ = orphan_rules ++ local_rules
+ where
+ orphan_rules = [ toHsRule fn rule | ProtoCoreRule _ fn rule <- rules ]
+ local_rules = [ toHsRule fn rule
+ | fn <- varSetElems emitted,
+ rule <- rulesRules (idSpecialisation fn),
+ not (isBuiltinRule rule),
+ -- We can't print builtin rules in interface files
+ -- Since they are built in, an importing module
+ -- will have access to them anyway
+ all (`elemVarSet` emitted) (varSetElems (ruleSomeLhsFreeVars interestingId rule))
+ -- Spit out a rule only if all its lhs free vars are emitted
+ -- This is a good reason not to do it when we emit the Id itself
+ ]
+\end{code}
\begin{code}
-ifaceInstances :: Handle -> Bag InstInfo -> IO IdSet -- The IdSet is the needed dfuns
-ifaceInstances if_hdl inst_infos
- | null togo_insts = return emptyVarSet
- | otherwise = hPutCol if_hdl pp_inst (sortLt lt_inst togo_insts) >>
- return needed_ids
- where
+ifaceInstances :: Bag InstInfo -> ([RdrNameInstDecl], IdSet)
+ -- The IdSet is the needed dfuns
+
+ifaceInstances inst_infos
+ = (decls, needed_ids)
+ where
+ decls = map to_decl togo_insts
togo_insts = filter is_togo_inst (bagToList inst_infos)
needed_ids = mkVarSet [dfun_id | InstInfo _ _ _ _ dfun_id _ _ _ <- togo_insts]
is_togo_inst (InstInfo _ _ _ _ dfun_id _ _ _) = isLocallyDefined dfun_id
-------
- lt_inst (InstInfo _ _ _ _ dfun_id1 _ _ _)
- (InstInfo _ _ _ _ dfun_id2 _ _ _)
- = getOccName dfun_id1 < getOccName dfun_id2
- -- The dfuns are assigned names df1, df2, etc, in order of original textual
- -- occurrence, and this makes as good a sort order as any
-
- -------
- pp_inst (InstInfo clas tvs tys theta dfun_id _ _ _)
+ to_decl (InstInfo clas tvs tys theta dfun_id _ _ _)
= let
-- The deNoteType is very important. It removes all type
-- synonyms from the instance type in interface files.
-- that mentioned T but not Tibble.
forall_ty = mkSigmaTy tvs (classesToPreds theta)
(deNoteType (mkDictTy clas tys))
- renumbered_ty = tidyTopType forall_ty
+ tidy_ty = tidyTopType forall_ty
in
- hcat [ptext SLIT("instance "), pprType renumbered_ty,
- ptext SLIT(" = "), ppr_unqual_name dfun_id, semi]
+ InstDecl (toHsType tidy_ty) EmptyMonoBinds [] (toRdrName dfun_id) noSrcLoc
+\end{code}
+
+\begin{code}
+ifaceTyCon :: TyCon -> RdrNameHsDecl
+ifaceTyCon tycon
+ | isSynTyCon tycon
+ = TyClD (TySynonym (toRdrName tycon)
+ (toHsTyVars tyvars) (toHsType ty)
+ noSrcLoc)
+ where
+ (tyvars, ty) = getSynTyConDefn tycon
+
+ifaceTyCon tycon
+ | isAlgTyCon tycon
+ = TyClD (TyData new_or_data (toHsContext (tyConTheta tycon))
+ (toRdrName tycon)
+ (toHsTyVars tyvars)
+ (map ifaceConDecl (tyConDataCons tycon))
+ (tyConFamilySize tycon)
+ Nothing NoDataPragmas noSrcLoc)
+ where
+ tyvars = tyConTyVars tycon
+ new_or_data | isNewTyCon tycon = NewType
+ | otherwise = DataType
+
+ ifaceConDecl data_con
+ = ConDecl (toRdrName data_con) (error "ifaceConDecl")
+ (toHsTyVars ex_tyvars)
+ (toHsContext ex_theta)
+ details noSrcLoc
+ where
+ (tyvars1, _, ex_tyvars, ex_theta, arg_tys, tycon1) = dataConSig data_con
+ field_labels = dataConFieldLabels data_con
+ strict_marks = dataConStrictMarks data_con
+ details
+ | null field_labels
+ = ASSERT( tycon == tycon1 && tyvars == tyvars1 )
+ VanillaCon (zipWith mk_bang_ty strict_marks arg_tys)
+
+ | otherwise
+ = RecCon (zipWith mk_field strict_marks field_labels)
+
+ mk_bang_ty NotMarkedStrict ty = Unbanged (toHsType ty)
+ mk_bang_ty (MarkedUnboxed _ _) ty = Unpacked (toHsType ty)
+ mk_bang_ty MarkedStrict ty = Banged (toHsType ty)
+
+ mk_field strict_mark field_label
+ = ([toRdrName field_label], mk_bang_ty strict_mark (fieldLabelType field_label))
+
+ifaceTyCon tycon
+ = pprPanic "pprIfaceTyDecl" (ppr tycon)
+
+ifaceClass clas
+ = TyClD (ClassDecl (toHsContext sc_theta)
+ (toRdrName clas)
+ (toHsTyVars clas_tyvars)
+ (toHsFDs clas_fds)
+ (map toClassOpSig op_stuff)
+ EmptyMonoBinds NoClassPragmas
+ bogus bogus bogus [] noSrcLoc
+ )
+ where
+ bogus = error "ifaceClass"
+ (clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas
+
+ toClassOpSig (sel_id, dm_id, explicit_dm)
+ = ASSERT( sel_tyvars == clas_tyvars)
+ ClassOpSig (toRdrName sel_id) bogus explicit_dm (toHsType op_ty) noSrcLoc
+ where
+ (sel_tyvars, _, op_ty) = splitSigmaTy (idType sel_id)
\end{code}
%************************************************************************
%* *
-\subsection{Printing values}
+\subsection{Value bindings}
%* *
%************************************************************************
\begin{code}
-ifaceId :: (Id -> IdInfo) -- This function "knows" the extra info added
- -- by the STG passes. Sigh
+ifaceBinds :: IdSet -- These Ids are needed already
+ -> [Id] -- Ids used at code-gen time; they have better pragma info!
+ -> [CoreBind] -- In dependency order, later depend on earlier
+ -> (Bag RdrNameHsDecl, IdSet) -- Set of Ids actually spat out
+
+ifaceBinds needed_ids final_ids binds
+ = go needed_ids (reverse binds) emptyBag emptyVarSet
+ -- Reverse so that later things will
+ -- provoke earlier ones to be emitted
+ where
+ final_id_map = listToUFM [(id,id) | id <- final_ids]
+ get_idinfo id = case lookupUFM final_id_map id of
+ Just id' -> idInfo id'
+ Nothing -> pprTrace "ifaceBinds not found:" (ppr id) $
+ idInfo id
- -> IdSet -- Set of Ids that are needed by earlier interface
- -- file emissions. If the Id isn't in this set, and isn't
- -- exported, there's no need to emit anything
- -> Bool -- True <=> recursive, so don't print unfolding
- -> Id
- -> CoreExpr -- The Id's right hand side
- -> Maybe (SDoc, IdSet) -- The emitted stuff, plus any *extra* needed Ids
+ go needed [] decls emitted
+ | not (isEmptyVarSet needed) = pprTrace "ifaceBinds: free vars:"
+ (sep (map ppr (varSetElems needed)))
+ (decls, emitted)
+ | otherwise = (decls, emitted)
+
+ go needed (NonRec id rhs : binds) decls emitted
+ = case ifaceId get_idinfo needed False id rhs of
+ Nothing -> go needed binds decls emitted
+ Just (decl, extras) -> let
+ needed' = (needed `unionVarSet` extras) `delVarSet` id
+ -- 'extras' can include the Id itself via a rule
+ emitted' = emitted `extendVarSet` id
+ in
+ go needed' binds (decl `consBag` decls) emitted'
+
+ -- Recursive groups are a bit more of a pain. We may only need one to
+ -- start with, but it may call out the next one, and so on. So we
+ -- have to look for a fixed point.
+ go needed (Rec pairs : binds) decls emitted
+ = go needed' binds decls' emitted'
+ where
+ (new_decls, new_emitted, extras) = go_rec needed pairs
+ decls' = new_decls `unionBags` decls
+ needed' = (needed `unionVarSet` extras) `minusVarSet` mkVarSet (map fst pairs)
+ emitted' = emitted `unionVarSet` new_emitted
+
+ go_rec :: IdSet -> [(Id,CoreExpr)] -> (Bag RdrNameHsDecl, IdSet, IdSet)
+ go_rec needed pairs
+ | null decls = (emptyBag, emptyVarSet, emptyVarSet)
+ | otherwise = (more_decls `unionBags` listToBag decls,
+ more_emitted `unionVarSet` mkVarSet emitted,
+ more_extras `unionVarSet` extras)
+ where
+ maybes = map do_one pairs
+ emitted = [id | ((id,_), Just _) <- pairs `zip` maybes]
+ reduced_pairs = [pair | (pair, Nothing) <- pairs `zip` maybes]
+ (decls, extras_s) = unzip (catMaybes maybes)
+ extras = unionVarSets extras_s
+ (more_decls, more_emitted, more_extras) = go_rec extras reduced_pairs
+
+ do_one (id,rhs) = ifaceId get_idinfo needed True id rhs
+\end{code}
+
+
+\begin{code}
+ifaceId :: (Id -> IdInfo) -- This function "knows" the extra info added
+ -- by the STG passes. Sigh
+
+ -> IdSet -- Set of Ids that are needed by earlier interface
+ -- file emissions. If the Id isn't in this set, and isn't
+ -- exported, there's no need to emit anything
+ -> Bool -- True <=> recursive, so don't print unfolding
+ -> Id
+ -> CoreExpr -- The Id's right hand side
+ -> Maybe (RdrNameHsDecl, IdSet) -- The emitted stuff, plus any *extra* needed Ids
ifaceId get_idinfo needed_ids is_rec id rhs
| not (id `elemVarSet` needed_ids || -- Needed [no id in needed_ids has omitIfaceSigForId]
- (isUserExportedId id && not (omitIfaceSigForId id))) -- or exported and not to be omitted
+ (isUserExportedId id && not (omitIfaceSigForId id))) -- or exported and not to be omitted
= Nothing -- Well, that was easy!
ifaceId get_idinfo needed_ids is_rec id rhs
= ASSERT2( arity_matches_strictness, ppr id )
- Just (hsep [sig_pretty, prag_pretty, char ';'], new_needed_ids)
+ Just (SigD (IfaceSig (toRdrName id) (toHsType id_type) hs_idinfo noSrcLoc),
+ new_needed_ids)
where
+ id_type = idType id
core_idinfo = idInfo id
stg_idinfo = get_idinfo id
- ty_pretty = pprType (idType id)
- sig_pretty = hsep [ppr (getOccName id), dcolon, ty_pretty]
-
- prag_pretty
- | opt_OmitInterfacePragmas = empty
- | otherwise = hsep [ptext SLIT("{-##"),
- arity_pretty,
- caf_pretty,
- cpr_pretty,
- strict_pretty,
- wrkr_pretty,
- unfold_pretty,
- ptext SLIT("##-}")]
+ hs_idinfo | opt_OmitInterfacePragmas = []
+ | otherwise = arity_hsinfo ++ caf_hsinfo ++ cpr_hsinfo ++
+ strict_hsinfo ++ wrkr_hsinfo ++ unfold_hsinfo
------------ Arity --------------
- arity_info = arityInfo stg_idinfo
- arity_pretty = ppArityInfo arity_info
+ arity_info = arityInfo stg_idinfo
+ arity_hsinfo = case arityInfo stg_idinfo of
+ a@(ArityExactly n) -> [HsArity a]
+ other -> []
------------ Caf Info --------------
- caf_pretty = ppCafInfo (cafInfo stg_idinfo)
+ caf_hsinfo = case cafInfo stg_idinfo of
+ NoCafRefs -> [HsNoCafRefs]
+ otherwise -> []
------------ CPR Info --------------
- cpr_pretty = ppCprInfo (cprInfo core_idinfo)
+ cpr_hsinfo = case cprInfo core_idinfo of
+ ReturnsCPR -> [HsCprInfo]
+ NoCPRInfo -> []
------------ Strictness --------------
strict_info = strictnessInfo core_idinfo
bottoming_fn = isBottomingStrictness strict_info
- strict_pretty = ppStrictnessInfo strict_info
+ strict_hsinfo = case strict_info of
+ NoStrictnessInfo -> []
+ info -> [HsStrictness info]
+
------------ Worker --------------
work_info = workerInfo core_idinfo
has_worker = workerExists work_info
- wrkr_pretty = ppWorkerInfo work_info
- HasWorker work_id wrap_arity = work_info
-
-
- ------------ Occ info --------------
- loop_breaker = isLoopBreaker (occInfo core_idinfo)
+ wrkr_hsinfo = case work_info of
+ HasWorker work_id _ -> [HsWorker (toRdrName work_id)]
+ other -> []
------------ Unfolding --------------
inline_pragma = inlinePragInfo core_idinfo
dont_inline = isNeverInlinePrag inline_pragma
- unfold_pretty | show_unfold = ptext SLIT("__U") <> pprInlinePragInfo inline_pragma <+> pprIfaceUnfolding rhs
- | otherwise = empty
+ unfold_hsinfo | show_unfold = [HsUnfold inline_pragma (toUfExpr rhs)]
+ | otherwise = []
show_unfold = not has_worker && -- Not unnecessary
not bottoming_fn && -- Not necessary
------------ Specialisations --------------
spec_info = specInfo core_idinfo
+ ------------ Occ info --------------
+ loop_breaker = isLoopBreaker (occInfo core_idinfo)
+
------------ Extra free Ids --------------
new_needed_ids | opt_OmitInterfacePragmas = emptyVarSet
| otherwise = worker_ids `unionVarSet`
unfold_ids `unionVarSet`
spec_ids
- worker_ids | has_worker && interestingId work_id = unitVarSet work_id
+ worker_ids = case work_info of
+ HasWorker work_id _ | interestingId work_id -> unitVarSet work_id
-- Conceivably, the worker might come from
-- another module
- | otherwise = emptyVarSet
+ other -> emptyVarSet
spec_ids = filterVarSet interestingId (rulesRhsFreeVars spec_info)
------------ Sanity checking --------------
-- The arity of a wrapper function should match its strictness,
-- or else an importing module will get very confused indeed.
- arity_matches_strictness = not has_worker ||
- wrap_arity == arityLowerBound arity_info
+ arity_matches_strictness
+ = case work_info of
+ HasWorker _ wrap_arity -> wrap_arity == arityLowerBound arity_info
+ other -> True
interestingId id = isId id && isLocallyDefined id &&
not (omitIfaceSigForId id)
\end{code}
-\begin{code}
-ifaceBinds :: Handle
- -> IdSet -- These Ids are needed already
- -> [Id] -- Ids used at code-gen time; they have better pragma info!
- -> [CoreBind] -- In dependency order, later depend on earlier
- -> IO IdSet -- Set of Ids actually spat out
-
-ifaceBinds hdl needed_ids final_ids binds
- = mapIO (printForIface hdl) (bagToList pretties) >>
- hPutStr hdl "\n" >>
- return emitted
- where
- final_id_map = listToUFM [(id,id) | id <- final_ids]
- get_idinfo id = case lookupUFM final_id_map id of
- Just id' -> idInfo id'
- Nothing -> pprTrace "ifaceBinds not found:" (ppr id) $
- idInfo id
-
- (pretties, emitted) = go needed_ids (reverse binds) emptyBag emptyVarSet
- -- Reverse so that later things will
- -- provoke earlier ones to be emitted
- go needed [] pretties emitted
- | not (isEmptyVarSet needed) = pprTrace "ifaceBinds: free vars:"
- (sep (map ppr (varSetElems needed)))
- (pretties, emitted)
- | otherwise = (pretties, emitted)
-
- go needed (NonRec id rhs : binds) pretties emitted
- = case ifaceId get_idinfo needed False id rhs of
- Nothing -> go needed binds pretties emitted
- Just (pretty, extras) -> let
- needed' = (needed `unionVarSet` extras) `delVarSet` id
- -- 'extras' can include the Id itself via a rule
- emitted' = emitted `extendVarSet` id
- in
- go needed' binds (pretty `consBag` pretties) emitted'
-
- -- Recursive groups are a bit more of a pain. We may only need one to
- -- start with, but it may call out the next one, and so on. So we
- -- have to look for a fixed point.
- go needed (Rec pairs : binds) pretties emitted
- = go needed' binds pretties' emitted'
- where
- (new_pretties, new_emitted, extras) = go_rec needed pairs
- pretties' = new_pretties `unionBags` pretties
- needed' = (needed `unionVarSet` extras) `minusVarSet` mkVarSet (map fst pairs)
- emitted' = emitted `unionVarSet` new_emitted
-
- go_rec :: IdSet -> [(Id,CoreExpr)] -> (Bag SDoc, IdSet, IdSet)
- go_rec needed pairs
- | null pretties = (emptyBag, emptyVarSet, emptyVarSet)
- | otherwise = (more_pretties `unionBags` listToBag pretties,
- more_emitted `unionVarSet` mkVarSet emitted,
- more_extras `unionVarSet` extras)
- where
- maybes = map do_one pairs
- emitted = [id | ((id,_), Just _) <- pairs `zip` maybes]
- reduced_pairs = [pair | (pair, Nothing) <- pairs `zip` maybes]
- (pretties, extras_s) = unzip (catMaybes maybes)
- extras = unionVarSets extras_s
- (more_pretties, more_emitted, more_extras) = go_rec extras reduced_pairs
-
- do_one (id,rhs) = ifaceId get_idinfo needed True id rhs
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Random small things}
-%* *
-%************************************************************************
-
-\begin{code}
-ifaceTyCons hdl tycons = hPutCol hdl upp_tycon (sortLt (<) (filter (for_iface_name . getName) tycons))
-ifaceClasses hdl classes = hPutCol hdl upp_class (sortLt (<) (filter (for_iface_name . getName) classes))
-
-for_iface_name name = isLocallyDefined name &&
- not (isWiredInName name)
-
-upp_tycon tycon = ifaceTyCon tycon
-upp_class clas = ifaceClass clas
-\end{code}
-
-
-\begin{code}
-ifaceTyCon :: TyCon -> SDoc
-ifaceTyCon tycon
- | isSynTyCon tycon
- = hsep [ ptext SLIT("type"),
- ppr (getName tycon),
- pprTyVarBndrs tyvars,
- ptext SLIT("="),
- ppr ty,
- semi
- ]
- where
- (tyvars, ty) = getSynTyConDefn tycon
-
-ifaceTyCon tycon
- | isAlgTyCon tycon
- = hsep [ ptext keyword,
- ppr_decl_class_context (tyConTheta tycon),
- ppr (getName tycon),
- pprTyVarBndrs (tyConTyVars tycon),
- ptext SLIT("="),
- hsep (punctuate (ptext SLIT(" | ")) (map ppr_con (tyConDataCons tycon))),
- semi
- ]
- where
- keyword | isNewTyCon tycon = SLIT("newtype")
- | otherwise = SLIT("data")
-
- tyvars = tyConTyVars tycon
-
- ppr_con data_con
- | null field_labels
- = ASSERT( tycon == tycon1 && tyvars == tyvars1 )
- hsep [ ppr_ex ex_tyvars ex_theta,
- ppr name,
- hsep (map ppr_arg_ty (strict_marks `zip` arg_tys))
- ]
-
- | otherwise
- = hsep [ ppr_ex ex_tyvars ex_theta,
- ppr name,
- braces $ hsep $ punctuate comma (map ppr_field (strict_marks `zip` field_labels))
- ]
- where
- (tyvars1, _, ex_tyvars, ex_theta, arg_tys, tycon1) = dataConSig data_con
- field_labels = dataConFieldLabels data_con
- strict_marks = dataConStrictMarks data_con
- name = getName data_con
-
- ppr_ex [] ex_theta = ASSERT( null ex_theta ) empty
- ppr_ex ex_tvs ex_theta = ptext SLIT("__forall") <+> brackets (pprTyVarBndrs ex_tvs)
- <+> pprIfaceClasses ex_theta <+> ptext SLIT("=>")
-
- ppr_arg_ty (strict_mark, ty) = ppr_strict_mark strict_mark <> pprParendType ty
-
- ppr_strict_mark NotMarkedStrict = empty
- ppr_strict_mark (MarkedUnboxed _ _) = ptext SLIT("! ! ")
- ppr_strict_mark MarkedStrict = ptext SLIT("! ")
-
- ppr_field (strict_mark, field_label)
- = hsep [ ppr (fieldLabelName field_label),
- dcolon,
- ppr_strict_mark strict_mark <> pprParendType (fieldLabelType field_label)
- ]
-
-ifaceTyCon tycon
- = pprPanic "pprIfaceTyDecl" (ppr tycon)
-
-ifaceClass clas
- = hsep [ptext SLIT("class"),
- ppr_decl_class_context sc_theta,
- ppr clas, -- Print the name
- pprTyVarBndrs clas_tyvars,
- pprFundeps clas_fds,
- pp_ops,
- semi
- ]
- where
- (clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas
-
- pp_ops | null op_stuff = empty
- | otherwise = hsep [ptext SLIT("where"),
- braces (hsep (punctuate semi (map ppr_classop op_stuff)))
- ]
-
- ppr_classop (sel_id, dm_id, explicit_dm)
- = ASSERT( sel_tyvars == clas_tyvars)
- hsep [ppr (getOccName sel_id),
- if explicit_dm then equals else empty,
- dcolon,
- ppr op_ty
- ]
- where
- (sel_tyvars, _, op_ty) = splitSigmaTy (idType sel_id)
-
-ppr_decl_context :: ThetaType -> SDoc
-ppr_decl_context [] = empty
-ppr_decl_context theta = pprIfaceTheta theta <+> ptext SLIT(" =>")
-
-ppr_decl_class_context :: ClassContext -> SDoc
-ppr_decl_class_context [] = empty
-ppr_decl_class_context ctxt = pprIfaceClasses ctxt <+> ptext SLIT(" =>")
-
-pprIfaceTheta :: ThetaType -> SDoc -- Use braces rather than parens in interface files
-pprIfaceTheta [] = empty
-pprIfaceTheta theta = braces (hsep (punctuate comma [pprIfacePred p | p <- theta]))
-
--- ZZ - not sure who uses this - i.e. whether IParams really show up or not
--- (it's not used to print normal value signatures)
-pprIfacePred :: PredType -> SDoc
-pprIfacePred (Class clas tys) = pprConstraint clas tys
-pprIfacePred (IParam n ty) = char '?' <> ppr n <+> ptext SLIT("::") <+> ppr ty
-
-pprIfaceClasses :: ClassContext -> SDoc
-pprIfaceClasses [] = empty
-pprIfaceClasses theta = braces (hsep (punctuate comma [pprConstraint c tys | (c,tys) <- theta]))
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Random small things}
-%* *
-%************************************************************************
-
-When printing export lists, we print like this:
- Avail f f
- AvailTC C [C, x, y] C(x,y)
- AvailTC C [x, y] C!(x,y) -- Exporting x, y but not C
-
-\begin{code}
-upp_avail :: AvailInfo -> SDoc
-upp_avail (Avail name) = pprOccName (getOccName name)
-upp_avail (AvailTC name []) = empty
-upp_avail (AvailTC name ns) = hcat [pprOccName (getOccName name), bang, upp_export ns']
- where
- bang | name `elem` ns = empty
- | otherwise = char '|'
- ns' = filter (/= name) ns
-
-upp_export :: [Name] -> SDoc
-upp_export [] = empty
-upp_export names = braces (hsep (map (pprOccName . getOccName) names))
-
-upp_fixity :: (Name, Fixity) -> SDoc
-upp_fixity (name, fixity) = hsep [ptext SLIT("0"), ppr fixity, ppr name, semi]
- -- Dummy version number!
-
-ppr_unqual_name :: NamedThing a => a -> SDoc -- Just its occurrence name
-ppr_unqual_name name = pprOccName (getOccName name)
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Comparisons}
-%* *
-%************************************************************************
-
-
-The various sorts above simply prevent unnecessary "wobbling" when
-things change that don't have to. We therefore compare lexically, not
-by unique
-
-\begin{code}
-lt_avail :: AvailInfo -> AvailInfo -> Bool
-
-a1 `lt_avail` a2 = availName a1 `lt_name` availName a2
-
-lt_name :: Name -> Name -> Bool
-n1 `lt_name` n2 = nameRdrName n1 < nameRdrName n2
-
-lt_lexical :: NamedThing a => a -> a -> Bool
-lt_lexical a1 a2 = getName a1 `lt_name` getName a2
-
-lt_imp_vers :: ImportVersion a -> ImportVersion a -> Bool
-lt_imp_vers (m1,_,_,_,_) (m2,_,_,_,_) = m1 < m2
-
-sort_versions vs = sortLt lt_vers vs
-
-lt_vers :: LocalVersion Name -> LocalVersion Name -> Bool
-lt_vers (n1,v1) (n2,v2) = n1 `lt_name` n2
-\end{code}
-
-
-\begin{code}
-hPutCol :: Handle
- -> (a -> SDoc)
- -> [a]
- -> IO ()
-hPutCol hdl fmt xs = mapIO (printForIface hdl . fmt) xs
-
-mapIO :: (a -> IO b) -> [a] -> IO ()
-mapIO f [] = return ()
-mapIO f (x:xs) = f x >> mapIO f xs
-\end{code}
import IdInfo ( InlinePragInfo(..), CprInfo(..) )
import Name ( isLowerISO, isUpperISO )
-import PrelMods ( mkTupNameStr, mkUbxTupNameStr )
+import PrelNames ( mkTupNameStr )
import CmdLineOpts ( opt_IgnoreIfacePragmas, opt_HiVersion, opt_NoHiCheck )
import Demand ( Demand(..) {- instance Read -} )
import UniqFM ( UniqFM, listToUFM, lookupUFM)
-import BasicTypes ( NewOrData(..) )
+import BasicTypes ( NewOrData(..), Boxity(..) )
import SrcLoc ( SrcLoc, incSrcLine, srcLocFile, srcLocLine,
replaceSrcLine, mkSrcLoc )
go n buf =
case currentChar# buf of
','# -> go (n+1) (stepOn buf)
- ')'# -> cont (ITqconid (mod, snd (mkTupNameStr n))) (stepOn buf)
+ ')'# -> cont (ITqconid (mod, snd (mkTupNameStr Boxed n))) (stepOn buf)
_ -> back_off
lex_ubx_tuple cont mod buf back_off =
case currentChar# buf of
','# -> go (n+1) (stepOn buf)
'#'# -> case lookAhead# buf 1# of
- ')'# -> cont (ITqconid (mod, snd (mkUbxTupNameStr n)))
+ ')'# -> cont (ITqconid (mod, snd (mkTupNameStr Unboxed n)))
(stepOnBy# buf 2#)
_ -> back_off
_ -> back_off
, checkPrec -- String -> P String
, checkContext -- HsType -> P HsContext
, checkInstType -- HsType -> P HsType
- , checkAssertion -- HsType -> P HsAsst
, checkDataHeader -- HsQualType -> P (HsContext,HsName,[HsName])
, checkSimple -- HsType -> [HsName] -> P ((HsName,[HsName]))
, checkPattern -- HsExp -> P HsPat
import RdrHsSyn
import RdrName
import CallConv
-import PrelMods ( pRELUDE_Name, mkUbxTupNameStr, mkTupNameStr )
+import PrelNames ( pRELUDE_Name, mkTupNameStr )
import OccName ( dataName, tcName, varName, tvName, setOccNameSpace, occNameUserString )
import CmdLineOpts ( opt_NoImplicitPrelude )
import StringBuffer ( lexemeToString )
import FastString ( unpackFS )
+import BasicTypes ( Boxity(..) )
import ErrUtils
import UniqFM ( UniqFM, listToUFM, lookupUFM )
import Outputable
splitForConApp t ts = split t ts
where
- split (MonoTyApp t u) ts = split t (Unbanged u : ts)
+ split (HsAppTy t u) ts = split t (Unbanged u : ts)
- split (MonoTyVar t) ts = returnP (con, ts)
+ split (HsTyVar t) ts = returnP (con, ts)
where t_occ = rdrNameOcc t
con = setRdrNameOcc t (setOccNameSpace t_occ dataName)
checkInstType t
= case t of
HsForAllTy tvs ctxt ty ->
- checkAssertion ty [] `thenP` \(c,ts)->
- returnP (HsForAllTy tvs ctxt (MonoDictTy c ts))
+ checkDictTy ty [] `thenP` \ dict_ty ->
+ returnP (HsForAllTy tvs ctxt dict_ty)
- ty -> checkAssertion ty [] `thenP` \(c,ts)->
- returnP (HsForAllTy Nothing [] (MonoDictTy c ts))
+ ty -> checkDictTy ty [] `thenP` \ dict_ty->
+ returnP (HsForAllTy Nothing [] dict_ty)
checkContext :: RdrNameHsType -> P RdrNameContext
-checkContext (MonoTupleTy ts True)
+checkContext (HsTupleTy _ ts)
= mapP (\t -> checkPred t []) ts `thenP` \ps ->
returnP ps
-checkContext (MonoTyVar t) -- empty contexts are allowed
+checkContext (HsTyVar t) -- empty contexts are allowed
| t == unitTyCon_RDR = returnP []
checkContext t
= checkPred t [] `thenP` \p ->
checkPred :: RdrNameHsType -> [RdrNameHsType]
-> P (HsPred RdrName)
-checkPred (MonoTyVar t) args@(_:_) | not (isRdrTyVar t)
+checkPred (HsTyVar t) args@(_:_) | not (isRdrTyVar t)
= returnP (HsPClass t args)
-checkPred (MonoTyApp l r) args = checkPred l (r:args)
-checkPred (MonoIParamTy n ty) [] = returnP (HsPIParam n ty)
+checkPred (HsAppTy l r) args = checkPred l (r:args)
+checkPred (HsPredTy (HsPIParam n ty)) [] = returnP (HsPIParam n ty)
checkPred _ _ = parseError "Illegal class assertion"
-checkAssertion :: RdrNameHsType -> [RdrNameHsType]
- -> P (HsClassAssertion RdrName)
-checkAssertion (MonoTyVar t) args@(_:_) | not (isRdrTyVar t)
- = returnP (t,args)
-checkAssertion (MonoTyApp l r) args = checkAssertion l (r:args)
-checkAssertion _ _ = parseError "Illegal class assertion"
+checkDictTy :: RdrNameHsType -> [RdrNameHsType] -> P RdrNameHsType
+checkDictTy (HsTyVar t) args@(_:_) | not (isRdrTyVar t)
+ = returnP (mkHsDictTy t args)
+checkDictTy (HsAppTy l r) args = checkDictTy l (r:args)
+checkDictTy _ _ = parseError "Illegal class assertion"
checkDataHeader :: RdrNameHsType
-> P (RdrNameContext, RdrName, [RdrNameHsTyVar])
returnP ([],c,map UserTyVar ts)
checkSimple :: RdrNameHsType -> [RdrName] -> P ((RdrName,[RdrName]))
-checkSimple (MonoTyApp l (MonoTyVar a)) xs | isRdrTyVar a
+checkSimple (HsAppTy l (HsTyVar a)) xs | isRdrTyVar a
= checkSimple l (a:xs)
-checkSimple (MonoTyVar t) xs | not (isRdrTyVar t) = returnP (t,xs)
+checkSimple (HsTyVar t) xs | not (isRdrTyVar t) = returnP (t,xs)
checkSimple t _ = trace (showSDoc (ppr t)) $ parseError "Illegal data/newtype declaration"
---------------------------------------------------------------------------
| otherwise = mkPreludeQual tcName pRELUDE_Name funName
tupleCon_RDR arity
- | opt_NoImplicitPrelude = mkSrcUnqual dataName (snd (mkTupNameStr arity))
+ | opt_NoImplicitPrelude = mkSrcUnqual dataName (snd (mkTupNameStr Boxed arity))
| otherwise = mkPreludeQual dataName pRELUDE_Name
- (snd (mkTupNameStr arity))
+ (snd (mkTupNameStr Boxed arity))
tupleTyCon_RDR arity
- | opt_NoImplicitPrelude = mkSrcUnqual tcName (snd (mkTupNameStr arity))
+ | opt_NoImplicitPrelude = mkSrcUnqual tcName (snd (mkTupNameStr Boxed arity))
| otherwise = mkPreludeQual tcName pRELUDE_Name
- (snd (mkTupNameStr arity))
+ (snd (mkTupNameStr Boxed arity))
ubxTupleCon_RDR arity
- | opt_NoImplicitPrelude = mkSrcUnqual dataName (snd (mkUbxTupNameStr arity))
+ | opt_NoImplicitPrelude = mkSrcUnqual dataName (snd (mkTupNameStr Unboxed arity))
| otherwise = mkPreludeQual dataName pRELUDE_Name
- (snd (mkUbxTupNameStr arity))
+ (snd (mkTupNameStr Unboxed arity))
ubxTupleTyCon_RDR arity
- | opt_NoImplicitPrelude = mkSrcUnqual tcName (snd (mkUbxTupNameStr arity))
+ | opt_NoImplicitPrelude = mkSrcUnqual tcName (snd (mkTupNameStr Unboxed arity))
| otherwise = mkPreludeQual tcName pRELUDE_Name
- (snd (mkUbxTupNameStr arity))
+ (snd (mkTupNameStr Unboxed arity))
unitName = SLIT("()")
funName = SLIT("(->)")
{-
-----------------------------------------------------------------------------
-$Id: Parser.y,v 1.30 2000/05/23 11:35:37 simonpj Exp $
+$Id: Parser.y,v 1.31 2000/05/25 12:41:17 simonpj Exp $
Haskell grammar.
import HsSyn
import HsPragmas
+import HsTypes ( mkHsTupCon )
import RdrHsSyn
import Lex
import ParseUtil
import RdrName
-import PrelMods ( mAIN_Name )
-import OccName ( varName, ipName, dataName, tcClsName, tvName )
+import PrelInfo ( mAIN_Name )
+import OccName ( varName, ipName, tcName, dataName, tcClsName, tvName )
import SrcLoc ( SrcLoc )
import Module
import CallConv
import CmdLineOpts ( opt_SccProfilingOn )
-import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..) )
+import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), NewOrData(..) )
import Panic
import GlaExts
| srcloc 'data' ctype '=' constrs deriving
{% checkDataHeader $3 `thenP` \(cs,c,ts) ->
returnP (RdrHsDecl (TyClD
- (TyData DataType cs c ts (reverse $5) $6
+ (TyData DataType cs c ts (reverse $5) (length $5) $6
NoDataPragmas $1))) }
| srcloc 'newtype' ctype '=' newconstr deriving
{% checkDataHeader $3 `thenP` \(cs,c,ts) ->
returnP (RdrHsDecl (TyClD
- (TyData NewType cs c ts [$5] $6
+ (TyData NewType cs c ts [$5] 1 $6
NoDataPragmas $1))) }
| srcloc 'class' ctype fds where
{ RdrHsDecl (ForD (ForeignDecl $5 FoLabel $7 (mkExtName $4 $5)
defaultCallConv $1)) }
- | decl { $1 }
+ | '{-# DEPRECATED' deprecations '#-}' { $2 }
+ | '{-# RULES' rules '#-}' { $2 }
+ | decl { $1 }
decls :: { [RdrBinding] }
: decls ';' decl { $3 : $1 }
(map (\t -> RdrSig (SpecSig $3 t $2)) $5) }
| '{-# SPECIALISE' srcloc 'instance' inst_type '#-}'
{ RdrSig (SpecInstSig $4 $2) }
- | '{-# RULES' rules '#-}' { $2 }
- | '{-# DEPRECATED' deprecations '#-}' { $2 }
opt_phase :: { Maybe Int }
: INTEGER { Just (fromInteger $1) }
rule :: { RdrBinding }
: STRING rule_forall fexp '=' srcloc exp
- { RdrHsDecl (RuleD (RuleDecl $1 [] $2 $3 $6 $5)) }
+ { RdrHsDecl (RuleD (HsRule $1 [] $2 $3 $6 $5)) }
rule_forall :: { [RdrNameRuleBndr] }
: 'forall' rule_var_list '.' { $2 }
-- SUP: TEMPORARY HACK, not checking for `module Foo'
deprecation :: { RdrBinding }
: srcloc exportlist STRING
- { foldr1 RdrAndBindings [ RdrSig (DeprecSig (Deprecation n $3) $1) | n <- $2 ] }
+ { foldr RdrAndBindings RdrNullBind
+ [ RdrHsDecl (DeprecD (Deprecation n $3 $1)) | n <- $2 ] }
-----------------------------------------------------------------------------
-- Foreign import/export
| type { $1 }
type :: { RdrNameHsType }
- : btype '->' type { MonoFunTy $1 $3 }
- | ipvar '::' type { MonoIParamTy $1 $3 }
+ : btype '->' type { HsFunTy $1 $3 }
+ | ipvar '::' type { mkHsIParamTy $1 $3 }
| btype { $1 }
btype :: { RdrNameHsType }
- : btype atype { MonoTyApp $1 $2 }
+ : btype atype { HsAppTy $1 $2 }
| atype { $1 }
atype :: { RdrNameHsType }
- : gtycon { MonoTyVar $1 }
- | tyvar { MonoTyVar $1 }
- | '(' type ',' types ')' { MonoTupleTy ($2 : reverse $4) True }
- | '(#' types '#)' { MonoTupleTy (reverse $2) False }
- | '[' type ']' { MonoListTy $2 }
+ : gtycon { HsTyVar $1 }
+ | tyvar { HsTyVar $1 }
+ | '(' type ',' types ')' { HsTupleTy (mkHsTupCon tcName Boxed ($2:$4)) ($2 : reverse $4) }
+ | '(#' types '#)' { HsTupleTy (mkHsTupCon tcName Unboxed $2) (reverse $2) }
+ | '[' type ']' { HsListTy $2 }
| '(' ctype ')' { $2 }
gtycon :: { RdrName }
| gcon { HsVar $1 }
| literal { HsLit $1 }
| '(' exp ')' { HsPar $2 }
- | '(' exp ',' texps ')' { ExplicitTuple ($2 : reverse $4) True }
- | '(#' texps '#)' { ExplicitTuple (reverse $2) False }
+ | '(' exp ',' texps ')' { ExplicitTuple ($2 : reverse $4) Boxed}
+ | '(#' texps '#)' { ExplicitTuple (reverse $2) Unboxed }
| '[' list ']' { $2 }
| '(' infixexp qop ')' { SectionL $2 $3 }
| '(' qopm infixexp ')' { SectionR $2 $3 }
RdrNameRuleBndr,
RdrNameDeprecation,
RdrNameHsRecordBinds,
+ RdrNameFixitySig,
RdrBinding(..),
RdrMatch(..),
type RdrNameMonoBinds = MonoBinds RdrName RdrNamePat
type RdrNamePat = InPat RdrName
type RdrNameHsType = HsType RdrName
-type RdrNameHsTyVar = HsTyVar RdrName
+type RdrNameHsTyVar = HsTyVarBndr RdrName
type RdrNameSig = Sig RdrName
type RdrNameStmt = Stmt RdrName RdrNamePat
type RdrNameTyClDecl = TyClDecl RdrName RdrNamePat
type RdrNameRuleBndr = RuleBndr RdrName
type RdrNameRuleDecl = RuleDecl RdrName RdrNamePat
-type RdrNameDeprecation = Deprecation RdrName
+type RdrNameDeprecation = DeprecDecl RdrName
+type RdrNameFixitySig = FixitySig RdrName
type RdrNameHsRecordBinds = HsRecordBinds RdrName RdrNamePat
extract_tys tys acc = foldr extract_ty acc tys
-extract_ty (MonoTyApp ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
-extract_ty (MonoListTy ty) acc = extract_ty ty acc
-extract_ty (MonoTupleTy tys _) acc = foldr extract_ty acc tys
-extract_ty (MonoFunTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
-extract_ty (MonoIParamTy n ty) acc = extract_ty ty acc
-extract_ty (MonoDictTy cls tys) acc = foldr extract_ty (cls : acc) tys
-extract_ty (MonoUsgTy usg ty) acc = extract_ty ty acc
-extract_ty (MonoUsgForAllTy uv ty) acc = extract_ty ty acc
-extract_ty (MonoTyVar tv) acc = tv : acc
+extract_ty (HsAppTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
+extract_ty (HsListTy ty) acc = extract_ty ty acc
+extract_ty (HsTupleTy _ tys) acc = foldr extract_ty acc tys
+extract_ty (HsFunTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
+extract_ty (HsPredTy p) acc = extract_pred p acc
+extract_ty (HsUsgTy usg ty) acc = extract_ty ty acc
+extract_ty (HsUsgForAllTy uv ty) acc = extract_ty ty acc
+extract_ty (HsTyVar tv) acc = tv : acc
extract_ty (HsForAllTy Nothing ctxt ty) acc = extract_ctxt ctxt (extract_ty ty acc)
extract_ty (HsForAllTy (Just tvs) ctxt ty)
acc = acc ++
cvInstDeclSig sig = sig
cvClassOpSig (Sig var poly_ty src_loc) = ClassOpSig var (panic "cvClassOpSig:dm_name")
- (panic "cvClassOpSig:dm_present")
+ False
poly_ty src_loc
cvClassOpSig sig = sig
\end{code}
\begin{code}
module PrelInfo (
- module ThinAir,
+ module PrelNames,
module MkId,
builtinNames, -- Names of things whose *unique* must be known, but
-- deriving(C) clause
- -- Random other things
- main_NAME, ioTyCon_NAME,
- deRefStablePtr_NAME, makeStablePtr_NAME,
- bindIO_NAME, returnIO_NAME,
+
+ -- Primop RdrNames
+ eqH_Char_RDR, ltH_Char_RDR, eqH_Word_RDR, ltH_Word_RDR,
+ eqH_Addr_RDR, ltH_Addr_RDR, eqH_Float_RDR, ltH_Float_RDR,
+ eqH_Double_RDR, ltH_Double_RDR, eqH_Int_RDR, ltH_Int_RDR,
+ geH_RDR, leH_RDR, minusH_RDR, tagToEnumH_RDR,
+ -- Random other things
maybeCharLikeCon, maybeIntLikeCon,
needsDataDeclCtxtClassKeys, cCallishClassKeys, cCallishTyKeys,
isNoDictClass, isNumericClass, isStandardClass, isCcallishClass,
isCreturnableClass, numericTyKeys, fractionalClassKeys,
- -- RdrNames for lots of things, mainly used in derivings
- eq_RDR, ne_RDR, le_RDR, lt_RDR, ge_RDR, gt_RDR, max_RDR, min_RDR,
- compare_RDR, minBound_RDR, maxBound_RDR, enumFrom_RDR, enumFromTo_RDR,
- enumFromThen_RDR, enumFromThenTo_RDR, succ_RDR, pred_RDR, fromEnum_RDR, toEnum_RDR,
- ratioDataCon_RDR, range_RDR, index_RDR, inRange_RDR, readsPrec_RDR,
- readList_RDR, showsPrec_RDR, showList_RDR, plus_RDR, times_RDR,
- ltTag_RDR, eqTag_RDR, gtTag_RDR, eqH_Char_RDR, ltH_Char_RDR,
- eqH_Word_RDR, ltH_Word_RDR, eqH_Addr_RDR, ltH_Addr_RDR, eqH_Float_RDR,
- ltH_Float_RDR, eqH_Double_RDR, ltH_Double_RDR, eqH_Int_RDR,
- ltH_Int_RDR, geH_RDR, leH_RDR, minusH_RDR, false_RDR, true_RDR,
- and_RDR, not_RDR, append_RDR, map_RDR, compose_RDR, mkInt_RDR,
- error_RDR, assertErr_RDR, getTag_RDR, tagToEnumH_RDR,
- showString_RDR, showParen_RDR, readParen_RDR, lex_RDR,
- showSpace_RDR, showList___RDR, readList___RDR, negate_RDR,
-
- numClass_RDR, fractionalClass_RDR, eqClass_RDR,
- ccallableClass_RDR, creturnableClass_RDR,
- monadClass_RDR, enumClass_RDR, ordClass_RDR,
- ioDataCon_RDR,
-
- main_RDR,
-
- mkTupConRdrName, mkUbxTupConRdrName
-
) where
#include "HsVersions.h"
-
-
-- friends:
-import ThinAir -- Re-export all these
import MkId -- Ditto
+import PrelNames -- Prelude module names
-import PrelMods -- Prelude module names
import PrimOp ( PrimOp(..), allThePrimOps, primOpRdrName )
import DataCon ( DataCon, dataConId, dataConWrapId )
import PrimRep ( PrimRep(..) )
import TysWiredIn
-- others:
-import RdrName ( RdrName, mkPreludeQual )
+import RdrName ( RdrName )
import Var ( varUnique, Id )
import Name ( Name, OccName, Provenance(..),
NameSpace, tcName, clsName, varName, dataName,
mkKnownKeyGlobal,
getName, mkGlobalName, nameRdrName
)
-import RdrName ( rdrNameModule, rdrNameOcc, mkSrcQual )
import Class ( Class, classKey )
-import TyCon ( tyConDataCons, TyCon )
+import TyCon ( tyConDataConsIfAvailable, TyCon )
import Type ( funTyCon )
import Bag
+import BasicTypes ( Boxity(..) )
import Unique -- *Key stuff
import UniqFM ( UniqFM, listToUFM )
import Util ( isIn )
-- PrimOps
, listToBag (map (getName . mkPrimOpId) allThePrimOps)
- -- Thin-air ids
- , listToBag thinAirIdNames
-
-- Other names with magic keys
, listToBag knownKeyNames
]
getTyConNames :: TyCon -> Bag Name
getTyConNames tycon
= getName tycon `consBag`
- unionManyBags (map get_data_con_names (tyConDataCons tycon))
+ unionManyBags (map get_data_con_names (tyConDataConsIfAvailable tycon))
-- Synonyms return empty list of constructors
where
get_data_con_names dc = listToBag [getName (dataConId dc), -- Worker
%************************************************************************
%* *
+\subsection{RdrNames for the primops}
+%* *
+%************************************************************************
+
+These can't be in PrelNames, because we get the RdrName from the PrimOp,
+which is above PrelNames in the module hierarchy.
+
+\begin{code}
+eqH_Char_RDR = primOpRdrName CharEqOp
+ltH_Char_RDR = primOpRdrName CharLtOp
+eqH_Word_RDR = primOpRdrName WordEqOp
+ltH_Word_RDR = primOpRdrName WordLtOp
+eqH_Addr_RDR = primOpRdrName AddrEqOp
+ltH_Addr_RDR = primOpRdrName AddrLtOp
+eqH_Float_RDR = primOpRdrName FloatEqOp
+ltH_Float_RDR = primOpRdrName FloatLtOp
+eqH_Double_RDR = primOpRdrName DoubleEqOp
+ltH_Double_RDR = primOpRdrName DoubleLtOp
+eqH_Int_RDR = primOpRdrName IntEqOp
+ltH_Int_RDR = primOpRdrName IntLtOp
+geH_RDR = primOpRdrName IntGeOp
+leH_RDR = primOpRdrName IntLeOp
+minusH_RDR = primOpRdrName IntSubOp
+
+tagToEnumH_RDR = primOpRdrName TagToEnumOp
+\end{code}
+
+%************************************************************************
+%* *
\subsection{Wired in TyCons}
%* *
%************************************************************************
, word64PrimTyCon
]
-tuple_tycons = unitTyCon : [tupleTyCon i | i <- [2..37] ]
-unboxed_tuple_tycons = [unboxedTupleTyCon i | i <- [1..37] ]
+tuple_tycons = unitTyCon : [tupleTyCon Boxed i | i <- [2..37] ]
+unboxed_tuple_tycons = [tupleTyCon Unboxed i | i <- [1..37] ]
data_tycons
= [ addrTyCon
Ids, Synonyms, Classes and ClassOps with builtin keys.
\begin{code}
-ioTyCon_NAME = mkKnownKeyGlobal (ioTyCon_RDR, ioTyConKey)
-main_NAME = mkKnownKeyGlobal (main_RDR, mainKey)
-
- -- Operations needed when compiling FFI decls
-bindIO_NAME = mkKnownKeyGlobal (bindIO_RDR, bindIOIdKey)
-returnIO_NAME = mkKnownKeyGlobal (returnIO_RDR, returnIOIdKey)
-deRefStablePtr_NAME = mkKnownKeyGlobal (deRefStablePtr_RDR, deRefStablePtrIdKey)
-makeStablePtr_NAME = mkKnownKeyGlobal (makeStablePtr_RDR, makeStablePtrIdKey)
-
knownKeyNames :: [Name]
knownKeyNames
- = [main_NAME, ioTyCon_NAME]
- ++
- map mkKnownKeyGlobal
+ = map mkKnownKeyGlobal
[
-- Type constructors (synonyms especially)
- (orderingTyCon_RDR, orderingTyConKey)
+ (ioTyCon_RDR, ioTyConKey)
+ , (main_RDR, mainKey)
+ , (orderingTyCon_RDR, orderingTyConKey)
, (rationalTyCon_RDR, rationalTyConKey)
, (ratioDataCon_RDR, ratioDataConKey)
, (ratioTyCon_RDR, ratioTyConKey)
, (makeStablePtr_RDR, makeStablePtrIdKey)
, (bindIO_RDR, bindIOIdKey)
, (returnIO_RDR, returnIOIdKey)
+ , (addr2Integer_RDR, addr2IntegerIdKey)
+ -- Strings and lists
, (map_RDR, mapIdKey)
, (append_RDR, appendIdKey)
+ , (unpackCString_RDR, unpackCStringIdKey)
+ , (unpackCString2_RDR, unpackCString2IdKey)
+ , (unpackCStringAppend_RDR, unpackCStringAppendIdKey)
+ , (unpackCStringFoldr_RDR, unpackCStringFoldrIdKey)
-- List operations
, (concat_RDR, concatIdKey)
, (filter_RDR, filterIdKey)
, (zip_RDR, zipIdKey)
+ , (foldr_RDR, foldrIdKey)
, (build_RDR, buildIdKey)
, (augment_RDR, augmentIdKey)
\begin{code}
maybeCharLikeCon, maybeIntLikeCon :: DataCon -> Bool
-maybeCharLikeCon con = getUnique con == charDataConKey
-maybeIntLikeCon con = getUnique con == intDataConKey
+maybeCharLikeCon con = con `hasKey` charDataConKey
+maybeIntLikeCon con = con `hasKey` intDataConKey
\end{code}
%************************************************************************
%* *
-\subsection{Commonly-used RdrNames}
-%* *
-%************************************************************************
-
-These RdrNames are not really "built in", but some parts of the compiler
-(notably the deriving mechanism) need to mention their names, and it's convenient
-to write them all down in one place.
-
-\begin{code}
-main_RDR = varQual mAIN_Name SLIT("main")
-otherwiseId_RDR = varQual pREL_BASE_Name SLIT("otherwise")
-
-intTyCon_RDR = nameRdrName (getName intTyCon)
-ioTyCon_RDR = tcQual pREL_IO_BASE_Name SLIT("IO")
-ioDataCon_RDR = dataQual pREL_IO_BASE_Name SLIT("IO")
-bindIO_RDR = varQual pREL_IO_BASE_Name SLIT("bindIO")
-returnIO_RDR = varQual pREL_IO_BASE_Name SLIT("returnIO")
-
-orderingTyCon_RDR = tcQual pREL_BASE_Name SLIT("Ordering")
-
-rationalTyCon_RDR = tcQual pREL_REAL_Name SLIT("Rational")
-ratioTyCon_RDR = tcQual pREL_REAL_Name SLIT("Ratio")
-ratioDataCon_RDR = dataQual pREL_REAL_Name SLIT(":%")
-
-byteArrayTyCon_RDR = tcQual pREL_BYTEARR_Name SLIT("ByteArray")
-mutableByteArrayTyCon_RDR = tcQual pREL_BYTEARR_Name SLIT("MutableByteArray")
-
-foreignObjTyCon_RDR = tcQual pREL_IO_BASE_Name SLIT("ForeignObj")
-stablePtrTyCon_RDR = tcQual pREL_STABLE_Name SLIT("StablePtr")
-stablePtrDataCon_RDR = dataQual pREL_STABLE_Name SLIT("StablePtr")
-deRefStablePtr_RDR = varQual pREL_STABLE_Name SLIT("deRefStablePtr")
-makeStablePtr_RDR = varQual pREL_STABLE_Name SLIT("makeStablePtr")
-
--- Random PrelBase data constructors
-mkInt_RDR = dataQual pREL_BASE_Name SLIT("I#")
-false_RDR = dataQual pREL_BASE_Name SLIT("False")
-true_RDR = dataQual pREL_BASE_Name SLIT("True")
-
--- Random PrelBase functions
-and_RDR = varQual pREL_BASE_Name SLIT("&&")
-not_RDR = varQual pREL_BASE_Name SLIT("not")
-compose_RDR = varQual pREL_BASE_Name SLIT(".")
-append_RDR = varQual pREL_BASE_Name SLIT("++")
-map_RDR = varQual pREL_BASE_Name SLIT("map")
-build_RDR = varQual pREL_BASE_Name SLIT("build")
-augment_RDR = varQual pREL_BASE_Name SLIT("augment")
-
--- Classes Eq and Ord
-eqClass_RDR = clsQual pREL_BASE_Name SLIT("Eq")
-ordClass_RDR = clsQual pREL_BASE_Name SLIT("Ord")
-eq_RDR = varQual pREL_BASE_Name SLIT("==")
-ne_RDR = varQual pREL_BASE_Name SLIT("/=")
-le_RDR = varQual pREL_BASE_Name SLIT("<=")
-lt_RDR = varQual pREL_BASE_Name SLIT("<")
-ge_RDR = varQual pREL_BASE_Name SLIT(">=")
-gt_RDR = varQual pREL_BASE_Name SLIT(">")
-ltTag_RDR = dataQual pREL_BASE_Name SLIT("LT")
-eqTag_RDR = dataQual pREL_BASE_Name SLIT("EQ")
-gtTag_RDR = dataQual pREL_BASE_Name SLIT("GT")
-max_RDR = varQual pREL_BASE_Name SLIT("max")
-min_RDR = varQual pREL_BASE_Name SLIT("min")
-compare_RDR = varQual pREL_BASE_Name SLIT("compare")
-
--- Class Monad
-monadClass_RDR = clsQual pREL_BASE_Name SLIT("Monad")
-monadPlusClass_RDR = clsQual pREL_BASE_Name SLIT("MonadPlus")
-thenM_RDR = varQual pREL_BASE_Name SLIT(">>=")
-returnM_RDR = varQual pREL_BASE_Name SLIT("return")
-failM_RDR = varQual pREL_BASE_Name SLIT("fail")
-
--- Class Functor
-functorClass_RDR = clsQual pREL_BASE_Name SLIT("Functor")
-
--- Class Show
-showClass_RDR = clsQual pREL_SHOW_Name SLIT("Show")
-showList___RDR = varQual pREL_SHOW_Name SLIT("showList__")
-showsPrec_RDR = varQual pREL_SHOW_Name SLIT("showsPrec")
-showList_RDR = varQual pREL_SHOW_Name SLIT("showList")
-showSpace_RDR = varQual pREL_SHOW_Name SLIT("showSpace")
-showString_RDR = varQual pREL_SHOW_Name SLIT("showString")
-showParen_RDR = varQual pREL_SHOW_Name SLIT("showParen")
-
-
--- Class Read
-readClass_RDR = clsQual pREL_READ_Name SLIT("Read")
-readsPrec_RDR = varQual pREL_READ_Name SLIT("readsPrec")
-readList_RDR = varQual pREL_READ_Name SLIT("readList")
-readParen_RDR = varQual pREL_READ_Name SLIT("readParen")
-lex_RDR = varQual pREL_READ_Name SLIT("lex")
-readList___RDR = varQual pREL_READ_Name SLIT("readList__")
-
-
--- Class Num
-numClass_RDR = clsQual pREL_NUM_Name SLIT("Num")
-fromInt_RDR = varQual pREL_NUM_Name SLIT("fromInt")
-fromInteger_RDR = varQual pREL_NUM_Name SLIT("fromInteger")
-minus_RDR = varQual pREL_NUM_Name SLIT("-")
-negate_RDR = varQual pREL_NUM_Name SLIT("negate")
-plus_RDR = varQual pREL_NUM_Name SLIT("+")
-times_RDR = varQual pREL_NUM_Name SLIT("*")
-
--- Other numberic classes
-realClass_RDR = clsQual pREL_REAL_Name SLIT("Real")
-integralClass_RDR = clsQual pREL_REAL_Name SLIT("Integral")
-realFracClass_RDR = clsQual pREL_REAL_Name SLIT("RealFrac")
-fractionalClass_RDR = clsQual pREL_REAL_Name SLIT("Fractional")
-fromRational_RDR = varQual pREL_REAL_Name SLIT("fromRational")
-
-floatingClass_RDR = clsQual pREL_FLOAT_Name SLIT("Floating")
-realFloatClass_RDR = clsQual pREL_FLOAT_Name SLIT("RealFloat")
-
--- Class Ix
-ixClass_RDR = clsQual pREL_ARR_Name SLIT("Ix")
-range_RDR = varQual pREL_ARR_Name SLIT("range")
-index_RDR = varQual pREL_ARR_Name SLIT("index")
-inRange_RDR = varQual pREL_ARR_Name SLIT("inRange")
-
--- Class CCallable and CReturnable
-ccallableClass_RDR = clsQual pREL_GHC_Name SLIT("CCallable")
-creturnableClass_RDR = clsQual pREL_GHC_Name SLIT("CReturnable")
-
--- Class Enum
-enumClass_RDR = clsQual pREL_ENUM_Name SLIT("Enum")
-succ_RDR = varQual pREL_ENUM_Name SLIT("succ")
-pred_RDR = varQual pREL_ENUM_Name SLIT("pred")
-toEnum_RDR = varQual pREL_ENUM_Name SLIT("toEnum")
-fromEnum_RDR = varQual pREL_ENUM_Name SLIT("fromEnum")
-enumFrom_RDR = varQual pREL_ENUM_Name SLIT("enumFrom")
-enumFromTo_RDR = varQual pREL_ENUM_Name SLIT("enumFromTo")
-enumFromThen_RDR = varQual pREL_ENUM_Name SLIT("enumFromThen")
-enumFromThenTo_RDR = varQual pREL_ENUM_Name SLIT("enumFromThenTo")
-
--- Class Bounded
-boundedClass_RDR = clsQual pREL_ENUM_Name SLIT("Bounded")
-minBound_RDR = varQual pREL_ENUM_Name SLIT("minBound")
-maxBound_RDR = varQual pREL_ENUM_Name SLIT("maxBound")
-
-
--- List functions
-concat_RDR = varQual pREL_LIST_Name SLIT("concat")
-filter_RDR = varQual pREL_LIST_Name SLIT("filter")
-zip_RDR = varQual pREL_LIST_Name SLIT("zip")
-
-int8TyCon_RDR = tcQual iNT_Name SLIT("Int8")
-int16TyCon_RDR = tcQual iNT_Name SLIT("Int16")
-int32TyCon_RDR = tcQual iNT_Name SLIT("Int32")
-int64TyCon_RDR = tcQual pREL_ADDR_Name SLIT("Int64")
-
-word8TyCon_RDR = tcQual wORD_Name SLIT("Word8")
-word16TyCon_RDR = tcQual wORD_Name SLIT("Word16")
-word32TyCon_RDR = tcQual wORD_Name SLIT("Word32")
-word64TyCon_RDR = tcQual pREL_ADDR_Name SLIT("Word64")
-
-error_RDR = varQual pREL_ERR_Name SLIT("error")
-assert_RDR = varQual pREL_GHC_Name SLIT("assert")
-assertErr_RDR = varQual pREL_ERR_Name SLIT("assertError")
-runSTRep_RDR = varQual pREL_ST_Name SLIT("runSTRep")
-
-eqH_Char_RDR = primOpRdrName CharEqOp
-ltH_Char_RDR = primOpRdrName CharLtOp
-eqH_Word_RDR = primOpRdrName WordEqOp
-ltH_Word_RDR = primOpRdrName WordLtOp
-eqH_Addr_RDR = primOpRdrName AddrEqOp
-ltH_Addr_RDR = primOpRdrName AddrLtOp
-eqH_Float_RDR = primOpRdrName FloatEqOp
-ltH_Float_RDR = primOpRdrName FloatLtOp
-eqH_Double_RDR = primOpRdrName DoubleEqOp
-ltH_Double_RDR = primOpRdrName DoubleLtOp
-eqH_Int_RDR = primOpRdrName IntEqOp
-ltH_Int_RDR = primOpRdrName IntLtOp
-geH_RDR = primOpRdrName IntGeOp
-leH_RDR = primOpRdrName IntLeOp
-minusH_RDR = primOpRdrName IntSubOp
-
-tagToEnumH_RDR = primOpRdrName TagToEnumOp
-getTag_RDR = varQual pREL_GHC_Name SLIT("getTag#")
-\end{code}
-
-\begin{code}
-mkTupConRdrName :: Int -> RdrName
-mkTupConRdrName arity = case mkTupNameStr arity of
- (mod, occ) -> dataQual mod occ
-
-mkUbxTupConRdrName :: Int -> RdrName
-mkUbxTupConRdrName arity = case mkUbxTupNameStr arity of
- (mod, occ) -> dataQual mod occ
-\end{code}
-
-
-%************************************************************************
-%* *
\subsection[Class-std-groups]{Standard groups of Prelude classes}
%* *
%************************************************************************
= cCallishClassKeys
\end{code}
-
-%************************************************************************
-%* *
-\subsection{Local helpers}
-%* *
-%************************************************************************
-
-\begin{code}
-varQual = mkPreludeQual varName
-dataQual = mkPreludeQual dataName
-tcQual = mkPreludeQual tcName
-clsQual = mkPreludeQual clsName
-\end{code}
-
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
-\section[PrelMods]{Definitions of prelude modules}
-
-The strings identify built-in prelude modules. They are
-defined here so as to avod
-
-[oh dear, looks like the recursive module monster caught up with
- and gobbled whoever was writing the above :-) -- SOF ]
-
-\begin{code}
-module PrelMods
- (
- mkTupNameStr, mkUbxTupNameStr,
-
- pREL_GHC, pREL_BASE, pREL_ADDR, pREL_STABLE,
- pREL_IO_BASE, pREL_PACK, pREL_ERR, pREL_NUM, pREL_FLOAT, pREL_REAL,
-
- pREL_GHC_Name, pRELUDE_Name,
- mAIN_Name, pREL_MAIN_Name, pREL_ERR_Name,
- pREL_BASE_Name, pREL_NUM_Name, pREL_LIST_Name,
- pREL_TUP_Name, pREL_ADDR_Name, pREL_READ_Name,
- pREL_PACK_Name, pREL_CONC_Name, pREL_IO_BASE_Name,
- pREL_ST_Name, pREL_ARR_Name, pREL_BYTEARR_Name, pREL_FOREIGN_Name,
- pREL_STABLE_Name, pREL_SHOW_Name, pREL_ENUM_Name, iNT_Name, wORD_Name,
- pREL_REAL_Name, pREL_FLOAT_Name
- ) where
-
-#include "HsVersions.h"
-
-import Module ( Module, ModuleName, mkPrelModule, mkSrcModule )
-import Util ( nOfThem )
-import Panic ( panic )
-\end{code}
-
-\begin{code}
-pRELUDE_Name = mkSrcModule "Prelude"
-pREL_GHC_Name = mkSrcModule "PrelGHC" -- Primitive types and values
-pREL_BASE_Name = mkSrcModule "PrelBase"
-pREL_ENUM_Name = mkSrcModule "PrelEnum"
-pREL_SHOW_Name = mkSrcModule "PrelShow"
-pREL_READ_Name = mkSrcModule "PrelRead"
-pREL_NUM_Name = mkSrcModule "PrelNum"
-pREL_LIST_Name = mkSrcModule "PrelList"
-pREL_TUP_Name = mkSrcModule "PrelTup"
-pREL_PACK_Name = mkSrcModule "PrelPack"
-pREL_CONC_Name = mkSrcModule "PrelConc"
-pREL_IO_BASE_Name = mkSrcModule "PrelIOBase"
-pREL_ST_Name = mkSrcModule "PrelST"
-pREL_ARR_Name = mkSrcModule "PrelArr"
-pREL_BYTEARR_Name = mkSrcModule "PrelByteArr"
-pREL_FOREIGN_Name = mkSrcModule "PrelForeign"
-pREL_STABLE_Name = mkSrcModule "PrelStable"
-pREL_ADDR_Name = mkSrcModule "PrelAddr"
-pREL_ERR_Name = mkSrcModule "PrelErr"
-pREL_REAL_Name = mkSrcModule "PrelReal"
-pREL_FLOAT_Name = mkSrcModule "PrelFloat"
-
-pREL_MAIN_Name = mkSrcModule "PrelMain"
-mAIN_Name = mkSrcModule "Main"
-iNT_Name = mkSrcModule "Int"
-wORD_Name = mkSrcModule "Word"
-
-pREL_GHC = mkPrelModule pREL_GHC_Name
-pREL_BASE = mkPrelModule pREL_BASE_Name
-pREL_ADDR = mkPrelModule pREL_ADDR_Name
-pREL_STABLE = mkPrelModule pREL_STABLE_Name
-pREL_IO_BASE = mkPrelModule pREL_IO_BASE_Name
-pREL_PACK = mkPrelModule pREL_PACK_Name
-pREL_ERR = mkPrelModule pREL_ERR_Name
-pREL_NUM = mkPrelModule pREL_NUM_Name
-pREL_REAL = mkPrelModule pREL_REAL_Name
-pREL_FLOAT = mkPrelModule pREL_FLOAT_Name
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Constructing the names of tuples
-%* *
-%************************************************************************
-
-\begin{code}
-mkTupNameStr, mkUbxTupNameStr :: Int -> (ModuleName, FAST_STRING)
-
-mkTupNameStr 0 = (pREL_BASE_Name, SLIT("()"))
-mkTupNameStr 1 = panic "Name.mkTupNameStr: 1 ???"
-mkTupNameStr 2 = (pREL_TUP_Name, _PK_ "(,)") -- not strictly necessary
-mkTupNameStr 3 = (pREL_TUP_Name, _PK_ "(,,)") -- ditto
-mkTupNameStr 4 = (pREL_TUP_Name, _PK_ "(,,,)") -- ditto
-mkTupNameStr n = (pREL_TUP_Name, _PK_ ("(" ++ nOfThem (n-1) ',' ++ ")"))
-
-mkUbxTupNameStr 0 = panic "Name.mkUbxTupNameStr: 0 ???"
-mkUbxTupNameStr 1 = (pREL_GHC_Name, _PK_ "(# #)") -- 1 and 0 both make sense!!!
-mkUbxTupNameStr 2 = (pREL_GHC_Name, _PK_ "(#,#)")
-mkUbxTupNameStr 3 = (pREL_GHC_Name, _PK_ "(#,,#)")
-mkUbxTupNameStr 4 = (pREL_GHC_Name, _PK_ "(#,,,#)")
-mkUbxTupNameStr n = (pREL_GHC_Name, _PK_ ("(#" ++ nOfThem (n-1) ',' ++ "#)"))
-\end{code}
-
-
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section[PrelNames]{Definitions of prelude modules}
+
+The strings identify built-in prelude modules. They are
+defined here so as to avod
+
+[oh dear, looks like the recursive module monster caught up with
+ and gobbled whoever was writing the above :-) -- SOF ]
+
+\begin{code}
+module PrelNames
+ (
+ -- Prelude modules
+ pREL_GHC, pREL_BASE, pREL_ADDR, pREL_STABLE,
+ pREL_IO_BASE, pREL_PACK, pREL_ERR, pREL_NUM, pREL_FLOAT, pREL_REAL,
+
+ -- Module names (both Prelude and otherwise)
+ pREL_GHC_Name, pRELUDE_Name,
+ mAIN_Name, pREL_MAIN_Name, pREL_ERR_Name,
+ pREL_BASE_Name, pREL_NUM_Name, pREL_LIST_Name,
+ pREL_TUP_Name, pREL_ADDR_Name, pREL_READ_Name,
+ pREL_PACK_Name, pREL_CONC_Name, pREL_IO_BASE_Name,
+ pREL_ST_Name, pREL_ARR_Name, pREL_BYTEARR_Name, pREL_FOREIGN_Name,
+ pREL_STABLE_Name, pREL_SHOW_Name, pREL_ENUM_Name, iNT_Name, wORD_Name,
+ pREL_REAL_Name, pREL_FLOAT_Name,
+
+ -- RdrNames for lots of things, mainly used in derivings
+ eq_RDR, ne_RDR, le_RDR, lt_RDR, ge_RDR, gt_RDR, max_RDR, min_RDR,
+ compare_RDR, minBound_RDR, maxBound_RDR, enumFrom_RDR, enumFromTo_RDR,
+ enumFromThen_RDR, enumFromThenTo_RDR, succ_RDR, pred_RDR, fromEnum_RDR, toEnum_RDR,
+ ratioDataCon_RDR, range_RDR, index_RDR, inRange_RDR, readsPrec_RDR,
+ readList_RDR, showsPrec_RDR, showList_RDR, plus_RDR, times_RDR,
+ ltTag_RDR, eqTag_RDR, gtTag_RDR, false_RDR, true_RDR,
+ and_RDR, not_RDR, append_RDR, map_RDR, compose_RDR, mkInt_RDR,
+ error_RDR, assertErr_RDR,
+ showString_RDR, showParen_RDR, readParen_RDR, lex_RDR,
+ showSpace_RDR, showList___RDR, readList___RDR, negate_RDR,
+ addr2Integer_RDR, ioTyCon_RDR,
+ foldr_RDR, build_RDR, getTag_RDR,
+
+ orderingTyCon_RDR, rationalTyCon_RDR, ratioTyCon_RDR, byteArrayTyCon_RDR,
+ mutableByteArrayTyCon_RDR, foreignObjTyCon_RDR,
+ intTyCon_RDR, stablePtrTyCon_RDR, stablePtrDataCon_RDR,
+ int8TyCon_RDR, int16TyCon_RDR, int32TyCon_RDR, int64TyCon_RDR,
+ word8TyCon_RDR, word16TyCon_RDR, word32TyCon_RDR, word64TyCon_RDR,
+
+ boundedClass_RDR, monadPlusClass_RDR, functorClass_RDR, showClass_RDR,
+ realClass_RDR, integralClass_RDR, floatingClass_RDR, realFracClass_RDR,
+ realFloatClass_RDR, readClass_RDR, ixClass_RDR,
+ fromInt_RDR, fromInteger_RDR, minus_RDR, fromRational_RDR,
+
+ bindIO_RDR, returnIO_RDR, thenM_RDR, returnM_RDR, failM_RDR,
+
+ deRefStablePtr_RDR, makeStablePtr_RDR,
+ concat_RDR, filter_RDR, zip_RDR, augment_RDR,
+ otherwiseId_RDR, assert_RDR, runSTRep_RDR,
+
+ unpackCString_RDR, unpackCString2_RDR, unpackCStringAppend_RDR, unpackCStringFoldr_RDR,
+ numClass_RDR, fractionalClass_RDR, eqClass_RDR,
+ ccallableClass_RDR, creturnableClass_RDR,
+ monadClass_RDR, enumClass_RDR, ordClass_RDR,
+ ioDataCon_RDR,
+
+ main_RDR,
+
+ mkTupNameStr, mkTupConRdrName
+
+ ) where
+
+#include "HsVersions.h"
+
+import Module ( Module, ModuleName, mkPrelModule, mkSrcModule )
+import OccName ( NameSpace, varName, dataName, tcName, clsName )
+import RdrName ( RdrName, mkPreludeQual )
+import BasicTypes ( Boxity(..), Arity )
+import Util ( nOfThem )
+import Panic ( panic )
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Module names}
+%* *
+%************************************************************************
+
+\begin{code}
+pRELUDE_Name = mkSrcModule "Prelude"
+pREL_GHC_Name = mkSrcModule "PrelGHC" -- Primitive types and values
+pREL_BASE_Name = mkSrcModule "PrelBase"
+pREL_ENUM_Name = mkSrcModule "PrelEnum"
+pREL_SHOW_Name = mkSrcModule "PrelShow"
+pREL_READ_Name = mkSrcModule "PrelRead"
+pREL_NUM_Name = mkSrcModule "PrelNum"
+pREL_LIST_Name = mkSrcModule "PrelList"
+pREL_TUP_Name = mkSrcModule "PrelTup"
+pREL_PACK_Name = mkSrcModule "PrelPack"
+pREL_CONC_Name = mkSrcModule "PrelConc"
+pREL_IO_BASE_Name = mkSrcModule "PrelIOBase"
+pREL_ST_Name = mkSrcModule "PrelST"
+pREL_ARR_Name = mkSrcModule "PrelArr"
+pREL_BYTEARR_Name = mkSrcModule "PrelByteArr"
+pREL_FOREIGN_Name = mkSrcModule "PrelForeign"
+pREL_STABLE_Name = mkSrcModule "PrelStable"
+pREL_ADDR_Name = mkSrcModule "PrelAddr"
+pREL_ERR_Name = mkSrcModule "PrelErr"
+pREL_REAL_Name = mkSrcModule "PrelReal"
+pREL_FLOAT_Name = mkSrcModule "PrelFloat"
+
+pREL_MAIN_Name = mkSrcModule "PrelMain"
+mAIN_Name = mkSrcModule "Main"
+iNT_Name = mkSrcModule "Int"
+wORD_Name = mkSrcModule "Word"
+
+pREL_GHC = mkPrelModule pREL_GHC_Name
+pREL_BASE = mkPrelModule pREL_BASE_Name
+pREL_ADDR = mkPrelModule pREL_ADDR_Name
+pREL_STABLE = mkPrelModule pREL_STABLE_Name
+pREL_IO_BASE = mkPrelModule pREL_IO_BASE_Name
+pREL_PACK = mkPrelModule pREL_PACK_Name
+pREL_ERR = mkPrelModule pREL_ERR_Name
+pREL_NUM = mkPrelModule pREL_NUM_Name
+pREL_REAL = mkPrelModule pREL_REAL_Name
+pREL_FLOAT = mkPrelModule pREL_FLOAT_Name
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Constructing the names of tuples
+%* *
+%************************************************************************
+
+\begin{code}
+mkTupNameStr :: Boxity -> Int -> (ModuleName, FAST_STRING)
+
+mkTupNameStr Boxed 0 = (pREL_BASE_Name, SLIT("()"))
+mkTupNameStr Boxed 1 = panic "Name.mkTupNameStr: 1 ???"
+mkTupNameStr Boxed 2 = (pREL_TUP_Name, _PK_ "(,)") -- not strictly necessary
+mkTupNameStr Boxed 3 = (pREL_TUP_Name, _PK_ "(,,)") -- ditto
+mkTupNameStr Boxed 4 = (pREL_TUP_Name, _PK_ "(,,,)") -- ditto
+mkTupNameStr Boxed n = (pREL_TUP_Name, _PK_ ("(" ++ nOfThem (n-1) ',' ++ ")"))
+
+mkTupNameStr Unboxed 0 = panic "Name.mkUbxTupNameStr: 0 ???"
+mkTupNameStr Unboxed 1 = (pREL_GHC_Name, _PK_ "(# #)") -- 1 and 0 both make sense!!!
+mkTupNameStr Unboxed 2 = (pREL_GHC_Name, _PK_ "(#,#)")
+mkTupNameStr Unboxed 3 = (pREL_GHC_Name, _PK_ "(#,,#)")
+mkTupNameStr Unboxed 4 = (pREL_GHC_Name, _PK_ "(#,,,#)")
+mkTupNameStr Unboxed n = (pREL_GHC_Name, _PK_ ("(#" ++ nOfThem (n-1) ',' ++ "#)"))
+
+mkTupConRdrName :: NameSpace -> Boxity -> Arity -> RdrName
+mkTupConRdrName space boxity arity = case mkTupNameStr boxity arity of
+ (mod, occ) -> mkPreludeQual space mod occ
+\end{code}
+
+
+
+%************************************************************************
+%* *
+\subsection{Commonly-used RdrNames}
+%* *
+%************************************************************************
+
+These RdrNames are not really "built in", but some parts of the compiler
+(notably the deriving mechanism) need to mention their names, and it's convenient
+to write them all down in one place.
+
+\begin{code}
+main_RDR = varQual mAIN_Name SLIT("main")
+
+ioTyCon_RDR = tcQual pREL_IO_BASE_Name SLIT("IO")
+ioDataCon_RDR = dataQual pREL_IO_BASE_Name SLIT("IO")
+bindIO_RDR = varQual pREL_IO_BASE_Name SLIT("bindIO")
+returnIO_RDR = varQual pREL_IO_BASE_Name SLIT("returnIO")
+
+
+rationalTyCon_RDR = tcQual pREL_REAL_Name SLIT("Rational")
+ratioTyCon_RDR = tcQual pREL_REAL_Name SLIT("Ratio")
+ratioDataCon_RDR = dataQual pREL_REAL_Name SLIT(":%")
+
+byteArrayTyCon_RDR = tcQual pREL_BYTEARR_Name SLIT("ByteArray")
+mutableByteArrayTyCon_RDR = tcQual pREL_BYTEARR_Name SLIT("MutableByteArray")
+
+foreignObjTyCon_RDR = tcQual pREL_IO_BASE_Name SLIT("ForeignObj")
+stablePtrTyCon_RDR = tcQual pREL_STABLE_Name SLIT("StablePtr")
+stablePtrDataCon_RDR = dataQual pREL_STABLE_Name SLIT("StablePtr")
+deRefStablePtr_RDR = varQual pREL_STABLE_Name SLIT("deRefStablePtr")
+makeStablePtr_RDR = varQual pREL_STABLE_Name SLIT("makeStablePtr")
+
+-- Random PrelBase data types and constructors
+intTyCon_RDR = tcQual pREL_BASE_Name SLIT("Int")
+orderingTyCon_RDR = tcQual pREL_BASE_Name SLIT("Ordering")
+mkInt_RDR = dataQual pREL_BASE_Name SLIT("I#")
+false_RDR = dataQual pREL_BASE_Name SLIT("False")
+true_RDR = dataQual pREL_BASE_Name SLIT("True")
+
+-- Random PrelBase functions
+otherwiseId_RDR = varQual pREL_BASE_Name SLIT("otherwise")
+and_RDR = varQual pREL_BASE_Name SLIT("&&")
+not_RDR = varQual pREL_BASE_Name SLIT("not")
+compose_RDR = varQual pREL_BASE_Name SLIT(".")
+append_RDR = varQual pREL_BASE_Name SLIT("++")
+foldr_RDR = varQual pREL_BASE_Name SLIT("foldr")
+map_RDR = varQual pREL_BASE_Name SLIT("map")
+build_RDR = varQual pREL_BASE_Name SLIT("build")
+augment_RDR = varQual pREL_BASE_Name SLIT("augment")
+
+-- Strings
+unpackCString_RDR = varQual pREL_BASE_Name SLIT("unpackCString#")
+unpackCString2_RDR = varQual pREL_BASE_Name SLIT("unpackNBytes#")
+unpackCStringAppend_RDR = varQual pREL_BASE_Name SLIT("unpackAppendCString#")
+unpackCStringFoldr_RDR = varQual pREL_BASE_Name SLIT("unpackFoldrCString#")
+
+-- Classes Eq and Ord
+eqClass_RDR = clsQual pREL_BASE_Name SLIT("Eq")
+ordClass_RDR = clsQual pREL_BASE_Name SLIT("Ord")
+eq_RDR = varQual pREL_BASE_Name SLIT("==")
+ne_RDR = varQual pREL_BASE_Name SLIT("/=")
+le_RDR = varQual pREL_BASE_Name SLIT("<=")
+lt_RDR = varQual pREL_BASE_Name SLIT("<")
+ge_RDR = varQual pREL_BASE_Name SLIT(">=")
+gt_RDR = varQual pREL_BASE_Name SLIT(">")
+ltTag_RDR = dataQual pREL_BASE_Name SLIT("LT")
+eqTag_RDR = dataQual pREL_BASE_Name SLIT("EQ")
+gtTag_RDR = dataQual pREL_BASE_Name SLIT("GT")
+max_RDR = varQual pREL_BASE_Name SLIT("max")
+min_RDR = varQual pREL_BASE_Name SLIT("min")
+compare_RDR = varQual pREL_BASE_Name SLIT("compare")
+
+-- Class Monad
+monadClass_RDR = clsQual pREL_BASE_Name SLIT("Monad")
+monadPlusClass_RDR = clsQual pREL_BASE_Name SLIT("MonadPlus")
+thenM_RDR = varQual pREL_BASE_Name SLIT(">>=")
+returnM_RDR = varQual pREL_BASE_Name SLIT("return")
+failM_RDR = varQual pREL_BASE_Name SLIT("fail")
+
+-- Class Functor
+functorClass_RDR = clsQual pREL_BASE_Name SLIT("Functor")
+
+-- Class Show
+showClass_RDR = clsQual pREL_SHOW_Name SLIT("Show")
+showList___RDR = varQual pREL_SHOW_Name SLIT("showList__")
+showsPrec_RDR = varQual pREL_SHOW_Name SLIT("showsPrec")
+showList_RDR = varQual pREL_SHOW_Name SLIT("showList")
+showSpace_RDR = varQual pREL_SHOW_Name SLIT("showSpace")
+showString_RDR = varQual pREL_SHOW_Name SLIT("showString")
+showParen_RDR = varQual pREL_SHOW_Name SLIT("showParen")
+
+
+-- Class Read
+readClass_RDR = clsQual pREL_READ_Name SLIT("Read")
+readsPrec_RDR = varQual pREL_READ_Name SLIT("readsPrec")
+readList_RDR = varQual pREL_READ_Name SLIT("readList")
+readParen_RDR = varQual pREL_READ_Name SLIT("readParen")
+lex_RDR = varQual pREL_READ_Name SLIT("lex")
+readList___RDR = varQual pREL_READ_Name SLIT("readList__")
+
+
+-- Class Num
+numClass_RDR = clsQual pREL_NUM_Name SLIT("Num")
+fromInt_RDR = varQual pREL_NUM_Name SLIT("fromInt")
+fromInteger_RDR = varQual pREL_NUM_Name SLIT("fromInteger")
+minus_RDR = varQual pREL_NUM_Name SLIT("-")
+negate_RDR = varQual pREL_NUM_Name SLIT("negate")
+plus_RDR = varQual pREL_NUM_Name SLIT("+")
+times_RDR = varQual pREL_NUM_Name SLIT("*")
+addr2Integer_RDR = varQual pREL_NUM_Name SLIT("addr2Integer")
+
+-- Other numberic classes
+realClass_RDR = clsQual pREL_REAL_Name SLIT("Real")
+integralClass_RDR = clsQual pREL_REAL_Name SLIT("Integral")
+realFracClass_RDR = clsQual pREL_REAL_Name SLIT("RealFrac")
+fractionalClass_RDR = clsQual pREL_REAL_Name SLIT("Fractional")
+fromRational_RDR = varQual pREL_REAL_Name SLIT("fromRational")
+
+floatingClass_RDR = clsQual pREL_FLOAT_Name SLIT("Floating")
+realFloatClass_RDR = clsQual pREL_FLOAT_Name SLIT("RealFloat")
+
+-- Class Ix
+ixClass_RDR = clsQual pREL_ARR_Name SLIT("Ix")
+range_RDR = varQual pREL_ARR_Name SLIT("range")
+index_RDR = varQual pREL_ARR_Name SLIT("index")
+inRange_RDR = varQual pREL_ARR_Name SLIT("inRange")
+
+-- Class CCallable and CReturnable
+ccallableClass_RDR = clsQual pREL_GHC_Name SLIT("CCallable")
+creturnableClass_RDR = clsQual pREL_GHC_Name SLIT("CReturnable")
+
+-- Class Enum
+enumClass_RDR = clsQual pREL_ENUM_Name SLIT("Enum")
+succ_RDR = varQual pREL_ENUM_Name SLIT("succ")
+pred_RDR = varQual pREL_ENUM_Name SLIT("pred")
+toEnum_RDR = varQual pREL_ENUM_Name SLIT("toEnum")
+fromEnum_RDR = varQual pREL_ENUM_Name SLIT("fromEnum")
+enumFrom_RDR = varQual pREL_ENUM_Name SLIT("enumFrom")
+enumFromTo_RDR = varQual pREL_ENUM_Name SLIT("enumFromTo")
+enumFromThen_RDR = varQual pREL_ENUM_Name SLIT("enumFromThen")
+enumFromThenTo_RDR = varQual pREL_ENUM_Name SLIT("enumFromThenTo")
+
+-- Class Bounded
+boundedClass_RDR = clsQual pREL_ENUM_Name SLIT("Bounded")
+minBound_RDR = varQual pREL_ENUM_Name SLIT("minBound")
+maxBound_RDR = varQual pREL_ENUM_Name SLIT("maxBound")
+
+
+-- List functions
+concat_RDR = varQual pREL_LIST_Name SLIT("concat")
+filter_RDR = varQual pREL_LIST_Name SLIT("filter")
+zip_RDR = varQual pREL_LIST_Name SLIT("zip")
+
+int8TyCon_RDR = tcQual iNT_Name SLIT("Int8")
+int16TyCon_RDR = tcQual iNT_Name SLIT("Int16")
+int32TyCon_RDR = tcQual iNT_Name SLIT("Int32")
+int64TyCon_RDR = tcQual pREL_ADDR_Name SLIT("Int64")
+
+word8TyCon_RDR = tcQual wORD_Name SLIT("Word8")
+word16TyCon_RDR = tcQual wORD_Name SLIT("Word16")
+word32TyCon_RDR = tcQual wORD_Name SLIT("Word32")
+word64TyCon_RDR = tcQual pREL_ADDR_Name SLIT("Word64")
+
+error_RDR = varQual pREL_ERR_Name SLIT("error")
+assert_RDR = varQual pREL_GHC_Name SLIT("assert")
+getTag_RDR = varQual pREL_GHC_Name SLIT("getTag#")
+assertErr_RDR = varQual pREL_ERR_Name SLIT("assertError")
+runSTRep_RDR = varQual pREL_ST_Name SLIT("runSTRep")
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Local helpers}
+%* *
+%************************************************************************
+
+\begin{code}
+varQual = mkPreludeQual varName
+dataQual = mkPreludeQual dataName
+tcQual = mkPreludeQual tcName
+clsQual = mkPreludeQual clsName
+\end{code}
+
, float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit
, addr2IntLit, int2AddrLit, float2DoubleLit, double2FloatLit
)
+import RdrName ( RdrName )
import PrimOp ( PrimOp(..), primOpOcc )
import TysWiredIn ( trueDataConId, falseDataConId )
-import TyCon ( tyConDataCons, isEnumerationTyCon, isNewTyCon )
+import TyCon ( tyConDataConsIfAvailable, isEnumerationTyCon, isNewTyCon )
import DataCon ( DataCon, dataConTag, dataConRepArity, dataConTyCon, dataConId, fIRST_TAG )
import CoreUnfold ( maybeUnfoldingTemplate )
import CoreUtils ( exprIsValue, cheapEqExpr, exprIsConApp_maybe )
import Type ( splitTyConApp_maybe )
import OccName ( occNameUserString)
-import ThinAir ( unpackCStringFoldrId )
+import PrelNames ( unpackCStringFoldr_RDR )
+import Unique ( unpackCStringFoldrIdKey, hasKey )
import Maybes ( maybeToBool )
import Char ( ord, chr )
import Bits ( Bits(..) )
= BuiltinRule (primop_rule op)
where
op_name = _PK_ (occNameUserString (primOpOcc op))
- op_name_case = op_name _APPEND_ SLIT("case")
+ op_name_case = op_name _APPEND_ SLIT("->case")
-- ToDo: something for integer-shift ops?
-- NotOp
\begin{code}
tagToEnumRule [Type ty, Lit (MachInt i)]
= ASSERT( isEnumerationTyCon tycon )
- Just (SLIT("TagToEnum"), Var (dataConId dc))
+ case filter correct_tag (tyConDataConsIfAvailable tycon) of
+
+
+ [] -> Nothing -- Abstract type
+ (dc:rest) -> ASSERT( null rest )
+ Just (SLIT("TagToEnum"), Var (dataConId dc))
where
+ correct_tag dc = (dataConTag dc - fIRST_TAG) == tag
tag = fromInteger i
- constrs = tyConDataCons tycon
- (dc:_) = [ dc | dc <- constrs, tag == dataConTag dc - fIRST_TAG ]
(Just (tycon,_)) = splitTyConApp_maybe ty
tagToEnumRule other = Nothing
%************************************************************************
\begin{code}
-builtinRules :: [ProtoCoreRule]
+builtinRules :: [(RdrName, CoreRule)]
-- Rules for non-primops that can't be expressed using a RULE pragma
builtinRules
- = [ ProtoCoreRule False unpackCStringFoldrId
- (BuiltinRule match_append_lit_str)
+ = [ (unpackCStringFoldr_RDR, BuiltinRule match_append_lit_str)
]
--- unpack "foo" c (unpack "baz" c n) = unpack "foobaz" c n
+-- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n) = unpackFoldrCString# "foobaz" c n
match_append_lit_str [Type ty1,
Lit (MachStr s1),
`App` c2
`App` n
]
- | unpk == unpackCStringFoldrId &&
+ | unpk `hasKey` unpackCStringFoldrIdKey &&
c1 `cheapEqExpr` c2
= ASSERT( ty1 == ty2 )
Just (SLIT("AppendLitString"),
UsageAnn(..), mkUsgTy
)
import Unique ( Unique, mkPrimOpIdUnique )
-import BasicTypes ( Arity )
+import BasicTypes ( Arity, Boxity(..) )
import CStrings ( CLabelString, pprCLabelString )
-import PrelMods ( pREL_GHC, pREL_GHC_Name )
+import PrelNames ( pREL_GHC, pREL_GHC_Name )
import Outputable
import Util ( assoc, zipWithEqual )
import GlaExts ( Int(..), Int#, (==#) )
= [intPrimTy, byteArrayPrimTy, -- Integer
intPrimTy]
-unboxedPair = mkUnboxedTupleTy 2
-unboxedTriple = mkUnboxedTupleTy 3
-unboxedQuadruple = mkUnboxedTupleTy 4
+unboxedSingleton = mkTupleTy Unboxed 1
+unboxedPair = mkTupleTy Unboxed 2
+unboxedTriple = mkTupleTy Unboxed 3
+unboxedQuadruple = mkTupleTy Unboxed 4
mkIOTy ty = mkFunTy realWorldStatePrimTy
(unboxedPair [realWorldStatePrimTy,ty])
primOpInfo IndexArrayOp
= let { elt = alphaTy; elt_tv = alphaTyVar } in
mkGenPrimOp SLIT("indexArray#") [elt_tv] [mkArrayPrimTy elt, intPrimTy]
- (mkUnboxedTupleTy 1 [elt])
+ (unboxedSingleton [elt])
---------------------------------------------------------------------------
-- Primitive arrays full of unboxed bytes:
Nothing -> pprPanic "primOpUsg:inFun" (ppr op <+> ppr ty)
inUB fs ty = case splitTyConApp_maybe ty of
- Just (tc,tys) -> ASSERT( tc == unboxedTupleTyCon (length fs) )
- mkUnboxedTupleTy (length fs) (zipWithEqual "primOpUsg"
+ Just (tc,tys) -> ASSERT( tc == tupleTyCon Unboxed (length fs) )
+ mkTupleTy Unboxed (length fs) (zipWithEqual "primOpUsg"
($) fs tys)
Nothing -> pprPanic "primOpUsg:inUB" (ppr op <+> ppr ty)
\end{code}
Bool -- True <=> really a "casm"
Bool -- True <=> might invoke Haskell GC
CallConv -- calling convention to use.
+ deriving( Eq )
data CCallTarget
= StaticTarget CLabelString -- An "unboxed" ccall# to `fn'.
-- (unique is used to generate a 'typedef' to cast
-- the function pointer if compiling the ccall# down to
-- .hc code - can't do this inline for tedious reasons.)
+ deriving( Eq )
ccallMayGC :: CCall -> Bool
ccallMayGC (CCall _ _ may_gc _) = may_gc
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
-\section{Thin air Ids}
-
-\begin{code}
-module ThinAir (
- thinAirIdNames, -- Names of non-wired-in Ids that may be used out of
- setThinAirIds, -- thin air in any compilation. If they are not wired in
- -- we must be sure to import them from some Prelude
- -- interface file even if they are not overtly
- -- mentioned. Subset of builtinNames.
- -- Here are the thin-air Ids themselves
- addr2IntegerId,
- unpackCStringId, unpackCString2Id,
- unpackCStringAppendId, unpackCStringFoldrId,
- foldrId, buildId,
-
- noRepIntegerIds,
- noRepStrIds
-
- ) where
-
-#include "HsVersions.h"
-
-import Var ( Id, varUnique )
-import Name ( mkKnownKeyGlobal, varName )
-import RdrName ( mkPreludeQual )
-import PrelMods
-import UniqFM ( UniqFM, listToUFM, lookupWithDefaultUFM )
-import Unique
-import Outputable
-import IOExts
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Thin air entities}
-%* *
-%************************************************************************
-
-These are Ids that we need to reference in various parts of the
-system, and we'd like to pull them out of thin air rather than pass
-them around. We'd also like to have all the IdInfo available for each
-one: i.e. everything that gets pulled out of the interface file.
-
-The solution is to generate this map of global Ids after the
-typechecker, and assign it to a global variable. Any subsequent
-pass may refer to the map to pull Ids out. Any invalid
-(i.e. pre-typechecker) access to the map will result in a panic.
-
-\begin{code}
-thinAirIdNames
- = map mkKnownKeyGlobal
- [
- -- Needed for converting literals to Integers (used in tidyCoreExpr)
- (varQual pREL_NUM_Name SLIT("addr2Integer"), addr2IntegerIdKey)
-
- -- Folds and builds; introduced by desugaring list comprehensions
- , (varQual pREL_BASE_Name SLIT("unpackNBytes#"), unpackCString2IdKey)
- , (varQual pREL_BASE_Name SLIT("unpackCString#"), unpackCStringIdKey)
- , (varQual pREL_BASE_Name SLIT("unpackAppendCString#"), unpackCStringAppendIdKey)
- , (varQual pREL_BASE_Name SLIT("unpackFoldrCString#"), unpackCStringFoldrIdKey)
-
- , (varQual pREL_BASE_Name SLIT("foldr"), foldrIdKey)
- , (varQual pREL_BASE_Name SLIT("build"), buildIdKey)
- ]
-
-varQual = mkPreludeQual varName
-\end{code}
-
-
-\begin{code}
-noRepIntegerIds = [addr2IntegerId]
-
-noRepStrIds = [unpackCString2Id, unpackCStringId]
-
-addr2IntegerId = lookupThinAirId addr2IntegerIdKey
-
-unpackCStringId = lookupThinAirId unpackCStringIdKey
-unpackCString2Id = lookupThinAirId unpackCString2IdKey
-unpackCStringAppendId = lookupThinAirId unpackCStringAppendIdKey
-unpackCStringFoldrId = lookupThinAirId unpackCStringFoldrIdKey
-
-foldrId = lookupThinAirId foldrIdKey
-buildId = lookupThinAirId buildIdKey
-\end{code}
-
-\begin{code}
-{-# NOINLINE thinAirIdMapRef #-}
-thinAirIdMapRef :: IORef (UniqFM Id)
-thinAirIdMapRef = unsafePerformIO (newIORef (panic "thinAirIdMap: still empty"))
-
-setThinAirIds :: [Id] -> IO ()
-setThinAirIds thin_air_ids
- = writeIORef thinAirIdMapRef the_map
- where
- the_map = listToUFM [(varUnique id, id) | id <- thin_air_ids]
-
-thinAirIdMap :: UniqFM Id
-thinAirIdMap = unsafePerformIO (readIORef thinAirIdMapRef)
- -- Read it just once, the first time someone tugs on thinAirIdMap
-
-lookupThinAirId :: Unique -> Id
-lookupThinAirId uniq = lookupWithDefaultUFM thinAirIdMap
- (panic "lookupThinAirId: no mapping") uniq
-\end{code}
-
mkTyConApp, mkTyConTy, mkTyVarTys,
unboxedTypeKind, boxedTypeKind, openTypeKind, mkArrowKinds
)
-import PrelMods ( pREL_GHC )
+import PrelNames ( pREL_GHC )
import Outputable
import Unique
\end{code}
-- tuples
mkTupleTy,
- tupleTyCon, tupleCon, unitTyCon, unitDataConId, pairTyCon,
-
- -- unboxed tuples
- mkUnboxedTupleTy,
- unboxedTupleTyCon, unboxedTupleCon,
+ tupleTyCon, tupleCon,
+ unitTyCon, unitDataConId, pairTyCon,
+ unboxedSingletonTyCon, unboxedSingletonDataCon,
unboxedPairTyCon, unboxedPairDataCon,
stablePtrTyCon,
import {-# SOURCE #-} MkId( mkDataConId, mkDataConWrapId )
-- friends:
-import PrelMods
+import PrelNames
import TysPrim
-- others:
import TyCon ( TyCon, AlgTyConFlavour(..), ArgVrcs, tyConDataCons,
mkAlgTyCon, mkSynTyCon, mkTupleTyCon, isUnLiftedTyCon
)
-import BasicTypes ( Arity, NewOrData(..), RecFlag(..) )
+import BasicTypes ( Arity, NewOrData(..), RecFlag(..), Boxity(..), isBoxed )
import Type ( Type, mkTyConTy, mkTyConApp, mkSigmaTy, mkTyVarTys,
mkArrowKinds, boxedTypeKind, unboxedTypeKind,
mkFunTy, mkFunTys,
[] -- No context
argvrcs
cons
+ (length cons)
[] -- No derivings
new_or_data
is_rec
%************************************************************************
\begin{code}
-tupleTyCon :: Arity -> TyCon
-tupleTyCon i | i > mAX_TUPLE_SIZE = fst (mk_tuple i) -- Build one specially
- | otherwise = tupleTyConArr!i
-
-tupleCon :: Arity -> DataCon
-tupleCon i | i > mAX_TUPLE_SIZE = snd (mk_tuple i) -- Build one specially
- | otherwise = tupleConArr!i
-
-tupleTyCons :: [TyCon]
-tupleTyCons = elems tupleTyConArr
-
-tupleTyConArr :: Array Int TyCon
-tupleTyConArr = array (0,mAX_TUPLE_SIZE) ([0..] `zip` map fst tuples)
-
-tupleConArr :: Array Int DataCon
-tupleConArr = array (0,mAX_TUPLE_SIZE) ([0..] `zip` map snd tuples)
-
-tuples :: [(TyCon,DataCon)]
-tuples = [mk_tuple i | i <- [0..mAX_TUPLE_SIZE]]
-
-mk_tuple :: Int -> (TyCon,DataCon)
-mk_tuple arity = (tycon, tuple_con)
+tupleTyCon :: Boxity -> Arity -> TyCon
+tupleTyCon boxity i | i > mAX_TUPLE_SIZE = fst (mk_tuple boxity i) -- Build one specially
+tupleTyCon Boxed i = fst (boxedTupleArr ! i)
+tupleTyCon Unboxed i = fst (unboxedTupleArr ! i)
+
+tupleCon :: Boxity -> Arity -> DataCon
+tupleCon boxity i | i > mAX_TUPLE_SIZE = snd (mk_tuple boxity i) -- Build one specially
+tupleCon Boxed i = snd (boxedTupleArr ! i)
+tupleCon Unboxed i = snd (unboxedTupleArr ! i)
+
+boxedTupleArr, unboxedTupleArr :: Array Int (TyCon,DataCon)
+boxedTupleArr = array (0,mAX_TUPLE_SIZE) [(i,mk_tuple Boxed i) | i <- [0..mAX_TUPLE_SIZE]]
+unboxedTupleArr = array (0,mAX_TUPLE_SIZE) [(i,mk_tuple Unboxed i) | i <- [0..mAX_TUPLE_SIZE]]
+
+mk_tuple :: Boxity -> Int -> (TyCon,DataCon)
+mk_tuple boxity arity = (tycon, tuple_con)
where
- tycon = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con True
+ tycon = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con boxity
tc_name = mkWiredInTyConName tc_uniq mod name_str tycon
- tc_kind = mkArrowKinds (map tyVarKind tyvars) boxedTypeKind
+ tc_kind = mkArrowKinds (map tyVarKind tyvars) res_kind
+ res_kind | isBoxed boxity = boxedTypeKind
+ | otherwise = unboxedTypeKind
+
+ tyvars | isBoxed boxity = take arity alphaTyVars
+ | otherwise = take arity openAlphaTyVars
tuple_con = pcDataCon dc_uniq mod name_str tyvars [] tyvar_tys tycon
- tyvars = take arity alphaTyVars
tyvar_tys = mkTyVarTys tyvars
- (mod_name, name_str) = mkTupNameStr arity
- tc_uniq = mkTupleTyConUnique arity
- dc_uniq = mkTupleDataConUnique arity
+ (mod_name, name_str) = mkTupNameStr boxity arity
+ tc_uniq = mkTupleTyConUnique boxity arity
+ dc_uniq = mkTupleDataConUnique boxity arity
mod = mkPrelModule mod_name
-unitTyCon = tupleTyCon 0
+unitTyCon = tupleTyCon Boxed 0
unitDataConId = dataConId (head (tyConDataCons unitTyCon))
-pairTyCon = tupleTyCon 2
-\end{code}
+pairTyCon = tupleTyCon Boxed 2
-%************************************************************************
-%* *
-\subsection[TysWiredIn-ubx-tuples]{Unboxed Tuple Types}
-%* *
-%************************************************************************
+unboxedSingletonTyCon = tupleTyCon Unboxed 1
+unboxedSingletonDataCon = tupleCon Unboxed 1
-\begin{code}
-unboxedTupleTyCon :: Arity -> TyCon
-unboxedTupleTyCon i | i > mAX_TUPLE_SIZE = fst (mk_unboxed_tuple i)
- | otherwise = unboxedTupleTyConArr!i
-
-unboxedTupleCon :: Arity -> DataCon
-unboxedTupleCon i | i > mAX_TUPLE_SIZE = snd (mk_unboxed_tuple i)
- | otherwise = unboxedTupleConArr!i
-
-unboxedTupleTyConArr :: Array Int TyCon
-unboxedTupleTyConArr = array (0,mAX_TUPLE_SIZE) ([0..] `zip` map fst ubx_tuples)
-
-unboxedTupleConArr :: Array Int DataCon
-unboxedTupleConArr = array (0,mAX_TUPLE_SIZE) ([0..] `zip` map snd ubx_tuples)
-
-ubx_tuples :: [(TyCon,DataCon)]
-ubx_tuples = [mk_unboxed_tuple i | i <- [0..mAX_TUPLE_SIZE]]
-
-mk_unboxed_tuple :: Int -> (TyCon,DataCon)
-mk_unboxed_tuple arity = (tycon, tuple_con)
- where
- tycon = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con False
- tc_name = mkWiredInTyConName tc_uniq mod name_str tycon
- tc_kind = mkArrowKinds (map tyVarKind tyvars) unboxedTypeKind
-
- tuple_con = pcDataCon dc_uniq mod name_str tyvars [] tyvar_tys tycon
- tyvars = take arity openAlphaTyVars
- tyvar_tys = mkTyVarTys tyvars
- (mod_name, name_str) = mkUbxTupNameStr arity
- tc_uniq = mkUbxTupleTyConUnique arity
- dc_uniq = mkUbxTupleDataConUnique arity
- mod = mkPrelModule mod_name
-
-unboxedPairTyCon = unboxedTupleTyCon 2
-unboxedPairDataCon = unboxedTupleCon 2
+unboxedPairTyCon = tupleTyCon Unboxed 2
+unboxedPairDataCon = tupleCon Unboxed 2
\end{code}
%************************************************************************
\end{itemize}
\begin{code}
-mkTupleTy :: Int -> [Type] -> Type
-mkTupleTy arity tys = mkTyConApp (tupleTyCon arity) tys
-
-mkUnboxedTupleTy :: Int -> [Type] -> Type
-mkUnboxedTupleTy arity tys = mkTyConApp (unboxedTupleTyCon arity) tys
+mkTupleTy :: Boxity -> Int -> [Type] -> Type
+mkTupleTy boxity arity tys = mkTyConApp (tupleTyCon boxity arity) tys
-unitTy = mkTupleTy 0 []
+unitTy = mkTupleTy Boxed 0 []
\end{code}
+{- Notes about the syntax of interface files
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The header
+~~~~~~~~~~
+ interface "edison" M 4 6 2 ! 406 Module M, version 4, from package 'edison',
+ Fixities version 6, rules version 2
+ Interface syntax version 406
+ ! means M contains orphans
+
+Import declarations
+~~~~~~~~~~~~~~~~~~~
+ import Foo ; To compile M I used nothing from Foo, but it's
+ below me in the hierarchy
+
+ import Foo ! @ ; Ditto, but the ! means that Foo contains orphans
+ and the @ means that Foo is a boot interface
+
+ import Foo :: 3 ; To compile M I used everything from Foo, which has
+ module version 3
+
+ import Foo :: 3 2 6 a 1 b 3 c 7 ; To compile M I used Foo. It had
+ module version 3
+ fixity version 2
+ rules version 6
+ and some specific things besides.
+
+-}
+
+
{
module ParseIface ( parseIface, IfaceStuff(..) ) where
import HsSyn -- quite a bit of stuff
import RdrHsSyn -- oodles of synonyms
-import HsTypes ( mkHsForAllTy, mkHsUsForAllTy )
+import HsTypes ( mkHsForAllTy, mkHsUsForAllTy, mkHsTupCon )
import HsCore
+import Demand ( mkStrictnessInfo )
import Literal ( Literal(..), mkMachInt, mkMachInt64, mkMachWord, mkMachWord64 )
import BasicTypes ( Fixity(..), FixityDirection(..),
- NewOrData(..), Version
+ NewOrData(..), Version, initialVersion, Boxity(..)
)
import CostCentre ( CostCentre(..), IsCafCC(..), IsDupdCC(..) )
import CallConv ( cCallConv )
import PrimOp ( CCall(..), CCallTarget(..) )
import Lex
-import RnMonad ( ImportVersion, LocalVersion, ParsedIface(..), WhatsImported(..),
+import RnMonad ( ImportVersion, ParsedIface(..), WhatsImported(..),
RdrNamePragma, ExportItem, RdrAvailInfo, GenAvailInfo(..),
WhetherHasOrphans, IsBootInterface
)
EncodedFS
)
import Module ( ModuleName, PackageName, mkSysModuleFS, mkModule )
-import PrelInfo ( mkTupConRdrName, mkUbxTupConRdrName )
import SrcLoc ( SrcLoc )
import CmdLineOpts ( opt_InPackage )
import Maybes
import Outputable
+import List ( insert )
import GlaExts
import FastString ( tailFS )
iface :: { ParsedIface }
-iface : '__interface' package mod_name INTEGER orphans checkVersion 'where'
+iface : '__interface' package mod_name
+ version sub_versions
+ orphans checkVersion 'where'
exports_part
import_part
+ fix_decl_part
instance_decl_part
decls_part
rules_and_deprecs
{ ParsedIface {
pi_mod = mkModule $3 $2, -- Module itself
- pi_vers = fromInteger $4, -- Module version
- pi_orphan = $5,
- pi_exports = $8, -- Exports
- pi_usages = $9, -- Usages
- pi_insts = $10, -- Local instances
- pi_decls = $11, -- Decls
- pi_rules = fst $12, -- Rules
- pi_deprecs = snd $12 -- Deprecations
- } }
+ pi_vers = $4, -- Module version
+ pi_orphan = $6,
+ pi_exports = $9, -- Exports
+ pi_usages = $10, -- Usages
+ pi_fixity = (fst $5,$11), -- Fixies
+ pi_insts = $12, -- Local instances
+ pi_decls = $13, -- Decls
+ pi_rules = (snd $5,fst $14), -- Rules
+ pi_deprecs = snd $14 -- Deprecations
+ } }
+
+-- Versions for fixities and rules (optional)
+sub_versions :: { (Version,Version) }
+ : '[' version version ']' { ($2,$3) }
+ | {- empty -} { (initialVersion, initialVersion) }
--------------------------------------------------------------------------
import_part :: { [ImportVersion OccName] }
import_part : { [] }
- | import_part import_decl { $2 : $1 }
+ | import_decl import_part { $1 : $2 }
import_decl :: { ImportVersion OccName }
-import_decl : 'import' mod_name INTEGER orphans is_boot whats_imported ';'
- { (mkSysModuleFS $2, fromInteger $3, $4, $5, $6) }
- -- import Foo 3 :: a 1 b 3 c 7 ; means import a,b,c from Foo
- -- import Foo 3 ; means import all of Foo
- -- import Foo 3 ! :: ...stuff... ; the ! means that Foo contains orphans
+import_decl : 'import' mod_name orphans is_boot whats_imported ';'
+ { (mkSysModuleFS $2, $3, $4, $5) }
orphans :: { WhetherHasOrphans }
orphans : { False }
| '@' { True }
whats_imported :: { WhatsImported OccName }
-whats_imported : { Everything }
- | '::' name_version_pairs { Specifically $2 }
+whats_imported : { NothingAtAll }
+ | '::' version { Everything $2 }
+ | '::' version version version name_version_pairs { Specifically $2 $3 $4 $5 }
-name_version_pairs :: { [LocalVersion OccName] }
+name_version_pairs :: { [(OccName, Version)] }
name_version_pairs : { [] }
| name_version_pair name_version_pairs { $1 : $2 }
-name_version_pair :: { LocalVersion OccName }
-name_version_pair : var_occ INTEGER { ($1, fromInteger $2) }
- | tc_occ INTEGER { ($1, fromInteger $2) }
+name_version_pair :: { (OccName, Version) }
+name_version_pair : var_occ version { ($1, $2) }
+ | tc_occ version { ($1, $2) }
--------------------------------------------------------------------------
exports_part :: { [ExportItem] }
exports_part : { [] }
- | exports_part '__export'
- mod_name entities ';' { (mkSysModuleFS $3, $4) : $1 }
+ | '__export' mod_name entities ';'
+ exports_part { (mkSysModuleFS $2, $3) : $5 }
entities :: { [RdrAvailInfo] }
entities : { [] }
| entity entities { $1 : $2 }
entity :: { RdrAvailInfo }
-entity : tc_occ { AvailTC $1 [$1] }
- | var_occ { Avail $1 }
- | tc_occ stuff_inside { AvailTC $1 ($1:$2) }
+entity : var_occ { Avail $1 }
+ | tc_occ { AvailTC $1 [$1] }
| tc_occ '|' stuff_inside { AvailTC $1 $3 }
+ | tc_occ stuff_inside { AvailTC $1 (insert $1 $2) }
+ -- The 'insert' is important. The stuff_inside is sorted, and
+ -- insert keeps it that way. This is important when comparing
+ -- against the new interface file, which has the stuff in sorted order
+ -- If they differ, we'll bump the module number when it's unnecessary
stuff_inside :: { [OccName] }
stuff_inside : '{' val_occs '}' { $2 }
--------------------------------------------------------------------------
+fix_decl_part :: { [RdrNameFixitySig] }
+fix_decl_part : {- empty -} { [] }
+ | fix_decls ';' { $1 }
+
+fix_decls :: { [RdrNameFixitySig] }
+fix_decls : { [] }
+ | fix_decl fix_decls { $1 : $2 }
+
+fix_decl :: { RdrNameFixitySig }
+fix_decl : src_loc fixity prec var_or_data_name { FixitySig $4 (Fixity $3 $2) $1 }
+
fixity :: { FixityDirection }
fixity : 'infixl' { InfixL }
| 'infixr' { InfixR }
| 'infix' { InfixN }
-mb_fix :: { Int }
-mb_fix : {-nothing-} { 9 }
- | INTEGER { (fromInteger $1) }
+prec :: { Int }
+prec : INTEGER { fromInteger $1 }
-----------------------------------------------------------------------------
| 'where' '{' csigs1 '}' { $3 }
csigs1 :: { [RdrNameSig] }
-csigs1 : csig { [$1] }
+csigs1 : { [] }
| csig ';' csigs1 { $1 : $3 }
csig :: { RdrNameSig }
decls_part :: { [(Version, RdrNameHsDecl)] }
decls_part
: {- empty -} { [] }
- | decls_part version decl ';' { ($2,$3):$1 }
+ | opt_version decl ';' decls_part { ($1,$2):$4 }
decl :: { RdrNameHsDecl }
decl : src_loc var_name '::' type maybe_idinfo
{ SigD (IfaceSig $2 $4 ($5 $2) $1) }
| src_loc 'type' tc_name tv_bndrs '=' type
{ TyClD (TySynonym $3 $4 $6 $1) }
- | src_loc 'data' decl_context tc_name tv_bndrs constrs
- { TyClD (TyData DataType $3 $4 $5 $6 Nothing noDataPragmas $1) }
- | src_loc 'newtype' decl_context tc_name tv_bndrs newtype_constr
- { TyClD (TyData NewType $3 $4 $5 $6 Nothing noDataPragmas $1) }
- | src_loc 'class' decl_context tc_name tv_bndrs fds csigs
+ | src_loc 'data' opt_decl_context tc_name tv_bndrs constrs
+ { TyClD (TyData DataType $3 $4 $5 $6 (length $6) Nothing noDataPragmas $1) }
+ | src_loc 'newtype' opt_decl_context tc_name tv_bndrs newtype_constr
+ { TyClD (TyData NewType $3 $4 $5 $6 1 Nothing noDataPragmas $1) }
+ | src_loc 'class' opt_decl_context tc_name tv_bndrs fds csigs
{ TyClD (mkClassDecl $3 $4 $5 $6 $7 EmptyMonoBinds
noClassPragmas $1) }
- | src_loc fixity mb_fix var_or_data_name
- { FixD (FixitySig $4 (Fixity $3 $2) $1) }
maybe_idinfo :: { RdrName -> [HsIdInfo RdrName] }
maybe_idinfo : {- empty -} { \_ -> [] }
rule :: { RdrNameRuleDecl }
rule : src_loc STRING rule_forall qvar_name
- core_args '=' core_expr { IfaceRuleDecl $4 (UfRuleBody $2 $3 $5 $7) $1 }
+ core_args '=' core_expr { IfaceRule $2 $3 $4 $5 $7 $1 }
rule_forall :: { [UfBinder RdrName] }
rule_forall : '__forall' '{' core_bndrs '}' { $3 }
deprecs :: { [RdrNameDeprecation] }
deprecs : {- empty -} { [] }
- | deprecs deprec ';' { $2 : $1 }
+ | deprec ';' deprecs { $1 : $3 }
deprec :: { RdrNameDeprecation }
-deprec : STRING { Deprecation (IEModuleContents undefined) $1 }
- | deprec_name STRING { Deprecation $1 $2 }
+deprec : src_loc STRING { Deprecation (IEModuleContents undefined) $2 $1 }
+ | src_loc deprec_name STRING { Deprecation $2 $3 $1 }
-- SUP: TEMPORARY HACK
deprec_name :: { RdrNameIE }
-----------------------------------------------------------------------------
version :: { Version }
-version : INTEGER { fromInteger $1 }
+version : INTEGER { fromInteger $1 }
-decl_context :: { RdrNameContext }
-decl_context : { [] }
- | '{' context_list1 '}' '=>' { $2 }
+opt_version :: { Version }
+opt_version : version { $1 }
+ | {- empty -} { initialVersion }
+
+opt_decl_context :: { RdrNameContext }
+opt_decl_context : { [] }
+ | context '=>' { $1 }
----------------------------------------------------------------------------
| src_loc '=' ex_stuff data_name '{' var_name '::' atype '}'
{ [mk_con_decl $4 $3 (NewCon $8 (Just $6)) $1] }
-ex_stuff :: { ([HsTyVar RdrName], RdrNameContext) }
+ex_stuff :: { ([HsTyVarBndr RdrName], RdrNameContext) }
ex_stuff : { ([],[]) }
- | '__forall' forall context '=>' { ($2,$3) }
+ | '__forall' tv_bndrs opt_context '=>' { ($2,$3) }
batypes :: { [RdrNameBangType] }
batypes : { [] }
type :: { RdrNameHsType }
type : '__fuall' fuall '=>' type { mkHsUsForAllTy $2 $4 }
- | '__forall' forall context '=>' type
- { mkHsForAllTy (Just $2) $3 $5 }
- | btype '->' type { MonoFunTy $1 $3 }
+ | '__forall' tv_bndrs
+ opt_context '=>' type { mkHsForAllTy (Just $2) $3 $5 }
+ | btype '->' type { HsFunTy $1 $3 }
| btype { $1 }
fuall :: { [RdrName] }
fuall : '[' uv_bndrs ']' { $2 }
-forall :: { [HsTyVar RdrName] }
-forall : '[' tv_bndrs ']' { $2 }
+opt_context :: { RdrNameContext }
+opt_context : { [] }
+ | context { $1 }
context :: { RdrNameContext }
-context : { [] }
- | '{' context_list1 '}' { $2 }
+context : '(' context_list1 ')' { $2 }
+ | '{' context_list1 '}' { $2 } -- Backward compatibility
context_list1 :: { RdrNameContext }
context_list1 : class { [$1] }
btype :: { RdrNameHsType }
btype : atype { $1 }
- | btype atype { MonoTyApp $1 $2 }
- | '__u' usage atype { MonoUsgTy $2 $3 }
+ | btype atype { HsAppTy $1 $2 }
+ | '__u' usage atype { HsUsgTy $2 $3 }
-usage :: { MonoUsageAnn RdrName }
-usage : '-' { MonoUsOnce }
- | '!' { MonoUsMany }
- | uv_name { MonoUsVar $1 }
+usage :: { HsUsageAnn RdrName }
+usage : '-' { HsUsOnce }
+ | '!' { HsUsMany }
+ | uv_name { HsUsVar $1 }
atype :: { RdrNameHsType }
-atype : qtc_name { MonoTyVar $1 }
- | tv_name { MonoTyVar $1 }
- | '(' types2 ')' { MonoTupleTy $2 True{-boxed-} }
- | '(#' types0 '#)' { MonoTupleTy $2 False{-unboxed-} }
- | '[' type ']' { MonoListTy $2 }
- | '{' qcls_name atypes '}' { MonoDictTy $2 $3 }
- | '{' ipvar_name '::' type '}' { MonoIParamTy $2 $4 }
+atype : qtc_name { HsTyVar $1 }
+ | tv_name { HsTyVar $1 }
+ | '(' ')' { HsTupleTy (mkHsTupCon tcName Boxed []) [] }
+ | '(' types2 ')' { HsTupleTy (mkHsTupCon tcName Boxed $2) $2 }
+ | '(#' types0 '#)' { HsTupleTy (mkHsTupCon tcName Unboxed $2) $2 }
+ | '[' type ']' { HsListTy $2 }
+ | '{' qcls_name atypes '}' { mkHsDictTy $2 $3 }
+ | '{' ipvar_name '::' type '}' { mkHsIParamTy $2 $4 }
| '(' type ')' { $2 }
--- This one is dealt with via qtc_name
--- | '(' ')' { MonoTupleTy [] True }
-
atypes :: { [RdrNameHsType] {- Zero or more -} }
atypes : { [] }
| atype atypes { $1 : $2 }
: VARID { mkSysUnqual tvName $1 }
| VARSYM { mkSysUnqual tvName $1 {- Allow t2 as a tyvar -} }
-tv_bndr :: { HsTyVar RdrName }
+tv_bndr :: { HsTyVarBndr RdrName }
: tv_name '::' akind { IfaceTyVar $1 $3 }
| tv_name { IfaceTyVar $1 boxedTypeKind }
-tv_bndrs :: { [HsTyVar RdrName] }
+tv_bndrs :: { [HsTyVarBndr RdrName] }
+tv_bndrs : tv_bndrs1 { $1 }
+ | '[' tv_bndrs1 ']' { $2 } -- Backward compatibility
+
+tv_bndrs1 :: { [HsTyVarBndr RdrName] }
: { [] }
- | tv_bndr tv_bndrs { $1 : $2 }
+ | tv_bndr tv_bndrs1 { $1 : $2 }
---------------------------------------------------
fds :: { [([RdrName], [RdrName])] }
: '__A' INTEGER { HsArity (exactArity (fromInteger $2)) }
| '__U' inline_prag core_expr { HsUnfold $2 $3 }
| '__M' { HsCprInfo }
- | '__S' { HsStrictness (HsStrictnessInfo $1) }
+ | '__S' { HsStrictness (mkStrictnessInfo $1) }
| '__C' { HsNoCafRefs }
| '__P' qvar_name { HsWorker $2 }
inline_prag :: { InlinePragInfo }
: {- empty -} { NoInlinePragInfo }
- | '[' INTEGER ']' { IMustNotBeINLINEd True (Just (fromInteger $2)) } -- INLINE n
- | '[' '!' ']' { IMustNotBeINLINEd True Nothing } -- NOTINLINE
- | '[' '!' INTEGER ']' { IMustNotBeINLINEd False (Just (fromInteger $3)) } -- NOINLINE n
+ | '[' from_prag phase ']' { IMustNotBeINLINEd $2 $3 }
+
+from_prag :: { Bool }
+ : {- empty -} { True }
+ | '!' { False }
+
+phase :: { Maybe Int }
+ : {- empty -} { Nothing }
+ | INTEGER { Just (fromInteger $1) }
-------------------------------------------------------
core_expr :: { UfExpr RdrName }
| '__litlit' STRING atype { UfLitLit $2 $3 }
- | '__inline_me' core_expr { UfNote UfInlineMe $2 }
- | '__inline_call' core_expr { UfNote UfInlineCall $2 }
- | '__coerce' atype core_expr { UfNote (UfCoerce $2) $3 }
- | scc core_expr { UfNote (UfSCC $1) $2 }
| fexpr { $1 }
fexpr :: { UfExpr RdrName }
fexpr : fexpr core_arg { UfApp $1 $2 }
+ | scc core_aexpr { UfNote (UfSCC $1) $2 }
+ | '__inline_me' core_aexpr { UfNote UfInlineMe $2 }
+ | '__inline_call' core_aexpr { UfNote UfInlineCall $2 }
+ | '__coerce' atype core_aexpr { UfNote (UfCoerce $2) $3 }
| core_aexpr { $1 }
core_arg :: { UfExpr RdrName }
core_aexpr :: { UfExpr RdrName } -- Atomic expressions
core_aexpr : qvar_name { UfVar $1 }
| qdata_name { UfVar $1 }
- -- This one means that e.g. "True" will parse as
- -- (UfVar True_Id) rather than (UfCon True_Con []).
- -- No big deal; it'll be inlined in a jiffy. I tried
- -- parsing it to (Con con []) directly, but got bitten
- -- when a real constructor Id showed up in an interface
- -- file. As usual, a hack bites you in the end.
- -- If you want to get a UfCon, then use the
- -- curly-bracket notation (True {}).
-
--- This one is dealt with by qdata_name: see above comments
--- | '(' ')' { UfTuple (mkTupConRdrName 0) [] }
| core_lit { UfLit $1 }
| '(' core_expr ')' { $2 }
- -- Tuple construtors are for the *worker* of the tuple
- -- Going direct saves needless messing about
- | '(' comma_exprs2 ')' { UfTuple (mkRdrNameWkr (mkTupConRdrName (length $2))) $2 }
- | '(#' comma_exprs0 '#)' { UfTuple (mkRdrNameWkr (mkUbxTupConRdrName (length $2))) $2 }
+ | '(' ')' { UfTuple (mkHsTupCon dataName Boxed []) [] }
+ | '(' comma_exprs2 ')' { UfTuple (mkHsTupCon dataName Boxed $2) $2 }
+ | '(#' comma_exprs0 '#)' { UfTuple (mkHsTupCon dataName Unboxed $2) $2 }
| '{' '__ccall' ccall_string type '}'
{ let
| core_val_bndr '=' core_expr ';' rec_binds { ($1,$3) : $5 }
core_alts :: { [UfAlt RdrName] }
- : core_alt { [$1] }
+ : { [] }
| core_alt ';' core_alts { $1 : $3 }
core_alt :: { UfAlt RdrName }
core_pat : core_lit { (UfLitAlt $1, []) }
| '__litlit' STRING atype { (UfLitLitAlt $2 $3, []) }
| qdata_name core_pat_names { (UfDataAlt $1, $2) }
- | '(' comma_var_names1 ')' { (UfDataAlt (mkTupConRdrName (length $2)), $2) }
- | '(#' comma_var_names1 '#)' { (UfDataAlt (mkUbxTupConRdrName (length $2)), $2) }
+ | '(' ')' { (UfTupleAlt (mkHsTupCon dataName Boxed []), []) }
+ | '(' comma_var_names1 ')' { (UfTupleAlt (mkHsTupCon dataName Boxed $2), $2) }
+ | '(#' comma_var_names1 '#)' { (UfTupleAlt (mkHsTupCon dataName Unboxed $2), $2) }
| '__DEFAULT' { (UfDefault, []) }
| '(' core_pat ')' { $2 }
src_loc :: { SrcLoc }
src_loc : {% getSrcLocP }
+-- Check the project version: this makes sure
+-- that the project version (e.g. 407) in the interface
+-- file is the same as that for the compiler that's reading it
checkVersion :: { () }
: {-empty-} {% checkVersion Nothing }
| INTEGER {% checkVersion (Just (fromInteger $1)) }
#include "HsVersions.h"
import HsSyn
-import RdrHsSyn ( RdrNameHsModule )
+import HsPragmas ( DataPragmas(..) )
+import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameDeprecation )
import RnHsSyn ( RenamedHsModule, RenamedHsDecl,
extractHsTyNames, extractHsCtxtTyNames
)
import CmdLineOpts ( opt_HiMap, opt_D_dump_rn_trace, opt_D_dump_minimal_imports,
- opt_D_dump_rn, opt_D_dump_rn_stats, opt_WarnDeprecations
+ opt_D_dump_rn, opt_D_dump_rn_stats, opt_WarnDeprecations,
+ opt_WarnUnusedBinds
)
import RnMonad
import RnNames ( getGlobalNames )
import RnSource ( rnSourceDecls, rnDecl )
-import RnIfaces ( getImportedInstDecls, importDecl, getImportVersions, getInterfaceExports,
- getImportedRules, loadHomeInterface, getSlurped, removeContext
+import RnIfaces ( getImportedInstDecls, importDecl, mkImportExportInfo, getInterfaceExports,
+ getImportedRules, loadHomeInterface, getSlurped, removeContext,
+ loadBuiltinRules, getDeferredDecls, ImportDeclResult(..)
)
import RnEnv ( availName, availsToNameSet, unitAvailEnv, availEnvElts, plusAvailEnv,
warnUnusedImports, warnUnusedLocalBinds, warnUnusedModules,
- lookupImplicitOccRn, pprAvail,
- FreeVars, plusFVs, plusFV, unitFV, emptyFVs, isEmptyFVs
+ lookupImplicitOccsRn, pprAvail, unknownNameErr,
+ FreeVars, plusFVs, plusFV, unitFV, emptyFVs, isEmptyFVs, addOneFV
)
import Module ( Module, ModuleName, WhereFrom(..),
moduleNameUserString, mkSearchPath, moduleName, mkThisModule
import Name ( Name, isLocallyDefined, NamedThing(..), getSrcLoc,
nameOccName, nameUnique, nameModule, maybeUserImportedFrom,
isUserImportedExplicitlyName, isUserImportedName,
- maybeWiredInTyConName, maybeWiredInIdName, isWiredInName
+ maybeWiredInTyConName, maybeWiredInIdName, isWiredInName,
+ isUserExportedName, toRdrName
)
import OccName ( occNameFlavour, isValOcc )
import Id ( idType )
import TyCon ( isSynTyCon, getSynTyConDefn )
import NameSet
-import PrelMods ( mAIN_Name, pREL_MAIN_Name, pRELUDE_Name )
import TysWiredIn ( unitTyCon, intTyCon, doubleTyCon, boolTyCon )
-import PrelInfo ( ioTyCon_NAME, thinAirIdNames, fractionalClassKeys, derivingOccurrences )
+import PrelRules ( builtinRules )
+import PrelInfo ( mAIN_Name, pREL_MAIN_Name, pRELUDE_Name,
+ ioTyCon_RDR, unpackCString_RDR, unpackCString2_RDR, unpackCStringFoldr_RDR,
+ fractionalClassKeys, derivingOccurrences
+ )
import Type ( namesOfType, funTyCon )
import ErrUtils ( printErrorsAndWarnings, dumpIfSet, ghcExit )
-import BasicTypes ( NewOrData(..) )
+import BasicTypes ( Version, initialVersion )
import Bag ( isEmptyBag, bagToList )
import FiniteMap ( FiniteMap, eltsFM, fmToList, emptyFM, lookupFM, addToFM_C )
import UniqSupply ( UniqSupply )
import UniqFM ( lookupUFM )
+import SrcLoc ( noSrcLoc )
import Maybes ( maybeToBool, expectJust )
import Outputable
import IO ( openFile, IOMode(..) )
\begin{code}
-renameModule :: UniqSupply
- -> RdrNameHsModule
- -> IO (Maybe
- ( Module
- , RenamedHsModule -- Output, after renaming
- , InterfaceDetails -- Interface; for interface file generation
- , RnNameSupply -- Final env; for renaming derivings
- , [ModuleName] -- Imported modules; for profiling
- ))
-
+type RenameResult = ( Module -- This module
+ , RenamedHsModule -- Renamed module
+ , Maybe ParsedIface -- The existing interface file, if any
+ , ParsedIface -- The new interface
+ , RnNameSupply -- Final env; for renaming derivings
+ , FixityEnv -- The fixity environment; for derivings
+ , [ModuleName]) -- Imported modules; for profiling
+
+renameModule :: UniqSupply -> RdrNameHsModule -> IO (Maybe RenameResult)
renameModule us this_mod@(HsModule mod_name vers exports imports local_decls _ loc)
= -- Initialise the renamer monad
- initRn mod_name us (mkSearchPath opt_HiMap) loc
- (rename this_mod) >>=
- \ ((maybe_rn_stuff, dump_action), rn_errs_bag, rn_warns_bag) ->
+ do {
+ ((maybe_rn_stuff, dump_action), rn_errs_bag, rn_warns_bag)
+ <- initRn mod_name us (mkSearchPath opt_HiMap) loc (rename this_mod) ;
-- Check for warnings
- printErrorsAndWarnings rn_errs_bag rn_warns_bag >>
+ printErrorsAndWarnings rn_errs_bag rn_warns_bag ;
-- Dump any debugging output
- dump_action >>
+ dump_action ;
-- Return results
- if not (isEmptyBag rn_errs_bag) then
- ghcExit 1 >> return Nothing
- else
+ if not (isEmptyBag rn_errs_bag) then
+ do { ghcExit 1 ; return Nothing }
+ else
return maybe_rn_stuff
+ }
\end{code}
-
\begin{code}
-rename :: RdrNameHsModule
- -> RnMG (Maybe (Module, RenamedHsModule, InterfaceDetails, RnNameSupply, [ModuleName]), IO ())
-rename this_mod@(HsModule mod_name vers _ imports local_decls mod_deprec loc)
+rename :: RdrNameHsModule -> RnMG (Maybe RenameResult, IO ())
+rename this_mod@(HsModule mod_name vers exports imports local_decls mod_deprec loc)
= -- FIND THE GLOBAL NAME ENVIRONMENT
getGlobalNames this_mod `thenRn` \ maybe_stuff ->
-- CHECK FOR EARLY EXIT
- if not (maybeToBool maybe_stuff) then
- -- Everything is up to date; no need to recompile further
- rnDump [] [] `thenRn` \ dump_action ->
- returnRn (Nothing, dump_action)
- else
- let
- Just (export_env, gbl_env, fixity_env, global_avail_env) = maybe_stuff
- ExportEnv export_avails _ _ = export_env
- in
+ case maybe_stuff of {
+ Nothing -> -- Everything is up to date; no need to recompile further
+ rnDump [] [] `thenRn` \ dump_action ->
+ returnRn (Nothing, dump_action) ;
+
+ Just (gbl_env, local_gbl_env, export_avails, global_avail_env, old_iface) ->
+
+ -- DEAL WITH DEPRECATIONS
+ rnDeprecs local_gbl_env mod_deprec local_decls `thenRn` \ my_deprecs ->
+
+ -- DEAL WITH LOCAL FIXITIES
+ fixitiesFromLocalDecls local_gbl_env local_decls `thenRn` \ local_fixity_env ->
-- RENAME THE SOURCE
- initRnMS gbl_env fixity_env SourceMode (
+ initRnMS gbl_env local_fixity_env SourceMode (
rnSourceDecls local_decls
) `thenRn` \ (rn_local_decls, source_fvs) ->
-- SLURP IN ALL THE NEEDED DECLARATIONS
implicitFVs mod_name rn_local_decls `thenRn` \ implicit_fvs ->
let
- real_source_fvs = implicit_fvs `plusFV` source_fvs `plusFV` export_fvs
- -- It's important to do the "plus" this way round, so that
- -- when compiling the prelude, locally-defined (), Bool, etc
- -- override the implicit ones.
-
-- The export_fvs make the exported names look just as if they
-- occurred in the source program. For the reasoning, see the
- -- comments with RnIfaces.getImportVersions
- export_fvs = mkNameSet (map availName export_avails)
- in
- slurpImpDecls real_source_fvs `thenRn` \ rn_imp_decls ->
- let
- rn_all_decls = rn_local_decls ++ rn_imp_decls
+ -- comments with RnIfaces.getImportVersions.
+ -- We only need the 'parent name' of the avail;
+ -- that's enough to suck in the declaration.
+ export_fvs = mkNameSet (map availName export_avails)
+ real_source_fvs = source_fvs `plusFV` export_fvs
- -- COLLECT ALL DEPRECATIONS
- deprec_sigs = [ ds | ValD bnds <- rn_local_decls, ds <- collectDeprecs bnds ]
- deprecs = case mod_deprec of
- Nothing -> deprec_sigs
- Just txt -> Deprecation (IEModuleContents undefined) txt : deprec_sigs
+ slurp_fvs = implicit_fvs `plusFV` real_source_fvs
+ -- It's important to do the "plus" this way round, so that
+ -- when compiling the prelude, locally-defined (), Bool, etc
+ -- override the implicit ones.
in
+ loadBuiltinRules builtinRules `thenRn_`
+ slurpImpDecls slurp_fvs `thenRn` \ rn_imp_decls ->
-- EXIT IF ERRORS FOUND
+ rnDump rn_imp_decls rn_local_decls `thenRn` \ dump_action ->
checkErrsRn `thenRn` \ no_errs_so_far ->
if not no_errs_so_far then
-- Found errors already, so exit now
- rnDump rn_imp_decls rn_all_decls `thenRn` \ dump_action ->
returnRn (Nothing, dump_action)
else
-- GENERATE THE VERSION/USAGE INFO
- getImportVersions mod_name export_env `thenRn` \ my_usages ->
- getNameSupplyRn `thenRn` \ name_supply ->
+ mkImportExportInfo mod_name export_avails exports `thenRn` \ (my_exports, my_usages) ->
-- RETURN THE RENAMED MODULE
+ getNameSupplyRn `thenRn` \ name_supply ->
let
- has_orphans = any isOrphanDecl rn_local_decls
+ this_module = mkThisModule mod_name
direct_import_mods = [mod | ImportDecl mod _ _ _ _ _ <- imports]
+
+ -- Export only those fixities that are for names that are
+ -- (a) defined in this module
+ -- (b) exported
+ exported_fixities
+ = [ FixitySig (toRdrName name) fixity loc
+ | FixitySig name fixity loc <- nameEnvElts local_fixity_env,
+ isUserExportedName name
+ ]
+
+ new_iface = ParsedIface { pi_mod = this_module
+ , pi_vers = initialVersion
+ , pi_orphan = any isOrphanDecl rn_local_decls
+ , pi_exports = my_exports
+ , pi_usages = my_usages
+ , pi_fixity = (initialVersion, exported_fixities)
+ , pi_deprecs = my_deprecs
+ -- These ones get filled in later
+ , pi_insts = [], pi_decls = []
+ , pi_rules = (initialVersion, [])
+ }
+
renamed_module = HsModule mod_name vers
trashed_exports trashed_imports
- rn_all_decls
+ (rn_local_decls ++ rn_imp_decls)
mod_deprec
loc
+
+ result = (this_module, renamed_module,
+ old_iface, new_iface,
+ name_supply, local_fixity_env,
+ direct_import_mods)
in
+
-- REPORT UNUSED NAMES, AND DEBUG DUMP
reportUnusedNames mod_name direct_import_mods
gbl_env global_avail_env
- export_env
- source_fvs `thenRn_`
- rnDump rn_imp_decls rn_all_decls `thenRn` \ dump_action ->
-
- returnRn (Just (mkThisModule mod_name,
- renamed_module,
- (InterfaceDetails has_orphans my_usages export_env deprecs),
- name_supply,
- direct_import_mods), dump_action)
+ export_avails source_fvs `thenRn_`
+
+ returnRn (Just result, dump_action) }
where
trashed_exports = {-trace "rnSource:trashed_exports"-} Nothing
trashed_imports = {-trace "rnSource:trashed_imports"-} []
-
- collectDeprecs EmptyBinds = []
- collectDeprecs (ThenBinds x y) = collectDeprecs x ++ collectDeprecs y
- collectDeprecs (MonoBind _ sigs _) = [ d | DeprecSig d _ <- sigs ]
\end{code}
@implicitFVs@ forces the renamer to slurp in some things which aren't
\begin{code}
implicitFVs mod_name decls
- = mapRn lookupImplicitOccRn implicit_occs `thenRn` \ implicit_names ->
- returnRn (implicit_main `plusFV`
- mkNameSet (map getName default_tycons) `plusFV`
- mkNameSet thinAirIdNames `plusFV`
- mkNameSet implicit_names)
+ = lookupImplicitOccsRn implicit_occs `thenRn` \ implicit_names ->
+ returnRn (mkNameSet (map getName default_tycons) `plusFV`
+ implicit_names)
where
-- Add occurrences for Int, and (), because they
-- are the types to which ambigious type variables may be defaulted by
-- Add occurrences for IO or PrimIO
implicit_main | mod_name == mAIN_Name
- || mod_name == pREL_MAIN_Name = unitFV ioTyCon_NAME
- | otherwise = emptyFVs
+ || mod_name == pREL_MAIN_Name = [ioTyCon_RDR]
+ | otherwise = []
-- Now add extra "occurrences" for things that
-- the deriving mechanism, or defaulting, will later need in order to
-- generate code
- implicit_occs = foldr ((++) . get) [] decls
+ implicit_occs = string_occs ++ foldr ((++) . get) implicit_main decls
+
+ -- Virtually every program has error messages in it somewhere
+ string_occs = [unpackCString_RDR, unpackCString2_RDR, unpackCStringFoldr_RDR]
- get (TyClD (TyData _ _ _ _ _ (Just deriv_classes) _ _))
+ get (TyClD (TyData _ _ _ _ _ _ (Just deriv_classes) _ _))
= concat (map get_deriv deriv_classes)
get other = []
-- The decl is an orphan if Baz and T are both not locally defined,
-- even if Foo *is* locally defined
-isOrphanDecl (RuleD (RuleDecl _ _ _ lhs _ _))
+isOrphanDecl (RuleD (HsRule _ _ _ lhs _ _))
= check lhs
where
-- At the moment we just check for common LHS forms
getSlurped `thenRn` \ source_binders ->
slurpSourceRefs source_binders source_fvs `thenRn` \ (decls, needed) ->
- -- And finally get everything else
- closeDecls decls needed
+ -- Then get everything else
+ closeDecls decls needed `thenRn` \ decls1 ->
+
+ -- Finally, get any deferred data type decls
+ slurpDeferredDecls decls1 `thenRn` \ final_decls ->
+
+ returnRn final_decls
-------------------------------------------------------
slurpSourceRefs :: NameSet -- Variables defined in source
go_outer decls fvs all_gates refs -- refs are not necessarily slurped yet
= traceRn (text "go_outer" <+> ppr refs) `thenRn_`
- go_inner decls fvs emptyFVs refs `thenRn` \ (decls1, fvs1, gates1) ->
+ foldlRn go_inner (decls, fvs, emptyFVs) refs `thenRn` \ (decls1, fvs1, gates1) ->
getImportedInstDecls (all_gates `plusFV` gates1) `thenRn` \ inst_decls ->
rnInstDecls decls1 fvs1 gates1 inst_decls `thenRn` \ (decls2, fvs2, gates2) ->
go_outer decls2 fvs2 (all_gates `plusFV` gates2)
-- Knock out the all_gates because even if we don't slurp any new
-- decls we can get some apparently-new gates from wired-in names
- go_inner decls fvs gates []
- = returnRn (decls, fvs, gates)
-
- go_inner decls fvs gates (wanted_name:refs)
- | isWiredInName wanted_name
- = load_home wanted_name `thenRn_`
- go_inner decls fvs (gates `plusFV` getWiredInGates wanted_name) refs
-
- | otherwise
- = importDecl wanted_name `thenRn` \ maybe_decl ->
- case maybe_decl of
- Nothing -> go_inner decls fvs gates refs -- No declaration... (already slurped, or local)
- Just decl -> rnIfaceDecl decl `thenRn` \ (new_decl, fvs1) ->
- go_inner (new_decl : decls)
- (fvs1 `plusFV` fvs)
- (gates `plusFV` getGates source_fvs new_decl)
- refs
-
- -- When we find a wired-in name we must load its
- -- home module so that we find any instance decls therein
- load_home name
- | name `elemNameSet` source_binders = returnRn ()
- -- When compiling the prelude, a wired-in thing may
- -- be defined in this module, in which case we don't
- -- want to load its home module!
- -- Using 'isLocallyDefined' doesn't work because some of
- -- the free variables returned are simply 'listTyCon_Name',
- -- with a system provenance. We could look them up every time
- -- but that seems a waste.
- | otherwise = loadHomeInterface doc name `thenRn_`
- returnRn ()
- where
- doc = ptext SLIT("need home module for wired in thing") <+> ppr name
+ go_inner (decls, fvs, gates) wanted_name
+ = importDecl wanted_name `thenRn` \ import_result ->
+ case import_result of
+ AlreadySlurped -> returnRn (decls, fvs, gates)
+ WiredIn -> returnRn (decls, fvs, gates `plusFV` getWiredInGates wanted_name)
+ Deferred -> returnRn (decls, fvs, gates `addOneFV` wanted_name) -- It's a type constructor
+
+ HereItIs decl -> rnIfaceDecl decl `thenRn` \ (new_decl, fvs1) ->
+ returnRn (new_decl : decls,
+ fvs1 `plusFV` fvs,
+ gates `plusFV` getGates source_fvs new_decl)
rnInstDecls decls fvs gates []
= returnRn (decls, fvs, gates)
-------------------------------------------------------
-rnIfaceDecls :: [RenamedHsDecl] -> FreeVars
- -> [(Module, RdrNameHsDecl)]
- -> RnM d ([RenamedHsDecl], FreeVars)
-rnIfaceDecls decls fvs [] = returnRn (decls, fvs)
-rnIfaceDecls decls fvs (d:ds) = rnIfaceDecl d `thenRn` \ (new_decl, fvs1) ->
- rnIfaceDecls (new_decl:decls) (fvs1 `plusFV` fvs) ds
-
-rnIfaceDecl (mod, decl) = initIfaceRnMS mod (rnDecl decl)
-
-
--------------------------------------------------------
-- Augment decls with any decls needed by needed.
-- Return also free vars of the new decls (only)
slurpDecls decls needed
-------------------------------------------------------
slurpDecl decls fvs wanted_name
- = importDecl wanted_name `thenRn` \ maybe_decl ->
- case maybe_decl of
- -- No declaration... (wired in thing)
- Nothing -> returnRn (decls, fvs)
-
+ = importDecl wanted_name `thenRn` \ import_result ->
+ case import_result of
-- Found a declaration... rename it
- Just decl -> rnIfaceDecl decl `thenRn` \ (new_decl, fvs1) ->
- returnRn (new_decl:decls, fvs1 `plusFV` fvs)
+ HereItIs decl -> rnIfaceDecl decl `thenRn` \ (new_decl, fvs1) ->
+ returnRn (new_decl:decls, fvs1 `plusFV` fvs)
+
+ -- No declaration... (wired in thing, or deferred, or already slurped)
+ other -> returnRn (decls, fvs)
+
+
+-------------------------------------------------------
+rnIfaceDecls :: [RenamedHsDecl] -> FreeVars
+ -> [(Module, RdrNameHsDecl)]
+ -> RnM d ([RenamedHsDecl], FreeVars)
+rnIfaceDecls decls fvs [] = returnRn (decls, fvs)
+rnIfaceDecls decls fvs (d:ds) = rnIfaceDecl d `thenRn` \ (new_decl, fvs1) ->
+ rnIfaceDecls (new_decl:decls) (fvs1 `plusFV` fvs) ds
+
+rnIfaceDecl (mod, decl) = initIfaceRnMS mod (rnDecl decl)
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Deferred declarations}
+%* *
+%*********************************************************
+
+The idea of deferred declarations is this. Suppose we have a function
+ f :: T -> Int
+ data T = T1 A | T2 B
+ data A = A1 X | A2 Y
+ data B = B1 P | B2 Q
+Then we don't want to load T and all its constructors, and all
+the types those constructors refer to, and all the types *those*
+constructors refer to, and so on. That might mean loading many more
+interface files than is really necessary. So we 'defer' loading T.
+
+But f might be strict, and the calling convention for evaluating
+values of type T depends on how many constructors T has, so
+we do need to load T, but not the full details of the type T.
+So we load the full decl for T, but only skeleton decls for A and B:
+ f :: T -> Int
+ data T = {- 2 constructors -}
+
+Whether all this is worth it is moot.
+
+\begin{code}
+slurpDeferredDecls :: [RenamedHsDecl] -> RnMG [RenamedHsDecl]
+slurpDeferredDecls decls
+ = getDeferredDecls `thenRn` \ def_decls ->
+ rnIfaceDecls decls emptyFVs (map stripDecl def_decls) `thenRn` \ (decls1, fvs) ->
+ ASSERT( isEmptyFVs fvs )
+ returnRn decls1
+
+stripDecl (mod, TyClD (TyData dt _ tc tvs _ nconstrs _ _ loc))
+ = (mod, TyClD (TyData dt [] tc tvs [] nconstrs Nothing NoDataPragmas loc))
+ -- Nuke the context and constructors
+ -- But retain the *number* of constructors!
+ -- Also the tvs will have kinds on them.
\end{code}
(map getTyVarName tvs)
-- A type synonym type constructor isn't a "gate" for instance decls
-getGates source_fvs (TyClD (TyData _ ctxt tycon tvs cons _ _ _))
+getGates source_fvs (TyClD (TyData _ ctxt tycon tvs cons _ _ _ _))
= delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) cons)
(map getTyVarName tvs)
`addOneToNameSet` tycon
%*********************************************************
%* *
+\subsection{Fixities}
+%* *
+%*********************************************************
+
+\begin{code}
+fixitiesFromLocalDecls :: GlobalRdrEnv -> [RdrNameHsDecl] -> RnMG FixityEnv
+fixitiesFromLocalDecls gbl_env decls
+ = foldlRn getFixities emptyNameEnv decls `thenRn` \ env ->
+ traceRn (text "fixity env" <+> vcat (map ppr (nameEnvElts env))) `thenRn_`
+ returnRn env
+ where
+ getFixities :: FixityEnv -> RdrNameHsDecl -> RnMG FixityEnv
+ getFixities acc (FixD fix)
+ = fix_decl acc fix
+
+ getFixities acc (TyClD (ClassDecl _ _ _ _ sigs _ _ _ _ _ _ _))
+ = foldlRn fix_decl acc [sig | FixSig sig <- sigs]
+ -- Get fixities from class decl sigs too.
+ getFixities acc other_decl
+ = returnRn acc
+
+ fix_decl acc sig@(FixitySig rdr_name fixity loc)
+ = -- Check for fixity decl for something not declared
+ case lookupRdrEnv gbl_env rdr_name of {
+ Nothing | opt_WarnUnusedBinds
+ -> pushSrcLocRn loc (addWarnRn (unusedFixityDecl rdr_name fixity))
+ `thenRn_` returnRn acc
+ | otherwise -> returnRn acc ;
+
+ Just (name:_) ->
+
+ -- Check for duplicate fixity decl
+ case lookupNameEnv acc name of {
+ Just (FixitySig _ _ loc') -> addErrRn (dupFixityDecl rdr_name loc loc')
+ `thenRn_` returnRn acc ;
+
+ Nothing -> returnRn (addToNameEnv acc name (FixitySig name fixity loc))
+ }}
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Deprecations}
+%* *
+%*********************************************************
+
+For deprecations, all we do is check that the names are in scope.
+It's only imported deprecations, dealt with in RnIfaces, that we
+gather them together.
+
+\begin{code}
+rnDeprecs :: GlobalRdrEnv -> Maybe DeprecTxt
+ -> [RdrNameHsDecl] -> RnMG [RdrNameDeprecation]
+rnDeprecs gbl_env mod_deprec decls
+ = mapRn rn_deprec deprecs `thenRn_`
+ returnRn (extra_deprec ++ deprecs)
+ where
+ deprecs = [d | DeprecD d <- decls]
+ extra_deprec = case mod_deprec of
+ Nothing -> []
+ Just txt -> [Deprecation (IEModuleContents undefined) txt noSrcLoc]
+
+ rn_deprec (Deprecation ie txt loc)
+ = pushSrcLocRn loc $
+ mapRn check (ieNames ie)
+
+ check n = case lookupRdrEnv gbl_env n of
+ Nothing -> addErrRn (unknownNameErr n)
+ Just _ -> returnRn ()
+\end{code}
+
+
+%*********************************************************
+%* *
\subsection{Unused names}
%* *
%*********************************************************
\begin{code}
reportUnusedNames :: ModuleName -> [ModuleName]
-> GlobalRdrEnv -> AvailEnv
- -> ExportEnv -> NameSet -> RnMG ()
+ -> Avails -> NameSet -> RnMG ()
reportUnusedNames mod_name direct_import_mods
gbl_env avail_env
- (ExportEnv export_avails _ _) mentioned_names
+ export_avails mentioned_names
= let
used_names = mentioned_names `unionNameSets` availsToNameSet export_avails
other -> pprTrace "to_ie" (ppr n <+> ppr (nameModule n) <+> ppr other) $
returnRn (IEVar n)
-warnDeprec :: (Name, DeprecTxt) -> RnM d ()
-warnDeprec (name, txt)
- = pushSrcLocRn (getSrcLoc name) $
- addWarnRn $
- sep [ text (occNameFlavour (nameOccName name)) <+> ppr name <+>
- text "is deprecated:", nest 4 (ppr txt) ]
-
-
rnDump :: [RenamedHsDecl] -- Renamed imported decls
-> [RenamedHsDecl] -- Renamed local decls
-> RnMG (IO ())
-rnDump imp_decls decls
+rnDump imp_decls local_decls
| opt_D_dump_rn_trace ||
opt_D_dump_rn_stats ||
opt_D_dump_rn
= getRnStats imp_decls `thenRn` \ stats_msg ->
returnRn (printErrs stats_msg >>
- dumpIfSet opt_D_dump_rn "Renamer:" (vcat (map ppr decls)))
+ dumpIfSet opt_D_dump_rn "Renamer:"
+ (vcat (map ppr (local_decls ++ imp_decls))))
| otherwise = returnRn (return ())
\end{code}
getRnStats imported_decls
= getIfacesRn `thenRn` \ ifaces ->
let
- n_mods = length [() | (_, _, _, Just _) <- eltsFM (iImpModInfo ifaces)]
+ n_mods = length [() | (_, _, Just _) <- eltsFM (iImpModInfo ifaces)]
decls_read = [decl | (_, avail, True, (_,decl)) <- nameEnvElts (iDecls ifaces),
-- Data, newtype, and class decls are in the decls_fm
inst_decls = length [() | InstD _ <- decls]
\end{code}
+
+%************************************************************************
+%* *
+\subsection{Errors and warnings}
+%* *
+%************************************************************************
+
+\begin{code}
+warnDeprec :: (Name, DeprecTxt) -> RnM d ()
+warnDeprec (name, txt)
+ = pushSrcLocRn (getSrcLoc name) $
+ addWarnRn $
+ sep [ text (occNameFlavour (nameOccName name)) <+> ppr name <+>
+ text "is deprecated:", nest 4 (ppr txt) ]
+
+
+unusedFixityDecl rdr_name fixity
+ = hsep [ptext SLIT("Unused fixity declaration for"), quotes (ppr rdr_name)]
+
+dupFixityDecl rdr_name loc1 loc2
+ = vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name),
+ ptext SLIT("at ") <+> ppr loc1,
+ ptext SLIT("and") <+> ppr loc2]
+\end{code}
import {-# SOURCE #-} RnSource ( rnHsSigType )
import HsSyn
-import HsBinds ( sigsForMe, cmpHsSig, sigName, hsSigDoc )
+import HsBinds ( eqHsSig, sigName, hsSigDoc )
import RdrHsSyn
import RnHsSyn
import RnMonad
import RnExpr ( rnMatch, rnGRHSs, rnPat, checkPrecMatch )
-import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, lookupGlobalOccRn, lookupOccRn,
+import RnEnv ( bindLocatedLocalsRn, lookupBndrRn,
+ lookupGlobalOccRn, lookupOccRn, lookupSigOccRn,
warnUnusedLocalBinds, mapFvRn,
FreeVars, emptyFVs, plusFV, plusFVs, unitFV, addOneFV,
unknownNameErr
= returnRn (EmptyBinds, emptyFVs)
rnTopMonoBinds mbinds sigs
- = mapRn lookupBndrRn binder_rdr_names `thenRn` \ binder_names ->
- renameSigs (okBindSig (mkNameSet binder_names)) sigs `thenRn` \ (siglist, sig_fvs) ->
+ = mapRn lookupBndrRn binder_rdr_names `thenRn` \ binder_names ->
+ let
+ bndr_name_set = mkNameSet binder_names
+ in
+ renameSigs (okBindSig bndr_name_set) sigs `thenRn` \ (siglist, sig_fvs) ->
let
type_sig_vars = [n | Sig n _ _ <- siglist]
- un_sigd_binders | opt_WarnMissingSigs = binder_names `minusList` type_sig_vars
+ un_sigd_binders | opt_WarnMissingSigs = nameSetToList (delListFromNameSet bndr_name_set type_sig_vars)
| otherwise = []
in
mapRn_ (addWarnRn.missingSigWarn) un_sigd_binders `thenRn_`
-- Find which things are bound in this group
let
names_bound_here = mkNameSet (collectPatBinders pat')
- sigs_for_me = sigsForMe (`elemNameSet` names_bound_here) sigs
in
+ sigsForMe names_bound_here sigs `thenRn` \ sigs_for_me ->
rnGRHSs grhss `thenRn` \ (grhss', fvs) ->
returnRn
[(names_bound_here,
= pushSrcLocRn locn $
lookupBndrRn name `thenRn` \ new_name ->
let
- sigs_for_me = sigsForMe (new_name ==) sigs
+ names_bound_here = unitNameSet new_name
in
+ sigsForMe names_bound_here sigs `thenRn` \ sigs_for_me ->
mapFvRn rnMatch matches `thenRn` \ (new_matches, fvs) ->
mapRn_ (checkPrecMatch inf new_name) new_matches `thenRn_`
returnRn
FunMonoBind new_name inf new_matches locn,
sigs_for_me
)]
+
+
+sigsForMe names_bound_here sigs
+ = foldlRn check [] (filter (sigForThisGroup names_bound_here) sigs)
+ where
+ check sigs sig = case filter (eqHsSig sig) sigs of
+ [] -> returnRn (sig:sigs)
+ other -> dupSigDeclErr sig `thenRn_`
+ returnRn sigs
\end{code}
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
+ (goods, bads) = partition ok_sig in_scope
in
mapRn_ unknownSigErr bads `thenRn_`
- mapRn_ dupSigDeclErr dups `thenRn_`
returnRn (goods, fvs)
--- We use lookupOccRn in the signatures, which is a little bit unsatisfactory
+-- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory
-- because this won't work for:
-- instance Foo T where
-- {-# INLINE op #-}
renameSig (Sig v ty src_loc)
= pushSrcLocRn src_loc $
- lookupOccRn v `thenRn` \ new_v ->
+ lookupSigOccRn 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 (SpecSig v ty src_loc)
= pushSrcLocRn src_loc $
- lookupOccRn v `thenRn` \ new_v ->
+ lookupSigOccRn 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 (FixSig (FixitySig v fix src_loc))
= pushSrcLocRn src_loc $
- lookupOccRn v `thenRn` \ new_v ->
+ lookupSigOccRn v `thenRn` \ new_v ->
returnRn (FixSig (FixitySig new_v fix src_loc), unitFV new_v)
-renameSig (DeprecSig (Deprecation ie txt) src_loc)
- = pushSrcLocRn src_loc $
- renameIE lookupOccRn ie `thenRn` \ (new_ie, fvs) ->
- returnRn (DeprecSig (Deprecation new_ie txt) src_loc, fvs)
-
renameSig (InlineSig v p src_loc)
= pushSrcLocRn src_loc $
- lookupOccRn v `thenRn` \ new_v ->
+ lookupSigOccRn v `thenRn` \ new_v ->
returnRn (InlineSig new_v p src_loc, unitFV new_v)
renameSig (NoInlineSig v p src_loc)
= pushSrcLocRn src_loc $
- lookupOccRn v `thenRn` \ new_v ->
+ lookupSigOccRn v `thenRn` \ new_v ->
returnRn (NoInlineSig new_v p src_loc, unitFV new_v)
\end{code}
%************************************************************************
\begin{code}
-dupSigDeclErr (sig:sigs)
+dupSigDeclErr sig
= pushSrcLocRn loc $
addErrRn (sep [ptext SLIT("Duplicate") <+> ptext what_it_is <> colon,
ppr sig])
import Name ( Name, Provenance(..), ExportFlag(..), NamedThing(..),
ImportReason(..), getSrcLoc,
mkLocalName, mkImportedLocalName, mkGlobalName, mkUnboundName,
- mkIPName, isSystemName, isWiredInName,
+ mkIPName, isWiredInName, hasBetterProv,
nameOccName, setNameModule, nameModule,
pprOccName, isLocallyDefined, nameUnique, nameOccName,
- occNameUserString,
setNameProvenance, getNameProvenance, pprNameProvenance
)
import NameSet
mkDFunOcc, occNameUserString, occNameString,
occNameFlavour
)
-import TysWiredIn ( tupleTyCon, unboxedTupleTyCon, listTyCon )
+import TysWiredIn ( listTyCon )
import Type ( funTyCon )
import Module ( ModuleName, mkThisModule, moduleName, mkVanillaModule, pprModuleName )
import TyCon ( TyCon )
import UniqSupply
import SrcLoc ( SrcLoc, noSrcLoc )
import Outputable
-import Util ( removeDups, equivClasses, thenCmp )
+import Util ( removeDups, equivClasses, thenCmp, sortLt )
import List ( nub )
\end{code}
%*********************************************************
\begin{code}
-newLocalTopBinder :: Module -> OccName
- -> (Name -> ExportFlag) -> SrcLoc
- -> RnM d Name
-newLocalTopBinder mod occ rec_exp_fn loc
- = newTopBinder mod occ (\name -> setNameProvenance name (LocalDef loc (rec_exp_fn name)))
- -- We must set the provenance of the thing in the cache
- -- correctly, particularly whether or not it is locally defined.
- --
- -- Since newLocalTopBinder is used only
- -- at binding occurrences, we may as well get the provenance
- -- dead right first time; hence the rec_exp_fn passed in
-
-newImportedBinder :: Module -> RdrName -> RnM d Name
-newImportedBinder mod rdr_name
- = ASSERT2( isUnqual rdr_name, ppr rdr_name )
- newTopBinder mod (rdrNameOcc rdr_name) (\name -> name)
- -- Provenance is already implicitImportProvenance
-
implicitImportProvenance = NonLocalDef ImplicitImport False
-newTopBinder :: Module -> OccName -> (Name -> Name) -> RnM d Name
-newTopBinder mod occ set_prov
+newTopBinder :: Module -> OccName -> RnM d Name
+newTopBinder mod occ
= -- First check the cache
+ traceRn (text "newTopBinder" <+> ppr mod <+> ppr occ) `thenRn_`
+
getNameSupplyRn `thenRn` \ (us, inst_ns, cache, ipcache) ->
let
key = (moduleName mod, occ)
in
case lookupFM cache key of
- -- A hit in the cache!
- -- Set the Module of the thing, and set its provenance (hack pending
- -- spj update)
+ -- A hit in the cache! We are at the binding site of the name, which is
+ -- the time we know all about the Name's host Module (in particular, which
+ -- package it comes from), so update the Module in the name.
+ -- But otherwise *leave the Provenance alone*:
--
- -- It also means that if there are two defns for the same thing
- -- in a module, then each gets a separate SrcLoc
+ -- * For imported names, the Provenance may already be correct.
+ -- e.g. We imported Prelude.hi, and set the provenance of PrelShow.Show
+ -- to 'UserImport from Prelude'. Note that we havn't yet opened PrelShow.hi
+ -- Later we find we really need PrelShow.Show, so we open PrelShow.hi, and
+ -- that's when we find the binding occurrence of Show.
--
- -- There's a complication for wired-in names. We don't want to
+ -- * For locally defined names, we do a setProvenance on the Name
+ -- right after newTopBinder, and then use updateProveances to finally
+ -- set the provenances in the cache correctly.
+ --
+ -- NB: for wired-in names it's important not to
-- forget that they are wired in even when compiling that module
-- (else we spit out redundant defns into the interface file)
- -- So for them we just set the provenance
Just name -> let
- new_name = set_prov (setNameModule name mod)
+ new_name = setNameModule name mod
new_cache = addToFM cache key new_name
in
setNameSupplyRn (us, inst_ns, new_cache, ipcache) `thenRn_`
+ traceRn (text "newTopBinder: overwrite" <+> ppr new_name) `thenRn_`
returnRn new_name
-- Miss in the cache!
-- Build a completely new Name, and put it in the cache
+ -- Even for locally-defined names we use implicitImportProvenance;
+ -- updateProvenances will set it to rights
Nothing -> let
(us', us1) = splitUniqSupply us
uniq = uniqFromSupply us1
- new_name = set_prov (mkGlobalName uniq mod occ implicitImportProvenance)
+ new_name = mkGlobalName uniq mod occ implicitImportProvenance
new_cache = addToFM cache key new_name
in
setNameSupplyRn (us', inst_ns, new_cache, ipcache) `thenRn_`
+ traceRn (text "newTopBinder: new" <+> ppr new_name) `thenRn_`
returnRn new_name
key = (mod_name, occ)
in
case lookupFM cache key of
- Just name -> returnRn name
- Nothing -> setNameSupplyRn (us', inst_ns, new_cache, ipcache) `thenRn_`
+ Just name -> traceRn (text "mkImportedGlobalName: hit" <+> ppr name) `thenRn_`
+ returnRn name
+ Nothing -> setNameSupplyRn (us', inst_ns, new_cache, ipcache) `thenRn_`
+ traceRn (text "mkImportedGlobalName: new" <+> ppr name) `thenRn_`
returnRn name
where
(us', us1) = splitUniqSupply us
= setNameProvenance name_in_cache (getNameProvenance name_with_prov)
-
mkImportedGlobalFromRdrName :: RdrName -> RnM d Name
mkImportedGlobalFromRdrName rdr_name
| isQual rdr_name
%* *
%*********************************************************
-@newImplicitBinder@ is used for (a) dfuns
-(b) default methods, defined in this module.
+@newImplicitBinder@ is used for
+ (a) dfuns (RnSource.rnDecl on InstDecls)
+ (b) default methods (RnSource.rnDecl on ClassDecls)
+when these dfuns/default methods are defined in the module being compiled
\begin{code}
newImplicitBinder occ src_loc
= getModuleRn `thenRn` \ mod_name ->
- newLocalTopBinder (mkThisModule mod_name) occ (\_ -> Exported) src_loc
+ newTopBinder (mkThisModule mod_name) occ `thenRn` \ name ->
+ returnRn (setNameProvenance name (LocalDef src_loc Exported))
\end{code}
Make a name for the dict fun for an instance decl
\begin{code}
getDFunKey :: RenamedHsType -> (OccName, OccName) -- Used to manufacture DFun names
-getDFunKey (HsForAllTy _ _ ty) = getDFunKey ty
-getDFunKey (MonoFunTy _ ty) = getDFunKey ty
-getDFunKey (MonoDictTy cls (ty:_)) = (nameOccName cls, get_tycon_key ty)
-
-get_tycon_key (MonoTyVar tv) = nameOccName (getName tv)
-get_tycon_key (MonoTyApp ty _) = get_tycon_key ty
-get_tycon_key (MonoTupleTy tys True) = getOccName (tupleTyCon (length tys))
-get_tycon_key (MonoTupleTy tys False) = getOccName (unboxedTupleTyCon (length tys))
-get_tycon_key (MonoListTy _) = getOccName listTyCon
-get_tycon_key (MonoFunTy _ _) = getOccName funTyCon
+getDFunKey (HsForAllTy _ _ ty) = getDFunKey ty
+getDFunKey (HsFunTy _ ty) = getDFunKey ty
+getDFunKey (HsPredTy (HsPClass cls (ty:_))) = (nameOccName cls, get_tycon_key ty)
+
+get_tycon_key (HsTyVar tv) = getOccName tv
+get_tycon_key (HsAppTy ty _) = get_tycon_key ty
+get_tycon_key (HsTupleTy (HsTupCon n _) tys) = getOccName n
+get_tycon_key (HsListTy _) = getOccName listTyCon
+get_tycon_key (HsFunTy _ _) = getOccName funTyCon
\end{code}
bindUVarRn = bindLocalRn
-------------------------------------
-extendTyVarEnvFVRn :: [HsTyVar Name] -> RnMS (a, FreeVars) -> RnMS (a, FreeVars)
+extendTyVarEnvFVRn :: [HsTyVarBndr Name] -> RnMS (a, FreeVars) -> RnMS (a, FreeVars)
-- This tiresome function is used only in rnDecl on InstDecl
extendTyVarEnvFVRn tyvars enclosed_scope
= getLocalNameEnv `thenRn` \ env ->
setLocalNameEnv new_env enclosed_scope `thenRn` \ (thing, fvs) ->
returnRn (thing, delListFromNameSet fvs tyvar_names)
-bindTyVarsRn :: SDoc -> [HsTyVar RdrName]
- -> ([HsTyVar Name] -> RnMS a)
+bindTyVarsRn :: SDoc -> [HsTyVarBndr RdrName]
+ -> ([HsTyVarBndr Name] -> RnMS a)
-> RnMS a
bindTyVarsRn doc_str tyvar_names enclosed_scope
= bindTyVars2Rn doc_str tyvar_names $ \ names tyvars ->
enclosed_scope tyvars
-- Gruesome name: return Names as well as HsTyVars
-bindTyVars2Rn :: SDoc -> [HsTyVar RdrName]
- -> ([Name] -> [HsTyVar Name] -> RnMS a)
+bindTyVars2Rn :: SDoc -> [HsTyVarBndr RdrName]
+ -> ([Name] -> [HsTyVarBndr Name] -> RnMS a)
-> RnMS a
bindTyVars2Rn doc_str tyvar_names enclosed_scope
= getSrcLocRn `thenRn` \ loc ->
bindLocatedLocalsRn doc_str located_tyvars $ \ names ->
enclosed_scope names (zipWith replaceTyVarName tyvar_names names)
-bindTyVarsFVRn :: SDoc -> [HsTyVar RdrName]
- -> ([HsTyVar Name] -> RnMS (a, FreeVars))
+bindTyVarsFVRn :: SDoc -> [HsTyVarBndr RdrName]
+ -> ([HsTyVarBndr Name] -> RnMS (a, FreeVars))
-> RnMS (a, FreeVars)
bindTyVarsFVRn doc_str rdr_names enclosed_scope
= bindTyVars2Rn doc_str rdr_names $ \ names tyvars ->
enclosed_scope tyvars `thenRn` \ (thing, fvs) ->
returnRn (thing, delListFromNameSet fvs names)
-bindTyVarsFV2Rn :: SDoc -> [HsTyVar RdrName]
- -> ([Name] -> [HsTyVar Name] -> RnMS (a, FreeVars))
+bindTyVarsFV2Rn :: SDoc -> [HsTyVarBndr RdrName]
+ -> ([Name] -> [HsTyVarBndr Name] -> RnMS (a, FreeVars))
-> RnMS (a, FreeVars)
bindTyVarsFV2Rn doc_str rdr_names enclosed_scope
= bindTyVars2Rn doc_str rdr_names $ \ names tyvars ->
\begin{code}
lookupBndrRn rdr_name
- = getNameEnvs `thenRn` \ (global_env, local_env) ->
+ = traceRn (text "lookupBndrRn" <+> ppr rdr_name) `thenRn_`
+ getNameEnvs `thenRn` \ (global_env, local_env) ->
-- Try local env
case lookupRdrEnv local_env rdr_name of {
getModeRn `thenRn` \ mode ->
case mode of
InterfaceMode -> -- Look in the global name cache
- mkImportedGlobalFromRdrName rdr_name
+ mkImportedGlobalFromRdrName rdr_name `thenRn` \ n ->
+ traceRn (text "lookupBndrRn result:" <+> ppr n) `thenRn_`
+ returnRn n
SourceMode -> -- Source mode, so look up a *qualified* version
-- of the name, so that we get the right one even
Nothing -> pprPanic "lookupBndrRn" (ppr mod <+> ppr rdr_name)
}
--- Just like lookupRn except that we record the occurrence too
--- Perhaps surprisingly, even wired-in names are recorded.
--- Why? So that we know which wired-in names are referred to when
--- deciding which instance declarations to import.
+-- lookupOccRn looks up an occurrence of a RdrName
lookupOccRn :: RdrName -> RnMS Name
lookupOccRn rdr_name
= getNameEnvs `thenRn` \ (global_env, local_env) ->
= getNameEnvs `thenRn` \ (global_env, local_env) ->
lookup_global_occ global_env rdr_name
+-- lookupSigOccRn is used for type signatures and pragmas
+-- Is this valid?
+-- module A
+-- import M( f )
+-- f :: Int -> Int
+-- f x = x
+-- In a sense, it's clear that the 'f' in the signature must refer
+-- to A.f, but the Haskell98 report does not stipulate this, so
+-- I treat the 'f' in the signature as a reference to an unqualified
+-- 'f' and hence fail with an ambiguous reference.
+lookupSigOccRn :: RdrName -> RnMS Name
+lookupSigOccRn = lookupOccRn
+
+{- OLD VERSION
+-- This code tries to be cleverer than the above.
+-- The variable in a signature must refer to a locally-defined thing,
+-- even if there's an imported thing of the same name.
+--
+-- But this doesn't work for instance decls:
+-- instance Enum Int where
+-- {-# INLINE enumFrom #-}
+-- ...
+-- Here the enumFrom is an imported reference!
+lookupSigOccRn rdr_name
+ = getNameEnvs `thenRn` \ (global_env, local_env) ->
+ case (lookupRdrEnv local_env rdr_name, lookupRdrEnv global_env rdr_name) of
+ (Just name, _) -> returnRn name
+
+ (Nothing, Just names) -> case filter isLocallyDefined names of
+ [n] -> returnRn n
+ ns -> pprPanic "lookupSigOccRn" (ppr rdr_name <+> ppr names <+> ppr ns)
+ -- There can't be a local top-level name-clash
+ -- (That's dealt with elsewhere.)
+
+ (Nothing, Nothing) -> failWithRn (mkUnboundName rdr_name)
+ (unknownNameErr rdr_name)
+-}
+
+
-- Look in both local and global env
lookup_occ global_env local_env rdr_name
= case lookupRdrEnv local_env rdr_name of
\begin{code}
lookupImplicitOccRn :: RdrName -> RnM d Name
lookupImplicitOccRn rdr_name = mkImportedGlobalFromRdrName rdr_name
+
+lookupImplicitOccsRn :: [RdrName] -> RnM d NameSet
+lookupImplicitOccsRn rdr_names
+ = mapRn lookupImplicitOccRn rdr_names `thenRn` \ names ->
+ returnRn (mkNameSet names)
\end{code}
@unQualInScope@ returns a function that takes a @Name@ and tells whether
add n ns | any (is_duplicate n) ns_old = map choose ns -- Eliminate duplicates
| otherwise = n:ns
where
- choose n' | n==n' && better_provenance n n' = n
- | otherwise = n'
-
--- Choose
--- a local thing over an imported thing
--- a user-imported thing over a non-user-imported thing
--- an explicitly-imported thing over an implicitly imported thing
-better_provenance n1 n2
- = case (getNameProvenance n1, getNameProvenance n2) of
- (LocalDef _ _, _ ) -> True
- (NonLocalDef (UserImport _ _ True) _, _ ) -> True
- (NonLocalDef (UserImport _ _ _ ) _, NonLocalDef ImplicitImport _) -> True
- other -> False
+ choose m | n==m && n `hasBetterProv` m = n
+ | otherwise = m
+
is_duplicate :: Name -> Name -> Bool
is_duplicate n1 n2 | isLocallyDefined n1 && isLocallyDefined n2 = False
availsToNameSet :: [AvailInfo] -> NameSet
availsToNameSet avails = foldl addAvailToNameSet emptyNameSet avails
-availName :: AvailInfo -> Name
+availName :: GenAvailInfo name -> name
availName (Avail n) = n
availName (AvailTC n _) = n
-availNames :: AvailInfo -> [Name]
+availNames :: GenAvailInfo name -> [name]
availNames (Avail n) = [n]
availNames (AvailTC n ns) = ns
addSysAvails avail [] = avail
addSysAvails (AvailTC n ns) sys = AvailTC n (sys ++ ns)
+rdrAvailInfo :: AvailInfo -> RdrAvailInfo
+-- Used when building the avails we are going to put in an interface file
+-- We sort the components to reduce needless wobbling of interfaces
+rdrAvailInfo (Avail n) = Avail (nameOccName n)
+rdrAvailInfo (AvailTC n ns) = AvailTC (nameOccName n) (sortLt (<) (map nameOccName ns))
+
filterAvail :: RdrNameIE -- Wanted
-> AvailInfo -- Available
-> Maybe AvailInfo -- Resulting available;
#include "HsVersions.h"
import {-# SOURCE #-} RnBinds ( rnBinds )
-import {-# SOURCE #-} RnSource ( rnHsSigType, rnHsPolyType, rnHsType )
+import {-# SOURCE #-} RnSource ( rnHsSigType, rnHsType )
import HsSyn
import RdrHsSyn
import RnHsSyn
import RnMonad
import RnEnv
-import RnIfaces ( lookupFixity )
+import RnIfaces ( lookupFixityRn )
import CmdLineOpts ( opt_GlasgowExts, opt_IgnoreAsserts )
import BasicTypes ( Fixity(..), FixityDirection(..), defaultFixity, negateFixity, negatePrecedence )
import PrelInfo ( numClass_RDR, fractionalClass_RDR, eqClass_RDR,
ccallableClass_RDR, creturnableClass_RDR,
monadClass_RDR, enumClass_RDR, ordClass_RDR,
ratioDataCon_RDR, negate_RDR, assertErr_RDR,
- ioDataCon_RDR
+ ioDataCon_RDR, addr2Integer_RDR,
+ foldr_RDR, build_RDR
)
import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon,
floatPrimTyCon, doublePrimTyCon
import UniqFM ( isNullUFM )
import FiniteMap ( elemFM )
import UniqSet ( emptyUniqSet, UniqSet )
-import Unique ( assertIdKey )
+import Unique ( hasKey, assertIdKey )
import Util ( removeDups )
import ListSetOps ( unionLists )
import Maybes ( maybeToBool )
rnPat (SigPatIn pat ty)
| opt_GlasgowExts
= rnPat pat `thenRn` \ (pat', fvs1) ->
- rnHsPolyType doc ty `thenRn` \ (ty', fvs2) ->
+ rnHsType doc ty `thenRn` \ (ty', fvs2) ->
returnRn (SigPatIn pat' ty', fvs1 `plusFV` fvs2)
| otherwise
-- See comments with rnExpr (OpApp ...)
(case mode of
InterfaceMode -> returnRn (ConOpPatIn pat1' con' defaultFixity pat2')
- SourceMode -> lookupFixity con' `thenRn` \ fixity ->
+ SourceMode -> lookupFixityRn con' `thenRn` \ fixity ->
mkConOpPatRn pat1' con' fixity pat2'
) `thenRn` \ pat' ->
returnRn (pat', fvs1 `plusFV` fvs2 `addOneFV` con')
rnGRHSs grhss `thenRn` \ (grhss', grhss_fvs) ->
(case maybe_rhs_sig of
Nothing -> returnRn (Nothing, emptyFVs)
- Just ty | opt_GlasgowExts -> rnHsPolyType doc_sig ty `thenRn` \ (ty', ty_fvs) ->
+ Just ty | opt_GlasgowExts -> rnHsType doc_sig ty `thenRn` \ (ty', ty_fvs) ->
returnRn (Just ty', ty_fvs)
| otherwise -> addErrRn (patSigErr ty) `thenRn_`
returnRn (Nothing, emptyFVs)
rnExpr (HsVar v)
= lookupOccRn v `thenRn` \ name ->
- if nameUnique name == assertIdKey then
+ if name `hasKey` assertIdKey then
-- We expand it to (GHCerr.assert__ location)
mkAssertExpr
else
-- Don't even look up the fixity when in interface mode
getModeRn `thenRn` \ mode ->
(case mode of
- SourceMode -> lookupFixity op_name `thenRn` \ fixity ->
+ SourceMode -> lookupFixityRn op_name `thenRn` \ fixity ->
mkOpAppRn e1' op' fixity e2'
InterfaceMode -> returnRn (OpApp e1' op' defaultFixity e2')
) `thenRn` \ final_e ->
rnExpr (HsCCall fun args may_gc is_casm fake_result_ty)
-- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls
- = lookupImplicitOccRn ccallableClass_RDR `thenRn` \ cc ->
- lookupImplicitOccRn creturnableClass_RDR `thenRn` \ cr ->
- lookupImplicitOccRn ioDataCon_RDR `thenRn` \ io ->
+ = lookupImplicitOccsRn [ccallableClass_RDR,
+ creturnableClass_RDR,
+ ioDataCon_RDR] `thenRn` \ implicit_fvs ->
rnExprs args `thenRn` \ (args', fvs_args) ->
returnRn (HsCCall fun args' may_gc is_casm fake_result_ty,
- fvs_args `addOneFV` cc `addOneFV` cr `addOneFV` io)
+ fvs_args `plusFV` implicit_fvs)
rnExpr (HsSCC lbl expr)
= rnExpr expr `thenRn` \ (expr', fvs_expr) ->
rnExpr e@(HsDo do_or_lc stmts src_loc)
= pushSrcLocRn src_loc $
- lookupImplicitOccRn monadClass_RDR `thenRn` \ monad ->
+ lookupImplicitOccsRn implicit_rdr_names `thenRn` \ implicit_fvs ->
rnStmts rnExpr stmts `thenRn` \ (stmts', fvs) ->
-- check the statement list ends in an expression
case last stmts' of {
ReturnStmt _ -> returnRn () ; -- for list comprehensions
_ -> addErrRn (doStmtListErr e)
} `thenRn_`
- returnRn (HsDo do_or_lc stmts' src_loc, fvs `addOneFV` monad)
+ returnRn (HsDo do_or_lc stmts' src_loc, fvs `plusFV` implicit_fvs)
+ where
+ implicit_rdr_names = [foldr_RDR, build_RDR, monadClass_RDR]
+ -- Monad stuff should not be necessary for a list comprehension
+ -- but the typechecker looks up the bind and return Ids anyway
+ -- Oh well.
+
rnExpr (ExplicitList exps)
= rnExprs exps `thenRn` \ (exps', fvs) ->
returnRn (ExplicitList exps', fvs `addOneFV` listTyCon_name)
-rnExpr (ExplicitTuple exps boxed)
+rnExpr (ExplicitTuple exps boxity)
= rnExprs exps `thenRn` \ (exps', fvs) ->
- returnRn (ExplicitTuple exps' boxed, fvs `addOneFV` tycon_name)
+ returnRn (ExplicitTuple exps' boxity, fvs `addOneFV` tycon_name)
where
- tycon_name = tupleTyCon_name boxed (length exps)
+ tycon_name = tupleTyCon_name boxity (length exps)
rnExpr (RecordCon con_id rbinds)
= lookupOccRn con_id `thenRn` \ conname ->
checkPrecMatch True op _ = panic "checkPrecMatch"
checkPrec op (ConOpPatIn _ op1 _ _) right
- = lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
- lookupFixity op1 `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) ->
+ = lookupFixityRn op `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
+ lookupFixityRn op1 `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) ->
let
inf_ok = op1_prec > op_prec ||
(op1_prec == op_prec &&
checkRn inf_ok (precParseErr infol infor)
checkPrec op (NegPatIn _) right
- = lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
+ = lookupFixityRn op `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
checkRn (op_prec <= negatePrecedence) (precParseNegPatErr (ppr_op op,op_fix))
checkPrec op pat right
where
HsVar op_name = op
go_for_it pp_arg_op arg_fix@(Fixity arg_prec _)
- = lookupFixity op_name `thenRn` \ op_fix@(Fixity op_prec _) ->
+ = lookupFixityRn op_name `thenRn` \ op_fix@(Fixity op_prec _) ->
checkRn (op_prec < arg_prec)
(sectionPrecErr (ppr_op op_name, op_fix) (pp_arg_op, arg_fix) section)
\end{code}
= returnRn (unitFV (getName addrPrimTyCon))
litOccurrence (HsInt _)
- = lookupImplicitOccRn numClass_RDR `thenRn` \ num ->
- returnRn (unitFV num) -- Int and Integer are forced in by Num
+ = lookupImplicitOccsRn [numClass_RDR, addr2Integer_RDR]
+ -- Int and Integer are forced in by Num
litOccurrence (HsFrac _)
- = lookupImplicitOccRn fractionalClass_RDR `thenRn` \ frac ->
- lookupImplicitOccRn ratioDataCon_RDR `thenRn` \ ratio ->
- returnRn (unitFV frac `plusFV` unitFV ratio)
+ = lookupImplicitOccsRn [fractionalClass_RDR,ratioDataCon_RDR,addr2Integer_RDR]
-- We have to make sure that the Ratio type is imported with
-- its constructor, because literals of type Ratio t are
-- built with that constructor.
import HsSyn
import HsPragmas ( InstancePragmas, GenPragmas, DataPragmas, ClassPragmas, ClassOpPragmas )
-import TysWiredIn ( tupleTyCon, unboxedTupleTyCon,
- listTyCon, charTyCon )
+import TysWiredIn ( tupleTyCon, listTyCon, charTyCon )
import Name ( Name, getName )
import NameSet
+import BasicTypes ( Boxity )
import Util
import Outputable
\end{code}
type RenamedSig = Sig Name
type RenamedStmt = Stmt Name RenamedPat
type RenamedFixitySig = FixitySig Name
-type RenamedDeprecation = Deprecation Name
+type RenamedDeprecation = DeprecDecl Name
type RenamedClassOpPragmas = ClassOpPragmas Name
type RenamedClassPragmas = ClassPragmas Name
charTyCon_name = getName charTyCon
listTyCon_name = getName listTyCon
-tupleTyCon_name :: Bool -> Int -> Name
-tupleTyCon_name True n = getName (tupleTyCon n)
-tupleTyCon_name False n = getName (unboxedTupleTyCon n)
+tupleTyCon_name :: Boxity -> Int -> Name
+tupleTyCon_name boxity n = getName (tupleTyCon boxity n)
extractHsTyNames :: RenamedHsType -> NameSet
extractHsTyNames ty
= get ty
where
- get (MonoTyApp ty1 ty2) = get ty1 `unionNameSets` get ty2
- get (MonoListTy ty) = unitNameSet listTyCon_name
+ get (HsAppTy ty1 ty2) = get ty1 `unionNameSets` get ty2
+ get (HsListTy ty) = unitNameSet listTyCon_name
`unionNameSets` get ty
- get (MonoTupleTy tys boxed) = unitNameSet (tupleTyCon_name boxed (length tys))
- `unionNameSets` extractHsTyNames_s tys
- get (MonoFunTy ty1 ty2) = get ty1 `unionNameSets` get ty2
- get (MonoIParamTy n ty) = get ty
- get (MonoDictTy cls tys) = unitNameSet cls `unionNameSets` extractHsTyNames_s tys
- get (MonoUsgForAllTy uv ty) = get ty
- get (MonoUsgTy u ty) = get ty
- get (MonoTyVar tv) = unitNameSet tv
+ get (HsTupleTy (HsTupCon n _) tys) = unitNameSet n
+ `unionNameSets` extractHsTyNames_s tys
+ get (HsFunTy ty1 ty2) = get ty1 `unionNameSets` get ty2
+ get (HsPredTy p) = extractHsPredTyNames p
+ get (HsUsgForAllTy uv ty) = get ty
+ get (HsUsgTy u ty) = get ty
+ get (HsTyVar tv) = unitNameSet tv
get (HsForAllTy (Just tvs)
- ctxt ty) = (extractHsCtxtTyNames ctxt `unionNameSets` get ty)
+ ctxt ty) = (extractHsCtxtTyNames ctxt `unionNameSets` get ty)
`minusNameSet`
mkNameSet (map getTyVarName tvs)
get ty@(HsForAllTy Nothing _ _) = pprPanic "extractHsTyNames" (ppr ty)
\begin{code}
module RnIfaces (
- getInterfaceExports,
+ findAndReadIface,
+
+ getInterfaceExports, getDeferredDecls,
getImportedInstDecls, getImportedRules,
- lookupFixity, loadHomeInterface,
- importDecl, recordSlurp,
- getImportVersions, getSlurped,
+ lookupFixityRn, loadHomeInterface,
+ importDecl, ImportDeclResult(..), recordLocalSlurps, loadBuiltinRules,
+ mkImportExportInfo, getSlurped,
- checkUpToDate,
+ checkModUsage, outOfDate, upToDate,
getDeclBinders, getDeclSysBinders,
removeContext -- removeContext probably belongs somewhere else
#include "HsVersions.h"
-import CmdLineOpts ( opt_NoPruneDecls, opt_IgnoreIfacePragmas )
+import CmdLineOpts ( opt_NoPruneDecls, opt_NoPruneTyDecls, opt_IgnoreIfacePragmas )
import HsSyn ( HsDecl(..), TyClDecl(..), InstDecl(..), IfaceSig(..),
HsType(..), ConDecl(..), IE(..), ConDetails(..), Sig(..),
ForeignDecl(..), ForKind(..), isDynamicExtName,
FixitySig(..), RuleDecl(..),
- isClassOpSig, Deprecation(..)
+ isClassOpSig, DeprecDecl(..)
)
+import HsImpExp ( ieNames )
+import CoreSyn ( CoreRule )
import BasicTypes ( Version, NewOrData(..), defaultFixity )
import RdrHsSyn ( RdrNameHsDecl, RdrNameInstDecl, RdrNameTyClDecl, RdrNameRuleDecl,
- extractHsTyRdrNames, RdrNameDeprecation
+ RdrNameFixitySig, RdrNameDeprecation, RdrNameIE,
+ extractHsTyRdrNames
)
-import RnEnv ( mkImportedGlobalName, newImportedBinder, mkImportedGlobalFromRdrName,
+import RnEnv ( mkImportedGlobalName, newTopBinder, mkImportedGlobalFromRdrName,
lookupOccRn, lookupImplicitOccRn,
- pprAvail,
+ pprAvail, rdrAvailInfo,
availName, availNames, addAvailToNameSet, addSysAvails,
FreeVars, emptyFVs
)
import RnHsSyn ( RenamedHsDecl, RenamedDeprecation )
import ParseIface ( parseIface, IfaceStuff(..) )
-import FiniteMap ( FiniteMap, sizeFM, emptyFM, delFromFM, listToFM,
- lookupFM, addToFM, addToFM_C, addListToFM,
- fmToList, elemFM, foldFM
- )
-import Name ( Name {-instance NamedThing-},
- nameModule, isLocallyDefined,
+import Name ( Name {-instance NamedThing-}, nameOccName,
+ nameModule, isLocallyDefined,
isWiredInName, nameUnique, NamedThing(..)
)
import Module ( Module, moduleString, pprModule,
import NameSet
import Var ( Id )
import SrcLoc ( mkSrcLoc, SrcLoc )
-import PrelMods ( pREL_GHC )
-import PrelInfo ( cCallishTyKeys )
-import Bag
+import PrelInfo ( pREL_GHC, cCallishTyKeys )
import Maybes ( MaybeErr(..), maybeToBool, orElse )
import ListSetOps ( unionLists )
-import Outputable
-import Unique ( Unique )
+import Unique ( Unique, Uniquable(..) )
import StringBuffer ( StringBuffer, hGetStringBuffer )
import FastString ( mkFastString )
import ErrUtils ( Message )
+import Util ( sortLt, lengthExceeds )
import Lex
+import FiniteMap
import Outputable
+import Bag
import IO ( isDoesNotExistError )
import List ( nub )
ImportByUserSource -> True ; -- hi-boot
ImportBySystem ->
case mod_info of
- Just (_, _, is_boot, _) -> is_boot
+ Just (_, is_boot, _) -> is_boot
Nothing -> False
-- We're importing a module we know absolutely
}
redundant_source_import
= case (from, mod_info) of
- (ImportByUserSource, Just (_,_,False,_)) -> True
+ (ImportByUserSource, Just (_,False,_)) -> True
other -> False
in
-- CHECK WHETHER WE HAVE IT ALREADY
case mod_info of {
- Just (_, _, _, Just _)
+ Just (_, _, Just _)
-> -- We're read it already so don't re-read it
returnRn (ifaces, Nothing) ;
-- so that we don't look again
let
mod = mkVanillaModule mod_name
- new_mod_map = addToFM mod_map mod_name (0, False, False, Just (mod, from, []))
+ new_mod_map = addToFM mod_map mod_name (False, False, Just (mod, 0, 0, 0, from, []))
new_ifaces = ifaces { iImpModInfo = new_mod_map }
in
setIfacesRn new_ifaces `thenRn_`
getModuleRn `thenRn` \ this_mod_nm ->
let
- rd_decls = pi_decls iface
- mod = pi_mod iface
+ mod = pi_mod iface
in
-- Sanity check. If we're system-importing a module we know nothing at all
-- about, it should be from a different package to this one
case from of { ImportBySystem -> True; other -> False } &&
isLocalModule mod,
ppr mod )
- foldlRn (loadDecl mod) (iDecls ifaces) rd_decls `thenRn` \ new_decls ->
- foldlRn (loadInstDecl mod) (iInsts ifaces) (pi_insts iface) `thenRn` \ new_insts ->
- (if opt_IgnoreIfacePragmas
- then returnRn emptyBag
- else foldlRn (loadRule mod) (iRules ifaces) (pi_rules iface)) `thenRn` \ new_rules ->
- (if opt_IgnoreIfacePragmas
- then returnRn emptyNameEnv
- else foldlRn (loadDeprec mod) (iDeprecs ifaces) (pi_deprecs iface)) `thenRn` \ new_deprecs ->
- foldlRn (loadFixDecl mod_name) (iFixes ifaces) rd_decls `thenRn` \ new_fixities ->
- mapRn (loadExport this_mod_nm) (pi_exports iface) `thenRn` \ avails_s ->
+ foldlRn (loadDecl mod) (iDecls ifaces) (pi_decls iface) `thenRn` \ new_decls ->
+ foldlRn (loadInstDecl mod) (iInsts ifaces) (pi_insts iface) `thenRn` \ new_insts ->
+ loadRules mod (iRules ifaces) (pi_rules iface) `thenRn` \ new_rules ->
+ loadFixDecls mod_name (iFixes ifaces) (pi_fixity iface) `thenRn` \ new_fixities ->
+ foldlRn (loadDeprec mod) (iDeprecs ifaces) (pi_deprecs iface) `thenRn` \ new_deprecs ->
+ mapRn (loadExport this_mod_nm) (pi_exports iface) `thenRn` \ avails_s ->
let
-- For an explicit user import, add to mod_map info about
-- the things the imported module depends on, extracted
-- Now add info about this module
mod_map2 = addToFM mod_map1 mod_name mod_details
- cts = (pi_mod iface, from, concat avails_s)
- mod_details = (pi_vers iface, pi_orphan iface, hi_boot_file, Just cts)
+ cts = (pi_mod iface, pi_vers iface,
+ fst (pi_fixity iface), fst (pi_rules iface),
+ from, concat avails_s)
+ mod_details = (pi_orphan iface, hi_boot_file, Just cts)
new_ifaces = ifaces { iImpModInfo = mod_map2,
iDecls = new_decls,
returnRn (new_ifaces, Nothing)
}}
+-----------------------------------------------------
+-- Adding module dependencies from the
+-- import decls in the interface file
+-----------------------------------------------------
+
addModDeps :: Module -> [ImportVersion a]
-> ImportedModuleInfo -> ImportedModuleInfo
-- (addModDeps M ivs deps)
-- Except for its descendents which contain orphans,
-- and in that case, forget about the boot indicator
filtered_new_deps
- | isLocalModule mod = [ (imp_mod, (version, has_orphans, is_boot, Nothing))
- | (imp_mod, version, has_orphans, is_boot, _) <- new_deps
+ | isLocalModule mod = [ (imp_mod, (has_orphans, is_boot, Nothing))
+ | (imp_mod, has_orphans, is_boot, _) <- new_deps
]
- | otherwise = [ (imp_mod, (version, True, False, Nothing))
- | (imp_mod, version, has_orphans, _, _) <- new_deps,
+ | otherwise = [ (imp_mod, (True, False, Nothing))
+ | (imp_mod, has_orphans, _, _) <- new_deps,
has_orphans
]
add (imp_mod, dep) deps = addToFM_C combine deps imp_mod dep
- combine old@(_, _, old_is_boot, cts) new
+ combine old@(_, old_is_boot, cts) new
| maybeToBool cts || not old_is_boot = old -- Keep the old info if it's already loaded
-- or if it's a non-boot pending load
| otherwise = new -- Otherwise pick new info
+
+-----------------------------------------------------
+-- Loading the export list
+-----------------------------------------------------
+
loadExport :: ModuleName -> ExportItem -> RnM d [AvailInfo]
loadExport this_mod (mod, entities)
| mod == this_mod = returnRn []
returnRn (AvailTC name names)
-loadFixDecl :: ModuleName -> FixityEnv
- -> (Version, RdrNameHsDecl)
- -> RnM d FixityEnv
-loadFixDecl mod_name fixity_env (version, FixD sig@(FixitySig rdr_name fixity loc))
- = -- Ignore the version; when the fixity changes the version of
- -- its 'host' entity changes, so we don't need a separate version
- -- number for fixities
- mkImportedGlobalName mod_name (rdrNameOcc rdr_name) `thenRn` \ name ->
- let
- new_fixity_env = addToNameEnv fixity_env name (FixitySig name fixity loc)
- in
- returnRn new_fixity_env
-
- -- Ignore the other sorts of decl
-loadFixDecl mod_name fixity_env other_decl = returnRn fixity_env
+-----------------------------------------------------
+-- Loading type/class/value decls
+-----------------------------------------------------
loadDecl :: Module
-> DeclsMap
returnRn new_decls_map
}
where
- -- newImportedBinder puts into the cache the binder with the
+ -- newTopBinder puts into the cache the binder with the
-- module information set correctly. When the decl is later renamed,
-- the binding site will thereby get the correct module.
- new_name rdr_name loc = newImportedBinder mod rdr_name
+ -- There maybe occurrences that don't have the correct Module, but
+ -- by the typechecker will propagate the binding definition to all
+ -- the occurrences, so that doesn't matter
+ new_name rdr_name loc = newTopBinder mod (rdrNameOcc rdr_name)
{-
If a signature decl is being loaded, and optIgnoreIfacePragmas is on,
-> SigD (IfaceSig name tp [] loc)
other -> decl
+-----------------------------------------------------
+-- Loading fixity decls
+-----------------------------------------------------
+
+loadFixDecls mod_name fixity_env (version, decls)
+ | null decls = returnRn fixity_env
+
+ | otherwise
+ = mapRn (loadFixDecl mod_name) decls `thenRn` \ to_add ->
+ returnRn (addListToNameEnv fixity_env to_add)
+
+loadFixDecl mod_name sig@(FixitySig rdr_name fixity loc)
+ = mkImportedGlobalName mod_name (rdrNameOcc rdr_name) `thenRn` \ name ->
+ returnRn (name, FixitySig name fixity loc)
+
+
+-----------------------------------------------------
+-- Loading instance decls
+-----------------------------------------------------
+
loadInstDecl :: Module
-> Bag GatedDecl
-> RdrNameInstDecl
removeContext (HsForAllTy tvs cxt ty) = HsForAllTy tvs [] (removeFuns ty)
removeContext ty = removeFuns ty
-removeFuns (MonoFunTy _ ty) = removeFuns ty
+removeFuns (HsFunTy _ ty) = removeFuns ty
removeFuns ty = ty
-loadRule :: Module -> Bag GatedDecl
- -> RdrNameRuleDecl -> RnM d (Bag GatedDecl)
+-----------------------------------------------------
+-- Loading Rules
+-----------------------------------------------------
+
+loadRules :: Module -> IfaceRules
+ -> (Version, [RdrNameRuleDecl])
+ -> RnM d IfaceRules
+loadRules mod rule_bag (version, rules)
+ | null rules || opt_IgnoreIfacePragmas
+ = returnRn rule_bag
+ | otherwise
+ = setModuleRn mod_name $
+ mapRn (loadRule mod) rules `thenRn` \ new_rules ->
+ returnRn (rule_bag `unionBags` listToBag new_rules)
+ where
+ mod_name = moduleName mod
+
+loadRule :: Module -> RdrNameRuleDecl -> RnM d GatedDecl
-- "Gate" the rule simply by whether the rule variable is
-- needed. We can refine this later.
-loadRule mod rules decl@(IfaceRuleDecl var body src_loc)
- = setModuleRn (moduleName mod) $
- mkImportedGlobalFromRdrName var `thenRn` \ var_name ->
- returnRn ((unitNameSet var_name, (mod, RuleD decl)) `consBag` rules)
+loadRule mod decl@(IfaceRule _ _ var _ _ src_loc)
+ = mkImportedGlobalFromRdrName var `thenRn` \ var_name ->
+ returnRn (unitNameSet var_name, (mod, RuleD decl))
+
+loadBuiltinRules :: [(RdrName, CoreRule)] -> RnMG ()
+loadBuiltinRules builtin_rules
+ = getIfacesRn `thenRn` \ ifaces ->
+ mapRn loadBuiltinRule builtin_rules `thenRn` \ rule_decls ->
+ setIfacesRn (ifaces { iRules = iRules ifaces `unionBags` listToBag rule_decls })
+
+loadBuiltinRule (var, rule)
+ = mkImportedGlobalFromRdrName var `thenRn` \ var_name ->
+ returnRn (unitNameSet var_name, (nameModule var_name, RuleD (IfaceRuleOut var rule)))
+
+
+-----------------------------------------------------
+-- Loading Deprecations
+-----------------------------------------------------
--- SUP: TEMPORARY HACK, ignoring module deprecations for now
loadDeprec :: Module -> DeprecationEnv -> RdrNameDeprecation -> RnM d DeprecationEnv
-loadDeprec mod deprec_env (Deprecation (IEModuleContents _) txt)
+loadDeprec mod deprec_env (Deprecation (IEModuleContents _) txt _)
= traceRn (text "module deprecation not yet implemented:" <+> ppr mod <> colon <+> ppr txt) `thenRn_`
+ -- SUP: TEMPORARY HACK, ignoring module deprecations for now
returnRn deprec_env
-loadDeprec mod deprec_env (Deprecation ie txt)
+
+loadDeprec mod deprec_env (Deprecation ie txt _)
= setModuleRn (moduleName mod) $
- mapRn mkImportedGlobalFromRdrName (namesFromIE ie) `thenRn` \ names ->
+ mapRn mkImportedGlobalFromRdrName (ieNames ie) `thenRn` \ names ->
traceRn (text "loaded deprecation(s) for" <+> hcat (punctuate comma (map ppr names)) <> colon <+> ppr txt) `thenRn_`
returnRn (extendNameEnv deprec_env (zip names (repeat txt)))
-
-namesFromIE :: IE a -> [a]
-namesFromIE (IEVar n ) = [n]
-namesFromIE (IEThingAbs n ) = [n]
-namesFromIE (IEThingAll n ) = [n]
-namesFromIE (IEThingWith n ns) = n:ns
-namesFromIE (IEModuleContents _ ) = []
\end{code}
%********************************************************
%* *
-\subsection{Loading usage information}
+\subsection{Checking usage information}
%* *
%********************************************************
upToDate = True
outOfDate = False
-checkUpToDate :: ModuleName -> RnMG Bool -- True <=> no need to recompile
- -- When this guy is called, we already know that the
- -- source code is unchanged from last time
-checkUpToDate mod_name
- = getIfacesRn `thenRn` \ ifaces ->
- findAndReadIface doc_str mod_name
- False {- Not hi-boot -} `thenRn` \ read_result ->
-
- -- CHECK WHETHER WE HAVE IT ALREADY
- case read_result of
- Left err -> -- Old interface file not found, or garbled, so we'd better bail out
- traceRn (vcat [ptext SLIT("No old iface") <+> pprModuleName mod_name,
- err]) `thenRn_`
- returnRn outOfDate
-
- Right iface
- -> -- Found it, so now check it
- checkModUsage (pi_usages iface)
- where
- -- Only look in current directory, with suffix .hi
- doc_str = sep [ptext SLIT("need usage info from"), pprModuleName mod_name]
+checkModUsage :: [ImportVersion OccName] -> RnMG Bool
+-- Given the usage information extracted from the old
+-- M.hi file for the module being compiled, figure out
+-- whether M needs to be recompiled.
checkModUsage [] = returnRn upToDate -- Yes! Everything is up to date!
-checkModUsage ((mod_name, old_mod_vers, _, _, Specifically []) : rest)
+checkModUsage ((mod_name, _, _, NothingAtAll) : rest)
-- If CurrentModule.hi contains
-- import Foo :: ;
-- then that simply records that Foo lies below CurrentModule in the
= traceRn (ptext SLIT("Nothing used from:") <+> ppr mod_name) `thenRn_`
checkModUsage rest -- This one's ok, so check the rest
-checkModUsage ((mod_name, old_mod_vers, _, _, whats_imported) : rest)
+checkModUsage ((mod_name, _, _, whats_imported) : rest)
= tryLoadInterface doc_str mod_name ImportBySystem `thenRn` \ (ifaces, maybe_err) ->
case maybe_err of {
- Just err -> traceRn (sep [ptext SLIT("Can't find version number for module"),
- pprModuleName mod_name]) `thenRn_`
- returnRn outOfDate ;
+ Just err -> out_of_date (sep [ptext SLIT("Can't find version number for module"),
+ pprModuleName mod_name]) ;
-- Couldn't find or parse a module mentioned in the
-- old interface file. Don't complain -- it might just be that
-- the current module doesn't need that import and it's been deleted
+
Nothing ->
let
- new_mod_vers = case lookupFM (iImpModInfo ifaces) mod_name of
- Just (version, _, _, _) -> version
+ (_, new_mod_vers, new_fix_vers, new_rule_vers, _, _)
+ = case lookupFM (iImpModInfo ifaces) mod_name of
+ Just (_, _, Just stuff) -> stuff
+
+ old_mod_vers = case whats_imported of
+ Everything v -> v
+ Specifically v _ _ _ -> v
+ -- NothingAtAll case dealt with by previous eqn for checkModUsage
in
-- If the module version hasn't changed, just move on
if new_mod_vers == old_mod_vers then
-- If the usage info wants to say "I imported everything from this module"
-- it does so by making whats_imported equal to Everything
-- In that case, we must recompile
- case whats_imported of {
- Everything -> traceRn (ptext SLIT("...and I needed the whole module")) `thenRn_`
- returnRn outOfDate; -- Bale out
+ case whats_imported of { -- NothingAtAll dealt with earlier
+
+ Everything _
+ -> out_of_date (ptext SLIT("...and I needed the whole module")) ;
- Specifically old_local_vers ->
+ Specifically _ old_fix_vers old_rule_vers old_local_vers ->
+ if old_fix_vers /= new_fix_vers then
+ out_of_date (ptext SLIT("Fixities changed"))
+ else if old_rule_vers /= new_rule_vers then
+ out_of_date (ptext SLIT("Rules changed"))
+ else
-- Non-empty usage list, so check item by item
checkEntityUsage mod_name (iDecls ifaces) old_local_vers `thenRn` \ up_to_date ->
if up_to_date then
traceRn (ptext SLIT("...but the bits I use haven't.")) `thenRn_`
checkModUsage rest -- This one's ok, so check the rest
else
- returnRn outOfDate -- This one failed, so just bail out now
+ returnRn outOfDate -- This one failed, so just bail out now
}}
where
doc_str = sep [ptext SLIT("need version info for"), pprModuleName mod_name]
case lookupNameEnv decls name of
Nothing -> -- We used it before, but it ain't there now
- traceRn (sep [ptext SLIT("No longer exported:"), ppr name])
- `thenRn_` returnRn outOfDate
+ out_of_date (sep [ptext SLIT("No longer exported:"), ppr name])
Just (new_vers,_,_,_) -- It's there, but is it up to date?
| new_vers == old_vers
| otherwise
-- Out of date, so bale out
- -> traceRn (sep [ptext SLIT("Out of date:"), ppr name]) `thenRn_`
- returnRn outOfDate
+ -> out_of_date (sep [ptext SLIT("Out of date:"), ppr name])
+
+out_of_date msg = traceRn msg `thenRn_` returnRn outOfDate
\end{code}
%*********************************************************
\begin{code}
-importDecl :: Name -> RnMG (Maybe (Module, RdrNameHsDecl))
- -- Returns Nothing for
- -- (a) wired in name
- -- (b) local decl
- -- (c) already slurped
+importDecl :: Name -> RnMG ImportDeclResult
+
+data ImportDeclResult
+ = AlreadySlurped
+ | WiredIn
+ | Deferred
+ | HereItIs (Module, RdrNameHsDecl)
importDecl name
- | isWiredInName name
- = returnRn Nothing
- | otherwise
= getSlurped `thenRn` \ already_slurped ->
if name `elemNameSet` already_slurped then
- returnRn Nothing -- Already dealt with
- else
- if isLocallyDefined name then -- Don't bring in decls from
+ returnRn AlreadySlurped -- Already dealt with
+
+ else if isLocallyDefined name then -- Don't bring in decls from
-- the renamed module's own interface file
- addWarnRn (importDeclWarn name) `thenRn_`
- returnRn Nothing
- else
- getNonWiredInDecl name
-\end{code}
+ addWarnRn (importDeclWarn name) `thenRn_`
+ returnRn AlreadySlurped
-\begin{code}
-getNonWiredInDecl :: Name -> RnMG (Maybe (Module, RdrNameHsDecl))
+ else if isWiredInName name then
+ -- When we find a wired-in name we must load its
+ -- home module so that we find any instance decls therein
+ loadHomeInterface doc name `thenRn_`
+ returnRn WiredIn
+
+ else getNonWiredInDecl name
+ where
+ doc = ptext SLIT("need home module for wired in thing") <+> ppr name
+
+
+{- I don't think this is necessary any more; SLPJ May 00
+ load_home name
+ | name `elemNameSet` source_binders = returnRn ()
+ -- When compiling the prelude, a wired-in thing may
+ -- be defined in this module, in which case we don't
+ -- want to load its home module!
+ -- Using 'isLocallyDefined' doesn't work because some of
+ -- the free variables returned are simply 'listTyCon_Name',
+ -- with a system provenance. We could look them up every time
+ -- but that seems a waste.
+ | otherwise = loadHomeInterface doc name `thenRn_`
+ returnRn ()
+-}
+
+getNonWiredInDecl :: Name -> RnMG ImportDeclResult
getNonWiredInDecl needed_name
= traceRn doc_str `thenRn_`
loadHomeInterface doc_str needed_name `thenRn` \ ifaces ->
case lookupNameEnv (iDecls ifaces) needed_name of
+ Just (version, avail, is_tycon_name, decl@(_, TyClD (TyData DataType _ _ _ _ ncons _ _ _)))
+ -- This case deals with deferred import of algebraic data types
+
+ | not opt_NoPruneTyDecls
+
+ && (opt_IgnoreIfacePragmas || ncons > 1)
+ -- We only defer if imported interface pragmas are ingored
+ -- or if it's not a product type.
+ -- Sole reason: The wrapper for a strict function may need to look
+ -- inside its arg, and hence need to see its arg type's constructors.
+
+ && not (getUnique tycon_name `elem` cCallishTyKeys)
+ -- Never defer ccall types; we have to unbox them,
+ -- and importing them does no harm
+
+ -> -- OK, so we're importing a deferrable data type
+ if needed_name == tycon_name then
+ -- The needed_name is the TyCon of a data type decl
+ -- Record that it's slurped, put it in the deferred set
+ -- and don't return a declaration at all
+ setIfacesRn (recordSlurp (ifaces {iDeferred = iDeferred ifaces
+ `addOneToNameSet` tycon_name})
+ version (AvailTC needed_name [needed_name])) `thenRn_`
+ returnRn Deferred
+ else
+ -- The needed name is a constructor of a data type decl,
+ -- getting a constructor, so remove the TyCon from the deferred set
+ -- (if it's there) and return the full declaration
+ setIfacesRn (recordSlurp (ifaces {iDeferred = iDeferred ifaces
+ `delFromNameSet` tycon_name})
+ version avail) `thenRn_`
+ returnRn (HereItIs decl)
+ where
+ tycon_name = availName avail
+
Just (version,avail,_,decl)
- -> recordSlurp (Just version) avail `thenRn_`
- returnRn (Just decl)
+ -> setIfacesRn (recordSlurp ifaces version avail) `thenRn_`
+ returnRn (HereItIs decl)
- Nothing -- Can happen legitimately for "Optional" occurrences
+ Nothing
-> addErrRn (getDeclErr needed_name) `thenRn_`
- returnRn Nothing
+ returnRn AlreadySlurped
where
doc_str = ptext SLIT("need decl for") <+> ppr needed_name
+
+getDeferredDecls :: RnMG [(Module, RdrNameHsDecl)]
+getDeferredDecls
+ = getIfacesRn `thenRn` \ ifaces ->
+ let
+ decls_map = iDecls ifaces
+ deferred_names = nameSetToList (iDeferred ifaces)
+ get_abstract_decl n = case lookupNameEnv decls_map n of
+ Just (_, _, _, decl) -> decl
+ in
+ traceRn (sep [text "getDeferredDecls", nest 4 (fsep (map ppr deferred_names))]) `thenRn_`
+ returnRn (map get_abstract_decl deferred_names)
\end{code}
@getWiredInDecl@ maps a wired-in @Name@ to what it makes available.
getInterfaceExports mod_name from
= loadInterface doc_str mod_name from `thenRn` \ ifaces ->
case lookupFM (iImpModInfo ifaces) mod_name of
- Just (_, _, _, Just (mod, _, avails)) -> returnRn (mod, avails)
+ Just (_, _, Just (mod, _, _, _, _, avails)) -> returnRn (mod, avails)
-- loadInterface always puts something in the map
-- even if it's a fake
where
getIfacesRn `thenRn` \ ifaces ->
let
orphan_mods =
- [mod | (mod, (_, True, _, Nothing)) <- fmToList (iImpModInfo ifaces)]
+ [mod | (mod, (True, _, Nothing)) <- fmToList (iImpModInfo ifaces)]
in
loadOrphanModules orphan_mods `thenRn_`
= getIfacesRn `thenRn` \ ifaces ->
let
gates = iSlurp ifaces -- Anything at all that's been slurped
- (decls, new_rules) = selectGated gates (iRules ifaces)
+ rules = iRules ifaces
+ (decls, new_rules) = selectGated gates rules
in
- setIfacesRn (ifaces { iRules = new_rules }) `thenRn_`
+ if null decls then
+ returnRn []
+ else
+ setIfacesRn (ifaces { iRules = new_rules }) `thenRn_`
traceRn (sep [text "getImportedRules:",
- text "Slurped" <+> int (length decls) <+> text "rules"]) `thenRn_`
+ text "Slurped" <+> int (length decls) <+> text "rules"]) `thenRn_`
returnRn decls
selectGated gates decl_bag
| isEmptyNameSet (reqd `minusNameSet` gates) = (decl:yes, no)
| otherwise = (yes, (reqd,decl) `consBag` no)
-lookupFixity :: Name -> RnMS Fixity
-lookupFixity name
+lookupFixityRn :: Name -> RnMS Fixity
+lookupFixityRn name
| isLocallyDefined name
= getFixityEnv `thenRn` \ local_fix_env ->
- case lookupNameEnv local_fix_env name of
- Just (FixitySig _ fix _) -> returnRn fix
- Nothing -> returnRn defaultFixity
+ returnRn (lookupFixity local_fix_env name)
| otherwise -- Imported
-- For imported names, we have to get their fixities by doing a loadHomeInterface,
-- When we come across a use of 'f', we need to know its fixity, and it's then,
-- and only then, that we load B.hi. That is what's happening here.
= loadHomeInterface doc name `thenRn` \ ifaces ->
- case lookupNameEnv (iFixes ifaces) name of
- Just (FixitySig _ fix _) -> returnRn fix
- Nothing -> returnRn defaultFixity
+ returnRn (lookupFixity (iFixes ifaces) name)
where
doc = ptext SLIT("Checking fixity for") <+> ppr name
\end{code}
So we'll get an early bale-out when compiling A if B's version changes.
\begin{code}
-getImportVersions :: ModuleName -- Name of this module
- -> ExportEnv -- Info about exports
- -> RnMG (VersionInfo Name) -- Version info for these names
-
-getImportVersions this_mod (ExportEnv _ _ export_all_mods)
+mkImportExportInfo :: ModuleName -- Name of this module
+ -> Avails -- Info about exports
+ -> Maybe [RdrNameIE] -- The export header
+ -> RnMG ([ExportItem], -- Export info for iface file; sorted
+ [ImportVersion OccName]) -- Import info for iface file; sorted
+ -- Both results are sorted into canonical order to
+ -- reduce needless wobbling of interface files
+
+mkImportExportInfo this_mod export_avails exports
= getIfacesRn `thenRn` \ ifaces ->
let
+ export_all_mods = case exports of
+ Nothing -> []
+ Just es -> [mod | IEModuleContents mod <- es,
+ mod /= this_mod]
+
mod_map = iImpModInfo ifaces
imp_names = iVSlurp ifaces
-- mv_map groups together all the things imported from a particular module.
- mv_map :: FiniteMap ModuleName [(Name,Version)]
+ mv_map :: FiniteMap ModuleName [(OccName,Version)]
mv_map = foldr add_mv emptyFM imp_names
+ add_mv (name, version) mv_map = addItem mv_map (moduleName (nameModule name))
+ (nameOccName name, version)
+
-- Build the result list by adding info for each module.
-- For (a) a library module, we don't record it at all unless it contains orphans
-- (We must never lose track of orphans.)
-- whether something is a boot file along with the usage info for it, but
-- I can't be bothered just now.
- mk_version_info mod_name (version, has_orphans, is_boot, contents) so_far
+ mk_imp_info mod_name (has_orphans, is_boot, contents) so_far
| mod_name == this_mod -- Check if M appears in the set of modules 'below' M
-- This seems like a convenient place to check
= WARN( not is_boot, ptext SLIT("Wierd:") <+> ppr this_mod <+>
| otherwise
= let
- go_for_it exports = (mod_name, version, has_orphans, is_boot, exports)
+ go_for_it exports = (mod_name, has_orphans, is_boot, exports)
: so_far
in
case contents of
-- information. The Nothing says that we didn't even open the interface
-- file but we must still propagate the dependeny info.
-- The module in question must be a local module (in the same package)
- go_for_it (Specifically [])
+ go_for_it NothingAtAll
- Just (mod, how_imported, _)
+ Just (mod, mod_vers, fix_vers, rule_vers, how_imported, _)
| is_sys_import && is_lib_module && not has_orphans
-> so_far
| is_lib_module -- Record the module but not detailed
|| mod_name `elem` export_all_mods -- version information for the imports
- -> go_for_it Everything
+ -> go_for_it (Everything mod_vers)
| otherwise
-> case lookupFM mv_map mod_name of
- Just whats_imported -> go_for_it (Specifically whats_imported)
- Nothing -> go_for_it (Specifically [])
+ Just whats_imported -> go_for_it (Specifically mod_vers fix_vers rule_vers
+ (sortImport whats_imported))
+ Nothing -> go_for_it NothingAtAll
-- This happens if you have
-- import Foo
-- but don't actually *use* anything from Foo
ImportBySystem -> True
other -> False
+
+ import_info = foldFM mk_imp_info [] mod_map
+
+ -- Sort exports into groups by module
+ export_fm :: FiniteMap ModuleName [RdrAvailInfo]
+ export_fm = foldr insert emptyFM export_avails
+
+ insert avail efm = addItem efm (moduleName (nameModule (availName avail)))
+ (rdrAvailInfo avail)
+
+ export_info = [(m, sortExport as) | (m,as) <- fmToList export_fm]
in
+ returnRn (export_info, import_info)
- returnRn (foldFM mk_version_info [] mod_map)
- where
- add_mv v@(name, version) mv_map
- = addToFM_C add_item mv_map mod [v]
- where
- mod = moduleName (nameModule name)
- add_item vs _ = (v:vs)
+
+addItem :: FiniteMap ModuleName [a] -> ModuleName -> a -> FiniteMap ModuleName [a]
+addItem fm mod x = addToFM_C add_item fm mod [x]
+ where
+ add_item xs _ = x:xs
+
+sortImport :: [(OccName,Version)] -> [(OccName,Version)]
+ -- Make the usage lists appear in canonical order
+sortImport vs = sortLt lt vs
+ where
+ lt (n1,v1) (n2,v2) = n1 < n2
+
+sortExport :: [RdrAvailInfo] -> [RdrAvailInfo]
+sortExport as = sortLt lt as
+ where
+ lt a1 a2 = availName a1 < availName a2
\end{code}
\begin{code}
= getIfacesRn `thenRn` \ ifaces ->
returnRn (iSlurp ifaces)
-recordSlurp maybe_version avail
--- Nothing for locally defined names
--- Just version for imported names
- = getIfacesRn `thenRn` \ ifaces@(Ifaces { iSlurp = slurped_names,
- iVSlurp = imp_names }) ->
- let
+recordSlurp ifaces@(Ifaces { iSlurp = slurped_names, iVSlurp = imp_names })
+ version avail
+ = let
new_slurped_names = addAvailToNameSet slurped_names avail
+ new_imp_names = (availName avail, version) : imp_names
+ in
+ ifaces { iSlurp = new_slurped_names, iVSlurp = new_imp_names }
- new_imp_names = case maybe_version of
- Just version -> (availName avail, version) : imp_names
- Nothing -> imp_names
+recordLocalSlurps local_avails
+ = getIfacesRn `thenRn` \ ifaces ->
+ let
+ new_slurped_names = foldl addAvailToNameSet (iSlurp ifaces) local_avails
in
- setIfacesRn (ifaces { iSlurp = new_slurped_names,
- iVSlurp = new_imp_names })
+ setIfacesRn (ifaces { iSlurp = new_slurped_names })
\end{code}
-> RdrNameHsDecl
-> RnM d (Maybe AvailInfo)
-getDeclBinders new_name (TyClD (TyData _ _ tycon _ condecls _ _ src_loc))
+getDeclBinders new_name (TyClD (TyData _ _ tycon _ condecls _ _ _ src_loc))
= new_name tycon src_loc `thenRn` \ tycon_name ->
getConFieldNames new_name condecls `thenRn` \ sub_names ->
returnRn (Just (AvailTC tycon_name (tycon_name : nub sub_names)))
= new_name var src_loc `thenRn` \ var_name ->
returnRn (Just (Avail var_name))
-getDeclBinders new_name (FixD _) = returnRn Nothing
+getDeclBinders new_name (FixD _) = returnRn Nothing
+getDeclBinders new_name (DeprecD _) = returnRn Nothing
-- foreign declarations
getDeclBinders new_name (ForD (ForeignDecl nm kind _ dyn _ loc))
getDeclSysBinders new_name (TyClD (ClassDecl _ cname _ _ sigs _ _ tname dname dwname snames src_loc))
= sequenceRn [new_name n src_loc | n <- (tname : dname : dwname : snames)]
-getDeclSysBinders new_name (TyClD (TyData _ _ _ _ cons _ _ _))
+getDeclSysBinders new_name (TyClD (TyData _ _ _ _ cons _ _ _ _))
= sequenceRn [new_name wkr_name src_loc | ConDecl _ wkr_name _ _ _ src_loc <- cons]
getDeclSysBinders new_name other_decl
\begin{code}
module RnMonad(
module RnMonad,
+
+ module RdrName, -- Re-exports
+ module Name, -- from these two
+
Module,
FiniteMap,
Bag,
- Name,
RdrNameHsDecl,
RdrNameInstDecl,
Version,
import HsSyn
import RdrHsSyn
import RnHsSyn ( RenamedFixitySig, RenamedDeprecation )
-import BasicTypes ( Version )
+import BasicTypes ( Version, defaultFixity )
import SrcLoc ( noSrcLoc )
import ErrUtils ( addShortErrLocLine, addShortWarnLocLine,
pprBagOfErrors, ErrMsg, WarnMsg, Message
)
-import Name ( Name, OccName, NamedThing(..),
+import RdrName ( RdrName, dummyRdrVarName, rdrNameOcc,
+ RdrNameEnv, emptyRdrEnv, extendRdrEnv,
+ lookupRdrEnv, addListToRdrEnv, rdrEnvToList, rdrEnvElts
+ )
+import Name ( Name, OccName, NamedThing(..), getSrcLoc,
isLocallyDefinedName, nameModule, nameOccName,
- decode, mkLocalName, mkUnboundName
+ decode, mkLocalName, mkUnboundName,
+ NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, extendNameEnv,
+ addToNameEnv_C, plusNameEnv_C, nameEnvElts,
+ elemNameEnv, addToNameEnv, addListToNameEnv
)
import Module ( Module, ModuleName, ModuleHiMap, SearchPath, WhereFrom,
- mkModuleHiMaps, moduleName, mkVanillaModule, mkSearchPath
+ mkModuleHiMaps, moduleName, mkSearchPath
)
import NameSet
-import RdrName ( RdrName, dummyRdrVarName, rdrNameOcc )
import CmdLineOpts ( opt_D_dump_rn_trace, opt_HiMap )
import PrelInfo ( builtinNames )
import TysWiredIn ( boolTyCon )
import SrcLoc ( SrcLoc, mkGeneratedSrcLoc )
import Unique ( Unique, getUnique, unboundKey )
-import UniqFM ( UniqFM )
import FiniteMap ( FiniteMap, emptyFM, bagToFM, lookupFM, addToFM, addListToFM,
addListToFM_C, addToFM_C, eltsFM, fmToList
)
import Bag ( Bag, mapBag, emptyBag, isEmptyBag, snocBag )
import Maybes ( mapMaybe )
import UniqSet
-import UniqFM
import UniqSupply
import Util
import Outputable
\begin{code}
--------------------------------
-type RdrNameEnv a = FiniteMap RdrName a
type GlobalRdrEnv = RdrNameEnv [Name] -- The list is because there may be name clashes
-- These only get reported on lookup,
-- not on construction
type LocalRdrEnv = RdrNameEnv Name
-emptyRdrEnv :: RdrNameEnv a
-lookupRdrEnv :: RdrNameEnv a -> RdrName -> Maybe a
-addListToRdrEnv :: RdrNameEnv a -> [(RdrName,a)] -> RdrNameEnv a
-extendRdrEnv :: RdrNameEnv a -> RdrName -> a -> RdrNameEnv a
-
-emptyRdrEnv = emptyFM
-lookupRdrEnv = lookupFM
-addListToRdrEnv = addListToFM
-rdrEnvElts = eltsFM
-extendRdrEnv = addToFM
-rdrEnvToList = fmToList
-
---------------------------------
-type NameEnv a = UniqFM a -- Domain is Name
-
-emptyNameEnv :: NameEnv a
-nameEnvElts :: NameEnv a -> [a]
-addToNameEnv_C :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a
-addToNameEnv :: NameEnv a -> Name -> a -> NameEnv a
-plusNameEnv :: NameEnv a -> NameEnv a -> NameEnv a
-plusNameEnv_C :: (a->a->a) -> NameEnv a -> NameEnv a -> NameEnv a
-extendNameEnv :: NameEnv a -> [(Name,a)] -> NameEnv a
-lookupNameEnv :: NameEnv a -> Name -> Maybe a
-delFromNameEnv :: NameEnv a -> Name -> NameEnv a
-elemNameEnv :: Name -> NameEnv a -> Bool
-unitNameEnv :: Name -> a -> NameEnv a
-
-emptyNameEnv = emptyUFM
-nameEnvElts = eltsUFM
-addToNameEnv_C = addToUFM_C
-addToNameEnv = addToUFM
-plusNameEnv = plusUFM
-plusNameEnv_C = plusUFM_C
-extendNameEnv = addListToUFM
-lookupNameEnv = lookupUFM
-delFromNameEnv = delFromUFM
-elemNameEnv = elemUFM
-unitNameEnv = unitUFM
-
--------------------------------
type FixityEnv = NameEnv RenamedFixitySig
-- We keep the whole fixity sig so that we
-- can report line-number info when there is a duplicate
-- fixity declaration
+lookupFixity :: FixityEnv -> Name -> Fixity
+lookupFixity env name
+ = case lookupNameEnv env name of
+ Just (FixitySig _ fix _) -> fix
+ Nothing -> defaultFixity
+
--------------------------------
type DeprecationEnv = NameEnv DeprecTxt
\end{code}
--------------------------------
-data ExportEnv = ExportEnv Avails Fixities [ModuleName]
- -- The list of modules is the modules exported
- -- with 'module M' in the export list
-
type Avails = [AvailInfo]
-type Fixities = [(Name, Fixity)]
type ExportAvails = (FiniteMap ModuleName Avails,
-- Used to figure out "module M" export specifiers
-- NB: If the type or class is itself
-- to be in scope, it must be in this list.
-- Thus, typically: AvailTC Eq [Eq, ==, /=]
+ deriving( Eq )
+ -- Equality used when deciding if the interface has changed
type AvailEnv = NameEnv AvailInfo -- Maps a Name to the AvailInfo that contains it
type AvailInfo = GenAvailInfo Name
\begin{code}
type ExportItem = (ModuleName, [RdrAvailInfo])
-type VersionInfo name = [ImportVersion name]
-type ImportVersion name = (ModuleName, Version,
- WhetherHasOrphans, IsBootInterface, WhatsImported name)
+type ImportVersion name = (ModuleName, WhetherHasOrphans, IsBootInterface, WhatsImported name)
+
+type ModVersionInfo = (Version, -- Version of the whole module
+ Version, -- Version number for all fixity decls together
+ Version) -- ...ditto all rules together
type WhetherHasOrphans = Bool
-- An "orphan" is
type IsBootInterface = Bool
-data WhatsImported name = Everything
- | Specifically [LocalVersion name] -- List guaranteed non-empty
+data WhatsImported name = NothingAtAll -- The module is below us in the
+ -- hierarchy, but we import nothing
- -- ("M", hif, ver, Everything) means there was a "module M" in
- -- this module's export list, so we just have to go by M's version, "ver",
- -- not the list of LocalVersions.
+ | Everything Version -- The module version
+ | Specifically Version -- Module version
+ Version -- Fixity version
+ Version -- Rules version
+ [(name,Version)] -- List guaranteed non-empty
+ deriving( Eq )
+ -- 'Specifically' doesn't let you say "I imported f but none of the fixities in
+ -- the module. If you use anything in the module you get its fixity and rule version
+ -- So if the fixities or rules change, you'll recompile, even if you don't use either.
+ -- This is easy to implement, and it's safer: you might not have used the rules last
+ -- time round, but if someone has added a new rule you might need it this time
-type LocalVersion name = (name, Version)
+ -- 'Everything' means there was a "module M" in
+ -- this module's export list, so we just have to go by M's version,
+ -- not the list of (name,version) pairs
data ParsedIface
= ParsedIface {
pi_orphan :: WhetherHasOrphans, -- Whether this module has orphans
pi_usages :: [ImportVersion OccName], -- Usages
pi_exports :: [ExportItem], -- Exports
- pi_decls :: [(Version, RdrNameHsDecl)], -- Local definitions
pi_insts :: [RdrNameInstDecl], -- Local instance declarations
- pi_rules :: [RdrNameRuleDecl], -- Rules
+ pi_decls :: [(Version, RdrNameHsDecl)], -- Local definitions
+ pi_fixity :: (Version, [RdrNameFixitySig]), -- Local fixity declarations, with their version
+ pi_rules :: (Version, [RdrNameRuleDecl]), -- Rules, with their version
pi_deprecs :: [RdrNameDeprecation] -- Deprecations
}
-data InterfaceDetails
- = InterfaceDetails WhetherHasOrphans
- (VersionInfo Name) -- Version information for what this module imports
- ExportEnv -- What modules this one depends on
- [Deprecation Name]
-
-
--- needed by Main to fish out the fixities assoc list.
-getIfaceFixities :: InterfaceDetails -> Fixities
-getIfaceFixities (InterfaceDetails _ _ (ExportEnv _ fs _) _) = fs
-
type RdrNamePragma = () -- Fudge for now
-------------------
iDecls :: DeclsMap, -- A single, global map of Names to decls
- iFixes :: FixityEnv, -- A single, global map of Names to fixities
- -- See comments with RnIfaces.lookupFixity
+ iDeferred :: NameSet, -- data (not newtype) TyCons that have been slurped,
+ -- but none of their constructors have.
+ -- If this is still the case right at the end
+ -- we can get away with importing them abstractly
+
+ iFixes :: FixityEnv,
+ -- A single, global map of Names to fixities
+ -- See comments with RnIfaces.lookupFixity
iSlurp :: NameSet,
-- All the names (whether "big" or "small", whether wired-in or not,
-- Each is 'gated' by the names that must be available before
-- this instance decl is needed.
- iRules :: Bag GatedDecl,
- -- Ditto transformation rules
+ iRules :: IfaceRules,
+ -- Similar to instance decls, except that we track the version number of the
+ -- rules we import from each module
+ -- [We keep just one rule-version number for each module]
+ -- The Bool is True if we import any rules at all from that module
iDeprecs :: DeprecationEnv
}
+type IfaceRules = Bag GatedDecl
+
type GatedDecl = (NameSet, (Module, RdrNameHsDecl))
type ImportedModuleInfo
- = FiniteMap ModuleName (Version, WhetherHasOrphans, IsBootInterface,
- Maybe (Module, WhereFrom, Avails))
+ = FiniteMap ModuleName (WhetherHasOrphans, IsBootInterface,
+ Maybe (Module, Version, Version, Version, WhereFrom, Avails))
+ -- The three Versions are module version, fixity version, rules version
+
-- Suppose the domain element is module 'A'
--
-- The first Bool is True if A contains
emptyIfaces :: Ifaces
emptyIfaces = Ifaces { iImpModInfo = emptyFM,
iDecls = emptyNameEnv,
+ iDeferred = emptyNameSet,
iFixes = emptyNameEnv,
iSlurp = unitNameSet (mkUnboundName dummyRdrVarName),
-- Pretend that the dummy unbound name has already been
RdrNameHsModule, RdrNameHsDecl
)
import RnIfaces ( getInterfaceExports, getDeclBinders, getDeclSysBinders,
- recordSlurp, checkUpToDate
+ recordLocalSlurps, checkModUsage, findAndReadIface, outOfDate
)
import RnEnv
import RnMonad
import FiniteMap
-import PrelMods
-import PrelInfo ( main_RDR )
+import PrelInfo ( pRELUDE_Name, mAIN_Name, main_RDR )
import UniqFM ( lookupUFM )
import Bag ( bagToList )
import Module ( ModuleName, mkThisModule, pprModuleName, WhereFrom(..) )
isLocallyDefined, setNameProvenance,
nameOccName, getSrcLoc, pprProvenance, getNameProvenance
)
-import RdrName ( RdrName, rdrNameOcc, setRdrNameOcc, mkRdrQual, mkRdrUnqual, isQual )
+import RdrName ( RdrName, rdrNameOcc, setRdrNameOcc, mkRdrQual, mkRdrUnqual, isQual, isUnqual )
import OccName ( setOccNameSpace, dataName )
import SrcLoc ( SrcLoc )
import NameSet ( elemNameSet, emptyNameSet )
\begin{code}
getGlobalNames :: RdrNameHsModule
- -> RnMG (Maybe (ExportEnv,
- GlobalRdrEnv,
- FixityEnv, -- Fixities for local decls only
- AvailEnv -- Maps a name to its parent AvailInfo
- -- Just for in-scope things only
+ -> RnMG (Maybe (GlobalRdrEnv, -- Maps all in-scope things
+ GlobalRdrEnv, -- Maps just *local* things
+ Avails, -- The exported stuff
+ AvailEnv, -- Maps a name to its parent AvailInfo
+ -- Just for in-scope things only
+ Maybe ParsedIface -- The old interface file, if any
))
-- Nothing => no need to recompile
getGlobalNames (HsModule this_mod _ exports imports decls _ mod_loc)
= -- These two fix-loops are to get the right
-- provenance information into a Name
- fixRn (\ ~(rec_gbl_env, rec_exported_avails, _) ->
+ fixRn ( \ ~(Just (rec_gbl_env, _, rec_export_avails, _, _)) ->
let
rec_unqual_fn :: Name -> Bool -- Is this chap in scope unqualified?
rec_unqual_fn = unQualInScope rec_gbl_env
rec_exp_fn :: Name -> ExportFlag
- rec_exp_fn = mk_export_fn (availsToNameSet rec_exported_avails)
+ rec_exp_fn = mk_export_fn (availsToNameSet rec_export_avails)
in
setModuleRn this_mod $
all_avails :: ExportAvails
all_avails = foldr plusExportAvails local_mod_avails (imp_avails_s2 ++ imp_avails_s1)
+ (_, global_avail_env) = all_avails
in
- -- TRY FOR EARLY EXIT
- -- We can't go for an early exit before this because we have to check
- -- for name clashes. Consider:
- --
- -- module A where module B where
- -- import B h = True
- -- f = h
- --
- -- Suppose I've compiled everything up, and then I add a
- -- new definition to module B, that defines "f".
- --
- -- Then I must detect the name clash in A before going for an early
- -- exit. The early-exit code checks what's actually needed from B
- -- to compile A, and of course that doesn't include B.f. That's
- -- why we wait till after the plusEnv stuff to do the early-exit.
- checkEarlyExit this_mod `thenRn` \ up_to_date ->
- if up_to_date then
- returnRn (gbl_env, junk_exp_fn, Nothing)
- else
-
- -- RECORD BETTER PROVENANCES IN THE CACHE
- -- The names in the envirnoment have better provenances (e.g. imported on line x)
- -- than the names in the name cache. We update the latter now, so that we
- -- we start renaming declarations we'll get the good names
- -- The isQual is because the qualified name is always in scope
- updateProvenances (concat [names | (rdr_name, names) <- rdrEnvToList imp_gbl_env,
- isQual rdr_name]) `thenRn_`
-
- -- PROCESS EXPORT LISTS
- exportsFromAvail this_mod exports all_avails gbl_env `thenRn` \ exported_avails ->
-
- -- DONE
- returnRn (gbl_env, exported_avails, Just all_avails)
- ) `thenRn` \ (gbl_env, exported_avails, maybe_stuff) ->
-
- case maybe_stuff of {
- Nothing -> returnRn Nothing ;
- Just all_avails ->
-
- -- DEAL WITH FIXITIES
- fixitiesFromLocalDecls gbl_env decls `thenRn` \ local_fixity_env ->
- let
- -- Export only those fixities that are for names that are
- -- (a) defined in this module
- -- (b) exported
- exported_fixities :: [(Name,Fixity)]
- exported_fixities = [(name,fixity)
- | FixitySig name fixity _ <- nameEnvElts local_fixity_env,
- isLocallyDefined name
- ]
-
- -- CONSTRUCT RESULTS
- export_mods = case exports of
- Nothing -> []
- Just es -> [mod | IEModuleContents mod <- es, mod /= this_mod]
-
- export_env = ExportEnv exported_avails exported_fixities export_mods
- (_, global_avail_env) = all_avails
- in
- traceRn (text "fixity env" <+> vcat (map ppr (nameEnvElts local_fixity_env))) `thenRn_`
-
- returnRn (Just (export_env, gbl_env, local_fixity_env, global_avail_env))
- }
+ -- TRY FOR EARLY EXIT
+ -- We can't go for an early exit before this because we have to check
+ -- for name clashes. Consider:
+ --
+ -- module A where module B where
+ -- import B h = True
+ -- f = h
+ --
+ -- Suppose I've compiled everything up, and then I add a
+ -- new definition to module B, that defines "f".
+ --
+ -- Then I must detect the name clash in A before going for an early
+ -- exit. The early-exit code checks what's actually needed from B
+ -- to compile A, and of course that doesn't include B.f. That's
+ -- why we wait till after the plusEnv stuff to do the early-exit.
+
+ -- Check For eacly exit
+ checkErrsRn `thenRn` \ no_errs_so_far ->
+ if not no_errs_so_far then
+ -- Found errors already, so exit now
+ returnRn Nothing
+ else
+ checkEarlyExit this_mod `thenRn` \ (up_to_date, old_iface) ->
+ if up_to_date then
+ -- Interface files are sufficiently unchanged
+ putDocRn (text "Compilation IS NOT required") `thenRn_`
+ returnRn Nothing
+ else
+
+ -- RECORD BETTER PROVENANCES IN THE CACHE
+ -- The names in the envirnoment have better provenances (e.g. imported on line x)
+ -- than the names in the name cache. We update the latter now, so that we
+ -- we start renaming declarations we'll get the good names
+ -- The isQual is because the qualified name is always in scope
+ updateProvenances (concat [names | (rdr_name, names) <- rdrEnvToList gbl_env,
+ isQual rdr_name]) `thenRn_`
+
+ -- PROCESS EXPORT LISTS
+ exportsFromAvail this_mod exports all_avails gbl_env `thenRn` \ export_avails ->
+
+
+ -- ALL DONE
+ returnRn (Just (gbl_env, local_gbl_env, export_avails, global_avail_env, old_iface))
+ )
where
- junk_exp_fn = error "RnNames:export_fn"
-
all_imports = prel_imports ++ imports
-- NB: opt_NoImplicitPrelude is slightly different to import Prelude ();
\end{code}
\begin{code}
-checkEarlyExit mod
- = checkErrsRn `thenRn` \ no_errs_so_far ->
- if not no_errs_so_far then
- -- Found errors already, so exit now
- returnRn True
- else
-
- traceRn (text "Considering whether compilation is required...") `thenRn_`
- if not opt_SourceUnchanged then
- -- Source code changed and no errors yet... carry on
- traceRn (nest 4 (text "source file changed or recompilation check turned off")) `thenRn_`
- returnRn False
- else
-
- -- Unchanged source, and no errors yet; see if usage info
- -- up to date, and exit if so
- checkUpToDate mod `thenRn` \ up_to_date ->
- (if up_to_date
- then putDocRn (text "Compilation IS NOT required")
- else returnRn ()) `thenRn_`
- returnRn up_to_date
+checkEarlyExit mod_name
+ = traceRn (text "Considering whether compilation is required...") `thenRn_`
+
+ -- Read the old interface file, if any, for the module being compiled
+ findAndReadIface doc_str mod_name False {- Not hi-boot -} `thenRn` \ maybe_iface ->
+
+ -- CHECK WHETHER WE HAVE IT ALREADY
+ case maybe_iface of
+ Left err -> -- Old interface file not found, so we'd better bail out
+ traceRn (vcat [ptext SLIT("No old interface file for") <+> pprModuleName mod_name,
+ err]) `thenRn_`
+ returnRn (outOfDate, Nothing)
+
+ Right iface
+ | not opt_SourceUnchanged
+ -> -- Source code changed
+ traceRn (nest 4 (text "source file changed or recompilation check turned off")) `thenRn_`
+ returnRn (False, Just iface)
+
+ | otherwise
+ -> -- Source code unchanged and no errors yet... carry on
+ checkModUsage (pi_usages iface) `thenRn` \ up_to_date ->
+ returnRn (up_to_date, Just iface)
+ where
+ -- Only look in current directory, with suffix .hi
+ doc_str = sep [ptext SLIT("need usage info from"), pprModuleName mod_name]
\end{code}
\begin{code}
mapRn_ (addErrRn . dupDeclErr) dups `thenRn_`
-- Record that locally-defined things are available
- mapRn_ (recordSlurp Nothing) avails `thenRn_`
+ recordLocalSlurps avails `thenRn_`
-- Build the environment
qualifyImports mod_name
mod = mkThisModule mod_name
newLocalName rdr_name loc
- = (if isQual rdr_name then
- qualNameErr (text "the binding for" <+> quotes (ppr rdr_name)) (rdr_name,loc)
- -- There should never be a qualified name in a binding position (except in instance decls)
- -- The parser doesn't check this because the same parser parses instance decls
- else
- returnRn ()) `thenRn_`
-
- newLocalTopBinder mod (rdrNameOcc rdr_name) rec_exp_fn loc
+ = check_unqual rdr_name loc `thenRn_`
+ newTopBinder mod (rdrNameOcc rdr_name) `thenRn` \ name ->
+ returnRn (setNameProvenance name (LocalDef loc (rec_exp_fn name)))
+ -- There should never be a qualified name in a binding position (except in instance decls)
+ -- The parser doesn't check this because the same parser parses instance decls
+ check_unqual rdr_name loc
+ | isUnqual rdr_name = returnRn ()
+ | otherwise = qualNameErr (text "the binding for" <+> quotes (ppr rdr_name))
+ (rdr_name,loc)
getLocalDeclBinders :: (RdrName -> SrcLoc -> RnMG Name) -- New-name function
-> RdrNameHsDecl
-- The getDeclSysBinders is just to get the names of superclass selectors
-- etc, into the cache
new_sys_name rdr_name loc = newImplicitBinder (rdrNameOcc rdr_name) loc
-
-fixitiesFromLocalDecls :: GlobalRdrEnv -> [RdrNameHsDecl] -> RnMG FixityEnv
-fixitiesFromLocalDecls gbl_env decls
- = foldlRn getFixities emptyNameEnv decls
- where
- getFixities :: FixityEnv -> RdrNameHsDecl -> RnMG FixityEnv
- getFixities acc (FixD fix)
- = fix_decl acc fix
-
- getFixities acc (TyClD (ClassDecl _ _ _ _ sigs _ _ _ _ _ _ _))
- = foldlRn fix_decl acc [sig | FixSig sig <- sigs]
- -- Get fixities from class decl sigs too.
- getFixities acc other_decl
- = returnRn acc
-
- fix_decl acc sig@(FixitySig rdr_name fixity loc)
- = -- Check for fixity decl for something not declared
- case lookupRdrEnv gbl_env rdr_name of {
- Nothing | opt_WarnUnusedBinds
- -> pushSrcLocRn loc (addWarnRn (unusedFixityDecl rdr_name fixity))
- `thenRn_` returnRn acc
- | otherwise -> returnRn acc ;
-
- Just (name:_) ->
-
- -- Check for duplicate fixity decl
- case lookupNameEnv acc name of {
- Just (FixitySig _ _ loc') -> addErrRn (dupFixityDecl rdr_name loc loc')
- `thenRn_` returnRn acc ;
-
- Nothing -> returnRn (addToNameEnv acc name (FixitySig name fixity loc))
- }}
\end{code}
%************************************************************************
= hsep [ptext SLIT("Duplicate"),
quotes (ptext SLIT("Module") <+> pprModuleName mod),
ptext SLIT("in export list")]
-
-unusedFixityDecl rdr_name fixity
- = hsep [ptext SLIT("Unused fixity declaration for"), quotes (ppr rdr_name)]
-
-dupFixityDecl rdr_name loc1 loc2
- = vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name),
- ptext SLIT("at ") <+> ppr loc1,
- ptext SLIT("and") <+> ppr loc2]
\end{code}
\section[RnSource]{Main pass of renamer}
\begin{code}
-module RnSource ( rnDecl, rnSourceDecls, rnHsType, rnHsSigType, rnHsPolyType ) where
+module RnSource ( rnDecl, rnSourceDecls, rnHsType, rnHsSigType ) where
#include "HsVersions.h"
import RnExpr
import HsSyn
import HsPragmas
-import HsTypes ( getTyVarName, pprHsPred, cmpHsTypes )
-import RdrName ( RdrName, isRdrDataCon, rdrNameOcc, isRdrTyVar )
+import HsTypes ( getTyVarName )
+import RdrName ( RdrName, isRdrDataCon, rdrNameOcc, isRdrTyVar, mkRdrNameWkr )
import RdrHsSyn ( RdrNameContext, RdrNameHsType, RdrNameConDecl,
extractRuleBndrsTyVars, extractHsTyRdrTyVars, extractHsTysRdrTyVars
)
import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs, unknownSigErr )
import RnEnv ( bindTyVarsRn, lookupBndrRn, lookupOccRn, getIPName,
- lookupImplicitOccRn,
+ lookupImplicitOccRn, lookupImplicitOccsRn,
bindLocalsRn, bindLocalRn, bindLocalsFVRn, bindUVarRn,
bindTyVarsFVRn, bindTyVarsFV2Rn, extendTyVarEnvFVRn,
bindCoreLocalFVRn, bindCoreLocalsFVRn,
import RnMonad
import FunDeps ( oclose )
+import Class ( FunDep )
import Name ( Name, OccName,
ExportFlag(..), Provenance(..),
import OccName ( mkDefaultMethodOcc )
import BasicTypes ( TopLevelFlag(..) )
import FiniteMap ( elemFM )
-import PrelInfo ( derivableClassKeys,
- deRefStablePtr_NAME, makeStablePtr_NAME, bindIO_NAME, returnIO_NAME
+import PrelInfo ( derivableClassKeys, cCallishClassKeys,
+ deRefStablePtr_RDR, makeStablePtr_RDR, bindIO_RDR
)
import Bag ( bagToList )
import List ( partition, nub )
rnSourceDecls decls
= go emptyFVs [] decls
where
- -- Fixity decls have been dealt with already; ignore them
- go fvs ds' [] = returnRn (ds', fvs)
- go fvs ds' (FixD _:ds) = go fvs ds' ds
- go fvs ds' (d:ds) = rnDecl d `thenRn` \(d', fvs') ->
- go (fvs `plusFV` fvs') (d':ds') ds
+ -- Fixity and deprecations have been dealt with already; ignore them
+ go fvs ds' [] = returnRn (ds', fvs)
+ go fvs ds' (FixD _:ds) = go fvs ds' ds
+ go fvs ds' (DeprecD _:ds) = go fvs ds' ds
+ go fvs ds' (d:ds) = rnDecl d `thenRn` \(d', fvs') ->
+ go (fvs `plusFV` fvs') (d':ds') ds
\end{code}
rnDecl (SigD (IfaceSig name ty id_infos loc))
= pushSrcLocRn loc $
- lookupBndrRn name `thenRn` \ name' ->
- rnHsPolyType doc_str ty `thenRn` \ (ty',fvs1) ->
- mapFvRn rnIdInfo id_infos `thenRn` \ (id_infos', fvs2) ->
+ mkImportedGlobalFromRdrName name `thenRn` \ name' ->
+ rnHsType doc_str ty `thenRn` \ (ty',fvs1) ->
+ mapFvRn rnIdInfo id_infos `thenRn` \ (id_infos', fvs2) ->
returnRn (SigD (IfaceSig name' ty' id_infos' loc), fvs1 `plusFV` fvs2)
where
doc_str = text "the interface signature for" <+> quotes (ppr name)
However, we can also do some scoping checks at the same time.
\begin{code}
-rnDecl (TyClD (TyData new_or_data context tycon tyvars condecls derivings pragmas src_loc))
+rnDecl (TyClD (TyData new_or_data context tycon tyvars condecls nconstrs derivings pragmas src_loc))
= pushSrcLocRn src_loc $
lookupBndrRn tycon `thenRn` \ tycon' ->
bindTyVarsFVRn data_doc tyvars $ \ tyvars' ->
mapFvRn rnConDecl condecls `thenRn` \ (condecls', con_fvs) ->
rnDerivs derivings `thenRn` \ (derivings', deriv_fvs) ->
ASSERT(isNoDataPragmas pragmas)
- returnRn (TyClD (TyData new_or_data context' tycon' tyvars' condecls'
+ returnRn (TyClD (TyData new_or_data context' tycon' tyvars' condecls' nconstrs
derivings' noDataPragmas src_loc),
cxt_fvs `plusFV` con_fvs `plusFV` deriv_fvs)
where
= pushSrcLocRn src_loc $
lookupBndrRn name `thenRn` \ name' ->
bindTyVarsFVRn syn_doc tyvars $ \ tyvars' ->
- rnHsPolyType syn_doc (unquantify ty) `thenRn` \ (ty', ty_fvs) ->
+ rnHsType syn_doc (unquantify ty) `thenRn` \ (ty', ty_fvs) ->
returnRn (TyClD (TySynonym name' tyvars' ty' src_loc), ty_fvs)
where
syn_doc = text "the declaration for type synonym" <+> quotes (ppr name)
= pushSrcLocRn src_loc $
lookupOccRn name `thenRn` \ name' ->
let
- ok_ext_nm Dynamic = True
- ok_ext_nm (ExtName nm (Just mb)) = isCLabelString nm && isCLabelString mb
- ok_ext_nm (ExtName nm Nothing) = isCLabelString nm
-
- fvs1 = case imp_exp of
- FoImport _ | not isDyn -> emptyFVs
- FoLabel -> emptyFVs
- FoExport | isDyn -> mkNameSet [makeStablePtr_NAME,
- deRefStablePtr_NAME,
- bindIO_NAME, returnIO_NAME]
- | otherwise -> mkNameSet [name']
- _ -> emptyFVs
+ extra_fvs FoExport
+ | isDyn = lookupImplicitOccsRn [makeStablePtr_RDR, deRefStablePtr_RDR, bindIO_RDR]
+ | otherwise = returnRn (unitFV name')
+ extra_fvs other = returnRn emptyFVs
in
checkRn (ok_ext_nm ext_nm) (badExtName ext_nm) `thenRn_`
+ extra_fvs imp_exp `thenRn` \ fvs1 ->
rnHsSigType fo_decl_msg ty `thenRn` \ (ty', fvs2) ->
returnRn (ForD (ForeignDecl name' imp_exp ty' ext_nm cconv src_loc),
fvs1 `plusFV` fvs2)
where
fo_decl_msg = ptext SLIT("a foreign declaration")
isDyn = isDynamicExtName ext_nm
+
+ ok_ext_nm Dynamic = True
+ ok_ext_nm (ExtName nm (Just mb)) = isCLabelString nm && isCLabelString mb
+ ok_ext_nm (ExtName nm Nothing) = isCLabelString nm
\end{code}
%*********************************************************
%*********************************************************
\begin{code}
-rnDecl (RuleD (IfaceRuleDecl var body src_loc))
- = pushSrcLocRn src_loc $
- lookupOccRn var `thenRn` \ var' ->
- rnRuleBody body `thenRn` \ (body', fvs) ->
- returnRn (RuleD (IfaceRuleDecl var' body' src_loc), fvs `addOneFV` var')
+rnDecl (RuleD (IfaceRule rule_name vars fn args rhs src_loc))
+ = pushSrcLocRn src_loc $
+ lookupOccRn fn `thenRn` \ fn' ->
+ rnCoreBndrs vars $ \ vars' ->
+ mapFvRn rnCoreExpr args `thenRn` \ (args', fvs1) ->
+ rnCoreExpr rhs `thenRn` \ (rhs', fvs2) ->
+ returnRn (RuleD (IfaceRule rule_name vars' fn' args' rhs' src_loc),
+ (fvs1 `plusFV` fvs2) `addOneFV` fn')
-rnDecl (RuleD (RuleDecl rule_name tvs vars lhs rhs src_loc))
+rnDecl (RuleD (IfaceRuleOut fn rule))
+ -- This one is used for BuiltInRules
+ -- The rule itself is already done, but the thing
+ -- to attach it to is not.
+ = lookupOccRn fn `thenRn` \ fn' ->
+ returnRn (RuleD (IfaceRuleOut fn' rule), unitFV fn')
+
+rnDecl (RuleD (HsRule rule_name tvs vars lhs rhs src_loc))
= ASSERT( null tvs )
pushSrcLocRn src_loc $
bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs)]
in
mapRn (addErrRn . badRuleVar rule_name) bad_vars `thenRn_`
- returnRn (RuleD (RuleDecl rule_name sig_tvs' vars' lhs' rhs' src_loc),
+ returnRn (RuleD (HsRule rule_name sig_tvs' vars' lhs' rhs' src_loc),
fv_vars `plusFV` fv_lhs `plusFV` fv_rhs)
where
doc = text "the transformation rule" <+> ptext rule_name
get_var (RuleBndrSig v _) = v
rn_var (RuleBndr v, id) = returnRn (RuleBndr id, emptyFVs)
- rn_var (RuleBndrSig v t, id) = rnHsPolyType doc t `thenRn` \ (t', fvs) ->
+ rn_var (RuleBndrSig v t, id) = rnHsType doc t `thenRn` \ (t', fvs) ->
returnRn (RuleBndrSig id t', fvs)
\end{code}
returnRn (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2)
rnConDetails doc locn (NewCon ty mb_field)
- = rnHsPolyType doc ty `thenRn` \ (new_ty, fvs) ->
+ = rnHsType doc ty `thenRn` \ (new_ty, fvs) ->
rn_field mb_field `thenRn` \ new_mb_field ->
returnRn (NewCon new_ty new_mb_field, fvs)
where
returnRn ((new_names, new_ty), fvs)
rnBangTy doc (Banged ty)
- = rnHsPolyType doc ty `thenRn` \ (new_ty, fvs) ->
+ = rnHsType doc ty `thenRn` \ (new_ty, fvs) ->
returnRn (Banged new_ty, fvs)
rnBangTy doc (Unbanged ty)
- = rnHsPolyType doc ty `thenRn` \ (new_ty, fvs) ->
+ = rnHsType doc ty `thenRn` \ (new_ty, fvs) ->
returnRn (Unbanged new_ty, fvs)
rnBangTy doc (Unpacked ty)
- = rnHsPolyType doc ty `thenRn` \ (new_ty, fvs) ->
+ = rnHsType doc ty `thenRn` \ (new_ty, fvs) ->
returnRn (Unpacked new_ty, fvs)
-- This data decl will parse OK
-- rnHsSigType is used for source-language type signatures,
-- which use *implicit* universal quantification.
rnHsSigType doc_str ty
- = rnHsPolyType (text "the type signature for" <+> doc_str) ty
+ = rnHsType (text "the type signature for" <+> doc_str) ty
---------------------------------------
-rnHsPolyType, rnHsType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
--- rnHsPolyType is prepared to see a for-all; rnHsType is not
--- The former is called for the top level of type sigs and function args.
+rnHsType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
----------------------------------------
-rnHsPolyType doc (HsForAllTy Nothing ctxt ty)
+rnHsType doc (HsForAllTy Nothing ctxt ty)
-- Implicit quantifiction in source code (no kinds on tyvars)
-- Given the signature C => T we universally quantify
-- over FV(T) \ {in-scope-tyvars}
checkConstraints doc forall_tyvars mentioned_in_tau ctxt ty `thenRn` \ ctxt' ->
rnForAll doc (map UserTyVar forall_tyvars) ctxt' ty
-rnHsPolyType doc (HsForAllTy (Just forall_tyvars) ctxt tau)
+rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt tau)
-- Explicit quantification.
-- Check that the forall'd tyvars are a subset of the
-- free tyvars in the tau-type part
checkConstraints doc forall_tyvar_names mentioned_in_tau ctxt tau `thenRn` \ ctxt' ->
rnForAll doc forall_tyvars ctxt' tau
-rnHsPolyType doc other_ty = rnHsType doc other_ty
+rnHsType doc (HsTyVar tyvar)
+ = lookupOccRn tyvar `thenRn` \ tyvar' ->
+ returnRn (HsTyVar tyvar', unitFV tyvar')
+
+rnHsType doc (HsFunTy ty1 ty2)
+ = rnHsType doc ty1 `thenRn` \ (ty1', fvs1) ->
+ -- Might find a for-all as the arg of a function type
+ rnHsType doc ty2 `thenRn` \ (ty2', fvs2) ->
+ -- Or as the result. This happens when reading Prelude.hi
+ -- when we find return :: forall m. Monad m -> forall a. a -> m a
+ returnRn (HsFunTy ty1' ty2', fvs1 `plusFV` fvs2)
+rnHsType doc (HsListTy ty)
+ = rnHsType doc ty `thenRn` \ (ty', fvs) ->
+ returnRn (HsListTy ty', fvs `addOneFV` listTyCon_name)
+-- Unboxed tuples are allowed to have poly-typed arguments. These
+-- sometimes crop up as a result of CPR worker-wrappering dictionaries.
+rnHsType doc (HsTupleTy (HsTupCon _ boxity) tys)
+ -- Don't do lookupOccRn, because this is built-in syntax
+ -- so it doesn't need to be in scope
+ = mapFvRn (rnHsType doc) tys `thenRn` \ (tys', fvs) ->
+ returnRn (HsTupleTy (HsTupCon n' boxity) tys', fvs `addOneFV` n')
+ where
+ n' = tupleTyCon_name boxity (length tys)
+
+
+rnHsType doc (HsAppTy ty1 ty2)
+ = rnHsType doc ty1 `thenRn` \ (ty1', fvs1) ->
+ rnHsType doc ty2 `thenRn` \ (ty2', fvs2) ->
+ returnRn (HsAppTy ty1' ty2', fvs1 `plusFV` fvs2)
+
+rnHsType doc (HsPredTy pred)
+ = rnPred doc pred `thenRn` \ (pred', fvs) ->
+ returnRn (HsPredTy pred', fvs)
+
+rnHsType doc (HsUsgForAllTy uv_rdr ty)
+ = bindUVarRn doc uv_rdr $ \ uv_name ->
+ rnHsType doc ty `thenRn` \ (ty', fvs) ->
+ returnRn (HsUsgForAllTy uv_name ty',
+ fvs )
+
+rnHsType doc (HsUsgTy usg ty)
+ = newUsg usg `thenRn` \ (usg', usg_fvs) ->
+ rnHsType doc ty `thenRn` \ (ty', ty_fvs) ->
+ -- A for-all can occur inside a usage annotation
+ returnRn (HsUsgTy usg' ty',
+ usg_fvs `plusFV` ty_fvs)
+ where
+ newUsg usg = case usg of
+ HsUsOnce -> returnRn (HsUsOnce, emptyFVs)
+ HsUsMany -> returnRn (HsUsMany, emptyFVs)
+ HsUsVar uv_rdr -> lookupOccRn uv_rdr `thenRn` \ uv_name ->
+ returnRn (HsUsVar uv_name, emptyFVs)
+
+rnHsTypes doc tys = mapFvRn (rnHsType doc) tys
+\end{code}
+
+\begin{code}
+-- We use lookupOcc here because this is interface file only stuff
+-- and we need the workers...
+rnHsTupCon (HsTupCon n boxity)
+ = lookupOccRn n `thenRn` \ n' ->
+ returnRn (HsTupCon n' boxity, unitFV n')
+
+rnHsTupConWkr (HsTupCon n boxity)
+ -- Tuple construtors are for the *worker* of the tuple
+ -- Going direct saves needless messing about
+ = lookupOccRn (mkRdrNameWkr n) `thenRn` \ n' ->
+ returnRn (HsTupCon n' boxity, unitFV n')
+\end{code}
+
+\begin{code}
-- Check that each constraint mentions at least one of the forall'd type variables
-- Since the forall'd type variables are a subset of the free tyvars
-- of the tau-type part, this guarantees that every constraint mentions
rnHsType doc ty `thenRn` \ (new_ty, ty_fvs) ->
returnRn (mkHsForAllTy (Just new_tyvars) new_ctxt new_ty,
cxt_fvs `plusFV` ty_fvs)
-
----------------------------------------
-rnHsType doc ty@(HsForAllTy _ _ inner_ty)
- = addWarnRn (unexpectedForAllTy ty) `thenRn_`
- rnHsPolyType doc ty
-
-rnHsType doc (MonoTyVar tyvar)
- = lookupOccRn tyvar `thenRn` \ tyvar' ->
- returnRn (MonoTyVar tyvar', unitFV tyvar')
-
-rnHsType doc (MonoFunTy ty1 ty2)
- = rnHsPolyType doc ty1 `thenRn` \ (ty1', fvs1) ->
- -- Might find a for-all as the arg of a function type
- rnHsPolyType doc ty2 `thenRn` \ (ty2', fvs2) ->
- -- Or as the result. This happens when reading Prelude.hi
- -- when we find return :: forall m. Monad m -> forall a. a -> m a
- returnRn (MonoFunTy ty1' ty2', fvs1 `plusFV` fvs2)
-
-rnHsType doc (MonoListTy ty)
- = rnHsType doc ty `thenRn` \ (ty', fvs) ->
- returnRn (MonoListTy ty', fvs `addOneFV` listTyCon_name)
-
--- Unboxed tuples are allowed to have poly-typed arguments. These
--- sometimes crop up as a result of CPR worker-wrappering dictionaries.
-rnHsType doc (MonoTupleTy tys boxed)
- = (if boxed
- then mapFvRn (rnHsType doc) tys
- else mapFvRn (rnHsPolyType doc) tys) `thenRn` \ (tys', fvs) ->
- returnRn (MonoTupleTy tys' boxed, fvs `addOneFV` tup_con_name)
- where
- tup_con_name = tupleTyCon_name boxed (length tys)
-
-rnHsType doc (MonoTyApp ty1 ty2)
- = rnHsType doc ty1 `thenRn` \ (ty1', fvs1) ->
- rnHsType doc ty2 `thenRn` \ (ty2', fvs2) ->
- returnRn (MonoTyApp ty1' ty2', fvs1 `plusFV` fvs2)
-
-rnHsType doc (MonoIParamTy n ty)
- = getIPName n `thenRn` \ name ->
- rnHsType doc ty `thenRn` \ (ty', fvs) ->
- returnRn (MonoIParamTy name ty', fvs)
-
-rnHsType doc (MonoDictTy clas tys)
- = lookupOccRn clas `thenRn` \ clas' ->
- rnHsTypes doc tys `thenRn` \ (tys', fvs) ->
- returnRn (MonoDictTy clas' tys', fvs `addOneFV` clas')
-
-rnHsType doc (MonoUsgForAllTy uv_rdr ty)
- = bindUVarRn doc uv_rdr $ \ uv_name ->
- rnHsType doc ty `thenRn` \ (ty', fvs) ->
- returnRn (MonoUsgForAllTy uv_name ty',
- fvs )
-
-rnHsType doc (MonoUsgTy usg ty)
- = newUsg usg `thenRn` \ (usg', usg_fvs) ->
- rnHsPolyType doc ty `thenRn` \ (ty', ty_fvs) ->
- -- A for-all can occur inside a usage annotation
- returnRn (MonoUsgTy usg' ty',
- usg_fvs `plusFV` ty_fvs)
- where
- newUsg usg = case usg of
- MonoUsOnce -> returnRn (MonoUsOnce, emptyFVs)
- MonoUsMany -> returnRn (MonoUsMany, emptyFVs)
- MonoUsVar uv_rdr -> lookupOccRn uv_rdr `thenRn` \ uv_name ->
- returnRn (MonoUsVar uv_name, emptyFVs)
-
-rnHsTypes doc tys = mapFvRn (rnHsType doc) tys
\end{code}
-
\begin{code}
rnContext :: SDoc -> RdrNameContext -> RnMS (RenamedContext, FreeVars)
-
rnContext doc ctxt
- = mapAndUnzipRn (rnPred doc) ctxt `thenRn` \ (theta, fvs_s) ->
+ = mapAndUnzipRn rn_pred ctxt `thenRn` \ (theta, fvs_s) ->
let
- (_, dup_asserts) = removeDups (cmpHsPred compare) theta
+ (_, dups) = removeDupsEq theta
+ -- We only have equality, not ordering
in
-- Check for duplicate assertions
-- If this isn't an error, then it ought to be:
- mapRn_ (addWarnRn . dupClassAssertWarn theta) dup_asserts `thenRn_`
-
+ mapRn (addWarnRn . dupClassAssertWarn theta) dups `thenRn_`
returnRn (theta, plusFVs fvs_s)
+ where
+ --Someone discovered that @CCallable@ and @CReturnable@
+ -- could be used in contexts such as:
+ -- foo :: CCallable a => a -> PrimIO Int
+ -- Doing this utterly wrecks the whole point of introducing these
+ -- classes so we specifically check that this isn't being done.
+ rn_pred pred = rnPred doc pred `thenRn` \ (pred', fvs)->
+ checkRn (not (bad_pred pred'))
+ (naughtyCCallContextErr pred') `thenRn_`
+ returnRn (pred', fvs)
+
+ bad_pred (HsPClass clas _) = getUnique clas `elem` cCallishClassKeys
+ bad_pred other = False
+
rnPred doc (HsPClass clas tys)
= lookupOccRn clas `thenRn` \ clas_name ->
rnHsTypes doc tys `thenRn` \ (tys', fvs) ->
returnRn (HsPClass clas_name tys', fvs `addOneFV` clas_name)
+
rnPred doc (HsPIParam n ty)
= getIPName n `thenRn` \ name ->
rnHsType doc ty `thenRn` \ (ty', fvs) ->
\end{code}
\begin{code}
-rnFds :: SDoc -> [([RdrName],[RdrName])] -> RnMS ([([Name],[Name])], FreeVars)
+rnFds :: SDoc -> [FunDep RdrName] -> RnMS ([FunDep Name], FreeVars)
rnFds doc fds
= mapAndUnzipRn rn_fds fds `thenRn` \ (theta, fvs_s) ->
rnIdInfo (HsUpdate update) = returnRn (HsUpdate update, emptyFVs)
rnIdInfo HsNoCafRefs = returnRn (HsNoCafRefs, emptyFVs)
rnIdInfo HsCprInfo = returnRn (HsCprInfo, emptyFVs)
-rnIdInfo (HsSpecialise rule_body) = rnRuleBody rule_body
- `thenRn` \ (rule_body', fvs) ->
- returnRn (HsSpecialise rule_body', fvs)
-rnRuleBody (UfRuleBody str vars args rhs)
- = rnCoreBndrs vars $ \ vars' ->
- mapFvRn rnCoreExpr args `thenRn` \ (args', fvs1) ->
- rnCoreExpr rhs `thenRn` \ (rhs', fvs2) ->
- returnRn (UfRuleBody str vars' args' rhs', fvs1 `plusFV` fvs2)
\end{code}
@UfCore@ expressions.
\begin{code}
rnCoreExpr (UfType ty)
- = rnHsPolyType (text "unfolding type") ty `thenRn` \ (ty', fvs) ->
+ = rnHsType (text "unfolding type") ty `thenRn` \ (ty', fvs) ->
returnRn (UfType ty', fvs)
rnCoreExpr (UfVar v)
returnRn (UfLitLit l ty', fvs)
rnCoreExpr (UfCCall cc ty)
- = rnHsPolyType (text "ccall") ty `thenRn` \ (ty', fvs) ->
+ = rnHsType (text "ccall") ty `thenRn` \ (ty', fvs) ->
returnRn (UfCCall cc ty', fvs)
rnCoreExpr (UfTuple con args)
- = lookupOccRn con `thenRn` \ con' ->
- mapFvRn rnCoreExpr args `thenRn` \ (args', fvs) ->
- returnRn (UfTuple con' args', fvs `addOneFV` con')
+ = rnHsTupConWkr con `thenRn` \ (con', fvs1) ->
+ mapFvRn rnCoreExpr args `thenRn` \ (args', fvs2) ->
+ returnRn (UfTuple con' args', fvs1 `plusFV` fvs2)
rnCoreExpr (UfApp fun arg)
= rnCoreExpr fun `thenRn` \ (fun', fv1) ->
\begin{code}
rnCoreBndr (UfValBinder name ty) thing_inside
- = rnHsPolyType doc ty `thenRn` \ (ty', fvs1) ->
+ = rnHsType doc ty `thenRn` \ (ty', fvs1) ->
bindCoreLocalFVRn name ( \ name' ->
thing_inside (UfValBinder name' ty')
) `thenRn` \ (result, fvs2) ->
\begin{code}
rnCoreAlt (con, bndrs, rhs)
- = rnUfCon con `thenRn` \ (con', fvs1) ->
+ = rnUfCon con bndrs `thenRn` \ (con', fvs1) ->
bindCoreLocalsFVRn bndrs ( \ bndrs' ->
rnCoreExpr rhs `thenRn` \ (rhs', fvs2) ->
returnRn ((con', bndrs', rhs'), fvs2)
returnRn (result, fvs1 `plusFV` fvs3)
rnNote (UfCoerce ty)
- = rnHsPolyType (text "unfolding coerce") ty `thenRn` \ (ty', fvs) ->
+ = rnHsType (text "unfolding coerce") ty `thenRn` \ (ty', fvs) ->
returnRn (UfCoerce ty', fvs)
rnNote (UfSCC cc) = returnRn (UfSCC cc, emptyFVs)
rnNote UfInlineMe = returnRn (UfInlineMe, emptyFVs)
-rnUfCon UfDefault
+rnUfCon UfDefault _
= returnRn (UfDefault, emptyFVs)
-rnUfCon (UfDataAlt con)
+rnUfCon (UfTupleAlt tup_con) bndrs
+ = rnHsTupCon tup_con `thenRn` \ (HsTupCon con' _, fvs) ->
+ returnRn (UfDataAlt con', fvs)
+ -- Makes the type checker a little easier
+
+rnUfCon (UfDataAlt con) _
= lookupOccRn con `thenRn` \ con' ->
returnRn (UfDataAlt con', unitFV con')
-rnUfCon (UfLitAlt lit)
+rnUfCon (UfLitAlt lit) _
= returnRn (UfLitAlt lit, emptyFVs)
-rnUfCon (UfLitLitAlt lit ty)
- = rnHsPolyType (text "litlit") ty `thenRn` \ (ty', fvs) ->
+rnUfCon (UfLitLitAlt lit ty) _
+ = rnHsType (text "litlit") ty `thenRn` \ (ty', fvs) ->
returnRn (UfLitLitAlt lit ty', fvs)
\end{code}
ptext SLIT("does not appear in method signature")])
4 (ppr sig)
-dupClassAssertWarn ctxt (assertion : dups)
- = sep [hsep [ptext SLIT("Duplicate class assertion"),
- quotes (pprHsPred assertion),
- ptext SLIT("in the context:")],
- nest 4 (pprHsContext ctxt <+> ptext SLIT("..."))]
-
badDataCon name
= hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
univErr doc constraint ty
= sep [ptext SLIT("All of the type variable(s) in the constraint")
- <+> quotes (pprHsPred constraint)
+ <+> quotes (ppr constraint)
<+> ptext SLIT("are already in scope"),
nest 4 (ptext SLIT("At least one must be universally quantified here"))
]
(ptext SLIT("In") <+> doc)
ambigErr doc constraint ty
- = sep [ptext SLIT("Ambiguous constraint") <+> quotes (pprHsPred constraint),
+ = sep [ptext SLIT("Ambiguous constraint") <+> quotes (ppr constraint),
nest 4 (ptext SLIT("in the type:") <+> ppr ty),
nest 4 (ptext SLIT("Each forall-d type variable mentioned by the constraint must appear after the =>."))]
$$
(ptext SLIT("In") <+> doc)
-unexpectedForAllTy ty
- = ptext SLIT("Unexpected forall type:") <+> ppr ty
-
badRuleLhsErr name lhs
= sep [ptext SLIT("Rule") <+> ptext name <> colon,
nest 4 (ptext SLIT("Illegal left-hand side:") <+> ppr lhs)]
badExtName :: ExtName -> Message
badExtName ext_nm
= sep [quotes (ppr ext_nm) <+> ptext SLIT("is not a valid C identifier")]
+
+dupClassAssertWarn ctxt (assertion : dups)
+ = sep [hsep [ptext SLIT("Duplicate class assertion"),
+ quotes (ppr assertion),
+ ptext SLIT("in the context:")],
+ nest 4 (ppr ctxt <+> ptext SLIT("..."))]
+
+naughtyCCallContextErr (HsPClass clas _)
+ = sep [ptext SLIT("Can't use class") <+> quotes (ppr clas),
+ ptext SLIT("in a context")]
\end{code}
\begin{code}
module OccurAnal (
- occurAnalyseBinds, occurAnalyseExpr, occurAnalyseGlobalExpr,
- markBinderInsideLambda, tagBinders,
- UsageDetails
+ occurAnalyseBinds, occurAnalyseGlobalExpr, occurAnalyseRule
) where
#include "HsVersions.h"
import Digraph ( stronglyConnCompR, SCC(..) )
import Unique ( u2i, buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey )
import UniqFM ( keysUFM )
-import Util ( zipWithEqual, mapAndUnzip, count )
+import Util ( zipWithEqual, mapAndUnzip )
import Outputable
\end{code}
= -- Top level expr, so no interesting free vars, and
-- discard occurence info returned
snd (occurAnalyseExpr (\_ -> False) expr)
+
+occurAnalyseRule :: CoreRule -> CoreRule
+occurAnalyseRule rule@(BuiltinRule _) = rule
+occurAnalyseRule (Rule str tpl_vars tpl_args rhs)
+ -- Add occ info to tpl_vars, rhs
+ = Rule str tpl_vars' tpl_args rhs'
+ where
+ (rhs_uds, rhs') = occurAnalyseExpr isLocallyDefined rhs
+ (rhs_uds1, tpl_vars') = tagBinders rhs_uds tpl_vars
\end{code}
Nothing -> IAmDead
Just info -> binderInfoToOccInfo info
-markBinderInsideLambda :: CoreBndr -> CoreBndr
-markBinderInsideLambda bndr
- | isTyVar bndr
- = bndr
-
- | otherwise
- = case idOccInfo bndr of
- OneOcc _ once -> bndr `setIdOccInfo` OneOcc insideLam once
- other -> bndr
-
funOccZero = funOccurrence 0
\end{code}
import CoreUtils ( exprType, exprIsTrivial, exprIsBottom )
import CoreFVs -- all of it
+import Subst
import Id ( Id, idType, idFreeTyVars, mkSysLocal, isOneShotLambda, modifyIdInfo,
idSpecialisation, idWorkerInfo, setIdInfo
)
import IdInfo ( workerExists, vanillaIdInfo, demandInfo, setDemandInfo )
import Var ( Var, TyVar, setVarUnique )
-import VarEnv
-import Subst
import VarSet
+import VarEnv
import Name ( getOccName )
import OccName ( occNameUserString )
import Type ( isUnLiftedType, mkPiType, Type )
import BasicTypes ( TopLevelFlag(..) )
import Demand ( isStrict, wwLazy )
-import VarSet
-import VarEnv
import UniqSupply
import Util ( sortLt, isSingleton, count )
import Outputable
cloneVar TopLevel env v ctxt_lvl dest_lvl
= returnUs (env, v) -- Don't clone top level things
cloneVar NotTopLevel env v ctxt_lvl dest_lvl
- = getUniqueUs `thenLvl` \ uniq ->
+ = ASSERT( isId v )
+ getUniqueUs `thenLvl` \ uniq ->
let
v' = setVarUnique v uniq
v'' = subst_id_info env ctxt_lvl dest_lvl v'
cloneVars TopLevel env vs ctxt_lvl dest_lvl
= returnUs (env, vs) -- Don't clone top level things
cloneVars NotTopLevel env vs ctxt_lvl dest_lvl
- = getUniquesUs (length vs) `thenLvl` \ uniqs ->
+ = ASSERT( all isId vs )
+ getUniquesUs (length vs) `thenLvl` \ uniqs ->
let
vs' = zipWith setVarUnique vs uniqs
vs'' = map (subst_id_info env' ctxt_lvl dest_lvl) vs'
NamedThing(..), OccName
)
import TyCon ( TyCon, isDataTyCon )
-import PrelRules ( builtinRules )
import Type ( Type,
isUnLiftedType,
tidyType, tidyTypes, tidyTopType, tidyTyVar, tidyTyVars,
better_local_rules <- simplRules ru_us local_rules binds
- let all_imported_rules = builtinRules ++ imported_rules
- -- Here is where we add in the built-in rules
-
let (binds1, local_rule_base) = prepareLocalRuleBase binds better_local_rules
- imported_rule_base = prepareOrphanRuleBase all_imported_rules
+ imported_rule_base = prepareOrphanRuleBase imported_rules
-- Do the main business
(stats, processed_binds, processed_local_rules)
bind_vars = foldr (unionVarSet . mkVarSet . bindersOf) emptyVarSet binds
+simplRule rule@(ProtoCoreRule is_local id (BuiltinRule _))
+ = returnSmpl rule
simplRule rule@(ProtoCoreRule is_local id (Rule name bndrs args rhs))
| not is_local
= returnSmpl rule -- No need to fiddle with imported rules
import Name ( isLocalName, setNameUnique )
import SimplMonad
import Type ( Type, tyVarsOfType, tyVarsOfTypes, mkForAllTys, seqType, repType,
- splitTyConApp_maybe, splitAlgTyConApp_maybe, mkTyVarTys, applyTys, splitFunTys, mkFunTys
+ splitTyConApp_maybe, mkTyVarTys, applyTys, splitFunTys, mkFunTys
)
+import TyCon ( tyConDataConsIfAvailable )
import PprType ( {- instance Outputable Type -} )
import DataCon ( dataConRepArity )
import TysPrim ( statePrimTyCon )
-- Note the repType: we want to look through newtypes for this purpose
-canUpdateInPlace ty = case splitAlgTyConApp_maybe (repType ty) of
- Just (_, _, [dc]) -> arity == 1 || arity == 2
- where
- arity = dataConRepArity dc
+canUpdateInPlace ty = case splitTyConApp_maybe (repType ty) of {
+ Nothing -> False ;
+ Just (tycon, _) ->
+
+ case tyConDataConsIfAvailable tycon of
+ [dc] -> arity == 1 || arity == 2
+ where
+ arity = dataConRepArity dc
other -> False
+ }
\end{code}
idOccInfo, setIdOccInfo,
zapLamIdInfo, zapFragileIdInfo,
idStrictness, isBottomingId,
- setInlinePragma, mayHaveNoBinding,
+ setInlinePragma,
setOneShotLambda, maybeModifyIdInfo
)
import IdInfo ( InlinePragInfo(..), OccInfo(..), StrictnessInfo(..),
import DataCon ( DataCon, dataConNumInstArgs, dataConRepStrictness, dataConRepArity,
dataConSig, dataConArgTys
)
-import Name ( isLocallyDefined )
import CoreSyn
-import CoreFVs ( exprFreeVars )
+import CoreFVs ( exprFreeVars, mustHaveLocalBinding )
import CoreUnfold ( Unfolding, mkOtherCon, mkUnfolding, otherCons, maybeUnfoldingTemplate,
callSiteInline, hasSomeUnfolding, noUnfolding
)
import Subst ( Subst, mkSubst, emptySubst, substTy, substExpr,
substEnv, isInScope, lookupIdSubst, substIdInfo
)
-import TyCon ( isDataTyCon, tyConDataCons, tyConClass_maybe, tyConArity, isDataTyCon )
+import TyCon ( isDataTyCon, tyConDataConsIfAvailable,
+ tyConClass_maybe, tyConArity, isDataTyCon
+ )
import TysPrim ( realWorldStatePrimTy )
import PrelInfo ( realWorldPrimId )
import BasicTypes ( TopLevelFlag(..), isTopLevel, isLoopBreaker )
case lookupIdSubst subst var of
DoneEx e -> zapSubstEnv (simplExprF e cont)
ContEx env1 e -> setSubstEnv env1 (simplExprF e cont)
- DoneId var1 occ -> WARN( not (isInScope var1 subst) && isLocallyDefined var1 && not (mayHaveNoBinding var1),
+ DoneId var1 occ -> WARN( not (isInScope var1 subst) && mustHaveLocalBinding var1,
text "simplVar:" <+> ppr var )
- -- The mayHaveNoBinding test accouunts for the fact
- -- that class dictionary constructors dont have top level
- -- bindings and hence aren't in scope.
zapSubstEnv (completeCall var1 occ cont)
-- The template is already simplified, so don't re-substitute.
-- This is VITAL. Consider
[] -> alts
other -> [alt | alt@(con,_,_) <- alts, not (con `elem` scrut_cons)]
- missing_cons = [data_con | data_con <- tyConDataCons tycon,
+ missing_cons = [data_con | data_con <- tyConDataConsIfAvailable tycon,
not (data_con `elem` handled_data_cons)]
handled_data_cons = [data_con | DataAlt data_con <- scrut_cons] ++
[data_con | (DataAlt data_con, _, _) <- filtered_alts]
#include "HsVersions.h"
import CoreSyn -- All of it
-import OccurAnal ( occurAnalyseExpr, tagBinders, UsageDetails )
+import OccurAnal ( occurAnalyseRule )
import BinderInfo ( markMany )
-import CoreFVs ( exprFreeVars, idRuleVars, ruleSomeLhsFreeVars )
+import CoreFVs ( exprFreeVars, idRuleVars, ruleRhsFreeVars, ruleSomeLhsFreeVars )
import CoreUnfold ( isCheapUnfolding, unfoldingTemplate )
-import CoreUtils ( eqExpr, cheapEqExpr )
+import CoreUtils ( eqExpr )
import PprCore ( pprCoreRule )
import Subst ( Subst, InScopeSet, substBndr, lookupSubst, extendSubst,
mkSubst, substEnv, setSubstEnv, emptySubst, isInScope,
idSpecialisation, setIdSpecialisation,
setIdNoDiscard, maybeModifyIdInfo, modifyIdInfo
)
-import IdInfo ( setSpecInfo, specInfo )
import Name ( Name, isLocallyDefined )
import Var ( isTyVar, isId )
import VarSet
= Rules (rule:rules) rhs_fvs
-- Put it at the start for lack of anything better
-addRule id (Rules rules rhs_fvs) (Rule str tpl_vars tpl_args rhs)
- = Rules (insert rules) (rhs_fvs `unionVarSet` new_rhs_fvs)
+addRule id (Rules rules rhs_fvs) rule
+ = Rules (insertRule rules new_rule) (rhs_fvs `unionVarSet` new_rhs_fvs)
where
- new_rule = Rule str tpl_vars' tpl_args rhs'
- -- Add occ info to tpl_vars, rhs
-
- (rhs_uds, rhs') = occurAnalyseExpr isLocallyDefined rhs
- (rhs_uds1, tpl_vars') = tagBinders rhs_uds tpl_vars
-
- insert [] = [new_rule]
- insert (rule:rules) | new_is_more_specific rule = (new_rule:rule:rules)
- | otherwise = rule : insert rules
-
- new_is_more_specific rule = maybeToBool (matchRule tpl_var_set rule tpl_args)
-
- tpl_var_set = mkVarSet tpl_vars'
- -- Actually we should probably include the free vars of tpl_args,
- -- but I can't be bothered
-
- new_rhs_fvs = (exprFreeVars rhs' `minusVarSet` tpl_var_set) `delVarSet` id
+ new_rule = occurAnalyseRule rule
+ new_rhs_fvs = ruleRhsFreeVars new_rule `delVarSet` id
-- Hack alert!
-- Don't include the Id in its own rhs free-var set.
-- Otherwise the occurrence analyser makes bindings recursive
-- that shoudn't be. E.g.
-- RULE: f (f x y) z ==> f x (f y z)
+insertRule rules new_rule@(Rule _ tpl_vars tpl_args _)
+ = go rules
+ where
+ tpl_var_set = mkVarSet tpl_vars
+ -- Actually we should probably include the free vars of tpl_args,
+ -- but I can't be bothered
+
+ go [] = [new_rule]
+ go (rule:rules) | new_is_more_specific rule = (new_rule:rule:rules)
+ | otherwise = rule : go rules
+
+ new_is_more_specific rule = maybeToBool (matchRule tpl_var_set rule tpl_args)
+
addIdSpecialisations :: Id -> [([CoreBndr], [CoreExpr], CoreExpr)] -> Id
addIdSpecialisations id spec_stuff
= setIdSpecialisation id new_rules
CoreRule -- The rule itself
-pprProtoCoreRule (ProtoCoreRule _ fn rule) = pprCoreRule (Just fn) rule
+pprProtoCoreRule (ProtoCoreRule _ fn rule) = pprCoreRule (ppr fn) rule
lookupRule :: InScopeSet -> Id -> [CoreExpr] -> Maybe (RuleName, CoreExpr)
lookupRule in_scope fn args
mkForAllTys, boxedTypeKind
)
import PprType ( {- instance Outputable Type -} )
-import Subst ( Subst, mkSubst, substTy, emptySubst, substBndrs, extendSubstList,
+import Subst ( Subst, mkSubst, substTy, mkSubst, substBndrs, extendSubstList,
substId, substAndCloneId, substAndCloneIds, lookupIdSubst
)
import Var ( TyVar, mkSysTyVar, setVarUnique )
return binds'
where
+ -- We need to start with a Subst that knows all the things
+ -- that are in scope, so that the substitution engine doesn't
+ -- accidentally re-use a unique that's already in use
+ -- Easiest thing is to do it all at once, as if all the top-level
+ -- decls were mutually recursive
+ top_subst = mkSubst (mkVarSet (bindersOfBinds binds)) emptySubstEnv
+
go [] = returnSM ([], emptyUDs)
go (bind:binds) = go binds `thenSM` \ (binds', uds) ->
- specBind emptySubst bind uds `thenSM` \ (bind', uds') ->
+ specBind top_subst bind uds `thenSM` \ (bind', uds') ->
returnSM (bind' ++ binds', uds')
dump_specs var = pprCoreRules var (idSpecialisation var)
returnSM (Case scrut' case_bndr' alts', uds_scrut `plusUDs` uds_alts)
where
(subst_alt, case_bndr') = substId subst case_bndr
+ -- No need to clone case binder; it can't float like a let(rec)
spec_alt (con, args, rhs)
= specExpr subst_rhs rhs `thenSM` \ (rhs', uds) ->
import Id ( Id, idType, idArity, idStrictness, idUnfolding, isDataConId_maybe )
import DataCon ( dataConTyCon, splitProductType_maybe, dataConRepArgTys )
import IdInfo ( StrictnessInfo(..) )
-import Demand ( Demand(..), wwPrim, wwStrict, wwEnum, wwUnpackData, wwLazy,
- wwUnpackNew )
+import Demand ( Demand(..), wwPrim, wwStrict, wwEnum, wwUnpackData, wwLazy, wwUnpackNew,
+ mkStrictnessInfo, isLazy
+ )
import SaLib
import TyCon ( isProductTyCon, isRecursiveTyCon, isEnumerationTyCon, isNewTyCon )
import BasicTypes ( Arity, NewOrData(..) )
-import Type ( splitAlgTyConApp_maybe,
+import Type ( splitTyConApp_maybe,
isUnLiftedType, Type )
import TyCon ( tyConUnique )
import PrelInfo ( numericTyKeys )
-- HOWEVER, if we make diverging functions appear lazy, they
-- don't get wrappers, and then we get dreadful reboxing.
-- See notes with WwLib.worthSplitting
- = StrictnessInfo (combineDemands id str_ds abs_ds) (isBot str_res)
+ = find_strictness id str_ds str_res abs_ds
findStrictness id str_val abs_val = NoStrictnessInfo
-- Here the strictness value takes three args, but the absence value
-- takes only one, for reasons I don't quite understand (see cheapFixpoint)
-combineDemands id orig_str_ds orig_abs_ds
- = go orig_str_ds orig_abs_ds
+find_strictness id orig_str_ds orig_str_res orig_abs_ds
+ = mkStrictnessInfo (go orig_str_ds orig_abs_ds, res_bot)
where
+ res_bot = isBot orig_str_res
+
go str_ds abs_ds = zipWith mk_dmd str_ds (abs_ds ++ repeat wwLazy)
- mk_dmd str_dmd (WwLazy True) = WARN( case str_dmd of { WwLazy _ -> False; other -> True },
- ppr id <+> ppr orig_str_ds <+> ppr orig_abs_ds )
- WwLazy True -- Best of all
+ mk_dmd str_dmd (WwLazy True)
+ = WARN( not (res_bot || isLazy str_dmd),
+ ppr id <+> ppr orig_str_ds <+> ppr orig_abs_ds )
+ -- If the arg isn't used we jolly well don't expect the function
+ -- to be strict in it. Unless the function diverges.
+ WwLazy True -- Best of all
+
mk_dmd (WwUnpack nd u str_ds)
(WwUnpack _ _ abs_ds) = WwUnpack nd u (go str_ds abs_ds)
where
is_numeric_type ty
- = case (splitAlgTyConApp_maybe ty) of -- NB: duplicates stuff done above
- Nothing -> False
- Just (tycon, _, _)
- | tyConUnique tycon `is_elem` numericTyKeys
- -> True
- _{-something else-} -> False
+ = case (splitTyConApp_maybe ty) of -- NB: duplicates stuff done above
+ Nothing -> False
+ Just (tycon, _) -> tyConUnique tycon `is_elem` numericTyKeys
where
is_elem = isIn "is_numeric_type"
import Demand ( Demand(..), wwLazy, wwPrim )
import PrelInfo ( realWorldPrimId, aBSENT_ERROR_ID )
import TysPrim ( realWorldStatePrimTy )
-import TysWiredIn ( unboxedTupleCon, unboxedTupleTyCon )
+import TysWiredIn ( tupleCon )
import Type ( isUnLiftedType,
splitForAllTys, splitFunTys, isAlgType,
splitNewType_maybe,
Type
)
import TyCon ( isNewTyCon, isProductTyCon, TyCon )
-import BasicTypes ( NewOrData(..), Arity )
+import BasicTypes ( NewOrData(..), Arity, Boxity(..) )
import Var ( TyVar, Var, isId )
import UniqSupply ( returnUs, thenUs, getUniqueUs, getUniquesUs,
mapUs, UniqSM )
let
(wrap_wild : work_wild : args) = zipWith mk_ww_local uniqs (ubx_tup_ty : body_ty : con_arg_tys)
arg_vars = map Var args
- ubx_tup_con = unboxedTupleCon n_con_args
+ ubx_tup_con = tupleCon Unboxed n_con_args
ubx_tup_ty = exprType ubx_tup_app
ubx_tup_app = mkConApp ubx_tup_con (map Type con_arg_tys ++ arg_vars)
con_app = mkConApp data_con (map Type tycon_arg_tys ++ arg_vars)
zonkTcThetaType
)
import Bag
-import Class ( classInstEnv, Class )
+import Class ( classInstEnv, Class, FunDep )
import FunDeps ( instantiateFdClassTys )
import Id ( Id, idFreeTyVars, idType, mkUserLocal, mkSysLocal )
import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass )
| FunDep
Class -- the class from which this arises
- [([TcType], [TcType])]
+ [FunDep TcType]
InstLoc
data OverloadedLit
\begin{code}
instance Ord Inst where
compare = cmpInst
-instance Ord PredType where
- compare = cmpPred
instance Eq Inst where
(==) i1 i2 = case i1 `cmpInst` i2 of
EQ -> True
other -> False
-instance Eq PredType where
- (==) p1 p2 = case p1 `cmpPred` p2 of
- EQ -> True
- other -> False
-cmpInst (Dict _ pred1 _) (Dict _ pred2 _)
- = (pred1 `cmpPred` pred2)
-cmpInst (Dict _ _ _) other
- = LT
-
-cmpInst (Method _ _ _ _ _ _) (Dict _ _ _)
- = GT
-cmpInst (Method _ id1 tys1 _ _ _) (Method _ id2 tys2 _ _ _)
- = (id1 `compare` id2) `thenCmp` (tys1 `compare` tys2)
-cmpInst (Method _ _ _ _ _ _) other
- = LT
-
-cmpInst (LitInst _ lit1 ty1 _) (LitInst _ lit2 ty2 _)
- = (lit1 `cmpOverLit` lit2) `thenCmp` (ty1 `compare` ty2)
-cmpInst (LitInst _ _ _ _) (FunDep _ _ _)
- = LT
-cmpInst (LitInst _ _ _ _) other
- = GT
-
-cmpInst (FunDep clas1 fds1 _) (FunDep clas2 fds2 _)
- = (clas1 `compare` clas2) `thenCmp` (fds1 `compare` fds2)
-cmpInst (FunDep _ _ _) other
- = GT
-
-cmpPred (Class c1 tys1) (Class c2 tys2)
- = (c1 `compare` c2) `thenCmp` (tys1 `compare` tys2)
-cmpPred (IParam n1 ty1) (IParam n2 ty2)
- = (n1 `compare` n2) `thenCmp` (ty1 `compare` ty2)
-cmpPred (Class _ _) (IParam _ _) = LT
-cmpPred _ _ = GT
+cmpInst (Dict _ pred1 _) (Dict _ pred2 _) = (pred1 `compare` pred2)
+cmpInst (Dict _ _ _) other = LT
+
+cmpInst (Method _ _ _ _ _ _) (Dict _ _ _) = GT
+cmpInst (Method _ id1 tys1 _ _ _) (Method _ id2 tys2 _ _ _) = (id1 `compare` id2) `thenCmp` (tys1 `compare` tys2)
+cmpInst (Method _ _ _ _ _ _) other = LT
+
+cmpInst (LitInst _ lit1 ty1 _) (LitInst _ lit2 ty2 _) = (lit1 `cmpOverLit` lit2) `thenCmp` (ty1 `compare` ty2)
+cmpInst (LitInst _ _ _ _) (FunDep _ _ _) = LT
+cmpInst (LitInst _ _ _ _) other = GT
+
+cmpInst (FunDep clas1 fds1 _) (FunDep clas2 fds2 _) = (clas1 `compare` clas2) `thenCmp` (fds1 `compare` fds2)
+cmpInst (FunDep _ _ _) other = GT
cmpOverLit (OverloadedIntegral i1) (OverloadedIntegral i2) = i1 `compare` i2
cmpOverLit (OverloadedFractional f1) (OverloadedFractional f2) = f1 `compare` f2
newMethodWithGivenTy orig id tys theta tau `thenNF_Tc` \ meth_inst ->
returnNF_Tc (unitLIE meth_inst, instToId meth_inst)
-instOverloadedFun orig (HsVar v) arg_tys theta tau
+instOverloadedFun orig v arg_tys theta tau
+-- This is where we introduce new functional dependencies into the LIE
= newMethodWithGivenTy orig v arg_tys theta tau `thenNF_Tc` \ inst ->
instFunDeps orig theta `thenNF_Tc` \ fds ->
- returnNF_Tc (HsVar (instToId inst), mkLIE (inst : fds))
+ returnNF_Tc (instToId inst, mkLIE (inst : fds))
instFunDeps orig theta
= tcGetInstLoc orig `thenNF_Tc` \ loc ->
)
import TcEnv ( tcExtendLocalValEnv,
newSpecPragmaId, newLocalId,
- tcLookupTyCon,
+ tcLookupTyConByKey,
tcGetGlobalTyVars, tcExtendGlobalTyVars
)
import TcSimplify ( tcSimplify, tcSimplifyAndCheck, tcSimplifyToDicts )
)
import TcUnify ( unifyTauTy, unifyTauTyLists )
-import PrelInfo ( main_NAME, ioTyCon_NAME )
-
import Id ( Id, mkVanillaId, setInlinePragma, idFreeTyVars )
import Var ( idType, idName )
import IdInfo ( setInlinePragInfo, InlinePragInfo(..) )
import Maybes ( maybeToBool )
import BasicTypes ( TopLevelFlag(..), RecFlag(..), isNotTopLevel )
import FiniteMap ( listToFM, lookupFM )
+import Unique ( ioTyConKey, mainKey, hasKey, Uniquable(..) )
import SrcLoc ( SrcLoc )
import Outputable
\end{code}
zonkTcTypes mono_id_tys `thenNF_Tc` \ zonked_mono_id_tys ->
let
body_tyvars = tyVarsOfTypes zonked_mono_id_tys `minusVarSet` free_tyvars
+ fds = getAllFunDepsOfLIE lie
in
if is_unrestricted
then
- let fds = getAllFunDepsOfLIE lie in
+ -- We need to augment the type variables that appear explicitly in
+ -- the type by those that are determined by the functional dependencies.
+ -- e.g. suppose our type is C a b => a -> a
+ -- with the fun-dep a->b
+ -- Then we should generalise over b too; otherwise it will be
+ -- reported as ambiguous.
zonkFunDeps fds `thenNF_Tc` \ fds' ->
- let tvFundep = tyVarFunDep fds'
- extended_tyvars = oclose tvFundep body_tyvars in
+ let tvFundep = tyVarFunDep fds'
+ extended_tyvars = oclose tvFundep body_tyvars
+ in
-- pprTrace "gTVTG" (ppr (lie, body_tyvars, extended_tyvars)) $
returnNF_Tc (emptyVarSet, extended_tyvars)
else
| main_bound_here
= -- First unify the main_id with IO t, for any old t
tcSetErrCtxt mainTyCheckCtxt (
- tcLookupTyCon ioTyCon_NAME `thenTc` \ ioTyCon ->
+ tcLookupTyConByKey ioTyConKey `thenTc` \ ioTyCon ->
newTyVarTy boxedTypeKind `thenNF_Tc` \ t_tv ->
unifyTauTy ((mkTyConApp ioTyCon [t_tv]))
(idType main_mono_id)
find_main NotTopLevel binder_names mono_ids = Nothing
find_main TopLevel binder_names mono_ids = go binder_names mono_ids
go [] [] = Nothing
- go (n:ns) (m:ms) | n == main_NAME = Just m
- | otherwise = go ns ms
+ go (n:ns) (m:ms) | n `hasKey` mainKey = Just m
+ | otherwise = go ns ms
\end{code}
4 (ptext SLIT("(the signature contexts in a mutually recursive group should all be identical)"))
mainContextsErr id
- | getName id == main_NAME = ptext SLIT("Main.main cannot be overloaded")
+ | id `hasKey` mainKey = ptext SLIT("Main.main cannot be overloaded")
| otherwise
= quotes (ppr id) <+> ptext SLIT("cannot be overloaded") <> char ',' <> -- sigh; workaround for cpp's inability to deal
ptext SLIT("because it is mutually recursive with Main.main") -- with commas inside SLIT strings.
mainTyCheckCtxt
- = hsep [ptext SLIT("When checking that"), quotes (ppr main_NAME),
+ = hsep [ptext SLIT("When checking that"), quotes (ptext SLIT("main")),
ptext SLIT("has the required type")]
-----------------------------------------------
import HsSyn ( HsDecl(..), TyClDecl(..), Sig(..), MonoBinds(..),
InPat(..), HsBinds(..), GRHSs(..),
HsExpr(..), HsLit(..), HsType(..), HsPred(..),
- pprHsClassAssertion, mkSimpleMatch,
+ mkSimpleMatch,
andMonoBinds, andMonoBindList, getTyVarName,
isClassDecl, isClassOpSig, isPragSig, collectMonoBinders
)
import Inst ( Inst, InstOrigin(..), LIE, emptyLIE, plusLIE, plusLIEs, newDicts, newMethod )
import TcEnv ( TcId, ValueEnv, TcTyThing(..), tcAddImportedIdInfo,
- tcLookupClass, tcLookupTy, tcExtendTyVarEnvForMeths, tcExtendGlobalTyVars,
+ tcLookupTy, tcExtendTyVarEnvForMeths, tcExtendGlobalTyVars,
tcExtendLocalValEnv
)
import TcBinds ( tcBindWithSigs, tcSpecSigs )
(classArityErr class_name) `thenTc_`
-- Get the (mutable) class kind
- tcLookupTy class_name `thenNF_Tc` \ (kind, _, _) ->
+ tcLookupTy class_name `thenNF_Tc` \ (kind, _) ->
-- Make suitable tyvars and do kind checking
-- The net effect is to mutate the class kind
tyvar_names fundeps class_sigs def_methods pragmas
tycon_name datacon_name datacon_wkr_name sc_sel_names src_loc)
= -- LOOK THINGS UP IN THE ENVIRONMENT
- tcLookupTy class_name `thenTc` \ (class_kind, _, AClass rec_class) ->
+ tcLookupTy class_name `thenTc` \ (class_kind, AClass rec_class arity) ->
tcExtendTopTyVarScope class_kind tyvar_names $ \ tyvars _ ->
-- The class kind is by now immutable
clas -- Yes! It's a dictionary
new_or_data
in
- returnTc clas
+ returnTc (class_name, AClass clas arity)
\end{code}
\begin{code}
mapTc tc_fd_tyvar vs `thenTc` \ vs' ->
returnTc (us', vs')
tc_fd_tyvar v =
- tcLookupTy v `thenTc` \(_, _, thing) ->
- case thing of
- ATyVar tv -> returnTc tv
- -- ZZ else should fail more gracefully
+ tcLookupTy v `thenTc` \(_, ATyVar tv) ->
+ returnTc tv
\end{code}
\begin{code}
returnTc (sc_theta', sc_tys, sc_sel_ids)
where
- check_constraint (HsPClass c tys) = checkTc (all is_tyvar tys)
- (superClassErr class_name (c, tys))
+ check_constraint sc@(HsPClass c tys) = checkTc (all is_tyvar tys)
+ (superClassErr class_name sc)
- is_tyvar (MonoTyVar _) = True
- is_tyvar other = False
+ is_tyvar (HsTyVar _) = True
+ is_tyvar other = False
tcClassSig :: ValueEnv -- Knot tying only!
| otherwise -- It is locally defined
= recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $
tcAddSrcLoc src_loc $
- tcLookupClass class_name `thenNF_Tc` \ clas ->
+ tcLookupTy class_name `thenNF_Tc` \ (_, AClass clas _) ->
tcDefaultMethodBinds clas default_binds class_sigs
\end{code}
= ptext SLIT("Too many parameters for class") <+> quotes (ppr class_name)
superClassErr class_name sc
- = ptext SLIT("Illegal superclass constraint") <+> quotes (pprHsClassAssertion sc)
+ = ptext SLIT("Illegal superclass constraint") <+> quotes (ppr sc)
<+> ptext SLIT("in declaration for class") <+> quotes (ppr class_name)
defltMethCtxt class_name
OccName, nameOccName
)
import RdrName ( RdrName )
-import RnMonad ( Fixities )
+import RnMonad ( FixityEnv )
import SrcLoc ( mkGeneratedSrcLoc, SrcLoc )
import TyCon ( tyConTyVars, tyConDataCons, tyConDerivings,
tyConTheta, maybeTyConSingleCon, isDataTyCon,
\begin{code}
tcDeriving :: ModuleName -- name of module under scrutiny
- -> Fixities -- for the deriving code (Show/Read.)
+ -> FixityEnv -- for the deriving code (Show/Read.)
-> RnNameSupply -- for "renaming" bits of generated code
-> Bag InstInfo -- What we already know about instances
-> TcM s (Bag InstInfo, -- The generated "instance decls".
------------------------------------------------------------------
chk_out :: Class -> TyCon -> Maybe Message
chk_out clas tycon
- | clas_key == enumClassKey && not is_enumeration = bog_out nullary_why
- | clas_key == boundedClassKey && not is_enumeration_or_single = bog_out single_nullary_why
- | clas_key == ixClassKey && not is_enumeration_or_single = bog_out single_nullary_why
+ | clas `hasKey` enumClassKey && not is_enumeration = bog_out nullary_why
+ | clas `hasKey` boundedClassKey && not is_enumeration_or_single = bog_out single_nullary_why
+ | clas `hasKey` ixClassKey && not is_enumeration_or_single = bog_out single_nullary_why
| any isExistentialDataCon (tyConDataCons tycon) = Just (existentialErr clas tycon)
| otherwise = Nothing
where
- clas_key = classKey clas
-
is_enumeration = isEnumerationTyCon tycon
is_single_con = maybeToBool (maybeTyConSingleCon tycon)
is_enumeration_or_single = is_enumeration || is_single_con
-- Generate the method bindings for the required instance
-- (paired with class name, as we need that when generating dict
-- names.)
-gen_bind :: Fixities -> InstInfo -> ({-class-}OccName, {-tyCon-}OccName, RdrNameMonoBinds)
+gen_bind :: FixityEnv -> InstInfo -> ({-class-}OccName, {-tyCon-}OccName, RdrNameMonoBinds)
gen_bind fixities (InstInfo clas _ [ty] _ _ _ _ _)
| not from_here
= (clas_nm, tycon_nm, EmptyMonoBinds)
- | ckey == showClassKey
+ | clas `hasKey` showClassKey
= (clas_nm, tycon_nm, gen_Show_binds fixities tycon)
- | ckey == readClassKey
+ | clas `hasKey` readClassKey
= (clas_nm, tycon_nm, gen_Read_binds fixities tycon)
| otherwise
= (clas_nm, tycon_nm,
,(boundedClassKey, gen_Bounded_binds)
,(ixClassKey, gen_Ix_binds)
]
- ckey
+ (classKey clas)
tycon)
where
clas_nm = nameOccName (getName clas)
tycon_nm = nameOccName (getName tycon)
from_here = isLocallyDefined tycon
(tycon,_,_) = splitAlgTyConApp ty
- ckey = classKey clas
-
gen_inst_info :: InstInfo
-> (Name, RenamedMonoBinds)
TcEnv, ValueEnv, TcTyThing(..),
- initEnv, getEnvTyCons, getEnvClasses, getAllEnvTyCons,
+ initEnv, getEnvTyCons, getEnvClasses, getEnvAllTyCons,
tcExtendUVarEnv, tcLookupUVar,
tcExtendTyVarEnv, tcExtendTyVarEnvForMeths, tcExtendTypeEnv, tcGetInScopeTyVars,
tcLookupTy,
- tcLookupTyCon, tcLookupTyConByKey,
- tcLookupClass, tcLookupClassByKey, tcLookupClassByKey_maybe,
+ tcLookupTyConByKey,
+ tcLookupClassByKey, tcLookupClassByKey_maybe,
tcExtendGlobalValEnv, tcExtendLocalValEnv,
tcGetValueEnv, tcSetValueEnv,
#include "HsVersions.h"
-import HsTypes ( HsTyVar, getTyVarName )
+import HsTypes ( HsTyVarBndr, getTyVarName )
import Id ( mkUserLocal, isDataConWrapId_maybe )
import MkId ( mkSpecPragmaId )
import Var ( TyVar, Id, setVarName,
type NameEnv val = UniqFM val -- Keyed by Names
type UsageEnv = NameEnv UVar
-type TypeEnv = NameEnv (TcKind, Maybe Arity, TcTyThing)
+type TypeEnv = NameEnv (TcKind, TcTyThing)
type ValueEnv = NameEnv Id
valueEnvIds :: ValueEnv -> [Id]
data TcTyThing = ATyVar TcTyVar -- Mutable only so that the kind can be mutable
-- if the kind is mutable, the tyvar must be so that
-- zonking works
- | ATyCon TyCon
- | AClass Class
+ | ADataTyCon TyCon
+ | ASynTyCon TyCon Arity
+ | AClass Class Arity
initEnv :: TcRef TcTyVarSet -> TcEnv
initEnv mut = TcEnv emptyUFM emptyUFM emptyUFM (emptyVarSet, mut)
-getEnvTyCons (TcEnv _ te _ _) = [tc | (_, _, ATyCon tc) <- eltsUFM te]
-getEnvClasses (TcEnv _ te _ _) = [cl | (_, _, AClass cl) <- eltsUFM te]
-getAllEnvTyCons (TcEnv _ te _ _) = catMaybes (map gettc (eltsUFM te))
+getEnvClasses (TcEnv _ te _ _) = [cl | (_, AClass cl _) <- eltsUFM te]
+
+getEnvTyCons (TcEnv _ te _ _) = catMaybes (map get_tc (eltsUFM te))
+ where
+ get_tc (_, ADataTyCon tc) = Just tc
+ get_tc (_, ASynTyCon tc _) = Just tc
+ get_tc other = Nothing
+
+getEnvAllTyCons te_list = catMaybes (map get_tc te_list)
+ -- The 'all' means 'including the tycons from class decls'
where
- gettc (_,_, ATyCon tc) = Just tc
- gettc (_,_, AClass cl) = Just (classTyCon cl)
- gettc _ = Nothing
+ get_tc (_, ADataTyCon tc) = Just tc
+ get_tc (_, ASynTyCon tc _) = Just tc
+ get_tc (_, AClass cl _) = Just (classTyCon cl)
+ get_tc other = Nothing
\end{code}
The UsageEnv
tcExtendTyVarEnv tyvars scope
= tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve (in_scope_tvs, gtvs)) ->
let
- extend_list = [ (getName tv, (kindToTcKind (tyVarKind tv), Nothing, ATyVar tv))
+ extend_list = [ (getName tv, (kindToTcKind (tyVarKind tv), ATyVar tv))
| tv <- tyvars
]
te' = addListToUFM te extend_list
in
tcSetEnv (TcEnv ue te' ve gtvs) thing_inside
where
- stuff = [ (getName sig_tv, (kindToTcKind (tyVarKind inst_tv), Nothing, ATyVar inst_tv))
+ stuff = [ (getName sig_tv, (kindToTcKind (tyVarKind inst_tv), ATyVar inst_tv))
| (sig_tv, inst_tv) <- zipEqual "tcMeth" sig_tyvars inst_tyvars
]
Type constructors and classes
\begin{code}
-tcExtendTypeEnv :: [(Name, (TcKind, Maybe Arity, TcTyThing))] -> TcM s r -> TcM s r
+tcExtendTypeEnv :: [(Name, (TcKind, TcTyThing))] -> TcM s r -> TcM s r
tcExtendTypeEnv bindings scope
- = ASSERT( null [tv | (_, (_,_,ATyVar tv)) <- bindings] )
+ = ASSERT( null [tv | (_, (_,ATyVar tv)) <- bindings] )
-- Not for tyvars; use tcExtendTyVarEnv
tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
let
Looking up in the environments.
\begin{code}
-tcLookupTy :: Name -> NF_TcM s (TcKind, Maybe Arity, TcTyThing)
+tcLookupTy :: Name -> NF_TcM s (TcKind, TcTyThing)
tcLookupTy name
= tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
case lookupUFM te name of {
Nothing ->
case maybeWiredInTyConName name of
- Just tc -> returnNF_Tc (kindToTcKind (tyConKind tc), maybe_arity, ATyCon tc)
- where
- maybe_arity | isSynTyCon tc = Just (tyConArity tc)
- | otherwise = Nothing
+ Just tc | isSynTyCon tc -> returnNF_Tc (kindToTcKind (tyConKind tc), ASynTyCon tc (tyConArity tc))
+ | otherwise -> returnNF_Tc (kindToTcKind (tyConKind tc), ADataTyCon tc)
Nothing -> -- This can happen if an interface-file
-- unfolding is screwed up
failWithTc (tyNameOutOfScope name)
}
-tcLookupClass :: Name -> NF_TcM s Class
-tcLookupClass name
- = tcLookupTy name `thenNF_Tc` \ (_, _, AClass clas) ->
- returnNF_Tc clas
-
-tcLookupTyCon :: Name -> NF_TcM s TyCon
-tcLookupTyCon name
- = tcLookupTy name `thenNF_Tc` \ (_, _, ATyCon tycon) ->
- returnNF_Tc tycon
-
tcLookupClassByKey :: Unique -> NF_TcM s Class
tcLookupClassByKey key
= tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
case lookupUFM_Directly te key of
- Just (_, _, AClass cl) -> returnNF_Tc cl
- other -> pprPanic "tcLookupClassByKey:" (pprUnique10 key)
+ Just (_, AClass cl _) -> returnNF_Tc cl
+ other -> pprPanic "tcLookupClassByKey:" (pprUnique10 key)
tcLookupClassByKey_maybe :: Unique -> NF_TcM s (Maybe Class)
tcLookupClassByKey_maybe key
= tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
case lookupUFM_Directly te key of
- Just (_, _, AClass cl) -> returnNF_Tc (Just cl)
- other -> returnNF_Tc Nothing
+ Just (_, AClass cl _) -> returnNF_Tc (Just cl)
+ other -> returnNF_Tc Nothing
tcLookupTyConByKey :: Unique -> NF_TcM s TyCon
tcLookupTyConByKey key
= tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
case lookupUFM_Directly te key of
- Just (_, _, ATyCon tc) -> returnNF_Tc tc
- other -> pprPanic "tcLookupTyConByKey:" (pprUnique10 key)
+ Just (_, ADataTyCon tc) -> returnNF_Tc tc
+ Just (_, ASynTyCon tc _) -> returnNF_Tc tc
+ other -> pprPanic "tcLookupTyConByKey:" (pprUnique10 key)
\end{code}
tcLookupValue, tcLookupClassByKey,
tcLookupValueByKey,
tcExtendGlobalTyVars, tcLookupValueMaybe,
- tcLookupTyCon, tcLookupDataCon
+ tcLookupTyConByKey, tcLookupDataCon
)
import TcMatches ( tcMatchesCase, tcMatchLambda, tcStmts )
import TcMonoType ( tcHsSigType, checkSigTyVars, sigCtxt )
floatPrimTy, addrPrimTy
)
import TysWiredIn ( boolTy, charTy, stringTy )
-import PrelInfo ( ioTyCon_NAME )
-import TcUnify ( unifyTauTy, unifyFunTy, unifyListTy, unifyTupleTy,
- unifyUnboxedTupleTy )
+import TcUnify ( unifyTauTy, unifyFunTy, unifyListTy, unifyTupleTy )
import Unique ( cCallableClassKey, cReturnableClassKey,
enumFromClassOpKey, enumFromThenClassOpKey,
enumFromToClassOpKey, enumFromThenToClassOpKey,
- thenMClassOpKey, failMClassOpKey, returnMClassOpKey
+ thenMClassOpKey, failMClassOpKey, returnMClassOpKey, ioTyConKey
)
import Outputable
import Maybes ( maybeToBool, mapMaybe )
= -- Get the callable and returnable classes.
tcLookupClassByKey cCallableClassKey `thenNF_Tc` \ cCallableClass ->
tcLookupClassByKey cReturnableClassKey `thenNF_Tc` \ cReturnableClass ->
- tcLookupTyCon ioTyCon_NAME `thenNF_Tc` \ ioTyCon ->
+ tcLookupTyConByKey ioTyConKey `thenNF_Tc` \ ioTyCon ->
let
new_arg_dict (arg, arg_ty)
= newClassDicts (CCallOrigin (_UNPK_ lbl) (Just arg))
= tcAddErrCtxt (listCtxt expr) $
tcMonoExpr expr elt_ty
-tcMonoExpr (ExplicitTuple exprs boxed) res_ty
- = (if boxed
- then unifyTupleTy (length exprs) res_ty
- else unifyUnboxedTupleTy (length exprs) res_ty
- ) `thenTc` \ arg_tys ->
+tcMonoExpr (ExplicitTuple exprs boxity) res_ty
+ = unifyTupleTy boxity (length exprs) res_ty `thenTc` \ arg_tys ->
mapAndUnzipTc (\ (expr, arg_ty) -> tcMonoExpr expr arg_ty)
(exprs `zip` arg_tys) -- we know they're of equal length.
`thenTc` \ (exprs', lies) ->
- returnTc (ExplicitTuple exprs' boxed, plusLIEs lies)
+ returnTc (ExplicitTuple exprs' boxity, plusLIEs lies)
tcMonoExpr expr@(RecordCon con_name rbinds) res_ty
= tcAddErrCtxt (recordConCtxt expr) $
tcLookupValueMaybe name `thenNF_Tc` \ maybe_local ->
case maybe_local of
- Just tc_id -> instantiate_it (OccurrenceOf tc_id) (HsVar tc_id) (unannotTy (idType tc_id))
+ Just tc_id -> instantiate_it (OccurrenceOf tc_id) tc_id (unannotTy (idType tc_id))
Nothing -> tcLookupValue name `thenNF_Tc` \ id ->
tcInstId id `thenNF_Tc` \ (tyvars, theta, tau) ->
- instantiate_it2 (OccurrenceOf id) (HsVar id) tyvars theta tau
+ instantiate_it2 (OccurrenceOf id) id tyvars theta tau
where
-- The instantiate_it loop runs round instantiating the Id.
instantiate_it2 orig fun tyvars theta tau
= if null theta then -- Is it overloaded?
- returnNF_Tc (mkHsTyApp fun arg_tys, emptyLIE, tau)
+ returnNF_Tc (mkHsTyApp (HsVar fun) arg_tys, emptyLIE, tau)
else
-- Yes, it's overloaded
instOverloadedFun orig fun arg_tys theta tau `thenNF_Tc` \ (fun', lie1) ->
checkForeignRes non_io_result_ok pred_res_ty ty =
case (splitTyConApp_maybe ty) of
Just (io, [res_ty])
- | (getUnique io) == ioTyConKey && pred_res_ty res_ty
+ | io `hasKey` ioTyConKey && pred_res_ty res_ty
-> returnTc ()
_
-> check (non_io_result_ok && pred_res_ty ty)
)
import RdrHsSyn ( mkOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat )
import RdrName ( RdrName, mkSrcUnqual )
-import RnMonad ( Fixities )
+import RnMonad ( FixityEnv, lookupFixity )
import BasicTypes ( RecFlag(..), Fixity(..), FixityDirection(..)
, maxPrecedence, defaultFixity
+ , Boxity(..)
)
import FieldLabel ( fieldLabelName )
import DataCon ( isNullaryDataCon, dataConTag,
enum_range
= mk_easy_FunMonoBind tycon_loc range_RDR
- [TuplePatIn [a_Pat, b_Pat] True{-boxed-}] [] $
+ [TuplePatIn [a_Pat, b_Pat] Boxed] [] $
untag_Expr tycon [(a_RDR, ah_RDR)] $
untag_Expr tycon [(b_RDR, bh_RDR)] $
HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
enum_index
= mk_easy_FunMonoBind tycon_loc index_RDR
- [AsPatIn c_RDR (TuplePatIn [a_Pat, wildPat] True{-boxed-}),
+ [AsPatIn c_RDR (TuplePatIn [a_Pat, wildPat] Boxed),
d_Pat] [] (
HsIf (HsPar (mk_easy_App inRange_RDR [c_RDR, d_RDR])) (
untag_Expr tycon [(a_RDR, ah_RDR)] (
enum_inRange
= mk_easy_FunMonoBind tycon_loc inRange_RDR
- [TuplePatIn [a_Pat, b_Pat] True{-boxed-}, c_Pat] [] (
+ [TuplePatIn [a_Pat, b_Pat] Boxed, c_Pat] [] (
untag_Expr tycon [(a_RDR, ah_RDR)] (
untag_Expr tycon [(b_RDR, bh_RDR)] (
untag_Expr tycon [(c_RDR, ch_RDR)] (
--------------------------------------------------------------
single_con_range
= mk_easy_FunMonoBind tycon_loc range_RDR
- [TuplePatIn [con_pat as_needed, con_pat bs_needed] True{-boxed-}] [] $
+ [TuplePatIn [con_pat as_needed, con_pat bs_needed] Boxed] [] $
HsDo ListComp stmts tycon_loc
where
stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
mk_qual a b c = BindStmt (VarPatIn c)
(HsApp (HsVar range_RDR)
- (ExplicitTuple [HsVar a, HsVar b] True))
+ (ExplicitTuple [HsVar a, HsVar b] Boxed))
tycon_loc
----------------
single_con_index
= mk_easy_FunMonoBind tycon_loc index_RDR
- [TuplePatIn [con_pat as_needed, con_pat bs_needed] True,
+ [TuplePatIn [con_pat as_needed, con_pat bs_needed] Boxed,
con_pat cs_needed] [range_size] (
foldl mk_index (HsLit (HsInt 0)) (zip3 as_needed bs_needed cs_needed))
where
mk_index multiply_by (l, u, i)
= genOpApp (
(HsApp (HsApp (HsVar index_RDR)
- (ExplicitTuple [HsVar l, HsVar u] True)) (HsVar i))
+ (ExplicitTuple [HsVar l, HsVar u] Boxed)) (HsVar i))
) plus_RDR (
genOpApp (
(HsApp (HsVar rangeSize_RDR)
- (ExplicitTuple [HsVar l, HsVar u] True))
+ (ExplicitTuple [HsVar l, HsVar u] Boxed))
) times_RDR multiply_by
)
range_size
= mk_easy_FunMonoBind tycon_loc rangeSize_RDR
- [TuplePatIn [a_Pat, b_Pat] True] [] (
+ [TuplePatIn [a_Pat, b_Pat] Boxed] [] (
genOpApp (
(HsApp (HsApp (HsVar index_RDR)
- (ExplicitTuple [a_Expr, b_Expr] True)) b_Expr)
+ (ExplicitTuple [a_Expr, b_Expr] Boxed)) b_Expr)
) plus_RDR (HsLit (HsInt 1)))
------------------
single_con_inRange
= mk_easy_FunMonoBind tycon_loc inRange_RDR
- [TuplePatIn [con_pat as_needed, con_pat bs_needed] True,
+ [TuplePatIn [con_pat as_needed, con_pat bs_needed] Boxed,
con_pat cs_needed]
[] (
foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed))
where
in_range a b c = HsApp (HsApp (HsVar inRange_RDR)
- (ExplicitTuple [HsVar a, HsVar b] True))
+ (ExplicitTuple [HsVar a, HsVar b] Boxed))
(HsVar c)
\end{code}
%************************************************************************
\begin{code}
-gen_Read_binds :: Fixities -> TyCon -> RdrNameMonoBinds
+gen_Read_binds :: FixityEnv -> TyCon -> RdrNameMonoBinds
-gen_Read_binds fixities tycon
+gen_Read_binds fixity_env tycon
= reads_prec `AndMonoBinds` read_list
where
tycon_loc = getSrcLoc tycon
con_qual
| not is_infix =
BindStmt
- (TuplePatIn [LitPatIn (mkHsString data_con_str), d_Pat] True)
+ (TuplePatIn [LitPatIn (mkHsString data_con_str), d_Pat] Boxed)
(HsApp (HsVar lex_RDR) c_Expr)
tycon_loc
| otherwise =
BindStmt
- (TuplePatIn [LitPatIn (mkHsString data_con_str), VarPatIn bs2] True)
+ (TuplePatIn [LitPatIn (mkHsString data_con_str), VarPatIn bs2] Boxed)
(HsApp (HsVar lex_RDR) (HsVar bs1))
tycon_loc
str_qual str res draw_from =
BindStmt
- (TuplePatIn [LitPatIn (mkHsString str), VarPatIn res] True)
+ (TuplePatIn [LitPatIn (mkHsString str), VarPatIn res] Boxed)
(HsApp (HsVar lex_RDR) draw_from)
tycon_loc
str_qual_paren str res draw_from =
BindStmt
- (TuplePatIn [LitPatIn (mkHsString str), VarPatIn res] True)
+ (TuplePatIn [LitPatIn (mkHsString str), VarPatIn res] Boxed)
(HsApp (readParen_Expr true_Expr (HsVar lex_RDR)) draw_from)
tycon_loc
mk_read_qual p con_field res draw_from =
BindStmt
- (TuplePatIn [VarPatIn con_field, VarPatIn res] True)
+ (TuplePatIn [VarPatIn con_field, VarPatIn res] Boxed)
(HsApp (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt p))) draw_from)
tycon_loc
result_expr = ExplicitTuple [con_expr, if null bs_needed
then d_Expr
- else HsVar (last bs_needed)] True
+ else HsVar (last bs_needed)] Boxed
- [lp,rp] = getLRPrecs is_infix fixities dc_nm
+ [lp,rp] = getLRPrecs is_infix fixity_env dc_nm
quals
| is_infix = let (h:t) = field_quals in (h:con_qual:t)
-}
paren_prec_limit
| not is_infix = fromInt maxPrecedence
- | otherwise = getFixity fixities dc_nm
+ | otherwise = getFixity fixity_env dc_nm
read_paren_arg -- parens depend on precedence...
| nullary_con = false_Expr -- it's optional.
%************************************************************************
\begin{code}
-gen_Show_binds :: Fixities -> TyCon -> RdrNameMonoBinds
+gen_Show_binds :: FixityEnv -> TyCon -> RdrNameMonoBinds
-gen_Show_binds fixs_assoc tycon
+gen_Show_binds fixity_env tycon
= shows_prec `AndMonoBinds` show_list
where
tycon_loc = getSrcLoc tycon
mk_showString_app str = HsApp (HsVar showString_RDR)
(HsLit (mkHsString str))
- prec_cons = getLRPrecs is_infix fixs_assoc dc_nm
+ prec_cons = getLRPrecs is_infix fixity_env dc_nm
real_show_thingies
| is_infix =
(map show_label labels)
real_show_thingies
- (con_left_assoc, con_right_assoc) = isLRAssoc fixs_assoc dc_nm
+ (con_left_assoc, con_right_assoc) = isLRAssoc fixity_env dc_nm
{-
c.f. Figure 16 and 17 in Haskell 1.1 report
-}
paren_prec_limit
| not is_infix = fromInt maxPrecedence + 1
- | otherwise = getFixity fixs_assoc dc_nm + 1
+ | otherwise = getFixity fixity_env dc_nm + 1
\end{code}
\begin{code}
-getLRPrecs :: Bool -> Fixities -> Name -> [Integer]
-getLRPrecs is_infix fixs_assoc nm = [lp, rp]
+getLRPrecs :: Bool -> FixityEnv -> Name -> [Integer]
+getLRPrecs is_infix fixity_env nm = [lp, rp]
where
{-
Figuring out the fixities of the arguments to a constructor,
cf. Figures 16-18 in Haskell 1.1 report.
-}
- (con_left_assoc, con_right_assoc) = isLRAssoc fixs_assoc nm
- paren_con_prec = getFixity fixs_assoc nm
+ (con_left_assoc, con_right_assoc) = isLRAssoc fixity_env nm
+ paren_con_prec = getFixity fixity_env nm
maxPrec = fromInt maxPrecedence
lp
| con_right_assoc = paren_con_prec
| otherwise = paren_con_prec + 1
-getFixity :: Fixities -> Name -> Integer
-getFixity fixs_assoc nm =
- case lookupFixity fixs_assoc nm of
- Fixity x _ -> fromInt x
+getFixity :: FixityEnv -> Name -> Integer
+getFixity fixity_env nm = case lookupFixity fixity_env nm of
+ Fixity x _ -> fromInt x
-isLRAssoc :: Fixities -> Name -> (Bool, Bool)
+isLRAssoc :: FixityEnv -> Name -> (Bool, Bool)
isLRAssoc fixs_assoc nm =
case lookupFixity fixs_assoc nm of
Fixity _ InfixN -> (False, False)
Fixity _ InfixR -> (False, True)
Fixity _ InfixL -> (True, False)
-lookupFixity :: Fixities -> Name -> Fixity
-lookupFixity fixs_assoc nm = assocDefault defaultFixity fixs_assoc nm
-
isInfixOccName :: String -> Bool
isInfixOccName str =
case str of
(':':_) -> True
_ -> False
-
\end{code}
= mk_FunMonoBind (getSrcLoc tycon) rdr_name
[([ConPatIn mkInt_RDR [VarPatIn a_RDR]],
ExprWithTySig (HsApp tagToEnum_Expr a_Expr)
- (MonoTyVar (qual_orig_name tycon)))]
+ (HsTyVar (qual_orig_name tycon)))]
gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag)
= mk_easy_FunMonoBind (getSrcLoc tycon)
zonkRules :: [TcRuleDecl] -> NF_TcM s [TypecheckedRuleDecl]
zonkRules rs = mapNF_Tc zonkRule rs
-zonkRule (RuleDecl name tyvars vars lhs rhs loc)
+zonkRule (HsRule name tyvars vars lhs rhs loc)
= mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
mapNF_Tc zonkIdBndr [v | RuleBndr v <- vars] `thenNF_Tc` \ new_bndrs ->
tcExtendGlobalValEnv new_bndrs $
zonkExpr lhs `thenNF_Tc` \ new_lhs ->
zonkExpr rhs `thenNF_Tc` \ new_rhs ->
- returnNF_Tc (RuleDecl name new_tyvars (map RuleBndr new_bndrs) new_lhs new_rhs loc)
+ returnNF_Tc (HsRule name new_tyvars (map RuleBndr new_bndrs) new_lhs new_rhs loc)
-- I hate this map RuleBndr stuff
-zonkRule (IfaceRuleDecl fun rule loc)
- = returnNF_Tc (IfaceRuleDecl fun rule loc)
+zonkRule (IfaceRuleOut fun rule)
+ = zonkIdOcc fun `thenNF_Tc` \ fun' ->
+ returnNF_Tc (IfaceRuleOut fun' rule)
\end{code}
#include "HsVersions.h"
-import HsSyn ( HsDecl(..), IfaceSig(..) )
+import HsSyn ( HsDecl(..), IfaceSig(..), HsTupCon(..) )
import TcMonad
import TcMonoType ( tcHsType, tcHsTypeKind,
-- NB: all the tyars in interface files are kinded,
import MkId ( mkCCallOpId )
import IdInfo
import DataCon ( dataConSig, dataConArgTys )
-import Type ( mkSynTy, mkTyVarTys, splitAlgTyConApp, splitFunTys, unUsgTy )
+import Type ( mkSynTy, mkTyVarTys, splitAlgTyConApp, splitAlgTyConApp_maybe, splitFunTys, unUsgTy )
import Var ( mkTyVar, tyVarKind )
import VarEnv
import Name ( Name, NamedThing(..), isLocallyDefined )
-import Unique ( rationalTyConKey )
import TysWiredIn ( integerTy, stringTy )
import Demand ( wwLazy )
import ErrUtils ( pprBagOfErrors )
in
returnTc info2
- tcPrag info (HsStrictness (HsStrictnessInfo (demands,bot_result)))
- = returnTc (info `setStrictnessInfo` StrictnessInfo demands bot_result)
+ tcPrag info (HsStrictness strict_info)
+ = returnTc (info `setStrictnessInfo` strict_info)
tcPrag info (HsWorker nm)
= tcWorkerInfo unf_env ty info nm
tcGetUnique `thenNF_Tc` \ u ->
returnTc (Var (mkCCallOpId u cc ty'))
-tcCoreExpr (UfTuple name args)
+tcCoreExpr (UfTuple (HsTupCon name _) args)
= tcVar name `thenTc` \ con_id ->
mapTc tcCoreExpr args `thenTc` \ args' ->
let
-- A case alternative is made quite a bit more complicated
-- by the fact that we omit type annotations because we can
-- work them out. True enough, but its not that easy!
-tcCoreAlt scrut_ty (UfDataAlt con_name, names, rhs)
+tcCoreAlt scrut_ty alt@(UfDataAlt con_name, names, rhs)
= tcVar con_name `thenTc` \ con_id ->
let
- con = case isDataConWrapId_maybe con_id of
- Just con -> con
- Nothing -> pprPanic "tcCoreAlt" (ppr con_id)
+ con = case isDataConWrapId_maybe con_id of
+ Just con -> con
+ Nothing -> pprPanic "tcCoreAlt" (ppr con_id)
(main_tyvars, _, ex_tyvars, _, _, _) = dataConSig con
- (_, inst_tys, cons) = splitAlgTyConApp scrut_ty
+ (_, inst_tys, cons) = case splitAlgTyConApp_maybe scrut_ty of
+ Just stuff -> stuff
+ Nothing -> pprPanic "tcCoreAlt" (ppr alt)
ex_tyvars' = [mkTyVar name (tyVarKind tv) | (name,tv) <- names `zip` ex_tyvars]
ex_tys' = mkTyVarTys ex_tyvars'
arg_tys = dataConArgTys con (inst_tys ++ ex_tys')
#include "HsVersions.h"
import Name ( Name )
-import Type ( Type, tyVarsOfTypes )
-import Class ( className, classInstEnv, classExtraBigSig )
+import Class ( Class, FunDep, className, classInstEnv, classExtraBigSig )
import Unify ( unifyTyListsX, matchTys )
import Subst ( mkSubst, substTy )
import TcMonad
-import TcType ( zonkTcType, zonkTcTypes )
+import TcType ( TcType, TcTyVar, TcTyVarSet, zonkTcType, zonkTcTypes )
import TcUnify ( unifyTauTyLists )
-import Inst ( Inst, LookupInstResult(..),
+import Inst ( LIE, Inst, LookupInstResult(..),
lookupInst, getFunDepsOfLIE, getIPsOfLIE,
zonkLIE, zonkFunDeps {- for debugging -} )
import InstEnv ( InstEnv ) -- Reqd for 4.02; InstEnv is a synonym, and
\end{code}
\begin{code}
-tcImprove lie =
- if null nfdss then
- returnTc ()
- else
- -- zonkCfdss cfdss `thenTc` \ cfdss' ->
- -- pprTrace "tcI" (ppr cfdss') $
- iterImprove nfdss
- where
+tcImprove :: LIE -> TcM s ()
+-- Do unifications based on functional dependencies in the LIE
+tcImprove lie
+ | null nfdss = returnTc ()
+ | otherwise = iterImprove nfdss
+ where
+ nfdss, clas_nfdss, inst_nfdss, ip_nfdss :: [(TcTyVarSet, Name, [FunDep TcType])]
+ nfdss = ip_nfdss ++ clas_nfdss ++ inst_nfdss
+
+ cfdss :: [(Class, [FunDep TcType])]
cfdss = getFunDepsOfLIE lie
clas_nfdss = map (\(c, fds) -> (emptyVarSet, className c, fds)) cfdss
+
classes = nub (map fst cfdss)
inst_nfdss = concatMap getInstNfdssOf classes
+
ips = getIPsOfLIE lie
ip_nfdss = map (\(n, ty) -> (emptyVarSet, n, [([], [ty])])) ips
- nfdss = ip_nfdss ++ clas_nfdss ++ inst_nfdss
-getInstNfdssOf clas = nfdss
- where
+{- Example: we have
+ class C a b c | a->b where ...
+ instance C Int Bool c
+
+ Given the LIE FD C (Int->t)
+ we get clas_nfdss = [({}, C, [Int->t, t->Int])
+ inst_nfdss = [({c}, C, [Int->Bool, Bool->Int])]
+
+ Another way would be to flatten a bit
+ we get clas_nfdss = [({}, C, Int->t), ({}, C, t->Int)]
+ inst_nfdss = [({c}, C, Int->Bool), ({c}, C, Bool->Int)]
+
+ iterImprove then matches up the C and Int, and unifies t <-> Bool
+-}
+
+getInstNfdssOf :: Class -> [(TcTyVarSet, Name, [FunDep TcType])]
+getInstNfdssOf clas
+ = [ (free, nm, instantiateFdClassTys clas ts)
+ | (free, ts, i) <- classInstEnv clas
+ ]
+ where
nm = className clas
- ins = classInstEnv clas
- mk_nfds (free, ts, i) = (free, nm, instantiateFdClassTys clas ts)
- nfdss = map mk_nfds ins
-iterImprove :: [(VarSet, Name, [([Type],[Type])])] -> TcM s ()
+iterImprove :: [(VarSet, Name, [FunDep TcType])] -> TcM s ()
iterImprove [] = returnTc ()
iterImprove cfdss
- = -- zonkCfdss cfdss `thenTc` \ cfdss' ->
- -- pprTrace "iterI" (ppr cfdss') $
- -- instImprove cfdss `thenTc` \ change1 ->
- selfImprove pairImprove cfdss `thenTc` \ change2 ->
+ = selfImprove pairImprove cfdss `thenTc` \ change2 ->
if {- change1 || -} change2 then
iterImprove cfdss
else
returnTc ()
--- ZZ debugging...
-zonkCfdss ((c, fds) : cfdss)
- = zonkFunDeps fds `thenTc` \ fds' ->
- zonkCfdss cfdss `thenTc` \ cfdss' ->
- returnTc ((c, fds') : cfdss')
-zonkCfdss [] = returnTc []
-
-{-
-instImprove (cfds@(clas, fds) : cfdss)
- = instImprove1 cfds ins `thenTc` \ changed ->
- instImprove cfdss `thenTc` \ rest_changed ->
- returnTc (changed || rest_changed)
- where ins = classInstEnv clas
-instImprove [] = returnTc False
-
-instImprove1 cfds@(clas, fds1) ((free, ts, i) : ins)
- = -- pprTrace "iI1" (ppr (free, ts, i)) $
- checkFds fds1 free fds2 `thenTc` \ changed ->
- instImprove1 cfds ins `thenTc` \ rest_changed ->
- returnTc (changed || rest_changed)
- where fds2 = instantiateFdClassTys clas ts
-instImprove1 _ _ = returnTc False
--}
-
-- ZZ this will do a lot of redundant checking wrt instances
-- it would do to make this operate over two lists, the first
-- with only clas_nfds and ip_nfds, and the second with everything
-- caller could control whether the redundant inst improvements
-- were avoided
-- you could then also use this to check for consistency of new instances
+
+-- selfImprove is really just doing a cartesian product of all the fds
selfImprove f [] = returnTc False
selfImprove f (nfds : nfdss)
= mapTc (f nfds) nfdss `thenTc` \ changes ->
- anyTc changes `thenTc` \ changed ->
selfImprove f nfdss `thenTc` \ rest_changed ->
- returnTc (changed || rest_changed)
+ returnTc (or changes || rest_changed)
pairImprove (free1, n1, fds1) (free2, n2, fds2)
= if n1 == n2 then
mapTc zonkTcType ts2 `thenTc` \ ts2' ->
-- pprTrace "zMT" (ppr (ts1', free, ts2')) $
case unifyTyListsX free ts2' ts1' of
- Just subst {- (subst, []) -} -> -- pprTrace "zMT match!" empty $
- returnTc (Just subst)
- Nothing -> returnTc Nothing
-\end{code}
-
-Utilities:
-
-A monadic version of the standard Prelude `or' function.
-\begin{code}
-anyTc bs = foldrTc (\a b -> returnTc (a || b)) False bs
+ Just subst -> returnTc (Just subst)
+ Nothing -> returnTc Nothing
\end{code}
import TcBinds ( tcSpecSigs )
import TcClassDcl ( tcMethodBind, checkFromThisClass )
import TcMonad
-import RnMonad ( RnNameSupply, Fixities )
+import RnMonad ( RnNameSupply, FixityEnv )
import Inst ( Inst, InstOrigin(..),
newDicts, newClassDicts,
LIE, emptyLIE, plusLIE, plusLIEs )
import VarSet ( mkVarSet, varSetElems )
import TysPrim ( byteArrayPrimTyCon, mutableByteArrayPrimTyCon )
import TysWiredIn ( stringTy, isFFIArgumentTy, isFFIResultTy )
-import Unique ( Unique, cCallableClassKey, cReturnableClassKey, Uniquable(..) )
+import Unique ( Unique, cCallableClassKey, cReturnableClassKey, hasKey, Uniquable(..) )
import Outputable
\end{code}
tcInstDecls1 :: ValueEnv -- Contains IdInfo for dfun ids
-> [RenamedHsDecl]
-> ModuleName -- module name for deriving
- -> Fixities
+ -> FixityEnv
-> RnNameSupply -- for renaming derivings
-> TcM s (Bag InstInfo,
RenamedHsBinds)
| -- CCALL CHECK
-- A user declaration of a CCallable/CReturnable instance
-- must be for a "boxed primitive" type.
- (getUnique clas == cCallableClassKey && not (ccallable_type first_inst_tau)) ||
- (getUnique clas == cReturnableClassKey && not (creturnable_type first_inst_tau))
+ (clas `hasKey` cCallableClassKey && not (ccallable_type first_inst_tau)) ||
+ (clas `hasKey` cReturnableClassKey && not (creturnable_type first_inst_tau))
= addErrTc (nonBoxedPrimCCallErr clas first_inst_tau)
-- DERIVING CHECK
import CmdLineOpts ( opt_D_dump_tc, opt_D_dump_types, opt_PprStyle_Debug )
import HsSyn ( HsModule(..), HsBinds(..), MonoBinds(..), HsDecl(..) )
+import HsTypes ( toHsType )
import RnHsSyn ( RenamedHsModule )
import TcHsSyn ( TcMonoBinds, TypecheckedMonoBinds,
TypecheckedForeignDecl, TypecheckedRuleDecl,
import TcClassDcl ( tcClassDecls2, mkImplicitClassBinds )
import TcDefaults ( tcDefaults )
import TcEnv ( tcExtendGlobalValEnv, tcExtendTypeEnv,
- getEnvTyCons, getEnvClasses, tcLookupValueMaybe,
+ getEnvTyCons, getEnvClasses, tcLookupValueByKeyMaybe,
explicitLookupValueByKey, tcSetValueEnv,
- tcLookupTyCon, initEnv, valueEnvIds,
+ initEnv,
ValueEnv, TcTyThing(..)
)
import TcExpr ( tcId )
newTyVarTy
)
-import RnMonad ( RnNameSupply, getIfaceFixities, Fixities, InterfaceDetails )
+import RnMonad ( RnNameSupply, FixityEnv )
import Bag ( isEmptyBag )
import ErrUtils ( Message, printErrorsAndWarnings, dumpIfSet )
-import Id ( Id, idType )
+import Id ( Id, idType, idName )
import Module ( pprModuleName )
import OccName ( isSysOcc )
import Name ( Name, nameUnique, nameOccName, isLocallyDefined,
- toRdrName, NamedThing(..)
+ toRdrName, nameEnvElts, NamedThing(..)
)
import TyCon ( TyCon, tyConKind )
import Class ( Class, classSelIds, classTyCon )
import Type ( mkTyConApp, mkForAllTy,
boxedTypeKind, getTyVar, Type )
import TysWiredIn ( unitTy )
-import PrelMods ( mAIN_Name )
-import PrelInfo ( main_NAME, thinAirIdNames, setThinAirIds )
+import PrelInfo ( mAIN_Name )
import TcUnify ( unifyTauTy )
-import Unique ( Unique )
+import Unique ( Unique, mainKey )
import UniqSupply ( UniqSupply )
import Maybes ( maybeToBool )
import Util
tc_insts :: Bag InstInfo, -- Instance declaration information
tc_fords :: [TypecheckedForeignDecl], -- Foreign import & exports.
tc_rules :: [TypecheckedRuleDecl], -- Transformation rules
- tc_env :: ValueEnv,
- tc_thinair :: [Id] -- The thin-air Ids
+ tc_env :: ValueEnv
}
---------------
typecheckModule
:: UniqSupply
-> RnNameSupply
- -> InterfaceDetails
+ -> FixityEnv
-> RenamedHsModule
-> IO (Maybe TcResults)
-typecheckModule us rn_name_supply iface_det mod
- = initTc us initEnv (tcModule rn_name_supply (getIfaceFixities iface_det) mod)
- >>= \ (maybe_result, warns, errs) ->
+typecheckModule us rn_name_supply fixity_env mod
+ = initTc us initEnv (tcModule rn_name_supply fixity_env mod) >>= \ (maybe_result, warns, errs) ->
printErrorsAndWarnings errs warns >>
-
- -- write the thin-air Id map
- (case maybe_result of
- Just results -> setThinAirIds (tc_thinair results)
- Nothing -> return ()
- ) >>
-
+
(case maybe_result of
Nothing -> return ()
- Just results -> dumpIfSet opt_D_dump_tc "Typechecked" (dump_tc results)
+ Just results -> dumpIfSet opt_D_dump_types "Type signatures" (dump_sigs results) >>
+ dumpIfSet opt_D_dump_tc "Typechecked" (dump_tc results)
) >>
return (if isEmptyBag errs then
dump_tc results
= ppr (tc_binds results) $$ pp_rules (tc_rules results)
+dump_sigs results -- Print type signatures
+ = -- Convert to HsType so that we get source-language style printing
+ -- And sort by RdrName
+ vcat $ map ppr_sig $ sortLt lt_sig $
+ [(toRdrName id, toHsType (idType id)) | id <- nameEnvElts (tc_env results),
+ want_sig id
+ ]
+ where
+ lt_sig (n1,_) (n2,_) = n1 < n2
+ ppr_sig (n,t) = ppr n <+> dcolon <+> ppr t
+
+ want_sig id | opt_PprStyle_Debug = True
+ | otherwise = isLocallyDefined n && not (isSysOcc (nameOccName n))
+ where
+ n = idName id
+
pp_rules [] = empty
pp_rules rs = vcat [ptext SLIT("{-# RULES"),
nest 4 (vcat (map ppr rs)),
The internal monster:
\begin{code}
tcModule :: RnNameSupply -- for renaming derivings
- -> Fixities -- needed for Show/Read derivings.
+ -> FixityEnv -- needed for Show/Read derivings.
-> RenamedHsModule -- input
-> TcM s TcResults -- output
tcModule rn_name_supply fixities
- (HsModule mod_name verion exports imports decls _ src_loc)
+ (HsModule mod_name _ _ _ decls _ src_loc)
= tcAddSrcLoc src_loc $ -- record where we're starting
fixTc (\ ~(unf_env ,_) ->
) `thenTc` \ (_, env, inst_info, deriv_binds) ->
tcSetEnv env (
+ let
+ tycons = getEnvTyCons env
+ classes = getEnvClasses env
+ local_tycons = filter isLocallyDefined tycons
+ local_classes = filter isLocallyDefined classes
+ in
-- Default declarations
tcDefaults decls `thenTc` \ defaulting_tys ->
tcSetDefaultTys defaulting_tys $
+ -- Extend the TyCon envt with the tycons corresponding to
+ -- the classes.
+ -- They are mentioned in types in interface files.
+ tcExtendTypeEnv [ (getName tycon, (kindToTcKind (tyConKind tycon), ADataTyCon tycon))
+ | clas <- classes,
+ let tycon = classTyCon clas
+ ] $
+
+ -- Interface type signatures
+ -- We tie a knot so that the Ids read out of interfaces are in scope
+ -- when we read their pragmas.
+ -- What we rely on is that pragmas are typechecked lazily; if
+ -- any type errors are found (ie there's an inconsistency)
+ -- we silently discard the pragma
+ -- We must do this before mkImplicitDataBinds (which comes next), since
+ -- the latter looks up unpackCStringId, for example, which is usually
+ -- imported
+ tcInterfaceSigs unf_env decls `thenTc` \ sig_ids ->
+ tcExtendGlobalValEnv sig_ids $
+
-- Create any necessary record selector Ids and their bindings
-- "Necessary" includes data and newtype declarations
-- We don't create bindings for dictionary constructors;
-- they are always fully applied, and the bindings are just there
-- to support partial applications
- let
- tycons = getEnvTyCons env
- classes = getEnvClasses env
- local_tycons = filter isLocallyDefined tycons
- local_classes = filter isLocallyDefined classes
- in
mkImplicitDataBinds tycons `thenTc` \ (data_ids, imp_data_binds) ->
mkImplicitClassBinds classes `thenNF_Tc` \ (cls_ids, imp_cls_binds) ->
tcExtendGlobalValEnv data_ids $
tcExtendGlobalValEnv cls_ids $
- -- Extend the TyCon envt with the tycons corresponding to
- -- the classes.
- -- They are mentioned in types in interface files.
- tcExtendTypeEnv [ (getName tycon, (kindToTcKind (tyConKind tycon), Nothing, ATyCon tycon))
- | clas <- classes,
- let tycon = classTyCon clas
- ] $
-
- -- Interface type signatures
- -- We tie a knot so that the Ids read out of interfaces are in scope
- -- when we read their pragmas.
- -- What we rely on is that pragmas are typechecked lazily; if
- -- any type errors are found (ie there's an inconsistency)
- -- we silently discard the pragma
- tcInterfaceSigs unf_env decls `thenTc` \ sig_ids ->
- tcExtendGlobalValEnv sig_ids $
-
-- foreign import declarations next.
tcForeignImports decls `thenTc` \ (fo_ids, foi_decls) ->
tcExtendGlobalValEnv fo_ids $
-- Check that Main defines main
(if mod_name == mAIN_Name then
- tcLookupValueMaybe main_NAME `thenNF_Tc` \ maybe_main ->
+ tcLookupValueByKeyMaybe mainKey `thenNF_Tc` \ maybe_main ->
checkTc (maybeToBool maybe_main) noMainErr
else
returnTc ()
zonkForeignExports foe_decls `thenNF_Tc` \ foe_decls' ->
zonkRules rules `thenNF_Tc` \ rules' ->
- let
- thin_air_ids = map (explicitLookupValueByKey really_final_env . nameUnique) thinAirIdNames
- -- When looking up the thin-air names we must use
- -- a global env that includes the zonked locally-defined Ids too
- -- Hence using really_final_env
- in
returnTc (really_final_env,
(TcResults { tc_binds = all_binds',
tc_tycons = local_tycons,
tc_insts = inst_info,
tc_fords = foi_decls ++ foe_decls',
tc_rules = rules',
- tc_env = really_final_env,
- tc_thinair = thin_air_ids
+ tc_env = really_final_env
}))
)
\begin{code}
noMainErr
= hsep [ptext SLIT("Module"), quotes (pprModuleName mAIN_Name),
- ptext SLIT("must include a definition for"), quotes (ppr main_NAME)]
+ ptext SLIT("must include a definition for"), quotes (ptext SLIT("main"))]
\end{code}
#include "HsVersions.h"
-import HsSyn ( HsType(..), HsTyVar(..), MonoUsageAnn(..),
- Sig(..), HsPred(..), pprHsPred, pprParendHsType )
+import HsSyn ( HsType(..), HsTyVarBndr(..), HsUsageAnn(..),
+ Sig(..), HsPred(..), pprParendHsType, HsTupCon(..) )
import RnHsSyn ( RenamedHsType, RenamedContext, RenamedSig )
import TcHsSyn ( TcId )
import VarSet
import Bag ( bagToList )
import ErrUtils ( Message )
-import PrelInfo ( cCallishClassKeys )
import TyCon ( TyCon )
import Name ( Name, OccName, isLocallyDefined )
-import TysWiredIn ( mkListTy, mkTupleTy, mkUnboxedTupleTy )
+import TysWiredIn ( mkListTy, mkTupleTy )
import UniqFM ( elemUFM, foldUFM )
+import BasicTypes ( Boxity(..) )
import SrcLoc ( SrcLoc )
import Unique ( Unique, Uniquable(..) )
-import Util ( mapAccumL, isSingleton )
+import Util ( mapAccumL, isSingleton, removeDups )
import Outputable
\end{code}
returnTc tc_ty
tc_type_kind :: RenamedHsType -> TcM s (TcKind, Type)
-tc_type_kind ty@(MonoTyVar name)
+tc_type_kind ty@(HsTyVar name)
= tc_app ty []
-tc_type_kind (MonoListTy ty)
+tc_type_kind (HsListTy ty)
= tc_boxed_type ty `thenTc` \ tau_ty ->
returnTc (boxedTypeKind, mkListTy tau_ty)
-tc_type_kind (MonoTupleTy tys True {-boxed-})
+tc_type_kind (HsTupleTy (HsTupCon _ Boxed) tys)
= mapTc tc_boxed_type tys `thenTc` \ tau_tys ->
- returnTc (boxedTypeKind, mkTupleTy (length tys) tau_tys)
+ returnTc (boxedTypeKind, mkTupleTy Boxed (length tys) tau_tys)
-tc_type_kind (MonoTupleTy tys False {-unboxed-})
+tc_type_kind (HsTupleTy (HsTupCon _ Unboxed) tys)
= mapTc tc_type tys `thenTc` \ tau_tys ->
- returnTc (unboxedTypeKind, mkUnboxedTupleTy (length tys) tau_tys)
+ returnTc (unboxedTypeKind, mkTupleTy Unboxed (length tys) tau_tys)
-tc_type_kind (MonoFunTy ty1 ty2)
+tc_type_kind (HsFunTy ty1 ty2)
= tc_type ty1 `thenTc` \ tau_ty1 ->
tc_type ty2 `thenTc` \ tau_ty2 ->
returnTc (boxedTypeKind, mkFunTy tau_ty1 tau_ty2)
-tc_type_kind (MonoTyApp ty1 ty2)
+tc_type_kind (HsAppTy ty1 ty2)
= tc_app ty1 [ty2]
-tc_type_kind (MonoIParamTy n ty)
- = tc_type ty `thenTc` \ tau ->
- returnTc (boxedTypeKind, mkPredTy (IParam n tau))
+tc_type_kind (HsPredTy pred)
+ = tcClassAssertion True pred `thenTc` \ pred' ->
+ returnTc (boxedTypeKind, mkPredTy pred')
-tc_type_kind (MonoDictTy class_name tys)
- = tcClassAssertion (HsPClass class_name tys) `thenTc` \ (Class clas arg_tys) ->
- returnTc (boxedTypeKind, mkDictTy clas arg_tys)
-
-tc_type_kind (MonoUsgTy usg ty)
+tc_type_kind (HsUsgTy usg ty)
= newUsg usg `thenTc` \ usg' ->
tc_type_kind ty `thenTc` \ (kind, tc_ty) ->
returnTc (kind, mkUsgTy usg' tc_ty)
where
newUsg usg = case usg of
- MonoUsOnce -> returnTc UsOnce
- MonoUsMany -> returnTc UsMany
- MonoUsVar uv_name -> tcLookupUVar uv_name `thenTc` \ uv ->
+ HsUsOnce -> returnTc UsOnce
+ HsUsMany -> returnTc UsMany
+ HsUsVar uv_name -> tcLookupUVar uv_name `thenTc` \ uv ->
returnTc (UsVar uv)
-tc_type_kind (MonoUsgForAllTy uv_name ty)
+tc_type_kind (HsUsgForAllTy uv_name ty)
= let
uv = mkNamedUVar uv_name
in
-- f :: forall a. Num a => (# a->a, a->a #)
-- And we want these to get through the type checker
check ct@(Class c tys) | ambiguous = failWithTc (ambigErr (c,tys) tau)
- where ct_vars = tyVarsOfTypes tys
+ where ct_vars = tyVarsOfTypes tys
forall_tyvars = map varName in_scope_vars
- tau_vars = tyVarsOfType tau
- ambig ct_var = (varName ct_var `elem` forall_tyvars) &&
- not (ct_var `elemUFM` tau_vars)
- ambiguous = foldUFM ((||) . ambig) False ct_vars
+ tau_vars = tyVarsOfType tau
+ ambig ct_var = (varName ct_var `elem` forall_tyvars) &&
+ not (ct_var `elemUFM` tau_vars)
+ ambiguous = foldUFM ((||) . ambig) False ct_vars
check _ = returnTc ()
in
mapTc check theta `thenTc_`
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
-tc_app (MonoTyApp ty1 ty2) tys
+tc_app (HsAppTy ty1 ty2) tys
= tc_app ty1 (ty2:tys)
tc_app ty tys
-- But not quite; for synonyms it checks the correct arity, and builds a SynTy
-- hence the rather strange functionality.
-tc_fun_type (MonoTyVar name) arg_tys
- = tcLookupTy name `thenTc` \ (tycon_kind, maybe_arity, thing) ->
+tc_fun_type (HsTyVar name) arg_tys
+ = tcLookupTy name `thenTc` \ (tycon_kind, thing) ->
case thing of
- ATyVar tv -> returnTc (tycon_kind, mkAppTys (mkTyVarTy tv) arg_tys)
- AClass clas -> failWithTc (classAsTyConErr name)
- ATyCon tc -> case maybe_arity of
- Nothing -> -- Data or newtype
- returnTc (tycon_kind, mkTyConApp tc arg_tys)
+ ATyVar tv -> returnTc (tycon_kind, mkAppTys (mkTyVarTy tv) arg_tys)
+ AClass clas _ -> failWithTc (classAsTyConErr name)
+
+ ADataTyCon tc -> -- Data or newtype
+ returnTc (tycon_kind, mkTyConApp tc arg_tys)
- Just arity -> -- Type synonym
+ ASynTyCon tc arity -> -- Type synonym
checkTc (arity <= n_args) err_msg `thenTc_`
returnTc (tycon_kind, result_ty)
where
\begin{code}
tcContext :: RenamedContext -> TcM s ThetaType
-tcContext context
- = --Someone discovered that @CCallable@ and @CReturnable@
- -- could be used in contexts such as:
- -- foo :: CCallable a => a -> PrimIO Int
- -- Doing this utterly wrecks the whole point of introducing these
- -- classes so we specifically check that this isn't being done.
- --
- -- We *don't* do this check in tcClassAssertion, because that's
- -- called when checking a HsDictTy, and we don't want to reject
- -- instance CCallable Int
- -- etc. Ugh!
- mapTc check_naughty context `thenTc_`
-
- mapTc tcClassAssertion context
-
- where
- check_naughty (HsPClass class_name _)
- = checkTc (not (getUnique class_name `elem` cCallishClassKeys))
- (naughtyCCallContextErr class_name)
- check_naughty (HsPIParam _ _) = returnTc ()
-
-tcClassAssertion assn@(HsPClass class_name tys)
- = tcAddErrCtxt (appKindCtxt (pprHsPred assn)) $
- mapAndUnzipTc tc_type_kind tys `thenTc` \ (arg_kinds, arg_tys) ->
- tcLookupTy class_name `thenTc` \ (kind, ~(Just arity), thing) ->
+tcContext context = mapTc (tcClassAssertion False) context
+
+tcClassAssertion ccall_ok assn@(HsPClass class_name tys)
+ = tcAddErrCtxt (appKindCtxt (ppr assn)) $
+ mapAndUnzipTc tc_type_kind tys `thenTc` \ (arg_kinds, arg_tys) ->
+ tcLookupTy class_name `thenTc` \ (kind, thing) ->
case thing of
- ATyVar _ -> failWithTc (tyVarAsClassErr class_name)
- ATyCon _ -> failWithTc (tyConAsClassErr class_name)
- AClass clas ->
+ AClass clas arity ->
-- Check with kind mis-match
checkTc (arity == n_tys) err `thenTc_`
unifyKind kind (mkArrowKinds arg_kinds boxedTypeKind) `thenTc_`
where
n_tys = length tys
err = arityErr "Class" class_name arity n_tys
-tcClassAssertion assn@(HsPIParam name ty)
- = tcAddErrCtxt (appKindCtxt (pprHsPred assn)) $
+ other -> failWithTc (tyVarAsClassErr class_name)
+
+tcClassAssertion ccall_ok assn@(HsPIParam name ty)
+ = tcAddErrCtxt (appKindCtxt (ppr assn)) $
tc_type_kind ty `thenTc` \ (arg_kind, arg_ty) ->
returnTc (IParam name arg_ty)
\end{code}
%************************************************************************
\begin{code}
-tcExtendTopTyVarScope :: TcKind -> [HsTyVar Name]
+tcExtendTopTyVarScope :: TcKind -> [HsTyVarBndr Name]
-> ([TcTyVar] -> TcKind -> TcM s a)
-> TcM s a
tcExtendTopTyVarScope kind tyvar_names thing_inside
mk_tv (IfaceTyVar name _, kind) = mkTyVar name kind
-- NB: immutable tyvars, but perhaps with mutable kinds
-tcExtendTyVarScope :: [HsTyVar Name]
+tcExtendTyVarScope :: [HsTyVarBndr Name]
-> ([TcTyVar] -> TcM s a) -> TcM s a
tcExtendTyVarScope tv_names thing_inside
= mapNF_Tc tcHsTyVar tv_names `thenNF_Tc` \ tyvars ->
tcExtendTyVarEnv tyvars $
thing_inside tyvars
-tcHsTyVar :: HsTyVar Name -> NF_TcM s TcTyVar
+tcHsTyVar :: HsTyVarBndr Name -> NF_TcM s TcTyVar
tcHsTyVar (UserTyVar name) = newKindVar `thenNF_Tc` \ kind ->
tcNewMutTyVar name kind
-- NB: mutable kind => mutable tyvar, so that zonking can bind
tcHsTyVar (IfaceTyVar name kind) = returnNF_Tc (mkTyVar name (kindToTcKind kind))
-kcHsTyVar :: HsTyVar name -> NF_TcM s TcKind
+kcHsTyVar :: HsTyVarBndr name -> NF_TcM s TcKind
kcHsTyVar (UserTyVar name) = newKindVar
kcHsTyVar (IfaceTyVar name kind) = returnNF_Tc (kindToTcKind kind)
\end{code}
%************************************************************************
\begin{code}
-naughtyCCallContextErr clas_name
- = sep [ptext SLIT("Can't use class") <+> quotes (ppr clas_name),
- ptext SLIT("in a context")]
-
typeCtxt ty = ptext SLIT("In the type") <+> quotes (ppr ty)
typeKindCtxt :: RenamedHsType -> Message
ambigErr (c, ts) ty
= sep [ptext SLIT("Ambiguous constraint") <+> quotes (pprConstraint c ts),
nest 4 (ptext SLIT("for the type:") <+> ppr ty),
- nest 4 (ptext SLIT("Each forall'd type variable mentioned by the constraint must appear after the =>."))]
+ nest 4 (ptext SLIT("Each forall'd type variable mentioned by the constraint must appear after the =>"))]
\end{code}
)
import TcType ( TcType, TcTyVar, tcInstTyVars, newTyVarTy )
import TcMonoType ( tcHsSigType )
-import TcUnify ( unifyTauTy, unifyListTy,
- unifyTupleTy, unifyUnboxedTupleTy
- )
+import TcUnify ( unifyTauTy, unifyListTy, unifyTupleTy )
-import Bag ( Bag )
import CmdLineOpts ( opt_IrrefutableTuples )
import DataCon ( DataCon, dataConSig, dataConFieldLabels,
dataConSourceArity
import Unique ( eqClassOpKey, geClassOpKey, minusClassOpKey,
cCallableClassKey
)
+import BasicTypes ( isBoxed )
import Bag
import Util ( zipEqual )
import Outputable
tcPats tc_bndr pats (repeat elem_ty) `thenTc` \ (pats', lie_req, tvs, ids, lie_avail) ->
returnTc (ListPat elem_ty pats', lie_req, tvs, ids, lie_avail)
-tcPat tc_bndr pat_in@(TuplePatIn pats boxed) pat_ty
+tcPat tc_bndr pat_in@(TuplePatIn pats boxity) pat_ty
= tcAddErrCtxt (patCtxt pat_in) $
- (if boxed
- then unifyTupleTy arity pat_ty
- else unifyUnboxedTupleTy arity pat_ty) `thenTc` \ arg_tys ->
-
- tcPats tc_bndr pats arg_tys `thenTc` \ (pats', lie_req, tvs, ids, lie_avail) ->
+ unifyTupleTy boxity arity pat_ty `thenTc` \ arg_tys ->
+ tcPats tc_bndr pats arg_tys `thenTc` \ (pats', lie_req, tvs, ids, lie_avail) ->
-- possibly do the "make all tuple-pats irrefutable" test:
let
- unmangled_result = TuplePat pats' boxed
+ unmangled_result = TuplePat pats' boxity
-- Under flag control turn a pattern (x,y,z) into ~(x,y,z)
-- so that we can experiment with lazy tuple-matching.
-- it was easy to do.
possibly_mangled_result
- | opt_IrrefutableTuples && boxed = LazyPat unmangled_result
- | otherwise = unmangled_result
+ | opt_IrrefutableTuples && isBoxed boxity = LazyPat unmangled_result
+ | otherwise = unmangled_result
in
returnTc (possibly_mangled_result, lie_req, tvs, ids, lie_avail)
where
#include "HsVersions.h"
-import HsSyn ( HsDecl(..), RuleDecl(..), RuleBndr(..), HsTyVar(..) )
-import HsCore ( UfRuleBody(..) )
+import HsSyn ( HsDecl(..), RuleDecl(..), RuleBndr(..), HsTyVarBndr(..) )
+import CoreSyn ( CoreRule(..) )
import RnHsSyn ( RenamedHsDecl )
import TcHsSyn ( TypecheckedRuleDecl, mkHsLet )
import TcMonad
tcRules decls = mapAndUnzipTc tcRule [rule | RuleD rule <- decls] `thenTc` \ (lies, rules) ->
returnTc (plusLIEs lies, rules)
-tcRule (IfaceRuleDecl fun (UfRuleBody name vars args rhs) src_loc)
+tcRule (IfaceRule name vars fun args rhs src_loc)
= tcAddSrcLoc src_loc $
tcAddErrCtxt (ruleCtxt name) $
tcVar fun `thenTc` \ fun' ->
tcCoreLamBndrs vars $ \ vars' ->
mapTc tcCoreExpr args `thenTc` \ args' ->
tcCoreExpr rhs `thenTc` \ rhs' ->
- returnTc (emptyLIE, IfaceRuleDecl fun' (CoreRuleBody name vars' args' rhs') src_loc)
+ returnTc (emptyLIE, IfaceRuleOut fun' (Rule name vars' args' rhs'))
-tcRule (RuleDecl name sig_tvs vars lhs rhs src_loc)
+tcRule (IfaceRuleOut fun rule)
+ = tcVar fun `thenTc` \ fun' ->
+ returnTc (emptyLIE, IfaceRuleOut fun' rule)
+
+tcRule (HsRule name sig_tvs vars lhs rhs src_loc)
= tcAddSrcLoc src_loc $
tcAddErrCtxt (ruleCtxt name) $
newTyVarTy_OpenKind `thenNF_Tc` \ rule_ty ->
tcSimplifyAndCheck (text "tcRule") tpl_tvs
lhs_dicts rhs_lie `thenTc` \ (lie', rhs_binds) ->
- returnTc (lie', RuleDecl name (varSetElems tpl_tvs)
+ returnTc (lie', HsRule name (varSetElems tpl_tvs)
(map RuleBndr tpl_ids) -- yuk
(mkHsLet lhs_binds lhs')
(mkHsLet rhs_binds rhs')
#include "HsVersions.h"
import HsSyn ( HsDecl(..), TyClDecl(..),
- HsType(..), HsTyVar,
+ HsType(..), HsTyVarBndr,
ConDecl(..), ConDetails(..), BangType(..),
- Sig(..), HsPred(..),
+ Sig(..), HsPred(..), HsTupCon(..),
tyClDeclName, isClassDecl, isSynDecl
)
-import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, listTyCon_name, tupleTyCon_name )
+import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, listTyCon_name )
import BasicTypes ( RecFlag(..), NewOrData(..), Arity )
import TcMonad
import Inst ( InstanceMapper )
import TcClassDcl ( kcClassDecl, tcClassDecl1 )
import TcEnv ( ValueEnv, TcTyThing(..),
- tcExtendTypeEnv, getAllEnvTyCons
+ tcExtendTypeEnv, getEnvAllTyCons
)
import TcTyDecls ( tcTyDecl, kcTyDecl )
import TcMonoType ( kcHsTyVar )
-- Tie the knot
-- traceTc (ppr (map fst ty_env_stuff1)) `thenTc_`
- fixTc ( \ ~(rec_tyclss, rec_vrcs, _) ->
+ fixTc ( \ ~(rec_tyclss, _) ->
let
- rec_env = listToUFM rec_tyclss
+ rec_env = listToUFM rec_tyclss
+ rec_tycons = getEnvAllTyCons rec_tyclss
+ rec_vrcs = calcTyConArgVrcs rec_tycons
in
-- Do type checking
`thenTc` \ tyclss ->
tcGetEnv `thenTc` \ env ->
- let
- tycons = getAllEnvTyCons env
- vrcs = calcTyConArgVrcs tycons
- in
-
- returnTc (tyclss, vrcs, env)
- ) `thenTc` \ (_, _, env) ->
+ returnTc (tyclss, env)
+ ) `thenTc` \ (_, env) ->
-- traceTc (text "done" <+> ppr (map fst ty_env_stuff1)) `thenTc_`
returnTc env
where
tcDecl is_rec_group unf_env inst_mapper vrcs_env decl
= tcAddDeclCtxt decl $
if isClassDecl decl then
- tcClassDecl1 unf_env inst_mapper vrcs_env decl `thenTc` \ clas ->
- returnTc (getName clas, AClass clas)
+ tcClassDecl1 unf_env inst_mapper vrcs_env decl
else
- tcTyDecl is_rec_group vrcs_env decl `thenTc` \ tycon ->
- returnTc (getName tycon, ATyCon tycon)
+ tcTyDecl is_rec_group vrcs_env decl
tcAddDeclCtxt decl thing_inside
(name, loc, thing)
= case decl of
(ClassDecl _ name _ _ _ _ _ _ _ _ _ loc) -> (name, loc, "class")
- (TySynonym name _ _ loc) -> (name, loc, "type synonym")
- (TyData NewType _ name _ _ _ _ loc) -> (name, loc, "data type")
- (TyData DataType _ name _ _ _ _ loc) -> (name, loc, "newtype")
+ (TySynonym name _ _ loc) -> (name, loc, "type synonym")
+ (TyData NewType _ name _ _ _ _ _ loc) -> (name, loc, "data type")
+ (TyData DataType _ name _ _ _ _ _ loc) -> (name, loc, "newtype")
ctxt = hsep [ptext SLIT("In the"), text thing,
ptext SLIT("declaration for"), quotes (ppr name)]
Why do we need to grab all these type variables at once, including
those locally-quantified type variables in class op signatures?
- [Incidentally, this only works because the names are all unique by now.]
+ [Incidentally, this only works because the names are all unique by now.]
Because we can only commit to the final kind of a type variable when
we've completed the mutually recursive group. For example:
depends on *all the uses of class D*. For example, the use of
Monad c in bop's type signature means that D must have kind Type->Type.
+ [April 00: looks as if we've dropped this subtlety; I'm not sure when]
\begin{code}
-getTyBinding1 :: RenamedTyClDecl -> NF_TcM s (Name, (TcKind, Maybe Arity, TcTyThing))
+getTyBinding1 :: RenamedTyClDecl -> NF_TcM s (Name, (TcKind, TcTyThing))
getTyBinding1 (TySynonym name tyvars _ _)
= mapNF_Tc kcHsTyVar tyvars `thenNF_Tc` \ arg_kinds ->
newKindVar `thenNF_Tc` \ result_kind ->
returnNF_Tc (name, (foldr mkArrowKind result_kind arg_kinds,
- Just (length tyvars),
- ATyCon (pprPanic "ATyCon: syn" (ppr name))))
+ ASynTyCon (pprPanic "ATyCon: syn" (ppr name)) (length tyvars)))
-getTyBinding1 (TyData _ _ name tyvars _ _ _ _)
+getTyBinding1 (TyData _ _ name tyvars _ _ _ _ _)
= mapNF_Tc kcHsTyVar tyvars `thenNF_Tc` \ arg_kinds ->
returnNF_Tc (name, (foldr mkArrowKind boxedTypeKind arg_kinds,
- Nothing,
- ATyCon (error "ATyCon: data")))
+ ADataTyCon (error "ATyCon: data")))
getTyBinding1 (ClassDecl _ name tyvars _ _ _ _ _ _ _ _ _)
= mapNF_Tc kcHsTyVar tyvars `thenNF_Tc` \ arg_kinds ->
returnNF_Tc (name, (foldr mkArrowKind boxedTypeKind arg_kinds,
- Just (length tyvars),
- AClass (error "AClass")))
+ AClass (pprPanic "AClass" (ppr name)) (length tyvars)))
-- Zonk the kind to its final form, and lookup the
-- recursive tycon/class
-getTyBinding2 rec_env (name, (tc_kind, maybe_arity, thing))
+getTyBinding2 rec_env (name, (tc_kind, thing))
= zonkTcKindToKind tc_kind `thenNF_Tc` \ kind ->
- returnNF_Tc (name, (kind, maybe_arity, mk_thing thing (lookupUFM rec_env name)))
+ returnNF_Tc (name, (kind, mk_thing thing (lookupUFM rec_env name)))
where
- mk_thing (ATyCon _) ~(Just (ATyCon tc)) = ATyCon tc
- mk_thing (AClass _) ~(Just (AClass cls)) = AClass cls
+ mk_thing (ADataTyCon _) ~(Just (ADataTyCon tc)) = ADataTyCon tc
+ mk_thing (ASynTyCon _ arity) ~(Just (ASynTyCon tc _)) = ASynTyCon tc arity
+ mk_thing (AClass _ arity) ~(Just (AClass cls _)) = AClass cls arity
\end{code}
----------------------------------------------------
mk_edges :: RenamedTyClDecl -> (RenamedTyClDecl, Unique, [Unique])
-mk_edges decl@(TyData _ ctxt name _ condecls derivs _ _)
+mk_edges decl@(TyData _ ctxt name _ condecls _ derivs _ _)
= (decl, getUnique name, uniqSetToList (get_ctxt ctxt `unionUniqSets`
get_cons condecls `unionUniqSets`
get_deriv derivs))
get_bty (Unpacked ty) = get_ty ty
----------------------------------------------------
-get_ty (MonoTyVar name)
- = if isTvOcc (nameOccName name) then emptyUniqSet else set_name name
-get_ty (MonoTyApp ty1 ty2)
- = unionUniqSets (get_ty ty1) (get_ty ty2)
-get_ty (MonoFunTy ty1 ty2)
- = unionUniqSets (get_ty ty1) (get_ty ty2)
-get_ty (MonoListTy ty)
- = set_name listTyCon_name `unionUniqSets` get_ty ty
-get_ty (MonoTupleTy tys boxed)
- = set_name (tupleTyCon_name boxed (length tys)) `unionUniqSets` get_tys tys
-get_ty (MonoUsgTy _ ty)
- = get_ty ty
-get_ty (MonoUsgForAllTy _ ty)
- = get_ty ty
-get_ty (HsForAllTy _ ctxt mty)
- = get_ctxt ctxt `unionUniqSets` get_ty mty
-get_ty (MonoDictTy name _)
- = set_name name
-get_ty (MonoIParamTy name _)
- = emptyUniqSet
+get_ty (HsTyVar name) | isTvOcc (nameOccName name) = emptyUniqSet
+ | otherwise = set_name name
+get_ty (HsAppTy ty1 ty2) = unionUniqSets (get_ty ty1) (get_ty ty2)
+get_ty (HsFunTy ty1 ty2) = unionUniqSets (get_ty ty1) (get_ty ty2)
+get_ty (HsListTy ty) = set_name listTyCon_name `unionUniqSets` get_ty ty
+get_ty (HsTupleTy (HsTupCon n _) tys) = set_name n `unionUniqSets` get_tys tys
+get_ty (HsUsgTy _ ty) = get_ty ty
+get_ty (HsUsgForAllTy _ ty) = get_ty ty
+get_ty (HsForAllTy _ ctxt mty) = get_ctxt ctxt `unionUniqSets` get_ty mty
+get_ty (HsPredTy (HsPClass name _)) = set_name name
+get_ty (HsPredTy (HsPIParam _ _)) = emptyUniqSet -- I think
----------------------------------------------------
-get_tys tys
- = unionManyUniqSets (map get_ty tys)
+get_tys tys = unionManyUniqSets (map get_ty tys)
----------------------------------------------------
get_sigs sigs
tcContext, tcHsTopTypeKind
)
import TcType ( zonkTcTyVarToTyVar, zonkTcClassConstraints )
-import TcEnv ( tcLookupTy, TcTyThing(..) )
+import TcEnv ( tcLookupTy, tcLookupValueByKey, TcTyThing(..) )
import TcMonad
import TcUnify ( unifyKind )
import Name ( Name, isLocallyDefined, OccName, NamedThing(..), nameUnique )
import Outputable
import TyCon ( TyCon, AlgTyConFlavour(..), ArgVrcs, mkSynTyCon, mkAlgTyCon,
- tyConDataCons, tyConTyVars,
+ tyConDataConsIfAvailable, tyConTyVars,
isSynTyCon, isNewTyCon
)
import Type ( getTyVar, tyVarsOfTypes, splitFunTy, applyTys,
import TysWiredIn ( unitTy )
import Var ( tyVarKind )
import VarSet ( intersectVarSet, isEmptyVarSet )
+import Unique ( unpackCStringIdKey )
import Util ( equivClasses )
import FiniteMap ( FiniteMap, lookupWithDefaultFM )
import CmdLineOpts ( opt_GlasgowExts )
kcTyDecl :: RenamedTyClDecl -> TcM s ()
kcTyDecl (TySynonym name tyvar_names rhs src_loc)
- = tcLookupTy name `thenNF_Tc` \ (kind, _, _) ->
+ = tcLookupTy name `thenNF_Tc` \ (kind, _) ->
tcExtendTopTyVarScope kind tyvar_names $ \ _ result_kind ->
tcHsTypeKind rhs `thenTc` \ (rhs_kind, _) ->
unifyKind result_kind rhs_kind
-kcTyDecl (TyData _ context tycon_name tyvar_names con_decls _ _ src_loc)
- = tcLookupTy tycon_name `thenNF_Tc` \ (kind, _, _) ->
+kcTyDecl (TyData _ context tycon_name tyvar_names con_decls _ _ _ src_loc)
+ = tcLookupTy tycon_name `thenNF_Tc` \ (kind, _) ->
tcExtendTopTyVarScope kind tyvar_names $ \ result_kind _ ->
tcContext context `thenTc_`
mapTc kcConDecl con_decls `thenTc_`
%************************************************************************
\begin{code}
-tcTyDecl :: RecFlag -> FiniteMap Name ArgVrcs -> RenamedTyClDecl -> TcM s TyCon
+tcTyDecl :: RecFlag -> FiniteMap Name ArgVrcs -> RenamedTyClDecl -> TcM s (Name, TcTyThing)
tcTyDecl is_rec rec_vrcs (TySynonym tycon_name tyvar_names rhs src_loc)
- = tcLookupTy tycon_name `thenNF_Tc` \ (tycon_kind, Just arity, _) ->
+ = tcLookupTy tycon_name `thenNF_Tc` \ (tycon_kind, ASynTyCon _ arity) ->
tcExtendTopTyVarScope tycon_kind tyvar_names $ \ tyvars _ ->
tcHsTopTypeKind rhs `thenTc` \ (_, rhs_ty) ->
-- If the RHS mentions tyvars that aren't in scope, we'll
tycon_name
tycon = mkSynTyCon tycon_name tycon_kind arity tyvars rhs_ty argvrcs
in
- returnTc tycon
+ returnTc (tycon_name, ASynTyCon tycon arity)
-tcTyDecl is_rec rec_vrcs (TyData data_or_new context tycon_name tyvar_names con_decls derivings pragmas src_loc)
+tcTyDecl is_rec rec_vrcs (TyData data_or_new context tycon_name tyvar_names con_decls nconstrs derivings pragmas src_loc)
= -- Lookup the pieces
- tcLookupTy tycon_name `thenNF_Tc` \ (tycon_kind, _, ATyCon rec_tycon) ->
+ tcLookupTy tycon_name `thenNF_Tc` \ (tycon_kind, ADataTyCon rec_tycon) ->
tcExtendTopTyVarScope tycon_kind tyvar_names $ \ tyvars _ ->
-- Typecheck the pieces
tycon_name
tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt' argvrcs
- data_cons
+ data_cons nconstrs
derived_classes
flavour is_rec
in
- returnTc tycon
+ returnTc (tycon_name, ADataTyCon tycon)
where
tc_derivs Nothing = returnTc []
tc_derivs (Just ds) = mapTc tc_deriv ds
- tc_deriv name = tcLookupTy name `thenTc` \ (_, _, AClass clas) ->
+ tc_deriv name = tcLookupTy name `thenTc` \ (_, AClass clas _) ->
returnTc clas
\end{code}
in
returnTc (all_ids, binds)
where
- data_cons = tyConDataCons tycon
+ data_cons = tyConDataConsIfAvailable tycon
+ -- Abstract types mean we don't bring the
+ -- data cons into scope, which should be fine
data_con_wrapper_ids = map dataConWrapId data_cons
-- data type use the same type variables
= checkTc (all (== field_ty) other_tys)
(fieldTypeMisMatch field_name) `thenTc_`
- returnTc (mkRecordSelId tycon first_field_label)
+ tcLookupValueByKey unpackCStringIdKey `thenTc` \ unpack_id ->
+ returnTc (mkRecordSelId tycon first_field_label unpack_id)
where
field_ty = fieldLabelType first_field_label
field_name = fieldLabelName first_field_label
\begin{code}
module TcUnify ( unifyTauTy, unifyTauTyList, unifyTauTyLists,
- unifyFunTy, unifyListTy, unifyTupleTy, unifyUnboxedTupleTy,
+ unifyFunTy, unifyListTy, unifyTupleTy,
unifyKind, unifyKinds, unifyTypeKind
) where
splitAppTy_maybe,
tidyOpenType, tidyOpenTypes, tidyTyVar
)
-import TyCon ( TyCon, isTupleTyCon, isUnboxedTupleTyCon,
- tyConArity )
+import TyCon ( TyCon, isTupleTyCon, tupleTyConBoxity, tyConArity )
import Name ( hasBetterProv )
import Var ( TyVar, tyVarKind, varName, isSigTyVar )
import VarEnv
tcGetTyVar, tcPutTyVar, zonkTcType, tcTypeKind
)
-- others:
-import BasicTypes ( Arity )
-import TysWiredIn ( listTyCon, mkListTy, mkTupleTy, mkUnboxedTupleTy )
+import BasicTypes ( Arity, Boxity, isBoxed )
+import TysWiredIn ( listTyCon, mkListTy, mkTupleTy )
import PprType () -- Instances
import Util
import Outputable
\end{code}
\begin{code}
-unifyTupleTy :: Arity -> TcType -> TcM s [TcType]
-unifyTupleTy arity ty@(TyVarTy tyvar)
+unifyTupleTy :: Boxity -> Arity -> TcType -> TcM s [TcType]
+unifyTupleTy boxity arity ty@(TyVarTy tyvar)
= tcGetTyVar tyvar `thenNF_Tc` \ maybe_ty ->
case maybe_ty of
- Just ty' -> unifyTupleTy arity ty'
- other -> unify_tuple_ty_help arity ty
+ Just ty' -> unifyTupleTy boxity arity ty'
+ other -> unify_tuple_ty_help boxity arity ty
-unifyTupleTy arity ty
+unifyTupleTy boxity arity ty
= case splitTyConApp_maybe ty of
- Just (tycon, arg_tys) | isTupleTyCon tycon
- && tyConArity tycon == arity
- -> returnTc arg_tys
- other -> unify_tuple_ty_help arity ty
-
-unify_tuple_ty_help arity ty
- = mapNF_Tc (\ _ -> newTyVarTy boxedTypeKind) [1..arity] `thenNF_Tc` \ arg_tys ->
- unifyTauTy ty (mkTupleTy arity arg_tys) `thenTc_`
- returnTc arg_tys
-\end{code}
-
-\begin{code}
-unifyUnboxedTupleTy :: Arity -> TcType -> TcM s [TcType]
-unifyUnboxedTupleTy arity ty@(TyVarTy tyvar)
- = tcGetTyVar tyvar `thenNF_Tc` \ maybe_ty ->
- case maybe_ty of
- Just ty' -> unifyUnboxedTupleTy arity ty'
- other -> unify_unboxed_tuple_ty_help arity ty
-
-unifyUnboxedTupleTy arity ty
- = case splitTyConApp_maybe ty of
- Just (tycon, arg_tys) | isUnboxedTupleTyCon tycon
- && tyConArity tycon == arity
- -> returnTc arg_tys
- other -> unify_tuple_ty_help arity ty
-
-unify_unboxed_tuple_ty_help arity ty
- = mapNF_Tc (\ _ -> newTyVarTy_OpenKind) [1..arity] `thenNF_Tc` \ arg_tys ->
- unifyTauTy ty (mkUnboxedTupleTy arity arg_tys) `thenTc_`
+ Just (tycon, arg_tys)
+ | isTupleTyCon tycon
+ && tyConArity tycon == arity
+ && tupleTyConBoxity tycon == boxity
+ -> returnTc arg_tys
+ other -> unify_tuple_ty_help boxity arity ty
+
+unify_tuple_ty_help boxity arity ty
+ = mapNF_Tc new_tyvar [1..arity] `thenNF_Tc` \ arg_tys ->
+ unifyTauTy ty (mkTupleTy boxity arity arg_tys) `thenTc_`
returnTc arg_tys
+ where
+ new_tyvar _ | isBoxed boxity = newTyVarTy boxedTypeKind
+ | otherwise = newTyVarTy_OpenKind
\end{code}
Make sure a kind is of the form (Type b) for some boxity b.
\begin{code}
module Class (
- Class, ClassOpItem,
+ Class, ClassOpItem, ClassPred, ClassContext, FunDep,
mkClass, classTyVars,
classKey, className, classSelIds, classTyCon,
className :: Name,
classTyVars :: [TyVar], -- The class type variables
- classFunDeps :: [([TyVar], [TyVar])], -- The functional dependencies
+ classFunDeps :: [FunDep TyVar], -- The functional dependencies
classSCTheta :: [(Class,[Type])], -- Immediate superclasses, and the
classSCSels :: [Id], -- corresponding selector functions to
classTyCon :: TyCon -- The data type constructor for dictionaries
} -- of this class
+type ClassPred = (Class, [Type])
+type ClassContext = [ClassPred]
+
+type FunDep a = ([a],[a]) -- e.g. class C a b c | a b -> c, a c -> b where ...
+ -- Here fun-deps are [([a,b],[c]), ([a,c],[b])]
+
type ClassOpItem = (Id, -- Selector function; contains unfolding
Id, -- Default methods
Bool) -- True <=> an explicit default method was
#include "HsVersions.h"
-import Class ( classTvsFds )
-import Type ( tyVarsOfType )
-import Outputable ( interppSP, ptext, empty, hsep, punctuate, comma )
-import UniqSet ( elementOfUniqSet, addOneToUniqSet,
- uniqSetToList, unionManyUniqSets )
+import Var ( TyVar )
+import Class ( Class, FunDep, classTvsFds )
+import Type ( Type, tyVarsOfTypes )
+import Outputable ( Outputable, SDoc, interppSP, ptext, empty, hsep, punctuate, comma )
+import UniqSet
+import VarSet
+import Unique ( Uniquable )
import List ( elemIndex )
\end{code}
\begin{code}
+oclose :: Uniquable a => [FunDep a] -> UniqSet a -> UniqSet a
+-- (oclose fds tvs) closes the set of type variables tvs,
+-- wrt the functional dependencies fds. The result is a superset
+-- of the argument set.
+--
+-- For example,
+-- oclose [a -> b] {a} = {a,b}
+-- oclose [a b -> c] {a} = {a}
+-- oclose [a b -> c] {a,b} = {a,b,c}
+-- If all of the things on the left of an arrow are in the set, add
+-- the things on the right of that arrow.
+
oclose fds vs =
case oclose1 fds vs of
(vs', False) -> vs'
- (vs', True) -> oclose fds vs'
+ (vs', True) -> oclose fds vs'
oclose1 [] vs = (vs, False)
oclose1 (fd@(ls, rs):fds) vs =
osubset (u:us) vs = if u `elementOfUniqSet` vs then osubset us vs else False
ounion [] ys = (ys, False)
-ounion (x:xs) ys =
- if x `elementOfUniqSet` ys then (ys', b) else (addOneToUniqSet ys' x, True)
+ounion (x:xs) ys
+ | x `elementOfUniqSet` ys = (ys', b)
+ | otherwise = (addOneToUniqSet ys' x, True)
where
(ys', b) = ounion xs ys
-instantiateFdClassTys clas ts =
- map (lookupInstFundep tyvars ts) fundeps
- where
- (tyvars, fundeps) = classTvsFds clas
- lookupInstFundep tyvars ts (us, vs) =
- (lookupInstTys tyvars ts us, lookupInstTys tyvars ts vs)
+instantiateFdClassTys :: Class -> [a] -> [([a], [a])]
+-- Get the FDs of the class, and instantiate them
+instantiateFdClassTys clas ts
+ = map (lookupInstFundep tyvars ts) fundeps
+ where
+ (tyvars, fundeps) = classTvsFds clas
+ lookupInstFundep tyvars ts (us, vs)
+ = (lookupInstTys tyvars ts us, lookupInstTys tyvars ts vs)
+
lookupInstTys tyvars ts = map (lookupInstTy tyvars ts)
lookupInstTy tyvars ts u = ts !! i
where Just i = elemIndex u tyvars
-tyVarFunDep fdtys =
- map (\(xs, ys) -> (unionMap getTyVars xs, unionMap getTyVars ys)) fdtys
- where
- getTyVars ty = tyVarsOfType ty
- unionMap f xs = uniqSetToList (unionManyUniqSets (map f xs))
+tyVarFunDep :: [FunDep Type] -> [FunDep TyVar]
+tyVarFunDep fdtys
+ = [(varSetElems (tyVarsOfTypes xs), varSetElems (tyVarsOfTypes xs)) | (xs,ys) <- fdtys]
+pprFundeps :: Outputable a => [FunDep a] -> SDoc
pprFundeps [] = empty
pprFundeps fds = hsep (ptext SLIT("|") : punctuate comma (map ppr_fd fds))
ppr_fd (us, vs) = hsep [interppSP us, ptext SLIT("->"), interppSP vs]
-
\end{code}
ppr_ty env ctxt_prec ty@(TyConApp tycon tys)
-- KIND CASE; it's of the form (Type x)
- | tycon_uniq == typeConKey && n_tys == 1
+ | tycon `hasKey` typeConKey && n_tys == 1
= -- For kinds, print (Type x) as just x if x is a
-- type constructor (must be Boxed, Unboxed, AnyBox)
-- Otherwise print as (Type x)
= parens (char '#' <+> tys_w_commas <+> char '#')
-- LIST CASE
- | tycon_uniq == listTyConKey && n_tys == 1
+ | tycon `hasKey` listTyConKey && n_tys == 1
= brackets (ppr_ty env tOP_PREC ty1)
-- DICTIONARY CASE, prints {C a}
= maybeParen ctxt_prec tYCON_PREC (sep [ppr tycon, nest 4 tys_w_spaces])
where
- tycon_uniq = tyConUnique tycon
n_tys = length tys
(ty1:_) = tys
Just pred = maybe_pred
ppr_ty env ctxt_prec ty@(ForAllTy _ _)
= getPprStyle $ \ sty ->
maybeParen ctxt_prec fUN_PREC $
- if ifaceStyle sty then
- sep [ ptext SLIT("__forall") <+> brackets pp_tyvars <+> ptext SLIT("=>"),
- ppr_ty env tOP_PREC rho
- ]
- else
- -- The type checker occasionally prints a type in an error message,
- -- and it had better come out looking like a user type
- sep [ ptext SLIT("forall") <+> pp_tyvars <> ptext SLIT("."),
- ppr_theta theta,
- ppr_ty env tOP_PREC tau
- ]
- where
+ sep [ ptext SLIT("forall") <+> pp_tyvars <> ptext SLIT("."),
+ ppr_theta theta,
+ ppr_ty env tOP_PREC tau
+ ]
+ where
(tyvars, rho) = splitForAllTys ty -- don't treat theta specially any more (KSW 1999-04)
(theta, tau) = splitRhoTy rho
\begin{code}
pprTyVarBndr tyvar
= getPprStyle $ \ sty ->
- if (ifaceStyle sty || debugStyle sty) && kind /= boxedTypeKind then
+ if (ifaceStyle sty && kind /= boxedTypeKind) || debugStyle sty then
hsep [ppr tyvar, dcolon, pprParendKind kind]
-- See comments with ppDcolon in PprCore.lhs
else
isFunTyCon, isUnLiftedTyCon, isBoxedTyCon, isProductTyCon,
isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isPrimTyCon,
- isEnumerationTyCon, isTupleTyCon, isUnboxedTupleTyCon,
+ isEnumerationTyCon,
+ isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity,
isRecursiveTyCon, newTyConRep,
mkAlgTyCon,
tyConUnique,
tyConTyVars,
tyConArgVrcs_maybe,
- tyConDataCons,
+ tyConDataCons, tyConDataConsIfAvailable,
tyConFamilySize,
tyConDerivings,
tyConTheta,
import {-# SOURCE #-} DataCon ( DataCon, isExistentialDataCon )
-import Class ( Class )
+import Class ( Class, ClassContext )
import Var ( TyVar )
-import BasicTypes ( Arity, NewOrData(..), RecFlag(..) )
+import BasicTypes ( Arity, NewOrData(..), RecFlag(..), Boxity(..), isBoxed )
import Maybes
import Name ( Name, nameUnique, NamedThing(getName) )
import Unique ( Unique, Uniquable(..), anyBoxConKey )
tyConTyVars :: [TyVar],
tyConArgVrcs :: ArgVrcs,
- algTyConTheta :: [(Class,[Type])],
+ algTyConTheta :: ClassContext,
dataCons :: [DataCon],
-- Its data constructors, with fully polymorphic types
-- (b) in a quest for fast compilation we don't import
-- the constructors
+ noOfDataCons :: Int, -- Number of data constructors
+ -- Usually this is the same as the length of the
+ -- dataCons field, but the latter may be empty if
+ -- we imported the type abstractly. But even if we import
+ -- abstractly we still need to know the number of constructors
+ -- so we can get the return convention right. Tiresome!
+
algTyConDerivings :: [Class], -- Classes which have derived instances
algTyConFlavour :: AlgTyConFlavour,
tyConName :: Name,
tyConKind :: Kind,
tyConArity :: Arity,
- tyConBoxed :: Bool, -- True for boxed; False for unboxed
+ tyConBoxed :: Boxity,
tyConTyVars :: [TyVar],
dataCon :: DataCon
}
tyConArity = 2
}
-mkAlgTyCon name kind tyvars theta argvrcs cons derivs flavour rec
+mkAlgTyCon name kind tyvars theta argvrcs cons ncons derivs flavour rec
= AlgTyCon {
tyConName = name,
tyConUnique = nameUnique name,
tyConArgVrcs = argvrcs,
algTyConTheta = theta,
dataCons = cons,
+ noOfDataCons = ncons,
algTyConDerivings = derivs,
algTyConClass_maybe = Nothing,
algTyConFlavour = flavour,
tyConArgVrcs = argvrcs,
algTyConTheta = [],
dataCons = [con],
+ noOfDataCons = 1,
algTyConDerivings = [],
algTyConClass_maybe = Just clas,
algTyConFlavour = flavour,
isPrimTyCon _ = False
isUnLiftedTyCon (PrimTyCon {}) = True
-isUnLiftedTyCon (TupleTyCon { tyConBoxed = False }) = True
+isUnLiftedTyCon (TupleTyCon { tyConBoxed = boxity}) = not (isBoxed boxity)
isUnLiftedTyCon _ = False
-- isBoxedTyCon should not be applied to SynTyCon, nor KindCon
isBoxedTyCon (AlgTyCon {}) = True
isBoxedTyCon (FunTyCon {}) = True
-isBoxedTyCon (TupleTyCon {tyConBoxed = boxed}) = boxed
+isBoxedTyCon (TupleTyCon {tyConBoxed = boxity}) = isBoxed boxity
isBoxedTyCon (PrimTyCon {primTyConRep = rep}) = isFollowableRep rep
-- isAlgTyCon returns True for both @data@ and @newtype@
isDataTyCon (AlgTyCon {algTyConFlavour = new_or_data}) = case new_or_data of
NewTyCon _ -> False
other -> True
-isDataTyCon (TupleTyCon {tyConBoxed = True}) = True
+isDataTyCon (TupleTyCon {tyConBoxed = boxity}) = isBoxed boxity
isDataTyCon other = False
isNewTyCon (AlgTyCon {algTyConFlavour = NewTyCon _}) = True
isEnumerationTyCon (AlgTyCon {algTyConFlavour = EnumTyCon}) = True
isEnumerationTyCon other = False
--- The unit tycon isn't classed as a tuple tycon
-isTupleTyCon (TupleTyCon {tyConArity = arity, tyConBoxed = True}) = arity >= 2
-isTupleTyCon other = False
+-- The unit tycon didn't used to be classed as a tuple tycon
+-- but I thought that was silly so I've undone it
+-- If it can't be for some reason, it should be a AlgTyCon
+isTupleTyCon (TupleTyCon {}) = True
+isTupleTyCon other = False
-isUnboxedTupleTyCon (TupleTyCon {tyConBoxed = False}) = True
+isUnboxedTupleTyCon (TupleTyCon {tyConBoxed = boxity}) = not (isBoxed boxity)
isUnboxedTupleTyCon other = False
+isBoxedTupleTyCon (TupleTyCon {tyConBoxed = boxity}) = isBoxed boxity
+isBoxedTupleTyCon other = False
+
+tupleTyConBoxity tc = tyConBoxed tc
+
isRecursiveTyCon (AlgTyCon {algTyConRec = Recursive}) = True
isRecursiveTyCon other = False
\end{code}
\begin{code}
tyConDataCons :: TyCon -> [DataCon]
-tyConDataCons (AlgTyCon {dataCons = cons}) = cons
-tyConDataCons (TupleTyCon {dataCon = con}) = [con]
-tyConDataCons other = []
+tyConDataCons tycon = ASSERT2( not (null cons), ppr tycon ) cons
+ where
+ cons = tyConDataConsIfAvailable tycon
+
+tyConDataConsIfAvailable (AlgTyCon {dataCons = cons}) = cons -- Empty for abstract types
+tyConDataConsIfAvailable (TupleTyCon {dataCon = con}) = [con]
+tyConDataConsIfAvailable other = []
-- You may think this last equation should fail,
-- but it's quite convenient to return no constructors for
-- a synonym; see for example the call in TcTyClsDecls.
tyConFamilySize :: TyCon -> Int
-tyConFamilySize (AlgTyCon {dataCons = cons}) = length cons
-tyConFamilySize (TupleTyCon {}) = 1
+tyConFamilySize (AlgTyCon {noOfDataCons = n}) = n
+tyConFamilySize (TupleTyCon {}) = 1
#ifdef DEBUG
tyConFamilySize other = pprPanic "tyConFamilySize:" (ppr other)
#endif
\end{code}
\begin{code}
-tyConTheta :: TyCon -> [(Class, [Type])]
+tyConTheta :: TyCon -> ClassContext
tyConTheta (AlgTyCon {algTyConTheta = theta}) = theta
-- should ask about anything else
\end{code}
import Name ( Name, NamedThing(..), mkLocalName, tidyOccName
)
import NameSet
-import Class ( classTyCon, Class )
+import Class ( classTyCon, Class, ClassPred, ClassContext )
import TyCon ( TyCon,
isUnboxedTupleTyCon, isUnLiftedTyCon,
isFunTyCon, isDataTyCon, isNewTyCon, newTyConRep,
-- splitAlgTyConApp_maybe looks for
-- *saturated* applications of *algebraic* data types
-- "Algebraic" => newtype, data type, or dictionary (not function types)
--- We return the constructors too.
+-- We return the constructors too, so there had better be some.
splitAlgTyConApp_maybe :: Type -> Maybe (TyCon, [Type], [DataCon])
splitAlgTyConApp_maybe (TyConApp tc tys)
splitAlgTyConApp (TyConApp tc tys) = ASSERT( isAlgTyCon tc && tyConArity tc == length tys )
(tc, tys, tyConDataCons tc)
splitAlgTyConApp (NoteTy _ ty) = splitAlgTyConApp ty
+#ifdef DEBUG
+splitAlgTyConApp ty = pprPanic "splitAlgTyConApp" (pprType ty)
+#endif
\end{code}
"Dictionary" types are just ordinary data types, but you can
%************************************************************************
\begin{code}
-type RhoType = Type
-type TauType = Type
data PredType = Class Class [Type]
| IParam Name Type
-type ThetaType = [PredType]
-type ClassPred = (Class, [Type])
-type ClassContext = [ClassPred]
-type SigmaType = Type
+ deriving( Eq, Ord )
+
+type ThetaType = [PredType]
+type RhoType = Type
+type TauType = Type
+type SigmaType = Type
\end{code}
\begin{code}
-- others
import SrcLoc ( mkBuiltinSrcLoc )
-import PrelMods ( pREL_GHC )
+import PrelNames ( pREL_GHC )
import Unique -- quite a few *Keys
import Util ( thenCmp )
\end{code}
#include "HsVersions.h"
import TypeRep ( Type(..), TyNote(..) ) -- friend
-import TyCon ( TyCon, ArgVrcs, tyConKind, tyConArity, tyConDataCons, tyConTyVars,
+import TyCon ( TyCon, ArgVrcs, tyConKind, tyConArity, tyConDataConsIfAvailable, tyConTyVars,
tyConArgVrcs_maybe, getSynTyConDefn, isSynTyCon, isAlgTyCon )
import DataCon ( dataConRepArgTys )
calcTyConArgVrcs tycons
= let oi = foldl (\fm tc -> addToFM fm tc (initial tc)) emptyFM tycons
- initial tc = if isAlgTyCon tc && null (tyConDataCons tc) then
+ initial tc = if isAlgTyCon tc && null (tyConDataConsIfAvailable tc) then
-- make pessimistic assumption (and warn)
take (tyConArity tc) abstractVrcs
else
-> ArgVrcs -- new ArgVrcs for tycon
tcaoIter oi tc | isAlgTyCon tc
- = let cs = tyConDataCons tc
- vs = tyConTyVars tc
- argtys = concatMap dataConRepArgTys cs
- myfao tc = lookupWithDefaultFM oi (expectJust "tcaoIter(Alg)" $
- tyConArgVrcs_maybe tc)
- tc
- -- we use the already-computed result for tycons not in this SCC
- in map (\v -> anyVrc (\ty -> vrcInTy myfao v ty) argtys)
+ = if null data_cons then
+ -- Abstract types get uninformative variances
+ abstractVrcs
+ else
+ map (\v -> anyVrc (\ty -> vrcInTy myfao v ty) argtys)
vs
+ where
+ data_cons = tyConDataConsIfAvailable tc
+ vs = tyConTyVars tc
+ argtys = concatMap dataConRepArgTys data_cons
+ myfao tc = lookupWithDefaultFM oi (expectJust "tcaoIter(Alg)" $
+ tyConArgVrcs_maybe tc)
+ tc
+ -- we use the already-computed result for tycons not in this SCC
tcaoIter oi tc | isSynTyCon tc
= let (tyvs,ty) = getSynTyConDefn tc
import UConSet
import CoreSyn
+import CoreFVs ( mustHaveLocalBinding )
import Rules ( RuleBase )
import TypeRep ( Type(..), TyNote(..) ) -- friend
import Type ( UsageAnn(..),
import Literal ( Literal(..), literalType )
import Var ( Var, UVar, varType, setVarType, mkUVar, modifyIdInfo )
import IdInfo ( setLBVarInfo, LBVarInfo(..) )
-import Id ( mayHaveNoBinding, isExportedId )
+import Id ( isExportedId )
import Name ( isLocallyDefined )
import VarEnv
import VarSet
--lookupVar ve v = error "lookupVar unimplemented"
lookupVar ve v = case lookupVarEnv ve v of
Just v' -> v'
- Nothing -> ASSERT( not (isLocallyDefined v) || (mayHaveNoBinding v) )
+ Nothing -> ASSERT( not (mustHaveLocalBinding v) )
ASSERT( isUsgTy (varType v) )
v
#include "HsVersions.h"
import CoreSyn
+import CoreFVs ( mustHaveLocalBinding )
import Literal ( Literal(..) )
import Var ( Var, varName, varType, setVarType, mkUVar )
-import Id ( mayHaveNoBinding, isExportedId )
+import Id ( isExportedId )
import Name ( isLocallyDefined )
import TypeRep ( Type(..), TyNote(..) ) -- friend
import Type ( UsageAnn(..), isUsgTy, splitFunTys )
\begin{code}
hasLocalDef :: Var -> Bool
-hasLocalDef var = isLocallyDefined var
- && not (mayHaveNoBinding var)
+hasLocalDef var = mustHaveLocalBinding var
hasUsgInfo :: Var -> Bool
hasUsgInfo var = (not . isLocallyDefined) var
edges1 = zipWith (,) [0..] sorted_edges
graph = array bounds [(,) v (mapMaybe key_vertex ks) | (,) v (_, _, ks) <- edges1]
- key_map = array bounds [(,) v k | (,) v (_, k, _ ) <- edges1]
+ key_map = array bounds [(,) v k | (,) v (_, k, _ ) <- edges1]
vertex_map = array bounds edges1
(_,k1,_) `lt` (_,k2,_) = case k1 `compare` k2 of { LT -> True; other -> False }
-- printForIface prints all on one line for interface files.
-- It's called repeatedly for successive lines
printForIface :: Handle -> SDoc -> IO ()
-printForIface handle doc = printDoc OneLineMode handle (doc PprInterface)
+printForIface handle doc = printDoc LeftMode handle (doc PprInterface)
pprCode :: CodeStyle -> SDoc -> SDoc
pprCode cs d = withPprStyle (PprCode cs) d
*********************************************************
\begin{code}
-best :: Mode
- -> Int -- Line length
+best :: Int -- Line length
-> Int -- Ribbon length
-> RDoc
-> RDoc -- No unions in here!
-best OneLineMode IBOX(w) IBOX(r) p
- = get p
- where
- get Empty = Empty
- get NoDoc = NoDoc
- get (NilAbove p) = nilAbove_ (get p)
- get (TextBeside s sl p) = textBeside_ s sl (get p)
- get (Nest k p) = get p -- Elide nest
- get (p `Union` q) = first (get p) (get q)
-
-best mode IBOX(w) IBOX(r) p
+best IBOX(w) IBOX(r) p
= get w p
where
get :: INT -- (Remaining) width of line
first p q | nonEmptySet p = p
| otherwise = q
-nonEmptySet NoDoc = False
+nonEmptySet NoDoc = False
nonEmptySet (p `Union` q) = True
nonEmptySet Empty = True
nonEmptySet (NilAbove p) = True -- NoDoc always in first line
\begin{code}
-fullRender OneLineMode _ _ txt end doc = easy_display space_text txt end (reduceDoc doc)
-fullRender LeftMode _ _ txt end doc = easy_display nl_text txt end (reduceDoc doc)
+fullRender OneLineMode _ _ txt end doc
+ = lay (reduceDoc doc)
+ where
+ lay NoDoc = cant_fail
+ lay (Union p q) = (lay q) -- Second arg can't be NoDoc
+ lay (Nest k p) = lay p
+ lay Empty = end
+ lay (NilAbove p) = space_text `txt` lay p -- NoDoc always on first line
+ lay (TextBeside s sl p) = s `txt` lay p
+
+fullRender LeftMode _ _ txt end doc
+ = lay (reduceDoc doc)
+ where
+ lay NoDoc = cant_fail
+ lay (Union p q) = lay (first p q)
+ lay (Nest k p) = lay p
+ lay Empty = end
+ lay (NilAbove p) = nl_text `txt` lay p -- NoDoc always on first line
+ lay (TextBeside s sl p) = s `txt` lay p
fullRender mode line_length ribbons_per_line txt end doc
= display mode line_length ribbon_length txt end best_doc
where
- best_doc = best mode hacked_line_length ribbon_length (reduceDoc doc)
+ best_doc = best hacked_line_length ribbon_length (reduceDoc doc)
hacked_line_length, ribbon_length :: Int
ribbon_length = round (fromInt line_length / ribbons_per_line)
}}
cant_fail = error "easy_display: NoDoc"
-easy_display nl_text txt end doc
- = lay doc cant_fail
- where
- lay NoDoc no_doc = no_doc
- lay (Union p q) no_doc = {- lay p -} (lay q cant_fail) -- Second arg can't be NoDoc
- lay (Nest k p) no_doc = lay p no_doc
- lay Empty no_doc = end
- lay (NilAbove p) no_doc = nl_text `txt` lay p cant_fail -- NoDoc always on first line
- lay (TextBeside s sl p) no_doc = s `txt` lay p no_doc
indent n | n GREQ ILIT(8) = '\t' : indent (n MINUS ILIT(8))
| otherwise = spaces n
assoc, assocUsing, assocDefault, assocDefaultUsing,
-- duplicate handling
- hasNoDups, equivClasses, runs, removeDups, equivClassesByUniq,
+ hasNoDups, equivClasses, runs, removeDups, removeDupsEq, equivClassesByUniq,
-- sorting
IF_NOT_GHC(quicksort COMMA stableSortLt COMMA mergesort COMMA)
where
collect_dups dups_so_far [x] = (dups_so_far, x)
collect_dups dups_so_far dups@(x:xs) = (dups:dups_so_far, x)
+
+removeDupsEq :: Eq a => [a] -> ([a], [[a]])
+-- Same, but with only equality
+-- It's worst case quadratic, but we only use it on short lists
+removeDupsEq [] = ([], [])
+removeDupsEq (x:xs) | x `elem` xs = (ys, (x : filter (== x) xs) : zs)
+ where
+ (ys,zs) = removeDupsEq (filter (/= x) xs)
+removeDupsEq (x:xs) | otherwise = (x:ys, zs)
+ where
+ (ys,zs) = removeDupsEq xs
\end{code}
</Para>
</ListItem>
</VarListEntry>
+
<VarListEntry>
<Term><Option>-ddump-tc</Option>:</Term>
<ListItem>
</Para>
</ListItem>
</VarListEntry>
+
+<VarListEntry>
+<Term><Option>-ddump-types</Option>:</Term>
+<ListItem>
+<Para>
+Dump a type signature for each value defined at the top level
+of the module. The list is sorted alphabetically.
+Using <Option>-dppr-debug</Option> dumps a type signature for
+all the imported and system-defined things as well; useful
+for debugging the compiler.
+</Para>
+</ListItem>
+</VarListEntry>
+
<VarListEntry>
<Term><Option>-ddump-deriv</Option>:</Term>
<ListItem>
+++ /dev/null
-%************************************************************************
-%* *
-\section[Driver-iface-thing]{Interface-file handling}
-%* *
-%************************************************************************
-
-\begin{code}
-%OldVersion = ();
-%Decl = (); # details about individual definitions
-%Stuff = (); # where we glom things together
-%HiExists = ('old',-1, 'new',-1); # 1 <=> definitely exists; 0 <=> doesn't
-%HiHasBeenRead = ('old', 0, 'new', 0);
-%ModuleVersion = ('old', 0, 'new', 0);
-
-%HiSections = ();
-
-sub postprocessHiFile {
- local($hsc_hi, # The iface info produced by hsc.
- $hifile_target, # The name both of the .hi file we
- # already have and which we *might*
- # replace.
- $going_interactive) = @_;
-
- local($new_hi) = "$Tmp_prefix.hi-new";
- local($show_hi_diffs) = $HiDiff_flag && ! $HiOnStdout && ! $going_interactive && -f $hifile_target;
-
- print STDERR "*** New hi file follows...\n" if $Verbose;
- system("$Cat $hsc_hi 1>&2") if $Verbose;
-
- &constructNewHiFile($hsc_hi, *hifile_target, $new_hi, $show_hi_diffs);
-
- # run diff if they asked for it
- if ($show_hi_diffs) {
- if ( $HiDiff_flag eq 'usages' ) {
- # lots of near-useless info; but if you want it...
- &run_something("$Cmp -s $hifile_target $new_hi || $Diff $hifile_target $new_hi 1>&2 || exit 0",
- "Diff'ing old and new .$HiSuffix files"); # NB: to stderr
- } else {
- # strip out usages, *then* run diff
- local($hi_before) = "$Tmp_prefix.hi-before";
- local($hi_after) = "$Tmp_prefix.hi-now";
-
- &deUsagifyHi($hifile_target, $hi_before);
- &deUsagifyHi($new_hi, $hi_after);
-
- &run_something("$Cmp -s $hi_before $hi_after || $Diff $hi_before $hi_after 1>&2 || exit 0",
- "Diff'ing old and new .$HiSuffix files"); # NB: to stderr
- }
- }
-
- # if we produced an interface file "no matter what",
- # print what we got on stderr.
- if ( $HiOnStdout ) {
- if ( $HiWith ne '' ) {
- # output some of the sections
- local($hi_after) = "$Tmp_prefix.hi-now";
-
- foreach $hi ( split(' ',$HiWith) ) {
- $HiSection{$hi} = 1;
- }
- &hiSectionsOnly($new_hi, $hi_after);
-
- system("$Cat $hi_after 1>&2 ; $Rm $hi_after; ");
- } else {
- system("$Cat $new_hi 1>&2");
- }
- } else {
- &run_something("$Cmp -s $hifile_target $new_hi || ( $Rm $hifile_target && $Cp $new_hi $hifile_target )",
- "Replace .$HiSuffix file, if changed");
- }
-}
-
-sub deUsagifyHi {
- local($ifile,$ofile) = @_;
-
- open(OLDHIF, "< $ifile") || &tidy_up_and_die(1,"Can't open $ifile (read)\n");
- open(NEWHIF, "> $ofile") || &tidy_up_and_die(1,"Can't open $ofile (write)\n");
-
- # read up to _usages_ line
- $_ = <OLDHIF>;
- while ($_ ne '') {
- print NEWHIF $_ unless /^(__interface|import)/;
- $_ = <OLDHIF>;
- }
-
- close(OLDHIF) || &tidy_up_and_die(1,"Failed reading from $ifile\n");
- close(NEWHIF) || &tidy_up_and_die(1,"Failed writing to $ofile\n");
-}
-\end{code}
-
-\begin{code}
-sub hiSectionsOnly {
- local($ifile,$ofile) = @_;
-
- open(OLDHIF, "< $ifile") || &tidy_up_and_die(1,"Can't open $ifile (read)\n");
- open(NEWHIF, "> $ofile") || &tidy_up_and_die(1,"Can't open $ofile (write)\n");
-
- # read up to _usages_ line
- $_ = <OLDHIF>;
- while ($_ ne '' ) {
- if ( /^__export/ && $HiSection {'exports'} ||
- /^import / && $HiSection {'imports'} ||
- /^\d+ ([^ ]+ :: |type |data |class |newtype )/ && $HiSection {'declarations'} ||
- /^instance / && $HiSection {'instances'} ) {
- print NEWHIF $_;
- $_ = <OLDHIF>;
- } else {
- $_ = <OLDHIF>;
- }
- }
-
- close(OLDHIF) || &tidy_up_and_die(1,"Failed reading from $ifile\n");
- close(NEWHIF) || &tidy_up_and_die(1,"Failed writing to $ofile\n");
-}
-\end{code}
-
-\begin{code}
-sub constructNewHiFile {
- local($hsc_hi, # The iface info produced by hsc.
- *hifile_target, # Pre-existing .hi filename (if it exists)
- $new_hi, # Filename for new one
- $show_hi_diffs) = @_;
- local($hiname,$hidir);
- local($mod_name_dec);
-
- &readHiFile('new',$hsc_hi) unless $HiHasBeenRead{'new'} == 1;
-
- # Sigh, we need decode the module name found in the interface file
- # since that's the (base)name we want to use when outputting the
- # interface file.
- $mod_name_dec = $ModuleName{'new'};
- $mod_name_dec =~ s/zz/z/g;
- $mod_name_dec =~ s/ZZ/Z/g;
- $mod_name_dec =~ s/zu/_/g;
-
- if ($Specific_hi_file eq '') { # -ohi is used even if module name != stem of filename.
- ($hiname = $hifile_target) = $1 if $hifile_target =~ /\/?([^\/]+)\.$HiSuffix$/;
- if ( $mod_name_dec ne $hiname ) {
- $hidir = '';
- # strip off basename only if we've got a dirname.
- ($hidir = $hifile_target) =~ s/(.*\/)[^\/]*$/$1/
- if ( $hifile_target =~ /\/$hiname\.$HiSuffix/ );
- $hifile_target = $hidir . $mod_name_dec . ".$HiSuffix";
- }
- }
- &readHiFile('old',$hifile_target) unless $HiHasBeenRead{'old'} == 1;
-
- open(NEWHI, "> $new_hi") || &tidy_up_and_die(1,"Can't open $new_hi (write)\n");
-
- local(@decl_names) = (); # Declarations in new module
- foreach $v (sort (keys %Decl)) {
- next unless $v =~ /^new:(.*$)/;
- push(@decl_names,$1);
- }
-
- local($new_module_version) = &calcNewModuleVersion(@decl_names);
- print NEWHI "__interface ", $PackageName{'new'}, $ModuleName{'new'}, " $new_module_version $Orphan{'new'} $ProjectVersionInt where\n";
- print NEWHI $Stuff{'new:exports'};
- print NEWHI $Stuff{'new:usages'} unless $Stuff{'new:usages'} eq '';
- print NEWHI $Stuff{'new:instances'} unless $Stuff{'new:instances'} eq '';
-
- foreach $v (@decl_names) {
- &printNewItemVersion(NEWHI, $v, $new_module_version, $show_hi_diffs); # Print new version number
- print NEWHI $Decl{"new:$v"}; # Print the new decl itself
- }
- print NEWHI $Stuff{'new:rules'} unless $Stuff{'new:rules'} eq '';
- print NEWHI $Stuff{'new:deprecations'} unless $Stuff{'new:deprecations'} eq '';
-
- close(NEWHI) || &tidy_up_and_die(1,"Failed writing to $new_hi\n");
-}
-\end{code}
-
-Read the .hi file made by the compiler, or the old one.
-All the declarations in the file are stored in
-
- $Decl{"$mod:$v"}
-
-where $mod is "new" or "old", depending on whether it's the new or old
- .hi file that's being read.
-
-and $v is
- for values v "v"
- for tycons T "type T" or "data T"
- for classes C "class C"
-
-
-\begin{code}
-sub readHiFile {
- local($mod, # module to read; can be special tag 'old'
- # (old .hi file for module being compiled) or
- # 'new' (new proto-.hi file for...)
- $hifile) = @_; # actual file to read
-
- # info about the old version of this module's interface
- $HiExists{$mod} = -1; # 1 <=> definitely exists; 0 <=> doesn't
- $HiHasBeenRead{$mod} = 0;
- $ModuleVersion{$mod} = 0;
- $Stuff{"$mod:usages"} = ''; # stuff glommed together
- $Stuff{"$mod:exports"} = '';
- $Stuff{"$mod:instances"} = '';
- $Stuff{"$mod:declarations"} = '';
- $Stuff{"$mod:rules"} = '';
- $Stuff{"$mod:deprecations"} = '';
-
- if (! -f $hifile) { # no pre-existing .hi file
- $HiExists{$mod} = 0;
- return();
- }
-
- open(HIFILE, "< $hifile") || &tidy_up_and_die(1,"Can't open $hifile (read)\n");
- $HiExists{$mod} = 1;
- hi_line: while (<HIFILE>) {
- next if /^ *$/; # blank line
-
- if ( /^__interface ("[A-Za-z]*"\s*)([A-Z]\S*)\s+(\d+)?\s*(\!)?/ ) {
- if ( $mod ne 'new' ) {
- # Reading old .hi file
- $ModuleVersion{$mod} = $3;
- }
-
- $PackageName{$mod} = $1;
- $ModuleName{$mod} = $2; # used to decide name of iface file.
- $Orphan{$mod} = $4;
- # optional "!" indicates that the
- # module contains orphan rules or instance decls
-
- } elsif ( /^import / ) {
- $Stuff{"$mod:usages"} .= $_; # save the whole thing
-
- } elsif ( /^__export/ ) {
- $Stuff{"$mod:exports"} .= $_;
-
- } elsif ( /^instance / ) {
- $Stuff{"$mod:instances"} .= $_;
-
- } elsif ( /^{-## __R / ) {
- $Stuff{"$mod:rules"} .= $_;
-
- } elsif ( /^{-## __D / ) {
- $Stuff{"$mod:deprecations"} .= $_;
-
- } elsif ( /^-[-]+ .*/ ) { # silently ignore comment lines.
- ;
- } else { # We're in a declaration
-
- # Strip off the initial version number, if any
- if ( /^([0-9]+)\s+(.*\n)/ ) {
-
- # The "\n" is because we need to keep the newline at
- # the end, so that it looks the same as if there's no version
- # number and this if statement doesn't fire.
-
- # So there's an initial version number
- $version = $1;
- $_ = $2;
- }
-
- if ( /^type\s+(\S+)/ ) {
- # Type declaration
- $current_name = "type $1";
- $Decl{"$mod:$current_name"} = $_;
- if ($mod eq "old") { $OldVersion{$current_name} = $version; }
-
- } elsif ( /^(newtype|data)\s+({.*}\s+=>\s+)?(\S+)\s+/ ) {
- # Data declaration
- # The (...)? parts skips over the context of a data decl
- # to find the name of the type constructor. The curly
- # brackets are part of the iface file syntax for contexts
- $current_name = "data $3";
- $Decl{"$mod:$current_name"} = $_;
- if ($mod eq "old") { $OldVersion{$current_name} = $version; }
-
- } elsif ( /^class\s+(\{[^{}]*\}\s+=>\s+)?(\S+)\s+/ ) {
- # Class declaration
- # must be wary of => bit matching after "where"...
- # ..hence the [^{}] part
- # NB: a class decl may not have a where part at all
- $current_name = "class $2";
- $Decl{"$mod:$current_name"} = $_;
- if ($mod eq "old") { $OldVersion{$current_name} = $version; }
-
- } elsif ( /^infix(r|l)?\s+[0-9]\s+(\S+)/ ) {
- # fixity declaration
- $current_name = "fixity $2";
- $Decl{"$mod:$current_name"} = $_;
- if ($mod eq "old") { $OldVersion{$current_name} = $version; }
-
- } elsif ( /^(\S+)\s+::\s+/ ) {
- # Value declaration
- $current_name = $1;
- $Decl{"$mod:$current_name"} = $_;
- if ($mod eq "old") { $OldVersion{$current_name} = $version; }
-
- } else { # Continuation line
- # print STDERR "$Pgm:junk old iface line?:$_";
- $Decl{"$mod:$current_name"} .= $_
- }
-
- }
- }
-
- close(HIFILE) || &tidy_up_and_die(1,"Failed reading from $hifile\n");
- $HiHasBeenRead{$mod} = 1;
-}
-\end{code}
-
-\begin{code}
-sub calcNewModuleVersion {
- local (@decl_names) = @_;
-
- return(&mv_change(1,'no old .hi file')) if $HiExists{'old'} == 0;
- # could use "time()" as initial version; if a module existed, then was deleted,
- # then comes back, we don't want the resurrected one to have an
- # lower version number than the original (in case there are any
- # lingering references to the original in other .hi files).
-
- local($unchanged_version) = $ModuleVersion{'old'}; # will return one of these two
- local($changed_version) = $unchanged_version + 1;
-
- if ($Orphan{'old'} ne $Orphan{'new'}) {
- return(&mv_change($changed_version, "orphan-hood changed"));
- }
-
- foreach $t ( 'usages' , 'exports', 'instances', 'fixities', 'rules', 'deprecations' ) {
- return(&mv_change($changed_version,"$t changed")) if $Stuff{"old:$t"} ne $Stuff{"new:$t"};
- }
-
-# Decl need separate treatment; they aren't in $Stuff
- foreach $v (@decl_names) {
- return(&mv_change($changed_version,"$v changed")) if $Decl{"old:$v"} ne $Decl{"new:$v"};
- }
-
- print STDERR "$Pgm: module version unchanged at $unchanged_version\n"
- if $Verbose;
- return($unchanged_version);
-}
-
-sub mv_change {
- local($mv, $str) = @_;
-
- print STDERR "$Pgm: module version changed to $mv; reason: $str\n"
- if $Verbose;
- return($mv);
-}
-
-sub printNewItemVersion {
- local($hifile, $item, $mod_version, $show_hi_diffs) = @_;
- local($idecl) = $Decl{"new:$item"};
-
-
- if (! defined($Decl{"old:$item"})) { # Old decl doesn't exist
- if ($show_hi_diffs) {print STDERR "new: $item\n";}
- print $hifile "$mod_version "; # Use module version
-
- } elsif (! defined($OldVersion{"$item"}) ) {
- if ($show_hi_diffs) {print STDERR "$item: no old version?!\n";}
- print $hifile "$mod_version "; # Use module version
-
- } elsif ($idecl ne $Decl{"old:$item"}) { # Old decl differs from new decl
- local($odecl) = $Decl{"old:$item"};
- if ($show_hi_diffs) {print STDERR "changed: $item\nOld: $odecl", "New: $idecl";}
- print $hifile "--old: ", $OldVersion{"$item"}, " $odecl"
- if $Keep_HiDiffs; # show old in interface file
- print $hifile "$mod_version "; # Use module version
-
- } else { # Identical decls, so use old version number
- #if ($show_hi_diffs) {print STDERR "$item: unchanged\n";}
- print $hifile $OldVersion{"$item"}, " ";
- }
- return;
-}
-\end{code}
-
-\begin{code}
-# make "require"r happy...
-1;
-\end{code}
# Specialisation is best done before full laziness
# so that overloaded functions have all their dictionary lambdas manifest
($Oopt_DoSpecialise) ? ( $Oopt_DoSpecialise, ) : (),
- '-ffloat-outwards',
+# '-ffloat-outwards',
'-ffloat-inwards',
'-fsimplify',
}
if (-f $hsc_out_h_stub) {
- &run_something("cp $hsc_out_h_stub $ofile_h_stub_target", 'Copy foreign export header file');
+ &run_something("mv $hsc_out_h_stub $ofile_h_stub_target", 'Copy foreign export header file');
}
if (-f $hsc_out_c_stub) {
# See if it bailed out early, saying nothing needed doing.
# We work this out by seeing if it created an output .hi file
- if ( ! -f $hsc_hi && $ProduceHi !~ /-nohifile=/ ) {
+ if ( ! -f $hsc_out ) {
# Doesn't exist, so we bailed out early.
# Tell the C compiler and assembler not to run
$do_cc = 0; $do_as = 0;
# Interface-handling is important enough to live off by itself
- if ( $ProduceHi !~ /-nohifile=/ ) { # If we've produced one, process it.
- require('ghc-iface.prl') || &tidy_up_and_die(1,"$Pgm: panic: can't load ghc-iface.prl!\n");
- &postprocessHiFile($hsc_hi, $hifile_target, $going_interactive);
+ if ( -f $hsc_hi ) {
+ # print STDERR "Aha! A new hi file\n" ;
+ &run_something( "mv $hsc_hi $hifile_target", "Copy hi file" ) ;
+ } else {
+ # print STDERR "Oh ho! Hi file unchanged\n" ;
}
+
+
# if we're going to split up object files,
# we inject split markers into the .hc file now
if ( $HscLang eq 'C' && $SplitObjFiles ) {
__interface Main 1 where
__export Main main ;
-1 main :: __forall [a] => PrelIOBase.IO a; -- wish this could be __o. KSW 1999-04.
+1 main :: __forall a => PrelIOBase.IO a; -- wish this could be __o. KSW 1999-04.
-- because it's wired into the compiler
---------------------------------------------------------------------------
-__interface PrelErr 2 0 where
+__interface PrelErr 1 where
__export PrelErr error parError;
-- for PrelException.hi.
---------------------------------------------------------------------------
-__interface PrelException 1 0 where
+__interface PrelException 1 where
__export PrelException ioError catch;
-1 ioError :: __forall [a] => PrelIOBase.IOError -> PrelIOBase.IO a ;
-1 catch :: __forall [a] => PrelIOBase.IO a -> (PrelIOBase.IOError -> PrelIOBase.IO a) -> PrelIOBase.IO a ; -- wish there could be more __o's here. KSW 1999-04.
+1 ioError :: __forall a => PrelIOBase.IOError -> PrelIOBase.IO a ;
+1 catch :: __forall a => PrelIOBase.IO a -> (PrelIOBase.IOError -> PrelIOBase.IO a) -> PrelIOBase.IO a ; -- wish there could be more __o's here. KSW 1999-04.
-- primitive operations and types that GHC knows about.
---------------------------------------------------------------------------
-__interface "std" PrelGHC 2 0 where
+__interface "std" PrelGHC 1 407 where
__export PrelGHC
unsafeCoercezh
;
+-- Export PrelErr.error, so that others don't have to import PrelErr
+__export PrelErr error ;
+
+--------------------------------------------------
+-- These imports tell modules low down in the hierarchy that
+-- PrelErr and PrelBase are in the same package and
+-- should be read from their hi-boot files
+import PrelErr @ ;
+import PrelNum @ ;
+
+
+--------------------------------------------------
instance {CCallable Charzh} = zdfCCallableCharzh;
instance {CCallable Doublezh} = zdfCCallableDoublezh;
instance {CCallable Floatzh} = zdfCCallableFloatzh;
instance {CCallable Word64zh} = zdfCCallableWord64zh;
instance {CCallable Wordzh} = zdfCCallableWordzh;
instance {CCallable ByteArrayzh} = zdfCCallableByteArrayzh;
-instance __forall [s] => {CCallable (MutableByteArrayzh s)} = zdfCCallableMutableByteArrayzh;
+instance __forall s => {CCallable (MutableByteArrayzh s)} = zdfCCallableMutableByteArrayzh;
instance {CCallable ForeignObjzh} = zdfCCallableForeignObjzh;
-instance __forall [s] => {CCallable (StablePtrzh s)} = zdfCCallableStablePtrzh;
+instance __forall s => {CCallable (StablePtrzh s)} = zdfCCallableStablePtrzh;
-- CCallable and CReturnable have kind (Type AnyBox) so that
-- things like Int# can be instances of CCallable.
1 class CCallable a :: ? ;
1 class CReturnable a :: ? ;
-1 assert :: __forall [a] => PrelBase.Bool -> a -> a ;
+1 assert :: __forall a => PrelBase.Bool -> a -> a ;
-- These guys don't really exist:
--
1 zdfCCallableWord64zh :: {CCallable Word64zh} ;
1 zdfCCallableWordzh :: {CCallable Wordzh} ;
1 zdfCCallableByteArrayzh :: {CCallable ByteArrayzh} ;
-1 zdfCCallableMutableByteArrayzh :: __forall [s] => {CCallable (MutableByteArrayzh s)} ;
+1 zdfCCallableMutableByteArrayzh :: __forall s => {CCallable (MutableByteArrayzh s)} ;
1 zdfCCallableForeignObjzh :: {CCallable ForeignObjzh} ;
-1 zdfCCallableStablePtrzh :: __forall [a] => {CCallable (StablePtrzh a)} ;
+1 zdfCCallableStablePtrzh :: __forall a => {CCallable (StablePtrzh a)} ;
any, all, elem, notElem, lookup,
maximum, minimum, concatMap,
zip, zip3, zipWith, zipWith3, unzip, unzip3,
-
#ifdef USE_REPORT_PRELUDE
#else
#-}
\end{code}
+The foldr2/right rule isn't exactly right, because it changes
+the strictness of foldr2 (and thereby zip)
+
+E.g. main = print (null (zip nonobviousNil (build undefined)))
+ where nonobviousNil = f 3
+ f n = if n == 0 then [] else f (n-1)
+
+I'm going to leave it though.
+
+
zip takes two lists and returns a list of corresponding pairs. If one
input list is short, excess elements of the longer list are discarded.
zip3 takes three lists and returns a list of triples. Zips for larger
-- other Prelude files that precede PrelPack
---------------------------------------------------------------------------
-__interface PrelPack 1 where
+__interface PrelPack 1 1 1 where
__export PrelPack packCStringzh ;
1 packCStringzh :: [PrelBase.Char] -> PrelGHC.ByteArrayzh ;
import {-# SOURCE #-} PrelErr ( error )
import PrelBase
+import PrelTup
import PrelMaybe
import PrelList ( (!!), break, dropWhile
#ifdef USE_REPORT_PRELUDE
# ProjectVersionInt does *not* contain the patchlevel (rationale: this
# figure is used for conditional compilations, and library interfaces
# etc. are not supposed to change between patchlevels).
+#
+# The ProjectVersionInt is included in interface files, and GHC
+# checks that it's reading interface generated by the same ProjectVersion
+# as itself. It does this even though interface file syntax may not
+# change between versions. Rationale: calling conventions or other
+# random .o-file stuff might change even if the .hi syntax doesn't
ProjectName = The Glorious Glasgow Haskell Compilation System
ProjectNameShort = ghc
CcMajorVersion=36
CcMinorVersion=1
+# Interface file version (hi-boot files only)
#
-# Interface file version
+# A GHC built with HscIfaceFileVersion=n will look for
+# M.hi-boot-n, and only then for
+# M.hi-boot.
+# (It'll be happy with the latter if the former doesn't exist.)
#
-# If you should happen to make changes to the interface file format
-# that will break compatibility with older versions, up this variable.
-#
+# This variable is used ONLY for hi-boot files.
+# Its only purpose is to allow you to have a single directory
+# with multiple .hi-boot files for the same module, each
+# corresponding to a different version of GHC.
+#
+# It is propagated to hsc like this:
+# * This file is included in ghc/Makefile
+# * ghc/Makefile has a main/Constants.lhs-specific flag
+# -DHscIfaceFileVersion=$(HscIfaceFileVersion)
+# * main/Constants.lhs defines
+# interfaceFileFormatVersion = HscIfaceFileVersion
+# So there!
+
HscIfaceFileVersion=5
-# But watch out: interface file format after Simon's renamer
-# hacking isn't the same as before, but it may not make
-# any difference for the GHC boot files.
-# May 1999
+{-# OPTIONS -fglasgow-exts #-}\r
+\r
-- !!! Scoped type variables in result signatures\r
module ShouldCompile where\r
\r
projects / ghc-hetmet.git / commitdiff