cvs remove TcGRHSs.hi-boot TcGRHSs.hi-boot-5 TcGRHSs.lhs
cvs remove pbinding.ugn
cvs add grhsb.ugn gdexp.ugn
+cvs add basicTypes/OccName.lhs
+
+
+New in 4.02
+* Scoped type variables
+* Warnings for unused variables should work now (they didn't before)
+* Simplifier improvements:
+ - Much better treatment of strict arguments
+ - Better treatment of bottoming Ids
+ - No need for w/w split for fns that are merely strict
+ - Fewer iterations needed, I hope
+* Less gratuitous renaming in interface files and abs C
+* OccName is a separate module, and is an abstract data type
+
-----------------------
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: AbsCSyn.lhs,v 1.18 1998/12/02 13:17:16 simonm Exp $
+% $Id: AbsCSyn.lhs,v 1.19 1998/12/18 17:40:32 simonpj Exp $
%
\section[AbstractC]{Abstract C: the last stop before machine code}
import CmdLineOpts ( opt_ProduceC )
import Maybes ( maybeToBool )
import PrimOp ( PrimOp(..) )
-import Util ( panic )
+import Panic ( panic )
infixr 9 `thenFlt`
\end{code}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CLabel.lhs,v 1.21 1998/12/02 13:17:19 simonm Exp $
+% $Id: CLabel.lhs,v 1.22 1998/12/18 17:40:34 simonpj Exp $
%
\section[CLabel]{@CLabel@: Information to make C Labels}
-This module deals with printing (a) C string literals and (b) C labels.
+This module deals with printing C string literals
\begin{code}
module CStrings(
+ cSEP, pp_cSEP,
- cSEP,
- pp_cSEP,
-
- identToC, modnameToC,
stringToC, charToC,
charToEasyHaskell
-
) where
#include "HsVersions.h"
-import Char ( isAlphanum, ord, chr )
+import Char ( ord, chr )
import Outputable
\end{code}
-\begin{verbatim}
-_ is the main separator
-
-orig becomes
-**** *******
-_ Zu
-' Zq (etc for ops ??)
-<funny char> Z[hex-digit][hex-digit]
-Prelude<x> ZP<x>
-<std class> ZC<?>
-<std tycon> ZT<?>
-\end{verbatim}
-
\begin{code}
cSEP = SLIT("_") -- official C separator
pp_cSEP = char '_'
-identToC :: FAST_STRING -> SDoc
-modnameToC :: FAST_STRING -> FAST_STRING
stringToC :: String -> String
charToC, charToEasyHaskell :: Char -> String
[chr (n + ord '0')]
else
octify (n `quot` 8) ++ [chr (n `rem` 8 + ord '0')]
-
-identToC ps
- = let
- str = _UNPK_ ps
- in
- (<>)
- (case str of
- 's':'t':'d':_ -> -- avoid "stdin", "stdout", and "stderr"...
- char 'Z'
- _ -> empty)
-
- (if (all isAlphanum str) -- we gamble that this test will succeed...
- then ptext ps
- else hcat (map char_to_c str))
- where
- char_to_c 'Z' = ptext SLIT("ZZ")
- char_to_c '&' = ptext SLIT("Za")
- char_to_c '|' = ptext SLIT("Zb")
- char_to_c ':' = ptext SLIT("Zc")
- char_to_c '/' = ptext SLIT("Zd")
- char_to_c '=' = ptext SLIT("Ze")
- char_to_c '>' = ptext SLIT("Zg")
- char_to_c '#' = ptext SLIT("Zh")
- char_to_c '<' = ptext SLIT("Zl")
- char_to_c '-' = ptext SLIT("Zm")
- char_to_c '!' = ptext SLIT("Zn")
- char_to_c '.' = ptext SLIT("_")
- char_to_c '+' = ptext SLIT("Zp")
- char_to_c '\'' = ptext SLIT("Zq")
- char_to_c '*' = ptext SLIT("Zt")
- char_to_c '_' = ptext SLIT("_")
-
- char_to_c c = if isAlphanum c
- then char c
- else char 'Z' <> int (ord c)
\end{code}
-For \tr{modnameToC}, we really only have to worry about \tr{'}s (quote
-chars) in the name. Rare.
-\begin{code}
-modnameToC ps
- = let
- str = _UNPK_ ps
- in
- if not (any quote_here str) then
- ps
- else
- _PK_ (concat (map char_to_c str))
- where
- quote_here '\'' = True
- quote_here _ = False
-
- char_to_c c
- = if isAlphanum c then [c] else 'Z' : (show (ord c))
-\end{code}
-
-
import AbsCSyn
import PrimOp ( primOpNeedsWrapper, PrimOp(..) )
-import Util ( trace )
+import Panic ( trace )
-- --------------------------------------------------------------------------
data CostRes = Cost (Int, Int, Int, Int, Int)
\begin{code}
module PprAbsC (
writeRealC,
- dumpRealC
-#ifdef DEBUG
- , pprAmode -- otherwise, not exported
- , pprMagicId
-#endif
+ dumpRealC,
+ pprAmode,
+ pprMagicId
) where
#include "HsVersions.h"
import StgSyn ( SRT(..) )
import BitSet ( intBS )
import Outputable
-import Util ( nOfThem, panic, assertPanic )
+import Util ( nOfThem )
import Addr ( Addr )
import ST
in ASSERT (length nvrs <= 1) nvrs
pprAbsC (CCodeBlock label abs_C) _
- = ASSERT( maybeToBool(nonemptyAbsC abs_C) )
+ = if not (maybeToBool(nonemptyAbsC abs_C)) then
+ pprTrace "pprAbsC: curious empty code block for" (pprCLabel label) empty
+ else
case (pprTempAndExternDecls abs_C) of { (pp_temps, pp_exts) ->
vcat [
hcat [text (if (externallyVisibleCLabel label)
module BasicTypes(
Version, Arity,
Unused, unused,
- Module, moduleString, pprModule,
Fixity(..), FixityDirection(..), StrictnessMark(..),
NewOrData(..), IfaceFlavour(..), TopLevelFlag(..), RecFlag(..)
) where
%************************************************************************
%* *
-\subsection[Module]{The name of a module}
-%* *
-%************************************************************************
-
-\begin{code}
-type Module = FAST_STRING
-
-moduleString :: Module -> String
-moduleString mod = _UNPK_ mod
-
-pprModule :: Module -> SDoc
-pprModule m = ptext m
-\end{code}
-
-%************************************************************************
-%* *
\subsection[IfaceFlavour]{IfaceFlavour}
%* *
%************************************************************************
dcName :: Name,
dcUnique :: Unique, -- Cached from Name
dcTag :: ConTag,
- dcType :: Type, -- Type of the constructor (see notes below)
+
+ -- Running example:
+ --
+ -- data Eq a => T a = forall b. Ord b => MkT a [b]
+
+ dcType :: Type, -- Type of the constructor
+ -- forall ab . Ord b => a -> [b] -> MkT a
+ -- (this is *not* of the constructor Id:
+ -- see notes after this data type declaration)
+
+ -- The next six fields express the type of the constructor, in pieces
+ -- e.g.
+ --
+ -- dcTyVars = [a]
+ -- dcTheta = [Eq a]
+ -- dcExTyVars = [b]
+ -- dcExTheta = [Ord b]
+ -- dcArgTys = [a,List b]
+ -- dcTyCon = T
dcTyVars :: [TyVar], -- Type vars and context for the data type decl
dcTheta :: ThetaType,
dcArgTys :: [Type], -- Argument types
dcTyCon :: TyCon, -- Result tycon
+ -- Now the strictness annotations and field labels of the constructor
dcStricts :: [StrictnessMark], -- Strict args, in the same order as the argument types;
-- length = dataConNumFields dataCon
-- same order as the argument types;
-- length = 0 (if not a record) or dataConSourceArity.
+ -- Finally, the curried function that corresponds to the constructor
+ -- mkT :: forall a b. (Eq a, Ord b) => a -> [b] -> T a
+ -- mkT = /\ab. \deq dord p qs. Con MkT [a, b, dord, p, qs]
+ -- This unfolding is built in MkId.mkDataConId
+
dcId :: Id -- The corresponding Id
}
isStrict (WwUnpack other _ _) = True
isStrict WwStrict = True
isStrict WwEnum = True
-isStrict WwPrim = False -- NB: we treat only lifted types as strict.
- -- Why is this important? Mostly it doesn't matter
- -- but it saves a test for lifted-ness in SimplUtils.etaCoreExpr
+isStrict WwPrim = True
isStrict _ = False
\end{code}
%* *
%************************************************************************
+
\begin{code}
+pprDemands demands bot = hcat (map pprDemand demands) <> pp_bot
+ where
+ pp_bot | bot = ptext SLIT("B")
+ | otherwise = empty
+
+
+pprDemand (WwLazy False) = char 'L'
+pprDemand (WwLazy True) = char 'A'
+pprDemand WwStrict = char 'S'
+pprDemand WwPrim = char 'P'
+pprDemand WwEnum = char 'E'
+pprDemand (WwUnpack nd wu args) = char ch <> parens (hcat (map pprDemand args))
+ where
+ ch = case nd of
+ DataType | wu -> 'U'
+ | otherwise -> 'u'
+ NewType | wu -> 'N'
+ | otherwise -> 'n'
+
+instance Outputable Demand where
+ ppr (WwLazy False) = empty
+ ppr other_demand = ptext SLIT("__D") <+> pprDemand other_demand
+
+instance Show Demand where
+ showsPrec p d = showsPrecSDoc p (ppr d)
+\end{code}
+
+
+\begin{code}
+{- ------------------- OMITTED NOW -------------------------------
+ -- Reading demands is done in Lex.lhs
+ -- Also note that the (old) code here doesn't take proper
+ -- account of the 'B' suffix for bottoming functions
+
#ifdef REALLY_HASKELL_1_3
instance Read Demand where
showsPrec p d = showsPrecSDoc p (ppr d)
#endif
+readDemands :: String ->
+
read_em acc ('L' : xs) = read_em (WwLazy False : acc) xs
read_em acc ('A' : xs) = read_em (WwLazy True : acc) xs
read_em acc ('S' : xs) = read_em (WwStrict : acc) xs
do_unpack new_or_data wrapper_unpacks acc xs
= case (read_em [] xs) of
[(stuff, rest)] -> read_em (WwUnpack new_or_data wrapper_unpacks stuff : acc) rest
- _ -> pprPanic "Demand.do_unpack:" (ppr acc <+> text ("::"++xs))
-
-
-pprDemands demands = hcat (map pprDemand demands)
-
-pprDemand (WwLazy False) = char 'L'
-pprDemand (WwLazy True) = char 'A'
-pprDemand WwStrict = char 'S'
-pprDemand WwPrim = char 'P'
-pprDemand WwEnum = char 'E'
-pprDemand (WwUnpack nd wu args) = char ch <> parens (pprDemands args)
- where
- ch = case nd of
- DataType | wu -> 'U'
- | otherwise -> 'u'
- NewType | wu -> 'N'
- | otherwise -> 'n'
+ _ -> pprPanic "Demand.do_unpack:" (ppr acc <+> dcolon <> text xs)
-instance Outputable Demand where
- ppr (WwLazy False) = empty
- ppr other_demand = ptext SLIT("__D") <+> pprDemand other_demand
+-------------------- END OF OMISSION ------------------------------ -}
\end{code}
+
\begin{code}
module Id (
- Id, DictId, GenId,
+ Id, DictId,
-- Simple construction
mkVanillaId, mkImportedId, mkSysLocal, mkUserLocal,
mkTemplateLocals, mkWildId, mkUserId,
-- Taking an Id apart
- idName, idType, idUnique, idInfo,
+ idName, idType, idUnique, idInfo, idDetails,
idPrimRep, isId,
recordSelectorFieldLabel,
-- Modifying an Id
- setIdName, setIdUnique, setIdType, setIdInfo,
- setIdVisibility, mkIdVisible,
+ setIdName, setIdUnique, setIdType, setIdInfo, mkIdVisible,
-- Predicates
omitIfaceSigForId,
isRecordSelector,
isPrimitiveId_maybe, isDataConId_maybe,
isConstantId,
- isBottomingId,
+ isBottomingId, idAppIsBottom,
-- IdInfo stuff
setIdUnfolding,
import {-# SOURCE #-} CoreUnfold ( Unfolding )
-import Var ( Id, GenId, DictId, VarDetails(..),
+import Var ( Id, DictId, VarDetails(..),
isId, mkId,
- idName, idType, idUnique, idInfo, varDetails,
+ idName, idType, idUnique, idInfo, idDetails,
setIdName, setVarType, setIdUnique, setIdInfo, modifyIdInfo,
externallyVisibleId
)
import VarSet
-import Type ( GenType, Type, tyVarsOfType, typePrimRep, addFreeTyVars )
+import Type ( Type, tyVarsOfType, typePrimRep, addFreeTyVars )
import IdInfo
import Demand ( Demand )
-import Name ( Name, OccName,
+import Name ( Name, OccName, Module,
mkSysLocalName, mkLocalName,
- isWiredInName, setNameVisibility, mkNameVisible
+ isWiredInName, mkNameVisible
)
import Const ( Con(..) )
import PrimRep ( PrimRep )
import PrimOp ( PrimOp )
import FieldLabel ( FieldLabel(..) )
-import BasicTypes ( Module )
import Unique ( Unique, mkBuiltinUnique, getBuiltinUniques )
import Outputable
%************************************************************************
\begin{code}
-mkVanillaId :: Name -> (GenType flexi) -> GenId flexi
-mkVanillaId name ty = mkId name ty VanillaId noIdInfo
+mkVanillaId :: Name -> Type -> Id
+mkVanillaId name ty = mkId name (addFreeTyVars ty) VanillaId noIdInfo
mkImportedId :: Name -> Type -> IdInfo -> Id
-mkImportedId name ty info = mkId name ty VanillaId info
+mkImportedId name ty info = mkId name (addFreeTyVars ty) VanillaId info
-mkUserId :: Name -> GenType flexi -> GenId flexi
+mkUserId :: Name -> Type -> Id
mkUserId name ty = mkVanillaId name ty
-- SysLocal: for an Id being created by the compiler out of thin air...
-- UserLocal: an Id with a name the user might recognize...
-mkUserLocal :: OccName -> Unique -> GenType flexi -> GenId flexi
-mkSysLocal :: Unique -> GenType flexi -> GenId flexi
+mkUserLocal :: OccName -> Unique -> Type -> Id
+mkSysLocal :: FAST_STRING -> Unique -> Type -> Id
-mkSysLocal uniq ty = mkVanillaId (mkSysLocalName uniq) ty
-mkUserLocal occ uniq ty = mkVanillaId (mkLocalName uniq occ) ty
+mkSysLocal fs uniq ty = mkVanillaId (mkSysLocalName uniq fs) ty
+mkUserLocal occ uniq ty = mkVanillaId (mkLocalName uniq occ) ty
\end{code}
Make some local @Ids@ for a template @CoreExpr@. These have bogus
\begin{code}
-- "Wild Id" typically used when you need a binder that you don't expect to use
mkWildId :: Type -> Id
-mkWildId ty = mkSysLocal (mkBuiltinUnique 1) ty
+mkWildId ty = mkSysLocal SLIT("wild") (mkBuiltinUnique 1) ty
-- "Template locals" typically used in unfoldings
mkTemplateLocals :: [Type] -> [Id]
-mkTemplateLocals tys = zipWith mkSysLocal
+mkTemplateLocals tys = zipWith (mkSysLocal SLIT("tpl"))
(getBuiltinUniques (length tys))
tys
\end{code}
%************************************************************************
\begin{code}
-idFreeTyVars :: (GenId flexi) -> (GenTyVarSet flexi)
+idFreeTyVars :: Id -> TyVarSet
idFreeTyVars id = tyVarsOfType (idType id)
-setIdType :: GenId flexi1 -> GenType flexi2 -> GenId flexi2
+setIdType :: Id -> Type -> Id
-- Add free tyvar info to the type
setIdType id ty = setVarType id (addFreeTyVars ty)
= True
| otherwise
- = case varDetails id of
+ = case idDetails id of
RecordSelId _ -> True -- Includes dictionary selectors
ConstantId _ -> True
-- ConstantIds are implied by their type or class decl;
other -> False -- Don't omit!
\end{code}
-See notes with setNameVisibility (Name.lhs)
-
\begin{code}
-setIdVisibility :: Maybe Module -> Unique -> Id -> Id
-setIdVisibility maybe_mod u id
- = setIdName id (setNameVisibility maybe_mod u (idName id))
-
mkIdVisible :: Module -> Unique -> Id -> Id
mkIdVisible mod u id
= setIdName id (mkNameVisible mod u (idName id))
\begin{code}
recordSelectorFieldLabel :: Id -> FieldLabel
-recordSelectorFieldLabel id = case varDetails id of
+recordSelectorFieldLabel id = case idDetails id of
RecordSelId lbl -> lbl
-isRecordSelector id = case varDetails id of
+isRecordSelector id = case idDetails id of
RecordSelId lbl -> True
other -> False
-isPrimitiveId_maybe id = case varDetails id of
+isPrimitiveId_maybe id = case idDetails id of
ConstantId (PrimOp op) -> Just op
other -> Nothing
-isDataConId_maybe id = case varDetails id of
+isDataConId_maybe id = case idDetails id of
ConstantId (DataCon con) -> Just con
other -> Nothing
-isConstantId id = case varDetails id of
+isConstantId id = case idDetails id of
ConstantId _ -> True
other -> False
\end{code}
\begin{code}
---------------------------------
-- ARITY
-getIdArity :: GenId flexi -> ArityInfo
+getIdArity :: Id -> ArityInfo
getIdArity id = arityInfo (idInfo id)
-setIdArity :: GenId flexi -> ArityInfo -> GenId flexi
+setIdArity :: Id -> ArityInfo -> Id
setIdArity id arity = modifyIdInfo id (arity `setArityInfo`)
---------------------------------
-- STRICTNESS
-getIdStrictness :: GenId flexi -> StrictnessInfo
+getIdStrictness :: Id -> StrictnessInfo
getIdStrictness id = strictnessInfo (idInfo id)
-setIdStrictness :: GenId flexi -> StrictnessInfo -> GenId flexi
+setIdStrictness :: Id -> StrictnessInfo -> Id
setIdStrictness id strict_info = modifyIdInfo id (strict_info `setStrictnessInfo`)
-isBottomingId :: GenId flexi -> Bool
-isBottomingId id = bottomIsGuaranteed (strictnessInfo (idInfo id))
+-- isBottomingId returns true if an application to n args would diverge
+isBottomingId :: Id -> Bool
+isBottomingId id = isBottomingStrictness (strictnessInfo (idInfo id))
+
+idAppIsBottom :: Id -> Int -> Bool
+idAppIsBottom id n = appIsBottom (strictnessInfo (idInfo id)) n
---------------------------------
-- UNFOLDING
-getIdUnfolding :: GenId flexi -> Unfolding
+getIdUnfolding :: Id -> Unfolding
getIdUnfolding id = unfoldingInfo (idInfo id)
-setIdUnfolding :: GenId flexi -> Unfolding -> GenId flexi
+setIdUnfolding :: Id -> Unfolding -> Id
setIdUnfolding id unfolding = modifyIdInfo id (unfolding `setUnfoldingInfo`)
---------------------------------
-- DEMAND
-getIdDemandInfo :: GenId flexi -> Demand
+getIdDemandInfo :: Id -> Demand
getIdDemandInfo id = demandInfo (idInfo id)
-setIdDemandInfo :: GenId flexi -> Demand -> GenId flexi
+setIdDemandInfo :: Id -> Demand -> Id
setIdDemandInfo id demand_info = modifyIdInfo id (demand_info `setDemandInfo`)
---------------------------------
-- UPDATE INFO
-getIdUpdateInfo :: GenId flexi -> UpdateInfo
+getIdUpdateInfo :: Id -> UpdateInfo
getIdUpdateInfo id = updateInfo (idInfo id)
-setIdUpdateInfo :: GenId flexi -> UpdateInfo -> GenId flexi
+setIdUpdateInfo :: Id -> UpdateInfo -> Id
setIdUpdateInfo id upd_info = modifyIdInfo id (upd_info `setUpdateInfo`)
---------------------------------
-- SPECIALISATION
-getIdSpecialisation :: GenId flexi -> IdSpecEnv
+getIdSpecialisation :: Id -> IdSpecEnv
getIdSpecialisation id = specInfo (idInfo id)
-setIdSpecialisation :: GenId flexi -> IdSpecEnv -> GenId flexi
+setIdSpecialisation :: Id -> IdSpecEnv -> Id
setIdSpecialisation id spec_info = modifyIdInfo id (spec_info `setSpecInfo`)
---------------------------------
-- CAF INFO
-getIdCafInfo :: GenId flexi -> CafInfo
+getIdCafInfo :: Id -> CafInfo
getIdCafInfo id = cafInfo (idInfo id)
-setIdCafInfo :: GenId flexi -> CafInfo -> GenId flexi
+setIdCafInfo :: Id -> CafInfo -> Id
setIdCafInfo id caf_info = modifyIdInfo id (caf_info `setCafInfo`)
\end{code}
OK not to if optimisation is switched off.
\begin{code}
-getInlinePragma :: GenId flexi -> InlinePragInfo
+getInlinePragma :: Id -> InlinePragInfo
getInlinePragma id = inlinePragInfo (idInfo id)
-setInlinePragma :: GenId flexi -> InlinePragInfo -> GenId flexi
+setInlinePragma :: Id -> InlinePragInfo -> Id
setInlinePragma id prag = modifyIdInfo id (setInlinePragInfo prag)
-modifyInlinePragma :: GenId flexi -> (InlinePragInfo -> InlinePragInfo) -> GenId flexi
+modifyInlinePragma :: Id -> (InlinePragInfo -> InlinePragInfo) -> Id
modifyInlinePragma id fn = modifyIdInfo id (\info -> setInlinePragInfo (fn (inlinePragInfo info)) info)
-idWantsToBeINLINEd :: GenId flexi -> Bool
+idWantsToBeINLINEd :: Id -> Bool
idWantsToBeINLINEd id = case getInlinePragma id of
IWantToBeINLINEd -> True
IMustBeINLINEd -> True
-- Strictness
StrictnessInfo(..), -- Non-abstract
- workerExists, mkStrictnessInfo, mkBottomStrictnessInfo,
- noStrictnessInfo, bottomIsGuaranteed, strictnessInfo,
+ workerExists, mkStrictnessInfo,
+ noStrictnessInfo, strictnessInfo,
ppStrictnessInfo, setStrictnessInfo,
+ isBottomingStrictness, appIsBottom,
-- Unfolding
unfoldingInfo, setUnfoldingInfo,
data StrictnessInfo
= NoStrictnessInfo
- | BottomGuaranteed -- This Id guarantees never to return;
- -- it is bottom regardless of its arguments.
- -- Useful for "error" and other disguised
- -- variants thereof.
-
| StrictnessInfo [Demand]
+ Bool -- True <=> the function diverges regardless of its arguments
+ -- Useful for "error" and other disguised variants thereof.
+ -- 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
+
Bool -- True <=> there is a worker. There might not be, even for a
-- strict function, because:
-- (a) the function might be small enough to inline,
-- so no need for w/w split
-- (b) the strictness info might be "SSS" or something, so no w/w split.
-
- -- Worker's Id, if applicable, and a list of the constructors
- -- mentioned by the wrapper. This is necessary so that the
- -- renamer can slurp them in. Without this info, the renamer doesn't
- -- know which data types to slurp in concretely. Remember, for
- -- strict things we don't put the unfolding in the interface file, to save space.
- -- This constructor list allows the renamer to behave much as if the
- -- unfolding *was* in the interface file.
\end{code}
\begin{code}
-mkStrictnessInfo :: [Demand] -> Bool -> StrictnessInfo
+mkStrictnessInfo :: ([Demand], Bool) -> Bool -> StrictnessInfo
-mkStrictnessInfo xs has_wrkr
- | all isLazy xs = NoStrictnessInfo -- Uninteresting
- | otherwise = StrictnessInfo xs has_wrkr
+mkStrictnessInfo (xs, is_bot) has_wrkr
+ | all isLazy xs && not is_bot = NoStrictnessInfo -- Uninteresting
+ | otherwise = StrictnessInfo xs is_bot has_wrkr
noStrictnessInfo = NoStrictnessInfo
-mkBottomStrictnessInfo = BottomGuaranteed
-bottomIsGuaranteed BottomGuaranteed = True
-bottomIsGuaranteed other = False
+isBottomingStrictness (StrictnessInfo _ bot _) = bot
+isBottomingStrictness NoStrictnessInfo = False
-ppStrictnessInfo NoStrictnessInfo = empty
-ppStrictnessInfo BottomGuaranteed = ptext SLIT("__bot")
+-- appIsBottom returns true if an application to n args would diverge
+appIsBottom (StrictnessInfo ds bot _) n = bot && (n >= length ds)
+appIsBottom NoStrictnessInfo n = False
-ppStrictnessInfo (StrictnessInfo wrapper_args wrkr_maybe)
- = hsep [ptext SLIT("__S"), pprDemands wrapper_args]
+ppStrictnessInfo NoStrictnessInfo = empty
+ppStrictnessInfo (StrictnessInfo wrapper_args bot wrkr_maybe)
+ = hsep [ptext SLIT("__S"), pprDemands wrapper_args bot]
\end{code}
\begin{code}
workerExists :: StrictnessInfo -> Bool
-workerExists (StrictnessInfo _ worker_exists) = worker_exists
-workerExists other = False
+workerExists (StrictnessInfo _ _ worker_exists) = worker_exists
+workerExists other = False
\end{code}
import TysWiredIn ( boolTy )
import Type ( Type, ThetaType,
mkDictTy, mkTyConApp, mkTyVarTys, mkFunTys, mkFunTy, mkSigmaTy,
- isUnLiftedType, substFlexiTheta,
+ isUnLiftedType, substTopTheta,
splitSigmaTy, splitFunTy_maybe, splitAlgTyConApp,
splitFunTys, splitForAllTys
)
import Var ( Id, TyVar, VarDetails(..), mkId )
import VarEnv ( zipVarEnv )
import Const ( Con(..) )
-import Name ( mkCompoundName, mkWiredInIdName,
- mkWorkerName, mkSuperDictSelName,
+import Name ( mkDerivedName, mkWiredInIdName,
+ mkWorkerOcc, mkSuperDictSelOcc,
Name, NamedThing(..),
)
-import PrimOp ( PrimOp, primOpType, primOpStr, primOpUniq )
+import PrimOp ( PrimOp, primOpType, primOpOcc, primOpUniq )
import DataCon ( DataCon, dataConStrictMarks, dataConFieldLabels,
dataConArgTys, dataConSig
)
= mkVanillaId dm_name ty
mkWorkerId uniq unwrkr ty
- = mkVanillaId (mkCompoundName mkWorkerName uniq (getName unwrkr)) ty
+ = mkVanillaId (mkDerivedName mkWorkerOcc (getName unwrkr) uniq) ty
\end{code}
%************************************************************************
mkSuperDictSelId uniq clas index ty
= mkDictSelId name clas ty
where
- name = mkCompoundName (mkSuperDictSelName index) uniq (getName clas)
+ name = mkDerivedName (mkSuperDictSelOcc index) (getName clas) uniq
-- For method selectors the clean thing to do is
-- to give the method selector the same name as the class op itself.
mkPrimitiveId prim_op
= id
where
- occ_name = primOpStr prim_op
+ occ_name = primOpOcc prim_op
key = primOpUniq prim_op
ty = primOpType prim_op
name = mkWiredInIdName key pREL_GHC occ_name id
= mkVanillaId dfun_name dfun_ty
where
(class_tyvars, sc_theta, _, _, _) = classBigSig clas
- sc_theta' = substFlexiTheta (zipVarEnv class_tyvars inst_tys) sc_theta
- -- Doesn't really need to be flexi
+ sc_theta' = substTopTheta (zipVarEnv class_tyvars inst_tys) sc_theta
dfun_theta = case inst_decl_theta of
[] -> [] -- If inst_decl_theta is empty, then we don't
\begin{code}
module Name (
- -- Re-export the Module type
- Module,
- pprModule, moduleString,
-
- -- The basic form of names
- isLexCon, isLexVar, isLexId, isLexSym,
- isLexConId, isLexConSym, isLexVarId, isLexVarSym,
- mkTupNameStr, mkUbxTupNameStr, isLowerISO, isUpperISO,
-
- -- The OccName type
- OccName(..), varOcc,
- pprOccName, occNameString, occNameFlavour,
- isTvOcc, isTCOcc, isVarOcc, prefixOccName,
+ -- Re-export the OccName stuff
+ module OccName,
-- The Name type
Name, -- Abstract
- mkLocalName, mkSysLocalName,
-
- mkCompoundName, mkGlobalName,
-
+ mkLocalName, mkSysLocalName, mkTopName,
+ mkDerivedName, mkGlobalName,
mkWiredInIdName, mkWiredInTyConName,
maybeWiredInIdName, maybeWiredInTyConName,
isWiredInName,
- nameUnique, changeUnique, setNameProvenance, getNameProvenance,
- setNameVisibility, mkNameVisible,
- nameOccName, nameModule,
+ nameUnique, setNameUnique, setNameProvenance, getNameProvenance,
+ tidyTopName, mkNameVisible,
+ nameOccName, nameModule, setNameOcc,
isExportedName, nameSrcLoc,
isLocallyDefinedName,
pprNameProvenance,
- -- Special Names
- dictNamePrefix, mkSuperDictSelName, mkWorkerName,
- mkDefaultMethodName, mkClassTyConStr, mkClassDataConStr,
-
-- Misc
- Provenance(..), pprProvenance,
- ExportFlag(..),
- PrintUnqualified,
+ Provenance(..), ImportReason(..), pprProvenance,
+ ExportFlag(..), PrintUnqualified,
-- Class NamedThing and overloaded friends
NamedThing(..),
import {-# SOURCE #-} Var ( Id )
import {-# SOURCE #-} TyCon ( TyCon )
-import CStrings ( identToC )
-import PrelMods ( pREL_BASE, pREL_TUP, pREL_GHC )
+import OccName -- All of it
import CmdLineOpts ( opt_PprStyle_NoPrags, opt_OmitInterfacePragmas, opt_EnsureSplittableC )
-import BasicTypes ( Module, IfaceFlavour(..), moduleString, pprModule )
+import BasicTypes ( IfaceFlavour(..) )
import SrcLoc ( noSrcLoc, mkBuiltinSrcLoc, SrcLoc )
import Unique ( pprUnique, Unique, Uniquable(..) )
import Outputable
-import Char ( isUpper, isLower, ord )
-import Util ( nOfThem )
import GlaExts
\end{code}
%************************************************************************
%* *
-\subsection{Lexical categories}
-%* *
-%************************************************************************
-
-These functions test strings to see if they fit the lexical categories
-defined in the Haskell report.
-
-\begin{code}
-isLexCon, isLexVar, isLexId, isLexSym, isLexConId, isLexConSym,
- isLexVarId, isLexVarSym :: FAST_STRING -> Bool
-
-isLexCon cs = isLexConId cs || isLexConSym cs
-isLexVar cs = isLexVarId cs || isLexVarSym cs
-
-isLexId cs = isLexConId cs || isLexVarId cs
-isLexSym cs = isLexConSym cs || isLexVarSym cs
-
--------------
-
-isLexConId cs
- | _NULL_ cs = False
- | cs == SLIT("[]") = True
- | c == '(' = True -- (), (,), (,,), ...
- | otherwise = isUpper c || isUpperISO c
- where
- c = _HEAD_ cs
-
-isLexVarId cs
- | _NULL_ cs = False
- | otherwise = isLower c || isLowerISO c
- where
- c = _HEAD_ cs
-
-isLexConSym cs
- | _NULL_ cs = False
- | otherwise = c == ':'
- || cs == SLIT("->")
- where
- c = _HEAD_ cs
-
-isLexVarSym cs
- | _NULL_ cs = False
- | otherwise = isSymbolASCII c
- || isSymbolISO c
- where
- c = _HEAD_ cs
-
--------------
-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'#
---0xc0 <= oc && oc <= 0xde && oc /= 0xd7 where oc = ord c
-isLowerISO (C# c#) = c# `geChar#` '\xdf'# && c# `leChar#` '\xff'# && c# `neChar#` '\xf7'#
---0xdf <= oc && oc <= 0xff && oc /= 0xf7 where oc = ord c
-\end{code}
-
-\begin{code}
-mkTupNameStr 0 = (pREL_BASE, SLIT("()"))
-mkTupNameStr 1 = panic "Name.mkTupNameStr: 1 ???"
-mkTupNameStr 2 = (pREL_TUP, _PK_ "(,)") -- not strictly necessary
-mkTupNameStr 3 = (pREL_TUP, _PK_ "(,,)") -- ditto
-mkTupNameStr 4 = (pREL_TUP, _PK_ "(,,,)") -- ditto
-mkTupNameStr n = (pREL_TUP, _PK_ ("(" ++ nOfThem (n-1) ',' ++ ")"))
-
-mkUbxTupNameStr 0 = panic "Name.mkUbxTupNameStr: 0 ???"
-mkUbxTupNameStr 1 = (pREL_GHC, _PK_ "(# #)") -- 1 and 0 both make sense!!!
-mkUbxTupNameStr 2 = (pREL_GHC, _PK_ "(#,#)")
-mkUbxTupNameStr 3 = (pREL_GHC, _PK_ "(#,,#)")
-mkUbxTupNameStr 4 = (pREL_GHC, _PK_ "(#,,,#)")
-mkUbxTupNameStr n = (pREL_GHC, _PK_ ("(#" ++ nOfThem (n-1) ',' ++ "#)"))
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[Name-pieces-datatypes]{The @OccName@ datatypes}
-%* *
-%************************************************************************
-
-\begin{code}
-data OccName = VarOcc FAST_STRING -- Variables and data constructors
- | TvOcc FAST_STRING -- Type variables
- | TCOcc FAST_STRING -- Type constructors and classes
-
-pprOccName :: OccName -> SDoc
-pprOccName n = getPprStyle $ \ sty ->
- if codeStyle sty
- then identToC (occNameString n)
- else ptext (occNameString n)
-
-varOcc :: FAST_STRING -> OccName
-varOcc = VarOcc
-
-occNameString :: OccName -> FAST_STRING
-occNameString (VarOcc s) = s
-occNameString (TvOcc s) = s
-occNameString (TCOcc s) = s
-
-mapOccName :: (FAST_STRING -> FAST_STRING) -> OccName -> OccName
-mapOccName f (VarOcc s) = VarOcc (f s)
-mapOccName f (TvOcc s) = TvOcc (f s)
-mapOccName f (TCOcc s) = TCOcc (f s)
-
-prefixOccName :: FAST_STRING -> OccName -> OccName
-prefixOccName prefix (VarOcc s) = VarOcc (prefix _APPEND_ s)
-prefixOccName prefix (TvOcc s) = TvOcc (prefix _APPEND_ s)
-prefixOccName prefix (TCOcc s) = TCOcc (prefix _APPEND_ s)
-
--- occNameFlavour is used only to generate good error messages, so it doesn't matter
--- that the VarOcc case isn't mega-efficient. We could have different Occ constructors for
--- data constructors and values, but that makes everything else a bit more complicated.
-occNameFlavour :: OccName -> String
-occNameFlavour (VarOcc s) | isLexConId s = "Data constructor"
- | otherwise = "Value"
-occNameFlavour (TvOcc s) = "Type variable"
-occNameFlavour (TCOcc s) = "Type constructor or class"
-
-isVarOcc, isTCOcc, isTvOcc :: OccName -> Bool
-isVarOcc (VarOcc s) = True
-isVarOcc other = False
-
-isTvOcc (TvOcc s) = True
-isTvOcc other = False
-
-isTCOcc (TCOcc s) = True
-isTCOcc other = False
-
-instance Eq OccName where
- a == b = case (a `compare` b) of { EQ -> True; _ -> False }
- a /= b = case (a `compare` b) of { EQ -> False; _ -> True }
-
-instance Ord OccName where
- a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False }
- a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False }
- a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True }
- a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True }
- compare a b = cmpOcc a b
-
-(VarOcc s1) `cmpOcc` (VarOcc s2) = s1 `compare` s2
-(VarOcc s1) `cmpOcc` other2 = LT
-
-(TvOcc s1) `cmpOcc` (VarOcc s2) = GT
-(TvOcc s1) `cmpOcc` (TvOcc s2) = s1 `compare` s2
-(TvOcc s1) `cmpOcc` other = LT
-
-(TCOcc s1) `cmpOcc` (TCOcc s2) = s1 `compare` s2
-(TCOcc s1) `cmpOcc` other = GT
-
-instance Outputable OccName where
- ppr = pprOccName
-\end{code}
-
-
-%************************************************************************
-%* *
\subsection[Name-datatype]{The @Name@ datatype, and name construction}
%* *
%************************************************************************
\begin{code}
data Name
= Local Unique
- (Maybe OccName) -- For ones that started life with a user name
+ OccName -- How to print it
+ Bool -- True <=> this is a "sys-local"
+ -- see notes just below
+
| Global Unique
Module -- The defining module
Provenance -- How it was defined
\end{code}
+Sys-locals are only used internally. When the compiler generates (say)
+a fresh desguar variable it always calls it "ds", and of course it gets
+a fresh unique. But when printing -ddump-xx dumps, we must print it with
+its unique, because there'll be a lot of "ds" variables. That debug
+printing issue is the ONLY way in which sys-locals are different. I think.
+
+Before anything gets printed in interface files or output code, it's
+fed through a 'tidy' processor, which zaps the OccNames to have
+unique names; and converts all sys-locals to ordinary locals
+If any desugarer sys-locals have survived that far, they get changed to
+"ds1", "ds2", etc.
+
Things with a @Global@ name are given C static labels, so they finally
appear in the .o file's symbol table. They appear in the symbol table
in the form M.n. If originally-local things have this property they
must be made @Global@ first.
-\begin{code}
-data Provenance
- = NoProvenance
-
- | LocalDef -- Defined locally
- SrcLoc -- Defn site
- ExportFlag -- Whether it's exported
-
- | NonLocalDef -- Defined non-locally
- SrcLoc -- Defined non-locally; src-loc gives defn site
- IfaceFlavour -- Whether the defn site is an .hi-boot file
- PrintUnqualified
-
- | WiredInTyCon TyCon -- There's a wired-in version
- | WiredInId Id -- ...ditto...
-
-type PrintUnqualified = Bool -- True <=> the unqualified name of this thing is
- -- in scope in this module, so print it
- -- unqualified in error messages
-\end{code}
-
-Something is "Exported" if it may be mentioned by another module without
-warning. The crucial thing about Exported things is that they must
-never be dropped as dead code, even if they aren't used in this module.
-Furthermore, being Exported means that we can't see all call sites of the thing.
-
-Exported things include:
-
- - explicitly exported Ids, including data constructors,
- class method selectors
-
- - dfuns from instance decls
-
-Being Exported is *not* the same as finally appearing in the .o file's
-symbol table. For example, a local Id may be mentioned in an Exported
-Id's unfolding in the interface file, in which case the local Id goes
-out too.
-
-\begin{code}
-data ExportFlag = Exported | NotExported
-\end{code}
\begin{code}
mkLocalName :: Unique -> OccName -> Name
-mkLocalName uniq occ = Local uniq (Just occ)
+mkLocalName uniq occ = Local uniq occ False
+ -- NB: You might worry that after lots of huffing and
+ -- puffing we might end up with two local names with distinct
+ -- uniques, but the same OccName. Indeed we can, but that's ok
+ -- * the insides of the compiler don't care: they use the Unique
+ -- * when printing for -ddump-xxx you can switch on -dppr-debug to get the
+ -- uniques if you get confused
+ -- * for interface files we tidyCore first, which puts the uniques
+ -- into the print name (see setNameVisibility below)
mkGlobalName :: Unique -> Module -> OccName -> Provenance -> Name
mkGlobalName = Global
-mkSysLocalName :: Unique -> Name
-mkSysLocalName uniq = Local uniq Nothing
+mkSysLocalName :: Unique -> FAST_STRING -> Name
+mkSysLocalName uniq fs = Local uniq (varOcc fs) True
+
+mkTopName :: Unique -> Module -> FAST_STRING -> Name
+ -- Make a top-level name; make it Global if top-level
+ -- things should be externally visible; Local otherwise
+ -- This chap is only used *after* the tidyCore phase
+ -- Notably, it is used during STG lambda lifting
+ --
+ -- We have to make sure that the name is globally unique
+ -- and we don't have tidyCore to help us. So we append
+ -- the unique. Hack! Hack!
+mkTopName uniq mod fs
+ | all_toplev_ids_visible = Global uniq mod occ (LocalDef noSrcLoc NotExported)
+ | otherwise = Local uniq occ False
+ where
+ occ = varOcc (_PK_ ((_UNPK_ fs) ++ show uniq))
-mkWiredInIdName :: Unique -> Module -> FAST_STRING -> Id -> Name
-mkWiredInIdName uniq mod occ id
- = Global uniq mod (VarOcc occ) (WiredInId id)
+mkWiredInIdName :: Unique -> Module -> OccName -> Id -> Name
+mkWiredInIdName uniq mod occ id = Global uniq mod occ (WiredInId id)
+-- mkWiredInTyConName takes a FAST_STRING instead of
+-- an OccName, which is a bit yukky but that's what the
+-- clients find easiest.
mkWiredInTyConName :: Unique -> Module -> FAST_STRING -> TyCon -> Name
mkWiredInTyConName uniq mod occ tycon
- = Global uniq mod (TCOcc occ) (WiredInTyCon tycon)
-
-
-mkCompoundName :: (OccName -> OccName)
- -> Unique -- New unique
- -> Name -- Base name
- -> Name -- Result is always a value name
-
-mkCompoundName f uniq (Global _ mod occ prov)
- = Global uniq mod (f occ) prov
-
-mkCompoundName f uniq (Local _ (Just occ))
- = Local uniq (Just (f occ))
+ = Global uniq mod (tcOcc occ) (WiredInTyCon tycon)
-mkCompoundName f uniq (Local _ Nothing)
- = Local uniq Nothing
+mkDerivedName :: (OccName -> OccName)
+ -> Name -- Base name
+ -> Unique -- New unique
+ -> Name -- Result is always a value name
-setNameProvenance :: Name -> Provenance -> Name
- -- setNameProvenance used to only change the provenance of
- -- Implicit-provenance things, but that gives bad error messages
- -- for names defined twice in the same module, so I changed it to
- -- set the provenance of *any* global (SLPJ Jun 97)
-setNameProvenance (Global uniq mod occ _) prov = Global uniq mod occ prov
-setNameProvenance other_name prov = other_name
-
-getNameProvenance :: Name -> Provenance
-getNameProvenance (Global uniq mod occ prov) = prov
-getNameProvenance (Local uniq occ) = LocalDef noSrcLoc NotExported
+mkDerivedName f (Global _ mod occ prov) uniq = Global uniq mod (f occ) prov
+mkDerivedName f (Local _ occ sys) uniq = Local uniq (f occ) sys
-- When we renumber/rename things, we need to be
-- able to change a Name's Unique to match the cached
-- one in the thing it's the name of. If you know what I mean.
-changeUnique (Local _ n ) u = Local u n
-changeUnique (Global _ mod occ prov) u = Global u mod occ prov
+setNameUnique (Local _ occ sys) u = Local u occ sys
+setNameUnique (Global _ mod occ prov) u = Global u mod occ prov
+
+setNameOcc :: Name -> OccName -> Name
+ -- Give the thing a new OccName, *and*
+ -- record that it's no longer a sys-local
+ -- This is used by the tidy-up pass
+setNameOcc (Global uniq mod _ prov) occ = Global uniq mod occ prov
+setNameOcc (Local uniq _ sys) occ = Local uniq occ False
\end{code}
-setNameVisibility is applied to names in the final program
-The Maybe Module argument is (Just mod) for top-level values,
-and Nothing for all others (local values and type variables)
+%************************************************************************
+%* *
+\subsection{Setting provenance and visibility
+%* *
+%************************************************************************
+
+tidyTopName is applied to top-level names in the final program
For top-level things, it globalises Local names
(if all top-level things should be visible)
and localises non-exported Global names
(if only exported things should be visible)
-For nested things it localises Global names.
-
In all cases except an exported global, it gives it a new occurrence name.
The "visibility" here concerns whether the .o file's symbol table
top-level defns externally visible
\begin{code}
-setNameVisibility :: Maybe Module -> Unique -> Name -> Name
+tidyTopName :: Module -> TidyOccEnv -> Name -> (TidyOccEnv, Name)
+tidyTopName mod env name
+ | isExported name = (env, name) -- Don't fiddle with an exported name
+ -- It should be in the TidyOccEnv already
+ | otherwise = (env', name')
+ where
+ prov = getNameProvenance name
+ uniq = nameUnique name
+ (env', occ') = tidyOccName env (nameOccName name)
-setNameVisibility maybe_mod uniq name@(Global _ mod occ (LocalDef loc NotExported))
- | not all_toplev_ids_visible || not_top_level maybe_mod
- = Local uniq Nothing -- Localise Global name
+ name' | all_toplev_ids_visible = Global uniq mod occ' prov
+ | otherwise = Local uniq occ' False
-setNameVisibility maybe_mod uniq name@(Global _ _ _ _)
- = name -- Otherwise don't fiddle with Global
+all_toplev_ids_visible =
+ not opt_OmitInterfacePragmas || -- Pragmas can make them visible
+ opt_EnsureSplittableC -- Splitting requires visiblilty
+\end{code}
-setNameVisibility (Just mod) uniq (Local _ _)
- | all_toplev_ids_visible
- = Global uniq mod -- Globalise Local name
- (uniqToOccName uniq)
- (LocalDef noSrcLoc NotExported)
+\begin{code}
+setNameProvenance :: Name -> Provenance -> Name
+ -- setNameProvenance used to only change the provenance of
+ -- Implicit-provenance things, but that gives bad error messages
+ -- for names defined twice in the same module, so I changed it to
+ -- set the provenance of *any* global (SLPJ Jun 97)
+setNameProvenance (Global uniq mod occ _) prov = Global uniq mod occ prov
+setNameProvenance other_name prov = other_name
-setNameVisibility maybe_mod uniq (Local _ _)
- = Local uniq Nothing -- New unique for Local; zap its occ
+getNameProvenance :: Name -> Provenance
+getNameProvenance (Global uniq mod occ prov) = prov
+getNameProvenance (Local _ _ _) = LocalDef noSrcLoc NotExported
+\end{code}
+\begin{code}
-- make the Name globally visible regardless.
mkNameVisible :: Module -> Unique -> Name -> Name
mkNameVisible mod occ_uniq nm@(Global _ _ _ _) = nm
-mkNameVisible mod occ_uniq nm@(Local uniq occ)
- = Global uniq mod (uniqToOccName occ_uniq) (LocalDef noSrcLoc Exported)
+mkNameVisible mod occ_uniq nm@(Local uniq occ _)
+ = Global uniq mod occ (LocalDef noSrcLoc Exported)
+\end{code}
-uniqToOccName uniq = VarOcc (_PK_ ('_':show uniq))
- -- The "_" is to make sure that this OccName is distinct from all user-defined ones
-not_top_level (Just m) = False
-not_top_level Nothing = True
+%************************************************************************
+%* *
+\subsection{Provenance and export info}
+%* *
+%************************************************************************
-all_toplev_ids_visible =
- not opt_OmitInterfacePragmas || -- Pragmas can make them visible
- opt_EnsureSplittableC -- Splitting requires visiblilty
+\begin{code}
+data Provenance
+ = NoProvenance
+
+ | LocalDef -- Defined locally
+ SrcLoc -- Defn site
+ ExportFlag -- Whether it's exported
+
+ | NonLocalDef -- Defined non-locally
+ ImportReason
+ IfaceFlavour -- Whether the defn site is an .hi-boot file
+ PrintUnqualified
+
+ | WiredInTyCon TyCon -- There's a wired-in version
+ | WiredInId Id -- ...ditto...
+
+data ImportReason
+ = UserImport Module SrcLoc Bool -- Imported from module M on line L
+ -- Note the M may well not be the defining module
+ -- for this thing!
+ -- The Bool is true iff the thing was named *explicitly* in the import spec,
+ -- rather than being imported as part of a group; e.g.
+ -- import B
+ -- import C( T(..) )
+ -- Here, everything imported by B, and the constructors of T
+ -- are not named explicitly; only T is named explicitly.
+ -- This info is used when warning of unused names.
+
+ | ImplicitImport -- Imported implicitly for some other reason
+
+
+type PrintUnqualified = Bool -- True <=> the unqualified name of this thing is
+ -- in scope in this module, so print it
+ -- unqualified in error messages
+
+data ExportFlag = Exported | NotExported
+\end{code}
+
+Something is "Exported" if it may be mentioned by another module without
+warning. The crucial thing about Exported things is that they must
+never be dropped as dead code, even if they aren't used in this module.
+Furthermore, being Exported means that we can't see all call sites of the thing.
+
+Exported things include:
+
+ - explicitly exported Ids, including data constructors,
+ class method selectors
+
+ - dfuns from instance decls
+
+Being Exported is *not* the same as finally appearing in the .o file's
+symbol table. For example, a local Id may be mentioned in an Exported
+Id's unfolding in the interface file, in which case the local Id goes
+out too.
+
+
+\begin{code}
+-- pprNameProvenance is used in error messages to say where a name came from
+pprNameProvenance :: Name -> SDoc
+pprNameProvenance name = pprProvenance (getNameProvenance name)
+
+pprProvenance :: Provenance -> SDoc
+pprProvenance NoProvenance = ptext SLIT("No provenance")
+pprProvenance (LocalDef loc _) = ptext SLIT("defined at") <+> ppr loc
+pprProvenance (WiredInTyCon tc) = ptext SLIT("Wired-in tycon")
+pprProvenance (WiredInId id) = ptext SLIT("Wired-in id")
+pprProvenance (NonLocalDef ImplicitImport _ _)
+ = ptext SLIT("implicitly imported")
+pprProvenance (NonLocalDef (UserImport mod loc _) _ _)
+ = ptext SLIT("imported from") <+> ppr mod <+> ptext SLIT("at") <+> ppr loc
\end{code}
+
%************************************************************************
%* *
\subsection{Predicates and selectors}
-nameUnique (Local u _) = u
+nameUnique (Local u _ _) = u
nameUnique (Global u _ _ _) = u
-nameOccName (Local _ (Just occ)) = occ
-nameOccName (Local uniq Nothing) = pprPanic "nameOccName" (ppr uniq)
-nameOccName (Global _ _ occ _) = occ
+nameOccName (Local _ occ _) = occ
+nameOccName (Global _ _ occ _) = occ
nameModule (Global _ mod occ _) = mod
isExportedName (Global _ _ _ (LocalDef _ Exported)) = True
isExportedName other = False
-nameSrcLoc (Local _ _) = noSrcLoc
-nameSrcLoc (Global _ _ _ (LocalDef loc _)) = loc
-nameSrcLoc (Global _ _ _ (NonLocalDef loc _ _)) = loc
-nameSrcLoc (Global _ _ _ (WiredInTyCon _)) = mkBuiltinSrcLoc
-nameSrcLoc (Global _ _ _ (WiredInId _)) = mkBuiltinSrcLoc
-nameSrcLoc other = noSrcLoc
+nameSrcLoc (Global _ _ _ (LocalDef loc _)) = loc
+nameSrcLoc (Global _ _ _ (NonLocalDef (UserImport _ loc _) _ _)) = loc
+nameSrcLoc (Global _ _ _ (WiredInTyCon _)) = mkBuiltinSrcLoc
+nameSrcLoc (Global _ _ _ (WiredInId _)) = mkBuiltinSrcLoc
+nameSrcLoc other = noSrcLoc
-isLocallyDefinedName (Local _ _) = True
+isLocallyDefinedName (Local _ _ _) = True
isLocallyDefinedName (Global _ _ _ (LocalDef _ _)) = True
isLocallyDefinedName other = False
maybeWiredInTyConName other = Nothing
-isLocalName (Local _ _) = True
-isLocalName _ = False
+isLocalName (Local _ _ _) = True
+isLocalName _ = False
-isSysLocalName (Local _ Nothing) = True
-isSysLocalName other = False
+isSysLocalName (Local _ _ sys) = sys
+isSysLocalName other = False
isGlobalName (Global _ _ _ _) = True
isGlobalName other = False
\begin{code}
cmpName n1 n2 = c n1 n2
where
- c (Local u1 _) (Local u2 _) = compare u1 u2
- c (Local _ _) _ = LT
+ c (Local u1 _ _) (Local u2 _ _) = compare u1 u2
+ c (Local _ _ _) _ = LT
c (Global u1 _ _ _) (Global u2 _ _ _) = compare u1 u2
- c (Global _ _ _ _) _ = GT
+ c (Global _ _ _ _) _ = GT
\end{code}
\begin{code}
%************************************************************************
%* *
-\subsection[Special-Names]{Special Kinds of names}
-%* *
-%************************************************************************
-
-Here's our convention for splitting up the object file name space:
-
- _d... dictionary identifiers
- _g... externally visible (non-user visible) names
-
- _m... default methods
- _n... default methods (encoded symbols, eg. <= becomes _nle)
-
- _p... superclass selectors
-
- _w... workers
- _v... workers (encoded symbols)
-
- _x... local variables
-
- _u... user-defined names that previously began with '_'
-
- _[A-Z]... compiler-generated tycons/datacons (namely dictionary
- constructors)
-
- __.... keywords (__export, __letrec etc.)
-
-This knowledge is encoded in the following functions.
-
-\begin{code}
-dictNamePrefix :: FAST_STRING
-dictNamePrefix = SLIT("_d")
-
-mkSuperDictSelName :: Int -> OccName -> OccName
-mkSuperDictSelName index = prefixOccName (_PK_ ("_p" ++ show index ++ "_"))
-
-mkWorkerName :: OccName -> OccName
-mkWorkerName nm
- | isLexSym nm_str =
- prefixOccName SLIT("_v") (mapOccName trName nm)
- | otherwise =
- prefixOccName SLIT("_w") nm
- where nm_str = occNameString nm
-
-mkDefaultMethodName :: OccName -> OccName
-mkDefaultMethodName nm
- | isLexSym nm_str =
- prefixOccName SLIT("_n") (mapOccName trName nm)
- | otherwise =
- prefixOccName SLIT("_m") nm
- where nm_str = occNameString nm
-
--- not used yet:
---mkRecordSelectorName :: Name -> Name
---mkMethodSelectorName :: Name -> Name
-
-mkClassTyConStr, mkClassDataConStr :: FAST_STRING -> FAST_STRING
-
-mkClassTyConStr s = SLIT("_") _APPEND_ s
-mkClassDataConStr s = SLIT("_") _APPEND_ s
-
--- translate a string such that it can occur as *part* of an identifer. This
--- is used when we prefix identifiers to create new names, for example the
--- name of a default method.
-
-trName :: FAST_STRING -> FAST_STRING
-trName nm = _PK_ (foldr tran "" (_UNPK_ nm))
- where
- tran c cs = case trChar c of
- '\0' -> '_' : show (ord c) ++ cs
- c' -> c' : cs
- trChar '&' = 'a'
- trChar '|' = 'b'
- trChar ':' = 'c'
- trChar '/' = 'd'
- trChar '=' = 'e'
- trChar '>' = 'g'
- trChar '#' = 'h'
- trChar '@' = 'i'
- trChar '<' = 'l'
- trChar '-' = 'm'
- trChar '!' = 'n'
- trChar '+' = 'p'
- trChar '\'' = 'q'
- trChar '$' = 'r'
- trChar '?' = 's'
- trChar '*' = 't'
- trChar '_' = 'u'
- trChar '.' = 'v'
- trChar '\\' = 'w'
- trChar '%' = 'x'
- trChar '~' = 'y'
- trChar '^' = 'z'
- trChar _ = '\0'
-\end{code}
-
-%************************************************************************
-%* *
\subsection{Pretty printing}
%* *
%************************************************************************
-- When printing interfaces, all Locals have been given nice print-names
ppr name = pprName name
-pprName name
+pprName (Local uniq occ sys_local)
= getPprStyle $ \ sty ->
- let
- -- when printing local names for interface files, prepend the '_'
- -- to avoid clashes with user-defined names. In fact, these names
- -- will always begin with 'g' for top-level ids and 'x' otherwise,
- -- because these are the unique supplies going into the tidy phase.
- ppr (Local u n) | codeStyle sty = pprUnique u
- | ifaceStyle sty = char '_' <> pprUnique u
-
- ppr (Local u Nothing) = pprUnique u
- ppr (Local u (Just occ)) | userStyle sty = ptext (occNameString occ)
- | otherwise = ptext (occNameString occ) <> char '_' <> pprUnique u
-
- ppr name@(Global u m n prov)
- | codeStyle sty
- = identToC (m _APPEND_ SLIT(".") _APPEND_ occNameString n)
-
- | otherwise
- = hcat [pp_mod_dot, ptext (occNameString n), pp_debug sty name]
- where
- pp_mod_dot
- = case prov of -- Omit home module qualifier if in scope
- LocalDef _ _ -> pp_qual dot (user_sty || iface_sty)
- NonLocalDef _ hif omit -> pp_qual (pp_hif hif) (omit && user_sty)
- -- Hack: omit qualifers on wired in things
- -- in user style only
- WiredInTyCon _ -> pp_qual dot user_sty
- WiredInId _ -> pp_qual dot user_sty
- NoProvenance -> pp_qual dot False
-
- pp_qual sep omit_qual
- | omit_qual = empty
- | otherwise = pprModule m <> sep
-
- dot = text "."
- pp_hif HiFile = dot -- Vanilla case
- pp_hif HiBootFile = text "!" -- M!t indicates a name imported from a .hi-boot interface
-
- user_sty = userStyle sty
- iface_sty = ifaceStyle sty
- in
- ppr name
-
-
-pp_debug sty (Global uniq m n prov)
- | debugStyle sty = hcat [text "{-", pprUnique uniq, prov_p, text "-}"]
- | otherwise = empty
- where
- prov_p | opt_PprStyle_NoPrags = empty
- | otherwise = comma <> pp_prov prov
-
-pp_prov (LocalDef _ Exported) = char 'x'
-pp_prov (LocalDef _ NotExported) = char 'l'
-pp_prov (NonLocalDef _ _ _) = char 'n'
-pp_prov (WiredInTyCon _) = char 'W'
-pp_prov (WiredInId _) = char 'w'
-pp_prov NoProvenance = char '?'
+ if codeStyle sty then
+ pprUnique uniq -- When printing in code we required all names to
+ -- be globally unique; for example, we use this identifier
+ -- for the closure name. So we just print the unique alone.
+ else
+ pprOccName occ <> pp_local_extra sty uniq
+ where
+ pp_local_extra sty uniq
+ | sys_local = underscore <> pprUnique uniq -- Must print uniques for sys_locals
+ | debugStyle sty = text "{-" <> pprUnique uniq <> text "-}"
+ | otherwise = empty
--- pprNameProvenance is used in error messages to say where a name came from
-pprNameProvenance :: Name -> SDoc
-pprNameProvenance (Local _ _) = pprProvenance (LocalDef noSrcLoc NotExported)
-pprNameProvenance (Global _ _ _ prov) = pprProvenance prov
-pprProvenance :: Provenance -> SDoc
-pprProvenance (LocalDef loc _) = ptext SLIT("Locally defined at") <+> ppr loc
-pprProvenance (NonLocalDef loc _ _) = ptext SLIT("Non-locally defined at") <+> ppr loc
-pprProvenance (WiredInTyCon tc) = ptext SLIT("Wired-in tycon")
-pprProvenance (WiredInId id) = ptext SLIT("Wired-in id")
-pprProvenance NoProvenance = ptext SLIT("No provenance")
+pprName (Global uniq mod occ prov)
+ = getPprStyle $ \ sty ->
+ if codeStyle sty then
+ ppr mod <> underscore <> ppr occ
+ else
+ pp_mod_dot sty <> ppr occ <> pp_global_debug sty uniq prov
+ where
+ pp_mod_dot sty
+ = case prov of -- Omit home module qualifier if in scope
+ LocalDef _ _ -> pp_qual dot (user_sty || iface_sty)
+ NonLocalDef _ hif omit -> pp_qual (pp_hif hif) (omit && user_sty)
+ -- Hack: omit qualifers on wired in things
+ -- in user style only
+ WiredInTyCon _ -> pp_qual dot user_sty
+ WiredInId _ -> pp_qual dot user_sty
+ NoProvenance -> pp_qual dot False
+ where
+ user_sty = userStyle sty
+ iface_sty = ifaceStyle sty
+
+ pp_qual sep omit_qual
+ | omit_qual = empty
+ | otherwise = pprModule mod <> sep
+
+ pp_hif HiFile = dot -- Vanilla case
+ pp_hif HiBootFile = text "!" -- M!t indicates a name imported from a .hi-boot interface
+
+ pp_global_debug sty uniq prov
+ | debugStyle sty = hcat [text "{-", pprUnique uniq, prov_p prov, text "-}"]
+ | otherwise = empty
+
+ prov_p prov | opt_PprStyle_NoPrags = empty
+ | otherwise = comma <> pp_prov prov
+
+pp_prov (LocalDef _ Exported) = char 'x'
+pp_prov (LocalDef _ NotExported) = char 'l'
+pp_prov (NonLocalDef ImplicitImport _ _) = char 'i'
+pp_prov (NonLocalDef explicitimport _ _) = char 'I'
+pp_prov (WiredInTyCon _) = char 'W'
+pp_prov (WiredInId _) = char 'w'
+pp_prov NoProvenance = char '?'
\end{code}
isExported = isExportedName . getName
getSrcLoc = nameSrcLoc . getName
isLocallyDefined = isLocallyDefinedName . getName
-getOccString x = _UNPK_ (occNameString (getOccName x))
+getOccString x = occNameString (getOccName x)
\end{code}
\begin{code}
-{-# SPECIALIZE isLocallyDefined
- :: Name -> Bool
- #-}
+{-# SPECIALIZE isLocallyDefined :: Name -> Bool #-}
\end{code}
-- Sets of Names
NameSet,
emptyNameSet, unitNameSet, mkNameSet, unionNameSets, unionManyNameSets,
- minusNameSet, elemNameSet, nameSetToList, addOneToNameSet, addListToNameSet, isEmptyNameSet,
+ minusNameSet, elemNameSet, nameSetToList, addOneToNameSet, addListToNameSet,
+ delFromNameSet, delListFromNameSet, isEmptyNameSet,
) where
#include "HsVersions.h"
\begin{code}
type NameSet = UniqSet Name
-emptyNameSet :: NameSet
-unitNameSet :: Name -> NameSet
-addListToNameSet :: NameSet -> [Name] -> NameSet
-addOneToNameSet :: NameSet -> Name -> NameSet
-mkNameSet :: [Name] -> NameSet
-unionNameSets :: NameSet -> NameSet -> NameSet
-unionManyNameSets :: [NameSet] -> NameSet
-minusNameSet :: NameSet -> NameSet -> NameSet
-elemNameSet :: Name -> NameSet -> Bool
-nameSetToList :: NameSet -> [Name]
-isEmptyNameSet :: NameSet -> Bool
+emptyNameSet :: NameSet
+unitNameSet :: Name -> NameSet
+addListToNameSet :: NameSet -> [Name] -> NameSet
+addOneToNameSet :: NameSet -> Name -> NameSet
+mkNameSet :: [Name] -> NameSet
+unionNameSets :: NameSet -> NameSet -> NameSet
+unionManyNameSets :: [NameSet] -> NameSet
+minusNameSet :: NameSet -> NameSet -> NameSet
+elemNameSet :: Name -> NameSet -> Bool
+nameSetToList :: NameSet -> [Name]
+isEmptyNameSet :: NameSet -> Bool
+delFromNameSet :: NameSet -> Name -> NameSet
+delListFromNameSet :: NameSet -> [Name] -> NameSet
isEmptyNameSet = isEmptyUniqSet
emptyNameSet = emptyUniqSet
minusNameSet = minusUniqSet
elemNameSet = elementOfUniqSet
nameSetToList = uniqSetToList
+delFromNameSet = delOneFromUniqSet
+
+delListFromNameSet set ns = foldl delFromNameSet set ns
\end{code}
--- /dev/null
+
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+
+\section[OccName]{@OccName@}
+
+\begin{code}
+module OccName (
+ -- Modules
+ Module, -- Abstract, instance of Outputable
+ mkModule, mkModuleFS, moduleString, moduleCString, pprModule,
+
+ -- The OccName type
+ OccName, -- Abstract, instance of Outputable
+ varOcc, tcOcc, tvOcc, -- Occ constructors
+ srcVarOcc, srcTCOcc, srcTvOcc, -- For Occs arising from source code
+
+ mkSuperDictSelOcc, mkDFunOcc,
+ mkDictOcc, mkWorkerOcc, mkDefaultMethodOcc,
+ mkClassTyConOcc, mkClassDataConOcc,
+
+ isTvOcc, isTCOcc, isVarOcc, isConSymOcc, isConOcc, isSymOcc,
+ pprOccName, occNameString, occNameFlavour,
+
+ -- The basic form of names
+ isLexCon, isLexVar, isLexId, isLexSym,
+ isLexConId, isLexConSym, isLexVarId, isLexVarSym,
+ isLowerISO, isUpperISO,
+
+ -- Tidying up
+ TidyOccEnv, emptyTidyOccEnv, tidyOccName, initTidyOccEnv,
+
+ -- Junk
+ identToC
+
+ ) where
+
+#include "HsVersions.h"
+
+import Char ( isAlpha, isUpper, isLower, isAlphanum, ord )
+import Util ( thenCmp )
+import FiniteMap ( FiniteMap, emptyFM, lookupFM, addToFM, elemFM )
+import Outputable
+import GlaExts
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection[Module]{The name of a module}
+%* *
+%************************************************************************
+
+\begin{code}
+data Module = Module FAST_STRING -- User and interface files
+ FAST_STRING -- Print this in C files
+
+ -- The C version has quote chars Z-encoded
+
+instance Outputable Module where
+ ppr = pprModule
+
+instance Eq Module where
+ (Module m1 _) == (Module m2 _) = m1 == m2
+
+instance Ord Module where
+ (Module m1 _) `compare` (Module m2 _) = m1 `compare` m2
+
+pprModule :: Module -> SDoc
+pprModule (Module real code)
+ = getPprStyle $ \ sty ->
+ if codeStyle sty then
+ ptext code
+ else
+ ptext real
+
+mkModule :: String -> Module
+mkModule s = Module (_PK_ s) (identToC s)
+
+mkModuleFS :: FAST_STRING -> Module
+mkModuleFS s = Module s (identFsToC s)
+
+moduleString :: Module -> String
+moduleString (Module mod _) = _UNPK_ mod
+
+moduleCString :: Module -> String
+moduleCString (Module _ code) = _UNPK_ code
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection[Name-pieces-datatypes]{The @OccName@ datatypes}
+%* *
+%************************************************************************
+
+\begin{code}
+data OccName = OccName
+ OccSpace
+ FAST_STRING -- The 'real name'
+ FAST_STRING -- Print this in interface files
+ FAST_STRING -- Print this in C/asm code
+
+-- The OccSpace/real-name pair define the OccName
+-- The iface and c/asm versions are simply derived from the
+-- other two. They are cached here simply to avoid recomputing
+-- them repeatedly when printing
+
+-- The latter two are irrelevant in RdrNames; on the other hand,
+-- the OccSpace field is irrelevant after RdrNames.
+-- So the OccName type might be refined a bit.
+-- It is now abstract so that's easier than before
+
+
+-- Why three print-names?
+-- Real Iface C
+-- ---------------------
+-- foo foo foo
+--
+-- + + Zp Operators OK in interface files;
+-- 'Z' is the escape char for C names
+--
+-- x# x# xZh Trailing # lexed ok by GHC -fglasgow-exts
+--
+-- _foo _ufoo _ufoo Leading '_' is the escape char in interface files
+--
+-- _vfoo _vfoo _vfoo Worker for foo
+--
+-- _wp _wp _wp Worker for +
+
+
+data OccSpace = VarOcc -- Variables and data constructors
+ | TvOcc -- Type variables
+ | TCOcc -- Type constructors and classes
+ deriving( Eq, Ord )
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Printing}
+%* *
+%************************************************************************
+
+\begin{code}
+instance Outputable OccName where
+ ppr = pprOccName
+
+pprOccName :: OccName -> SDoc
+pprOccName (OccName space real iface code)
+ = getPprStyle $ \ sty ->
+ if codeStyle sty then
+ ptext code
+ else if ifaceStyle sty then
+ ptext iface
+ else
+ ptext real
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Construction}
+%* *
+%************************************************************************
+
+*Source-code* things beginning with '_' are zapped to begin with '_u'
+
+\begin{code}
+mkSrcOcc :: OccSpace -> FAST_STRING -> OccName
+mkSrcOcc occ_sp real
+ = case _UNPK_ real of
+
+ '_' : rest -> OccName occ_sp real (_PK_ zapped_str) (identToC zapped_str)
+ where
+ zapped_str = '_' : 'u' : rest
+
+ other -> OccName occ_sp real real (identFsToC real)
+
+srcVarOcc, srcTCOcc, srcTvOcc :: FAST_STRING -> OccName
+srcVarOcc = mkSrcOcc VarOcc
+srcTCOcc = mkSrcOcc TCOcc
+srcTvOcc = mkSrcOcc TvOcc
+\end{code}
+
+However, things that don't come from Haskell source code aren't
+treated specially.
+
+\begin{code}
+mkOcc :: OccSpace -> String -> OccName
+mkOcc occ_sp str = OccName occ_sp fs fs (identToC str)
+ where
+ fs = _PK_ str
+
+mkFsOcc :: OccSpace -> FAST_STRING -> OccName
+mkFsOcc occ_sp real = OccName occ_sp real real (identFsToC real)
+
+varOcc, tcOcc, tvOcc :: FAST_STRING -> OccName
+varOcc = mkFsOcc VarOcc
+tcOcc = mkFsOcc TCOcc
+tvOcc = mkFsOcc TvOcc
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Making system names}
+%* *
+%************************************************************************
+
+Here's our convention for splitting up the interface file name space:
+
+ _d... dictionary identifiers
+
+ _f... dict-fun identifiers (from inst decls)
+ _g... ditto, when the tycon has symbols
+
+ _t... externally visible (non-user visible) names
+
+ _m... default methods
+ _n... default methods (encoded symbols, eg. <= becomes _nle)
+
+ _p... superclass selectors
+
+ _v... workers
+ _w... workers (encoded symbols)
+
+ _x... local variables
+
+ _u... user-defined names that previously began with '_'
+
+ _T... compiler-generated tycons for dictionaries
+ _D.. ...ditto data cons
+
+ __.... keywords (__export, __letrec etc.)
+
+This knowledge is encoded in the following functions.
+
+
+
+
+@mkDerivedOcc@ generates an @OccName@ from an existing @OccName@;
+ eg: workers, derived methods
+
+We pass a character to use as the prefix. So, for example,
+ "f" gets derived to "_vf", if the prefix char is 'v'
+
+\begin{code}
+mk_deriv :: OccSpace -> Char -> String -> OccName
+mk_deriv occ_sp sys_ch str = mkOcc occ_sp ('_' : sys_ch : str)
+\end{code}
+
+Things are a bit more complicated if the thing is an operator; then
+we must encode it into a normal identifier first. We do this in
+a simple way, and use a different character prefix (one after the one
+suggested). For example
+ "<" gets derived to "_wl", if the prefix char is 'v'
+
+\begin{code}
+mk_enc_deriv :: OccSpace
+ -> Char -- The system-name-space character (see list above)
+ -> OccName -- The OccName from which we are deriving
+ -> OccName
+
+mk_enc_deriv occ_sp sys_ch occ
+ | needs_encoding real_str = mk_deriv occ_sp sys_op_ch (encode_operator real_str)
+ | otherwise = mk_deriv occ_sp sys_ch real_str
+ where
+ real_str = occNameString occ
+ sys_op_ch = succ sys_ch
+
+
+mkDictOcc, mkWorkerOcc, mkDefaultMethodOcc,
+ mkClassTyConOcc, mkClassDataConOcc
+ :: OccName -> OccName
+
+mkWorkerOcc = mk_enc_deriv VarOcc 'v' -- v,w
+mkDefaultMethodOcc = mk_enc_deriv VarOcc 'm' -- m,n
+mkClassTyConOcc = mk_enc_deriv TCOcc 'T' -- not U
+mkClassDataConOcc = mk_enc_deriv VarOcc 'D' -- not E
+mkDictOcc = mk_enc_deriv VarOcc 'd' -- not e
+\end{code}
+
+\begin{code}
+mkSuperDictSelOcc :: Int -- Index of superclass, eg 3
+ -> OccName -- Class, eg "Ord"
+ -> OccName -- eg "p3Ord"
+mkSuperDictSelOcc index cls_occ
+ = mk_deriv VarOcc 'p' (show index ++ occNameString cls_occ)
+\end{code}
+
+
+\begin{code}
+mkDFunOcc :: OccName -- class, eg "Ord"
+ -> OccName -- tycon (or something convenient from the instance type)
+ -- eg "Maybe"
+ -> Int -- Unique to distinguish dfuns which share the previous two
+ -- eg 3
+ -> OccName -- "dOrdMaybe3"
+
+mkDFunOcc cls_occ tycon_occ index
+ | needs_encoding tycon_str -- Drat! Have to encode the tycon
+ = mk_deriv VarOcc 'g' (show_index ++ cls_str ++ encode_operator tycon_str)
+ | otherwise -- Normal case
+ = mk_deriv VarOcc 'f' (show_index ++ cls_str ++ tycon_str)
+ where
+ cls_str = occNameString cls_occ
+ tycon_str = occNameString tycon_occ
+ -- NB: if a non-operator the tycon has a trailing # we don't encode.
+ show_index | index == 0 = ""
+ | otherwise = show index
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Lexical categories}
+%* *
+%************************************************************************
+
+These functions test strings to see if they fit the lexical categories
+defined in the Haskell report.
+
+\begin{code}
+isLexCon, isLexVar, isLexId, isLexSym :: FAST_STRING -> Bool
+isLexConId, isLexConSym, isLexVarId, isLexVarSym :: FAST_STRING -> Bool
+
+isLexCon cs = isLexConId cs || isLexConSym cs
+isLexVar cs = isLexVarId cs || isLexVarSym cs
+
+isLexId cs = isLexConId cs || isLexVarId cs
+isLexSym cs = isLexConSym cs || isLexVarSym cs
+
+-------------
+
+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
+
+isLexVarId cs -- Ordinary prefix identifiers
+ | _NULL_ cs = False -- e.g. "x", "_x"
+ | otherwise = isLower c || isLowerISO c || c == '_'
+ where
+ c = _HEAD_ cs
+
+isLexConSym cs -- Infix type or data constructors
+ | _NULL_ cs = False -- e.g. ":-:", ":", "->"
+ | otherwise = c == ':'
+ || cs == SLIT("->")
+ where
+ c = _HEAD_ cs
+
+isLexVarSym cs -- Infix identifiers
+ | _NULL_ cs = False -- e.g. "+"
+ | otherwise = isSymbolASCII c
+ || isSymbolISO c
+ where
+ c = _HEAD_ cs
+
+-------------
+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'#
+ --0xc0 <= oc && oc <= 0xde && oc /= 0xd7 where oc = ord c
+isLowerISO (C# c#) = c# `geChar#` '\xdf'# && c# `leChar#` '\xff'# && c# `neChar#` '\xf7'#
+ --0xdf <= oc && oc <= 0xff && oc /= 0xf7 where oc = ord c
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Predicates and taking them apart}
+%* *
+%************************************************************************
+
+\begin{code}
+occNameString :: OccName -> String
+occNameString (OccName _ s _ _) = _UNPK_ s
+
+-- occNameFlavour is used only to generate good error messages, so it doesn't matter
+-- that the VarOcc case isn't mega-efficient. We could have different Occ constructors for
+-- data constructors and values, but that makes everything else a bit more complicated.
+occNameFlavour :: OccName -> String
+occNameFlavour (OccName VarOcc s _ _) | isLexConId s = "Data constructor"
+ | otherwise = "Value"
+occNameFlavour (OccName TvOcc _ _ _) = "Type variable"
+occNameFlavour (OccName TCOcc s _ _) = "Type constructor or class"
+
+isVarOcc, isTCOcc, isTvOcc,
+ isConSymOcc, isSymOcc :: OccName -> Bool
+
+isVarOcc (OccName VarOcc _ _ _) = True
+isVarOcc other = False
+
+isTvOcc (OccName TvOcc _ _ _) = True
+isTvOcc other = False
+
+isTCOcc (OccName TCOcc _ _ _) = True
+isTCOcc other = False
+
+isConSymOcc (OccName _ s _ _) = isLexConSym s
+
+isSymOcc (OccName _ s _ _) = isLexSym s
+
+isConOcc (OccName _ s _ _) = isLexCon s
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Comparison}
+%* *
+%************************************************************************
+
+Comparison is done by space and 'real' name
+
+\begin{code}
+instance Eq OccName where
+ a == b = case (a `compare` b) of { EQ -> True; _ -> False }
+ a /= b = case (a `compare` b) of { EQ -> False; _ -> True }
+
+instance Ord OccName where
+ a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False }
+ a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False }
+ a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True }
+ a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True }
+
+ compare (OccName sp1 r1 _ _) (OccName sp2 r2 _ _)
+ = (sp1 `compare` sp2) `thenCmp` (r1 `compare` r2)
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Tidying them up}
+%* *
+%************************************************************************
+
+Before we print chunks of code we like to rename it so that
+we don't have to print lots of silly uniques in it. But we mustn't
+accidentally introduce name clashes! So the idea is that we leave the
+OccName alone unless it accidentally clashes with one that is already
+in scope; if so, we tack on '1' at the end and try again, then '2', and
+so on till we find a unique one.
+
+There's a wrinkle for operators. Consider '>>='. We can't use '>>=1'
+because that isn't a single lexeme. So we encode it to 'lle' and *then*
+tack on the '1', if necessary.
+
+\begin{code}
+type TidyOccEnv = FiniteMap FAST_STRING Int -- The in-scope OccNames
+emptyTidyOccEnv = emptyFM
+
+initTidyOccEnv :: [OccName] -> TidyOccEnv -- Initialise with names to avoid!
+initTidyOccEnv = foldl (\env (OccName _ fs _ _) -> addToFM env fs 1) emptyTidyOccEnv
+
+tidyOccName :: TidyOccEnv -> OccName -> (TidyOccEnv, OccName)
+
+tidyOccName in_scope occ@(OccName occ_sp real _ _)
+ | not (real `elemFM` in_scope)
+ = (addToFM in_scope real 1, occ) -- First occurrence
+
+ | otherwise -- Already occurs
+ = -- First encode, to deal with
+ -- a) operators, and
+ -- b) trailing # signs
+ -- so that we can then append '1', '2', etc
+ go in_scope (encode_operator (_UNPK_ real))
+ where
+
+ go in_scope str = case lookupFM in_scope pk_str of
+ Just n -> go (addToFM in_scope pk_str (n+1)) (str ++ show n)
+ -- Need to go round again, just in case "t3" (say)
+ -- clashes with a "t3" that's already in scope
+
+ Nothing -> (addToFM in_scope pk_str 1, mkFsOcc occ_sp pk_str)
+ -- str is now unique
+ where
+ pk_str = _PK_ str
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Encoding for operators in derived names}
+%* *
+%************************************************************************
+
+See comments with mk_enc_deriv
+
+\begin{code}
+needs_encoding :: String -> Bool -- Needs encoding when embedded in a derived name
+ -- Just look at the first character
+needs_encoding (c:cs) = not (isAlpha c || c == '_')
+
+encode_operator :: String -> String
+encode_operator nm = foldr tran "" nm
+ where
+ tran c cs = case trChar c of
+ '\0' -> '_' : show (ord c) ++ cs -- No translation
+ tr_c -> tr_c : cs
+
+ trChar '&' = 'a'
+ trChar '|' = 'b'
+ trChar ':' = 'c'
+ trChar '/' = 'd'
+ trChar '=' = 'e'
+ trChar '>' = 'g'
+ trChar '#' = 'h'
+ trChar '@' = 'i'
+ trChar '<' = 'l'
+ trChar '-' = 'm'
+ trChar '!' = 'n'
+ trChar '+' = 'p'
+ trChar '\'' = 'q'
+ trChar '$' = 'r'
+ trChar '?' = 's'
+ trChar '*' = 't'
+ trChar '_' = 'u'
+ trChar '.' = 'v'
+ trChar '\\' = 'w'
+ trChar '%' = 'x'
+ trChar '~' = 'y'
+ trChar '^' = 'z'
+ trChar _ = '\0' -- No translation
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{The 'Z' encoding}
+%* *
+%************************************************************************
+
+We provide two interfaces for efficiency.
+
+\begin{code}
+identToC :: String -> FAST_STRING
+identToC str
+ | all isAlphanum str && not std = _PK_ str
+ | std = _PK_ ("Zs" ++ encode str)
+ | otherwise = _PK_ (encode str)
+ where
+ std = has_std_prefix str
+
+identFsToC :: FAST_STRING -> FAST_STRING
+identFsToC fast_str
+ | all isAlphanum str && not std = fast_str
+ | std = _PK_ ("Zs" ++ encode str)
+ | otherwise = _PK_ (encode str)
+ where
+ std = has_std_prefix str
+ str = _UNPK_ fast_str
+
+-- avoid "stdin", "stdout", and "stderr"...
+has_std_prefix ('s':'t':'d':_) = True
+has_std_prefix _ = False
+
+encode :: String -> String
+encode [] = []
+encode (c:cs) = encode_ch c ++ encode cs
+
+encode_ch :: Char -> String
+encode_ch c | isAlphanum c = [c]
+ -- Common case first
+encode_ch 'Z' = "ZZ"
+encode_ch '&' = "Za"
+encode_ch '|' = "Zb"
+encode_ch ':' = "Zc"
+encode_ch '/' = "Zd"
+encode_ch '=' = "Ze"
+encode_ch '>' = "Zg"
+encode_ch '#' = "Zh"
+encode_ch '<' = "Zl"
+encode_ch '-' = "Zm"
+encode_ch '!' = "Zn"
+encode_ch '.' = "Zd"
+encode_ch '\'' = "Zq"
+encode_ch '*' = "Zt"
+encode_ch '+' = "Zp"
+encode_ch '_' = "_"
+encode_ch c = 'Z':show (ord c)
+\end{code}
+
+For \tr{modnameToC}, we really only have to worry about \tr{'}s
+(quote chars) in the name. Rare.
+
+\begin{code}
+modnameToC :: FAST_STRING -> FAST_STRING
+modnameToC fast_str = identFsToC fast_str
+\end{code}
import {-# SOURCE #-} Const ( Con )
-import Var ( GenId, GenTyVar )
+import Var ( Id, TyVar )
import CostCentre ( CostCentre )
-import Type ( GenType )
+import Type ( Type )
import Outputable
\end{code}
%************************************************************************
\begin{code}
-data PprEnv bndr flexi
+data PprEnv bndr
= PE {
pCon :: Con -> SDoc,
pSCC :: CostCentre -> SDoc,
- pTyVarO :: GenTyVar flexi -> SDoc, -- to print tyvar occurrences
- pTy :: GenType flexi -> SDoc, -- to print types
+ pTyVarO :: TyVar -> SDoc, -- to print tyvar occurrences
+ pTy :: Type -> SDoc, -- to print types
pBndr :: BindingSite -> bndr -> SDoc, -- to print value binders
- pOcc :: GenId flexi -> SDoc -- to print value occurrences
+ pOcc :: Id -> SDoc -- to print value occurrences
}
\end{code}
initPprEnv
:: Maybe (Con -> SDoc)
-> Maybe (CostCentre -> SDoc)
- -> Maybe (GenTyVar flexi -> SDoc)
- -> Maybe (GenType flexi -> SDoc)
+ -> Maybe (TyVar -> SDoc)
+ -> Maybe (Type -> SDoc)
-> Maybe (BindingSite -> bndr -> SDoc)
- -> Maybe (GenId flexi -> SDoc)
- -> PprEnv bndr flexi
+ -> Maybe (Id -> SDoc)
+ -> PprEnv bndr
-- you can specify all the printers individually; if
-- you don't specify one, you get bottom
#include "HsVersions.h"
import Unique
-import Util
+import Panic ( panic )
import GlaExts
augmentIdKey,
boolTyConKey,
boundedClassKey,
- boxedKindConKey,
+ boxedConKey,
buildIdKey,
byteArrayPrimTyConKey,
cCallableClassKey,
noMethodBindingErrorIdKey,
nonExhaustiveGuardsErrorIdKey,
numClassKey,
- openKindConKey,
+ anyBoxConKey,
ordClassKey,
orderingTyConKey,
otherwiseIdKey,
stateTyConKey,
statePrimTyConKey,
- superKindConKey,
+ typeConKey,
+ kindConKey,
+ boxityConKey,
mVarPrimTyConKey,
thenMClassOpKey,
threadIdPrimTyConKey,
toEnumClassOpKey,
traceIdKey,
trueDataConKey,
- unboxedKindConKey,
+ unboxedConKey,
unpackCString2IdKey,
unpackCStringAppendIdKey,
unpackCStringFoldrIdKey,
#include "HsVersions.h"
-import FastString ( uniqueOfFS )
+import FastString ( FastString, uniqueOfFS )
import GlaExts
import ST
import PrelBase ( Char(..), chr, ord )
import Outputable
-import Util
\end{code}
%************************************************************************
word64PrimTyConKey = mkPreludeTyConUnique 62
word64TyConKey = mkPreludeTyConUnique 63
voidTyConKey = mkPreludeTyConUnique 64
-boxedKindConKey = mkPreludeTyConUnique 65
-unboxedKindConKey = mkPreludeTyConUnique 66
-openKindConKey = mkPreludeTyConUnique 67
-superKindConKey = mkPreludeTyConUnique 68
-threadIdPrimTyConKey = mkPreludeTyConUnique 69
-
+boxedConKey = mkPreludeTyConUnique 65
+unboxedConKey = mkPreludeTyConUnique 66
+anyBoxConKey = mkPreludeTyConUnique 67
+kindConKey = mkPreludeTyConUnique 68
+boxityConKey = mkPreludeTyConUnique 69
+typeConKey = mkPreludeTyConUnique 70
+threadIdPrimTyConKey = mkPreludeTyConUnique 71
\end{code}
%************************************************************************
Var, IdOrTyVar, -- Abstract
VarDetails(..), -- Concrete
varName, varUnique, varDetails, varInfo, varType,
- setVarName, setVarUnique, setVarType,
+ setVarName, setVarUnique, setVarType, setVarOcc,
-- TyVars
- TyVar, GenTyVar,
+ TyVar,
tyVarName, tyVarKind,
- tyVarFlexi, setTyVarFlexi, removeTyVarFlexi, setTyVarName, setTyVarUnique,
- mkFlexiTyVar, mkTyVar, mkSysTyVar, isTyVar, isFlexiTyVar,
+ setTyVarName, setTyVarUnique,
+ mkTyVar, mkSysTyVar, isTyVar,
+ newMutTyVar, readMutTyVar, writeMutTyVar, isMutTyVar, makeTyVarImmutable,
-- Ids
- Id, DictId, GenId,
- idName, idType, idUnique, idInfo, modifyIdInfo,
+ Id, DictId,
+ idDetails, idName, idType, idUnique, idInfo, modifyIdInfo,
setIdName, setIdUnique, setIdInfo,
mkId, isId, externallyVisibleId
) where
#include "HsVersions.h"
-import {-# SOURCE #-} Type( GenType, Kind )
+import {-# SOURCE #-} Type( Type, Kind )
import {-# SOURCE #-} IdInfo( IdInfo )
import {-# SOURCE #-} Const( Con )
import FieldLabel ( FieldLabel )
import Unique ( Unique, Uniquable(..), mkUniqueGrimily, getKey )
-import Name ( Name, NamedThing(..),
- changeUnique, nameUnique,
+import Name ( Name, OccName, NamedThing(..),
+ setNameUnique, setNameOcc, nameUnique,
mkSysLocalName, isExternallyVisibleName
)
import BasicTypes ( Unused )
import Outputable
+
+import IOExts ( IORef, newIORef, readIORef, writeIORef )
\end{code}
in its @VarDetails@.
\begin{code}
-type IdOrTyVar = Var Unused Unused
+type IdOrTyVar = Var
-data Var flex_self flex_ty
+data Var
= Var {
varName :: Name,
realUnique :: Int#, -- Key for fast comparison
-- Identical to the Unique in the name,
-- cached here for speed
- varType :: GenType flex_ty,
- varDetails :: VarDetails flex_self,
+ varType :: Type,
+ varDetails :: VarDetails,
varInfo :: IdInfo -- Only used for Ids at the moment
}
-varUnique Var{realUnique = uniq} = mkUniqueGrimily uniq
-
-data VarDetails flex_self
- = TyVar
- | FlexiTyVar flex_self -- Used during unification
- | VanillaId -- Most Ids are like this
- | ConstantId Con -- The Id for a constant (data constructor or primop)
- | RecordSelId FieldLabel -- The Id for a record selector
+data VarDetails
+ = VanillaId -- Most Ids are like this
+ | ConstantId Con -- The Id for a constant (data constructor or primop)
+ | RecordSelId FieldLabel -- The Id for a record selector
+ | TyVar
+ | MutTyVar (IORef (Maybe Type)) -- Used during unification
+
+-- For a long time I tried to keep mutable Vars statically type-distinct
+-- from immutable Vars, but I've finally given up. It's just too painful.
+-- After type checking there are no MutTyVars left, but there's no static check
+-- of that fact.
\end{code}
\begin{code}
-instance Outputable (Var fs ft) where
+instance Outputable Var where
ppr var = ppr (varName var)
-instance Show (Var fs ft) where
+instance Show Var where
showsPrec p var = showsPrecSDoc p (ppr var)
-instance NamedThing (Var fs ft) where
+instance NamedThing Var where
getName = varName
-instance Uniquable (Var fs ft) where
+instance Uniquable Var where
getUnique = varUnique
-instance Eq (Var fs ft) where
+instance Eq Var where
a == b = realUnique a ==# realUnique b
-instance Ord (Var fs ft) where
+instance Ord Var where
a <= b = realUnique a <=# realUnique b
a < b = realUnique a <# realUnique b
a >= b = realUnique a >=# realUnique b
\begin{code}
-setVarUnique :: Var fs ft -> Unique -> Var fs ft
+varUnique :: Var -> Unique
+varUnique (Var {realUnique = uniq}) = mkUniqueGrimily uniq
+
+setVarUnique :: Var -> Unique -> Var
setVarUnique var uniq = var {realUnique = getKey uniq,
- varName = changeUnique (varName var) uniq}
+ varName = setNameUnique (varName var) uniq}
-setVarName :: Var fs ft -> Name -> Var fs ft
+setVarName :: Var -> Name -> Var
setVarName var new_name
= var { realUnique = getKey (getUnique new_name), varName = new_name }
-setVarType :: Var flex_self flex_ty1 -> GenType flex_ty2 -> Var flex_self flex_ty2
+setVarOcc :: Var -> OccName -> Var
+setVarOcc var new_occ
+ = var { varName = setNameOcc (varName var) new_occ }
+
+setVarType :: Var -> Type -> Var
setVarType var ty = var {varType = ty}
\end{code}
%************************************************************************
\begin{code}
-type GenTyVar flex_self = Var flex_self Unused -- Perhaps a mutable tyvar, but
- -- with a fixed Kind
-
-type TyVar = GenTyVar Unused -- NOt even mutable
+type TyVar = Var
\end{code}
\begin{code}
setTyVarUnique = setVarUnique
setTyVarName = setVarName
-
-tyVarFlexi :: GenTyVar flexi -> flexi
-tyVarFlexi (Var {varDetails = FlexiTyVar flex}) = flex
-tyVarFlexi other_var = pprPanic "tyVarFlexi" (ppr other_var)
-
-setTyVarFlexi :: GenTyVar flexi1 -> flexi2 -> GenTyVar flexi2
-setTyVarFlexi var flex = var {varDetails = FlexiTyVar flex}
-
-removeTyVarFlexi :: GenTyVar flexi1 -> GenTyVar flexi2
-removeTyVarFlexi var = var {varDetails = TyVar}
\end{code}
\begin{code}
-mkTyVar :: Name -> Kind -> GenTyVar flexi
+mkTyVar :: Name -> Kind -> TyVar
mkTyVar name kind = Var { varName = name, realUnique = getKey (nameUnique name),
varType = kind, varDetails = TyVar }
-mkSysTyVar :: Unique -> Kind -> GenTyVar flexi
+mkSysTyVar :: Unique -> Kind -> TyVar
mkSysTyVar uniq kind = Var { varName = name, realUnique = getKey uniq,
varType = kind, varDetails = TyVar }
where
- name = mkSysLocalName uniq
+ name = mkSysLocalName uniq SLIT("t")
+
+newMutTyVar :: Name -> Kind -> IO TyVar
+newMutTyVar name kind =
+ do loc <- newIORef Nothing
+ return (Var { varName = name,
+ realUnique = getKey (nameUnique name),
+ varType = kind,
+ varDetails = MutTyVar loc })
+
+readMutTyVar :: TyVar -> IO (Maybe Type)
+readMutTyVar (Var {varDetails = MutTyVar loc}) = readIORef loc
+
+writeMutTyVar :: TyVar -> Maybe Type -> IO ()
+writeMutTyVar (Var {varDetails = MutTyVar loc}) val = writeIORef loc val
-mkFlexiTyVar :: Name -> Kind -> flexi -> GenTyVar flexi
-mkFlexiTyVar name kind flex = Var { varName = name,
- realUnique = getKey (nameUnique name),
- varType = kind,
- varDetails = FlexiTyVar flex }
+makeTyVarImmutable :: TyVar -> TyVar
+makeTyVarImmutable tyvar = tyvar { varDetails = TyVar}
\end{code}
\begin{code}
-isTyVar :: Var fs ft -> Bool
+isTyVar :: Var -> Bool
isTyVar (Var {varDetails = details}) = case details of
- TyVar -> True
- FlexiTyVar _ -> True
- other -> False
+ TyVar -> True
+ MutTyVar _ -> True
+ other -> False
-isFlexiTyVar :: Var fs ft -> Bool
-isFlexiTyVar (Var {varDetails = FlexiTyVar _}) = True
-isFlexiTyVar other = False
+isMutTyVar :: Var -> Bool
+isMutTyVar (Var {varDetails = MutTyVar _}) = True
+isMutTyVar other = False
\end{code}
Most Id-related functions are in Id.lhs and MkId.lhs
\begin{code}
-type GenId flex_ty = Var Unused flex_ty
-type Id = GenId Unused
-type DictId = Id
+type Id = Var
+type DictId = Id
\end{code}
\begin{code}
setIdName :: Id -> Name -> Id
setIdName = setVarName
-setIdInfo :: GenId flexi -> IdInfo -> GenId flexi
+setIdInfo :: Id -> IdInfo -> Id
setIdInfo var info = var {varInfo = info}
-modifyIdInfo :: GenId flexi -> (IdInfo -> IdInfo) -> GenId flexi
+modifyIdInfo :: Id -> (IdInfo -> IdInfo) -> Id
modifyIdInfo var@(Var {varInfo = info}) fn = var {varInfo = fn info}
\end{code}
\begin{code}
-mkId :: Name -> GenType flex_ty -> VarDetails Unused -> IdInfo -> GenId flex_ty
+mkId :: Name -> Type -> VarDetails -> IdInfo -> Id
mkId name ty details info
= Var {varName = name, realUnique = getKey (nameUnique name), varType = ty,
varDetails = details, varInfo = info}
\end{code}
\begin{code}
-isId :: Var fs ft -> Bool
+isId :: Var -> Bool
isId (Var {varDetails = details}) = case details of
VanillaId -> True
ConstantId _ -> True
lookupVarEnv, lookupVarEnv_NF,
mapVarEnv, zipVarEnv,
modifyVarEnv, modifyVarEnv_Directly,
- isEmptyVarEnv, foldVarEnv
+ isEmptyVarEnv, foldVarEnv,
+
+ TidyEnv, emptyTidyEnv
) where
#include "HsVersions.h"
-import Var ( Var, Id )
+import OccName ( TidyOccEnv, emptyTidyOccEnv )
+import Var ( Var, Id, IdOrTyVar )
import UniqFM
import Util ( zipEqual )
\end{code}
%************************************************************************
%* *
+\subsection{Tidying}
+%* *
+%************************************************************************
+
+When tidying up print names, we keep a mapping of in-scope occ-names
+(the TidyOccEnv) and a Var-to-Var of the current renamings.
+
+\begin{code}
+type TidyEnv = (TidyOccEnv, VarEnv IdOrTyVar)
+emptyTidyEnv = (emptyTidyOccEnv, emptyVarEnv)
+\end{code}
+
+
+%************************************************************************
+%* *
\subsection{@VarEnv@s}
%* *
%************************************************************************
type TyVarEnv elt = VarEnv elt
emptyVarEnv :: VarEnv a
-mkVarEnv :: [(Var fs ft, a)] -> VarEnv a
-zipVarEnv :: [Var fs ft] -> [a] -> VarEnv a
-unitVarEnv :: Var fs ft -> a -> VarEnv a
-extendVarEnv :: VarEnv a -> Var fs ft -> a -> VarEnv a
+mkVarEnv :: [(Var, a)] -> VarEnv a
+zipVarEnv :: [Var] -> [a] -> VarEnv a
+unitVarEnv :: Var -> a -> VarEnv a
+extendVarEnv :: VarEnv a -> Var -> a -> VarEnv a
plusVarEnv :: VarEnv a -> VarEnv a -> VarEnv a
-extendVarEnvList :: VarEnv a -> [(Var fs ft, a)] -> VarEnv a
+extendVarEnvList :: VarEnv a -> [(Var, a)] -> VarEnv a
-delVarEnvList :: VarEnv a -> [Var fs ft] -> VarEnv a
-delVarEnv :: VarEnv a -> Var fs ft -> VarEnv a
+delVarEnvList :: VarEnv a -> [Var] -> VarEnv a
+delVarEnv :: VarEnv a -> Var -> VarEnv a
plusVarEnv_C :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a
mapVarEnv :: (a -> b) -> VarEnv a -> VarEnv b
-modifyVarEnv :: (a -> a) -> VarEnv a -> Var fs ft -> VarEnv a
+modifyVarEnv :: (a -> a) -> VarEnv a -> Var -> VarEnv a
rngVarEnv :: VarEnv a -> [a]
isEmptyVarEnv :: VarEnv a -> Bool
-lookupVarEnv :: VarEnv a -> Var fs ft -> Maybe a
-lookupVarEnv_NF :: VarEnv a -> Var fs ft -> a
-elemVarEnv :: Var fs ft -> VarEnv a -> Bool
+lookupVarEnv :: VarEnv a -> Var -> Maybe a
+lookupVarEnv_NF :: VarEnv a -> Var -> a
+elemVarEnv :: Var -> VarEnv a -> Bool
foldVarEnv :: (a -> b -> b) -> b -> VarEnv a -> b
\end{code}
\begin{code}
module VarSet (
- VarSet, IdSet, GenIdSet, TyVarSet, GenTyVarSet, IdOrTyVarSet,
+ VarSet, IdSet, TyVarSet, IdOrTyVarSet,
emptyVarSet, unitVarSet, mkVarSet,
extendVarSet,
elemVarSet, varSetElems,
#include "HsVersions.h"
-import Var ( Var, Id, GenId, TyVar, GenTyVar, IdOrTyVar, setVarUnique )
+import Var ( Var, Id, TyVar, IdOrTyVar, setVarUnique )
import Unique ( Uniquable(..), incrUnique )
import UniqSet
import Outputable
%************************************************************************
\begin{code}
-type VarSet fs ft = UniqSet (Var fs ft)
-type IdSet = UniqSet Id
-type GenIdSet flexi = UniqSet (GenId flexi)
-type TyVarSet = UniqSet TyVar
-type GenTyVarSet flexi = UniqSet (GenTyVar flexi)
-type IdOrTyVarSet = UniqSet IdOrTyVar
+type VarSet = UniqSet Var
+type IdSet = UniqSet Id
+type TyVarSet = UniqSet TyVar
+type IdOrTyVarSet = UniqSet IdOrTyVar
-emptyVarSet :: VarSet fs ft
-intersectVarSet :: VarSet fs ft -> VarSet fs ft -> VarSet fs ft
-intersectsVarSet:: VarSet fs ft -> VarSet fs ft -> Bool -- True if non-empty intersection
-unionVarSet :: VarSet fs ft -> VarSet fs ft -> VarSet fs ft
-unionVarSets :: [VarSet fs ft] -> VarSet fs ft
-varSetElems :: VarSet fs ft -> [Var fs ft]
-unitVarSet :: Var fs ft -> VarSet fs ft
-extendVarSet :: VarSet fs ft -> Var fs ft -> VarSet fs ft
-elemVarSet :: Var fs ft -> VarSet fs ft -> Bool
-delVarSet :: VarSet fs ft -> Var fs ft -> VarSet fs ft
-minusVarSet :: VarSet fs ft -> VarSet fs ft -> VarSet fs ft
-isEmptyVarSet :: VarSet fs ft -> Bool
-mkVarSet :: [Var fs ft] -> VarSet fs ft
-foldVarSet :: (Var fs ft -> a -> a) -> a -> VarSet fs ft -> a
-lookupVarSet :: VarSet fs ft -> Var fs ft -> Maybe (Var fs ft)
+emptyVarSet :: VarSet
+intersectVarSet :: VarSet -> VarSet -> VarSet
+intersectsVarSet:: VarSet -> VarSet -> Bool -- True if non-empty intersection
+unionVarSet :: VarSet -> VarSet -> VarSet
+unionVarSets :: [VarSet] -> VarSet
+varSetElems :: VarSet -> [Var]
+unitVarSet :: Var -> VarSet
+extendVarSet :: VarSet -> Var -> VarSet
+elemVarSet :: Var -> VarSet -> Bool
+delVarSet :: VarSet -> Var -> VarSet
+minusVarSet :: VarSet -> VarSet -> VarSet
+isEmptyVarSet :: VarSet -> Bool
+mkVarSet :: [Var] -> VarSet
+foldVarSet :: (Var -> a -> a) -> a -> VarSet -> a
+lookupVarSet :: VarSet -> Var -> Maybe Var
-- Returns the set element, which may be
-- (==) to the argument, but not the same as
-mapVarSet :: (Var fs ft -> Var fs ft) -> VarSet fs ft -> VarSet fs ft
-filterVarSet :: (Var fs ft -> Bool) -> VarSet fs ft -> VarSet fs ft
+mapVarSet :: (Var -> Var) -> VarSet -> VarSet
+filterVarSet :: (Var -> Bool) -> VarSet -> VarSet
emptyVarSet = emptyUniqSet
unitVarSet = unitUniqSet
\end{code}
\begin{code}
-uniqAway :: VarSet fs ft -> Var fs ft -> Var fs ft
+uniqAway :: VarSet -> Var -> Var
-- Give the Var a new unique, different to any in the VarSet
uniqAway set var
= try 1 (incrUnique (getUnique var))
import StgSyn ( StgArg, StgLiveVars, GenStgArg(..) )
import Unique ( Unique, Uniquable(..) )
import UniqSet ( elementOfUniqSet )
-import Util ( zipWithEqual, panic, sortLt )
+import Util ( zipWithEqual, sortLt )
import Outputable
\end{code}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgCase.lhs,v 1.18 1998/12/02 13:17:46 simonm Exp $
+% $Id: CgCase.lhs,v 1.19 1998/12/18 17:40:48 simonpj Exp $
%
%********************************************************
%* *
import TyCon ( TyCon, isEnumerationTyCon, isUnboxedTupleTyCon,
isNewTyCon, isAlgTyCon,
tyConDataCons, tyConFamilySize )
-import Type ( GenType(..), typePrimRep, splitAlgTyConApp, Type,
+import Type ( Type, typePrimRep, splitAlgTyConApp, splitAlgTyConApp_maybe,
splitFunTys, applyTys )
import Unique ( Unique, Uniquable(..) )
import Maybes ( maybeToBool )
_ -> Just tc
splitAlgTyConAppThroughNewTypes :: Type -> Maybe (TyCon, [Type])
-splitAlgTyConAppThroughNewTypes (TyConApp tc tys)
- | isNewTyCon tc =
- case (tyConDataCons tc) of
- [con] -> let ([ty], _) = splitFunTys
- (applyTys (dataConType con) tys)
- in splitAlgTyConAppThroughNewTypes ty
- _ -> Nothing
- | otherwise = Just (tc, tys)
-
-splitAlgTyConAppThroughNewTypes (NoteTy _ ty) =
- splitAlgTyConAppThroughNewTypes ty
-splitAlgTyConAppThroughNewTypes other = Nothing
+splitAlgTyConAppThroughNewTypes ty
+ = case splitAlgTyConApp_maybe ty of
+ Just (tc, tys, cons)
+ | isNewTyCon tc -> splitAlgTyConAppThroughNewTypes ty
+ | otherwise -> Just (tc, tys)
+ where
+ ([ty], _) = splitFunTys (applyTys (dataConType (head cons)) tys)
+
+ other -> Nothing
\end{code}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgClosure.lhs,v 1.20 1998/12/02 13:17:47 simonm Exp $
+% $Id: CgClosure.lhs,v 1.21 1998/12/18 17:40:49 simonpj Exp $
%
\section[CgClosure]{Code generation for closures}
import CmdLineOpts ( opt_GranMacros, opt_SccProfilingOn )
import CostCentre
import Id ( Id, idName, idType, idPrimRep )
-import Name ( Name )
+import Name ( Name, Module, pprModule )
import ListSetOps ( minusList )
import PrimRep ( PrimRep(..) )
-import Type ( showTypeCategory )
+import PprType ( showTypeCategory )
import Util ( isIn )
import CmdLineOpts ( opt_SccProfilingOn )
import Outputable
binding information.
\begin{code}
-closureDescription :: FAST_STRING -- Module
+closureDescription :: Module -- Module
-> Name -- Id of closure binding
-> String
closureDescription mod_name name
= showSDoc (
hcat [char '<',
- ptext mod_name,
+ pprModule mod_name,
char '.',
ppr name,
char '>'])
import PrimRep ( PrimRep(..) )
import BasicTypes ( TopLevelFlag(..) )
import Util
+import Panic ( assertPanic )
\end{code}
%************************************************************************
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgExpr.lhs,v 1.16 1998/12/03 17:23:30 simonm Exp $
+% $Id: CgExpr.lhs,v 1.17 1998/12/18 17:40:50 simonpj Exp $
%
%********************************************************
%* *
import StgSyn
import CgMonad
import AbsCSyn
-import AbsCUtils ( mkAbstractCs )
import CLabel ( mkClosureTblLabel )
import SMRep ( fixedHdrSize )
\begin{code}
cgExpr (StgCon (Literal lit) args res_ty)
= ASSERT( null args )
- performPrimReturn (CLit lit)
+ performPrimReturn (text "literal" <+> ppr lit) (CLit lit)
\end{code}
let result_amode = CReg (dataReturnConvPrim kind) in
performReturn
(COpStmt [result_amode] op arg_amodes [{-no vol_regs-}])
- (\ sequel -> mkPrimReturnCode sequel)
+ (mkPrimReturnCode (text "primapp)" <+> ppr x))
-- otherwise, must be returning an enumerated type (eg. Bool).
-- we've only got the tag in R2, so we have to load the constructor
\begin{code}
primRetUnboxedTuple :: PrimOp -> [StgArg] -> Type -> Code
primRetUnboxedTuple op args res_ty
- = getArgAmodes args `thenFC` \ arg_amodes ->
- {-
- put all the arguments in temporaries so they don't get stomped when
- we push the return address.
- -}
- let
- n_args = length args
- arg_uniqs = map mkBuiltinUnique [0..n_args-1]
- arg_reps = map getArgPrimRep args
- arg_temps = zipWith CTemp arg_uniqs arg_reps
- in
- absC (mkAbstractCs (zipWith CAssign arg_temps arg_amodes)) `thenC`
- {-
- allocate some temporaries for the return values.
- -}
- let
- Just (tc,ty_args) = splitAlgTyConAppThroughNewTypes res_ty
+ = let (tc,ty_args) = case splitAlgTyConAppThroughNewTypes res_ty of
+ Nothing -> pprPanic "primRetUnboxedTuple" (ppr res_ty)
+ Just pr -> pr
+
prim_reps = map typePrimRep ty_args
- temp_uniqs = map mkBuiltinUnique [n_args..n_args+length ty_args-1]
+ temp_uniqs = map mkBuiltinUnique [0..length ty_args]
temp_amodes = zipWith CTemp temp_uniqs prim_reps
in
- returnUnboxedTuple temp_amodes (absC (COpStmt temp_amodes op arg_temps []))
+ returnUnboxedTuple temp_amodes
+ (getArgAmodes args `thenFC` \ arg_amodes ->
+ absC (COpStmt temp_amodes op arg_amodes []))
\end{code}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgHeapery.lhs,v 1.10 1998/12/02 13:17:50 simonm Exp $
+% $Id: CgHeapery.lhs,v 1.11 1998/12/18 17:40:51 simonpj Exp $
%
\section[CgHeapery]{Heap management functions}
closureSMRep
)
import PrimRep ( PrimRep(..), isFollowableRep )
-import Util ( panic )
import CmdLineOpts ( opt_SccProfilingOn )
import GlaExts
+import Outputable
#ifdef DEBUG
import PprAbsC ( pprMagicId ) -- tmp
-import Outputable -- tmp
#endif
\end{code}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
-% $Id: CgLetNoEscape.lhs,v 1.11 1998/12/02 13:17:50 simonm Exp $
+% $Id: CgLetNoEscape.lhs,v 1.12 1998/12/18 17:40:51 simonpj Exp $
%
%********************************************************
%* *
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgMonad.lhs,v 1.15 1998/12/02 13:17:50 simonm Exp $
+% $Id: CgMonad.lhs,v 1.16 1998/12/18 17:40:52 simonpj Exp $
%
\section[CgMonad]{The code generation monad}
import AbsCUtils ( mkAbsCStmts )
import CmdLineOpts ( opt_SccProfilingOn, opt_DoTickyProfiling )
import CLabel ( CLabel, mkUpdEntryLabel )
+import OccName ( Module )
import DataCon ( ConTag )
import Id ( Id )
import VarEnv
data CompilationInfo
= MkCompInfo
- FAST_STRING -- the module name
+ Module -- the module name
data CgState
= MkCgState
\begin{code}
-moduleName :: FCode FAST_STRING
+moduleName :: FCode Module
moduleName (MkCgInfoDown (MkCompInfo mod_name) _ _ _) state
= (mod_name, state)
%
% (c) The GRASP Project, Glasgow University, 1992-1998
%
-% $Id: CgRetConv.lhs,v 1.15 1998/12/02 13:17:51 simonm Exp $
+% $Id: CgRetConv.lhs,v 1.16 1998/12/18 17:40:52 simonpj Exp $
%
\section[CgRetConv]{Return conventions for the code generator}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgStackery.lhs,v 1.9 1998/12/02 13:17:51 simonm Exp $
+% $Id: CgStackery.lhs,v 1.10 1998/12/18 17:40:53 simonpj Exp $
%
\section[CgStackery]{Stack management functions}
import CgUsages ( getRealSp )
import AbsCUtils ( mkAbstractCs, mkAbsCStmts, getAmodeRep )
import PrimRep ( getPrimRepSize, PrimRep(..), isFollowableRep )
-import Util ( panic )
+import Panic ( panic )
\end{code}
%************************************************************************
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgTailCall.lhs,v 1.16 1998/12/02 13:17:52 simonm Exp $
+% $Id: CgTailCall.lhs,v 1.17 1998/12/18 17:40:53 simonpj Exp $
%
%********************************************************
%* *
import Type ( isUnLiftedType )
import TyCon ( TyCon )
import PrimOp ( PrimOp )
-import Util ( zipWithEqual, panic, assertPanic )
+import Util ( zipWithEqual )
+import Outputable
+import Panic ( panic, assertPanic )
\end{code}
%************************************************************************
cgTailCall fun []
| isUnLiftedType (idType fun)
= getCAddrMode fun `thenFC` \ amode ->
- performPrimReturn amode
+ performPrimReturn (ppr fun) amode
\end{code}
The general case (@fun@ is boxed):
%************************************************************************
\begin{code}
-performPrimReturn :: CAddrMode -- The thing to return
+performPrimReturn :: SDoc -- Just for debugging (sigh)
+ -> CAddrMode -- The thing to return
-> Code
-performPrimReturn amode
+performPrimReturn doc amode
= let
kind = getAmodeRep amode
ret_reg = dataReturnConvPrim kind
VoidRep -> AbsCNop
kind -> (CAssign (CReg ret_reg) amode)
in
- performReturn assign_possibly mkPrimReturnCode
+ performReturn assign_possibly (mkPrimReturnCode doc)
-mkPrimReturnCode :: Sequel -> Code
-mkPrimReturnCode UpdateCode = panic "mkPrimReturnCode: Upd"
-mkPrimReturnCode sequel = sequelToAmode sequel `thenFC` \ dest_amode ->
+mkPrimReturnCode :: SDoc -- Debugging only
+ -> Sequel
+ -> Code
+mkPrimReturnCode doc UpdateCode = pprPanic "mkPrimReturnCode: Upd" doc
+mkPrimReturnCode doc sequel = sequelToAmode sequel `thenFC` \ dest_amode ->
absC (CReturn dest_amode DirectReturn)
-- Direct, no vectoring
import CgStackery ( allocUpdateFrame )
import CgUsages ( getSpRelOffset )
import CmdLineOpts ( opt_SccProfilingOn )
-import Util ( assertPanic )
+import Panic ( assertPanic )
\end{code}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: ClosureInfo.lhs,v 1.31 1998/12/02 13:17:55 simonm Exp $
+% $Id: ClosureInfo.lhs,v 1.32 1998/12/18 17:40:54 simonpj Exp $
%
\section[ClosureInfo]{Data structures which describe closures}
opt_SccGroup
)
import CostCentre ( CostCentre, CostCentreStack )
-import CStrings ( modnameToC )
import FiniteMap ( FiniteMap )
import Id ( Id, idName )
-import Name ( Module )
+import Name ( Module, moduleCString, moduleString )
import PrimRep ( getPrimRepSize, PrimRep(..) )
import Type ( Type )
import TyCon ( TyCon )
import BasicTypes ( TopLevelFlag(..) )
import Util
+import Panic ( assertPanic )
\end{code}
\begin{code}
-codeGen :: FAST_STRING -- module name
+codeGen :: Module -- module name
-> ([CostCentre], -- local cost-centres needing declaring/registering
[CostCentre], -- "extern" cost-centres needing declaring
[CostCentreStack]) -- pre-defined "singleton" cost centre stacks
-----------------
grp_name = case opt_SccGroup of
Just xx -> _PK_ xx
- Nothing -> mod_name -- default: module name
+ Nothing -> _PK_ (moduleString mod_name) -- default: module name
-----------------
mkCcRegister ccs cc_stacks import_names
in
[
CCallProfCCMacro SLIT("START_REGISTER_CCS")
- [ CLitLit (modnameToC (SLIT("_reg") _APPEND_ mod_name)) AddrRep],
+ [ CLitLit (_PK_ ("_reg" ++ moduleCString mod_name)) AddrRep],
register_ccs,
register_cc_stacks,
register_imports,
mk_import_register import_name
= CCallProfCCMacro SLIT("REGISTER_IMPORT")
- [CLitLit (modnameToC (SLIT("_reg") _APPEND_ import_name)) AddrRep]
+ [CLitLit (_PK_ ("_reg" ++ moduleCString import_name)) AddrRep]
\end{code}
%************************************************************************
sTD_ITBL_SIZE, pROF_ITBL_SIZE,
gRAN_ITBL_SIZE, tICKY_ITBL_SIZE )
import Outputable
-import Util ( panic )
import GlaExts ( Int(..), Int#, (<#), (==#), (<#), (>#) )
\end{code}
returnL alt_ty)
where
check alt_ty1 alt_ty2 = checkTys alt_ty1 alt_ty2 (mkCaseAltMsg e)
+
+lintCoreExpr e@(Type ty)
+ = addErrL (mkStrangeTyMsg e)
\end{code}
%************************************************************************
pp_binders bs = sep (punctuate comma (map pp_binder bs))
pp_binder :: Id -> SDoc
-pp_binder b = hsep [ppr b, text "::", ppr (idType b)]
+pp_binder b = hsep [ppr b, dcolon, ppr (idType b)]
\end{code}
\begin{code}
mkKindErrMsg tyvar arg_ty
= vcat [ptext SLIT("Kinds don't match in type application:"),
hang (ptext SLIT("Type variable:"))
- 4 (ppr tyvar <+> ptext SLIT("::") <+> ppr (tyVarKind tyvar)),
+ 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
hang (ptext SLIT("Arg type:"))
- 4 (ppr arg_ty <+> ptext SLIT("::") <+> ppr (typeKind arg_ty))]
+ 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
mkTyAppMsg :: Type -> Type -> ErrMsg
mkTyAppMsg ty arg_ty
= vcat [text "Illegal type application:",
hang (ptext SLIT("Exp type:"))
- 4 (ppr ty <+> ptext SLIT("::") <+> ppr (typeKind ty)),
+ 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)),
hang (ptext SLIT("Arg type:"))
- 4 (ppr arg_ty <+> ptext SLIT("::") <+> ppr (typeKind arg_ty))]
+ 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
mkRhsMsg :: Id -> Type -> ErrMsg
mkRhsMsg binder ty
ptext SLIT("From-type:") <+> ppr from_ty,
ptext SLIT("Type of enclosed expr:") <+> ppr expr_ty
]
+
+mkStrangeTyMsg e
+ = ptext SLIT("Type where expression expected:") <+> ppr e
\end{code}
CoreExpr, CoreAlt, CoreBind, CoreArg, CoreBndr,
TaggedExpr, TaggedAlt, TaggedBind, TaggedArg,
- mkLets, mkLams,
+ mkLets, mkLetBinds, mkLams,
mkApps, mkTyApps, mkValApps,
mkLit, mkStringLit, mkConApp, mkPrimApp, mkNote, mkNilExpr,
bindNonRec, mkIfThenElse, varToCoreExpr,
import TysWiredIn ( boolTy, stringTy, nilDataCon )
import CostCentre ( CostCentre, isDupdCC, noCostCentre )
-import Var ( Var, GenId, Id, TyVar, IdOrTyVar, isTyVar, isId, idType )
+import Var ( Var, Id, TyVar, IdOrTyVar, isTyVar, isId, idType )
import Id ( mkWildId, getInlinePragma )
-import Type ( GenType, Type, mkTyVarTy, isUnLiftedType )
+import Type ( Type, mkTyVarTy, isUnLiftedType )
import IdInfo ( InlinePragInfo(..) )
-import BasicTypes ( Unused )
import Const ( Con(..), DataCon, Literal(NoRepStr), PrimOp )
import TysWiredIn ( trueDataCon, falseDataCon )
import Outputable
These data types are the heart of the compiler
\begin{code}
-data Expr b f -- "b" for the type of binders,
- -- "f" for the flexi slot in types
- = Var (GenId f)
- | Con Con [Arg b f] -- Guaranteed saturated
- | App (Expr b f) (Arg b f)
- | Lam b (Expr b f)
- | Let (Bind b f) (Expr b f)
- | Case (Expr b f) b [Alt b f] -- Binder gets bound to value of scrutinee
- -- DEFAULT case must be last, if it occurs at all
- | Note (Note f) (Expr b f)
- | Type (GenType f) -- This should only show up at the top
- -- level of an Arg
-
-type Arg b f = Expr b f -- Can be a Type
-
-type Alt b f = (Con, [b], Expr b f)
+data Expr b -- "b" for the type of binders,
+ = Var Id
+ | Con Con [Arg b] -- Guaranteed saturated
+ -- The Con can be a DataCon, Literal, PrimOP
+ -- but cannot be DEFAULT
+ | App (Expr b) (Arg b)
+ | Lam b (Expr b)
+ | Let (Bind b) (Expr b)
+ | Case (Expr b) b [Alt b] -- Binder gets bound to value of scrutinee
+ -- DEFAULT case must be last, if it occurs at all
+ | Note Note (Expr b)
+ | Type Type -- This should only show up at the top
+ -- level of an Arg
+
+type Arg b = Expr b -- Can be a Type
+
+type Alt b = (Con, [b], Expr b)
-- (DEFAULT, [], rhs) is the default alternative
- -- Remember, a Con can be a literal or a data constructor
+ -- The Con can be a Literal, DataCon, or DEFAULT, but cannot be PrimOp
-data Bind b f = NonRec b (Expr b f)
- | Rec [(b, (Expr b f))]
+data Bind b = NonRec b (Expr b)
+ | Rec [(b, (Expr b))]
-data Note f
+data Note
= SCC CostCentre
| Coerce
- (GenType f) -- The to-type: type of whole coerce expression
- (GenType f) -- The from-type: type of enclosed expression
+ Type -- The to-type: type of whole coerce expression
+ Type -- The from-type: type of enclosed expression
| InlineCall -- Instructs simplifier to inline
-- the enclosed call
\begin{code}
type CoreBndr = IdOrTyVar
-type CoreExpr = Expr CoreBndr Unused
-type CoreArg = Arg CoreBndr Unused
-type CoreBind = Bind CoreBndr Unused
-type CoreAlt = Alt CoreBndr Unused
-type CoreNote = Note Unused
+type CoreExpr = Expr CoreBndr
+type CoreArg = Arg CoreBndr
+type CoreBind = Bind CoreBndr
+type CoreAlt = Alt CoreBndr
+type CoreNote = Note
\end{code}
Binders are ``tagged'' with a \tr{t}:
\begin{code}
type Tagged t = (CoreBndr, t)
-type TaggedBind t = Bind (Tagged t) Unused
-type TaggedExpr t = Expr (Tagged t) Unused
-type TaggedArg t = Arg (Tagged t) Unused
-type TaggedAlt t = Alt (Tagged t) Unused
+type TaggedBind t = Bind (Tagged t)
+type TaggedExpr t = Expr (Tagged t)
+type TaggedArg t = Arg (Tagged t)
+type TaggedAlt t = Alt (Tagged t)
\end{code}
%************************************************************************
\begin{code}
-mkApps :: Expr b f -> [Arg b f] -> Expr b f
-mkTyApps :: Expr b f -> [GenType f] -> Expr b f
-mkValApps :: Expr b f -> [Expr b f] -> Expr b f
+mkApps :: Expr b -> [Arg b] -> Expr b
+mkTyApps :: Expr b -> [Type] -> Expr b
+mkValApps :: Expr b -> [Expr b] -> Expr b
mkApps f args = foldl App f args
mkTyApps f args = foldl (\ e a -> App e (Type a)) f args
mkValApps f args = foldl (\ e a -> App e a) f args
-mkLit :: Literal -> Expr b f
-mkStringLit :: String -> Expr b f
-mkConApp :: DataCon -> [Arg b f] -> Expr b f
-mkPrimApp :: PrimOp -> [Arg b f] -> Expr b f
+mkLit :: Literal -> Expr b
+mkStringLit :: String -> Expr b
+mkConApp :: DataCon -> [Arg b] -> Expr b
+mkPrimApp :: PrimOp -> [Arg b] -> Expr b
mkLit lit = Con (Literal lit) []
mkStringLit str = Con (Literal (NoRepStr (_PK_ str) stringTy)) []
| otherwise = Type (mkTyVarTy v)
\end{code}
+\begin{code}
+mkLams :: [b] -> Expr b -> Expr b
+mkLams binders body = foldr Lam body binders
\end{code}
\begin{code}
-mkLets :: [Bind b f] -> Expr b f -> Expr b f
+mkLets :: [Bind b] -> Expr b -> Expr b
mkLets binds body = foldr Let body binds
-mkLams :: [b] -> Expr b f -> Expr b f
-mkLams binders body = foldr Lam body binders
-\end{code}
+mkLetBinds :: [CoreBind] -> CoreExpr -> CoreExpr
+-- mkLetBinds is like mkLets, but it uses bindNonRec to
+-- make a case binding for unlifted things
+mkLetBinds [] body = body
+mkLetBinds (NonRec b r : binds) body = bindNonRec b r (mkLetBinds binds body)
+mkLetBinds (bind : binds) body = Let bind (mkLetBinds binds body)
-\begin{code}
bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
-- (bindNonRec x r b) produces either
-- let x = r in b
-- depending on whether x is unlifted or not
bindNonRec bndr rhs body
| isUnLiftedType (idType bndr) = Case rhs bndr [(DEFAULT,[],body)]
- | otherwise = Let (NonRec bndr rhs) body
+ | otherwise = Let (NonRec bndr rhs) body
mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
mkIfThenElse guard then_expr else_expr
mkNote removes redundant coercions, and SCCs where possible
\begin{code}
-mkNote :: Note f -> Expr b f -> Expr b f
+mkNote :: Note -> Expr b -> Expr b
mkNote (Coerce to_ty1 from_ty1) (Note (Coerce to_ty2 from_ty2) expr)
= ASSERT( from_ty1 == to_ty2 )
mkNote (Coerce to_ty1 from_ty2) expr
%************************************************************************
\begin{code}
-bindersOf :: Bind b f -> [b]
+bindersOf :: Bind b -> [b]
bindersOf (NonRec binder _) = [binder]
bindersOf (Rec pairs) = [binder | (binder, _) <- pairs]
-rhssOfBind :: Bind b f -> [Expr b f]
+rhssOfBind :: Bind b -> [Expr b]
rhssOfBind (NonRec _ rhs) = [rhs]
rhssOfBind (Rec pairs) = [rhs | (_,rhs) <- pairs]
-rhssOfAlts :: [Alt b f] -> [Expr b f]
+rhssOfAlts :: [Alt b] -> [Expr b]
rhssOfAlts alts = [e | (_,_,e) <- alts]
isDeadBinder :: CoreBndr -> Bool
order.
\begin{code}
-collectBinders :: Expr b f -> ([b], Expr b f)
+collectBinders :: Expr b -> ([b], Expr b)
collectTyBinders :: CoreExpr -> ([TyVar], CoreExpr)
collectValBinders :: CoreExpr -> ([Id], CoreExpr)
collectTyAndValBinders :: CoreExpr -> ([TyVar], [Id], CoreExpr)
and the arguments to which it is applied.
\begin{code}
-collectArgs :: Expr b f -> (Expr b f, [Arg b f])
+collectArgs :: Expr b -> (Expr b, [Arg b])
collectArgs expr
= go expr []
where
It looks inside lambdas because (scc "foo" \x.e) = \x.scc "foo" e
\begin{code}
-coreExprCc :: Expr b f -> CostCentre
+coreExprCc :: Expr b -> CostCentre
coreExprCc (Note (SCC cc) e) = cc
coreExprCc (Note other_note e) = coreExprCc e
coreExprCc (Lam _ e) = coreExprCc e
isTypeArg (Type _) = True
isTypeArg other = False
-valArgCount :: [Arg b f] -> Int
+valArgCount :: [Arg b] -> Int
valArgCount [] = 0
valArgCount (Type _ : args) = valArgCount args
valArgCount (other : args) = 1 + valArgCount args
| AnnApp (AnnExpr bndr annot) (AnnExpr bndr annot)
| AnnCase (AnnExpr bndr annot) bndr [AnnAlt bndr annot]
| AnnLet (AnnBind bndr annot) (AnnExpr bndr annot)
- | AnnNote (Note Unused) (AnnExpr bndr annot)
+ | AnnNote Note (AnnExpr bndr annot)
| AnnType Type
type AnnAlt bndr annot = (Con, [bndr], AnnExpr bndr annot)
\end{code}
\begin{code}
-deAnnotate :: AnnExpr bndr annot -> Expr bndr Unused
+deAnnotate :: AnnExpr bndr annot -> Expr bndr
deAnnotate (_, AnnType t) = Type t
deAnnotate (_, AnnVar v) = Var v
opt_UnfoldingUseThreshold,
opt_UnfoldingConDiscount,
opt_UnfoldingKeenessFactor,
- opt_UnfoldCasms
+ opt_UnfoldCasms, opt_PprStyle_Debug
)
import Constants ( uNFOLDING_CHEAP_OP_COST,
uNFOLDING_DEAR_OP_COST,
import Type ( splitAlgTyConApp_maybe )
import Const ( isNoRepLit )
import Unique ( Unique )
-import Util ( isIn, panic )
+import Util ( isIn )
import Outputable
\end{code}
\begin{code}
smallEnoughToInline :: Id -- The function (trace msg only)
-> [Bool] -- Evaluated-ness of value arguments
+ -- ** May be infinite in don't care cases **
+ -- see couldBeSmallEnoughToInline etc
-> Bool -- Result is scrutinised
-> UnfoldingGuidance
-> Bool -- True => unfold it
smallEnoughToInline _ _ _ UnfoldAlways = True
smallEnoughToInline _ _ _ UnfoldNever = False
-smallEnoughToInline id arg_is_evald_s result_is_scruted
- (UnfoldIfGoodArgs m_tys_wanted n_vals_wanted discount_vec size scrut_discount)
- = if enough_args n_vals_wanted arg_is_evald_s &&
- size - discount <= opt_UnfoldingUseThreshold
- then
- True
+smallEnoughToInline id arg_evals result_is_scruted
+ (UnfoldIfGoodArgs m_tys_wanted n_vals_wanted discount_vec size scrut_discount)
+ | fun_with_no_args
+ = False
+
+ | (size - discount) > opt_UnfoldingUseThreshold
+ = if opt_PprStyle_Debug then
+ pprTrace " too big:" stuff False
else
- False
+ False
+
+ | otherwise -- All right!
+ = if opt_PprStyle_Debug then
+ pprTrace " small enough:" stuff True
+ else
+ True
+
where
+ stuff = braces (ppr id <+> ppr (take 10 arg_evals) <+> ppr result_is_scruted <+>
+ ppr size <+> ppr discount)
- enough_args n [] | n > 0 = False -- A function with no value args => don't unfold
- enough_args _ _ = True -- Otherwise it's ok to try
+ fun_with_no_args = n_vals_wanted > 0 && null arg_evals
+ -- A *function* with *no* value args => don't unfold
+ -- Otherwise it's ok to try
-- We multiple the raw discounts (args_discount and result_discount)
-- ty opt_UnfoldingKeenessFactor because the former have to do with
-- reduce with the lambdas in the function (we count 1 for a lambda
-- in size_up).
+ -- NB: we never take the length of arg_evals because it might be infinite
discount :: Int
- discount = length (take n_vals_wanted arg_is_evald_s) +
- round (
- opt_UnfoldingKeenessFactor *
- fromInt (args_discount + result_discount)
- )
+ discount = length (take n_vals_wanted arg_evals) +
+ round (opt_UnfoldingKeenessFactor *
+ fromInt (arg_discount + result_discount))
- args_discount = sum (zipWith arg_discount discount_vec arg_is_evald_s)
- result_discount | result_is_scruted = scrut_discount
- | otherwise = 0
+ arg_discount = sum (zipWith mk_arg_discount discount_vec arg_evals)
+ result_discount = mk_result_discount (drop n_vals_wanted arg_evals)
- arg_discount no_of_constrs is_evald
+ mk_arg_discount no_of_constrs is_evald
| is_evald = no_of_constrs * opt_UnfoldingConDiscount
| otherwise = 0
+
+ mk_result_discount extra_args
+ | not (null extra_args) || result_is_scruted = scrut_discount -- Over-applied, or case scrut
+ | otherwise = 0
\end{code}
We use this one to avoid exporting inlinings that we ``couldn't possibly
module CoreUtils (
IdSubst, SubstCoreExpr(..),
- coreExprType, exprFreeVars, exprSomeFreeVars,
+ coreExprType, coreAltsType, exprFreeVars, exprSomeFreeVars,
exprIsBottom, exprIsDupable, exprIsTrivial, exprIsWHNF, exprIsCheap,
FormSummary(..), mkFormSummary, whnfOrBottom,
import VarEnv
import Name ( isLocallyDefined )
import Const ( Con(..), isWHNFCon, conIsTrivial, conIsCheap )
-import Id ( Id, idType, setIdType, idUnique, isBottomingId,
+import Id ( Id, idType, setIdType, idUnique, idAppIsBottom,
getIdArity, idFreeTyVars,
getIdSpecialisation, setIdSpecialisation,
getInlinePragma, setInlinePragma,
\begin{code}
coreExprType :: CoreExpr -> Type
-coreExprType (Var var) = idType var
-coreExprType (Let _ body) = coreExprType body
-coreExprType (Case _ _ ((_,_,rhs):_)) = coreExprType rhs
-
+coreExprType (Var var) = idType var
+coreExprType (Let _ body) = coreExprType body
+coreExprType (Case _ _ alts) = coreAltsType alts
coreExprType (Note (Coerce ty _) e) = ty
coreExprType (Note other_note e) = coreExprType e
-
-coreExprType e@(Con con args) = applyTypeToArgs e (conType con) args
+coreExprType e@(Con con args) = applyTypeToArgs e (conType con) args
coreExprType (Lam binder expr)
| isId binder = idType binder `mkFunTy` coreExprType expr
(fun, args) -> applyTypeToArgs e (coreExprType fun) args
coreExprType other = pprTrace "coreExprType" (ppr other) alphaTy
+
+coreAltsType :: [CoreAlt] -> Type
+coreAltsType ((_,_,rhs) : _) = coreExprType rhs
\end{code}
\begin{code}
go n (App fun (Type _)) = go n fun -- Ignore type args
go n (App fun arg) = go (n+1) fun
- go n (Var f) | isBottomingId f = BottomForm
- go 0 (Var f) = VarForm
+ go n (Var f) | idAppIsBottom f n = BottomForm
+ go 0 (Var f) = VarForm
go n (Var f) | n < arityLowerBound (getIdArity f) = ValueForm
| otherwise = OtherForm
\end{code}
exprIsCheap other_expr -- look for manifest partial application
= case collectArgs other_expr of
- (Var f, _) | isBottomingId f -> True -- Application of a function which
- -- always gives bottom; we treat this as
- -- a WHNF, because it certainly doesn't
- -- need to be shared!
+ (Var f, args) | idAppIsBottom f (length args)
+ -> True -- Application of a function which
+ -- always gives bottom; we treat this as
+ -- a WHNF, because it certainly doesn't
+ -- need to be shared!
(Var f, args) ->
let
\begin{code}
exprIsBottom :: CoreExpr -> Bool -- True => definitely bottom
-exprIsBottom (Note _ e) = exprIsBottom e
-exprIsBottom (Let _ e) = exprIsBottom e
-exprIsBottom (Case e _ _) = exprIsBottom e -- Just chek the scrut
-exprIsBottom (Con _ _) = False
-exprIsBottom (App e _) = exprIsBottom e
-exprIsBottom (Var v) = isBottomingId v
-exprIsBottom (Lam _ _) = False
+exprIsBottom e = go 0 e
+ where
+ -- n is the number of args
+ go n (Note _ e) = go n e
+ go n (Let _ e) = go n e
+ go n (Case e _ _) = go 0 e -- Just check the scrut
+ go n (App e _) = go (n+1) e
+ go n (Var v) = idAppIsBottom v n
+ go n (Con _ _) = False
+ go n (Lam _ _) = False
\end{code}
exprIsWHNF reports True for head normal forms. Note that does not necessarily
I don't like this function but I'n not confidnt enough to change it.
\begin{code}
-squashableDictishCcExpr :: CostCentre -> Expr b f -> Bool
+squashableDictishCcExpr :: CostCentre -> Expr b -> Bool
squashableDictishCcExpr cc expr
| isDictCC cc = False -- that was easy...
| otherwise = squashable expr
False => may or may not be equal
\begin{code}
-cheapEqExpr :: Expr b f -> Expr b f -> Bool
+cheapEqExpr :: Expr b -> Expr b -> Bool
cheapEqExpr (Var v1) (Var v2) = v1==v2
cheapEqExpr (Con con1 args1) (Con con2 args2)
\end{code}
\begin{code}
-instance Outputable b => Outputable (Bind b f) where
+instance Outputable b => Outputable (Bind b) where
ppr bind = ppr_bind pprGenericEnv bind
-instance Outputable b => Outputable (Expr b f) where
+instance Outputable b => Outputable (Expr b) where
ppr expr = ppr_expr pprGenericEnv expr
-pprGenericEnv :: Outputable b => PprEnv b f
+pprGenericEnv :: Outputable b => PprEnv b
pprGenericEnv = initCoreEnv (\site -> ppr)
\end{code}
\end{code}
\begin{code}
-ppr_bind :: PprEnv b f -> Bind b f -> SDoc
+ppr_bind :: PprEnv b -> Bind b -> SDoc
ppr_bind pe (NonRec val_bdr expr) = ppr_binding_pe pe (val_bdr, expr)
ppr_bind pe (Rec binds) = vcat (map pp binds)
where
pp bind = ppr_binding_pe pe bind <> semi
-ppr_binding_pe :: PprEnv b f -> (b, Expr b f) -> SDoc
+ppr_binding_pe :: PprEnv b -> (b, Expr b) -> SDoc
ppr_binding_pe pe (val_bdr, expr)
= sep [pBndr pe LetBind val_bdr,
nest 2 (equals <+> ppr_expr pe expr)]
\end{code}
\begin{code}
-ppr_expr :: PprEnv b f -> Expr b f -> SDoc
+ppr_expr :: PprEnv b -> Expr b -> SDoc
ppr_expr pe (Type ty) = ptext SLIT("TYPE") <+> ppr ty -- Wierd
pprTypedBinder binder
| isTyVar binder = ptext SLIT("__a") <+> pprTyVarBndr binder
- | otherwise = pprIdBndr binder <+> ptext SLIT("::") <+> pprParendType (idType binder)
+ | otherwise = pprIdBndr binder <+> dcolon <+> pprParendType (idType binder)
-- The space before the :: is important; it helps the lexer
-- when reading inferfaces. Otherwise it would lex "a::b" as one thing.
--
import Id ( idType )
import DataCon ( DataCon, isTupleCon, isUnboxedTupleCon,
dataConSourceArity )
-import Name ( Name, occNameString,
- getOccName, getOccString, isLexConSym
- )
+import Name ( Name, mkLocalName, getOccName, isConSymOcc, getName, varOcc )
import Type ( Type,
isUnboxedType,
splitTyConApp_maybe
wordTy, wordDataCon,
stringTy
)
+import Unique ( unboundKey )
import TyCon ( tyConDataCons )
import UniqSet
import Outputable
\begin{code}
-newtype BoxedString = BS String
+newtype BoxedString = BS Name
type WarningPat = InPat BoxedString
type ExhaustivePat = ([WarningPat], [(BoxedString, [HsLit])])
instance Outputable BoxedString where
- ppr (BS s) = text s
+ ppr (BS n) = ppr n
check :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
untidy _ (ListPatIn pats) = ListPatIn (map untidy_no_pars pats)
untidy _ (TuplePatIn pats boxed) = TuplePatIn (map untidy_no_pars pats) boxed
+untidy _ (SigPatIn pat ty) = panic "Check.untidy: SigPatIn"
untidy _ (LazyPatIn pat) = panic "Check.untidy: LazyPatIn"
untidy _ (AsPatIn name pat) = panic "Check.untidy: AsPatIn"
untidy _ (NPlusKPatIn name lit) = panic "Check.untidy: NPlusKPatIn"
make_row_vars :: [HsLit] -> EquationInfo -> ExhaustivePat
make_row_vars used_lits (EqnInfo _ _ pats _ ) =
(VarPatIn new_var:take (length (tail pats)) (repeat new_wild_pat),[(new_var,used_lits)])
- where new_var = BS "#x"
+ where new_var = BS hash_x
+
+hash_x = mkLocalName unboundKey {- doesn't matter much -}
+ (varOcc SLIT("#x"))
make_row_vars_for_constructor :: EquationInfo -> [WarningPat]
make_row_vars_for_constructor (EqnInfo _ _ pats _ ) = take (length (tail pats)) (repeat new_wild_pat)
\begin{code}
-isInfixCon con = isLexConSym (occNameString (getOccName con))
+isInfixCon con = isConSymOcc (getOccName con)
-is_nil (ConPatIn (BS con) []) = con == getOccString nilDataCon
+is_nil (ConPatIn (BS con) []) = con == getName nilDataCon
is_nil _ = False
is_list (ListPatIn _) = True
make_con (ConPat id _ _ _ _) (p:q:ps, constraints)
| return_list id q = (make_list p q : ps, constraints)
| isInfixCon id = ((ConOpPatIn p name fixity q) : ps, constraints)
- where name = BS (getOccString id)
+ where name = BS (getName id)
fixity = panic "Check.make_con: Guessing fixity"
make_con (ConPat id _ _ _ pats) (ps,constraints)
| isUnboxedTupleCon id = (TuplePatIn pats_con False : rest_pats, constraints)
| otherwise = (ConPatIn name pats_con : rest_pats, constraints)
where num_args = length pats
- name = BS (getOccString id)
+ name = BS (getName id)
pats_con = take num_args ps
rest_pats = drop num_args ps
| otherwise = ConPatIn name pats
where
fixity = panic "Check.make_whole_con: Guessing fixity"
- name = BS (getOccString con)
+ name = BS (getName con)
arity = dataConSourceArity con
pats = take arity (repeat new_wild_pat)
simplify_pat pat@(WildPat gt) = pat
simplify_pat (VarPat id) = WildPat (idType id)
-simplify_pat (LazyPat p) = simplify_pat p
-
-simplify_pat (AsPat id p) = simplify_pat p
+simplify_pat (LazyPat p) = simplify_pat p
+simplify_pat (AsPat id p) = simplify_pat p
simplify_pat (ConPat id ty tvs dicts ps) = ConPat id ty tvs dicts (map simplify_pat ps)
import DsUtils
import DsExpr () -- Forces DsExpr to be compiled; DsBinds only
-- depends on DsExpr.hi-boot.
-
+import Name ( Module, moduleString )
import Bag ( isEmptyBag )
-import BasicTypes ( Module )
import CmdLineOpts ( opt_SccGroup, opt_SccProfilingOn )
import CoreLint ( beginPass, endPass )
import ErrUtils ( doIfSet )
\begin{code}
deSugar :: UniqSupply -- name supply
- -> GlobalValueEnv -- value env
+ -> ValueEnv -- value env
-> Module -- module name
-> TypecheckedMonoBinds
-> [TypecheckedForeignDecl]
module_and_group = (mod_name, grp_name)
grp_name = case opt_SccGroup of
Just xx -> _PK_ xx
- Nothing -> mod_name -- default: module name
+ Nothing -> _PK_ (moduleString mod_name) -- default: module name
\end{code}
import DsUtils
import Match ( matchWrapper )
-import BasicTypes ( Module, RecFlag(..) )
+import BasicTypes ( RecFlag(..) )
import CmdLineOpts ( opt_SccProfilingOn, opt_AutoSccsOnAllToplevs,
opt_AutoSccsOnExportedToplevs
)
import CostCentre ( mkAutoCC, IsCafCC(..), mkAllDictsCC )
import Id ( idType, Id )
import VarEnv
-import Name ( isExported )
+import Name ( Module, isExported )
import Type ( mkTyVarTy, isDictTy, substTy
)
import TysWiredIn ( voidTy )
where
error_string = "function " ++ showSDoc (ppr fun)
-dsMonoBinds _ (PatMonoBind pat grhss_and_binds locn) rest
+dsMonoBinds _ (PatMonoBind pat grhss locn) rest
= putSrcLocDs locn $
- dsGuarded grhss_and_binds `thenDs` \ body_expr ->
+ dsGuarded grhss `thenDs` \ body_expr ->
mkSelectorBinds pat body_expr `thenDs` \ sel_binds ->
returnDs (sel_binds ++ rest)
import TysPrim ( byteArrayPrimTy, realWorldStatePrimTy,
byteArrayPrimTyCon, mutableByteArrayPrimTyCon )
import TysWiredIn ( unitDataCon, stringTy,
- mkUnboxedTupleTy, unboxedPairDataCon,
+ unboxedPairDataCon,
mkUnboxedTupleTy, unboxedTupleCon
)
import Outputable
import HsSyn ( failureFreePat,
HsExpr(..), OutPat(..), HsLit(..), ArithSeqInfo(..),
Stmt(..), StmtCtxt(..), Match(..), HsBinds(..), MonoBinds(..),
+ mkSimpleMatch
)
import TcHsSyn ( TypecheckedHsExpr, TypecheckedHsBinds,
TypecheckedStmt,
dsLet b1 body'
-- Special case for bindings which bind unlifted variables
-dsLet (MonoBind (AbsBinds [] [] binder_triples bind) sigs is_rec) body
+dsLet (MonoBind (AbsBinds [] [] binder_triples (PatMonoBind pat grhss loc)) sigs is_rec) body
| or [isUnLiftedType (idType g) | (_, g, l) <- binder_triples]
= ASSERT (case is_rec of {NonRecursive -> True; other -> False})
- putSrcLocDs loc $
- dsGuarded grhss `thenDs` \ rhs ->
+ putSrcLocDs loc $
+ dsGuarded grhss `thenDs` \ rhs ->
let
body' = foldr bind body binder_triples
bind (tyvars, g, l) body = ASSERT( null tyvars )
mkErrorAppDs iRREFUT_PAT_ERROR_ID result_ty (showSDoc (ppr pat)) `thenDs` \ error_expr ->
matchSimply rhs PatBindMatch pat body' error_expr
where
- PatMonoBind pat grhss loc = bind
- result_ty = coreExprType body
+ result_ty = coreExprType body
-- Ordinary case for bindings
dsLet (MonoBind binds sigs is_rec) body
-- special case to handle unboxed tuple patterns
-dsExpr (HsCase discrim matches@[PatMatch (TuplePat ps boxed) (GRHSMatch rhs)]
- src_loc)
+dsExpr (HsCase discrim matches@[Match _ [TuplePat ps boxed] _ _] src_loc)
| all var_pat ps
= putSrcLocDs src_loc $
dsExpr discrim `thenDs` \ core_discrim ->
let
(_, a_ty) = splitAppTy (coreExprType expr2) -- Must be of form (m a)
zero_expr = TyApp (HsVar zero_id) [b_ty]
- main_match = PatMatch pat (SimpleMatch (
- HsDoOut do_or_lc stmts return_id then_id zero_id result_ty locn))
+ main_match = mkSimpleMatch [pat] (HsDoOut do_or_lc stmts return_id then_id zero_id result_ty locn)
+ (Just result_ty) locn
the_matches
= if failureFreePat pat
then [main_match]
- else [main_match, PatMatch (WildPat a_ty) (SimpleMatch zero_expr)]
+ else [main_match, mkSimpleMatch [WildPat a_ty] zero_expr (Just result_ty) locn]
in
matchWrapper DoBindMatch the_matches match_msg
`thenDs` \ (binders, matching_code) ->
import {-# SOURCE #-} DsExpr ( dsExpr, dsLet )
import {-# SOURCE #-} Match ( matchSinglePat )
-import HsSyn ( GRHSsAndBinds(..), Stmt(..), HsExpr(..), GRHS(..) )
-import TcHsSyn ( TypecheckedGRHSsAndBinds, TypecheckedGRHS,
- TypecheckedPat, TypecheckedStmt
- )
+import HsSyn ( Stmt(..), HsExpr(..), GRHSs(..), GRHS(..) )
+import TcHsSyn ( TypecheckedGRHSs, TypecheckedPat, TypecheckedStmt )
import CoreSyn ( CoreExpr, Bind(..) )
+import Type ( Type )
import DsMonad
import DsUtils
necessary. The type argument gives the type of the ei.
\begin{code}
-dsGuarded :: TypecheckedGRHSsAndBinds
- -> DsM CoreExpr
+dsGuarded :: TypecheckedGRHSs -> DsM CoreExpr
-dsGuarded (GRHSsAndBindsOut grhss binds err_ty)
- = dsGRHSs PatBindMatch [] grhss `thenDs` \ match_result ->
+dsGuarded grhss
+ = dsGRHSs PatBindMatch [] grhss `thenDs` \ (err_ty, match_result) ->
mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID err_ty "" `thenDs` \ error_expr ->
- extractMatchResult match_result error_expr `thenDs` \ body ->
- dsLet binds body
+ extractMatchResult match_result error_expr
\end{code}
-Desugar a list of (grhs, expr) pairs [grhs = guarded
-right-hand-side], as in:
-\begin{verbatim}
-p | g1 = e1
- | g2 = e2
- ...
- | gm = em
-\end{verbatim}
-We supply a @CoreExpr@ for the case in which all of
-the guards fail.
+In contrast, @dsGRHSs@ produces a @MatchResult@.
\begin{code}
dsGRHSs :: DsMatchKind -> [TypecheckedPat] -- These are to build a MatchContext from
- -> [TypecheckedGRHS] -- Guarded RHSs
- -> DsM MatchResult
-
-dsGRHSs kind pats [grhs] = dsGRHS kind pats grhs
-
-dsGRHSs kind pats (grhs:grhss)
- = dsGRHS kind pats grhs `thenDs` \ match_result1 ->
- dsGRHSs kind pats grhss `thenDs` \ match_result2 ->
- returnDs (combineMatchResults match_result1 match_result2)
+ -> TypecheckedGRHSs -- Guarded RHSs
+ -> DsM (Type, MatchResult)
+
+dsGRHSs kind pats (GRHSs grhss binds (Just ty))
+ = mapDs (dsGRHS kind pats) grhss `thenDs` \ match_results ->
+ let
+ match_result1 = foldr1 combineMatchResults match_results
+ match_result2 = adjustMatchResultDs (dsLet binds) match_result1
+ -- NB: nested dsLet inside matchResult
+ in
+ returnDs (ty, match_result2)
dsGRHS kind pats (GRHS guard locn)
= matchGuard guard (DsMatchContext kind pats locn)
import Id ( idType, Id )
import Type ( Type )
import TysWiredIn ( mkListTy, mkTupleTy, mkUnboxedTupleTy, unitTy )
-import Util ( panic )
+import Panic ( panic )
\end{code}
Note: If @outPatType@ doesn't bear a strong resemblance to @coreExprType@,
\begin{code}
collectTypedMonoBinders :: TypecheckedMonoBinds -> [Id]
-collectTypedMonoBinders EmptyMonoBinds = []
-collectTypedMonoBinders (PatMonoBind pat _ _) = collectTypedPatBinders pat
-collectTypedMonoBinders (FunMonoBind f _ _ _) = [f]
-collectTypedMonoBinders (VarMonoBind v _) = [v]
-collectTypedMonoBinders (CoreMonoBind v _) = [v]
+collectTypedMonoBinders EmptyMonoBinds = []
+collectTypedMonoBinders (PatMonoBind pat _ _) = collectTypedPatBinders pat
+collectTypedMonoBinders (FunMonoBind f _ _ _) = [f]
+collectTypedMonoBinders (VarMonoBind v _) = [v]
+collectTypedMonoBinders (CoreMonoBind v _) = [v]
collectTypedMonoBinders (AndMonoBinds bs1 bs2)
= collectTypedMonoBinders bs1 ++ collectTypedMonoBinders bs2
collectTypedMonoBinders (AbsBinds _ _ exports _)
getUniqueDs,
dsLookupGlobalValue,
- GlobalValueEnv,
+ ValueEnv,
dsWarn,
DsWarnings,
DsMatchContext(..), DsMatchKind(..), pprDsWarnings
#include "HsVersions.h"
import Bag ( emptyBag, snocBag, bagToList, Bag )
-import BasicTypes ( Module )
import ErrUtils ( WarnMsg )
import HsSyn ( OutPat )
import Id ( mkUserLocal, mkSysLocal, setIdUnique, Id )
-import Name ( Name, varOcc, maybeWiredInIdName )
+import Name ( Module, Name, maybeWiredInIdName )
import Var ( TyVar, setTyVarUnique )
import VarEnv
import Outputable
import SrcLoc ( noSrcLoc, SrcLoc )
import TcHsSyn ( TypecheckedPat )
-import TcEnv ( GlobalValueEnv )
+import TcEnv ( ValueEnv )
import Type ( Type )
import UniqSupply ( initUs, splitUniqSupply, uniqFromSupply, uniqsFromSupply,
UniqSM, UniqSupply )
import Unique ( Unique )
import UniqFM ( lookupWithDefaultUFM )
-import Util ( zipWithEqual, panic )
+import Util ( zipWithEqual )
infixr 9 `thenDs`
\end{code}
\begin{code}
type DsM result =
UniqSupply
- -> GlobalValueEnv
+ -> ValueEnv
-> SrcLoc -- to put in pattern-matching error msgs
-> (Module, Group) -- module + group name : for SCC profiling
-> DsWarnings
-- initDs returns the UniqSupply out the end (not just the result)
initDs :: UniqSupply
- -> GlobalValueEnv
+ -> ValueEnv
-> (Module, Group) -- module name: for profiling; (group name: from switches)
-> DsM a
-> (a, DsWarnings)
newSysLocalDs, newFailLocalDs :: Type -> DsM Id
newSysLocalDs ty us genv loc mod_and_grp warns
= case uniqFromSupply us of { assigned_uniq ->
- (mkSysLocal assigned_uniq ty, warns) }
+ (mkSysLocal SLIT("ds") assigned_uniq ty, warns) }
newSysLocalsDs tys = mapDs newSysLocalDs tys
newFailLocalDs ty us genv loc mod_and_grp warns
= case uniqFromSupply us of { assigned_uniq ->
- (mkUserLocal (varOcc SLIT("fail")) assigned_uniq ty, warns) }
+ (mkSysLocal SLIT("fail") assigned_uniq ty, warns) }
-- The UserLocal bit just helps make the code a little clearer
getUniqueDs :: DsM Unique
\end{code}
\begin{code}
-getModuleAndGroupDs :: DsM (FAST_STRING, FAST_STRING)
+getModuleAndGroupDs :: DsM (Module, Group)
getModuleAndGroupDs us genv loc mod_and_grp warns
= (mod_and_grp, warns)
\end{code}
\begin{code}
selectMatchVar :: TypecheckedPat -> DsM Id
-selectMatchVar (VarPat var) = returnDs var
-selectMatchVar (AsPat var pat) = returnDs var
-selectMatchVar (LazyPat pat) = selectMatchVar pat
-selectMatchVar other_pat = newSysLocalDs (outPatType other_pat) -- OK, better make up one...
+selectMatchVar (VarPat var) = returnDs var
+selectMatchVar (AsPat var pat) = returnDs var
+selectMatchVar (LazyPat pat) = selectMatchVar pat
+selectMatchVar other_pat = newSysLocalDs (outPatType other_pat) -- OK, better make up one...
\end{code}
unmix_eqns [] = []
unmix_eqns [eqn] = [ [eqn] ]
unmix_eqns (eq1@(EqnInfo _ _ (p1:p1s) _) : eq2@(EqnInfo _ _ (p2:p2s) _) : eqs)
- = if ( (irrefutablePat p1 && irrefutablePat p2)
- || (isConPat p1 && isConPat p2)
- || (isLitPat p1 && isLitPat p2) ) then
+ = if ( (isWildPat p1 && isWildPat p2)
+ || (isConPat p1 && isConPat p2)
+ || (isLitPat p1 && isLitPat p2) ) then
eq1 `tack_onto` unmixed_rest
else
[ eq1 ] : unmixed_rest
-- DsM'd because of internal call to "match".
-- "tidy1" does the interesting stuff, looking at
-- one pattern and fiddling the list of bindings.
+ --
+ -- POST CONDITION: head pattern in the EqnInfo is
+ -- WildPat
+ -- ConPat
+ -- NPat
+ -- LitPat
+ -- NPlusKPat
+ -- but no other
+
tidyEqnInfo v (EqnInfo n ctx (pat : pats) match_result)
= tidy1 v pat match_result `thenDs` \ (pat', match_result') ->
returnDs (EqnInfo n ctx (pat' : pats) match_result')
matchUnmixedEqns [] _ = panic "matchUnmixedEqns: no names"
matchUnmixedEqns all_vars@(var:vars) eqns_info
- | irrefutablePat first_pat
- = ASSERT( irrefutablePats column_1_pats ) -- Sanity check
+ | isWildPat first_pat
+ = ASSERT( all isWildPat column_1_pats ) -- Sanity check
-- Real true variables, just like in matchVar, SLPJ p 94
+ -- No binding to do: they'll all be wildcards by now (done in tidy)
match vars remaining_eqns_info
| isConPat first_pat
-> DsM ([Id], CoreExpr) -- Results
\end{code}
- a special case for the common ...:
- just one Match
- lots of (all?) unfailable pats
- e.g.,
- f x y z = ....
-
- This special case have been ``undone'' due to problems with the new warnings
- messages (Check.lhs.check). We need there the name of the variables to be able to
- print later the equation. JJQC 30-11-97
-
-\begin{old_code}
-matchWrapper kind [(PatMatch (VarPat var) match)] error_string
- = matchWrapper kind [match] error_string `thenDs` \ (vars, core_expr) ->
- returnDs (var:vars, core_expr)
-
-matchWrapper kind [(PatMatch (WildPat ty) match)] error_string
- = newSysLocalDs ty `thenDs` \ var ->
- matchWrapper kind [match] error_string `thenDs` \ (vars, core_expr) ->
- returnDs (var:vars, core_expr)
-
-matchWrapper kind [(GRHSMatch
- (GRHSsAndBindsOut [GRHS [ExprStmt expr _]] binds _))] error_string
- = dsExpr expr `thenDs` \ core_expr ->
- dsLet binds core_expr `thenDs` \ rhs ->
- returnDs ([], rhs)
-\end{old_code}
-
- And all the rest... (general case)
-
-
There is one small problem with the Lambda Patterns, when somebody
writes something similar to:
(\ (x:xs) -> ...)
ASSERT( all (== result_ty) result_tys )
returnDs (result_ty, eqn_infos)
where
- flatten_match (match, eqn_no) = flatten_match_help [] match eqn_no
-
- flatten_match_help :: [TypecheckedPat] -- Reversed list of patterns encountered so far
- -> TypecheckedMatch
- -> EqnNo
- -> DsM (Type, EquationInfo)
-
- flatten_match_help pats_so_far (PatMatch pat match) n
- = flatten_match_help (pat:pats_so_far) match n
-
- flatten_match_help pats_so_far (GRHSMatch (GRHSsAndBindsOut grhss binds ty)) n
- = dsGRHSs kind pats grhss `thenDs` \ match_result ->
+ flatten_match (Match _ pats _ grhss, n)
+ = dsGRHSs kind pats grhss `thenDs` \ (ty, match_result) ->
getSrcLocDs `thenDs` \ locn ->
- returnDs (ty, EqnInfo n (DsMatchContext kind pats locn) pats
- (adjustMatchResultDs (dsLet binds) match_result))
- -- NB: nested dsLet inside matchResult
- where
- pats = reverse pats_so_far -- They've accumulated in reverse order
-
- flatten_match_help pats_so_far (SimpleMatch expr) n
- = dsExpr expr `thenDs` \ core_expr ->
- getSrcLocDs `thenDs` \ locn ->
- returnDs (coreExprType core_expr,
- EqnInfo n (DsMatchContext kind pats locn) pats
- (cantFailMatchResult core_expr))
- where
- pats = reverse pats_so_far -- They've accumulated in reverse order
+ returnDs (ty, EqnInfo n (DsMatchContext kind pats locn) pats match_result)
\end{code}
import Id ( Id )
import CoreSyn
import Type ( mkTyVarTys )
+import Util ( equivClassesByUniq )
import Unique ( Uniquable(..), Unique )
-import UniqFM -- Until equivClassesUniq moves to Util
import Outputable
\end{code}
subst_it e = foldr subst_one e other_eqns
subst_one (EqnInfo _ _ (ConPat _ _ ex_tvs' _ _ : _) _) e = mkTyApps (mkLams ex_tvs' e) ex_tys
ex_tys = mkTyVarTys ex_tvs
-
-
--- Belongs in Util.lhs
-equivClassesByUniq :: (a -> Unique) -> [a] -> [[a]]
- -- NB: it's *very* important that if we have the input list [a,b,c],
- -- where a,b,c all have the same unique, then we get back the list
- -- [a,b,c]
- -- not
- -- [c,b,a]
- -- Hence the use of foldr, plus the reversed-args tack_on below
-equivClassesByUniq get_uniq xs
- = eltsUFM (foldr add emptyUFM xs)
- where
- add a ufm = addToUFM_C tack_on ufm (get_uniq a) [a]
- tack_on old new = new++old
\end{code}
Note on @shift_con_pats@ just above: does what the list comprehension in
import PrimRep ( PrimRep(IntRep) )
import Maybes ( catMaybes )
import Type ( Type, isUnLiftedType )
-import Util ( panic, assertPanic )
+import Panic ( panic, assertPanic )
\end{code}
\begin{code}
#include "HsVersions.h"
import {-# SOURCE #-} HsExpr ( pprExpr, HsExpr )
-import {-# SOURCE #-} HsMatches ( pprMatches, Match, pprGRHSsAndBinds, GRHSsAndBinds )
+import {-# SOURCE #-} HsMatches ( pprMatches, Match, pprGRHSs, GRHSs )
-- friends:
import HsTypes ( HsType )
--others:
import Id ( Id )
import Name ( OccName, NamedThing(..) )
-import BasicTypes ( RecFlag(..) )
+import BasicTypes ( RecFlag(..), Fixity )
import Outputable
import Bag
import SrcLoc ( SrcLoc )
-import Var ( GenTyVar )
+import Var ( TyVar )
\end{code}
%************************************************************************
Collections of bindings, created by dependency analysis and translation:
\begin{code}
-data HsBinds flexi id pat -- binders and bindees
+data HsBinds id pat -- binders and bindees
= EmptyBinds
- | ThenBinds (HsBinds flexi id pat)
- (HsBinds flexi id pat)
+ | ThenBinds (HsBinds id pat)
+ (HsBinds id pat)
- | MonoBind (MonoBinds flexi id pat)
+ | MonoBind (MonoBinds id pat)
[Sig id] -- Empty on typechecker output
RecFlag
\end{code}
\begin{code}
-nullBinds :: HsBinds flexi id pat -> Bool
+nullBinds :: HsBinds id pat -> Bool
nullBinds EmptyBinds = True
nullBinds (ThenBinds b1 b2) = nullBinds b1 && nullBinds b2
\begin{code}
instance (Outputable pat, NamedThing id, Outputable id) =>
- Outputable (HsBinds flexi id pat) where
+ Outputable (HsBinds id pat) where
ppr binds = ppr_binds binds
ppr_binds EmptyBinds = empty
Global bindings (where clauses)
\begin{code}
-data MonoBinds flexi id pat
+data MonoBinds id pat
= EmptyMonoBinds
- | AndMonoBinds (MonoBinds flexi id pat)
- (MonoBinds flexi id pat)
+ | AndMonoBinds (MonoBinds id pat)
+ (MonoBinds id pat)
| PatMonoBind pat
- (GRHSsAndBinds flexi id pat)
+ (GRHSs id pat)
SrcLoc
| FunMonoBind id
Bool -- True => infix declaration
- [Match flexi id pat] -- must have at least one Match
+ [Match id pat]
SrcLoc
| VarMonoBind id -- TRANSLATION
- (HsExpr flexi id pat)
+ (HsExpr id pat)
| CoreMonoBind id -- TRANSLATION
CoreExpr -- No zonking; this is a final CoreExpr with Ids and Types!
| AbsBinds -- Binds abstraction; TRANSLATION
- [GenTyVar flexi] -- Type variables
+ [TyVar] -- Type variables
[id] -- Dicts
- [([GenTyVar flexi], id, id)] -- (type variables, polymorphic, momonmorphic) triples
- (MonoBinds flexi id pat) -- The "business end"
+ [([TyVar], id, id)] -- (type variables, polymorphic, momonmorphic) triples
+ (MonoBinds id pat) -- The "business end"
-- Creates bindings for *new* (polymorphic, overloaded) locals
-- in terms of *old* (monomorphic, non-overloaded) ones.
in (fm,gm)
\begin{code}
-nullMonoBinds :: MonoBinds flexi id pat -> Bool
+nullMonoBinds :: MonoBinds id pat -> Bool
nullMonoBinds EmptyMonoBinds = True
nullMonoBinds (AndMonoBinds bs1 bs2) = nullMonoBinds bs1 && nullMonoBinds bs2
nullMonoBinds other_monobind = False
-andMonoBinds :: MonoBinds flexi id pat -> MonoBinds flexi id pat -> MonoBinds flexi id pat
+andMonoBinds :: MonoBinds id pat -> MonoBinds id pat -> MonoBinds id pat
andMonoBinds EmptyMonoBinds mb = mb
andMonoBinds mb EmptyMonoBinds = mb
andMonoBinds mb1 mb2 = AndMonoBinds mb1 mb2
-andMonoBindList :: [MonoBinds flexi id pat] -> MonoBinds flexi id pat
+andMonoBindList :: [MonoBinds id pat] -> MonoBinds id pat
andMonoBindList binds = foldr AndMonoBinds EmptyMonoBinds binds
\end{code}
\begin{code}
instance (NamedThing id, Outputable id, Outputable pat) =>
- Outputable (MonoBinds flexi id pat) where
+ Outputable (MonoBinds id pat) where
ppr mbind = ppr_monobind mbind
ppr_monobind (AndMonoBinds binds1 binds2)
= ($$) (ppr_monobind binds1) (ppr_monobind binds2)
-ppr_monobind (PatMonoBind pat grhss_n_binds locn)
- = sep [ppr pat, nest 4 (pprGRHSsAndBinds False grhss_n_binds)]
+ppr_monobind (PatMonoBind pat grhss locn)
+ = sep [ppr pat, nest 4 (pprGRHSs False grhss)]
ppr_monobind (FunMonoBind fun inf matches locn)
= pprMatches (False, ppr fun) matches
(HsType name)
SrcLoc
- | ClassOpSig name -- Selector name
- (Maybe name) -- Default-method name (if any)
+ | ClassOpSig name -- Selector name
+ (Maybe name) -- Default-method name (if any)
(HsType name)
SrcLoc
| SpecSig name -- specialise a function or datatype ...
- (HsType name) -- ... to these types
+ (HsType name) -- ... to these types
(Maybe name) -- ... maybe using this as the code for it
SrcLoc
- | InlineSig name -- INLINE f
+ | InlineSig name -- INLINE f
SrcLoc
- | NoInlineSig name -- NOINLINE f
+ | NoInlineSig name -- NOINLINE f
SrcLoc
- | SpecInstSig (HsType name) -- (Class tys); should be a specialisation of the
- -- current instance decl
+ | SpecInstSig (HsType name) -- (Class tys); should be a specialisation of the
+ -- current instance decl
SrcLoc
+
+ | FixSig (FixitySig name) -- Fixity declaration
+
+
+data FixitySig name = FixitySig name Fixity SrcLoc
\end{code}
\begin{code}
sigsForMe f sigs
= filter sig_for_me sigs
where
- sig_for_me (Sig n _ _) = f n
- sig_for_me (ClassOpSig n _ _ _) = f n
- sig_for_me (SpecSig n _ _ _) = f n
- sig_for_me (InlineSig n _) = f n
- sig_for_me (NoInlineSig n _) = f n
- sig_for_me (SpecInstSig _ _) = False
+ sig_for_me (Sig n _ _) = f n
+ sig_for_me (ClassOpSig n _ _ _) = f n
+ sig_for_me (SpecSig n _ _ _) = f n
+ sig_for_me (InlineSig n _) = f n
+ sig_for_me (NoInlineSig n _) = f n
+ sig_for_me (SpecInstSig _ _) = False
+ sig_for_me (FixSig (FixitySig n _ _)) = f n
+
+nonFixitySigs :: [Sig name] -> [Sig name]
+nonFixitySigs sigs = filter not_fix sigs
+ where
+ not_fix (FixSig _) = False
+ not_fix other = True
\end{code}
\begin{code}
instance (NamedThing name, Outputable name) => Outputable (Sig name) where
ppr sig = ppr_sig sig
+instance Outputable name => Outputable (FixitySig name) where
+ ppr (FixitySig name fixity loc) = sep [ppr fixity, ppr name]
+
ppr_sig (Sig var ty _)
- = sep [ppr var <+> ptext SLIT("::"),
- nest 4 (ppr ty)]
+ = sep [ppr var <+> dcolon, nest 4 (ppr ty)]
ppr_sig (ClassOpSig var _ ty _)
- = sep [ppr (getOccName var) <+> ptext SLIT("::"),
- nest 4 (ppr ty)]
+ = sep [ppr (getOccName var) <+> dcolon, nest 4 (ppr ty)]
ppr_sig (SpecSig var ty using _)
- = sep [ hsep [text "{-# SPECIALIZE", ppr var, ptext SLIT("::")],
+ = sep [ hsep [text "{-# SPECIALIZE", ppr var, dcolon],
nest 4 (hsep [ppr ty, pp_using using, text "#-}"])
]
where
ppr_sig (SpecInstSig ty _)
= hsep [text "{-# SPECIALIZE instance", ppr ty, text "#-}"]
+
+ppr_sig (FixSig fix_sig) = ppr fix_sig
\end{code}
after = if is_casm then text "'' " else space
instance Outputable name => Outputable (UfBinder name) where
- ppr (UfValBinder name ty) = hsep [ppr name, ptext SLIT("::"), ppr ty]
- ppr (UfTyBinder name kind) = hsep [ppr name, ptext SLIT("::"), ppr kind]
+ ppr (UfValBinder name ty) = hsep [ppr name, dcolon, ppr ty]
+ ppr (UfTyBinder name kind) = hsep [ppr name, dcolon, ppr kind]
\end{code}
%
\section[HsDecls]{Abstract syntax: global declarations}
-Definitions for: @FixityDecl@, @TyDecl@ and @ConDecl@, @ClassDecl@,
+Definitions for: @TyDecl@ and @ConDecl@, @ClassDecl@,
@InstDecl@, @DefaultDecl@ and @ForeignDecl@.
\begin{code}
-module HsDecls where
+module HsDecls (
+ HsDecl(..), TyClDecl(..), InstDecl(..),
+ DefaultDecl(..), ForeignDecl(..), ForKind(..),
+ ExtName(..), isDynamic,
+ ConDecl(..), ConDetails(..), BangType(..),
+ IfaceSig(..), SpecDataSig(..), HsIdInfo(..), HsStrictnessInfo(..),
+ hsDeclName, tyClDeclName, isClassDecl, isSynDecl, isDataDecl, countTyClDecls
+ ) where
#include "HsVersions.h"
-- friends:
-import HsBinds ( HsBinds, MonoBinds, Sig, nullMonoBinds )
+import HsBinds ( HsBinds, MonoBinds, Sig, FixitySig(..), nullMonoBinds )
import HsPragmas ( DataPragmas, ClassPragmas )
import HsTypes
import HsCore ( UfExpr )
%************************************************************************
\begin{code}
-data HsDecl flexi name pat
- = TyD (TyDecl name)
- | ClD (ClassDecl flexi name pat)
- | InstD (InstDecl flexi name pat)
+data HsDecl name pat
+ = TyClD (TyClDecl name pat)
+ | InstD (InstDecl name pat)
| DefD (DefaultDecl name)
- | ValD (HsBinds flexi name pat)
- | SigD (IfaceSig name)
+ | ValD (HsBinds name pat)
| ForD (ForeignDecl name)
+ | SigD (IfaceSig name)
+ | FixD (FixitySig name)
+
+-- NB: all top-level fixity decls are contained EITHER
+-- EITHER FixDs
+-- OR in the ClassDecls in TyClDs
+--
+-- The former covers
+-- a) data constructors
+-- b) class methods (but they can be also done in the
+-- signatures of class decls)
+-- c) imported functions (that have an IfacSig)
+-- d) top level decls
+--
+-- The latter is for class methods only
+
+-- It's a bit wierd that the fixity decls in the ValD
+-- cover all the classops and imported decls too, but it's convenient
+-- For a start, it means we don't need a FixD
\end{code}
\begin{code}
#ifdef DEBUG
hsDeclName :: (NamedThing name, Outputable name, Outputable pat)
- => HsDecl flexi name pat -> name
+ => HsDecl name pat -> name
#endif
-hsDeclName (TyD (TyData _ _ name _ _ _ _ _)) = name
-hsDeclName (TyD (TySynonym name _ _ _)) = name
-hsDeclName (ClD (ClassDecl _ name _ _ _ _ _ _ _)) = name
-hsDeclName (SigD (IfaceSig name _ _ _)) = name
-hsDeclName (InstD (InstDecl _ _ _ (Just name) _)) = name
-hsDeclName (ForD (ForeignDecl name _ _ _ _ _)) = name
+hsDeclName (TyClD decl) = tyClDeclName decl
+hsDeclName (SigD (IfaceSig name _ _ _)) = name
+hsDeclName (InstD (InstDecl _ _ _ (Just 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 (TySynonym name _ _ _) = name
+tyClDeclName (ClassDecl _ name _ _ _ _ _ _ _) = name
\end{code}
\begin{code}
instance (NamedThing name, Outputable name, Outputable pat)
- => Outputable (HsDecl flexi name pat) where
+ => Outputable (HsDecl name pat) where
- ppr (TyD td) = ppr td
- ppr (ClD cd) = ppr cd
+ ppr (TyClD dcl) = ppr dcl
ppr (SigD sig) = ppr sig
ppr (ValD binds) = ppr binds
ppr (DefD def) = ppr def
ppr (InstD inst) = ppr inst
ppr (ForD fd) = ppr fd
+ ppr (FixD fd) = ppr fd
+
+{- Why do we need ordering on decls?
#ifdef DEBUG
-- hsDeclName needs more context when DEBUG is on
instance (NamedThing name, Outputable name, Outputable pat, Eq name)
- => Eq (HsDecl flex name pat) where
+ => Eq (HsDecl name pat) where
d1 == d2 = hsDeclName d1 == hsDeclName d2
instance (NamedThing name, Outputable name, Outputable pat, Ord name)
- => Ord (HsDecl flex name pat) where
+ => Ord (HsDecl name pat) where
d1 `compare` d2 = hsDeclName d1 `compare` hsDeclName d2
#else
-instance (Eq name) => Eq (HsDecl flex name pat) where
+instance (Eq name) => Eq (HsDecl name pat) where
d1 == d2 = hsDeclName d1 == hsDeclName d2
-instance (Ord name) => Ord (HsDecl flexi name pat) where
+instance (Ord name) => Ord (HsDecl name pat) where
d1 `compare` d2 = hsDeclName d1 `compare` hsDeclName d2
#endif
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[FixityDecl]{A fixity declaration}
-%* *
-%************************************************************************
-
-\begin{code}
-data FixityDecl name = FixityDecl name Fixity SrcLoc
-
-instance Outputable name => Outputable (FixityDecl name) where
- ppr (FixityDecl name fixity loc) = sep [ppr fixity, ppr name]
+-}
\end{code}
%************************************************************************
\begin{code}
-data TyDecl name
+data TyClDecl name pat
= TyData NewOrData
(Context name) -- context
name -- type constructor
(HsType name) -- synonym expansion
SrcLoc
+ | ClassDecl (Context name) -- context...
+ name -- name of the class
+ [HsTyVar name] -- the class type variables
+ [Sig name] -- methods' signatures
+ (MonoBinds name pat) -- default methods
+ (ClassPragmas name)
+ name name -- The names of the tycon and datacon for this class
+ -- These are filled in by the renamer
+ SrcLoc
\end{code}
\begin{code}
-instance (NamedThing name, Outputable name)
- => Outputable (TyDecl name) where
+countTyClDecls :: [TyClDecl name pat] -> (Int, Int, Int, Int)
+ -- class, data, newtype, synonym decls
+countTyClDecls decls
+ = (length [() | ClassDecl _ _ _ _ _ _ _ _ _ <- 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
+
+isClassDecl (ClassDecl _ _ _ _ _ _ _ _ _) = True
+isClassDecl other = False
+\end{code}
+
+\begin{code}
+instance (NamedThing name, Outputable name, Outputable pat)
+ => Outputable (TyClDecl name pat) where
ppr (TySynonym tycon tyvars mono_ty src_loc)
= hang (pp_decl_head SLIT("type") empty tycon tyvars)
NewType -> SLIT("newtype")
DataType -> SLIT("data")
+ ppr (ClassDecl context clas tyvars sigs methods pragmas _ _ src_loc)
+ | null sigs -- No "where" part
+ = top_matter
+
+ | otherwise -- Laid out
+ = sep [hsep [top_matter, ptext SLIT("where {")],
+ nest 4 (vcat [sep (map ppr_sig sigs),
+ ppr methods,
+ char '}'])]
+ where
+ top_matter = hsep [ptext SLIT("class"), pprContext context,
+ ppr clas, hsep (map (ppr) tyvars)]
+ ppr_sig sig = ppr sig <> semi
+
+
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 [] = empty -- Curious!
+pp_condecls (c:cs) = sep (ppr c : map (\ c -> ptext SLIT("|") <+> ppr c) cs)
pp_tydecl pp_head pp_decl_rhs derivings
= hang pp_head 4 (sep [
= ppr con <+> braces (hsep (punctuate comma (map ppr_field fields)))
where
ppr_field (ns, ty) = hsep (map (ppr) ns) <+>
- ptext SLIT("::") <+>
+ dcolon <+>
ppr_bang ty
ppr_bang (Banged ty) = ptext SLIT("!") <> pprParendHsType ty
ppr_bang (Unbanged ty) = pprParendHsType ty
\end{code}
-%************************************************************************
-%* *
-\subsection[ClassDecl]{A class declaration}
-%* *
-%************************************************************************
-
-\begin{code}
-data ClassDecl flexi name pat
- = ClassDecl (Context name) -- context...
- name -- name of the class
- [HsTyVar name] -- the class type variables
- [Sig name] -- methods' signatures
- (MonoBinds flexi name pat) -- default methods
- (ClassPragmas name)
- name name -- The names of the tycon and datacon for this class
- -- These are filled in by the renamer
- SrcLoc
-\end{code}
-
-\begin{code}
-instance (NamedThing name, Outputable name, Outputable pat)
- => Outputable (ClassDecl flexi name pat) where
-
- ppr (ClassDecl context clas tyvars sigs methods pragmas _ _ src_loc)
- | null sigs -- No "where" part
- = top_matter
-
- | otherwise -- Laid out
- = sep [hsep [top_matter, ptext SLIT("where {")],
- nest 4 (vcat [sep (map ppr_sig sigs),
- ppr methods,
- char '}'])]
- where
- top_matter = hsep [ptext SLIT("class"), pprContext context,
- ppr clas, hsep (map (ppr) tyvars)]
- ppr_sig sig = ppr sig <> semi
-\end{code}
%************************************************************************
%* *
%************************************************************************
\begin{code}
-data InstDecl flexi name pat
+data InstDecl name pat
= InstDecl (HsType name) -- Context => Class Instance-type
-- Using a polytype means that the renamer conveniently
-- figures out the quantified type variables for us.
- (MonoBinds flexi name pat)
+ (MonoBinds name pat)
[Sig name] -- User-supplied pragmatic info
\begin{code}
instance (NamedThing name, Outputable name, Outputable pat)
- => Outputable (InstDecl flexi name pat) where
+ => Outputable (InstDecl name pat) where
ppr (InstDecl inst_ty binds uprags dfun_name src_loc)
= getPprStyle $ \ sty ->
ppr (ForeignDecl nm imp_exp ty ext_name cconv src_loc)
= ptext SLIT("foreign") <+> ppr_imp_exp <+> pprCallConv cconv <+>
- ppr ext_name <+> ppr_unsafe <+> ppr nm <+> ptext SLIT("::") <+> ppr ty
+ ppr ext_name <+> ppr_unsafe <+> ppr nm <+> dcolon <+> ppr ty
where
(ppr_imp_exp, ppr_unsafe) =
case imp_exp of
instance (NamedThing name, Outputable name) => Outputable (IfaceSig name) where
ppr (IfaceSig var ty _ _)
- = hang (hsep [ppr var, ptext SLIT("::")])
+ = hang (hsep [ppr var, dcolon])
4 (ppr ty)
data HsIdInfo name
data HsStrictnessInfo name
- = HsStrictnessInfo [Demand]
+ = HsStrictnessInfo ([Demand], Bool)
(Maybe (name, [name])) -- Worker, if any
-- and needed constructors
| HsBottom
_exports_
HsExpr HsExpr pprExpr;
_declarations_
-1 data HsExpr f i p;
-1 pprExpr _:_ _forall_ [i p f] {Name.NamedThing i, Outputable.Outputable i, Outputable.Outputable p} => HsExpr.HsExpr f i p -> Outputable.SDoc ;;
+1 data HsExpr i p;
+1 pprExpr _:_ _forall_ [i p] {Name.NamedThing i, Outputable.Outputable i, Outputable.Outputable p} => HsExpr.HsExpr i p -> Outputable.SDoc ;;
import HsTypes ( HsType )
-- others:
-import Name ( Name, NamedThing(..), isLexSym, occNameString )
+import Name ( Name, NamedThing(..), isSymOcc )
import Outputable
import PprType ( pprType, pprParendType )
-import Type ( GenType )
-import Var ( GenTyVar, Id )
+import Type ( Type )
+import Var ( TyVar, Id )
import DataCon ( DataCon )
import SrcLoc ( SrcLoc )
\end{code}
%************************************************************************
\begin{code}
-data HsExpr flexi id pat
+data HsExpr id pat
= HsVar id -- variable
| HsLit HsLit -- literal
| HsLitOut HsLit -- TRANSLATION
- (GenType flexi) -- (with its type)
+ Type -- (with its type)
- | HsLam (Match flexi id pat) -- lambda
- | HsApp (HsExpr flexi id pat) -- application
- (HsExpr flexi id pat)
+ | HsLam (Match id pat) -- lambda
+ | HsApp (HsExpr id pat) -- application
+ (HsExpr id pat)
-- Operator applications:
-- NB Bracketed ops such as (+) come out as Vars.
-- NB We need an expr for the operator in an OpApp/Section since
-- the typechecker may need to apply the operator to a few types.
- | OpApp (HsExpr flexi id pat) -- left operand
- (HsExpr flexi id pat) -- operator
+ | OpApp (HsExpr id pat) -- left operand
+ (HsExpr id pat) -- operator
Fixity -- Renamer adds fixity; bottom until then
- (HsExpr flexi id pat) -- right operand
+ (HsExpr id pat) -- right operand
-- We preserve prefix negation and parenthesis for the precedence parser.
-- They are eventually removed by the type checker.
- | NegApp (HsExpr flexi id pat) -- negated expr
- (HsExpr flexi id pat) -- the negate id (in a HsVar)
+ | NegApp (HsExpr id pat) -- negated expr
+ (HsExpr id pat) -- the negate id (in a HsVar)
- | HsPar (HsExpr flexi id pat) -- parenthesised expr
+ | HsPar (HsExpr id pat) -- parenthesised expr
- | SectionL (HsExpr flexi id pat) -- operand
- (HsExpr flexi id pat) -- operator
- | SectionR (HsExpr flexi id pat) -- operator
- (HsExpr flexi id pat) -- operand
+ | SectionL (HsExpr id pat) -- operand
+ (HsExpr id pat) -- operator
+ | SectionR (HsExpr id pat) -- operator
+ (HsExpr id pat) -- operand
- | HsCase (HsExpr flexi id pat)
- [Match flexi id pat] -- must have at least one Match
+ | HsCase (HsExpr id pat)
+ [Match id pat]
SrcLoc
- | HsIf (HsExpr flexi id pat) -- predicate
- (HsExpr flexi id pat) -- then part
- (HsExpr flexi id pat) -- else part
+ | HsIf (HsExpr id pat) -- predicate
+ (HsExpr id pat) -- then part
+ (HsExpr id pat) -- else part
SrcLoc
- | HsLet (HsBinds flexi id pat) -- let(rec)
- (HsExpr flexi id pat)
+ | HsLet (HsBinds id pat) -- let(rec)
+ (HsExpr id pat)
| HsDo StmtCtxt
- [Stmt flexi id pat] -- "do":one or more stmts
+ [Stmt id pat] -- "do":one or more stmts
SrcLoc
| HsDoOut StmtCtxt
- [Stmt flexi id pat] -- "do":one or more stmts
- id -- id for return
- id -- id for >>=
+ [Stmt id pat] -- "do":one or more stmts
+ id -- id for return
+ id -- id for >>=
id -- id for zero
- (GenType flexi) -- Type of the whole expression
+ Type -- Type of the whole expression
SrcLoc
| ExplicitList -- syntactic list
- [HsExpr flexi id pat]
+ [HsExpr id pat]
| ExplicitListOut -- TRANSLATION
- (GenType flexi) -- Gives type of components of list
- [HsExpr flexi id pat]
+ Type -- Gives type of components of list
+ [HsExpr id pat]
| ExplicitTuple -- tuple
- [HsExpr flexi id pat]
+ [HsExpr id pat]
-- NB: Unit is ExplicitTuple []
-- for tuples, we can get the types
-- direct from the components
Bool -- boxed?
| HsCon DataCon -- TRANSLATION; a saturated constructor application
- [GenType flexi]
- [HsExpr flexi id pat]
+ [Type]
+ [HsExpr id pat]
-- Record construction
| RecordCon id -- The constructor
- (HsRecordBinds flexi id pat)
+ (HsRecordBinds id pat)
| RecordConOut DataCon
- (HsExpr flexi id pat) -- Data con Id applied to type args
- (HsRecordBinds flexi id pat)
+ (HsExpr id pat) -- Data con Id applied to type args
+ (HsRecordBinds id pat)
-- Record update
- | RecordUpd (HsExpr flexi id pat)
- (HsRecordBinds flexi id pat)
+ | RecordUpd (HsExpr id pat)
+ (HsRecordBinds id pat)
- | RecordUpdOut (HsExpr flexi id pat) -- TRANSLATION
- (GenType flexi) -- Type of *result* record (may differ from
+ | RecordUpdOut (HsExpr id pat) -- TRANSLATION
+ Type -- Type of *result* record (may differ from
-- type of input record)
[id] -- Dicts needed for construction
- (HsRecordBinds flexi id pat)
+ (HsRecordBinds id pat)
- | ExprWithTySig -- signature binding
- (HsExpr flexi id pat)
+ | ExprWithTySig -- signature binding
+ (HsExpr id pat)
(HsType id)
- | ArithSeqIn -- arithmetic sequence
- (ArithSeqInfo flexi id pat)
+ | ArithSeqIn -- arithmetic sequence
+ (ArithSeqInfo id pat)
| ArithSeqOut
- (HsExpr flexi id pat) -- (typechecked, of course)
- (ArithSeqInfo flexi id pat)
+ (HsExpr id pat) -- (typechecked, of course)
+ (ArithSeqInfo id pat)
| CCall FAST_STRING -- call into the C world; string is
- [HsExpr flexi id pat] -- the C function; exprs are the
+ [HsExpr id pat] -- the C function; exprs are the
-- arguments to pass.
Bool -- True <=> might cause Haskell
-- garbage-collection (must generate
-- NOTE: this CCall is the *boxed*
-- version; the desugarer will convert
-- it into the unboxed "ccall#".
- (GenType flexi) -- The result type; will be *bottom*
+ Type -- The result type; will be *bottom*
-- until the typechecker gets ahold of it
| HsSCC FAST_STRING -- "set cost centre" (_scc_) annotation
- (HsExpr flexi id pat) -- expr whose cost is to be measured
+ (HsExpr id pat) -- expr whose cost is to be measured
\end{code}
Everything from here on appears only in typechecker output.
\begin{code}
| TyLam -- TRANSLATION
- [GenTyVar flexi]
- (HsExpr flexi id pat)
+ [TyVar]
+ (HsExpr id pat)
| TyApp -- TRANSLATION
- (HsExpr flexi id pat) -- generated by Spec
- [GenType flexi]
+ (HsExpr id pat) -- generated by Spec
+ [Type]
-- DictLam and DictApp are "inverses"
| DictLam
[id]
- (HsExpr flexi id pat)
+ (HsExpr id pat)
| DictApp
- (HsExpr flexi id pat)
+ (HsExpr id pat)
[id]
-type HsRecordBinds flexi id pat
- = [(id, HsExpr flexi id pat, Bool)]
+type HsRecordBinds id pat
+ = [(id, HsExpr id pat, Bool)]
-- True <=> source code used "punning",
-- i.e. {op1, op2} rather than {op1=e1, op2=e2}
\end{code}
\begin{code}
instance (NamedThing id, Outputable id, Outputable pat) =>
- Outputable (HsExpr flexi id pat) where
+ Outputable (HsExpr id pat) where
ppr expr = pprExpr expr
\end{code}
\begin{code}
pprExpr :: (NamedThing id, Outputable id, Outputable pat)
- => HsExpr flexi id pat -> SDoc
+ => HsExpr id pat -> SDoc
pprExpr e = pprDeeper (ppr_expr e)
pprBinds b = pprDeeper (ppr b)
ppr_expr (HsLitOut lit _) = ppr lit
ppr_expr (HsLam match)
- = hsep [char '\\', nest 2 (pprMatch True match)]
+ = hsep [char '\\', nest 2 (pprMatch (True,empty) match)]
ppr_expr expr@(HsApp e1 e2)
= let (fun, args) = collect_args expr [] in
pp_infixly v
= sep [pp_e1, hsep [pp_v, pp_e2]]
where
- pp_v | isLexSym (occNameString (getOccName v)) = ppr v
- | otherwise = char '`' <> ppr v <> char '`'
+ pp_v | isSymOcc (getOccName v) = ppr v
+ | otherwise = char '`' <> ppr v <> char '`'
ppr_expr (NegApp e _)
= char '-' <+> pprParendExpr e
= pp_rbinds (pprParendExpr aexp) rbinds
ppr_expr (ExprWithTySig expr sig)
- = hang (nest 2 (ppr_expr expr) <+> ptext SLIT("::"))
+ = hang (nest 2 (ppr_expr expr) <+> dcolon)
4 (ppr sig)
ppr_expr (ArithSeqIn info)
Parenthesize unless very simple:
\begin{code}
pprParendExpr :: (NamedThing id, Outputable id, Outputable pat)
- => HsExpr flexi id pat -> SDoc
+ => HsExpr id pat -> SDoc
pprParendExpr expr
= let
\begin{code}
pp_rbinds :: (NamedThing id, Outputable id, Outputable pat)
=> SDoc
- -> HsRecordBinds flexi id pat -> SDoc
+ -> HsRecordBinds id pat -> SDoc
pp_rbinds thing rbinds
= hang thing
\end{code}
\begin{code}
-data Stmt flexi id pat
+data Stmt id pat
= BindStmt pat
- (HsExpr flexi id pat)
+ (HsExpr id pat)
SrcLoc
- | LetStmt (HsBinds flexi id pat)
+ | LetStmt (HsBinds id pat)
- | GuardStmt (HsExpr flexi id pat) -- List comps only
+ | GuardStmt (HsExpr id pat) -- List comps only
SrcLoc
- | ExprStmt (HsExpr flexi id pat) -- Do stmts; and guarded things at the end
+ | ExprStmt (HsExpr id pat) -- Do stmts; and guarded things at the end
SrcLoc
- | ReturnStmt (HsExpr flexi id pat) -- List comps only, at the end
+ | ReturnStmt (HsExpr id pat) -- List comps only, at the end
\end{code}
\begin{code}
instance (NamedThing id, Outputable id, Outputable pat) =>
- Outputable (Stmt flexi id pat) where
+ Outputable (Stmt id pat) where
ppr stmt = pprStmt stmt
pprStmt (BindStmt pat expr _)
%************************************************************************
\begin{code}
-data ArithSeqInfo flexi id pat
- = From (HsExpr flexi id pat)
- | FromThen (HsExpr flexi id pat)
- (HsExpr flexi id pat)
- | FromTo (HsExpr flexi id pat)
- (HsExpr flexi id pat)
- | FromThenTo (HsExpr flexi id pat)
- (HsExpr flexi id pat)
- (HsExpr flexi id pat)
+data ArithSeqInfo id pat
+ = From (HsExpr id pat)
+ | FromThen (HsExpr id pat)
+ (HsExpr id pat)
+ | FromTo (HsExpr id pat)
+ (HsExpr id pat)
+ | FromThenTo (HsExpr id pat)
+ (HsExpr id pat)
+ (HsExpr id pat)
\end{code}
\begin{code}
instance (NamedThing id, Outputable id, Outputable pat) =>
- Outputable (ArithSeqInfo flexi id pat) where
+ Outputable (ArithSeqInfo id pat) where
ppr (From e1) = hcat [ppr e1, pp_dotdot]
ppr (FromThen e1 e2) = hcat [ppr e1, comma, space, ppr e2, pp_dotdot]
ppr (FromTo e1 e3) = hcat [ppr e1, pp_dotdot, ppr e3]
#include "HsVersions.h"
-import BasicTypes ( Module, IfaceFlavour(..) )
-import Name ( NamedThing )
+import BasicTypes ( IfaceFlavour(..) )
+import Name ( Module, NamedThing, pprModule )
import Outputable
import SrcLoc ( SrcLoc )
\end{code}
instance (NamedThing name, Outputable name) => Outputable (ImportDecl name) where
ppr (ImportDecl mod qual as_source as spec _)
= hang (hsep [ptext SLIT("import"), pp_src as_source,
- pp_qual qual, ptext mod, pp_as as])
+ pp_qual qual, pprModule mod, pp_as as])
4 (pp_spec spec)
where
pp_src HiFile = empty
pp_qual True = ptext SLIT("qualified")
pp_as Nothing = empty
- pp_as (Just a) = ptext SLIT("as ") <+> ptext a
+ pp_as (Just a) = ptext SLIT("as ") <+> pprModule a
pp_spec Nothing = empty
pp_spec (Just (False, spec))
ppr (IEThingWith thing withs)
= ppr thing <> parens (fsep (punctuate comma (map ppr withs)))
ppr (IEModuleContents mod)
- = ptext SLIT("module") <+> ptext mod
+ = ptext SLIT("module") <+> pprModule mod
\end{code}
-_interface_ HsMatches 1
+_interface_ HsMatches 2
_exports_
-HsMatches Match GRHSsAndBinds pprMatch pprMatches pprGRHSsAndBinds ;
+HsMatches Match GRHSs pprMatch pprMatches pprGRHSs ;
_declarations_
-1 data Match a b c ;
-1 data GRHSsAndBinds a b c ;
-1 pprGRHSsAndBinds _:_ _forall_ [i p f] {Name.NamedThing i, Outputable.Outputable i, Outputable.Outputable p} => PrelBase.Bool -> HsMatches.GRHSsAndBinds f i p -> Outputable.SDoc ;;
-1 pprMatch _:_ _forall_ [i p f] {Name.NamedThing i, Outputable.Outputable i, Outputable.Outputable p} => PrelBase.Bool -> HsMatches.Match f i p -> Outputable.SDoc ;;
-1 pprMatches _:_ _forall_ [i p f] {Name.NamedThing i, Outputable.Outputable i, Outputable.Outputable p} => (PrelBase.Bool, Outputable.SDoc) -> [HsMatches.Match f i p] -> Outputable.SDoc ;;
+1 data Match a b ;
+1 data GRHSs a b ;
+1 pprGRHSs _:_ _forall_ [i p] {Name.NamedThing i, Outputable.Outputable i, Outputable.Outputable p} => PrelBase.Bool -> HsMatches.GRHSs i p -> Outputable.SDoc ;;
+1 pprMatch _:_ _forall_ [i p] {Name.NamedThing i, Outputable.Outputable i, Outputable.Outputable p} => (PrelBase.Bool, Outputable.SDoc) -> HsMatches.Match i p -> Outputable.SDoc ;;
+1 pprMatches _:_ _forall_ [i p] {Name.NamedThing i, Outputable.Outputable i, Outputable.Outputable p} => (PrelBase.Bool, Outputable.SDoc) -> [HsMatches.Match i p] -> Outputable.SDoc ;;
%
\section[HsMatches]{Abstract syntax: matches and guarded right-hand-sides}
-The @Match@, @GRHSsAndBinds@ and @GRHS@ datatypes.
+The @Match@, @GRHSs@ and @GRHS@ datatypes.
\begin{code}
module HsMatches where
-- Friends
import HsExpr ( HsExpr, Stmt(..) )
-import HsBinds ( HsBinds, nullBinds )
+import HsBinds ( HsBinds(..), nullBinds )
+import HsTypes ( HsTyVar, HsType )
-- Others
-import Type ( GenType )
+import Type ( Type )
import SrcLoc ( SrcLoc )
import Outputable
import Name ( NamedThing )
%************************************************************************
%* *
-\subsection{@Match@, @GRHSsAndBinds@, and @GRHS@ datatypes}
+\subsection{@Match@, @GRHSs@, and @GRHS@ datatypes}
%* *
%************************************************************************
then \tr{g} has two @Match@es: @(x,y) = y@ and @((x:ys),y) = y+1@.
It is always the case that each element of an @[Match]@ list has the
-same number of @PatMatch@s inside it. This corresponds to saying that
+same number of @pats@s inside it. This corresponds to saying that
a function defined by pattern matching must have the same number of
patterns in each equation.
\begin{code}
-data Match flexi id pat
- = PatMatch pat
- (Match flexi id pat)
- | GRHSMatch (GRHSsAndBinds flexi id pat)
-
- | SimpleMatch (HsExpr flexi id pat) -- Used in translations
-\end{code}
-
-Sets of guarded right hand sides (GRHSs). In:
-\begin{verbatim}
-f (x,y) | x==True = y
- | otherwise = y*2
-\end{verbatim}
-a guarded right hand side is either
-@(x==True = y)@, or @(otherwise = y*2)@.
-
-For each match, there may be several guarded right hand
-sides, as the definition of @f@ shows.
-
-\begin{code}
-data GRHSsAndBinds flexi id pat
- = GRHSsAndBindsIn [GRHS flexi id pat] -- at least one GRHS
- (HsBinds flexi id pat)
-
- | GRHSsAndBindsOut [GRHS flexi id pat] -- at least one GRHS
- (HsBinds flexi id pat)
- (GenType flexi)
-
-data GRHS flexi id pat
- = GRHS [Stmt flexi id pat] -- The RHS is the final ExprStmt
- -- I considered using a RetunStmt, but
- -- it printed 'wrong' in error messages
- SrcLoc
-
-unguardedRHS :: (HsExpr flexi id pat) -> SrcLoc -> [GRHS flexi id pat]
+data Match id pat
+ = Match
+ [HsTyVar 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
+ -- Nothing after typechecking
+
+ (GRHSs id pat)
+
+-- GRHSs are used both for pattern bindings and for Matches
+data GRHSs id pat
+ = GRHSs [GRHS id pat] -- Guarded RHSs
+ (HsBinds id pat) -- The where clause
+ (Maybe Type) -- Just rhs_ty after type checking
+
+data GRHS id pat
+ = GRHS [Stmt id pat] -- The RHS is the final ExprStmt
+ -- I considered using a RetunStmt, but
+ -- it printed 'wrong' in error messages
+ SrcLoc
+
+mkSimpleMatch :: [pat] -> HsExpr id pat -> Maybe Type -> SrcLoc -> Match id pat
+mkSimpleMatch pats rhs maybe_rhs_ty locn
+ = Match [] pats Nothing (GRHSs (unguardedRHS rhs locn) EmptyBinds maybe_rhs_ty)
+
+unguardedRHS :: HsExpr id pat -> SrcLoc -> [GRHS id pat]
unguardedRHS rhs loc = [GRHS [ExprStmt rhs loc] loc]
\end{code}
THis is something of a nuisance, but no more.
\begin{code}
-getMatchLoc :: Match flexi id pat -> SrcLoc
-getMatchLoc (PatMatch _ m) = getMatchLoc m
-getMatchLoc (GRHSMatch (GRHSsAndBindsIn (GRHS _ loc : _) _)) = loc
+getMatchLoc :: Match id pat -> SrcLoc
+getMatchLoc (Match _ _ _ (GRHSs (GRHS _ loc : _) _ _)) = loc
\end{code}
%************************************************************************
We know the list must have at least one @Match@ in it.
\begin{code}
pprMatches :: (NamedThing id, Outputable id, Outputable pat)
- => (Bool, SDoc) -> [Match flexi id pat] -> SDoc
-
-pprMatches print_info@(is_case, name) [match]
- = if is_case then
- pprMatch is_case match
- else
- name <+> (pprMatch is_case match)
+ => (Bool, SDoc) -> [Match id pat] -> SDoc
+pprMatches print_info matches = vcat (map (pprMatch print_info) matches)
-pprMatches print_info (match1 : rest)
- = ($$) (pprMatches print_info [match1])
- (pprMatches print_info rest)
----------------------------------------------
pprMatch :: (NamedThing id, Outputable id, Outputable pat)
- => Bool -> Match flexi id pat -> SDoc
-
-pprMatch is_case first_match
- = sep [(sep (map (ppr) row_of_pats)),
- grhss_etc_stuff]
- where
- (row_of_pats, grhss_etc_stuff) = ppr_match is_case first_match
-
- ppr_match is_case (PatMatch pat match)
- = (pat:pats, grhss_stuff)
- where
- (pats, grhss_stuff) = ppr_match is_case match
-
- ppr_match is_case (GRHSMatch grhss_n_binds)
- = ([], pprGRHSsAndBinds is_case grhss_n_binds)
-
- ppr_match is_case (SimpleMatch expr)
- = ([], text (if is_case then "->" else "=") <+> ppr expr)
-
-----------------------------------------------------------
-
-pprGRHSsAndBinds :: (NamedThing id, Outputable id, Outputable pat)
- => Bool -> GRHSsAndBinds flexi id pat -> SDoc
-
-pprGRHSsAndBinds is_case (GRHSsAndBindsIn grhss binds)
- = ($$) (vcat (map (pprGRHS is_case) grhss))
- (if (nullBinds binds)
- then empty
- else vcat [ text "where", nest 4 (pprDeeper (ppr binds)) ])
+ => (Bool, SDoc) -> Match id pat -> SDoc
+pprMatch print_info@(is_case, name) (Match _ pats maybe_ty grhss)
+ = maybe_name <+> sep [sep (map ppr pats),
+ ppr_maybe_ty,
+ nest 2 (pprGRHSs is_case grhss)]
+ where
+ maybe_name | is_case = empty
+ | otherwise = name
+ ppr_maybe_ty = case maybe_ty of
+ Just ty -> dcolon <+> ppr ty
+ Nothing -> empty
+
+
+pprGRHSs :: (NamedThing id, Outputable id, Outputable pat)
+ => Bool -> GRHSs id pat -> SDoc
+pprGRHSs is_case (GRHSs grhss binds maybe_ty)
+ = vcat (map (pprGRHS is_case) grhss)
+ $$
+ (if nullBinds binds then empty
+ else text "where" $$ nest 4 (pprDeeper (ppr binds)))
-pprGRHSsAndBinds is_case (GRHSsAndBindsOut grhss binds ty)
- = ($$) (vcat (map (pprGRHS is_case) grhss))
- (if (nullBinds binds)
- then empty
- else vcat [text "where", nest 4 (pprDeeper (ppr binds)) ])
----------------------------------------------
pprGRHS :: (NamedThing id, Outputable id, Outputable pat)
- => Bool -> GRHS flexi id pat -> SDoc
+ => Bool -> GRHS id pat -> SDoc
pprGRHS is_case (GRHS [ExprStmt expr _] locn)
= text (if is_case then "->" else "=") <+> pprDeeper (ppr expr)
OutPat(..),
irrefutablePat, irrefutablePats,
- failureFreePat,
+ failureFreePat, isWildPat,
patsAreAllCons, isConPat,
patsAreAllLits, isLitPat,
- collectPatBinders
+ collectPatBinders, collectPatsBinders
) where
#include "HsVersions.h"
-- friends:
import HsBasic ( HsLit )
import HsExpr ( HsExpr )
+import HsTypes ( HsType )
import BasicTypes ( Fixity )
-- others:
-import Var ( Id, GenTyVar )
+import Var ( Id, TyVar )
import DataCon ( DataCon, dataConTyCon )
import Maybes ( maybeToBool )
import Outputable
import TyCon ( maybeTyConSingleCon )
-import Type ( GenType )
+import Type ( Type )
\end{code}
Patterns come in distinct before- and after-typechecking flavo(u)rs.
| LazyPatIn (InPat name) -- lazy pattern
| AsPatIn name -- as pattern
(InPat name)
+ | SigPatIn (InPat name)
+ (HsType name)
| ConPatIn name -- constructed type
[InPat name]
| ConOpPatIn (InPat name)
| RecPatIn name -- record
[(name, InPat name, Bool)] -- True <=> source used punning
-data OutPat flexi id
- = WildPat (GenType flexi) -- wild card
+data OutPat id
+ = WildPat Type -- wild card
- | VarPat id -- variable (type is in the Id)
+ | VarPat id -- variable (type is in the Id)
- | LazyPat (OutPat flexi id) -- lazy pattern
+ | LazyPat (OutPat id) -- lazy pattern
- | AsPat id -- as pattern
- (OutPat flexi id)
+ | AsPat id -- as pattern
+ (OutPat id)
- | ListPat -- syntactic list
- (GenType flexi) -- the type of the elements
- [OutPat flexi id]
+ | ListPat -- syntactic list
+ Type -- the type of the elements
+ [OutPat id]
- | TuplePat [OutPat flexi id] -- tuple
+ | TuplePat [OutPat id] -- tuple
Bool -- boxed?
-- UnitPat is TuplePat []
| ConPat DataCon
- (GenType flexi) -- the type of the pattern
- [GenTyVar flexi] -- Existentially bound type variables
+ Type -- the type of the pattern
+ [TyVar] -- Existentially bound type variables
[id] -- Ditto dictionaries
- [OutPat flexi id]
+ [OutPat id]
-- ConOpPats are only used on the input side
| RecPat DataCon -- record constructor
- (GenType flexi) -- the type of the pattern
- [GenTyVar flexi] -- Existentially bound type variables
+ Type -- the type of the pattern
+ [TyVar] -- Existentially bound type variables
[id] -- Ditto dictionaries
- [(Id, OutPat flexi id, Bool)] -- True <=> source used punning
+ [(Id, OutPat id, Bool)] -- True <=> source used punning
| LitPat -- Used for *non-overloaded* literal patterns:
-- Int#, Char#, Int, Char, String, etc.
HsLit
- (GenType flexi) -- type of pattern
+ Type -- type of pattern
| NPat -- Used for *overloaded* literal patterns
HsLit -- the literal is retained so that
-- the desugarer can readily identify
-- equations with identical literal-patterns
- (GenType flexi) -- type of pattern, t
- (HsExpr flexi id (OutPat flexi id))
+ Type -- type of pattern, t
+ (HsExpr id (OutPat id))
-- of type t -> Bool; detects match
| NPlusKPat id
-- (This could be an Integer, but then
-- it's harder to partitionEqnsByLit
-- in the desugarer.)
- (GenType flexi) -- Type of pattern, t
- (HsExpr flexi id (OutPat flexi id)) -- Of type t -> Bool; detects match
- (HsExpr flexi id (OutPat flexi id)) -- Of type t -> t; subtracts k
+ Type -- Type of pattern, t
+ (HsExpr id (OutPat id)) -- Of type t -> Bool; detects match
+ (HsExpr id (OutPat id)) -- Of type t -> t; subtracts k
| DictPat -- Used when destructing Dictionaries with an explicit case
[id] -- superclass dicts
pprInPat (WildPatIn) = char '_'
pprInPat (VarPatIn var) = ppr var
pprInPat (LitPatIn s) = ppr s
+pprInPat (SigPatIn pat ty) = ppr pat <+> dcolon <+> ppr ty
pprInPat (LazyPatIn pat) = char '~' <> ppr pat
pprInPat (AsPatIn name pat) = parens (hcat [ppr name, char '@', ppr pat])
\end{code}
\begin{code}
-instance (Outputable id) => Outputable (OutPat flexi id) where
+instance (Outputable id) => Outputable (OutPat id) where
ppr = pprOutPat
\end{code}
The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are.
\begin{code}
-irrefutablePats :: [OutPat a b] -> Bool
+irrefutablePats :: [OutPat id] -> Bool
irrefutablePats pat_list = all irrefutablePat pat_list
irrefutablePat (AsPat _ pat) = irrefutablePat pat
irrefutablePat (DictPat ds ms) = (length ds + length ms) <= 1
irrefutablePat other = False
-failureFreePat :: OutPat a b -> Bool
+failureFreePat :: OutPat id -> Bool
failureFreePat (WildPat _) = True
failureFreePat (VarPat _) = True
\end{code}
\begin{code}
-patsAreAllCons :: [OutPat a b] -> Bool
+isWildPat (WildPat _) = True
+isWildPat other = False
+
+patsAreAllCons :: [OutPat id] -> Bool
patsAreAllCons pat_list = all isConPat pat_list
isConPat (AsPat _ pat) = isConPat pat
isConPat (DictPat ds ms) = (length ds + length ms) > 1
isConPat other = False
-patsAreAllLits :: [OutPat a b] -> Bool
+patsAreAllLits :: [OutPat id] -> Bool
patsAreAllLits pat_list = all isLitPat pat_list
isLitPat (AsPat _ pat) = isLitPat pat
This function @collectPatBinders@ works with the ``collectBinders''
functions for @HsBinds@, etc. The order in which the binders are
collected is important; see @HsBinds.lhs@.
+
\begin{code}
collectPatBinders :: InPat a -> [a]
-
-collectPatBinders WildPatIn = []
-collectPatBinders (VarPatIn var) = [var]
-collectPatBinders (LitPatIn _) = []
-collectPatBinders (LazyPatIn pat) = collectPatBinders pat
-collectPatBinders (AsPatIn a pat) = a : collectPatBinders pat
-collectPatBinders (NPlusKPatIn n _) = [n]
-collectPatBinders (ConPatIn c pats) = concat (map collectPatBinders pats)
-collectPatBinders (ConOpPatIn p1 c f p2) = collectPatBinders p1 ++ collectPatBinders p2
-collectPatBinders (NegPatIn pat) = collectPatBinders pat
-collectPatBinders (ParPatIn pat) = collectPatBinders pat
-collectPatBinders (ListPatIn pats) = concat (map collectPatBinders pats)
-collectPatBinders (TuplePatIn pats _) = concat (map collectPatBinders pats)
-collectPatBinders (RecPatIn c fields) = concat (map (\ (f,pat,_) -> collectPatBinders pat) fields)
+collectPatBinders pat = collect pat []
+
+collectPatsBinders :: [InPat a] -> [a]
+collectPatsBinders pats = foldr collect [] pats
+
+collect WildPatIn bndrs = bndrs
+collect (VarPatIn var) bndrs = var : bndrs
+collect (LitPatIn _) bndrs = bndrs
+collect (SigPatIn pat _) bndrs = collect pat bndrs
+collect (LazyPatIn pat) bndrs = collect pat bndrs
+collect (AsPatIn a pat) bndrs = a : collect pat bndrs
+collect (NPlusKPatIn n _) bndrs = n : bndrs
+collect (ConPatIn c pats) bndrs = foldr collect bndrs pats
+collect (ConOpPatIn p1 c f p2) bndrs = collect p1 (collect p2 bndrs)
+collect (NegPatIn pat) bndrs = collect pat bndrs
+collect (ParPatIn pat) bndrs = collect pat bndrs
+collect (ListPatIn pats) bndrs = foldr collect bndrs pats
+collect (TuplePatIn pats _) bndrs = foldr collect bndrs pats
+collect (RecPatIn c fields) bndrs = foldr (\ (f,pat,_) bndrs -> collect pat bndrs) bndrs fields
\end{code}
#include "HsVersions.h"
-- friends:
+import HsDecls
import HsBinds
-import HsDecls ( HsDecl(..), TyDecl(..), InstDecl(..), ClassDecl(..),
- DefaultDecl(..), ForeignDecl(..), ForKind(..),
- ExtName(..), isDynamic, FixityDecl(..),
- ConDecl(..), ConDetails(..), BangType(..),
- IfaceSig(..), SpecDataSig(..),
- hsDeclName
- )
import HsExpr
import HsImpExp
import HsBasic
import HsPat
import HsTypes
import HsCore
-import BasicTypes ( Fixity, Version, NewOrData, IfaceFlavour, Module )
+import BasicTypes ( Fixity, Version, NewOrData, IfaceFlavour )
-- others:
import Outputable
import SrcLoc ( SrcLoc )
import Bag
-import Name ( NamedThing )
+import Name ( Module, NamedThing, pprModule )
\end{code}
All we actually declare here is the top-level structure for a module.
\begin{code}
-data HsModule flexi name pat
+data HsModule name pat
= HsModule
Module -- module name
(Maybe Version) -- source interface version number
-- imported interfaces early on, adding that
-- info to TyDecls/etc; so this list is
-- often empty, downstream.
- [FixityDecl name]
- [HsDecl flexi name pat] -- Type, class, value, and interface signature decls
+ [HsDecl name pat] -- Type, class, value, and interface signature decls
SrcLoc
\end{code}
\begin{code}
instance (NamedThing name, Outputable name, Outputable pat)
- => Outputable (HsModule flexi name pat) where
+ => Outputable (HsModule name pat) where
- ppr (HsModule name iface_version exports imports fixities
+ ppr (HsModule name iface_version exports imports
decls src_loc)
= vcat [
case exports of
- Nothing -> hsep [ptext SLIT("module"), ptext name, ptext SLIT("where")]
+ Nothing -> hsep [ptext SLIT("module"), pprModule name, ptext SLIT("where")]
Just es -> vcat [
- hsep [ptext SLIT("module"), ptext name, lparen],
+ hsep [ptext SLIT("module"), pprModule name, lparen],
nest 8 (interpp'SP es),
nest 4 (ptext SLIT(") where"))
],
pp_nonnull imports,
- pp_nonnull fixities,
pp_nonnull decls
]
where
it should return @[x, y, f, a, b]@ (remember, order important).
\begin{code}
-collectTopBinders :: HsBinds flexi name (InPat name) -> Bag (name,SrcLoc)
+collectTopBinders :: HsBinds name (InPat name) -> Bag (name,SrcLoc)
collectTopBinders EmptyBinds = emptyBag
collectTopBinders (MonoBind b _ _) = collectMonoBinders b
collectTopBinders (ThenBinds b1 b2)
= collectTopBinders b1 `unionBags` collectTopBinders b2
-collectMonoBinders :: MonoBinds flexi name (InPat name) -> Bag (name,SrcLoc)
-collectMonoBinders EmptyMonoBinds = emptyBag
-collectMonoBinders (PatMonoBind pat grhss_w_binds loc) = listToBag (map (\v->(v,loc)) (collectPatBinders pat))
-collectMonoBinders (FunMonoBind f _ matches loc) = unitBag (f,loc)
-collectMonoBinders (VarMonoBind v expr) = error "collectMonoBinders"
-collectMonoBinders (CoreMonoBind v expr) = error "collectMonoBinders"
-collectMonoBinders (AndMonoBinds bs1 bs2)
- = collectMonoBinders bs1 `unionBags` collectMonoBinders bs2
+collectMonoBinders :: MonoBinds name (InPat name) -> Bag (name,SrcLoc)
+collectMonoBinders EmptyMonoBinds = emptyBag
+collectMonoBinders (PatMonoBind pat _ loc) = listToBag (map (\v->(v,loc)) (collectPatBinders pat))
+collectMonoBinders (FunMonoBind f _ matches loc) = unitBag (f,loc)
+collectMonoBinders (VarMonoBind v expr) = error "collectMonoBinders"
+collectMonoBinders (CoreMonoBind v expr) = error "collectMonoBinders"
+collectMonoBinders (AndMonoBinds bs1 bs2) = collectMonoBinders bs1 `unionBags`
+ collectMonoBinders bs2
\end{code}
import Type ( Kind )
import PprType ( {- instance Outputable Kind -} )
import Outputable
-import Util ( thenCmp, cmpList, panic )
+import Util ( thenCmp, cmpList )
\end{code}
This is the syntax for types as seen in type signatures.
instance (Outputable name) => Outputable (HsTyVar name) where
ppr (UserTyVar name) = ppr name
- ppr (IfaceTyVar name kind) = hsep [ppr name, ptext SLIT("::"), ppr kind]
+ ppr (IfaceTyVar name kind) = hsep [ppr name, dcolon, ppr kind]
pprForAll [] = empty
pprForAll tvs = ptext SLIT("forall") <+> interppSP tvs <> ptext SLIT(".")
pprClassAssertion :: (Outputable name) => ClassAssertion name -> SDoc
pprClassAssertion (clas, tys)
- = ppr clas <+> hsep (map ppr tys)
+ = ppr clas <+> hsep (map pprParendHsType tys)
\end{code}
\begin{code}
import Constants -- Default values for some flags
import Maybes ( assocMaybe, firstJust, maybeToBool )
-import Util ( startsWith, panic, panic# )
+import Panic ( panic, panic# )
#if __GLASGOW_HASKELL__ < 301
import ArrBase ( Array(..) )
SwInt int -> Just int
_ -> Nothing
\end{code}
+
+\begin{code}
+startsWith, endsWith :: String -> String -> Maybe String
+
+startsWith [] str = Just str
+startsWith (c:cs) (s:ss)
+ = if c /= s then Nothing else startsWith cs ss
+startsWith _ [] = Nothing
+
+endsWith cs ss
+ = case (startsWith (reverse cs) (reverse ss)) of
+ Nothing -> Nothing
+ Just rs -> Just (reverse rs)
+\end{code}
#include "../includes/MachRegs.h"
#include "../includes/Constants.h"
-import Util
+-- import Util
\end{code}
All pretty arbitrary:
import AsmCodeGen ( dumpRealAsm, writeRealAsm )
#endif
+import OccName ( Module, moduleString )
import AbsCSyn ( absCNop )
import AbsCUtils ( flattenAbsC )
import CmdLineOpts
case maybe_rn_stuff of {
Nothing -> -- Hurrah! Renamer reckons that there's no need to
-- go any further
- reportCompile (_UNPK_ mod_name) "Compilation NOT required!" >>
+ reportCompile mod_name "Compilation NOT required!" >>
return ();
Just (rn_mod, iface_file_stuff, rn_name_supply, imported_modules) ->
Just (all_binds,
local_tycons, local_classes, inst_info,
fo_decls,
- ddump_deriv,
global_env,
global_ids) ->
-
-- ******* DESUGARER
show_pass "DeSugar" >>
_scc_ "DeSugar"
let
local_data_tycons = filter isDataTyCon local_tycons
in
- core2core core_cmds mod_name
+ core2core core_cmds mod_name local_classes
sm_uniqs desugared
>>=
\ simplified ->
flat_abstractC = flattenAbsC fl_uniqs abstractC
in
+ dumpIfSet opt_D_dump_absC "Abstract C" (dumpRealC abstractC) >>
+
show_pass "CodeOutput" >>
_scc_ "CodeOutput"
-- You can have C (c_output) or assembly-language (ncg_output),
dumpIfSet opt_D_dump_realC "Real C" c_output_d >>
doOutput opt_ProduceC c_output_w >>
- reportCompile (_UNPK_ mod_name) (showSDoc (ppSourceStats True rdr_module)) >>
+ reportCompile mod_name (showSDoc (ppSourceStats True rdr_module)) >>
ghcExit 0
} }
Nothing -> return ()
Just fname -> writeFile fname ("#include \"Rts.h\"\n#include \"RtsAPI.h\"\n"++rest)
where
- rest = "#include "++show ((_UNPK_ mod_name) ++ "_stub.h") ++ '\n':doc_str
+ rest = "#include "++show (moduleString mod_name ++ "_stub.h") ++ '\n':doc_str
outputHStub switch "" = return ()
outputHStub switch doc_str
Nothing -> return ()
Just fname -> writeFile fname ("#include \"Rts.h\"\n"++doc_str)
-ppSourceStats short (HsModule name version exports imports fixities decls src_loc)
+ppSourceStats short (HsModule name version exports imports decls src_loc)
= (if short then hcat else vcat)
(map pp_val
[("ExportAll ", export_all), -- 1 if no export list
trim ls = takeWhile (not.isSpace) (dropWhile isSpace ls)
- fixity_ds = length fixities
- type_decls = [d | TyD d@(TySynonym _ _ _ _) <- decls]
- data_decls = [d | TyD d@(TyData DataType _ _ _ _ _ _ _) <- decls]
- newt_decls = [d | TyD d@(TyData NewType _ _ _ _ _ _ _) <- decls]
- type_ds = length type_decls
- data_ds = length data_decls
- newt_ds = length newt_decls
- class_decls = [d | ClD d <- decls]
- class_ds = length class_decls
+ fixity_ds = length [() | FixD d <- decls]
+ -- NB: this omits fixity decls on local bindings and
+ -- in class decls. ToDo
+
+ tycl_decls = [d | TyClD d <- decls]
+ (class_ds, data_ds, newt_ds, type_ds) = countTyClDecls tycl_decls
+
inst_decls = [d | InstD d <- decls]
inst_ds = length inst_decls
default_ds = length [() | DefD _ <- decls]
(import_no, import_qual, import_as, import_all, import_partial, import_hiding)
= foldr add6 (0,0,0,0,0,0) (map import_info imports)
(data_constrs, data_derivs)
- = foldr add2 (0,0) (map data_info (newt_decls ++ data_decls))
+ = foldr add2 (0,0) (map data_info tycl_decls)
(class_method_ds, default_method_ds)
- = foldr add2 (0,0) (map class_info class_decls)
+ = foldr add2 (0,0) (map class_info tycl_decls)
(inst_method_ds, method_specs, method_inlines)
= foldr add3 (0,0,0) (map inst_info inst_decls)
count_binds (MonoBind b sigs _) = case (count_monobinds b, count_sigs sigs) of
((vs,fs),(ts,_,ss,is)) -> (vs,fs,ts,ss,is)
- count_monobinds EmptyMonoBinds = (0,0)
- count_monobinds (AndMonoBinds b1 b2) = count_monobinds b1 `add2` count_monobinds b2
+ count_monobinds EmptyMonoBinds = (0,0)
+ count_monobinds (AndMonoBinds b1 b2) = count_monobinds b1 `add2` count_monobinds b2
count_monobinds (PatMonoBind (VarPatIn n) r _) = (1,0)
- count_monobinds (PatMonoBind p r _) = (0,1)
- count_monobinds (FunMonoBind f _ m _) = (0,1)
+ count_monobinds (PatMonoBind p r _) = (0,1)
+ count_monobinds (FunMonoBind f _ m _) = (0,1)
count_sigs sigs = foldr add4 (0,0,0,0) (map sig_info sigs)
data_info (TyData _ _ _ _ constrs derivs _ _)
= (length constrs, case derivs of {Nothing -> 0; Just ds -> length ds})
+ data_info other = (0,0)
class_info (ClassDecl _ _ _ meth_sigs def_meths _ _ _ _)
= case count_sigs meth_sigs of
(_,classops,_,_) ->
(classops, addpr (count_monobinds def_meths))
+ class_info other = (0,0)
inst_info (InstDecl _ inst_meths inst_sigs _ _)
= case count_sigs inst_sigs of
\end{code}
\begin{code}
-reportCompile :: String -> String -> IO ()
+reportCompile :: Module -> String -> IO ()
#if REPORT_TO_MOTHERLODE && __GLASGOW_HASKELL__ >= 303
reportCompile mod_name info
| not opt_ReportCompile = return ()
| otherwise = (do
sock <- udpSocket 0
addr <- motherShip
- sendTo sock (mod_name++ ';': compiler_version ++ ';': os ++ ';':arch ++ '\n':' ':info ++ "\n") addr
+ sendTo sock (moduleString mod_name ++ ';': compiler_version ++ ';': os ++ ';':arch ++ '\n':' ':info ++ "\n") addr
return ()) `catch` (\ _ -> return ())
motherShip :: IO SockAddr
import HsSyn
import RdrHsSyn ( RdrName(..) )
import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..), IfaceFlavour(..),
- StrictnessMark(..),
- pprModule
+ StrictnessMark(..)
)
import RnMonad
import RnEnv ( availName, ifaceFlavour )
arityInfo, ppArityInfo,
strictnessInfo, ppStrictnessInfo,
cafInfo, ppCafInfo,
- bottomIsGuaranteed, workerExists,
+ workerExists, isBottomingStrictness
)
import CoreSyn ( CoreExpr, CoreBind, Bind(..) )
import CoreUtils ( exprSomeFreeVars )
import CoreUnfold ( calcUnfoldingGuidance, UnfoldingGuidance(..),
Unfolding, okToUnfoldInHiFile )
import Name ( isLocallyDefined, isWiredInName, modAndOcc, nameModule,
- OccName, occNameString, isExported,
+ OccName, pprOccName, pprModule, isExported, moduleString,
Name, NamedThing(..)
)
import TyCon ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon,
import Class ( Class, classBigSig )
import SpecEnv ( specEnvToList )
import FieldLabel ( fieldLabelName, fieldLabelType )
-import Type ( mkSigmaTy, splitSigmaTy, mkDictTy,
+import Type ( mkSigmaTy, splitSigmaTy, mkDictTy, tidyTopType,
Type, ThetaType
)
Nothing -> return Nothing -- not producing any .hi file
Just fn -> do
if_hdl <- openFile fn WriteMode
- hPutStr if_hdl ("__interface "++ _UNPK_ mod ++ ' ':show (opt_HiVersion :: Int))
+ hPutStr if_hdl ("__interface " ++ moduleString mod ++ ' ':show (opt_HiVersion :: Int))
hPutStrLn if_hdl " where"
return (Just if_hdl)
where
upp_uses (m, hif, mv, whats_imported)
= ptext SLIT("import ") <>
- hsep [pprModule m, pp_hif hif, int mv, ptext SLIT("::"),
+ hsep [pprModule m, pp_hif hif, int mv, dcolon,
upp_import_versions whats_imported
] <> semi
ifaceInstanceModules if_hdl [] = return ()
ifaceInstanceModules if_hdl imods
= let sorted = sortLt (<) imods
- lines = map (\m -> ptext SLIT("__instimport ") <> ptext m <>
+ lines = map (\m -> ptext SLIT("__instimport ") <> pprModule m <>
ptext SLIT(" ;")) sorted
in
printForIface if_hdl (vcat lines) >>
pp_inst (InstInfo clas tvs tys theta dfun_id _ _ _)
= let
forall_ty = mkSigmaTy tvs theta (mkDictTy clas tys)
- renumbered_ty = nmbrGlobalType forall_ty
+ renumbered_ty = tidyTopType forall_ty
in
hcat [ptext SLIT("instance "), pprType renumbered_ty,
ptext SLIT(" = "), ppr_unqual_name dfun_id, semi]
idinfo = get_idinfo id
inline_pragma = inlinePragInfo idinfo
- ty_pretty = pprType (nmbrGlobalType (idType id))
- sig_pretty = hcat [ppr (getOccName id), ptext SLIT(" :: "), ty_pretty]
+ ty_pretty = pprType (idType id)
+ sig_pretty = hsep [ppr (getOccName id), dcolon, ty_pretty]
prag_pretty
| opt_OmitInterfacePragmas = empty
------------ Strictness --------------
strict_info = strictnessInfo idinfo
has_worker = workerExists strict_info
+ bottoming_fn = isBottomingStrictness strict_info
strict_pretty = ppStrictnessInfo strict_info <+> wrkr_pretty
wrkr_pretty | not has_worker = empty
unfold_pretty | show_unfold = unfold_herald <+> pprIfaceUnfolding rhs
| otherwise = empty
- show_unfold = not implicit_unfolding && -- Not unnecessary
+ show_unfold = not has_worker && -- Not unnecessary
+ not bottoming_fn && -- Not necessary
unfolding_needed -- Not dangerous
unfolding_needed = case inline_pragma of
NoInlinePragInfo -> rhs_is_small
other -> False
- implicit_unfolding = has_worker ||
- bottomIsGuaranteed strict_info
unfold_herald = case inline_pragma of
NoInlinePragInfo -> ptext SLIT("__u")
ppr_field (strict_mark, field_label)
= hsep [ ppr (fieldLabelName field_label),
- ptext SLIT("::"),
+ dcolon,
ppr_strict_mark strict_mark <> pprParendType (fieldLabelType field_label)
]
= ASSERT( sel_tyvars == clas_tyvars)
hsep [ppr (getOccName sel_id),
if maybeToBool maybe_defm then equals else empty,
- ptext SLIT("::"),
+ dcolon,
ppr op_ty
]
where
AvailTC C [x, y] C!(x,y) -- Exporting x, y but not C
\begin{code}
+upp_avail :: AvailInfo -> SDoc
upp_avail NotAvailable = empty
-upp_avail (Avail name) = upp_occname (getOccName name)
+upp_avail (Avail name) = pprOccName (getOccName name)
upp_avail (AvailTC name []) = empty
-upp_avail (AvailTC name ns) = hcat [upp_occname (getOccName name), bang, upp_export ns']
+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 (upp_occname . getOccName) names))
+upp_export names = braces (hsep (map (pprOccName . getOccName) names))
-upp_fixity (occ, fixity) = hcat [ppr fixity, space, upp_occname occ, semi]
+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 = upp_occname (getOccName name)
-
-upp_occname :: OccName -> SDoc
-upp_occname occ = ptext (occNameString occ)
+ppr_unqual_name name = pprOccName (getOccName name)
\end{code}
import StixMacro ( macroCode, checkCode )
import StixPrim ( primCode, amodeToStix, amodeToStix' )
import UniqSupply ( returnUs, thenUs, mapUs, getUniqueUs, UniqSM )
-import Util ( naturalMergeSortLe, panic )
+import Util ( naturalMergeSortLe )
+import Panic ( panic )
import BitSet ( intBS )
#ifdef REALLY_HASKELL_1_3
import PrimOp ( commutableOp, PrimOp(..) )
import RegAllocInfo ( mkMRegsState, MRegsState )
import Stix ( StixTree(..), StixReg(..) )
-import PrimRep ( isFloatingRep )
import UniqSupply ( returnUs, thenUs, mapUs, initUs, UniqSM, UniqSupply )
-import UniqFM ( UniqFM, emptyUFM, addToUFM, lookupUFM )
import Outputable
-
-import GlaExts (trace) --tmp
-#include "nativeGen/NCG.h"
\end{code}
The 96/03 native-code generator has machine-independent and
let
stix = map (map genericOpt) treelists
in
-#if i386_TARGET_ARCH
- let
- stix' = map floatFix stix
- in
- codeGen stix'
-#else
codeGen stix
-#endif
\end{code}
@codeGen@ is the top-level code-generation function:
\begin{code}
primOpt op args = StPrim op args
\end{code}
-
------------------------------------------------------------------------------
-Fix up floating point operations for x86.
-
-The problem is that the code generator can't handle the weird register
-naming scheme for floating point registers on the x86, so we have to
-deal with memory-resident floating point values wherever possible.
-
-We therefore can't stand references to floating-point kinded temporary
-variables, and try to translate them into memory addresses wherever
-possible.
-
-\begin{code}
-floatFix :: [StixTree] -> [StixTree]
-floatFix trees = fltFix emptyUFM trees
-
-fltFix :: UniqFM StixTree -- mapping tmp vars to memory locations
- -> [StixTree]
- -> [StixTree]
-fltFix locs [] = []
-
--- The case we're interested in: loading a temporary from a memory
--- address. Eliminate the instruction and replace all future references
--- to the temporary with the memory address.
-fltFix locs ((StAssign rep (StReg (StixTemp uq _)) loc) : trees)
- | isFloatingRep rep = trace "found one" $ fltFix (addToUFM locs uq loc) trees
-
-fltFix locs ((StAssign rep src dst) : trees)
- = StAssign rep (fltFix1 locs src) (fltFix1 locs dst) : fltFix locs trees
-
-fltFix locs (tree : trees)
- = fltFix1 locs tree : fltFix locs trees
-
-
-fltFix1 :: UniqFM StixTree -> StixTree -> StixTree
-fltFix1 locs r@(StReg (StixTemp uq rep))
- | isFloatingRep rep = case lookupUFM locs uq of
- Nothing -> panic "fltFix1"
- Just tree -> trace "substed" $ tree
-
-fltFix1 locs (StIndex rep l r) =
- StIndex rep (fltFix1 locs l) (fltFix1 locs r)
-
-fltFix1 locs (StInd rep tree) =
- StInd rep (fltFix1 locs tree)
-
-fltFix1 locs (StAssign rep dst src) = panic "fltFix1: StAssign"
-
-fltFix1 locs (StJump tree) = StJump (fltFix1 locs tree)
-
-fltFix1 locs (StCondJump label tree) =
- StCondJump label (fltFix1 locs tree)
-
-fltFix1 locs (StPrim op trees) =
- StPrim op (map (fltFix1 locs) trees)
-
-fltFix1 locs (StCall f conv rep trees) =
- StCall f conv rep (map (fltFix1 locs) trees)
-
-fltFix1 locs tree = tree
-\end{code}
flattenOrdList, OrdList
)
import Unique ( mkBuiltinUnique )
-import Util ( mapAccumB, panic, trace )
+import Util ( mapAccumB )
import Outputable
\end{code}
mapAccumLUs, UniqSM
)
import Outputable
-import GlaExts (trace) --tmp
\end{code}
Code extractor for an entire stix tree---stix statement level.
returnUs code__2
assignFltCode pk dst src
- = trace "assignFltCode: dodgy floating point instruction" $
- getRegister dst `thenUs` \ register1 ->
+ = getRegister dst `thenUs` \ register1 ->
getRegister src `thenUs` \ register2 ->
--getNewRegNCG (registerRep register2)
-- `thenUs` \ tmp ->
import PrimRep ( PrimRep(..) )
import SMRep ( SMRep(..) )
import Stix ( StixTree(..), StixReg(..), CodeSegment )
-import Util ( panic )
+import Panic ( panic )
import Char ( isDigit )
import GlaExts ( word2Int#, int2Word#, shiftRL#, and#, (/=#) )
\end{code}
module U_literal,
module U_maybe,
module U_either,
- module U_pbinding,
+ module U_grhsb,
+ module U_gdexp,
+ module U_match,
module U_qid,
module U_tree,
module U_ttype
import U_literal
import U_maybe
import U_either
-import U_pbinding
+import U_gdexp
+import U_grhsb
+import U_match
import U_qid
import U_tree
import U_ttype
y z stuff
initUgn :: UgnM a -> IO a
-initUgn action = action (SLIT(""),SLIT(""),noSrcLoc)
+initUgn action = action (SLIT(""),mkModule "",noSrcLoc)
ioToUgnM :: IO a -> UgnM a
ioToUgnM x stuff = x
import U_ttype
%}}
type binding;
+ nullbind : < >;
+
+ /* And-bind; just concat two decl blobs together */
+ abind : < gabindfst : binding;
+ gabindsnd : binding; >;
+
+ /* Import decl */
+ import : < gibindimod : stringId;
+ gibindqual : long;
+ gibindas : maybe;
+ gibindspec : maybe;
+ gibindsource : long;
+ gibindline : long; >;
+
+ /* Fixity decl */
+ fixd : < gfixop : qid;
+ gfixinfx : long;
+ gfixprec : long;
+ gfixline : long; >;
+
+
+ /* Class declaration */
+ cbind : < gcbindc : list;
+ gcbindid : ttype;
+ gcbindw : binding;
+ gcline : long; >;
+
+ /* Instance declaration */
+ ibind : < gibindi : ttype;
+ gibindw : binding;
+ giline : long; >;
+
+ /* data type declaration */
tbind : < gtbindc : list; /* [context entries] */
gtbindid : ttype; /* applied tycon */
gtbindl : list; /* [constr] */
gtbindd : maybe; /* Maybe [deriving] */
gtline : long; >;
+
+ /* newtype declaration */
ntbind : < gntbindc : list; /* [context entries] */
gntbindid : ttype; /* applied tycon */
gntbindcty : list; /* [constr] (only 1 constrnew) */
gntbindd : maybe; /* Maybe [deriving] */
gntline : long; >;
+
+ /* type synonym declaration */
nbind : < gnbindid : ttype;
gnbindas : ttype;
gnline : long; >;
- pbind : < gpbindl : list;
+
+ /* Pattern binding */
+ pbind : < gpbindl : VOID_STAR; /* The pattern, of type tree;
+ we can't say 'tree' because
+ that gives mutual recursion in the C */
+ gpbindr : VOID_STAR; /* The RHS, of type grhsb; same nonsense */
gpline : long; >;
- fbind : < gfbindl : list;
+ /* Function binding */
+ fbind : < gfbindm : list; /* List of matches */
+ /* The match encodes the LHS as well as RHS */
gfline : long; >;
- abind : < gabindfst : binding;
- gabindsnd : binding; >;
- ibind : < gibindi : ttype;
- gibindw : binding;
- giline : long; >;
+
+ /* Default decl */
dbind : < gdbindts : list;
gdline : long; >;
- cbind : < gcbindc : list;
- gcbindid : ttype;
- gcbindw : binding;
- gcline : long; >;
+
+ /* Type signature */
sbind : < gsbindids : list;
gsbindid : ttype;
gsline : long; >;
- nullbind : < >;
-
- import : < gibindimod : stringId;
- gibindqual : long;
- gibindas : maybe;
- gibindspec : maybe;
- gibindsource : long;
- gibindline : long; >;
-
/* FFI declarations */
-
fobind : < gfobind_id : qid;
gfobind_ty : ttype;
gfobind_ext : maybe;
--- /dev/null
+%{
+#include "hspincl.h"
+%}
+%{{
+module U_gdexp where
+
+#include "HsVersions.h"
+
+import UgenUtil
+
+import U_list
+import U_tree
+%}}
+
+type gdexp;
+ pgdexp : < gpguard : list /* of quals */ ; /* Experimental change: guards are lists of quals */
+ gpgline : long; /* Line number of '=' sign */
+ gpexp : tree; >;
+end;
--- /dev/null
+%{
+#include "hspincl.h"
+%}
+%{{
+module U_grhsb where
+
+#include "HsVersions.h"
+
+import UgenUtil
+
+import U_binding
+import U_list
+%}}
+
+/* Guarded right hand sides and bindings */
+type grhsb;
+ pguards : < ggrhss : list; /* of gdexp */
+ ggbind1 : binding; >;
+ pnoguards : < gnogline : long; /* Line number of '=' sign */
+ grhs : VOID_STAR; /* The rhs, of type tree; can't say 'tree' because
+ that leads to mutual recursion in the C */
+ ggbind2 : binding; >;
+end;
+
extern list reverse_list();
extern tree root;
-/* For FN, PREVPATT and SAMEFN macros */
+/* For FN, SAMEFN macros */
extern qid fns[];
extern BOOLEAN samefn[];
-extern tree prevpatt[];
extern short icontexts;
/* Line Numbers */
ttype uttype;
constr uconstr;
binding ubinding;
- pbinding upbinding;
+ match umatch;
+ gdexp ugdexp;
+ grhsb ugrhsb;
entidt uentid;
id uid;
qid uqid;
**********************************************************************/
-%type <ulist> caserest alts alt quals
+%type <ulist> caserest alts quals
dorest stmts stmt
rbinds rbinds1 rpats rpats1 list_exps list_rest
qvarsk qvars_list
export_list enames
import_list inames
impdecls maybeimpdecls impdecl
- maybefixes fixes fix ops
dtyclses dtycls_list
- gdrhs gdpat valrhs
+ gdrhs gdpat
lampats cexps gd texps
tyvars1 constr_context forall
+%type <umatch> alt
+
+%type <ugrhsb> valrhs altrhs
+
%type <umaybe> maybeexports impspec deriving
- ext_name
+ ext_name opt_sig opt_asig
%type <uliteral> lit_constant
%type <utree> exp oexp dexp kexp fexp aexp rbind
expL oexpL kexpL expLno oexpLno dexpLno kexpLno
- vallhs funlhs qual leftexp
- pat cpat bpat apat apatc conpat rpat
- patk bpatk apatck conpatk
+ funlhs funlhs1 funlhs2 funlhs3 qual leftexp
+ pat dpat cpat bpat apat apatc conpat rpat
+ patk bpatk apatck conpatk
%type <uid> MINUS PLUS DARROW AS LAZY
%type <ubinding> topdecl topdecls letdecls
typed datad newtd classd instd defaultd foreignd
- decl decls valdef instdef instdefs
+ decl decls fixdecl fix_op fix_ops valdef
maybe_where cbody rinst type_and_maybe_id
-%type <upbinding> valrhs1 altrest
-
%type <uttype> polytype
conargatype conapptype
tautype
body
;
-body : ocurly { setstartlineno(); } interface_pragma orestm
- | vocurly interface_pragma vrestm
+body : ocurly { setstartlineno(); } main_body ccurly
+ | vocurly main_body vccurly
;
-interface_pragma : /* empty */
- | INTERFACE_UPRAGMA INTEGER END_UPRAGMA SEMI
- {
- source_version = atoi($2);
- }
- ;
-
-orestm : maybeimpdecls maybefixes topdecls ccurly
+main_body : interface_pragma maybeimpdecls topdecls
{
- root = mkhmodule(the_module_name,$1,module_exports,
- $2,$3,source_version,modulelineno);
+ root = mkhmodule(the_module_name, $2, module_exports,
+ $3, source_version,modulelineno);
}
- | impdecls ccurly
+ | interface_pragma impdecls
{
- root = mkhmodule(the_module_name,$1,module_exports,
- Lnil,mknullbind(),source_version,modulelineno);
+ root = mkhmodule(the_module_name, $2, module_exports,
+ mknullbind(), source_version, modulelineno);
}
-vrestm : maybeimpdecls maybefixes topdecls vccurly
- {
- root = mkhmodule(the_module_name,$1,module_exports,
- $2,$3,source_version,modulelineno);
- }
- | impdecls vccurly
+interface_pragma : /* empty */
+ | INTERFACE_UPRAGMA INTEGER END_UPRAGMA SEMI
{
- root = mkhmodule(the_module_name,$1,module_exports,
- Lnil,mknullbind(),source_version,modulelineno);
+ source_version = atoi($2);
}
+ ;
maybeexports : /* empty */ { $$ = mknothing(); }
| OPAREN export_list CPAREN { $$ = mkjust($2); }
* *
**********************************************************************/
-maybefixes: /* empty */ { $$ = Lnil; }
- | fixes SEMI { $$ = $1; }
- ;
-
-fixes : fix { $$ = $1; }
- | fixes SEMI fix { $$ = lconc($1,$3); }
- ;
-
-fix : INFIXL INTEGER { Precedence = checkfixity($2); Fixity = INFIXL; }
- ops { $$ = $4; }
- | INFIXR INTEGER { Precedence = checkfixity($2); Fixity = INFIXR; }
- ops { $$ = $4; }
- | INFIX INTEGER { Precedence = checkfixity($2); Fixity = INFIX; }
- ops { $$ = $4; }
- | INFIXL { Fixity = INFIXL; Precedence = 9; }
- ops { $$ = $3; }
- | INFIXR { Fixity = INFIXR; Precedence = 9; }
- ops { $$ = $3; }
- | INFIX { Fixity = INFIX; Precedence = 9; }
- ops { $$ = $3; }
- ;
-
-ops : op { $$ = lsing(mkfixop(mknoqual($1),infixint(Fixity),Precedence,startlineno)); }
- | ops COMMA op { $$ = lapp($1,mkfixop(mknoqual($3),infixint(Fixity),Precedence,startlineno)); }
- ;
-
topdecls: topdecl
| topdecls SEMI topdecl
{
;
-rinst : /* empty */ { $$ = mknullbind(); }
- | WHERE ocurly instdefs ccurly { $$ = $3; }
- | WHERE vocurly instdefs vccurly { $$ = $3; }
+rinst : /* empty */ { $$ = mknullbind(); }
+ | WHERE ocurly decls ccurly { $$ = $3; }
+ | WHERE vocurly decls vccurly { $$ = $3; }
;
defaultd: defaultkey OPAREN tautypes CPAREN { $$ = mkdbind($3,startlineno); }
;
/* FFI primitive declarations - GHC/Hugs specific */
-foreignd: foreignkey IMPORT callconv ext_name unsafe_flag qvarid DCOLON tautype { $$ = mkfobind($6,$8,$4,$5,$3,FOREIGN_IMPORT,startlineno); }
- | foreignkey EXPORT callconv ext_name qvarid DCOLON tautype { $$ = mkfobind($5,$7,$4,0,$3,FOREIGN_EXPORT,startlineno); }
- ;
- | foreignkey LABEL ext_name qvarid DCOLON tautype { $$ = mkfobind($4,$6,$3,0,-1,FOREIGN_LABEL,startlineno); }
+foreignd: foreignkey IMPORT callconv ext_name unsafe_flag qvarid DCOLON tautype
+ { $$ = mkfobind($6,$8,$4,$5,$3,FOREIGN_IMPORT,startlineno); }
+ | foreignkey EXPORT callconv ext_name qvarid DCOLON tautype
+ { $$ = mkfobind($5,$7,$4,0,$3,FOREIGN_EXPORT,startlineno); }
+ | foreignkey LABEL ext_name qvarid DCOLON tautype
+ { $$ = mkfobind($4,$6,$3,0,-1,FOREIGN_LABEL,startlineno); }
;
callconv: STDCALL { $$ = CALLCONV_STDCALL; }
to real mischief (ugly, but likely to work).
*/
-decl : qvarsk DCOLON polytype
+decl : fixdecl
+
+ | qvarsk DCOLON polytype
{ $$ = mksbind($1,$3,startlineno);
- PREVPATT = NULL; FN = NULL; SAMEFN = 0;
+ FN = NULL; SAMEFN = 0;
+ }
+
+ | qvark DCOLON polytype
+ { $$ = mksbind(lsing($1),$3,startlineno);
+ FN = NULL; SAMEFN = 0;
}
/* User-specified pragmas come in as "signatures"...
| SPECIALISE_UPRAGMA qvark DCOLON types_and_maybe_ids END_UPRAGMA
{
$$ = mkvspec_uprag($2, $4, startlineno);
- PREVPATT = NULL; FN = NULL; SAMEFN = 0;
+ FN = NULL; SAMEFN = 0;
}
| SPECIALISE_UPRAGMA INSTANCE gtycon atype END_UPRAGMA
{
$$ = mkispec_uprag($3, $4, startlineno);
- PREVPATT = NULL; FN = NULL; SAMEFN = 0;
+ FN = NULL; SAMEFN = 0;
}
| SPECIALISE_UPRAGMA DATA gtycon atypes END_UPRAGMA
{
$$ = mkdspec_uprag($3, $4, startlineno);
- PREVPATT = NULL; FN = NULL; SAMEFN = 0;
+ FN = NULL; SAMEFN = 0;
}
| INLINE_UPRAGMA qvark END_UPRAGMA
{
$$ = mkinline_uprag($2, startlineno);
- PREVPATT = NULL; FN = NULL; SAMEFN = 0;
+ FN = NULL; SAMEFN = 0;
}
| NOINLINE_UPRAGMA qvark END_UPRAGMA
{
$$ = mknoinline_uprag($2, startlineno);
- PREVPATT = NULL; FN = NULL; SAMEFN = 0;
+ FN = NULL; SAMEFN = 0;
}
| MAGIC_UNFOLDING_UPRAGMA qvark vark END_UPRAGMA
{
$$ = mkmagicuf_uprag($2, $3, startlineno);
- PREVPATT = NULL; FN = NULL; SAMEFN = 0;
+ FN = NULL; SAMEFN = 0;
}
/* end of user-specified pragmas */
| valdef
- | /* empty */ { $$ = mknullbind(); PREVPATT = NULL; FN = NULL; SAMEFN = 0; }
+ | /* empty */ { $$ = mknullbind(); FN = NULL; SAMEFN = 0; }
;
+fixdecl : INFIXL INTEGER { Precedence = checkfixity($2); Fixity = INFIXL; }
+ fix_ops { $$ = $4; }
+ | INFIXR INTEGER { Precedence = checkfixity($2); Fixity = INFIXR; }
+ fix_ops { $$ = $4; }
+ | INFIX INTEGER { Precedence = checkfixity($2); Fixity = INFIX; }
+ fix_ops { $$ = $4; }
+ | INFIXL { Fixity = INFIXL; Precedence = 9; }
+ fix_ops { $$ = $3; }
+ | INFIXR { Fixity = INFIXR; Precedence = 9; }
+ fix_ops { $$ = $3; }
+ | INFIX { Fixity = INFIX; Precedence = 9; }
+ fix_ops { $$ = $3; }
+ ;
+
+/* Grotesque global-variable hack to
+ make a separate fixity decl for each op */
+fix_ops : fix_op
+ | fix_ops COMMA fix_op { $$ = mkabind($1,$3); }
+ ;
+
+fix_op : op { $$ = mkfixd(mknoqual($1),infixint(Fixity),Precedence,startlineno); }
+ ;
+
qvarsk : qvark COMMA qvars_list { $$ = mklcons($1,$3); }
- | qvark { $$ = lsing($1); }
;
qvars_list: qvar { $$ = lsing($1); }
/* C a b c, where a,b,c are type variables */
/* C can be a class or tycon */
+
+/* simple_con_app can have no args; simple_con_app1 must have at least one */
simple_con_app: gtycon { $$ = mktname($1); }
| simple_con_app1 { $$ = $1; }
;
simple_con_app1: gtycon tyvar { $$ = mktapp(mktname($1),mknamedtvar($2)); }
- | simple_con_app tyvar { $$ = mktapp($1, mknamedtvar($2)); }
+ | simple_con_app1 tyvar { $$ = mktapp($1, mknamedtvar($2)); }
;
simple_context : OPAREN simple_context_list CPAREN { $$ = $2; }
| dtycls_list COMMA qtycls { $$ = lapp($1,$3); }
;
-instdefs : /* empty */ { $$ = mknullbind(); }
- | instdef { $$ = $1; }
- | instdefs SEMI instdef
- {
- if(SAMEFN)
- {
- extendfn($1,$3);
- $$ = $1;
- }
- else
- $$ = mkabind($1,$3);
- }
- ;
-
-/* instdef: same as valdef, except certain user-pragmas may appear */
-instdef :
- SPECIALISE_UPRAGMA qvark DCOLON types_and_maybe_ids END_UPRAGMA
- {
- $$ = mkvspec_uprag($2, $4, startlineno);
- PREVPATT = NULL; FN = NULL; SAMEFN = 0;
- }
-
- | INLINE_UPRAGMA qvark END_UPRAGMA
- {
- $$ = mkinline_uprag($2, startlineno);
- PREVPATT = NULL; FN = NULL; SAMEFN = 0;
- }
-
- | NOINLINE_UPRAGMA qvark END_UPRAGMA
- {
- $$ = mknoinline_uprag($2, startlineno);
- PREVPATT = NULL; FN = NULL; SAMEFN = 0;
- }
-
- | MAGIC_UNFOLDING_UPRAGMA qvark vark END_UPRAGMA
- {
- $$ = mkmagicuf_uprag($2, $3, startlineno);
- PREVPATT = NULL; FN = NULL; SAMEFN = 0;
- }
-
- | valdef
- ;
-
+valdef : funlhs opt_sig { checksamefn($1); }
+ get_line_no valrhs { $$ = mkfbind( lsing(mkpmatch( lsing($1), $2, $5 )), $4); }
-valdef : vallhs
+/* Special case for f :: type = e
+ We treat it as a special kind of pattern binding */
+ | qvark DCOLON tautype
+ get_line_no valrhs { $$ = mkpbind( mkrestr( mkident($1), $3 ), $5, $4 );
+ FN = NULL; SAMEFN = 0; }
- {
- tree fn = function($1);
- PREVPATT = $1;
+ | patk
+ get_line_no valrhs { $$ = mkpbind($1, $3, $2);
+ FN = NULL; SAMEFN = 0; }
- if(ttree(fn) == ident)
- {
- qid fun_id = gident((struct Sident *) fn);
- checksamefn(fun_id);
- FN = fun_id;
- }
-
- else if (ttree(fn) == infixap)
- {
- qid fun_id = ginffun((struct Sinfixap *) fn);
- checksamefn(fun_id);
- FN = fun_id;
- }
-
- else if(etags)
-#if 1/*etags*/
- printf("%u\n",startlineno);
-#else
- fprintf(stderr,"%u\tvaldef\n",startlineno);
-#endif
- }
-
- get_line_no
- valrhs
- {
- if ( lhs_is_patt($1) )
- {
- $$ = mkpbind($4, $3);
- FN = NULL;
- SAMEFN = 0;
- }
- else
- $$ = mkfbind($4, $3);
-
- PREVPATT = NULL;
- }
- ;
-
-get_line_no : { $$ = startlineno; }
+get_line_no : { $$ = hsplineno; /* startlineno; */ }
;
+/* This grammar still isn't quite right
+ If you say
+ (x + 2) y = e
+ you should get a function binding, but actually the (x+3) will
+ parse as a pattern, and you'll get a parse error. */
+
+funlhs : patk qvarop cpat { $$ = mkinfixap($2,$1,$3); }
+ | funlhs1 apat { $$ = mkap( $1, $2 ); }
+
+funlhs1 : oparenkey funlhs2 CPAREN { $$ = mkpar($2); }
+ | funlhs1 apat { $$ = mkap( $1, $2 ); }
+ | qvark { $$ = mkident($1); }
+ ;
-vallhs : patk { $$ = $1; }
- | patk qvarop pat { $$ = mkinfixap($2,$1,$3); }
- | funlhs { $$ = $1; }
- ;
+funlhs2 : cpat qvarop cpat { $$ = mkinfixap($2,$1,$3); }
+ | funlhs3 apat { $$ = mkap( $1, $2 ); }
-funlhs : qvark apat { $$ = mkap(mkident($1),$2); }
- | funlhs apat { $$ = mkap($1,$2); }
- ;
+funlhs3 : OPAREN funlhs2 CPAREN { $$ = mkpar($2); }
+ | funlhs3 apat { $$ = mkap( $1, $2 ); }
+ | qvar { $$ = mkident($1); }
+ ;
+opt_sig : { $$ = mknothing(); }
+ | DCOLON tautype { $$ = mkjust($2); }
+ ;
-valrhs : valrhs1 maybe_where { $$ = lsing(createpat($1, $2)); }
- ;
+/* opt_asig is the same, but with a parenthesised type */
+opt_asig : { $$ = mknothing(); }
+ | DCOLON atype { $$ = mkjust($2); }
+ ;
-valrhs1 : gdrhs { $$ = mkpguards($1); }
- | EQUAL exp { $$ = mkpnoguards($2); }
+valrhs : EQUAL get_line_no exp maybe_where { $$ = mkpnoguards($2, $3, $4); }
+ | gdrhs maybe_where { $$ = mkpguards($1, $2); }
;
-gdrhs : gd EQUAL exp { $$ = lsing(mkpgdexp($1,$3)); }
- | gd EQUAL exp gdrhs { $$ = mklcons(mkpgdexp($1,$3),$4); }
+gdrhs : gd EQUAL get_line_no exp { $$ = lsing(mkpgdexp($1,$3,$4)); }
+ | gd EQUAL get_line_no exp gdrhs { $$ = mklcons(mkpgdexp($1,$3,$4),$5); }
;
maybe_where:
Operators must be left-associative at the same precedence for
precedence parsing to work.
*/
- /* 8 S/R conflicts on qop -> shift */
-oexp : oexp qop oexp %prec MINUS { $$ = mkinfixap($2,$1,$3); }
+ /* 10 S/R conflicts on qop -> shift */
+oexp : oexp qop dexp %prec MINUS { $$ = mkinfixap($2,$1,$3); }
| dexp
;
kexpLno : LAMBDA
{ hsincindent(); /* push new context for FN = NULL; */
FN = NULL; /* not actually concerned about indenting */
- $<ulong>$ = hsplineno; /* remember current line number */
- }
- lampats
- { hsendindent();
- }
- RARROW exp /* lambda abstraction */
- {
- $$ = mklambda($3, $6, $<ulong>2);
}
+ lampats opt_asig
+ { hsendindent(); }
+
+ RARROW get_line_no exp /* lambda abstraction */
+ { $$ = mklambda( mkpmatch( $3, $4, mkpnoguards( $7, $8, mknullbind() ) ) ); }
/* If Expression */
| IF {$<ulong>$ = hsplineno;}
}
;
-alts : alt { $$ = $1; }
- | alts SEMI alt { $$ = lconc($1,$3); }
+alts : /* empty */ { $$ = Lnil; }
+ | alt { $$ = lsing($1); }
+ | alt SEMI alts { $$ = mklcons($1,$3); }
+ | SEMI alts { $$ = $2; }
;
-alt : pat { PREVPATT = $1; } altrest { $$ = lsing($3); PREVPATT = NULL; }
- | /* empty */ { $$ = Lnil; }
+alt : dpat opt_sig altrhs { $$ = mkpmatch( lsing($1), $2, $3 ); }
;
-altrest : gdpat maybe_where { $$ = createpat(mkpguards($1), $2); }
- | RARROW exp maybe_where { $$ = createpat(mkpnoguards($2),$3); }
- ;
+altrhs : RARROW get_line_no exp maybe_where { $$ = mkpnoguards($2, $3, $4); }
+ | gdpat maybe_where { $$ = mkpguards($1, $2); }
+ ;
-gdpat : gd RARROW exp { $$ = lsing(mkpgdexp($1,$3)); }
- | gd RARROW exp gdpat { $$ = mklcons(mkpgdexp($1,$3),$4); }
+gdpat : gd RARROW get_line_no exp { $$ = lsing(mkpgdexp($1,$3,$4)); }
+ | gd RARROW get_line_no exp gdpat { $$ = mklcons(mkpgdexp($1,$3,$4),$5); }
;
stmts : {pat_check = FALSE;} stmt {pat_check=TRUE; $$ = $2; }
* *
**********************************************************************/
-pat : qvar PLUS INTEGER { $$ = mkplusp($1, mkinteger($3)); }
+pat : dpat DCOLON tautype { $$ = mkrestr($1,$3); }
+ | dpat
+ ;
+
+dpat : qvar PLUS INTEGER { $$ = mkplusp($1, mkinteger($3)); }
| cpat
;
| CLITLIT /* yurble yurble */ { $$ = mkclitlit($1); }
;
+/* Sequence of apats for a lambda abstraction */
lampats : apat lampats { $$ = mklcons($1,$2); }
| apat { $$ = lsing($1); }
/* right recursion? (WDP) */
;
+/* Comma-separated sequence of pats */
pats : pat COMMA pats { $$ = mklcons($1, $3); }
| pat { $$ = lsing($1); }
/* right recursion? (WDP) */
;
+/* Comma separated sequence of record patterns, each of form 'field=pat' */
rpats : /* empty */ { $$ = Lnil; }
| rpats1
;
;
+/* I can't figure out just what these ...k patterns are for.
+ It seems to have something to do with recording the line number */
+
+/* Corresponds to a cpat */
patk : patk qconop bpat { $$ = mkinfixap($2,$1,$3); }
| bpatk
;
ccurly :
CCURLY
{
- FN = NULL; SAMEFN = 0; PREVPATT = NULL;
+ FN = NULL; SAMEFN = 0;
hsendindent();
}
;
vccurly1:
VCCURLY
{
- FN = NULL; SAMEFN = 0; PREVPATT = NULL;
+ FN = NULL; SAMEFN = 0;
hsendindent();
}
| error
{
yyerrok;
- FN = NULL; SAMEFN = 0; PREVPATT = NULL;
+ FN = NULL; SAMEFN = 0;
hsendindent();
}
;
#include "ttype.h"
#include "constr.h"
#include "binding.h"
-#include "entidt.h"
+#include "grhsb.h"
+#include "match.h"
#include "tree.h"
-#include "pbinding.h"
+#include "entidt.h"
+#include "gdexp.h"
extern char *input_filename;
extern tree hspmain();
--- /dev/null
+%{
+#include "hspincl.h"
+%}
+%{{
+module U_match where
+
+#include "HsVersions.h"
+
+import UgenUtil
+
+import U_list
+import U_maybe
+import U_grhsb
+%}}
+
+/* For case we have pmatch [pat] sig grhsb
+ For lambda we have pmatch pats sig grhsb
+ For a function binding we have pamtch [pat] sig grhsb
+ In the function binding case, the 'pat' is actually
+ an appliation of form (f p1 .. pn), or perhaps
+ (p1 `op` p2) p3 ... pn
+*/
+
+type match;
+ pmatch : < gmpats : list; /* of patterns */
+ gmsig : maybe; /* maybe sig */
+ gmrhsb : grhsb; /* guarded RHSs */
+ >;
+end;
+
+++ /dev/null
-%{
-#include "hspincl.h"
-%}
-%{{
-module U_pbinding where
-
-#include "HsVersions.h"
-
-import UgenUtil
-
-import U_constr ( U_constr ) -- interface only
-import U_binding
-import U_list
-import U_literal ( U_literal ) -- ditto
-import U_maybe ( U_maybe ) -- ditto
-import U_qid
-import U_tree
-import U_ttype ( U_ttype ) -- ditto
-%}}
-type pbinding;
- pgrhs : < ggpat : tree;
- ggdexprs : pbinding;
- ggbind : binding;
- ggfuncname : qid;
- ggline : long; >;
-
- pnoguards : < gpnoguard : tree; >;
- pguards : < gpguards : list; >;
-
- pgdexp : < gpguard : list; /* Experimental change: guards are lists of quals */
- gpexp : tree; >;
-end;
static void plist PROTO( (void (*)(/*NOT WORTH IT: void * */), list) );
static void pmaybe PROTO( (void (*)(), maybe) );
static void pmaybe_list PROTO( (void (*)(), maybe) );
-static void ppbinding PROTO((pbinding));
/* static void ppragma PROTO( (hpragma) ); */
static void pqid PROTO( (qid) );
static void prbind PROTO( (binding) );
static void pstr PROTO( (char *) );
static void ptree PROTO( (tree) );
+static void ppgdexp PROTO( (gdexp) );
+static void pgrhsb PROTO( (grhsb) );
+static void ppmatch PROTO( (match) );
static void pttype PROTO( (ttype) );
static void plineno PROTO( (long) );
plist(prbind, ghimplist(t));
pmaybe_list(pentid, ghexplist(t));
break;
- case fixop:
- PUTTAG('I');
- pqid(gfixop(t));
- printf("%lu\t%lu",gfixinfx(t),gfixprec(t));
- break;
case ident:
PUTTAG('i');
pqid(gident(t));
break;
case lambda:
PUTTAG('l');
- plineno(glamline(t));
- plist(ptree,glampats(t));
- ptree(glamexpr(t));
+ ppmatch(glammatch(t));
break;
case let:
PUTTAG('c');
plineno(gcaseline(t));
ptree(gcaseexpr(t));
- plist(ppbinding, gcasebody(t));
+ plist(ppmatch, gcasebody(t));
break;
case ife:
PUTTAG('b');
break;
case pbind :
PUTTAG('p');
+ ptree( gpbindl(b) );
+ pgrhsb( gpbindr(b) );
plineno(gpline(b));
- plist(ppbinding, gpbindl(b));
break;
case fbind :
PUTTAG('f');
+ plist(ppmatch, gfbindm(b));
plineno(gfline(b));
- plist(ppbinding, gfbindl(b));
break;
case abind :
PUTTAG('A');
PUTTAG('B');
break;
+ case fixd:
+ PUTTAG('I');
+ pqid(gfixop(b));
+ printf("%lu\t%lu",gfixinfx(b),gfixprec(b));
+ break;
+
case import:
PUTTAG('e');
plineno(gibindline(b));
}
-static void
-ppbinding(p)
- pbinding p;
-{
- switch(tpbinding(p)) {
- case pgrhs : PUTTAG('W');
- plineno(ggline(p));
- pqid(ggfuncname(p));
- ptree(ggpat(p));
- ppbinding(ggdexprs(p));
- prbind(ggbind(p));
- break;
- case pnoguards :
- PUTTAG('6');
- ptree(gpnoguard(p));
- break;
- case pguards :
- PUTTAG('9');
- plist(ptree, gpguards(p));
- break;
- case pgdexp :
- PUTTAG('&');
- plist(ptree, gpguard(p)); /* Experimental: pattern guards */
- ptree(gpexp(p));
- break;
- default :
- error("Bad pbinding");
- }
-}
-
+static void ppmatch(l) match l; { fprintf( stderr, "printtree.c: ppmatch" ); }
+static void ppgdexp(l) gdexp l; { fprintf( stderr, "printtree.c: ppgdexp" ); }
+static void pgrhsb(l) grhsb l; { fprintf( stderr, "printtree.c: pgrhsb" ); }
static void
pgrhses(l)
/*
- Check Previous Pattern usage
+ We've found a function definition. See if it defines the
+ same function as the previous definition (at this indentation level).
+ If so, set SAMEFN.
+ Set FN to the name of the function.
*/
void
-checksamefn(fn)
- qid fn;
+checksamefn(lhs)
+ tree lhs;
{
- char *this = qid_to_string(fn);
- char *was = (FN==NULL) ? NULL : qid_to_string(FN);
+ tree fn;
+ qid fn_id;
+ char *this, *was;
+ fn = function(lhs);
+
+ if (ttree(fn) == ident) {
+ fn_id = gident((struct Sident *) fn);
+ }
+ else if (ttree(fn) == infixap) {
+ fn_id = ginffun((struct Sinfixap *) fn);
+ }
+ else {
+ fprintf( stderr, "Wierd funlhs" );
+ return;
+ }
+
+ this = qid_to_string(fn_id);
+ was = (FN==NULL) ? NULL : qid_to_string(FN);
SAMEFN = (was != NULL && strcmp(this,was) == 0);
+ FN = fn_id;
if(!SAMEFN && etags)
#if 1/*etags*/
}
break;
+ case restr: /* type sig */
+ expORpat(wanted, grestre(e));
+ break;
+
case par: /* parenthesised */
expORpat(wanted, gpare(e));
break;
- case restr:
case lambda:
case let:
case casee:
/* ---------------------------------------------------------------------- */
+
BOOLEAN /* return TRUE if LHS is a pattern */
lhs_is_patt(tree e)
{
if(tbinding(bind) == abind)
bind = gabindsnd(bind);
- if(tbinding(bind) == pbind)
+ /* if(tbinding(bind) == pbind)
gpbindl(bind) = lconc(gpbindl(bind), gpbindl(rule));
- else if(tbinding(bind) == fbind)
- gfbindl(bind) = lconc(gfbindl(bind), gfbindl(rule));
- else
- fprintf(stderr,"bind error in decl (%d)\n",tbinding(bind));
-}
-
+
+ else */
-pbinding
-createpat(guards,where)
- pbinding guards;
- binding where;
-{
- qid func;
-
- if(FN != NULL)
- func = FN;
+ if(tbinding(bind) == fbind)
+ gfbindm(bind) = lconc(gfbindm(bind), gfbindm(rule));
else
- func = mknoqual(install_literal(""));
-
- return(mkpgrhs(PREVPATT,guards,where,func,endlineno));
+ fprintf(stderr,"bind error in decl (%d)\n",tbinding(bind));
}
import U_constr ( U_constr ) -- interface only
import U_binding
+import U_match
import U_list
import U_literal
import U_maybe
hmodule : < ghname : stringId;
ghimplist : list; /* [import] */
ghexplist : maybe; /* Maybe [entity] */
- ghfixes : list; /* [fixop] */
ghmodlist : binding;
ghversion : long;
ghmodline : long; >;
- fixop : < gfixop : qid;
- gfixinfx : long;
- gfixprec : long;
- gfixline : long; >;
ident : < gident : qid; >;
lit : < glit : literal; >;
ginfarg2 : tree; >;
negate : < gnexp : tree; >;
- lambda : < glampats : list;
- glamexpr : tree;
- glamline : long; >;
+ lambda : < glammatch : match;>;
let : < gletvdefs : binding;
gletvexpr : tree; >;
casee : < gcaseexpr : tree;
- gcasebody : list;
+ gcasebody : list; /* Of match */
gcaseline : long; >;
ife : < gifpred : tree;
gifthen : tree;
plusp : < gplusp : qid;
gplusi : literal; >;
wildp : < >;
- restr : < grestre : tree;
+ restr : < grestre : tree; /* type signature */
grestrt : ttype; >;
tuple : < gtuplelist : list; >;
exit(1);
}
+/* lconc l1 l2 appends l2 to the end of l1 */
list
lconc(l1, l2)
list l1;
return(l1);
}
+/* lapp( l, x ) appends [x] to the end of list l */
list
lapp(list l1, VOID_STAR l2)
{
void format_string PROTO((FILE *, unsigned char *, int));
list type2context PROTO((ttype));
void is_context_format PROTO((ttype, int));
-pbinding createpat PROTO((pbinding, binding));
void process_args PROTO((int, char **));
void hash_init PROTO((void));
void print_hash_table PROTO((void));
void hsindentoff PROTO((void));
int checkfixity PROTO((char *));
-void checksamefn PROTO((qid));
+void checksamefn PROTO((tree));
void checkinpat PROTO((void));
void expORpat PROTO((int,tree));
numClass_RDR, fractionalClass_RDR, eqClass_RDR,
ccallableClass_RDR, creturnableClass_RDR,
monadZeroClass_RDR, enumClass_RDR, ordClass_RDR,
- ioDataCon_RDR
+ ioDataCon_RDR,
+
+ mkTupConRdrName, mkUbxTupConRdrName
) where
import RdrHsSyn ( RdrName(..), varQual, tcQual, qual )
import BasicTypes ( IfaceFlavour )
import Var ( varUnique, Id )
-import Name ( Name, OccName(..), Provenance(..),
+import Name ( Name, OccName, Provenance(..),
getName, mkGlobalName, modAndOcc
)
import Class ( Class, classKey )
import Bag
import Unique -- *Key stuff
import UniqFM ( UniqFM, listToUFM, lookupWithDefaultUFM )
-import Util ( isIn, panic )
+import Util ( isIn )
+import Panic ( panic )
import IOExts
\end{code}
minusH_RDR = prelude_primop IntSubOp
\end{code}
+\begin{code}
+mkTupConRdrName :: Int -> RdrName
+mkTupConRdrName arity = varQual (mkTupNameStr arity)
+
+mkUbxTupConRdrName :: Int -> RdrName
+mkUbxTupConRdrName arity = varQual (mkUbxTupNameStr arity)
+\end{code}
+
+
%************************************************************************
%* *
\subsection[Class-std-groups]{Standard groups of Prelude classes}
\begin{code}
module PrelMods
(
+ mkTupNameStr, mkUbxTupNameStr,
+
pREL_GHC, pRELUDE, mONAD, rATIO, iX, mAIN, pREL_MAIN, pREL_ERR,
pREL_BASE, pREL_NUM, pREL_LIST, pREL_TUP, pREL_ADDR, pREL_READ,
pREL_PACK, pREL_CONC, pREL_IO_BASE, pREL_ST, pREL_ARR, pREL_FOREIGN,
#include "HsVersions.h"
-import BasicTypes( Module )
+import OccName ( Module, mkModule )
+import Util ( nOfThem )
+import Panic ( panic )
\end{code}
\begin{code}
pREL_PACK, pREL_CONC, pREL_IO_BASE, pREL_ST, pREL_ARR, pREL_FOREIGN :: Module
-pRELUDE = SLIT("Prelude")
-pREL_GHC = SLIT("PrelGHC") -- Primitive types and values
-pREL_BASE = SLIT("PrelBase")
-pREL_READ = SLIT("PrelRead")
-pREL_NUM = SLIT("PrelNum")
-pREL_LIST = SLIT("PrelList")
-pREL_TUP = SLIT("PrelTup")
-pREL_PACK = SLIT("PrelPack")
-pREL_CONC = SLIT("PrelConc")
-pREL_IO_BASE = SLIT("PrelIOBase")
-pREL_ST = SLIT("PrelST")
-pREL_ARR = SLIT("PrelArr")
-pREL_FOREIGN = SLIT("PrelForeign")
-pREL_ADDR = SLIT("PrelAddr")
-pREL_ERR = SLIT("PrelErr")
-
-mONAD = SLIT("Monad")
-rATIO = SLIT("Ratio")
-iX = SLIT("Ix")
-
-pREL_MAIN = SLIT("PrelMain")
-mAIN = SLIT("Main")
+pRELUDE = mkModule "Prelude"
+pREL_GHC = mkModule "PrelGHC" -- Primitive types and values
+pREL_BASE = mkModule "PrelBase"
+pREL_READ = mkModule "PrelRead"
+pREL_NUM = mkModule "PrelNum"
+pREL_LIST = mkModule "PrelList"
+pREL_TUP = mkModule "PrelTup"
+pREL_PACK = mkModule "PrelPack"
+pREL_CONC = mkModule "PrelConc"
+pREL_IO_BASE = mkModule "PrelIOBase"
+pREL_ST = mkModule "PrelST"
+pREL_ARR = mkModule "PrelArr"
+pREL_FOREIGN = mkModule "PrelForeign"
+pREL_ADDR = mkModule "PrelAddr"
+pREL_ERR = mkModule "PrelErr"
+
+mONAD = mkModule "Monad"
+rATIO = mkModule "Ratio"
+iX = mkModule "Ix"
+
+pREL_MAIN = mkModule "PrelMain"
+mAIN = mkModule "Main"
iNT, wORD :: Module
-iNT = SLIT("Int")
-wORD = SLIT("Word")
+iNT = mkModule "Int"
+wORD = mkModule "Word"
\end{code}
+
+%************************************************************************
+%* *
+\subsection{Constructing the names of tuples
+%* *
+%************************************************************************
+
+\begin{code}
+mkTupNameStr, mkUbxTupNameStr :: Int -> (Module, FAST_STRING)
+
+mkTupNameStr 0 = (pREL_BASE, SLIT("()"))
+mkTupNameStr 1 = panic "Name.mkTupNameStr: 1 ???"
+mkTupNameStr 2 = (pREL_TUP, _PK_ "(,)") -- not strictly necessary
+mkTupNameStr 3 = (pREL_TUP, _PK_ "(,,)") -- ditto
+mkTupNameStr 4 = (pREL_TUP, _PK_ "(,,,)") -- ditto
+mkTupNameStr n = (pREL_TUP, _PK_ ("(" ++ nOfThem (n-1) ',' ++ ")"))
+
+mkUbxTupNameStr 0 = panic "Name.mkUbxTupNameStr: 0 ???"
+mkUbxTupNameStr 1 = (pREL_GHC, _PK_ "(# #)") -- 1 and 0 both make sense!!!
+mkUbxTupNameStr 2 = (pREL_GHC, _PK_ "(#,#)")
+mkUbxTupNameStr 3 = (pREL_GHC, _PK_ "(#,,#)")
+mkUbxTupNameStr 4 = (pREL_GHC, _PK_ "(#,,,#)")
+mkUbxTupNameStr n = (pREL_GHC, _PK_ ("(#" ++ nOfThem (n-1) ',' ++ "#)"))
+\end{code}
+
+
-- others:
import CoreSyn -- quite a bit
import IdInfo -- quite a bit
-import Name ( mkWiredInIdName, Module )
+import Name ( mkWiredInIdName, varOcc, Module )
import Type
import Var ( TyVar )
+import Demand ( wwStrict )
import Unique -- lots of *Keys
import IOExts
pc_bottoming_Id key mod name ty
= pcMiscPrelId key mod name ty bottoming_info
where
- bottoming_info = mkBottomStrictnessInfo `setStrictnessInfo` noCafIdInfo
+ bottoming_info = mkStrictnessInfo ([wwStrict], True) False `setStrictnessInfo` noCafIdInfo
-- these "bottom" out, no matter what their arguments
eRROR_ID
pcMiscPrelId :: Unique{-IdKey-} -> Module -> FAST_STRING -> Type -> IdInfo -> Id
-pcMiscPrelId key mod occ ty info
+pcMiscPrelId key mod str ty info
= let
- name = mkWiredInIdName key mod occ imp
+ name = mkWiredInIdName key mod (varOcc str) imp
imp = mkVanillaId name ty `setIdInfo` info -- the usual case...
in
imp
PrimOp(..), allThePrimOps,
tagOf_PrimOp, -- ToDo: rm
primOpType,
- primOpUniq, primOpStr,
+ primOpUniq, primOpOcc,
commutableOp,
import TysPrim
import TysWiredIn
-import CStrings ( identToC )
import Var ( TyVar )
import CallConv ( CallConv, pprCallConv )
import PprType ( pprParendType )
+import OccName ( OccName, pprOccName, varOcc )
import TyCon ( TyCon )
import Type ( mkForAllTys, mkForAllTy, mkFunTy, mkFunTys,
mkTyConApp, typePrimRep,
| CCallOp (Either
FAST_STRING -- Left fn => An "unboxed" ccall# to `fn'.
Unique) -- Right u => first argument (an Addr#) is the function pointer
- -- (unique is used to
+ -- (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.)
-
Bool -- True <=> really a "casm"
Bool -- True <=> might invoke Haskell GC
CallConv -- calling convention to use.
(slightly) more convenient to use than @TyCons@.
\begin{code}
data PrimOpInfo
- = Dyadic FAST_STRING -- string :: T -> T -> T
+ = Dyadic OccName -- string :: T -> T -> T
Type
- | Monadic FAST_STRING -- string :: T -> T
+ | Monadic OccName -- string :: T -> T
Type
- | Compare FAST_STRING -- string :: T -> T -> Bool
+ | Compare OccName -- string :: T -> T -> Bool
Type
- | GenPrimOp FAST_STRING -- string :: \/a1..an . T1 -> .. -> Tk -> T
+ | GenPrimOp OccName -- string :: \/a1..an . T1 -> .. -> Tk -> T
[TyVar]
[Type]
Type
+
+mkDyadic str ty = Dyadic (varOcc str) ty
+mkMonadic str ty = Monadic (varOcc str) ty
+mkCompare str ty = Compare (varOcc str) ty
+mkGenPrimOp str tvs tys ty = GenPrimOp (varOcc str) tvs tys ty
\end{code}
Utility bits:
unboxedQuadruple = mkUnboxedTupleTy 4
unboxedSexTuple = mkUnboxedTupleTy 6
-integerMonadic name = GenPrimOp name [] one_Integer_ty
+integerMonadic name = mkGenPrimOp name [] one_Integer_ty
(unboxedTriple [intPrimTy, intPrimTy, byteArrayPrimTy])
-integerDyadic name = GenPrimOp name [] two_Integer_tys
+integerDyadic name = mkGenPrimOp name [] two_Integer_tys
(unboxedTriple [intPrimTy, intPrimTy, byteArrayPrimTy])
-integerDyadic2Results name = GenPrimOp name [] two_Integer_tys
+integerDyadic2Results name = mkGenPrimOp name [] two_Integer_tys
(unboxedSexTuple [intPrimTy, intPrimTy, byteArrayPrimTy,
intPrimTy, intPrimTy, byteArrayPrimTy])
-integerCompare name = GenPrimOp name [] two_Integer_tys intPrimTy
+integerCompare name = mkGenPrimOp name [] two_Integer_tys intPrimTy
\end{code}
%************************************************************************
There's plenty of this stuff!
\begin{code}
-primOpInfo CharGtOp = Compare SLIT("gtChar#") charPrimTy
-primOpInfo CharGeOp = Compare SLIT("geChar#") charPrimTy
-primOpInfo CharEqOp = Compare SLIT("eqChar#") charPrimTy
-primOpInfo CharNeOp = Compare SLIT("neChar#") charPrimTy
-primOpInfo CharLtOp = Compare SLIT("ltChar#") charPrimTy
-primOpInfo CharLeOp = Compare SLIT("leChar#") charPrimTy
-
-primOpInfo IntGtOp = Compare SLIT(">#") intPrimTy
-primOpInfo IntGeOp = Compare SLIT(">=#") intPrimTy
-primOpInfo IntEqOp = Compare SLIT("==#") intPrimTy
-primOpInfo IntNeOp = Compare SLIT("/=#") intPrimTy
-primOpInfo IntLtOp = Compare SLIT("<#") intPrimTy
-primOpInfo IntLeOp = Compare SLIT("<=#") intPrimTy
-
-primOpInfo WordGtOp = Compare SLIT("gtWord#") wordPrimTy
-primOpInfo WordGeOp = Compare SLIT("geWord#") wordPrimTy
-primOpInfo WordEqOp = Compare SLIT("eqWord#") wordPrimTy
-primOpInfo WordNeOp = Compare SLIT("neWord#") wordPrimTy
-primOpInfo WordLtOp = Compare SLIT("ltWord#") wordPrimTy
-primOpInfo WordLeOp = Compare SLIT("leWord#") wordPrimTy
-
-primOpInfo AddrGtOp = Compare SLIT("gtAddr#") addrPrimTy
-primOpInfo AddrGeOp = Compare SLIT("geAddr#") addrPrimTy
-primOpInfo AddrEqOp = Compare SLIT("eqAddr#") addrPrimTy
-primOpInfo AddrNeOp = Compare SLIT("neAddr#") addrPrimTy
-primOpInfo AddrLtOp = Compare SLIT("ltAddr#") addrPrimTy
-primOpInfo AddrLeOp = Compare SLIT("leAddr#") addrPrimTy
-
-primOpInfo FloatGtOp = Compare SLIT("gtFloat#") floatPrimTy
-primOpInfo FloatGeOp = Compare SLIT("geFloat#") floatPrimTy
-primOpInfo FloatEqOp = Compare SLIT("eqFloat#") floatPrimTy
-primOpInfo FloatNeOp = Compare SLIT("neFloat#") floatPrimTy
-primOpInfo FloatLtOp = Compare SLIT("ltFloat#") floatPrimTy
-primOpInfo FloatLeOp = Compare SLIT("leFloat#") floatPrimTy
-
-primOpInfo DoubleGtOp = Compare SLIT(">##") doublePrimTy
-primOpInfo DoubleGeOp = Compare SLIT(">=##") doublePrimTy
-primOpInfo DoubleEqOp = Compare SLIT("==##") doublePrimTy
-primOpInfo DoubleNeOp = Compare SLIT("/=##") doublePrimTy
-primOpInfo DoubleLtOp = Compare SLIT("<##") doublePrimTy
-primOpInfo DoubleLeOp = Compare SLIT("<=##") doublePrimTy
+primOpInfo CharGtOp = mkCompare SLIT("gtChar#") charPrimTy
+primOpInfo CharGeOp = mkCompare SLIT("geChar#") charPrimTy
+primOpInfo CharEqOp = mkCompare SLIT("eqChar#") charPrimTy
+primOpInfo CharNeOp = mkCompare SLIT("neChar#") charPrimTy
+primOpInfo CharLtOp = mkCompare SLIT("ltChar#") charPrimTy
+primOpInfo CharLeOp = mkCompare SLIT("leChar#") charPrimTy
+
+primOpInfo IntGtOp = mkCompare SLIT(">#") intPrimTy
+primOpInfo IntGeOp = mkCompare SLIT(">=#") intPrimTy
+primOpInfo IntEqOp = mkCompare SLIT("==#") intPrimTy
+primOpInfo IntNeOp = mkCompare SLIT("/=#") intPrimTy
+primOpInfo IntLtOp = mkCompare SLIT("<#") intPrimTy
+primOpInfo IntLeOp = mkCompare SLIT("<=#") intPrimTy
+
+primOpInfo WordGtOp = mkCompare SLIT("gtWord#") wordPrimTy
+primOpInfo WordGeOp = mkCompare SLIT("geWord#") wordPrimTy
+primOpInfo WordEqOp = mkCompare SLIT("eqWord#") wordPrimTy
+primOpInfo WordNeOp = mkCompare SLIT("neWord#") wordPrimTy
+primOpInfo WordLtOp = mkCompare SLIT("ltWord#") wordPrimTy
+primOpInfo WordLeOp = mkCompare SLIT("leWord#") wordPrimTy
+
+primOpInfo AddrGtOp = mkCompare SLIT("gtAddr#") addrPrimTy
+primOpInfo AddrGeOp = mkCompare SLIT("geAddr#") addrPrimTy
+primOpInfo AddrEqOp = mkCompare SLIT("eqAddr#") addrPrimTy
+primOpInfo AddrNeOp = mkCompare SLIT("neAddr#") addrPrimTy
+primOpInfo AddrLtOp = mkCompare SLIT("ltAddr#") addrPrimTy
+primOpInfo AddrLeOp = mkCompare SLIT("leAddr#") addrPrimTy
+
+primOpInfo FloatGtOp = mkCompare SLIT("gtFloat#") floatPrimTy
+primOpInfo FloatGeOp = mkCompare SLIT("geFloat#") floatPrimTy
+primOpInfo FloatEqOp = mkCompare SLIT("eqFloat#") floatPrimTy
+primOpInfo FloatNeOp = mkCompare SLIT("neFloat#") floatPrimTy
+primOpInfo FloatLtOp = mkCompare SLIT("ltFloat#") floatPrimTy
+primOpInfo FloatLeOp = mkCompare SLIT("leFloat#") floatPrimTy
+
+primOpInfo DoubleGtOp = mkCompare SLIT(">##") doublePrimTy
+primOpInfo DoubleGeOp = mkCompare SLIT(">=##") doublePrimTy
+primOpInfo DoubleEqOp = mkCompare SLIT("==##") doublePrimTy
+primOpInfo DoubleNeOp = mkCompare SLIT("/=##") doublePrimTy
+primOpInfo DoubleLtOp = mkCompare SLIT("<##") doublePrimTy
+primOpInfo DoubleLeOp = mkCompare SLIT("<=##") doublePrimTy
\end{code}
%************************************************************************
\begin{code}
-primOpInfo OrdOp = GenPrimOp SLIT("ord#") [] [charPrimTy] intPrimTy
-primOpInfo ChrOp = GenPrimOp SLIT("chr#") [] [intPrimTy] charPrimTy
+primOpInfo OrdOp = mkGenPrimOp SLIT("ord#") [] [charPrimTy] intPrimTy
+primOpInfo ChrOp = mkGenPrimOp SLIT("chr#") [] [intPrimTy] charPrimTy
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-primOpInfo IntAddOp = Dyadic SLIT("+#") intPrimTy
-primOpInfo IntSubOp = Dyadic SLIT("-#") intPrimTy
-primOpInfo IntMulOp = Dyadic SLIT("*#") intPrimTy
-primOpInfo IntQuotOp = Dyadic SLIT("quotInt#") intPrimTy
-primOpInfo IntRemOp = Dyadic SLIT("remInt#") intPrimTy
-
-primOpInfo IntNegOp = Monadic SLIT("negateInt#") intPrimTy
-primOpInfo IntAbsOp = Monadic SLIT("absInt#") intPrimTy
+primOpInfo IntAddOp = mkDyadic SLIT("+#") intPrimTy
+primOpInfo IntSubOp = mkDyadic SLIT("-#") intPrimTy
+primOpInfo IntMulOp = mkDyadic SLIT("*#") intPrimTy
+primOpInfo IntQuotOp = mkDyadic SLIT("quotInt#") intPrimTy
+primOpInfo IntRemOp = mkDyadic SLIT("remInt#") intPrimTy
+
+primOpInfo IntNegOp = mkMonadic SLIT("negateInt#") intPrimTy
+primOpInfo IntAbsOp = mkMonadic SLIT("absInt#") intPrimTy
\end{code}
%************************************************************************
A @Word#@ is an unsigned @Int#@.
\begin{code}
-primOpInfo WordQuotOp = Dyadic SLIT("quotWord#") wordPrimTy
-primOpInfo WordRemOp = Dyadic SLIT("remWord#") wordPrimTy
+primOpInfo WordQuotOp = mkDyadic SLIT("quotWord#") wordPrimTy
+primOpInfo WordRemOp = mkDyadic SLIT("remWord#") wordPrimTy
-primOpInfo AndOp = Dyadic SLIT("and#") wordPrimTy
-primOpInfo OrOp = Dyadic SLIT("or#") wordPrimTy
-primOpInfo XorOp = Dyadic SLIT("xor#") wordPrimTy
-primOpInfo NotOp = Monadic SLIT("not#") wordPrimTy
+primOpInfo AndOp = mkDyadic SLIT("and#") wordPrimTy
+primOpInfo OrOp = mkDyadic SLIT("or#") wordPrimTy
+primOpInfo XorOp = mkDyadic SLIT("xor#") wordPrimTy
+primOpInfo NotOp = mkMonadic SLIT("not#") wordPrimTy
primOpInfo SllOp
- = GenPrimOp SLIT("shiftL#") [] [wordPrimTy, intPrimTy] wordPrimTy
+ = mkGenPrimOp SLIT("shiftL#") [] [wordPrimTy, intPrimTy] wordPrimTy
primOpInfo SrlOp
- = GenPrimOp SLIT("shiftRL#") [] [wordPrimTy, intPrimTy] wordPrimTy
+ = mkGenPrimOp SLIT("shiftRL#") [] [wordPrimTy, intPrimTy] wordPrimTy
primOpInfo ISllOp
- = GenPrimOp SLIT("iShiftL#") [] [intPrimTy, intPrimTy] intPrimTy
+ = mkGenPrimOp SLIT("iShiftL#") [] [intPrimTy, intPrimTy] intPrimTy
primOpInfo ISraOp
- = GenPrimOp SLIT("iShiftRA#") [] [intPrimTy, intPrimTy] intPrimTy
+ = mkGenPrimOp SLIT("iShiftRA#") [] [intPrimTy, intPrimTy] intPrimTy
primOpInfo ISrlOp
- = GenPrimOp SLIT("iShiftRL#") [] [intPrimTy, intPrimTy] intPrimTy
+ = mkGenPrimOp SLIT("iShiftRL#") [] [intPrimTy, intPrimTy] intPrimTy
-primOpInfo Int2WordOp = GenPrimOp SLIT("int2Word#") [] [intPrimTy] wordPrimTy
-primOpInfo Word2IntOp = GenPrimOp SLIT("word2Int#") [] [wordPrimTy] intPrimTy
+primOpInfo Int2WordOp = mkGenPrimOp SLIT("int2Word#") [] [intPrimTy] wordPrimTy
+primOpInfo Word2IntOp = mkGenPrimOp SLIT("word2Int#") [] [wordPrimTy] intPrimTy
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-primOpInfo Int2AddrOp = GenPrimOp SLIT("int2Addr#") [] [intPrimTy] addrPrimTy
-primOpInfo Addr2IntOp = GenPrimOp SLIT("addr2Int#") [] [addrPrimTy] intPrimTy
+primOpInfo Int2AddrOp = mkGenPrimOp SLIT("int2Addr#") [] [intPrimTy] addrPrimTy
+primOpInfo Addr2IntOp = mkGenPrimOp SLIT("addr2Int#") [] [addrPrimTy] intPrimTy
\end{code}
similar).
\begin{code}
-primOpInfo FloatAddOp = Dyadic SLIT("plusFloat#") floatPrimTy
-primOpInfo FloatSubOp = Dyadic SLIT("minusFloat#") floatPrimTy
-primOpInfo FloatMulOp = Dyadic SLIT("timesFloat#") floatPrimTy
-primOpInfo FloatDivOp = Dyadic SLIT("divideFloat#") floatPrimTy
-primOpInfo FloatNegOp = Monadic SLIT("negateFloat#") floatPrimTy
-
-primOpInfo Float2IntOp = GenPrimOp SLIT("float2Int#") [] [floatPrimTy] intPrimTy
-primOpInfo Int2FloatOp = GenPrimOp SLIT("int2Float#") [] [intPrimTy] floatPrimTy
-
-primOpInfo FloatExpOp = Monadic SLIT("expFloat#") floatPrimTy
-primOpInfo FloatLogOp = Monadic SLIT("logFloat#") floatPrimTy
-primOpInfo FloatSqrtOp = Monadic SLIT("sqrtFloat#") floatPrimTy
-primOpInfo FloatSinOp = Monadic SLIT("sinFloat#") floatPrimTy
-primOpInfo FloatCosOp = Monadic SLIT("cosFloat#") floatPrimTy
-primOpInfo FloatTanOp = Monadic SLIT("tanFloat#") floatPrimTy
-primOpInfo FloatAsinOp = Monadic SLIT("asinFloat#") floatPrimTy
-primOpInfo FloatAcosOp = Monadic SLIT("acosFloat#") floatPrimTy
-primOpInfo FloatAtanOp = Monadic SLIT("atanFloat#") floatPrimTy
-primOpInfo FloatSinhOp = Monadic SLIT("sinhFloat#") floatPrimTy
-primOpInfo FloatCoshOp = Monadic SLIT("coshFloat#") floatPrimTy
-primOpInfo FloatTanhOp = Monadic SLIT("tanhFloat#") floatPrimTy
-primOpInfo FloatPowerOp = Dyadic SLIT("powerFloat#") floatPrimTy
+primOpInfo FloatAddOp = mkDyadic SLIT("plusFloat#") floatPrimTy
+primOpInfo FloatSubOp = mkDyadic SLIT("minusFloat#") floatPrimTy
+primOpInfo FloatMulOp = mkDyadic SLIT("timesFloat#") floatPrimTy
+primOpInfo FloatDivOp = mkDyadic SLIT("divideFloat#") floatPrimTy
+primOpInfo FloatNegOp = mkMonadic SLIT("negateFloat#") floatPrimTy
+
+primOpInfo Float2IntOp = mkGenPrimOp SLIT("float2Int#") [] [floatPrimTy] intPrimTy
+primOpInfo Int2FloatOp = mkGenPrimOp SLIT("int2Float#") [] [intPrimTy] floatPrimTy
+
+primOpInfo FloatExpOp = mkMonadic SLIT("expFloat#") floatPrimTy
+primOpInfo FloatLogOp = mkMonadic SLIT("logFloat#") floatPrimTy
+primOpInfo FloatSqrtOp = mkMonadic SLIT("sqrtFloat#") floatPrimTy
+primOpInfo FloatSinOp = mkMonadic SLIT("sinFloat#") floatPrimTy
+primOpInfo FloatCosOp = mkMonadic SLIT("cosFloat#") floatPrimTy
+primOpInfo FloatTanOp = mkMonadic SLIT("tanFloat#") floatPrimTy
+primOpInfo FloatAsinOp = mkMonadic SLIT("asinFloat#") floatPrimTy
+primOpInfo FloatAcosOp = mkMonadic SLIT("acosFloat#") floatPrimTy
+primOpInfo FloatAtanOp = mkMonadic SLIT("atanFloat#") floatPrimTy
+primOpInfo FloatSinhOp = mkMonadic SLIT("sinhFloat#") floatPrimTy
+primOpInfo FloatCoshOp = mkMonadic SLIT("coshFloat#") floatPrimTy
+primOpInfo FloatTanhOp = mkMonadic SLIT("tanhFloat#") floatPrimTy
+primOpInfo FloatPowerOp = mkDyadic SLIT("powerFloat#") floatPrimTy
\end{code}
%************************************************************************
similar).
\begin{code}
-primOpInfo DoubleAddOp = Dyadic SLIT("+##") doublePrimTy
-primOpInfo DoubleSubOp = Dyadic SLIT("-##") doublePrimTy
-primOpInfo DoubleMulOp = Dyadic SLIT("*##") doublePrimTy
-primOpInfo DoubleDivOp = Dyadic SLIT("/##") doublePrimTy
-primOpInfo DoubleNegOp = Monadic SLIT("negateDouble#") doublePrimTy
-
-primOpInfo Double2IntOp = GenPrimOp SLIT("double2Int#") [] [doublePrimTy] intPrimTy
-primOpInfo Int2DoubleOp = GenPrimOp SLIT("int2Double#") [] [intPrimTy] doublePrimTy
-
-primOpInfo Double2FloatOp = GenPrimOp SLIT("double2Float#") [] [doublePrimTy] floatPrimTy
-primOpInfo Float2DoubleOp = GenPrimOp SLIT("float2Double#") [] [floatPrimTy] doublePrimTy
-
-primOpInfo DoubleExpOp = Monadic SLIT("expDouble#") doublePrimTy
-primOpInfo DoubleLogOp = Monadic SLIT("logDouble#") doublePrimTy
-primOpInfo DoubleSqrtOp = Monadic SLIT("sqrtDouble#") doublePrimTy
-primOpInfo DoubleSinOp = Monadic SLIT("sinDouble#") doublePrimTy
-primOpInfo DoubleCosOp = Monadic SLIT("cosDouble#") doublePrimTy
-primOpInfo DoubleTanOp = Monadic SLIT("tanDouble#") doublePrimTy
-primOpInfo DoubleAsinOp = Monadic SLIT("asinDouble#") doublePrimTy
-primOpInfo DoubleAcosOp = Monadic SLIT("acosDouble#") doublePrimTy
-primOpInfo DoubleAtanOp = Monadic SLIT("atanDouble#") doublePrimTy
-primOpInfo DoubleSinhOp = Monadic SLIT("sinhDouble#") doublePrimTy
-primOpInfo DoubleCoshOp = Monadic SLIT("coshDouble#") doublePrimTy
-primOpInfo DoubleTanhOp = Monadic SLIT("tanhDouble#") doublePrimTy
-primOpInfo DoublePowerOp= Dyadic SLIT("**##") doublePrimTy
+primOpInfo DoubleAddOp = mkDyadic SLIT("+##") doublePrimTy
+primOpInfo DoubleSubOp = mkDyadic SLIT("-##") doublePrimTy
+primOpInfo DoubleMulOp = mkDyadic SLIT("*##") doublePrimTy
+primOpInfo DoubleDivOp = mkDyadic SLIT("/##") doublePrimTy
+primOpInfo DoubleNegOp = mkMonadic SLIT("negateDouble#") doublePrimTy
+
+primOpInfo Double2IntOp = mkGenPrimOp SLIT("double2Int#") [] [doublePrimTy] intPrimTy
+primOpInfo Int2DoubleOp = mkGenPrimOp SLIT("int2Double#") [] [intPrimTy] doublePrimTy
+
+primOpInfo Double2FloatOp = mkGenPrimOp SLIT("double2Float#") [] [doublePrimTy] floatPrimTy
+primOpInfo Float2DoubleOp = mkGenPrimOp SLIT("float2Double#") [] [floatPrimTy] doublePrimTy
+
+primOpInfo DoubleExpOp = mkMonadic SLIT("expDouble#") doublePrimTy
+primOpInfo DoubleLogOp = mkMonadic SLIT("logDouble#") doublePrimTy
+primOpInfo DoubleSqrtOp = mkMonadic SLIT("sqrtDouble#") doublePrimTy
+primOpInfo DoubleSinOp = mkMonadic SLIT("sinDouble#") doublePrimTy
+primOpInfo DoubleCosOp = mkMonadic SLIT("cosDouble#") doublePrimTy
+primOpInfo DoubleTanOp = mkMonadic SLIT("tanDouble#") doublePrimTy
+primOpInfo DoubleAsinOp = mkMonadic SLIT("asinDouble#") doublePrimTy
+primOpInfo DoubleAcosOp = mkMonadic SLIT("acosDouble#") doublePrimTy
+primOpInfo DoubleAtanOp = mkMonadic SLIT("atanDouble#") doublePrimTy
+primOpInfo DoubleSinhOp = mkMonadic SLIT("sinhDouble#") doublePrimTy
+primOpInfo DoubleCoshOp = mkMonadic SLIT("coshDouble#") doublePrimTy
+primOpInfo DoubleTanhOp = mkMonadic SLIT("tanhDouble#") doublePrimTy
+primOpInfo DoublePowerOp= mkDyadic SLIT("**##") doublePrimTy
\end{code}
%************************************************************************
primOpInfo IntegerDivModOp = integerDyadic2Results SLIT("divModInteger#")
primOpInfo Integer2IntOp
- = GenPrimOp SLIT("integer2Int#") [] one_Integer_ty intPrimTy
+ = mkGenPrimOp SLIT("integer2Int#") [] one_Integer_ty intPrimTy
primOpInfo Integer2WordOp
- = GenPrimOp SLIT("integer2Word#") [] one_Integer_ty wordPrimTy
+ = mkGenPrimOp SLIT("integer2Word#") [] one_Integer_ty wordPrimTy
primOpInfo Int2IntegerOp
- = GenPrimOp SLIT("int2Integer#") [] [intPrimTy]
+ = mkGenPrimOp SLIT("int2Integer#") [] [intPrimTy]
(unboxedTriple [intPrimTy, intPrimTy, byteArrayPrimTy])
primOpInfo Word2IntegerOp
- = GenPrimOp SLIT("word2Integer#") [] [wordPrimTy]
+ = mkGenPrimOp SLIT("word2Integer#") [] [wordPrimTy]
(unboxedTriple [intPrimTy, intPrimTy, byteArrayPrimTy])
primOpInfo Addr2IntegerOp
- = GenPrimOp SLIT("addr2Integer#") [] [addrPrimTy]
+ = mkGenPrimOp SLIT("addr2Integer#") [] [addrPrimTy]
(unboxedTriple [intPrimTy, intPrimTy, byteArrayPrimTy])
primOpInfo IntegerToInt64Op
- = GenPrimOp SLIT("integerToInt64#") [] one_Integer_ty int64PrimTy
+ = mkGenPrimOp SLIT("integerToInt64#") [] one_Integer_ty int64PrimTy
primOpInfo Int64ToIntegerOp
- = GenPrimOp SLIT("int64ToInteger#") [] [int64PrimTy]
+ = mkGenPrimOp SLIT("int64ToInteger#") [] [int64PrimTy]
(unboxedTriple [intPrimTy, intPrimTy, byteArrayPrimTy])
primOpInfo Word64ToIntegerOp
- = GenPrimOp SLIT("word64ToInteger#") [] [word64PrimTy]
+ = mkGenPrimOp SLIT("word64ToInteger#") [] [word64PrimTy]
(unboxedTriple [intPrimTy, intPrimTy, byteArrayPrimTy])
primOpInfo IntegerToWord64Op
- = GenPrimOp SLIT("integerToWord64#") [] one_Integer_ty word64PrimTy
+ = mkGenPrimOp SLIT("integerToWord64#") [] one_Integer_ty word64PrimTy
\end{code}
Encoding and decoding of floating-point numbers is sorta
\begin{code}
primOpInfo FloatEncodeOp
- = GenPrimOp SLIT("encodeFloat#") [] an_Integer_and_Int_tys floatPrimTy
+ = mkGenPrimOp SLIT("encodeFloat#") [] an_Integer_and_Int_tys floatPrimTy
primOpInfo DoubleEncodeOp
- = GenPrimOp SLIT("encodeDouble#") [] an_Integer_and_Int_tys doublePrimTy
+ = mkGenPrimOp SLIT("encodeDouble#") [] an_Integer_and_Int_tys doublePrimTy
primOpInfo FloatDecodeOp
- = GenPrimOp SLIT("decodeFloat#") [] [floatPrimTy]
+ = mkGenPrimOp SLIT("decodeFloat#") [] [floatPrimTy]
(unboxedQuadruple [intPrimTy, intPrimTy, intPrimTy, byteArrayPrimTy])
primOpInfo DoubleDecodeOp
- = GenPrimOp SLIT("decodeDouble#") [] [doublePrimTy]
+ = mkGenPrimOp SLIT("decodeDouble#") [] [doublePrimTy]
(unboxedQuadruple [intPrimTy, intPrimTy, intPrimTy, byteArrayPrimTy])
\end{code}
elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar;
state = mkStatePrimTy s
} in
- GenPrimOp SLIT("newArray#") [s_tv, elt_tv]
+ mkGenPrimOp SLIT("newArray#") [s_tv, elt_tv]
[intPrimTy, elt, state]
(unboxedPair [state, mkMutableArrayPrimTy s elt])
op_str = _PK_ ("new" ++ primRepString kind ++ "Array#")
state = mkStatePrimTy s
in
- GenPrimOp op_str [s_tv]
+ mkGenPrimOp op_str [s_tv]
[intPrimTy, state]
(unboxedPair [state, mkMutableByteArrayPrimTy s])
elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar;
mut_arr_ty = mkMutableArrayPrimTy s elt
} in
- GenPrimOp SLIT("sameMutableArray#") [s_tv, elt_tv] [mut_arr_ty, mut_arr_ty]
+ mkGenPrimOp SLIT("sameMutableArray#") [s_tv, elt_tv] [mut_arr_ty, mut_arr_ty]
boolTy
primOpInfo SameMutableByteArrayOp
s = alphaTy; s_tv = alphaTyVar;
mut_arr_ty = mkMutableByteArrayPrimTy s
} in
- GenPrimOp SLIT("sameMutableByteArray#") [s_tv] [mut_arr_ty, mut_arr_ty]
+ mkGenPrimOp SLIT("sameMutableByteArray#") [s_tv] [mut_arr_ty, mut_arr_ty]
boolTy
---------------------------------------------------------------------------
elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar;
state = mkStatePrimTy s
} in
- GenPrimOp SLIT("readArray#") [s_tv, elt_tv]
+ mkGenPrimOp SLIT("readArray#") [s_tv, elt_tv]
[mkMutableArrayPrimTy s elt, intPrimTy, state]
(unboxedPair [state, elt])
= let {
elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar
} in
- GenPrimOp SLIT("writeArray#") [s_tv, elt_tv]
+ mkGenPrimOp SLIT("writeArray#") [s_tv, elt_tv]
[mkMutableArrayPrimTy s elt, intPrimTy, elt, mkStatePrimTy s]
(mkStatePrimTy s)
primOpInfo IndexArrayOp
= let { elt = alphaTy; elt_tv = alphaTyVar } in
- GenPrimOp SLIT("indexArray#") [elt_tv] [mkArrayPrimTy elt, intPrimTy]
+ mkGenPrimOp SLIT("indexArray#") [elt_tv] [mkArrayPrimTy elt, intPrimTy]
(unboxedPair [realWorldStatePrimTy, elt])
---------------------------------------------------------------------------
| kind == StablePtrRep = [s_tv, betaTyVar]
| otherwise = [s_tv]
in
- GenPrimOp op_str tvs
+ mkGenPrimOp op_str tvs
[mkMutableByteArrayPrimTy s, intPrimTy, state]
(unboxedPair [state, relevant_type])
where
| otherwise = (prim_ty, [s_tv])
in
- GenPrimOp op_str tvs
+ mkGenPrimOp op_str tvs
[mkMutableByteArrayPrimTy s, intPrimTy, the_prim_ty, mkStatePrimTy s]
(mkStatePrimTy s)
| kind == StablePtrRep = ([alphaTy], [alphaTyVar])
| otherwise = ([],[])
in
- GenPrimOp op_str tvs [byteArrayPrimTy, intPrimTy]
+ mkGenPrimOp op_str tvs [byteArrayPrimTy, intPrimTy]
(mkTyConApp (primRepTyCon kind) prim_tycon_args)
primOpInfo (IndexOffForeignObjOp kind)
| kind == StablePtrRep = ([alphaTy], [alphaTyVar])
| otherwise = ([], [])
in
- GenPrimOp op_str tvs [foreignObjPrimTy, intPrimTy]
+ mkGenPrimOp op_str tvs [foreignObjPrimTy, intPrimTy]
(mkTyConApp (primRepTyCon kind) prim_tycon_args)
primOpInfo (IndexOffAddrOp kind)
| kind == StablePtrRep = ([alphaTy], [alphaTyVar])
| otherwise = ([], [])
in
- GenPrimOp op_str tvs [addrPrimTy, intPrimTy]
+ mkGenPrimOp op_str tvs [addrPrimTy, intPrimTy]
(mkTyConApp (primRepTyCon kind) prim_tycon_args)
primOpInfo (WriteOffAddrOp kind)
op_str = _PK_ ("write" ++ primRepString kind ++ "OffAddr#")
prim_ty = mkTyConApp (primRepTyCon kind) []
in
- GenPrimOp op_str [s_tv]
+ mkGenPrimOp op_str [s_tv]
[addrPrimTy, intPrimTy, prim_ty, mkStatePrimTy s]
(mkStatePrimTy s)
elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar;
state = mkStatePrimTy s
} in
- GenPrimOp SLIT("unsafeFreezeArray#") [s_tv, elt_tv]
+ mkGenPrimOp SLIT("unsafeFreezeArray#") [s_tv, elt_tv]
[mkMutableArrayPrimTy s elt, state]
(unboxedPair [state, mkArrayPrimTy elt])
s = alphaTy; s_tv = alphaTyVar;
state = mkStatePrimTy s
} in
- GenPrimOp SLIT("unsafeFreezeByteArray#") [s_tv]
+ mkGenPrimOp SLIT("unsafeFreezeByteArray#") [s_tv]
[mkMutableByteArrayPrimTy s, state]
(unboxedPair [state, byteArrayPrimTy])
---------------------------------------------------------------------------
primOpInfo SizeofByteArrayOp
- = GenPrimOp
+ = mkGenPrimOp
SLIT("sizeofByteArray#") []
[byteArrayPrimTy]
intPrimTy
primOpInfo SizeofMutableByteArrayOp
= let { s = alphaTy; s_tv = alphaTyVar } in
- GenPrimOp
+ mkGenPrimOp
SLIT("sizeofMutableByteArray#") [s_tv]
[mkMutableByteArrayPrimTy s]
intPrimTy
elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar;
state = mkStatePrimTy s
} in
- GenPrimOp SLIT("newMutVar#") [s_tv, elt_tv]
+ mkGenPrimOp SLIT("newMutVar#") [s_tv, elt_tv]
[elt, state]
(unboxedPair [state, mkMutVarPrimTy s elt])
elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar;
state = mkStatePrimTy s
} in
- GenPrimOp SLIT("readMutVar#") [s_tv, elt_tv]
+ mkGenPrimOp SLIT("readMutVar#") [s_tv, elt_tv]
[mkMutVarPrimTy s elt, state]
(unboxedPair [state, elt])
= let {
elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar
} in
- GenPrimOp SLIT("writeMutVar#") [s_tv, elt_tv]
+ mkGenPrimOp SLIT("writeMutVar#") [s_tv, elt_tv]
[mkMutVarPrimTy s elt, elt, mkStatePrimTy s]
(mkStatePrimTy s)
elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar;
mut_var_ty = mkMutVarPrimTy s elt
} in
- GenPrimOp SLIT("sameMutVar#") [s_tv, elt_tv] [mut_var_ty, mut_var_ty]
+ mkGenPrimOp SLIT("sameMutVar#") [s_tv, elt_tv] [mut_var_ty, mut_var_ty]
boolTy
\end{code}
a = alphaTy; a_tv = alphaTyVar;
b = betaTy; b_tv = betaTyVar;
in
- GenPrimOp SLIT("catch#") [a_tv, b_tv] [a, mkFunTy b a] a
+ mkGenPrimOp SLIT("catch#") [a_tv, b_tv] [a, mkFunTy b a] a
primOpInfo RaiseOp
= let
a = alphaTy; a_tv = alphaTyVar;
b = betaTy; b_tv = betaTyVar;
in
- GenPrimOp SLIT("raise#") [a_tv, b_tv] [a] b
+ mkGenPrimOp SLIT("raise#") [a_tv, b_tv] [a] b
\end{code}
%************************************************************************
elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar
state = mkStatePrimTy s
in
- GenPrimOp SLIT("newMVar#") [s_tv, elt_tv] [state]
+ mkGenPrimOp SLIT("newMVar#") [s_tv, elt_tv] [state]
(unboxedPair [state, mkMVarPrimTy s elt])
primOpInfo TakeMVarOp
elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar
state = mkStatePrimTy s
in
- GenPrimOp SLIT("takeMVar#") [s_tv, elt_tv]
+ mkGenPrimOp SLIT("takeMVar#") [s_tv, elt_tv]
[mkMVarPrimTy s elt, state]
(unboxedPair [state, elt])
= let
elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar
in
- GenPrimOp SLIT("putMVar#") [s_tv, elt_tv]
+ mkGenPrimOp SLIT("putMVar#") [s_tv, elt_tv]
[mkMVarPrimTy s elt, elt, mkStatePrimTy s]
(mkStatePrimTy s)
elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar
mvar_ty = mkMVarPrimTy s elt
in
- GenPrimOp SLIT("sameMVar#") [s_tv, elt_tv] [mvar_ty, mvar_ty] boolTy
+ mkGenPrimOp SLIT("sameMVar#") [s_tv, elt_tv] [mvar_ty, mvar_ty] boolTy
\end{code}
%************************************************************************
= let {
s = alphaTy; s_tv = alphaTyVar
} in
- GenPrimOp SLIT("delay#") [s_tv]
+ mkGenPrimOp SLIT("delay#") [s_tv]
[intPrimTy, mkStatePrimTy s] (mkStatePrimTy s)
primOpInfo WaitReadOp
= let {
s = alphaTy; s_tv = alphaTyVar
} in
- GenPrimOp SLIT("waitRead#") [s_tv]
+ mkGenPrimOp SLIT("waitRead#") [s_tv]
[intPrimTy, mkStatePrimTy s] (mkStatePrimTy s)
primOpInfo WaitWriteOp
= let {
s = alphaTy; s_tv = alphaTyVar
} in
- GenPrimOp SLIT("waitWrite#") [s_tv]
+ mkGenPrimOp SLIT("waitWrite#") [s_tv]
[intPrimTy, mkStatePrimTy s] (mkStatePrimTy s)
\end{code}
\begin{code}
-- fork# :: a -> State# RealWorld -> (# State# RealWorld, ThreadId# #)
primOpInfo ForkOp
- = GenPrimOp SLIT("fork#") [alphaTyVar]
+ = mkGenPrimOp SLIT("fork#") [alphaTyVar]
[alphaTy, realWorldStatePrimTy]
(unboxedPair [realWorldStatePrimTy, threadIdPrimTy])
-- killThread# :: ThreadId# -> State# RealWorld -> State# RealWorld
primOpInfo KillThreadOp
- = GenPrimOp SLIT("killThread#") []
+ = mkGenPrimOp SLIT("killThread#") []
[threadIdPrimTy, realWorldStatePrimTy]
realWorldStatePrimTy
\end{code}
\begin{code}
primOpInfo MakeForeignObjOp
- = GenPrimOp SLIT("makeForeignObj#") []
+ = mkGenPrimOp SLIT("makeForeignObj#") []
[addrPrimTy, realWorldStatePrimTy]
(unboxedPair [realWorldStatePrimTy, foreignObjPrimTy])
= let {
s = alphaTy; s_tv = alphaTyVar
} in
- GenPrimOp SLIT("writeForeignObj#") [s_tv]
+ mkGenPrimOp SLIT("writeForeignObj#") [s_tv]
[foreignObjPrimTy, addrPrimTy, mkStatePrimTy s] (mkStatePrimTy s)
\end{code}
\begin{code}
primOpInfo MkWeakOp
- = GenPrimOp SLIT("mkWeak#") [alphaTyVar, betaTyVar, gammaTyVar]
+ = mkGenPrimOp SLIT("mkWeak#") [alphaTyVar, betaTyVar, gammaTyVar]
[alphaTy, betaTy, gammaTy, realWorldStatePrimTy]
(unboxedPair [realWorldStatePrimTy, mkWeakPrimTy betaTy])
\end{code}
\begin{code}
primOpInfo DeRefWeakOp
- = GenPrimOp SLIT("deRefWeak#") [alphaTyVar]
+ = mkGenPrimOp SLIT("deRefWeak#") [alphaTyVar]
[mkWeakPrimTy alphaTy, realWorldStatePrimTy]
(unboxedTriple [realWorldStatePrimTy, intPrimTy, alphaTy])
\end{code}
\begin{code}
primOpInfo MakeStablePtrOp
- = GenPrimOp SLIT("makeStablePtr#") [alphaTyVar]
+ = mkGenPrimOp SLIT("makeStablePtr#") [alphaTyVar]
[alphaTy, realWorldStatePrimTy]
(unboxedPair [realWorldStatePrimTy,
mkTyConApp stablePtrPrimTyCon [alphaTy]])
primOpInfo DeRefStablePtrOp
- = GenPrimOp SLIT("deRefStablePtr#") [alphaTyVar]
+ = mkGenPrimOp SLIT("deRefStablePtr#") [alphaTyVar]
[mkStablePtrPrimTy alphaTy, realWorldStatePrimTy]
(unboxedPair [realWorldStatePrimTy, alphaTy])
primOpInfo EqStablePtrOp
- = GenPrimOp SLIT("eqStablePtr#") [alphaTyVar, betaTyVar]
+ = mkGenPrimOp SLIT("eqStablePtr#") [alphaTyVar, betaTyVar]
[mkStablePtrPrimTy alphaTy, mkStablePtrPrimTy betaTy]
intPrimTy
\end{code}
\begin{code}
primOpInfo ReallyUnsafePtrEqualityOp
- = GenPrimOp SLIT("reallyUnsafePtrEquality#") [alphaTyVar]
+ = mkGenPrimOp SLIT("reallyUnsafePtrEquality#") [alphaTyVar]
[alphaTy, alphaTy] intPrimTy
\end{code}
\begin{code}
primOpInfo SeqOp -- seq# :: a -> Int#
- = GenPrimOp SLIT("seq#") [alphaTyVar] [alphaTy] intPrimTy
+ = mkGenPrimOp SLIT("seq#") [alphaTyVar] [alphaTy] intPrimTy
primOpInfo ParOp -- par# :: a -> Int#
- = GenPrimOp SLIT("par#") [alphaTyVar] [alphaTy] intPrimTy
+ = mkGenPrimOp SLIT("par#") [alphaTyVar] [alphaTy] intPrimTy
\end{code}
\begin{code}
-- Same structure as _seq_ i.e. returns Int#
primOpInfo ParGlobalOp -- parGlobal# :: Int# -> Int# -> Int# -> Int# -> a -> b -> b
- = GenPrimOp SLIT("parGlobal#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] intPrimTy
+ = mkGenPrimOp SLIT("parGlobal#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] intPrimTy
primOpInfo ParLocalOp -- parLocal# :: Int# -> Int# -> Int# -> Int# -> a -> b -> b
- = GenPrimOp SLIT("parLocal#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] intPrimTy
+ = mkGenPrimOp SLIT("parLocal#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] intPrimTy
primOpInfo ParAtOp -- parAt# :: Int# -> Int# -> Int# -> Int# -> a -> b -> c -> c
- = GenPrimOp SLIT("parAt#") [alphaTyVar,betaTyVar,gammaTyVar] [betaTy,alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,gammaTy] intPrimTy
+ = mkGenPrimOp SLIT("parAt#") [alphaTyVar,betaTyVar,gammaTyVar] [betaTy,alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,gammaTy] intPrimTy
primOpInfo ParAtAbsOp -- parAtAbs# :: Int# -> Int# -> Int# -> Int# -> Int# -> a -> b -> b
- = GenPrimOp SLIT("parAtAbs#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] intPrimTy
+ = mkGenPrimOp SLIT("parAtAbs#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] intPrimTy
primOpInfo ParAtRelOp -- parAtRel# :: Int# -> Int# -> Int# -> Int# -> Int# -> a -> b -> b
- = GenPrimOp SLIT("parAtRel#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] intPrimTy
+ = mkGenPrimOp SLIT("parAtRel#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] intPrimTy
primOpInfo ParAtForNowOp -- parAtForNow# :: Int# -> Int# -> Int# -> Int# -> a -> b -> c -> c
- = GenPrimOp SLIT("parAtForNow#") [alphaTyVar,betaTyVar,gammaTyVar] [betaTy,alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,gammaTy] intPrimTy
+ = mkGenPrimOp SLIT("parAtForNow#") [alphaTyVar,betaTyVar,gammaTyVar] [betaTy,alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,gammaTy] intPrimTy
primOpInfo CopyableOp -- copyable# :: a -> a
- = GenPrimOp SLIT("copyable#") [alphaTyVar] [alphaTy] intPrimTy
+ = mkGenPrimOp SLIT("copyable#") [alphaTyVar] [alphaTy] intPrimTy
primOpInfo NoFollowOp -- noFollow# :: a -> a
- = GenPrimOp SLIT("noFollow#") [alphaTyVar] [alphaTy] intPrimTy
+ = mkGenPrimOp SLIT("noFollow#") [alphaTyVar] [alphaTy] intPrimTy
\end{code}
%************************************************************************
\begin{code}
primOpInfo (CCallOp _ _ _ _)
- = GenPrimOp SLIT("ccall#") [alphaTyVar] [] alphaTy
+ = mkGenPrimOp SLIT("ccall#") [alphaTyVar] [] alphaTy
{-
primOpInfo (CCallOp _ _ _ _ arg_tys result_ty)
- = GenPrimOp SLIT("ccall#") [] arg_tys result_tycon tys_applied
+ = mkGenPrimOp SLIT("ccall#") [] arg_tys result_tycon tys_applied
where
(result_tycon, tys_applied, _) = splitAlgTyConApp result_ty
-}
primOpCanFail DoubleAsinOp = True -- Arg out of domain
primOpCanFail DoubleAcosOp = True -- Arg out of domain
--- The default is "yes it's ok for speculation"
-primOpCanFail other_op = True
+primOpCanFail other_op = False
\end{code}
And some primops have side-effects and so, for example, must not be
\end{code}
\begin{code}
-primOpStr op
+primOpOcc op
= case (primOpInfo op) of
- Dyadic str _ -> str
- Monadic str _ -> str
- Compare str _ -> str
- GenPrimOp str _ _ _ -> str
+ Dyadic occ _ -> occ
+ Monadic occ _ -> occ
+ Compare occ _ -> occ
+ GenPrimOp occ _ _ _ -> occ
\end{code}
\begin{code}
primOpType :: PrimOp -> Type
primOpType op
= case (primOpInfo op) of
- Dyadic str ty -> dyadic_fun_ty ty
- Monadic str ty -> monadic_fun_ty ty
- Compare str ty -> compare_fun_ty ty
+ Dyadic occ ty -> dyadic_fun_ty ty
+ Monadic occ ty -> monadic_fun_ty ty
+ Compare occ ty -> compare_fun_ty ty
- GenPrimOp str tyvars arg_tys res_ty ->
+ GenPrimOp occ tyvars arg_tys res_ty ->
mkForAllTys tyvars (mkFunTys arg_tys res_ty)
\end{code}
pprPrimOp other_op
= getPprStyle $ \ sty ->
- if codeStyle sty then -- For C just print the primop itself
- identToC str
- else if ifaceStyle sty then -- For interfaces Print it qualified with PrelGHC.
- ptext SLIT("PrelGHC.") <> ptext str
- else -- Unqualified is good enough
- ptext str
+ if ifaceStyle sty then -- For interfaces Print it qualified with PrelGHC.
+ ptext SLIT("PrelGHC.") <> pprOccName occ
+ else
+ pprOccName occ
where
- str = primOpStr other_op
+ occ = primOpOcc other_op
\end{code}
where
name = mkWiredInTyConName key pREL_GHC str the_tycon
the_tycon = mkPrimTyCon name kind arity rep
- kind = mkArrowKinds (take arity (repeat openTypeKind)) result_kind
+ kind = mkArrowKinds (take arity (repeat boxedTypeKind)) result_kind
result_kind | isFollowableRep rep = boxedTypeKind -- Represented by a GC-ish ptr
| otherwise = unboxedTypeKind -- Represented by a non-ptr
-- others:
import Constants ( mAX_TUPLE_SIZE )
-import Name ( mkWiredInTyConName, mkWiredInIdName, mkTupNameStr,
- mkUbxTupNameStr )
+import Name ( Module, varOcc, mkWiredInTyConName, mkWiredInIdName )
import DataCon ( DataCon, mkDataCon )
import Var ( TyVar, tyVarKind )
import TyCon ( TyCon, mkAlgTyCon, mkSynTyCon, mkTupleTyCon )
-import BasicTypes ( Module, Arity, NewOrData(..),
+import BasicTypes ( Arity, NewOrData(..),
RecFlag(..), StrictnessMark(..) )
import Type ( Type, mkTyConTy, mkTyConApp, mkSigmaTy, mkTyVarTys,
mkArrowKinds, boxedTypeKind, unboxedTypeKind,
mkFunTy, mkFunTys, isUnLiftedType,
splitTyConApp_maybe, splitAlgTyConApp_maybe,
- GenType(..), ThetaType, TauType )
+ ThetaType, TauType )
import PrimRep ( PrimRep(..) )
import Unique
import CmdLineOpts ( opt_GlasgowExts )
-import Util ( assoc, panic )
+import Util ( assoc )
+import Panic ( panic )
import Array
alpha_tyvar = [alphaTyVar]
[ NotMarkedStrict | a <- arg_tys ]
[ {- no labelled fields -} ]
tyvars context [] [] arg_tys tycon id
- name = mkWiredInIdName key mod str id
+ name = mkWiredInIdName key mod (varOcc str) id
id = mkDataConId data_con
\end{code}
--
-- ) It's boxed; there is only one value of this
-- type, namely "void", whose semantics is just bottom.
+
voidTy = mkTyConTy voidTyCon
voidTyCon = pcNonRecDataTyCon voidTyConKey pREL_GHC SLIT("Void") [] [{-No data cons-}]
+
\end{code}
\begin{code}
intTyCon = pcNonRecDataTyCon intTyConKey pREL_BASE SLIT("Int") [] [intDataCon]
intDataCon = pcDataCon intDataConKey pREL_BASE SLIT("I#") [] [] [intPrimTy] intTyCon
-isIntTy :: GenType flexi -> Bool
+isIntTy :: Type -> Bool
isIntTy ty
= case (splitAlgTyConApp_maybe ty) of
Just (tycon, [], _) -> getUnique tycon == intTyConKey
addrTyCon = pcNonRecDataTyCon addrTyConKey pREL_ADDR SLIT("Addr") [] [addrDataCon]
addrDataCon = pcDataCon addrDataConKey pREL_ADDR SLIT("A#") [] [] [addrPrimTy] addrTyCon
-isAddrTy :: GenType flexi -> Bool
+isAddrTy :: Type -> Bool
isAddrTy ty
= case (splitAlgTyConApp_maybe ty) of
Just (tycon, [], _) -> getUnique tycon == addrTyConKey
floatTyCon = pcNonRecDataTyCon floatTyConKey pREL_BASE SLIT("Float") [] [floatDataCon]
floatDataCon = pcDataCon floatDataConKey pREL_BASE SLIT("F#") [] [] [floatPrimTy] floatTyCon
-isFloatTy :: GenType flexi -> Bool
+isFloatTy :: Type -> Bool
isFloatTy ty
= case (splitAlgTyConApp_maybe ty) of
Just (tycon, [], _) -> getUnique tycon == floatTyConKey
\begin{code}
doubleTy = mkTyConTy doubleTyCon
-isDoubleTy :: GenType flexi -> Bool
+isDoubleTy :: Type -> Bool
isDoubleTy ty
= case (splitAlgTyConApp_maybe ty) of
Just (tycon, [], _) -> getUnique tycon == doubleTyConKey
@Integer@ and its pals are not really primitive. @Integer@ itself, first:
\begin{code}
-integerTy :: GenType t
-integerTy = mkTyConTy integerTyCon
+integerTy :: Type
+integerTy = mkTyConTy integerTyCon
integerTyCon = pcNonRecDataTyCon integerTyConKey pREL_BASE SLIT("Integer") [] [integerDataCon]
integerDataCon = pcDataCon integerDataConKey pREL_BASE SLIT("J#")
[] [] [intPrimTy, intPrimTy, byteArrayPrimTy] integerTyCon
-isIntegerTy :: GenType flexi -> Bool
+isIntegerTy :: Type -> Bool
isIntegerTy ty
= case (splitAlgTyConApp_maybe ty) of
Just (tycon, [], _) -> getUnique tycon == integerTyConKey
\end{verbatim}
\begin{code}
-mkListTy :: GenType t -> GenType t
+mkListTy :: Type -> Type
mkListTy ty = mkTyConApp listTyCon [ty]
alphaListTy = mkSigmaTy alpha_tyvar [] (mkTyConApp listTyCon alpha_ty)
\end{itemize}
\begin{code}
-mkTupleTy :: Int -> [GenType t] -> GenType t
+mkTupleTy :: Int -> [Type] -> Type
mkTupleTy arity tys = mkTyConApp (tupleTyCon arity) tys
-mkUnboxedTupleTy :: Int -> [GenType t] -> GenType t
+mkUnboxedTupleTy :: Int -> [Type] -> Type
mkUnboxedTupleTy arity tys = mkTyConApp (unboxedTupleTyCon arity) tys
unitTy = mkTupleTy 0 []
#include "HsVersions.h"
-import Var ( externallyVisibleId, GenId, Id )
-import CStrings ( identToC, stringToC )
-import Name ( getOccString )
+import Var ( externallyVisibleId, Id )
+import CStrings ( stringToC )
+import Name ( Module, getOccString, moduleString, identToC, pprModule )
import Outputable
-import BasicTypes ( moduleString )
-import Util ( panic, assertPanic, thenCmp )
+import Util ( thenCmp )
\end{code}
A Cost Centre Stack is something that can be attached to a closure.
A Cost Centre is the argument of an _scc_ expression.
\begin{code}
+type Group = FAST_STRING -- "Group" that this CC is in; eg directory
+
data CostCentre
= NoCostCentre -- Having this constructor avoids having
-- to use "Maybe CostCentre" all the time.
- | NormalCC CcKind -- CcKind will include a cost-centre name
- FAST_STRING -- Name of module defining this CC.
- FAST_STRING -- "Group" that this CC is in.
- IsDupdCC -- see below
- IsCafCC -- see below
+ | NormalCC CcKind -- CcKind will include a cost-centre name
+ Module -- Name of module defining this CC.
+ Group -- "Group" that this CC is in.
+ IsDupdCC -- see below
+ IsCafCC -- see below
- | AllCafsCC FAST_STRING -- Ditto for CAFs.
- FAST_STRING -- We record module and group names.
+ | AllCafsCC Module -- Ditto for CAFs.
+ Group -- We record module and group names.
-- Again, one "big" CAF cc per module, where all
-- CAF costs are attributed unless the user asked for
-- per-individual-CAF cost attribution.
- | AllDictsCC FAST_STRING -- Ditto for dictionaries.
- FAST_STRING -- We record module and group names.
+ | AllDictsCC Module -- Ditto for dictionaries.
+ Group -- We record module and group names.
-- Again, one "big" DICT cc per module, where all
-- DICT costs are attributed unless the user asked for
-- per-individual-DICT cost attribution.
Building cost centres
\begin{code}
-mkUserCC :: FAST_STRING -> FAST_STRING -> FAST_STRING -> CostCentre
+mkUserCC :: FAST_STRING -> Module -> Group -> CostCentre
mkUserCC cc_name module_name group_name
= NormalCC (UserCC cc_name) module_name group_name
AnOriginalCC IsNotCafCC{-might be changed-}
-mkDictCC, mkAutoCC :: Id -> FAST_STRING -> FAST_STRING -> IsCafCC -> CostCentre
+mkDictCC, mkAutoCC :: Id -> Module -> Group -> IsCafCC -> CostCentre
mkDictCC id module_name group_name is_caf
= NormalCC (DictCC id) module_name group_name
sccAbleCostCentre cc | isCafCC cc = False
| otherwise = True
-ccFromThisModule :: CostCentre -> FAST_STRING{-module name-} -> Bool
+ccFromThisModule :: CostCentre -> Module -> Bool
ccFromThisModule (NormalCC _ m _ _ _) mod_name = m == mod_name
ccFromThisModule (AllCafsCC m _) mod_name = m == mod_name
getPprStyle $ \sty ->
if (codeStyle sty)
then ptext SLIT("CCS_") <>
- identToC (_PK_ (costCentreStr cc))
+ ptext (identToC (costCentreStr cc))
else ptext SLIT("CCS.") <> text (costCentreStr cc)
pprCostCentreStackDecl :: CostCentreStack -> SDoc
then ppCostCentreIface cc
else text (costCentreStr cc)
-ppCostCentreLbl cc = ptext SLIT("CC_") <> identToC (_PK_ (costCentreStr cc))
+ppCostCentreLbl cc = ptext SLIT("CC_") <> ptext (identToC (costCentreStr cc))
ppCostCentreIface cc = doubleQuotes (text (costCentreStr cc))
ppCostCentreName cc = doubleQuotes (text (stringToC (costCentreName cc)))
costCentreStr (NoCostCentre) = "NO_CC"
-costCentreStr (AllCafsCC m _) = "CAFs." ++ _UNPK_ m
-costCentreStr (AllDictsCC m _ d) = "DICTs." ++ _UNPK_ m
+costCentreStr (AllCafsCC m _) = "CAFs." ++ moduleString m
+costCentreStr (AllDictsCC m _ d) = "DICTs." ++ moduleString m
costCentreStr (NormalCC kind mod_name grp_name is_dupd is_caf)
= case is_caf of { IsCafCC -> "CAF:"; _ -> "" }
++ moduleString mod_name
ptext SLIT("CC_DECLARE"),char '(',
cc_ident, comma,
ppCostCentreName cc, comma,
- pp_str mod_name, comma,
- pp_str grp_name, comma,
+ doubleQuotes (pprModule mod_name), comma,
+ doubleQuotes (ptext grp_name), comma,
ptext is_subsumed, comma,
if externally_visible
then empty
where
cc_ident = ppCostCentreLbl cc
- pp_str s = doubleQuotes (ptext s)
-
(mod_name, grp_name, is_subsumed, externally_visible)
= get_cc_info cc
get_cc_info :: CostCentre ->
- (FAST_STRING, -- module name
- FAST_STRING, -- group name
+ (Module, -- module
+ Group, -- group name
FAST_STRING, -- subsumed value
Bool) -- externally visible
import CostCentre -- lots of things
import Const ( Con(..) )
import Id ( Id, mkSysLocal )
+import OccName ( Module )
import UniqSupply ( uniqFromSupply, splitUniqSupply, UniqSupply )
import Unique ( Unique )
-import Util ( removeDups, assertPanic, trace )
+import Util ( removeDups )
import Outputable
infixr 9 `thenMM`, `thenMM_`
[CostCentreStack]) -- singleton stacks (for CAFs)
stgMassageForProfiling
- :: FAST_STRING -> FAST_STRING -- module name, group name
+ :: Module -> FAST_STRING -- module name, group name
-> UniqSupply -- unique supply
-> [StgBinding] -- input
-> (CollectedCCs, [StgBinding])
-- make a trivial let-binding for the top-level function
getUniqueMM `thenMM` \ uniq ->
let
- new_var = mkSysLocal uniq var_type
+ new_var = mkSysLocal SLIT("sf") uniq var_type
in
returnMM ( (new_var, old_var) : bindings, StgVarAtom new_var )
else
\begin{code}
type MassageM result
- = FAST_STRING -- module name
+ = Module -- module name
-> CostCentreStack -- prevailing CostCentre
-- if none, subsumedCosts at top-level
-- useCurrentCostCentre at nested levels
-- the initUs function also returns the final UniqueSupply and CollectedCCs
-initMM :: FAST_STRING -- module name, which we may consult
+initMM :: Module -- module name, which we may consult
-> UniqSupply
-> MassageM a
-> (CollectedCCs, a)
import CostCentre -- Pretty much all of it
import IdInfo ( InlinePragInfo(..) )
-import Name ( mkTupNameStr, mkUbxTupNameStr,
- isLowerISO, isUpperISO )
+import Name ( isLowerISO, isUpperISO, mkModule )
+import PrelMods ( mkTupNameStr, mkUbxTupNameStr )
import CmdLineOpts ( opt_IgnoreIfacePragmas, opt_HiVersion, opt_NoHiCheck )
import Demand ( Demand(..) {- instance Read -} )
import UniqFM ( UniqFM, listToUFM, lookupUFM)
| ITspecialise
| ITnocaf
| ITunfold InlinePragInfo
- | ITstrict [Demand]
+ | ITstrict ([Demand], Bool)
| ITscc CostCentre
| ITdotdot -- reserved symbols
-------------------------------------------------------------------------------
lex_demand cont buf =
- case read_em [] buf of { (ls,buf') -> cont (ITstrict ls) (stepOverLexeme buf')}
+ case read_em [] buf of { (ls,buf') ->
+ case currentChar# buf' of
+ 'B'# -> cont (ITstrict (ls, True )) (stepOverLexeme (stepOn buf'))
+ _ -> cont (ITstrict (ls, False)) (stepOverLexeme buf')
+ }
where
-- code snatched from Demand.lhs
read_em acc buf =
case prefixMatch (stepOn buf) "CAFs." of
Just buf' ->
case untilChar# (stepOverLexeme buf') '\"'# of
- buf'' -> cont (ITscc (mkAllCafsCC ({-module-}lexemeToFastString buf'') _NIL_)) (stepOn (stepOverLexeme buf''))
+ buf'' -> cont (ITscc (mkAllCafsCC (mkModule (lexemeToString buf'')) _NIL_))
+ (stepOn (stepOverLexeme buf''))
Nothing ->
case prefixMatch (stepOn buf) "DICTs." of
Just buf' ->
case untilChar# (stepOverLexeme buf') '\"'# of
- buf'' -> cont (ITscc (mkAllDictsCC (lexemeToFastString buf'') _NIL_ True))
+ buf'' -> cont (ITscc (mkAllDictsCC (mkModule (lexemeToString buf'')) _NIL_ True))
(stepOn (stepOverLexeme buf''))
Nothing ->
let
match_user_cc buf =
case untilChar# buf '/'# of
buf' ->
- let mod_name = lexemeToFastString buf' in
+ let mod_name = mkModule (lexemeToString buf') in
-- case untilChar# (stepOn (stepOverLexeme buf')) '/'# of
-- buf'' ->
-- let grp_name = lexemeToFastString buf'' in
( "of", ITof ),
( "then", ITthen ),
( "type", ITtype ),
- ( "where", ITwhere ),
- ( "as", ITas ),
- ( "qualified", ITqualified ),
- ( "hiding", IThiding )
+ ( "where", ITwhere )
+
+-- These three aren't Haskell keywords at all
+-- and 'as' is often used as a variable name
+-- ( "as", ITas ),
+-- ( "qualified", ITqualified ),
+-- ( "hiding", IThiding )
+
]
haskellKeySymsFM = listToUFM $
getSrcLocIf s l = Succeeded l
happyError :: IfM a
-happyError s l = Failed (ifaceParseErr l ([]::[IfaceToken]){-Todo-})
+happyError s l = Failed (ifaceParseErr s l)
{-
-----------------------------------------------------------------
-ifaceParseErr l toks
+ifaceParseErr :: StringBuffer -> SrcLoc -> ErrMsg
+ifaceParseErr s l
= hsep [ppr l, ptext SLIT("Interface-file parse error;"),
- ptext SLIT("toks="), text (show (take 10 toks))]
+ ptext SLIT("current input ="), text first_bit]
+ where
+ first_bit = lexemeToString (stepOnBy# s 100#)
ifaceVersionErr hi_vers l toks
= hsep [ppr l, ptext SLIT("Interface file version error;"),
import HsSyn
import RdrHsSyn
-import Util ( panic )
+import Panic ( panic )
import Char ( isDigit, ord )
data RdrBinding
= RdrNullBind
| RdrAndBindings RdrBinding RdrBinding
-
- | RdrTyDecl RdrNameTyDecl
- | RdrFunctionBinding SrcLine [RdrMatch]
- | RdrPatternBinding SrcLine [RdrMatch]
- | RdrClassDecl RdrNameClassDecl
+ | RdrTyClDecl RdrNameTyClDecl
+ | RdrValBinding RdrNameMonoBinds -- Pattern or function binding
| RdrInstDecl RdrNameInstDecl
| RdrDefaultDecl RdrNameDefaultDecl
| RdrForeignDecl RdrNameForeignDecl
\begin{code}
data RdrMatch
- = RdrMatch_NoGuard
- SrcLine SrcFun
- RdrNamePat
- RdrNameHsExpr
- RdrBinding
-
- | RdrMatch_Guards
- SrcLine SrcFun
- RdrNamePat
- [([RdrNameStmt], RdrNameHsExpr)]
- -- (guard, expr)
- RdrBinding
+ = RdrMatch
+ [RdrNamePat]
+ (Maybe RdrNameHsType)
+ RdrNameGRHSs
\end{code}
Unscramble strings representing oct/dec/hex integer literals:
\begin{code}
module PrefixToHs (
- cvValSig,
- cvClassOpSig,
- cvInstDeclSig,
-
cvBinds,
cvMonoBindsAndSigs,
- cvMatches,
- cvOtherDecls,
- cvForeignDecls -- HACK
-
+ cvTopDecls,
+ cvValSig, cvClassOpSig, cvInstDeclSig
) where
#include "HsVersions.h"
import BasicTypes ( RecFlag(..) )
import SrcLoc ( mkSrcLoc )
-import Util ( mapAndUnzip, panic, assertPanic )
+import Util ( mapAndUnzip )
+import Panic ( panic, assertPanic )
\end{code}
%************************************************************************
\begin{code}
cvBinds :: SrcFile -> SigConverter -> RdrBinding -> RdrNameHsBinds
+ -- The mysterious SigConverter converts Sigs to ClassOpSigs
+ -- in class declarations. Mostly it's just an identity function
+
cvBinds sf sig_cvtr binding
= case (cvMonoBindsAndSigs sf sig_cvtr binding) of { (mbs, sigs) ->
MonoBind mbs sigs Recursive
cvMonoBindsAndSigs sf sig_cvtr fb
= mangle_bind (EmptyMonoBinds, []) fb
where
- -- If the function being bound has at least one argument, then the
- -- guarded right hand sides of each pattern binding are knitted
- -- into a series of patterns, each matched with its corresponding
- -- guarded right hand side (which may contain several
- -- alternatives). This series is then paired with the name of the
- -- function. Otherwise there is only one pattern, which is paired
- -- with a guarded right hand side.
+ mangle_bind acc RdrNullBind
+ = acc
mangle_bind acc (RdrAndBindings fb1 fb2)
= mangle_bind (mangle_bind acc fb1) fb2
mangle_bind (b_acc, s_acc) (RdrSig sig)
= (b_acc, sig_cvtr sig : s_acc)
- mangle_bind (b_acc, s_acc)
- (RdrPatternBinding lousy_srcline [patbinding])
- -- WDP: the parser has trouble getting a good line-number on RdrPatternBindings.
- = case (cvPatMonoBind sf patbinding) of { (pat, grhss, binds) ->
- let
- src_loc = mkSrcLoc sf good_srcline
- in
- (b_acc `AndMonoBinds`
- PatMonoBind pat (GRHSsAndBindsIn grhss binds) src_loc, s_acc)
- }
- where
- good_srcline = case patbinding of
- RdrMatch_NoGuard ln _ _ _ _ -> ln
- RdrMatch_Guards ln _ _ _ _ -> ln
-
-
- mangle_bind _ (RdrPatternBinding _ _)
- = panic "mangleBinding: more than one pattern on a RdrPatternBinding"
-
- mangle_bind (b_acc, s_acc) (RdrFunctionBinding srcline patbindings)
- -- must be a function binding...
- = case (cvFunMonoBind sf patbindings) of { (var, inf, matches) ->
- (b_acc `AndMonoBinds`
- FunMonoBind var inf matches (mkSrcLoc sf srcline), s_acc)
- }
-
- mangle_bind (b_acc, s_acc) other = (b_acc, s_acc)
- -- Ignore class decls, instance decls etc
+ mangle_bind (b_acc, s_acc) (RdrValBinding binding)
+ = (b_acc `AndMonoBinds` binding, s_acc)
\end{code}
-\begin{code}
-cvPatMonoBind :: SrcFile -> RdrMatch -> (RdrNamePat, [RdrNameGRHS], RdrNameHsBinds)
-
-cvPatMonoBind sf (RdrMatch_NoGuard srcline srcfun pat expr binding)
- = (pat, unguardedRHS expr (mkSrcLoc sf srcline), cvBinds sf cvValSig binding)
-
-cvPatMonoBind sf (RdrMatch_Guards srcline srcfun pat guardedexprs binding)
- = (pat, map (cvGRHS sf srcline) guardedexprs, cvBinds sf cvValSig binding)
-
-cvFunMonoBind :: SrcFile -> [RdrMatch] -> (RdrName {-VarName-}, Bool {-InfixDefn-}, [RdrNameMatch])
-
-cvFunMonoBind sf matches
- = (head srcfuns, head infixdefs, cvMatches sf False matches)
- where
- (srcfuns, infixdefs) = mapAndUnzip get_mdef matches
- -- ToDo: Check for consistent srcfun and infixdef
-
- get_mdef (RdrMatch_NoGuard _ sfun pat _ _) = get_pdef pat
- get_mdef (RdrMatch_Guards _ sfun pat _ _) = get_pdef pat
-
- get_pdef (ConPatIn fn _) = (fn, False)
- get_pdef (ConOpPatIn _ op _ _) = (op, True)
- get_pdef (ParPatIn pat) = get_pdef pat
-
-
-cvMatches :: SrcFile -> Bool -> [RdrMatch] -> [RdrNameMatch]
-cvMatch :: SrcFile -> Bool -> RdrMatch -> RdrNameMatch
-
-cvMatches sf is_case matches = map (cvMatch sf is_case) matches
-
-cvMatch sf is_case rdr_match
- = foldr PatMatch
- (GRHSMatch (GRHSsAndBindsIn guarded_exprs (cvBinds sf cvValSig binding)))
-
- -- For a FunMonoBinds, the first flattened "pattern" is
- -- just the function name, and we don't want to keep it.
- -- For a case expr, it's (presumably) a constructor name -- and
- -- we most certainly want to keep it! Hence the monkey busines...
-
- (if is_case then -- just one pattern: leave it untouched...
- [pat]
- else -- function pattern; extract arg patterns...
- case pat of ConPatIn fn pats -> pats
- ConOpPatIn p1 op _ p2 -> [p1,p2]
- ParPatIn pat -> panic "PrefixToHs.cvMatch:ParPatIn"
- )
- where
- (pat, binding, guarded_exprs)
- = case rdr_match of
- RdrMatch_NoGuard ln b c expr d -> (c,d, unguardedRHS expr (mkSrcLoc sf ln))
- RdrMatch_Guards ln b c gd_exps d -> (c,d, map (cvGRHS sf ln) gd_exps)
-
-cvGRHS :: SrcFile -> SrcLine -> ([RdrNameStmt], RdrNameHsExpr) -> RdrNameGRHS
-cvGRHS sf sl (g, e) = GRHS (g ++ [ExprStmt e locn]) locn
- where
- locn = mkSrcLoc sf sl
-\end{code}
%************************************************************************
%* *
Separate declarations into all the various kinds:
\begin{code}
-cvOtherDecls :: RdrBinding -> [RdrNameHsDecl]
-cvOtherDecls b
- = go [] b
+cvTopDecls :: SrcFile -> RdrBinding -> [RdrNameHsDecl]
+cvTopDecls srcfile bind
+ = let
+ (top_decls, mono_binds, sigs) = go ([], EmptyMonoBinds, []) bind
+ in
+ (ValD (MonoBind mono_binds sigs Recursive) : top_decls)
where
- go acc (RdrAndBindings b1 b2) = go (go acc b1) b2
- go acc (RdrTyDecl d) = TyD d : acc
- go acc (RdrClassDecl d) = ClD d : acc
- go acc (RdrInstDecl d) = InstD d : acc
- go acc (RdrDefaultDecl d) = DefD d : acc
- go acc other = acc
- -- Ignore value bindings
-
-cvForeignDecls :: RdrBinding -> [RdrNameHsDecl]
-cvForeignDecls b = go [] b
- where
- go acc (RdrAndBindings b1 b2) = go (go acc b1) b2
- go acc (RdrForeignDecl d) = ForD d : acc
- go acc other = acc
-
+ go acc RdrNullBind = acc
+ go acc (RdrAndBindings b1 b2) = go (go acc b1) b2
+ go (topds, mbs, sigs) (RdrTyClDecl d) = (TyClD d : topds, mbs, sigs)
+ go (topds, mbs, sigs) (RdrInstDecl d) = (InstD d : topds, mbs, sigs)
+ go (topds, mbs, sigs) (RdrDefaultDecl d) = (DefD d : topds, mbs, sigs)
+ go (topds, mbs, sigs) (RdrForeignDecl d) = (ForD d : topds, mbs, sigs)
+ go (topds, mbs, sigs) (RdrSig (FixSig d)) = (FixD d : topds, mbs, sigs)
+ go (topds, mbs, sigs) (RdrSig sig) = (topds, mbs, sig:sigs)
+ go (topds, mbs, sigs) (RdrValBinding bind) = (topds, mbs `AndMonoBinds` bind, sigs)
\end{code}
module RdrHsSyn (
RdrNameArithSeqInfo,
RdrNameBangType,
- RdrNameClassDecl,
RdrNameClassOpSig,
RdrNameConDecl,
RdrNameContext,
RdrNameSpecDataSig,
RdrNameDefaultDecl,
RdrNameForeignDecl,
- RdrNameFixityDecl,
RdrNameGRHS,
- RdrNameGRHSsAndBinds,
+ RdrNameGRHSs,
RdrNameHsBinds,
RdrNameHsDecl,
RdrNameHsExpr,
RdrNameHsType,
RdrNameSig,
RdrNameStmt,
- RdrNameTyDecl,
+ RdrNameTyClDecl,
RdrNameClassOpPragmas,
RdrNameClassPragmas,
RdrNameDataPragmas,
RdrNameGenPragmas,
RdrNameInstancePragmas,
- extractHsTyVars, extractHsCtxtTyVars,
+ extractHsTyVars, extractHsCtxtTyVars, extractPatsTyVars,
RdrName(..),
- qual, varQual, tcQual, varUnqual, lexVarQual, lexTcQual,
- mkTupConRdrName, mkUbxTupConRdrName,
+ qual, varQual, tcQual, varUnqual,
dummyRdrVarName, dummyRdrTcName,
isUnqual, isQual,
rdrNameOcc, rdrNameModule, ieOcc,
- cmpRdr, prefixRdrName,
- mkOpApp, mkClassDecl, isClassDataConRdrName
+ cmpRdr,
+ mkOpApp, mkClassDecl
) where
#include "HsVersions.h"
import HsSyn
-import BasicTypes ( Module, IfaceFlavour(..), Unused )
-import Name ( pprModule, OccName(..), pprOccName,
- mkTupNameStr, mkUbxTupNameStr,
- prefixOccName, NamedThing(..),
- mkClassTyConStr, mkClassDataConStr )
+import BasicTypes ( IfaceFlavour(..), Unused )
+import Name ( NamedThing(..),
+ Module, pprModule, mkModuleFS,
+ OccName, srcTCOcc, srcVarOcc, isTvOcc,
+ pprOccName, mkClassTyConOcc, mkClassDataConOcc
+ )
+import PrelMods ( mkTupNameStr, mkUbxTupNameStr )
import Util ( thenCmp )
import HsPragmas ( GenPragmas, ClassPragmas, DataPragmas, ClassOpPragmas, InstancePragmas )
import List ( nub )
import Outputable
-
-import Char ( isUpper )
\end{code}
\begin{code}
-type RdrNameArithSeqInfo = ArithSeqInfo Unused RdrName RdrNamePat
+type RdrNameArithSeqInfo = ArithSeqInfo RdrName RdrNamePat
type RdrNameBangType = BangType RdrName
-type RdrNameClassDecl = ClassDecl Unused RdrName RdrNamePat
type RdrNameClassOpSig = Sig RdrName
type RdrNameConDecl = ConDecl RdrName
type RdrNameContext = Context RdrName
-type RdrNameHsDecl = HsDecl Unused RdrName RdrNamePat
+type RdrNameHsDecl = HsDecl RdrName RdrNamePat
type RdrNameSpecDataSig = SpecDataSig RdrName
type RdrNameDefaultDecl = DefaultDecl RdrName
type RdrNameForeignDecl = ForeignDecl RdrName
-type RdrNameFixityDecl = FixityDecl RdrName
-type RdrNameGRHS = GRHS Unused RdrName RdrNamePat
-type RdrNameGRHSsAndBinds = GRHSsAndBinds Unused RdrName RdrNamePat
-type RdrNameHsBinds = HsBinds Unused RdrName RdrNamePat
-type RdrNameHsExpr = HsExpr Unused RdrName RdrNamePat
-type RdrNameHsModule = HsModule Unused RdrName RdrNamePat
+type RdrNameGRHS = GRHS RdrName RdrNamePat
+type RdrNameGRHSs = GRHSs RdrName RdrNamePat
+type RdrNameHsBinds = HsBinds RdrName RdrNamePat
+type RdrNameHsExpr = HsExpr RdrName RdrNamePat
+type RdrNameHsModule = HsModule RdrName RdrNamePat
type RdrNameIE = IE RdrName
type RdrNameImportDecl = ImportDecl RdrName
-type RdrNameInstDecl = InstDecl Unused RdrName RdrNamePat
-type RdrNameMatch = Match Unused RdrName RdrNamePat
-type RdrNameMonoBinds = MonoBinds Unused RdrName RdrNamePat
+type RdrNameInstDecl = InstDecl RdrName RdrNamePat
+type RdrNameMatch = Match RdrName RdrNamePat
+type RdrNameMonoBinds = MonoBinds RdrName RdrNamePat
type RdrNamePat = InPat RdrName
type RdrNameHsType = HsType RdrName
type RdrNameSig = Sig RdrName
-type RdrNameStmt = Stmt Unused RdrName RdrNamePat
-type RdrNameTyDecl = TyDecl RdrName
+type RdrNameStmt = Stmt RdrName RdrNamePat
+type RdrNameTyClDecl = TyClDecl RdrName RdrNamePat
type RdrNameClassOpPragmas = ClassOpPragmas RdrName
type RdrNameClassPragmas = ClassPragmas RdrName
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 (MonoDictTy cls tys) acc = foldr extract_ty acc tys
-extract_ty (MonoTyVar tv) acc = insert tv acc
+extract_ty (MonoTyVar tv) acc = insertTV tv acc
extract_ty (HsForAllTy tvs ctxt ty) acc = acc ++
(filter (`notElem` locals) $
extract_ctxt ctxt (extract_ty ty []))
where
locals = map getTyVarName tvs
-insert (Qual _ _ _) acc = acc
-insert (Unqual (TCOcc _)) acc = acc
-insert other acc = other : acc
+insertTV name@(Unqual occ) acc | isTvOcc occ = name : acc
+insertTV other acc = acc
+
+extractPatsTyVars :: [RdrNamePat] -> [RdrName]
+extractPatsTyVars pats = nub (foldr extract_pat [] pats)
+
+extract_pat (SigPatIn pat ty) acc = extract_ty ty acc
+extract_pat WildPatIn acc = acc
+extract_pat (VarPatIn var) acc = acc
+extract_pat (LitPatIn _) acc = acc
+extract_pat (LazyPatIn pat) acc = extract_pat pat acc
+extract_pat (AsPatIn a pat) acc = extract_pat pat acc
+extract_pat (NPlusKPatIn n _) acc = acc
+extract_pat (ConPatIn c pats) acc = foldr extract_pat acc pats
+extract_pat (ConOpPatIn p1 c f p2) acc = extract_pat p1 (extract_pat p2 acc)
+extract_pat (NegPatIn pat) acc = extract_pat pat acc
+extract_pat (ParPatIn pat) acc = extract_pat pat acc
+extract_pat (ListPatIn pats) acc = foldr extract_pat acc pats
+extract_pat (TuplePatIn pats _) acc = foldr extract_pat acc pats
+extract_pat (RecPatIn c fields) acc = foldr (\ (f,pat,_) acc -> extract_pat pat acc) acc fields
\end{code}
mkClassDecl cxt cname tyvars sigs mbinds prags loc
= ClassDecl cxt cname tyvars sigs mbinds prags tname dname loc
where
- -- The datacon and tycon are called ":C" where the class is C
+ -- The datacon and tycon are called "_DC" and "_TC", where the class is C
-- This prevents name clashes with user-defined tycons or datacons C
(dname, tname) = case cname of
- Qual m (TCOcc s) hif -> (Qual m (VarOcc s1) hif, Qual m (TCOcc s1) hif)
- where
- s1 = mkClassTyConStr s
-
- Unqual (TCOcc s) -> (Unqual (VarOcc s1), Unqual (TCOcc s1))
- where
- s1 = mkClassDataConStr s
-
--- This nasty little function tests for whether a RdrName was
--- constructed by the above process. It's used only for filtering
--- out duff error messages. Maybe there's a tidier way of doing this
--- but I can't work up the energy to find it.
-
-isClassDataConRdrName rdr_name
- = case rdrNameOcc rdr_name of
- TCOcc s -> case _UNPK_ s of
- ':' : c : _ -> isUpper c
- other -> False
- other -> False
+ Qual m occ hif -> (Qual m (mkClassDataConOcc occ) hif,
+ Qual m (mkClassTyConOcc occ) hif)
+ Unqual occ -> (Unqual (mkClassDataConOcc occ),
+ Unqual (mkClassTyConOcc occ))
\end{code}
%************************************************************************
| Qual Module OccName IfaceFlavour -- HiBootFile for M!.t (interface files only),
-- HiFile for the common M.t
+-- These ones are used for making RdrNames for known-key things,
+-- Or in code constructed from derivings
qual (m,n) = Qual m n HiFile
-tcQual (m,n) = Qual m (TCOcc n) HiFile
-varQual (m,n) = Qual m (VarOcc n) HiFile
-
-mkTupConRdrName :: Int -> RdrName -- The name for the tuple data construtor
- -- Hence VarOcc
-mkTupConRdrName arity = case mkTupNameStr arity of
- (mod, occ) -> Qual mod (VarOcc occ) HiFile
-
-mkUbxTupConRdrName :: Int -> RdrName -- The name for the tuple data construtor
- -- Hence VarOcc
-mkUbxTupConRdrName arity = case mkUbxTupNameStr arity of
- (mod, occ) -> Qual mod (VarOcc occ) HiFile
-
-lexTcQual (m,n,hif) = Qual m (TCOcc n) hif
-lexVarQual (m,n,hif) = Qual m (VarOcc n) hif
+tcQual (m,n) = Qual m (srcTCOcc n) HiFile
+varQual (m,n) = Qual m (srcVarOcc n) HiFile
+varUnqual n = Unqual (srcVarOcc n)
-- This guy is used by the reader when HsSyn has a slot for
-- an implicit name that's going to be filled in by
-- the renamer. We can't just put "error..." because
-- we sometimes want to print out stuff after reading but
-- before renaming
-dummyRdrVarName = Unqual (VarOcc SLIT("V-DUMMY"))
-dummyRdrTcName = Unqual (VarOcc SLIT("TC-DUMMY"))
-
+dummyRdrVarName = Unqual (srcVarOcc SLIT("V-DUMMY"))
+dummyRdrTcName = Unqual (srcVarOcc SLIT("TC-DUMMY"))
-varUnqual n = Unqual (VarOcc n)
isUnqual (Unqual _) = True
isUnqual (Qual _ _ _) = False
isQual (Qual _ _ _) = True
- -- Used for adding a prefix to a RdrName
-prefixRdrName :: FAST_STRING -> RdrName -> RdrName
-prefixRdrName prefix (Qual m n hif) = Qual m (prefixOccName prefix n) hif
-prefixRdrName prefix (Unqual n) = Unqual (prefixOccName prefix n)
-
cmpRdr (Unqual n1) (Unqual n2) = n1 `compare` n2
cmpRdr (Unqual n1) (Qual m2 n2 _) = LT
cmpRdr (Qual m1 n1 _) (Unqual n2) = GT
import CallConv
import CmdLineOpts ( opt_NoImplicitPrelude, opt_GlasgowExts )
-import Name ( OccName(..), Module, isLexConId )
+import Name ( OccName, srcTvOcc, srcVarOcc, srcTCOcc,
+ Module, mkModuleFS,
+ isConOcc, isLexConId
+ )
import Outputable
+import SrcLoc ( SrcLoc )
import PrelMods ( pRELUDE )
import FastString ( mkFastCharString )
import PrelRead ( readRational__ )
\end{code}
\begin{code}
-wlkTCId = wlkQid TCOcc
-wlkVarId = wlkQid VarOcc
-wlkDataId = wlkQid VarOcc
+wlkTCId = wlkQid srcTCOcc
+wlkVarId = wlkQid srcVarOcc
+wlkDataId = wlkQid srcVarOcc
wlkEntId = wlkQid (\occ -> if isLexConId occ
- then TCOcc occ
- else VarOcc occ)
+ then srcTCOcc occ
+ else srcVarOcc occ)
wlkQid :: (FAST_STRING -> OccName) -> U_qid -> UgnM RdrName
wlkQid mk_occ_name (U_noqual name)
= returnUgn (Unqual (mk_occ_name name))
wlkQid mk_occ_name (U_aqual mod name)
- = returnUgn (Qual mod (mk_occ_name name) HiFile)
+ = returnUgn (Qual (mkModuleFS mod) (mk_occ_name name) HiFile)
wlkQid mk_occ_name (U_gid n name)
| opt_NoImplicitPrelude
= returnUgn (Unqual (mk_occ_name name))
= returnUgn (Qual pRELUDE (mk_occ_name name) HiFile)
-rdTCId pt = rdU_qid pt `thenUgn` \ qid -> wlkTCId qid
-rdVarId pt = rdU_qid pt `thenUgn` \ qid -> wlkVarId qid
+rdTCId pt = rdU_qid pt `thenUgn` wlkTCId
+rdVarId pt = rdU_qid pt `thenUgn` wlkVarId
rdTvId pt = rdU_stringId pt `thenUgn` \ string -> wlkTvId string
-wlkTvId string = returnUgn (Unqual (TvOcc string))
+wlkTvId string = returnUgn (Unqual (srcTvOcc string))
cvFlag :: U_long -> Bool
cvFlag 0 = False
srcfile = mkFastCharString ``input_filename'' -- What A Great Hack! (TM)
in
initUgn $
- rdU_tree pt `thenUgn` \ (U_hmodule modname himplist hexplist hfixlist
+ rdU_tree pt `thenUgn` \ (U_hmodule mod_fs himplist hexplist
hmodlist srciface_version srcline) ->
+ let
+ mod_name = mkModuleFS mod_fs
+ in
- setSrcFileUgn srcfile $
- setSrcModUgn modname $
- mkSrcLocUgn srcline $ \ src_loc ->
+ setSrcFileUgn srcfile $
+ setSrcModUgn mod_name $
+ mkSrcLocUgn srcline $ \ src_loc ->
wlkMaybe rdEntities hexplist `thenUgn` \ exports ->
wlkList rdImport himplist `thenUgn` \ imports ->
- wlkList rdFixOp hfixlist `thenUgn` \ fixities ->
wlkBinding hmodlist `thenUgn` \ binding ->
let
- val_decl = ValD (cvBinds srcfile cvValSig binding)
- for_decls = cvForeignDecls binding
- other_decls = cvOtherDecls binding
+ top_decls = cvTopDecls srcfile binding
in
- returnUgn (modname,
- HsModule modname
+ returnUgn (mod_name,
+ HsModule mod_name
(case srciface_version of { 0 -> Nothing; n -> Just n })
exports
imports
- fixities
- (for_decls ++ val_decl: other_decls)
+ top_decls
src_loc
)
\end{code}
rdExpr :: ParseTree -> UgnM RdrNameHsExpr
rdPat :: ParseTree -> UgnM RdrNamePat
-rdExpr pt = rdU_tree pt `thenUgn` \ tree -> wlkExpr tree
-rdPat pt = rdU_tree pt `thenUgn` \ tree -> wlkPat tree
+rdExpr pt = rdU_tree pt `thenUgn` wlkExpr
+rdPat pt = rdU_tree pt `thenUgn` wlkPat
wlkExpr :: U_tree -> UgnM RdrNameHsExpr
wlkPat :: U_tree -> UgnM RdrNamePat
wlkExpr sccexp `thenUgn` \ expr ->
returnUgn (HsSCC label expr)
- U_lambda lampats lamexpr srcline -> -- lambda expression
- mkSrcLocUgn srcline $ \ src_loc ->
- wlkList rdPat lampats `thenUgn` \ pats ->
- wlkExpr lamexpr `thenUgn` \ body ->
- returnUgn (
- HsLam (foldr PatMatch
- (GRHSMatch (GRHSsAndBindsIn
- (unguardedRHS body src_loc)
- EmptyBinds))
- pats)
- )
+ U_lambda match -> -- lambda expression
+ wlkMatch match `thenUgn` \ match' ->
+ returnUgn (HsLam match')
U_casee caseexpr casebody srcline -> -- case expression
mkSrcLocUgn srcline $ \ src_loc ->
wlkExpr caseexpr `thenUgn` \ expr ->
wlkList rdMatch casebody `thenUgn` \ mats ->
- getSrcFileUgn `thenUgn` \ sf ->
- let
- matches = cvMatches sf True mats
- in
- returnUgn (HsCase expr matches src_loc)
+ returnUgn (HsCase expr mats src_loc)
U_ife ifpred ifthen ifelse srcline -> -- if expression
mkSrcLocUgn srcline $ \ src_loc ->
returnUgn (HsIf e1 e2 e3 src_loc)
U_let letvdefs letvexpr -> -- let expression
- wlkBinding letvdefs `thenUgn` \ binding ->
- wlkExpr letvexpr `thenUgn` \ expr ->
- getSrcFileUgn `thenUgn` \ sf ->
- let
- binds = cvBinds sf cvValSig binding
- in
- returnUgn (HsLet binds expr)
+ wlkLocalBinding letvdefs `thenUgn` \ binding ->
+ wlkExpr letvexpr `thenUgn` \ expr ->
+ returnUgn (HsLet binding expr)
U_doe gdo srcline -> -- do expression
mkSrcLocUgn srcline $ \ src_loc ->
returnUgn (BindStmt patt expr src_loc)
U_seqlet seqlet ->
- wlkBinding seqlet `thenUgn` \ bs ->
- getSrcFileUgn `thenUgn` \ sf ->
- let
- binds = cvBinds sf cvValSig bs
- in
+ wlkLocalBinding seqlet `thenUgn` \ binds ->
returnUgn (LetStmt binds)
U_comprh cexp cquals -> -- list comprehension
returnUgn (RecordUpd aexp recbinds)
#ifdef DEBUG
- U_hmodule _ _ _ _ _ _ _ -> error "U_hmodule"
+ U_hmodule _ _ _ _ _ _ -> error "U_hmodule"
U_as _ _ -> error "U_as"
U_lazyp _ -> error "U_lazyp"
U_wildp -> error "U_wildp"
U_dobind _ _ _ -> error "U_dobind"
U_doexp _ _ -> error "U_doexp"
U_rbind _ _ -> error "U_rbind"
- U_fixop _ _ _ _ -> error "U_fixop"
#endif
rdRbind pt
returnUgn (BindStmt pat expr loc)
U_seqlet seqlet ->
- wlkBinding seqlet `thenUgn` \ bs ->
- getSrcFileUgn `thenUgn` \ sf ->
- let
- binds = cvBinds sf cvValSig bs
- in
+ wlkLocalBinding seqlet `thenUgn` \ binds ->
returnUgn (LetStmt binds)
+
U_let letvdefs letvexpr ->
- wlkBinding letvdefs `thenUgn` \ binding ->
- wlkExpr letvexpr `thenUgn` \ expr ->
- getSrcLocUgn `thenUgn` \ loc ->
- getSrcFileUgn `thenUgn` \ sf ->
- let
- binds = cvBinds sf cvValSig binding
- in
+ wlkLocalBinding letvdefs `thenUgn` \ binds ->
+ wlkExpr letvexpr `thenUgn` \ expr ->
+ getSrcLocUgn `thenUgn` \ loc ->
returnUgn (GuardStmt (HsLet binds expr) loc)
\end{code}
wlkPat as_pat `thenUgn` \ pat ->
returnUgn (AsPatIn var pat)
+ U_restr pat ty ->
+ wlkPat pat `thenUgn` \ pat' ->
+ wlkHsType ty `thenUgn` \ ty' ->
+ returnUgn (SigPatIn pat' ty')
+
U_lazyp lazyp -> -- irrefutable ("twiddle") pattern
wlkPat lazyp `thenUgn` \ pat ->
returnUgn (LazyPatIn pat)
U_ident nn -> -- simple identifier
wlkVarId nn `thenUgn` \ n ->
returnUgn (
- case rdrNameOcc n of
- VarOcc occ | isLexConId occ -> ConPatIn n []
- other -> VarPatIn n
+ if isConOcc (rdrNameOcc n) then
+ ConPatIn n []
+ else
+ VarPatIn n
)
U_ap l r -> -- "application": there's a list of patterns lurking here!
%************************************************************************
\begin{code}
+wlkLocalBinding bind
+ = wlkBinding bind `thenUgn` \ bind' ->
+ getSrcFileUgn `thenUgn` \ sf ->
+ returnUgn (cvBinds sf cvValSig bind')
+
wlkBinding :: U_binding -> UgnM RdrBinding
wlkBinding binding
wlkBinding b `thenUgn` \ binding2 ->
returnUgn (RdrAndBindings binding1 binding2)
+ -- fixity declaration
+ U_fixd op dir_n prec srcline ->
+ let
+ dir = case dir_n of
+ (-1) -> InfixL
+ 0 -> InfixN
+ 1 -> InfixR
+ in
+ wlkVarId op `thenUgn` \ op ->
+ mkSrcLocUgn srcline $ \ src_loc ->
+ returnUgn (RdrSig (FixSig (FixitySig op (Fixity prec dir) src_loc)))
+
+
-- "data" declaration
U_tbind tctxt ttype tcons tderivs srcline ->
mkSrcLocUgn srcline $ \ src_loc ->
wlkConAndTyVars ttype `thenUgn` \ (tycon, tyvars) ->
wlkList rdConDecl tcons `thenUgn` \ cons ->
wlkDerivings tderivs `thenUgn` \ derivings ->
- returnUgn (RdrTyDecl (TyData DataType ctxt tycon tyvars cons derivings noDataPragmas src_loc))
+ returnUgn (RdrTyClDecl (TyData DataType ctxt tycon tyvars cons derivings noDataPragmas src_loc))
-- "newtype" declaration
U_ntbind ntctxt nttype ntcon ntderivs srcline ->
wlkConAndTyVars nttype `thenUgn` \ (tycon, tyvars) ->
wlkList rdConDecl ntcon `thenUgn` \ cons ->
wlkDerivings ntderivs `thenUgn` \ derivings ->
- returnUgn (RdrTyDecl (TyData NewType ctxt tycon tyvars cons derivings noDataPragmas src_loc))
+ returnUgn (RdrTyClDecl (TyData NewType ctxt tycon tyvars cons derivings noDataPragmas src_loc))
-- "type" declaration
U_nbind nbindid nbindas srcline ->
mkSrcLocUgn srcline $ \ src_loc ->
wlkConAndTyVars nbindid `thenUgn` \ (tycon, tyvars) ->
wlkHsType nbindas `thenUgn` \ expansion ->
- returnUgn (RdrTyDecl (TySynonym tycon tyvars expansion src_loc))
+ returnUgn (RdrTyClDecl (TySynonym tycon tyvars expansion src_loc))
-- function binding
- U_fbind fbindl srcline ->
+ U_fbind fbindm srcline ->
mkSrcLocUgn srcline $ \ src_loc ->
- wlkList rdMatch fbindl `thenUgn` \ matches ->
- returnUgn (RdrFunctionBinding srcline matches)
+ wlkList rdMatch fbindm `thenUgn` \ matches ->
+ returnUgn (RdrValBinding (mkRdrFunctionBinding matches src_loc))
-- pattern binding
- U_pbind pbindl srcline ->
- mkSrcLocUgn srcline $ \ src_loc ->
- wlkList rdMatch pbindl `thenUgn` \ matches ->
- returnUgn (RdrPatternBinding srcline matches)
+ U_pbind pbindl pbindr srcline ->
+ mkSrcLocUgn srcline $ \ src_loc ->
+ rdPat pbindl `thenUgn` \ pat ->
+ rdGRHSs pbindr `thenUgn` \ grhss ->
+ returnUgn (RdrValBinding (PatMonoBind pat grhss src_loc))
-- "class" declaration
U_cbind cbindc cbindid cbindw srcline ->
let
(final_methods, final_sigs) = cvMonoBindsAndSigs sf cvClassOpSig binding
in
- returnUgn (RdrClassDecl
+ returnUgn (RdrTyClDecl
(mkClassDecl ctxt clas tyvars final_sigs final_methods noClassPragmas src_loc))
-- "instance" declaration
-- "foreign" declaration
U_fobind id ty ext_name unsafe_flag cconv imp_exp srcline ->
- mkSrcLocUgn srcline $ \ src_loc ->
- wlkVarId id `thenUgn` \ h_id ->
- wlkHsType ty `thenUgn` \ h_ty ->
- wlkExtName ext_name `thenUgn` \ h_ext_name ->
- rdCallConv cconv `thenUgn` \ h_cconv ->
- rdForKind imp_exp (cvFlag unsafe_flag) `thenUgn` \ h_imp_exp ->
- returnUgn (RdrForeignDecl (ForeignDecl h_id h_imp_exp h_ty h_ext_name h_cconv src_loc))
-
- a_sig_we_hope ->
- -- signature(-like) things, including user pragmas
- wlk_sig_thing a_sig_we_hope
+ mkSrcLocUgn srcline $ \ src_loc ->
+ wlkVarId id `thenUgn` \ h_id ->
+ wlkHsType ty `thenUgn` \ h_ty ->
+ wlkExtName ext_name `thenUgn` \ h_ext_name ->
+ rdCallConv cconv `thenUgn` \ h_cconv ->
+ rdForKind imp_exp (cvFlag unsafe_flag) `thenUgn` \ h_imp_exp ->
+ returnUgn (RdrForeignDecl (ForeignDecl h_id h_imp_exp h_ty h_ext_name h_cconv src_loc))
+
+ U_sbind sbindids sbindid srcline ->
+ -- Type signature
+ mkSrcLocUgn srcline $ \ src_loc ->
+ wlkList rdVarId sbindids `thenUgn` \ vars ->
+ wlkHsSigType sbindid `thenUgn` \ poly_ty ->
+ returnUgn (foldr1 RdrAndBindings [RdrSig (Sig var poly_ty src_loc) | var <- vars])
+
+ U_vspec_uprag uvar vspec_tys srcline ->
+ -- value specialisation user-pragma
+ mkSrcLocUgn srcline $ \ src_loc ->
+ wlkVarId uvar `thenUgn` \ var ->
+ wlkList rd_ty_and_id vspec_tys `thenUgn` \ tys_and_ids ->
+ returnUgn (foldr1 RdrAndBindings [ RdrSig (SpecSig var ty using_id src_loc)
+ | (ty, using_id) <- tys_and_ids ])
+ where
+ rd_ty_and_id :: ParseTree -> UgnM (RdrNameHsType, Maybe RdrName)
+ rd_ty_and_id pt
+ = rdU_binding pt `thenUgn` \ (U_vspec_ty_and_id vspec_ty vspec_id) ->
+ wlkHsSigType vspec_ty `thenUgn` \ ty ->
+ wlkMaybe rdVarId vspec_id `thenUgn` \ id_maybe ->
+ returnUgn(ty, id_maybe)
+
+ U_ispec_uprag iclas ispec_ty srcline ->
+ -- instance specialisation user-pragma
+ mkSrcLocUgn srcline $ \ src_loc ->
+ wlkHsSigType ispec_ty `thenUgn` \ ty ->
+ returnUgn (RdrSig (SpecInstSig ty src_loc))
+
+ U_inline_uprag ivar srcline ->
+ -- value inlining user-pragma
+ mkSrcLocUgn srcline $ \ src_loc ->
+ wlkVarId ivar `thenUgn` \ var ->
+ returnUgn (RdrSig (InlineSig var src_loc))
+
+ U_noinline_uprag ivar srcline ->
+ -- No-inline pragma
+ mkSrcLocUgn srcline $ \ src_loc ->
+ wlkVarId ivar `thenUgn` \ var ->
+ returnUgn (RdrSig (NoInlineSig var src_loc))
+
+
+mkRdrFunctionBinding :: [RdrNameMatch] -> SrcLoc -> RdrNameMonoBinds
+mkRdrFunctionBinding fun_matches src_loc
+ = FunMonoBind (head fns) (head infs) matches src_loc
+ where
+ (fns, infs, matches) = unzip3 (map de_fun_match fun_matches)
+
+ de_fun_match (Match _ [ConPatIn fn pats] sig grhss) = (fn, False, Match [] pats sig grhss)
+ de_fun_match (Match _ [ConOpPatIn p1 fn _ p2] sig grhss) = (fn, True, Match [] [p1,p2] sig grhss)
+
+
+rdGRHSs :: ParseTree -> UgnM RdrNameGRHSs
+rdGRHSs pt = rdU_grhsb pt `thenUgn` wlkGRHSs
+
+wlkGRHSs :: U_grhsb -> UgnM RdrNameGRHSs
+wlkGRHSs (U_pguards rhss bind)
+ = wlkList rdGdExp rhss `thenUgn` \ gdexps ->
+ wlkLocalBinding bind `thenUgn` \ bind' ->
+ returnUgn (GRHSs gdexps bind' Nothing)
+wlkGRHSs (U_pnoguards srcline rhs bind)
+ = mkSrcLocUgn srcline $ \ src_loc ->
+ rdExpr rhs `thenUgn` \ rhs' ->
+ wlkLocalBinding bind `thenUgn` \ bind' ->
+ returnUgn (GRHSs (unguardedRHS rhs' src_loc) bind' Nothing)
+
+
+rdGdExp :: ParseTree -> UgnM RdrNameGRHS
+rdGdExp pt = rdU_gdexp pt `thenUgn` \ (U_pgdexp guards srcline rhs) ->
+ wlkQuals guards `thenUgn` \ guards' ->
+ mkSrcLocUgn srcline $ \ src_loc ->
+ wlkExpr rhs `thenUgn` \ expr' ->
+ returnUgn (GRHS (guards' ++ [ExprStmt expr' src_loc]) src_loc)
\end{code}
\begin{code}
returnUgn (Just derivs)
\end{code}
-\begin{code}
- -- type signature
-wlk_sig_thing (U_sbind sbindids sbindid srcline)
- = mkSrcLocUgn srcline $ \ src_loc ->
- wlkList rdVarId sbindids `thenUgn` \ vars ->
- wlkHsSigType sbindid `thenUgn` \ poly_ty ->
- returnUgn (foldr1 RdrAndBindings [RdrSig (Sig var poly_ty src_loc) | var <- vars])
-
- -- value specialisation user-pragma
-wlk_sig_thing (U_vspec_uprag uvar vspec_tys srcline)
- = mkSrcLocUgn srcline $ \ src_loc ->
- wlkVarId uvar `thenUgn` \ var ->
- wlkList rd_ty_and_id vspec_tys `thenUgn` \ tys_and_ids ->
- returnUgn (foldr1 RdrAndBindings [ RdrSig (SpecSig var ty using_id src_loc)
- | (ty, using_id) <- tys_and_ids ])
- where
- rd_ty_and_id :: ParseTree -> UgnM (RdrNameHsType, Maybe RdrName)
- rd_ty_and_id pt
- = rdU_binding pt `thenUgn` \ (U_vspec_ty_and_id vspec_ty vspec_id) ->
- wlkHsSigType vspec_ty `thenUgn` \ ty ->
- wlkMaybe rdVarId vspec_id `thenUgn` \ id_maybe ->
- returnUgn(ty, id_maybe)
-
- -- instance specialisation user-pragma
-wlk_sig_thing (U_ispec_uprag iclas ispec_ty srcline)
- = mkSrcLocUgn srcline $ \ src_loc ->
- wlkHsSigType ispec_ty `thenUgn` \ ty ->
- returnUgn (RdrSig (SpecInstSig ty src_loc))
-
- -- value inlining user-pragma
-wlk_sig_thing (U_inline_uprag ivar srcline)
- = mkSrcLocUgn srcline $ \ src_loc ->
- wlkVarId ivar `thenUgn` \ var ->
- returnUgn (RdrSig (InlineSig var src_loc))
-
-wlk_sig_thing (U_noinline_uprag ivar srcline)
- = mkSrcLocUgn srcline $ \ src_loc ->
- wlkVarId ivar `thenUgn` \ var ->
- returnUgn (RdrSig (NoInlineSig var src_loc))
-\end{code}
-
%************************************************************************
%* *
\subsection[wlkTypes]{Reading in types in various forms (and data constructors)}
rdHsType :: ParseTree -> UgnM RdrNameHsType
rdMonoType :: ParseTree -> UgnM RdrNameHsType
-rdHsType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkHsType ttype
-rdMonoType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkHsType ttype
+rdHsType pt = rdU_ttype pt `thenUgn` wlkHsType
+rdMonoType pt = rdU_ttype pt `thenUgn` wlkHsType
wlkHsConstrArgType ttype
-- Used for the argument types of contructors
wlkContext list = wlkList rdConAndTys list
-rdConAndTys pt
- = rdU_ttype pt `thenUgn` \ ttype ->
- wlkConAndTys ttype
+rdConAndTys pt = rdU_ttype pt `thenUgn` wlkConAndTys
wlkConAndTys ttype
= wlkHsType ttype `thenUgn` \ ty ->
\begin{code}
rdConDecl :: ParseTree -> UgnM RdrNameConDecl
-rdConDecl pt
- = rdU_constr pt `thenUgn` \ blah ->
- wlkConDecl blah
+rdConDecl pt = rdU_constr pt `thenUgn` wlkConDecl
wlkConDecl :: U_constr -> UgnM RdrNameConDecl
returnUgn (vars, ty)
-----------------
-rdBangType pt = rdU_ttype pt `thenUgn` \ ty -> wlkBangType ty
+rdBangType pt = rdU_ttype pt `thenUgn` wlkBangType
wlkBangType :: U_ttype -> UgnM (BangType RdrName)
%************************************************************************
\begin{code}
-rdMatch :: ParseTree -> UgnM RdrMatch
-
-rdMatch pt
- = rdU_pbinding pt `thenUgn` \ (U_pgrhs gpat gdexprs gbind gsrcfun srcline) ->
- mkSrcLocUgn srcline $ \ src_loc ->
- wlkPat gpat `thenUgn` \ pat ->
- wlkBinding gbind `thenUgn` \ binding ->
- wlkVarId gsrcfun `thenUgn` \ srcfun ->
- let
- wlk_guards (U_pnoguards exp)
- = wlkExpr exp `thenUgn` \ expr ->
- returnUgn (RdrMatch_NoGuard srcline srcfun pat expr binding)
-
- wlk_guards (U_pguards gs)
- = wlkList rd_gd_expr gs `thenUgn` \ gd_exps ->
- returnUgn (RdrMatch_Guards srcline srcfun pat gd_exps binding)
- in
- wlk_guards gdexprs
- where
- rd_gd_expr pt
- = rdU_pbinding pt `thenUgn` \ (U_pgdexp g e) ->
- wlkQuals g `thenUgn` \ guard ->
- wlkExpr e `thenUgn` \ expr ->
- returnUgn (guard, expr)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[rdFixOp]{Read in a fixity declaration}
-%* *
-%************************************************************************
-
-\begin{code}
-rdFixOp :: ParseTree -> UgnM RdrNameFixityDecl
-rdFixOp pt
- = rdU_tree pt `thenUgn` \ fix ->
- case fix of
- U_fixop op dir_n prec srcline -> wlkVarId op `thenUgn` \ op ->
- mkSrcLocUgn srcline $ \ src_loc ->
- returnUgn (FixityDecl op (Fixity prec dir) src_loc)
- where
- dir = case dir_n of
- (-1) -> InfixL
- 0 -> InfixN
- 1 -> InfixR
- _ -> error "ReadPrefix:rdFixOp"
+rdMatch :: ParseTree -> UgnM RdrNameMatch
+rdMatch pt = rdU_match pt `thenUgn` wlkMatch
+
+wlkMatch :: U_match -> UgnM RdrNameMatch
+wlkMatch (U_pmatch pats sig grhsb)
+ = wlkList rdPat pats `thenUgn` \ pats' ->
+ wlkMaybe rdHsType sig `thenUgn` \ maybe_ty ->
+ wlkGRHSs grhsb `thenUgn` \ grhss' ->
+ returnUgn (Match [] pats' maybe_ty grhss')
\end{code}
%************************************************************************
mkSrcLocUgn srcline $ \ src_loc ->
wlkMaybe rdU_stringId ias `thenUgn` \ maybe_as ->
wlkMaybe rd_spec ispec `thenUgn` \ maybe_spec ->
- returnUgn (ImportDecl imod (cvFlag iqual) (cvIfaceFlavour isrc) maybe_as maybe_spec src_loc)
+ returnUgn (ImportDecl (mkModuleFS imod)
+ (cvFlag iqual)
+ (cvIfaceFlavour isrc)
+ (case maybe_as of { Just m -> Just (mkModuleFS m); Nothing -> Nothing })
+ maybe_spec src_loc)
where
rd_spec pt = rdU_either pt `thenUgn` \ spec ->
case spec of
\end{code}
\begin{code}
-rdEntities pt
- = rdU_list pt `thenUgn` \ list ->
- wlkList rdEntity list
+rdEntities pt = rdU_list pt `thenUgn` wlkList rdEntity
rdEntity :: ParseTree -> UgnM (IE RdrName)
returnUgn (IEThingWith thing names)
U_entmod mod -> -- everything provided unqualified by a module
- returnUgn (IEModuleContents mod)
+ returnUgn (IEModuleContents (mkModuleFS mod))
\end{code}
import IdInfo ( ArityInfo, exactArity )
import Lex
+import RnEnv ( ifaceUnqualTC, ifaceUnqualVar, ifaceUnqualTv, ifaceQualVar, ifaceQualTC )
import RnMonad ( ImportVersion, LocalVersion, ParsedIface(..), WhatsImported(..),
RdrNamePragma, ExportItem, RdrAvailInfo, GenAvailInfo(..)
)
import Bag ( emptyBag, unitBag, snocBag )
import FiniteMap ( emptyFM, unitFM, addToFM, plusFM, bagToFM, FiniteMap )
-import Name ( OccName(..), isTCOcc, Provenance, Module,
- mkTupNameStr, mkUbxTupNameStr
+import Name ( OccName, isTCOcc, Provenance, Module,
+ varOcc, tcOcc, mkModuleFS
)
+import PrelMods ( mkTupNameStr, mkUbxTupNameStr )
+import PrelInfo ( mkTupConRdrName, mkUbxTupConRdrName )
import SrcLoc ( SrcLoc )
import Maybes
import Outputable
iface :: { ParsedIface }
-iface : '__interface' CONID INTEGER checkVersion 'where'
+iface : '__interface' mod_name INTEGER checkVersion 'where'
import_part
instance_import_part
exports_part
- fixities_part
instance_decl_part
decls_part
{ ParsedIface
- $2 -- Module name
+ $2 -- Module name
(fromInteger $3) -- Module version
(reverse $6) -- Usages
(reverse $8) -- Exports
(reverse $7) -- Instance import modules
- (reverse $9) -- Fixities
- (reverse $11) -- Decls
- (reverse $10) -- Local instances
+ (reverse $10) -- Decls
+ (reverse $9) -- Local instances
}
--------------------------------------------------------------------------
--------------------------------------------------------------------------
-fixities_part :: { [(OccName,Fixity)] }
-fixities_part : { [] }
- | fixities_part fixity_decl ';' { $2 : $1 }
-
-fixity_decl :: { (OccName,Fixity) }
-fixity_decl : 'infixl' mb_fix val_occ { ($3, Fixity $2 InfixL) }
- | 'infixr' mb_fix val_occ { ($3, Fixity $2 InfixR) }
- | 'infix' mb_fix val_occ { ($3, Fixity $2 InfixN) }
-
+fixity :: { FixityDirection }
+fixity : 'infixl' { InfixL }
+ | 'infixr' { InfixR }
+ | 'infix' { InfixN }
+
mb_fix :: { Int }
mb_fix : {-nothing-} { 9 }
| INTEGER { (fromInteger $1) }
decl : src_loc var_name '::' type maybe_idinfo
{ SigD (IfaceSig $2 $4 ($5 $2) $1) }
| src_loc 'type' tc_name tv_bndrs '=' type
- { TyD (TySynonym $3 $4 $6 $1) }
+ { TyClD (TySynonym $3 $4 $6 $1) }
| src_loc 'data' decl_context data_fs tv_bndrs constrs
- { TyD (TyData DataType $3 (Unqual (TCOcc $4)) $5 $6 Nothing noDataPragmas $1) }
+ { TyClD (TyData DataType $3 (ifaceUnqualTC $4) $5 $6 Nothing noDataPragmas $1) }
| src_loc 'newtype' decl_context tc_name tv_bndrs newtype_constr
- { TyD (TyData NewType $3 $4 $5 $6 Nothing noDataPragmas $1) }
+ { TyClD (TyData NewType $3 $4 $5 $6 Nothing noDataPragmas $1) }
| src_loc 'class' decl_context tc_name tv_bndrs csigs
- { ClD (mkClassDecl $3 $4 $5 $6 EmptyMonoBinds
+ { TyClD (mkClassDecl $3 $4 $5 $6 EmptyMonoBinds
noClassPragmas $1) }
+ | src_loc fixity mb_fix val_occ
+ { FixD (FixitySig (Unqual $4) (Fixity $3 $2) $1) }
+
maybe_idinfo :: { RdrName -> [HsIdInfo RdrName] }
maybe_idinfo : {- empty -} { \_ -> [] }
| src_loc PRAGMA { \x ->
case parseIface $2 $1 of
Succeeded (PIdInfo id_info) -> id_info
- other -> pprPanic "IdInfo parse failed"
- (ppr x)
+ Failed err -> pprPanic "IdInfo parse failed"
+ (vcat [ppr x, err])
}
-----------------------------------------------------------------------------
| constr '|' constrs1 { $1 : $3 }
constr :: { RdrNameConDecl }
-constr : src_loc ex_stuff data_fs batypes { mkConDecl (Unqual (VarOcc $3)) $2 (VanillaCon $4) $1 }
- | src_loc ex_stuff data_fs '{' fields1 '}' { mkConDecl (Unqual (VarOcc $3)) $2 (RecCon $5) $1 }
+constr : src_loc ex_stuff data_fs batypes { mkConDecl (ifaceUnqualVar $3) $2 (VanillaCon $4) $1 }
+ | src_loc ex_stuff data_fs '{' fields1 '}' { mkConDecl (ifaceUnqualVar $3) $2 (RecCon $5) $1 }
-- We use "data_fs" so as to include ()
newtype_constr :: { [RdrNameConDecl] {- Empty if handwritten abstract -} }
---------------------------------------------------------------------
mod_name :: { Module }
- : CONID { $1 }
+ : CONID { mkModuleFS $1 }
var_fs :: { FAST_STRING }
: VARID { $1 }
| commas ',' { $1 + 1 }
val_occ :: { OccName }
- : var_fs { VarOcc $1 }
- | data_fs { VarOcc $1 }
+ : var_fs { varOcc $1 }
+ | data_fs { varOcc $1 }
val_occs :: { [OccName] }
: val_occ { [$1] }
| val_occ val_occs { $1 : $2 }
entity_occ :: { OccName }
- : var_fs { VarOcc $1 }
- | data_fs { TCOcc $1 }
+ : var_fs { varOcc $1 }
+ | data_fs { tcOcc $1 }
var_name :: { RdrName }
-var_name : var_fs { Unqual (VarOcc $1) }
+var_name : var_fs { ifaceUnqualVar $1 }
qvar_name :: { RdrName }
qvar_name : var_name { $1 }
- | QVARID { lexVarQual $1 }
- | QVARSYM { lexVarQual $1 }
+ | QVARID { ifaceQualVar $1 }
+ | QVARSYM { ifaceQualVar $1 }
var_names :: { [RdrName] }
var_names : { [] }
var_names1 : var_name var_names { $1 : $2 }
data_name :: { RdrName }
- : CONID { Unqual (VarOcc $1) }
- | CONSYM { Unqual (VarOcc $1) }
- | '(' commas ')' { Unqual (VarOcc (snd (mkTupNameStr $2))) }
- | '[' ']' { Unqual (VarOcc SLIT("[]")) }
+ : CONID { ifaceUnqualVar $1 }
+ | CONSYM { ifaceUnqualVar $1 }
+ | '(' commas ')' { ifaceUnqualVar (snd (mkTupNameStr $2)) }
+ | '[' ']' { ifaceUnqualVar SLIT("[]") }
qdata_name :: { RdrName }
qdata_name : data_name { $1 }
- | QCONID { lexVarQual $1 }
- | QCONSYM { lexVarQual $1 }
+ | QCONID { ifaceQualVar $1 }
+ | QCONSYM { ifaceQualVar $1 }
qdata_names :: { [RdrName] }
qdata_names : { [] }
| qdata_name qdata_names { $1 : $2 }
tc_name :: { RdrName }
-tc_name : CONID { Unqual (TCOcc $1) }
- | CONSYM { Unqual (TCOcc $1) }
- | '(' '->' ')' { Unqual (TCOcc SLIT("->")) }
- | '(' commas ')' { Unqual (TCOcc (snd (mkTupNameStr $2))) }
- | '[' ']' { Unqual (TCOcc SLIT("[]")) }
+tc_name : CONID { ifaceUnqualTC $1 }
+ | CONSYM { ifaceUnqualTC $1 }
+ | '(' '->' ')' { ifaceUnqualTC SLIT("->") }
+ | '(' commas ')' { ifaceUnqualTC (snd (mkTupNameStr $2)) }
+ | '[' ']' { ifaceUnqualTC SLIT("[]") }
qtc_name :: { RdrName }
qtc_name : tc_name { $1 }
- | QCONID { lexTcQual $1 }
- | QCONSYM { lexTcQual $1 }
+ | QCONID { ifaceQualTC $1 }
+ | QCONSYM { ifaceQualTC $1 }
tv_name :: { RdrName }
-tv_name : VARID { Unqual (TvOcc $1) }
- | VARSYM { Unqual (TvOcc $1) {- Allow t2 as a tyvar -} }
+tv_name : VARID { ifaceUnqualTv $1 }
+ | VARSYM { ifaceUnqualTv $1 {- Allow t2 as a tyvar -} }
tv_bndr :: { HsTyVar RdrName }
tv_bndr : tv_name '::' akind { IfaceTyVar $1 $3 }
- | tv_name { UserTyVar $1 }
+ | tv_name { IfaceTyVar $1 boxedTypeKind }
tv_bndrs :: { [HsTyVar RdrName] }
: { [] }
akind :: { Kind }
: VARSYM { if $1 == SLIT("*") then
boxedTypeKind
- else if $1 == SLIT("**") then
+ else if $1 == SLIT("?") then
openTypeKind
else panic "ParseInterface: akind"
}
id_info_item :: { HsIdInfo RdrName }
id_info_item : '__A' arity_info { HsArity $2 }
| strict_info { HsStrictness $1 }
- | '__bot' { HsStrictness HsBottom }
| '__U' core_expr { HsUnfold $1 (Just $2) }
| '__U' { HsUnfold $1 Nothing }
| '__P' spec_tvs
)
import RnMonad
import RnNames ( getGlobalNames )
-import RnSource ( rnDecl )
+import RnSource ( rnIfaceDecl, rnSourceDecls )
import RnIfaces ( getImportedInstDecls, importDecl, getImportVersions, getSpecialInstModules,
getDeferredDataDecls,
mkSearchPath, getSlurpedNames, getRnStats
)
-import RnEnv ( addImplicitOccsRn, availNames )
+import RnEnv ( addImplicitOccsRn, availName, availNames, availsToNameSet, warnUnusedTopNames )
import Name ( Name, isLocallyDefined,
- NamedThing(..),
- nameModule, pprModule, pprOccName, nameOccName
+ NamedThing(..), ImportReason(..), Provenance(..),
+ nameModule, pprModule, pprOccName, nameOccName,
+ getNameProvenance
)
import NameSet
import TyCon ( TyCon )
, [Module] -- Imported modules; for profiling
))
-renameModule us this_mod@(HsModule mod_name vers exports imports fixities local_decls loc)
+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) >>=
\begin{code}
-rename this_mod@(HsModule mod_name vers exports imports fixities local_decls loc)
+rename this_mod@(HsModule mod_name vers exports imports local_decls loc)
= -- FIND THE GLOBAL NAME ENVIRONMENT
getGlobalNames this_mod `thenRn` \ maybe_stuff ->
returnRn Nothing
else
let
- Just (export_env, rn_env, explicit_info, print_unqual) = maybe_stuff
+ Just (export_env, rn_env, global_avail_env) = maybe_stuff
in
-- RENAME THE SOURCE
initRnMS rn_env mod_name SourceMode (
addImplicits mod_name `thenRn_`
- mapRn rnDecl local_decls
- ) `thenRn` \ rn_local_decls ->
+ rnSourceDecls local_decls
+ ) `thenRn` \ (rn_local_decls, fvs) ->
-- SLURP IN ALL THE NEEDED DECLARATIONS
- slurpDecls print_unqual rn_local_decls `thenRn` \ rn_all_decls ->
+ slurpDecls rn_local_decls `thenRn` \ rn_all_decls ->
-- EXIT IF ERRORS FOUND
checkErrsRn `thenRn` \ no_errs_so_far ->
getNameSupplyRn `thenRn` \ name_supply ->
-- REPORT UNUSED NAMES
- reportUnusedNames export_env explicit_info `thenRn_`
+ reportUnusedNames rn_env global_avail_env
+ export_env
+ fvs `thenRn_`
-- GENERATE THE SPECIAL-INSTANCE MODULE LIST
-- The "special instance" modules are those modules that contain instance
import_mods = [mod | ImportDecl mod _ _ _ _ _ <- imports]
renamed_module = HsModule mod_name vers
- trashed_exports trashed_imports trashed_fixities
+ trashed_exports trashed_imports
rn_all_decls
loc
in
where
trashed_exports = {-trace "rnSource:trashed_exports"-} Nothing
trashed_imports = {-trace "rnSource:trashed_imports"-} []
- trashed_fixities = []
\end{code}
@addImplicits@ forces the renamer to slurp in some things which aren't
\begin{code}
-slurpDecls print_unqual decls
+slurpDecls decls
= -- First of all, get all the compulsory decls
slurp_compulsories decls `thenRn` \ decls1 ->
returnRn (rn_data_decls ++ decls2)
where
- compulsory_mode = InterfaceMode Compulsory print_unqual
- optional_mode = InterfaceMode Optional print_unqual
+ compulsory_mode = InterfaceMode Compulsory
+ optional_mode = InterfaceMode Optional
-- The "slurp_compulsories" function is a loop that alternates
-- between slurping compulsory decls and slurping the instance
mod_name = nameModule (fst name_w_loc)
rn_iface_decl mod_name mode decl
- = initRnMS emptyRnEnv mod_name mode (rnDecl decl)
+ = initRnMS emptyRnEnv mod_name mode (rnIfaceDecl decl)
-rn_inst_decl mode (mod_name,decl) = rn_iface_decl mod_name mode (InstD decl)
-rn_data_decl mode (tycon_name,ty_decl) = rn_iface_decl mod_name mode (TyD ty_decl)
- where
- mod_name = nameModule tycon_name
+rn_inst_decl mode (mod_name,decl) = rn_iface_decl mod_name mode (InstD decl)
+rn_data_decl mode (mod_name,ty_decl) = rn_iface_decl mod_name mode (TyClD ty_decl)
\end{code}
\begin{code}
-reportUnusedNames (ExportEnv export_avails _) explicit_info
+reportUnusedNames (RnEnv gbl_env _) avail_env (ExportEnv export_avails _) mentioned_names
| not (opt_WarnUnusedBinds || opt_WarnUnusedImports)
= returnRn ()
| otherwise
- = getSlurpedNames `thenRn` \ slurped_names ->
- let
- unused_info :: FiniteMap Name HowInScope
- unused_info = foldl delListFromFM
- (delListFromFM explicit_info (nameSetToList slurped_names))
- (map availNames export_avails)
- unused_list = fmToList unused_info
-
- groups = filter wanted (equivClasses cmp unused_list)
+ = let
+ used_names = mentioned_names `unionNameSets` availsToNameSet export_avails
+
+ -- Now, a use of C implies a use of T,
+ -- if C was brought into scope by T(..) or T(C)
+ really_used_names = used_names `unionNameSets`
+ mkNameSet [ availName avail
+ | sub_name <- nameSetToList used_names,
+ let avail = case lookupNameEnv avail_env sub_name of
+ Just avail -> avail
+ Nothing -> pprTrace "r.u.n" (ppr sub_name) $
+ Avail sub_name
+ ]
+
+ defined_names = mkNameSet (concat (rdrEnvElts gbl_env))
+ defined_but_not_used = defined_names `minusNameSet` really_used_names
+
+ -- Filter out the ones only defined implicitly
+ bad_guys = filter is_explicit (nameSetToList defined_but_not_used)
+ is_explicit n = case getNameProvenance n of
+ LocalDef _ _ -> True
+ NonLocalDef (UserImport _ _ explicit) _ _ -> explicit
+ other -> False
+
+ -- Now group by whether locally defined or imported;
+ -- one group is the locally-defined ones, one group per import module
+ groups = equivClasses cmp bad_guys
where
- (name1, his1) `cmp` (name2, his2) = his1 `cmph` his2
+ name1 `cmp` name2 = getNameProvenance name1 `cmph` getNameProvenance name2
- (FromLocalDefn _) `cmph` (FromImportDecl _ _) = LT
- (FromLocalDefn _) `cmph` (FromLocalDefn _) = EQ
- (FromImportDecl m1 _) `cmph` (FromImportDecl m2 _) = m1 `compare` m2
- h1 `cmph` h2 = GT
-
- wanted ((_,FromImportDecl _ _) : _) = opt_WarnUnusedImports
- wanted ((_,FromLocalDefn _) : _) = opt_WarnUnusedImports
-
- pp_imp = sep [text "Warning: the following are unused:",
- nest 4 (vcat (map pp_group groups))]
-
- pp_group group = sep [msg <> char ':',
- nest 4 (sep (map (pprOccName . nameOccName . fst) group))]
- where
- his = case group of
- ((_,his) : _) -> his
-
- msg = case his of
- FromImportDecl m _ -> text "Imported from" <+> pprModule m
- FromLocalDefn _ -> text "Locally defined"
-
+ cmph (LocalDef _ _) (NonLocalDef _ _ _) = LT
+ cmph (LocalDef _ _) (LocalDef _ _) = EQ
+ cmph (NonLocalDef (UserImport m1 _ _) _ _)
+ (NonLocalDef (UserImport m2 _ _) _ _)
+ = m1 `compare` m2
+ cmph (NonLocalDef _ _ _) (LocalDef _ _) = GT
+ -- In-scope NonLocalDefs must have UserImport info on them
+
+ -- ToDo: report somehow on T(..) things where no constructors
+ -- are imported
in
- if null groups
- then returnRn ()
- else addWarnRn pp_imp
+ mapRn warnUnusedTopNames groups `thenRn_`
+ returnRn ()
rnStats :: [RenamedHsDecl] -> RnMG ()
rnStats all_decls
_exports_
RnBinds rnBinds;
_declarations_
-1 rnBinds _:_ _forall_ [a b] => RdrHsSyn.RdrNameHsBinds -> (RnHsSyn.RenamedHsBinds -> RnMonad.RnMS a (b, RnMonad.FreeVars)) -> RnMonad.RnMS a (b, RnMonad.FreeVars) ;;
+1 rnBinds _:_ _forall_ [a b] => RdrHsSyn.RdrNameHsBinds -> (RnHsSyn.RenamedHsBinds -> RnMonad.RnMS a (b, RnEnv.FreeVars)) -> RnMonad.RnMS a (b, RnEnv.FreeVars) ;;
import RdrHsSyn
import RnHsSyn
import RnMonad
-import RnExpr ( rnMatch, rnGRHSsAndBinds, rnPat, checkPrecMatch )
+import RnExpr ( rnMatch, rnGRHSs, rnPat, checkPrecMatch )
import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, lookupOccRn, lookupGlobalOccRn,
- isUnboundName, warnUnusedBinds
+ isUnboundName, warnUnusedBinds,
+ FreeVars, emptyFVs, plusFV, plusFVs, unitFV
)
import CmdLineOpts ( opt_WarnMissingSigs )
import Digraph ( stronglyConnComp, SCC(..) )
-import Name ( OccName(..), Name, isExportedName )
+import Name ( OccName, Name )
import NameSet
import BasicTypes ( RecFlag(..), TopLevelFlag(..) )
-import Util ( thenCmp, removeDups, panic, panic#, assertPanic )
+import Util ( thenCmp, removeDups )
import ListSetOps ( minusList )
import Bag ( bagToList )
import Outputable
contains bindings for the binders of this particular binding.
\begin{code}
-rnTopBinds :: RdrNameHsBinds -> RnMS s RenamedHsBinds
+rnTopBinds :: RdrNameHsBinds -> RnMS s (RenamedHsBinds, FreeVars)
-rnTopBinds EmptyBinds = returnRn EmptyBinds
+rnTopBinds EmptyBinds = returnRn (EmptyBinds, emptyFVs)
rnTopBinds (MonoBind bind sigs _) = rnTopMonoBinds bind sigs
-- The parser doesn't produce other forms
rnTopMonoBinds EmptyMonoBinds sigs
- = returnRn EmptyBinds
+ = returnRn (EmptyBinds, emptyFVs)
rnTopMonoBinds mbinds sigs
= mapRn lookupBndrRn binder_rdr_names `thenRn` \ binder_names ->
let
- binder_set = mkNameSet binder_names
- exported_binders = mkNameSet (filter isExportedName binder_names)
+ binder_set = mkNameSet binder_names
in
- rn_mono_binds TopLevel
- binder_set mbinds sigs `thenRn` \ (new_binds, fv_set) ->
- let
- unused_binders = binder_set `minusNameSet` (fv_set `unionNameSets` exported_binders)
- in
- warnUnusedBinds unused_binders `thenRn_`
- returnRn new_binds
+ rn_mono_binds TopLevel binder_set mbinds sigs
where
binder_rdr_names = map fst (bagToList (collectMonoBinders mbinds))
\end{code}
-- Now do the "thing inside", and deal with the free-variable calculations
thing_inside binds `thenRn` \ (result,result_fvs) ->
let
- all_fvs = result_fvs `unionNameSets` bind_fvs
- net_fvs = all_fvs `minusNameSet` binder_set
- unused_binders = binder_set `minusNameSet` all_fvs
+ all_fvs = result_fvs `plusFV` bind_fvs
+ unused_binders = nameSetToList (binder_set `minusNameSet` all_fvs)
in
warnUnusedBinds unused_binders `thenRn_`
- returnRn (result, net_fvs)
+ returnRn (result, delListFromNameSet all_fvs new_mbinders)
where
mbinders_w_srclocs = bagToList (collectMonoBinders mbinds)
\end{code}
-- which is a list of indivisible vertices so far as
-- the strongly-connected-components (SCC) analysis is concerned
renameSigs top_lev False binders sigs `thenRn` \ siglist ->
- flattenMonoBinds siglist mbinds `thenRn` \ mbinds_info ->
+ flattenMonoBinds siglist mbinds `thenRn` \ mbinds_info ->
-- Do the SCC analysis
let edges = mkEdges (mbinds_info `zip` [(0::Int)..])
final_binds = foldr1 ThenBinds (map reconstructCycle scc_result)
-- Deal with bound and free-var calculation
- rhs_fvs = unionManyNameSets [fvs | (_,fvs,_,_) <- mbinds_info]
+ rhs_fvs = plusFVs [fvs | (_,fvs,_,_) <- mbinds_info]
in
returnRn (final_binds, rhs_fvs)
\end{code}
flattenMonoBinds sigs bs2 `thenRn` \ flat2 ->
returnRn (flat1 ++ flat2)
-flattenMonoBinds sigs (PatMonoBind pat grhss_and_binds locn)
+flattenMonoBinds sigs (PatMonoBind pat grhss locn)
= pushSrcLocRn locn $
- rnPat pat `thenRn` \ pat' ->
- rnGRHSsAndBinds grhss_and_binds `thenRn` \ (grhss_and_binds', fvs) ->
+ rnPat pat `thenRn` \ (pat', pat_fvs) ->
-- Find which things are bound in this group
let
names_bound_here = mkNameSet (collectPatBinders pat')
sigs_for_me = sigsForMe (`elemNameSet` names_bound_here) sigs
- sigs_fvs = foldr sig_fv emptyNameSet sigs_for_me
+ sigs_fvs = foldr sig_fv emptyFVs sigs_for_me
+ fixity_sigs = [(name,sig) | FixSig sig@(FixitySig name _ _) <- sigs_for_me]
in
+ extendFixityEnv fixity_sigs $
+ rnGRHSs grhss `thenRn` \ (grhss', fvs) ->
returnRn
[(names_bound_here,
- fvs `unionNameSets` sigs_fvs,
- PatMonoBind pat' grhss_and_binds' locn,
+ fvs `plusFV` sigs_fvs `plusFV` pat_fvs,
+ PatMonoBind pat' grhss' locn,
sigs_for_me
)]
flattenMonoBinds sigs (FunMonoBind name inf matches locn)
- = pushSrcLocRn locn $
- mapRn (checkPrecMatch inf name) matches `thenRn_`
- lookupBndrRn name `thenRn` \ name' ->
- mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, fv_lists) ->
+ = pushSrcLocRn locn $
+ lookupBndrRn name `thenRn` \ name' ->
let
- fvs = unionManyNameSets fv_lists
sigs_for_me = sigsForMe (name' ==) sigs
- sigs_fvs = foldr sig_fv emptyNameSet sigs_for_me
+ sigs_fvs = foldr sig_fv emptyFVs sigs_for_me
+ fixity_sigs = [(name,sig) | FixSig sig@(FixitySig name _ _) <- sigs_for_me]
in
+ extendFixityEnv fixity_sigs $
+ mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, fv_lists) ->
+ mapRn (checkPrecMatch inf name') new_matches `thenRn_`
returnRn
[(unitNameSet name',
- fvs `unionNameSets` sigs_fvs,
+ plusFVs fv_lists `plusFV` sigs_fvs,
FunMonoBind name' inf new_matches locn,
sigs_for_me
)]
declaration. like @rnMonoBinds@ but without dependency analysis.
\begin{code}
-rnMethodBinds :: RdrNameMonoBinds -> RnMS s RenamedMonoBinds
+rnMethodBinds :: RdrNameMonoBinds -> RnMS s (RenamedMonoBinds, FreeVars)
-rnMethodBinds EmptyMonoBinds = returnRn EmptyMonoBinds
+rnMethodBinds EmptyMonoBinds = returnRn (EmptyMonoBinds, emptyFVs)
rnMethodBinds (AndMonoBinds mb1 mb2)
- = andRn AndMonoBinds (rnMethodBinds mb1)
- (rnMethodBinds mb2)
+ = rnMethodBinds mb1 `thenRn` \ (mb1', fvs1) ->
+ rnMethodBinds mb2 `thenRn` \ (mb2', fvs2) ->
+ returnRn (mb1' `AndMonoBinds` mb2', fvs1 `plusFV` fvs2)
rnMethodBinds (FunMonoBind name inf matches locn)
- = pushSrcLocRn locn $
- mapRn (checkPrecMatch inf name) matches `thenRn_`
+ = pushSrcLocRn locn $
- lookupGlobalOccRn name `thenRn` \ sel_name ->
+ lookupGlobalOccRn name `thenRn` \ sel_name ->
-- We use the selector name as the binder
- mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, _) ->
- returnRn (FunMonoBind sel_name inf new_matches locn)
+ mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, fvs_s) ->
+ mapRn (checkPrecMatch inf sel_name) new_matches `thenRn_`
+ returnRn (FunMonoBind sel_name inf new_matches locn, plusFVs fvs_s)
-rnMethodBinds (PatMonoBind (VarPatIn name) grhss_and_binds locn)
+rnMethodBinds (PatMonoBind (VarPatIn name) grhss locn)
= pushSrcLocRn locn $
lookupGlobalOccRn name `thenRn` \ sel_name ->
- rnGRHSsAndBinds grhss_and_binds `thenRn` \ (grhss_and_binds', _) ->
- returnRn (PatMonoBind (VarPatIn sel_name) grhss_and_binds' locn)
+ rnGRHSs grhss `thenRn` \ (grhss', fvs) ->
+ returnRn (PatMonoBind (VarPatIn sel_name) grhss' locn, fvs)
-- Can't handle method pattern-bindings which bind multiple methods.
rnMethodBinds mbind@(PatMonoBind other_pat _ locn)
= pushSrcLocRn locn $
- failWithRn EmptyMonoBinds (methodBindErr mbind)
+ failWithRn (EmptyMonoBinds, emptyFVs) (methodBindErr mbind)
\end{code}
\begin{code}
-- acct in the dependency analysis (or we get an
-- unexpected out-of-scope error)! WDP 95/07
-sig_fv (SpecSig _ _ (Just blah) _) acc = acc `unionNameSets` (unitNameSet blah)
+sig_fv (SpecSig _ _ (Just blah) _) acc = acc `plusFV` unitFV blah
sig_fv _ acc = acc
\end{code}
(b)~signatures given for things not bound here; (c)~with suitably
flaggery, that all top-level things have type signatures.
+At the moment we don't gather free-var info from the types in
+sigatures. We'd only need this if we wanted to report unused tyvars.
+
\begin{code}
renameSigs :: TopLevelFlag
-> Bool -- True <-> sigs for an instance decl
renameSig (Sig v ty src_loc)
= pushSrcLocRn src_loc $
lookupBndrRn v `thenRn` \ new_v ->
- rnHsSigType (quotes (ppr v)) ty `thenRn` \ new_ty ->
+ rnHsSigType (quotes (ppr v)) ty `thenRn` \ (new_ty,_) ->
returnRn (Sig new_v new_ty src_loc)
renameSig (SpecInstSig ty src_loc)
= pushSrcLocRn src_loc $
- rnHsSigType (text "A SPECIALISE instance pragma") ty `thenRn` \ new_ty ->
+ rnHsSigType (text "A SPECIALISE instance pragma") ty `thenRn` \ (new_ty, _) ->
returnRn (SpecInstSig new_ty src_loc)
renameSig (SpecSig v ty using src_loc)
= pushSrcLocRn src_loc $
lookupBndrRn v `thenRn` \ new_v ->
- rnHsSigType (quotes (ppr v)) ty `thenRn` \ new_ty ->
+ rnHsSigType (quotes (ppr v)) ty `thenRn` \ (new_ty,_) ->
rn_using using `thenRn` \ new_using ->
returnRn (SpecSig new_v new_ty new_using src_loc)
where
lookupBndrRn v `thenRn` \ new_v ->
returnRn (InlineSig new_v src_loc)
+renameSig (FixSig (FixitySig v fix src_loc))
+ = pushSrcLocRn src_loc $
+ lookupBndrRn v `thenRn` \ new_v ->
+ returnRn (FixSig (FixitySig new_v fix src_loc))
+
renameSig (NoInlineSig v src_loc)
= pushSrcLocRn src_loc $
lookupBndrRn v `thenRn` \ new_v ->
opt_WarnUnusedBinds, opt_WarnUnusedImports )
import HsSyn
import RdrHsSyn ( RdrName(..), RdrNameIE,
- rdrNameOcc, isQual, qual, isClassDataConRdrName
+ rdrNameOcc, isQual, qual
)
import HsTypes ( getTyVarName, replaceTyVarName )
import BasicTypes ( Fixity(..), FixityDirection(..), IfaceFlavour(..) )
import RnMonad
-import Name ( Name, OccName(..), Provenance(..), ExportFlag(..), NamedThing(..),
- occNameFlavour, getSrcLoc, occNameString,
+import Name ( Name, Provenance(..), ExportFlag(..), NamedThing(..),
+ ImportReason(..), getSrcLoc,
mkLocalName, mkGlobalName,
- nameOccName, setNameProvenance, isVarOcc,
- getNameProvenance, pprOccName, isLocalName,
- dictNamePrefix
+ nameOccName,
+ pprOccName, isLocalName, isLocallyDefined,
+ setNameProvenance, getNameProvenance, pprNameProvenance
)
import NameSet
+import OccName ( OccName, mkModuleFS,
+ mkDFunOcc, tcOcc, varOcc, tvOcc,
+ isVarOcc, occNameFlavour, occNameString
+ )
import TyCon ( TyCon )
-import TysWiredIn ( tupleTyCon, unboxedTupleTyCon,
- listTyCon, charTyCon )
import FiniteMap
import Unique ( Unique, Uniquable(..), unboundKey )
-import UniqFM ( listToUFM, plusUFM_C )
+import UniqFM ( emptyUFM, listToUFM, plusUFM_C )
import UniqSupply
import SrcLoc ( SrcLoc, noSrcLoc )
import Outputable
%*********************************************************
%* *
+\subsection{Making new rdr names}
+%* *
+%*********************************************************
+
+These functions make new RdrNames from stuff read from an interface file
+
+\begin{code}
+ifaceQualTC (m,n,hif) = Qual (mkModuleFS m) (tcOcc n) hif
+ifaceQualVar (m,n,hif) = Qual (mkModuleFS m) (varOcc n) hif
+
+ifaceUnqualTC n = Unqual (tcOcc n)
+ifaceUnqualVar n = Unqual (varOcc n)
+ifaceUnqualTv n = Unqual (tvOcc n)
+\end{code}
+
+%*********************************************************
+%* *
\subsection{Making new names}
%* *
%*********************************************************
\begin{code}
-newImportedGlobalName :: Module -> OccName
- -> IfaceFlavour
+newImportedGlobalName :: Module -> OccName -> IfaceFlavour
-> RnM s d Name
newImportedGlobalName mod occ hif
= -- First check the cache
getNameSupplyRn `thenRn` \ (us, inst_ns, cache) ->
let
key = (mod,occ)
- prov = NonLocalDef noSrcLoc hif False
+ prov = NonLocalDef ImplicitImport hif False
+ -- For in-scope things we improve the provenance in RnNames.qualifyImports
in
case lookupFM cache key of
-
+
-- A hit in the cache!
-- If it has no provenance at the moment then set its provenance
-- so that it has the right HiFlag component.
- -- (This is necessary
- -- for known-key things. For example, GHCmain.lhs imports as SOURCE
- -- Main; but Main.main is a known-key thing.)
+ -- (This is necessary for known-key things.
+ -- For example, GHCmain.lhs imports as SOURCE
+ -- Main; but Main.main is a known-key thing.)
-- Don't fiddle with the provenance if it already has one
Just name -> case getNameProvenance name of
NoProvenance -> let
setNameSupplyRn (us', inst_ns, new_cache) `thenRn_`
returnRn name
-{-
- let
- pprC ((mod,occ),name) = pprModule mod <> text "." <> pprOccName occ <+> text "--->"
- <+> ppr name
- in
- pprTrace "ng" (vcat [text "newGlobalName miss" <+> pprModule mod <+> pprOccName occ,
- brackets (sep (map pprC (fmToList cache))),
- text ""
- ]) $
--}
+
+newImportedGlobalFromRdrName (Qual mod_name occ hif)
+ = newImportedGlobalName mod_name occ hif
+
+newImportedGlobalFromRdrName (Unqual occ)
+ = -- An Unqual is allowed; interface files contain
+ -- unqualified names for locally-defined things, such as
+ -- constructors of a data type.
+ getModuleRn `thenRn ` \ mod_name ->
+ newImportedGlobalName mod_name occ HiFile
newLocallyDefinedGlobalName :: Module -> OccName
= -- First check the cache
getNameSupplyRn `thenRn` \ (us, inst_ns, cache) ->
let
- key = (mod,occ)
+ key = (mod,occ)
+ mk_prov 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 newLocallyDefinedGlobalName is used only
+ -- at binding occurrences, we may as well get the provenance
+ -- dead right first time; hence the rec_exp_fn passed in
in
case lookupFM cache key of
-- Overwrite whatever provenance is in the cache already;
-- this updates WiredIn things and known-key things,
-- which are there from the start, to LocalDef.
+ --
+ -- It also means that if there are two defns for the same thing
+ -- in a module, then each gets a separate SrcLoc
Just name -> let
- new_name = setNameProvenance name (LocalDef loc (rec_exp_fn new_name))
+ new_name = setNameProvenance name (mk_prov new_name)
new_cache = addToFM cache key new_name
in
setNameSupplyRn (us, inst_ns, new_cache) `thenRn_`
-- Miss in the cache!
-- Build a new original name, and put it in the cache
Nothing -> let
- provenance = LocalDef loc (rec_exp_fn new_name)
(us', us1) = splitUniqSupply us
uniq = uniqFromSupply us1
- new_name = mkGlobalName uniq mod occ provenance
+ new_name = mkGlobalName uniq mod occ (mk_prov new_name)
new_cache = addToFM cache key new_name
in
setNameSupplyRn (us', inst_ns, new_cache) `thenRn_`
returnRn new_name
--- newDfunName is a variant, specially for dfuns.
--- When renaming derived definitions we are in *interface* mode (because we can trip
--- over original names), but we still want to make the Dfun locally-defined.
--- So we can't use whether or not we're in source mode to decide the locally-defined question.
-newDfunName :: OccName -> OccName -> Maybe RdrName -> SrcLoc -> RnMS s Name
-newDfunName _ _ (Just n) src_loc -- Imported ones have "Just n"
- = getModuleRn `thenRn` \ mod_name ->
- newImportedGlobalName mod_name (rdrNameOcc n) HiFile {- Correct? -}
-newDfunName cl_nm tycon_nm Nothing src_loc -- Local instance decls have a "Nothing"
- = getModuleRn `thenRn` \ mod_name ->
- newInstUniq name `thenRn` \ inst_uniq ->
- let
- dfun_occ = VarOcc (dictNamePrefix _APPEND_
- name _APPEND_ _PK_(show inst_uniq))
- in
- newLocallyDefinedGlobalName mod_name dfun_occ
- (\_ -> Exported) src_loc
- where
- {-
- Dictionary names have the following form
-
- _d<class><tycon><n>
-
- where "n" is a positive number, and "tycon" is the
- name of the type constructor for which a "class"
- instance is derived.
-
- Prefixing dictionary names with their class and instance
- types improves the behaviour of the recompilation checker.
- (fewer recompilations required should an instance or type
- declaration be added to a module.)
- -}
- -- We're dropping the modids on purpose.
- tycon_nm_str = _PK_(map trHash (_UNPK_(occNameString tycon_nm)))
- cl_nm_str = _PK_(map trHash (_UNPK_(occNameString cl_nm)))
-
- trHash '#' = '_'
- trHash c = c
-
- -- give up on any type constructor that starts with a
- -- non-alphanumeric char (e.g., [] (,*)
- name
- | (_NULL_ tycon_nm_str) || not (isAlphanum (_HEAD_ (tycon_nm_str))) = cl_nm_str
- | otherwise = cl_nm_str _APPEND_ tycon_nm_str
-
-
newLocalNames :: [(RdrName,SrcLoc)] -> RnM s d [Name]
newLocalNames rdr_names
= getNameSupplyRn `thenRn` \ (us, inst_ns, cache) ->
setNameSupplyRn (us', inst_ns, cache) `thenRn_`
returnRn locals
+newDFunName cl_occ tycon_occ (Just n) src_loc -- Imported ones have "Just n"
+ = getModuleRn `thenRn` \ mod_name ->
+ newImportedGlobalName mod_name (rdrNameOcc n) HiFile {- Correct? -}
+
+newDFunName cl_occ tycon_occ Nothing src_loc -- Local instance decls have a "Nothing"
+ = getModuleRn `thenRn` \ mod_name ->
+ newInstUniq (cl_occ, tycon_occ) `thenRn` \ inst_uniq ->
+ let
+ dfun_occ = mkDFunOcc cl_occ tycon_occ inst_uniq
+ in
+ newLocallyDefinedGlobalName mod_name dfun_occ (\_ -> Exported) src_loc
+
+
-- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly
-- during compiler debugging.
mkUnboundName :: RdrName -> Name
\end{code}
\begin{code}
+-------------------------------------
bindLocatedLocalsRn :: SDoc -- Documentation string for error message
-> [(RdrName,SrcLoc)]
-> ([Name] -> RnMS s a)
newLocalNames rdr_names_w_loc `thenRn` \ names ->
let
- new_name_env = addListToFM name_env (map fst rdr_names_w_loc `zip` names)
+ new_name_env = addListToRdrEnv name_env (map fst rdr_names_w_loc `zip` names)
in
setLocalNameEnv new_name_env (enclosed_scope names)
where
check_shadow name_env (rdr_name,loc)
- = case lookupFM name_env rdr_name of
+ = case lookupRdrEnv name_env rdr_name of
Nothing -> returnRn ()
Just name -> pushSrcLocRn loc $
addWarnRn (shadowedNameWarn rdr_name)
+
+-------------------------------------
bindLocalsRn doc_str rdr_names enclosed_scope
= getSrcLocRn `thenRn` \ loc ->
bindLocatedLocalsRn (text doc_str)
(rdr_names `zip` repeat loc)
enclosed_scope
+ -- binLocalsFVRn is the same as bindLocalsRn
+ -- except that it deals with free vars
+bindLocalsFVRn doc_str rdr_names enclosed_scope
+ = bindLocalsRn doc_str rdr_names $ \ names ->
+ enclosed_scope names `thenRn` \ (thing, fvs) ->
+ returnRn (thing, delListFromNameSet fvs names)
+
+-------------------------------------
+extendTyVarEnvRn :: [HsTyVar Name] -> RnMS s a -> RnMS s a
+ -- This tiresome function is used only in rnDecl on InstDecl
+extendTyVarEnvRn tyvars enclosed_scope
+ = getLocalNameEnv `thenRn` \ env ->
+ let
+ new_env = addListToRdrEnv env [ (Unqual (getOccName name), name)
+ | tyvar <- tyvars,
+ let name = getTyVarName tyvar
+ ]
+ in
+ setLocalNameEnv new_env enclosed_scope
+
+bindTyVarsRn :: SDoc -> [HsTyVar RdrName]
+ -> ([HsTyVar Name] -> RnMS s a)
+ -> RnMS s 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 s a)
+ -> RnMS s a
+bindTyVars2Rn doc_str tyvar_names enclosed_scope
= getSrcLocRn `thenRn` \ loc ->
let
located_tyvars = [(getTyVarName tv, loc) | tv <- tyvar_names]
in
bindLocatedLocalsRn doc_str located_tyvars $ \ names ->
- enclosed_scope (zipWith replaceTyVarName tyvar_names names)
-
- -- Works in any variant of the renamer monad
+ enclosed_scope names (zipWith replaceTyVarName tyvar_names names)
+
+bindTyVarsFVRn :: SDoc -> [HsTyVar RdrName]
+ -> ([HsTyVar Name] -> RnMS s (a, FreeVars))
+ -> RnMS s (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 s (a, FreeVars))
+ -> RnMS s (a, FreeVars)
+bindTyVarsFV2Rn doc_str rdr_names enclosed_scope
+ = bindTyVars2Rn doc_str rdr_names $ \ names tyvars ->
+ enclosed_scope names tyvars `thenRn` \ (thing, fvs) ->
+ returnRn (thing, delListFromNameSet fvs names)
+
+
+-------------------------------------
checkDupOrQualNames, checkDupNames :: SDoc
-> [(RdrName, SrcLoc)]
-> RnM s d ()
+ -- Works in any variant of the renamer monad
checkDupOrQualNames doc_str rdr_names_w_loc
= -- Check for use of qualified names
-- Not found when processing an imported declaration,
-- so we create a new name for the purpose
- InterfaceMode _ _ ->
- case rdr_name of
- Qual mod_name occ hif -> newImportedGlobalName mod_name occ hif
-
- -- An Unqual is allowed; interface files contain
- -- unqualified names for locally-defined things, such as
- -- constructors of a data type.
- Unqual occ -> getModuleRn `thenRn ` \ mod_name ->
- newImportedGlobalName mod_name occ HiFile
-
+ InterfaceMode _ -> newImportedGlobalFromRdrName rdr_name
lookupBndrRn rdr_name
= lookupNameRn rdr_name `thenRn` \ maybe_name ->
- checkUnboundRn rdr_name maybe_name `thenRn` \ name ->
-
- if isLocalName name then
- returnRn name
- else
-
- ----------------------------------------------------
- -- OK, so we're at the binding site of a top-level defn
- -- Check to see whether its an imported decl
- getModeRn `thenRn` \ mode ->
- case mode of {
- SourceMode -> returnRn name ;
-
- InterfaceMode _ print_unqual_fn ->
-
- ----------------------------------------------------
- -- OK, the binding site of an *imported* defn
- -- so we can make the provenance more informative
- getSrcLocRn `thenRn` \ src_loc ->
- let
- name' = case getNameProvenance name of
- NonLocalDef _ hif _ -> setNameProvenance name
- (NonLocalDef src_loc hif (print_unqual_fn name'))
- other -> name
- in
- returnRn name'
- }
+ checkUnboundRn rdr_name maybe_name
-- Just like lookupRn except that we record the occurrence too
-- Perhaps surprisingly, even wired-in names are recorded.
-- After the type checker all occurrences are replaced by the one
-- at the binding site.
mungePrintUnqual (Qual _ _ _) name = name
-mungePrintUnqual (Unqual _) name = case new_prov of
- Nothing -> name
- Just prov' -> setNameProvenance name prov'
- where
- new_prov = case getNameProvenance name of
- NonLocalDef loc hif False -> Just (NonLocalDef loc hif True)
- other -> Nothing
+mungePrintUnqual (Unqual _) name
+ = case getNameProvenance name of
+ NonLocalDef imp hif False -> setNameProvenance name (NonLocalDef imp hif True)
+ other -> name
-- lookupImplicitOccRn takes an RdrName representing an *original* name, and
-- adds it to the occurrence pool so that it'll be loaded later. This is
addImplicitOccsRn :: [Name] -> RnMS s ()
addImplicitOccsRn names = addOccurrenceNames names
-
-charTyCon_name = getName charTyCon
-listTyCon_name = getName listTyCon
-
-tupleTyCon_name True n = getName (tupleTyCon n)
-tupleTyCon_name False n = getName (unboxedTupleTyCon n)
\end{code}
\begin{code}
-lookupFixity :: RdrName -> RnMS s Fixity
-lookupFixity rdr_name
+lookupFixity :: Name -> RnMS s Fixity
+lookupFixity name
= getFixityEnv `thenRn` \ fixity_env ->
- returnRn (lookupFixityEnv fixity_env rdr_name)
+ case lookupNameEnv fixity_env name of
+ Just (FixitySig _ fixity _) -> returnRn fixity
+ Nothing -> returnRn (Fixity 9 InfixL) -- Default case
\end{code}
-mkImportFn returns a function that takes a Name and tells whether
+mkPrintUnqualFn returns a function that takes a Name and tells whether
its unqualified name is in scope. This is put as a boolean flag in
the Name's provenance to guide whether or not to print the name qualified
in error messages.
\begin{code}
-mkImportFn :: RnEnv -> Name -> Bool
-mkImportFn (RnEnv env _)
+mkPrintUnqualFn :: GlobalRdrEnv -> Name -> Bool
+mkPrintUnqualFn env
= lookup
where
- lookup name = case lookupFM env (Unqual (nameOccName name)) of
- Just (name', _) -> name == name'
- Nothing -> False
+ lookup name = case lookupRdrEnv env (Unqual (nameOccName name)) of
+ Just [name'] -> name == name'
+ Nothing -> False
\end{code}
%************************************************************************
=============== RnEnv ================
\begin{code}
plusRnEnv (RnEnv n1 f1) (RnEnv n2 f2)
- = plusGlobalNameEnvRn n1 n2 `thenRn` \ n ->
- plusFixityEnvRn f1 f2 `thenRn` \ f ->
- returnRn (RnEnv n f)
+ = RnEnv (n1 `plusGlobalRdrEnv` n2)
+ (f1 `plusNameEnv` f2)
\end{code}
=============== NameEnv ================
\begin{code}
-plusGlobalNameEnvRn :: GlobalNameEnv -> GlobalNameEnv -> RnM s d GlobalNameEnv
-plusGlobalNameEnvRn env1 env2
- = mapRn addNameClashErrRn (conflictsFM conflicting_name env1 env2) `thenRn_`
- returnRn (env1 `plusFM` env2)
-
-addOneToGlobalNameEnv :: GlobalNameEnv -> RdrName -> (Name, HowInScope) -> RnM s d GlobalNameEnv
-addOneToGlobalNameEnv env rdr_name name
- = case lookupFM env rdr_name of
- Just name2 | conflicting_name name name2
- -> addNameClashErrRn (rdr_name, (name, name2)) `thenRn_`
- returnRn env
-
- other -> returnRn (addToFM env rdr_name name)
-
-delOneFromGlobalNameEnv :: GlobalNameEnv -> RdrName -> GlobalNameEnv
-delOneFromGlobalNameEnv env rdr_name = delFromFM env rdr_name
-
-conflicting_name :: (Name, HowInScope) -> (Name, HowInScope) -> Bool
-conflicting_name (n1, FromLocalDefn _) (n2, FromLocalDefn _) = True
-conflicting_name (n1,h1) (n2,h2) = n1 /= n2
+-- Look in global env only
+lookupGlobalNameRn :: RdrName -> RnMS s (Maybe Name)
+lookupGlobalNameRn rdr_name
+ = getNameEnvs `thenRn` \ (global_env, local_env) ->
+ lookup_global global_env rdr_name
+
+-- Look in both local and global env
+lookupNameRn :: RdrName -> RnMS s (Maybe Name)
+lookupNameRn rdr_name
+ = getNameEnvs `thenRn` \ (global_env, local_env) ->
+ case lookupRdrEnv local_env rdr_name of
+ Just name -> returnRn (Just name)
+ Nothing -> lookup_global global_env rdr_name
+
+lookup_global global_env rdr_name
+ = case lookupRdrEnv global_env rdr_name of
+ Just [name] -> returnRn (Just name)
+ Just stuff@(name:_) -> addNameClashErrRn rdr_name stuff `thenRn_`
+ returnRn (Just name)
+ Nothing -> returnRn Nothing
+
+plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv
+plusGlobalRdrEnv env1 env2 = plusFM_C combine_globals env1 env2
+
+addOneToGlobalRdrEnv :: GlobalRdrEnv -> RdrName -> Name -> GlobalRdrEnv
+addOneToGlobalRdrEnv env rdr_name name = addToFM_C combine_globals env rdr_name [name]
+
+delOneFromGlobalRdrEnv :: GlobalRdrEnv -> RdrName -> GlobalRdrEnv
+delOneFromGlobalRdrEnv env rdr_name = delFromFM env rdr_name
+
+combine_globals :: [Name] -- Old
+ -> [Name] -- New
+ -> [Name]
+combine_globals ns_old ns_new -- ns_new is often short
+ = foldr add ns_old ns_new
+ where
+ add n ns | all (no_conflict 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 user-imported thing over a non-user-imported thing
+-- and an explicitly-imported thing over an implicitly imported thing
+better_provenance n1 n2
+ = case (getNameProvenance n1, getNameProvenance n2) of
+ (NonLocalDef (UserImport _ _ True) _ _, _ ) -> True
+ (NonLocalDef (UserImport _ _ _ ) _ _, NonLocalDef ImplicitImport _ _) -> True
+ other -> False
+
+no_conflict :: Name -> Name -> Bool
+no_conflict n1 n2 | isLocallyDefined n1 && isLocallyDefined n2 = False
+ | otherwise = n1 == n2
-- We complain of a conflict if one RdrName maps to two different Names,
-- OR if one RdrName maps to the same *locally-defined* Name. The latter
-- case is to catch two separate, local definitions of the same thing.
--
-- If a module imports itself then there might be a local defn and an imported
-- defn of the same name; in this case the names will compare as equal, but
- -- will still have different HowInScope fields
-
-lookupNameEnv :: NameEnv -> RdrName -> Maybe Name
-lookupNameEnv = lookupFM
-\end{code}
-
-=============== FixityEnv ================
-\begin{code}
-plusFixityEnvRn f1 f2
- = mapRn (addErrRn.fixityClashErr) (conflictsFM bad_fix f1 f2) `thenRn_`
- returnRn (f1 `plusFM` f2)
-
-addOneToFixityEnv env rdr_name fixity = addToFM env rdr_name fixity
-
-lookupFixityEnv env rdr_name
- = case lookupFM env rdr_name of
- Just (fixity,_) -> fixity
- Nothing -> Fixity 9 InfixL -- Default case
-
-bad_fix :: (Fixity, HowInScope) -> (Fixity, HowInScope) -> Bool
-bad_fix (f1,_) (f2,_) = f1 /= f2
-
-pprFixityProvenance :: (Fixity, HowInScope) -> SDoc
-pprFixityProvenance (fixity, how_in_scope) = ppr how_in_scope
+ -- will still have different provenances
\end{code}
=============== ExportAvails ================
\begin{code}
-mkExportAvails :: Module -> Bool -> GlobalNameEnv -> [AvailInfo] -> ExportAvails
+mkEmptyExportAvails :: Module -> ExportAvails
+mkEmptyExportAvails mod_name = (unitFM mod_name [], emptyUFM)
+
+mkExportAvails :: Module -> Bool -> GlobalRdrEnv -> [AvailInfo] -> ExportAvails
mkExportAvails mod_name unqual_imp name_env avails
= (mod_avail_env, entity_avail_env)
where
unqual_in_scope n = Unqual (nameOccName n) `elemFM` name_env
entity_avail_env = listToUFM [ (name,avail) | avail <- avails,
- name <- availEntityNames avail]
+ name <- availNames avail]
plusExportAvails :: ExportAvails -> ExportAvails -> ExportAvails
plusExportAvails (m1, e1) (m2, e2)
= (plusFM_C (++) m1 m2, plusUFM_C plusAvail e1 e2)
+ -- ToDo: wasteful: we do this once for each constructor!
\end{code}
availNames (Avail n) = [n]
availNames (AvailTC n ns) = ns
--- availEntityNames is used to extract the names that can appear on their own in
--- an export or import list. For class decls, class methods can appear on their
--- own, thus import A( op )
--- but constructors cannot; thus
--- import B( T )
--- means import type T from B, not constructor T.
-
-availEntityNames :: AvailInfo -> [Name]
-availEntityNames NotAvailable = []
-availEntityNames (Avail n) = [n]
-availEntityNames (AvailTC n ns) = n : filter (isVarOcc . nameOccName) ns
-
filterAvail :: RdrNameIE -- Wanted
-> AvailInfo -- Available
-> AvailInfo -- Resulting available;
%************************************************************************
%* *
-\subsection{Finite map utilities}
+\subsection{Free variable manipulation}
%* *
%************************************************************************
-
-Generally useful function on finite maps to check for overlap.
-
\begin{code}
-conflictsFM :: Ord a
- => (b->b->Bool) -- False <=> no conflict; you can pick either
- -> FiniteMap a b -> FiniteMap a b
- -> [(a,(b,b))]
-conflictsFM bad fm1 fm2
- = filter (\(a,(b1,b2)) -> bad b1 b2)
- (fmToList (intersectFM_C (\b1 b2 -> (b1,b2)) fm1 fm2))
-
-conflictFM :: Ord a
- => (b->b->Bool)
- -> FiniteMap a b -> a -> b
- -> Maybe (a,(b,b))
-conflictFM bad fm key elt
- = case lookupFM fm key of
- Just elt' | bad elt elt' -> Just (key,(elt,elt'))
- other -> Nothing
+type FreeVars = NameSet
+
+plusFV :: FreeVars -> FreeVars -> FreeVars
+addOneFV :: FreeVars -> Name -> FreeVars
+unitFV :: Name -> FreeVars
+emptyFVs :: FreeVars
+plusFVs :: [FreeVars] -> FreeVars
+
+plusFV = unionNameSets
+addOneFV = addOneToNameSet
+unitFV = unitNameSet
+emptyFVs = emptyNameSet
+plusFVs = unionManyNameSets
\end{code}
\begin{code}
-warnUnusedBinds, warnUnusedMatches, warnUnusedImports :: NameSet -> RnM s d ()
+warnUnusedBinds, warnUnusedMatches :: [Name] -> RnM s d ()
-warnUnusedBinds names
- | opt_WarnUnusedBinds = warnUnusedNames names
- | otherwise = returnRn ()
+warnUnusedTopNames ns
+ | not opt_WarnUnusedBinds && not opt_WarnUnusedImports
+ = returnRn () -- Don't force ns unless necessary
+
+warnUnusedTopNames (n:ns)
+ | is_local && opt_WarnUnusedBinds = warnUnusedNames ns
+ | not is_local && opt_WarnUnusedImports = warnUnusedNames ns
+ where
+ is_local = isLocallyDefined n
+
+warnUnusedTopName other = returnRn ()
+
+warnUnusedBinds ns
+ | not opt_WarnUnusedBinds = returnRn ()
+ | otherwise = warnUnusedNames ns
warnUnusedMatches names
| opt_WarnUnusedMatches = warnUnusedNames names
- | otherwise = returnRn ()
+ | otherwise = returnRn ()
-warnUnusedImports names
- | opt_WarnUnusedImports = warnUnusedNames names
- | otherwise = returnRn ()
+warnUnusedNames :: [Name] -> RnM s d ()
+warnUnusedNames []
+ = returnRn ()
-warnUnusedNames :: NameSet -> RnM s d ()
warnUnusedNames names
- = mapRn warn (nameSetToList names) `thenRn_`
- returnRn ()
+ = addWarnRn $
+ sep [text "The following names are unused:",
+ nest 4 (vcat (map pp names))]
where
- warn name = pushSrcLocRn (getSrcLoc name) $
- addWarnRn (unusedNameWarn name)
+ pp n = ppr n <> comma <+> pprNameProvenance n
-unusedNameWarn name = quotes (ppr name) <+> ptext SLIT("is bound but not used")
-addNameClashErrRn (rdr_name, ((_,how_in_scope1), (_, how_in_scope2)))
+addNameClashErrRn rdr_name names
+{- NO LONGER NEEDED WITH LAZY NAME-CLASH REPORTING
| isClassDataConRdrName rdr_name
-- Nasty hack to prevent error messages complain about conflicts for ":C",
-- where "C" is a class. There'll be a message about C, and :C isn't
= returnRn ()
| otherwise
- = addErrRn (hang (hsep [ptext SLIT("Conflicting definitions for"), quotes (ppr rdr_name)])
- 4 (vcat [ppr how_in_scope1,
- ppr how_in_scope2]))
+-}
+
+ = addErrRn (vcat [ptext SLIT("Ambiguous occurrence") <+> quotes (ppr rdr_name),
+ ptext SLIT("It could refer to:") <+> vcat (map mk_ref names)])
+ where
+ mk_ref name = ppr name <> colon <+> pprNameProvenance name
fixityClashErr (rdr_name, ((_,how_in_scope1), (_, how_in_scope2)))
= hang (hsep [ptext SLIT("Conflicting fixities for"), quotes (ppr rdr_name)])
Basically dependency analysis.
-Handles @Match@, @GRHSsAndBinds@, @HsExpr@, and @Qualifier@ datatypes. In
+Handles @Match@, @GRHSs@, @HsExpr@, and @Qualifier@ datatypes. In
general, all of these functions return a renamed thing, and a set of
free variables.
\begin{code}
module RnExpr (
- rnMatch, rnGRHSsAndBinds, rnPat,
+ rnMatch, rnGRHSs, rnPat,
checkPrecMatch
) where
#include "HsVersions.h"
import {-# SOURCE #-} RnBinds ( rnBinds )
-import {-# SOURCE #-} RnSource ( rnHsSigType )
+import {-# SOURCE #-} RnSource ( rnHsSigType, rnHsType )
import HsSyn
import RdrHsSyn
import Name ( nameUnique, isLocallyDefined, NamedThing(..) )
import NameSet
import UniqFM ( isNullUFM )
+import FiniteMap ( elemFM )
import UniqSet ( emptyUniqSet, UniqSet )
import Unique ( assertIdKey )
import Util ( removeDups )
+import ListSetOps ( unionLists )
+import Maybes ( maybeToBool )
import Outputable
\end{code}
*********************************************************
\begin{code}
-rnPat :: RdrNamePat -> RnMS s RenamedPat
+rnPat :: RdrNamePat -> RnMS s (RenamedPat, FreeVars)
-rnPat WildPatIn = returnRn WildPatIn
+rnPat WildPatIn = returnRn (WildPatIn, emptyFVs)
rnPat (VarPatIn name)
= lookupBndrRn name `thenRn` \ vname ->
- returnRn (VarPatIn vname)
+ returnRn (VarPatIn vname, emptyFVs)
+rnPat (SigPatIn pat ty)
+ | opt_GlasgowExts
+ = rnPat pat `thenRn` \ (pat', fvs1) ->
+ rnHsType doc ty `thenRn` \ (ty', fvs2) ->
+ returnRn (SigPatIn pat' ty', fvs1 `plusFV` fvs2)
+
+ | otherwise
+ = addErrRn (patSigErr ty) `thenRn_`
+ rnPat pat
+ where
+ doc = text "a pattern type-signature"
+
rnPat (LitPatIn lit)
= litOccurrence lit `thenRn_`
lookupImplicitOccRn eqClass_RDR `thenRn_` -- Needed to find equality on pattern
- returnRn (LitPatIn lit)
+ returnRn (LitPatIn lit, emptyFVs)
rnPat (LazyPatIn pat)
- = rnPat pat `thenRn` \ pat' ->
- returnRn (LazyPatIn pat')
+ = rnPat pat `thenRn` \ (pat', fvs) ->
+ returnRn (LazyPatIn pat', fvs)
rnPat (AsPatIn name pat)
- = rnPat pat `thenRn` \ pat' ->
+ = rnPat pat `thenRn` \ (pat', fvs) ->
lookupBndrRn name `thenRn` \ vname ->
- returnRn (AsPatIn vname pat')
+ returnRn (AsPatIn vname pat', fvs)
rnPat (ConPatIn con pats)
- = lookupOccRn con `thenRn` \ con' ->
- mapRn rnPat pats `thenRn` \ patslist ->
- returnRn (ConPatIn con' patslist)
+ = lookupOccRn con `thenRn` \ con' ->
+ mapAndUnzipRn rnPat pats `thenRn` \ (patslist, fvs_s) ->
+ returnRn (ConPatIn con' patslist, plusFVs fvs_s `addOneFV` con')
rnPat (ConOpPatIn pat1 con _ pat2)
- = rnPat pat1 `thenRn` \ pat1' ->
+ = rnPat pat1 `thenRn` \ (pat1', fvs1) ->
lookupOccRn con `thenRn` \ con' ->
- lookupFixity con `thenRn` \ fixity ->
- rnPat pat2 `thenRn` \ pat2' ->
- mkConOpPatRn pat1' con' fixity pat2'
+ lookupFixity con' `thenRn` \ fixity ->
+ rnPat pat2 `thenRn` \ (pat2', fvs2) ->
+ mkConOpPatRn pat1' con' fixity pat2' `thenRn` \ pat' ->
+ returnRn (pat', fvs1 `plusFV` fvs2 `addOneFV` con')
-- Negated patters can only be literals, and they are dealt with
-- by negating the literal at compile time, not by using the negation
rnPat neg@(NegPatIn pat)
= checkRn (valid_neg_pat pat) (negPatErr neg)
`thenRn_`
- rnPat pat `thenRn` \ pat' ->
- returnRn (NegPatIn pat')
+ rnPat pat `thenRn` \ (pat', fvs) ->
+ returnRn (NegPatIn pat', fvs)
where
valid_neg_pat (LitPatIn (HsInt _)) = True
valid_neg_pat (LitPatIn (HsFrac _)) = True
valid_neg_pat _ = False
rnPat (ParPatIn pat)
- = rnPat pat `thenRn` \ pat' ->
- returnRn (ParPatIn pat')
+ = rnPat pat `thenRn` \ (pat', fvs) ->
+ returnRn (ParPatIn pat', fvs)
rnPat (NPlusKPatIn name lit)
= litOccurrence lit `thenRn_`
lookupImplicitOccRn ordClass_RDR `thenRn_`
lookupBndrRn name `thenRn` \ name' ->
- returnRn (NPlusKPatIn name' lit)
+ returnRn (NPlusKPatIn name' lit, emptyFVs)
rnPat (ListPatIn pats)
= addImplicitOccRn listTyCon_name `thenRn_`
- mapRn rnPat pats `thenRn` \ patslist ->
- returnRn (ListPatIn patslist)
+ mapAndUnzipRn rnPat pats `thenRn` \ (patslist, fvs_s) ->
+ returnRn (ListPatIn patslist, plusFVs fvs_s)
rnPat (TuplePatIn pats boxed)
= addImplicitOccRn (tupleTyCon_name boxed (length pats)) `thenRn_`
- mapRn rnPat pats `thenRn` \ patslist ->
- returnRn (TuplePatIn patslist boxed)
+ mapAndUnzipRn rnPat pats `thenRn` \ (patslist, fvs_s) ->
+ returnRn (TuplePatIn patslist boxed, plusFVs fvs_s)
rnPat (RecPatIn con rpats)
= lookupOccRn con `thenRn` \ con' ->
- rnRpats rpats `thenRn` \ rpats' ->
- returnRn (RecPatIn con' rpats')
+ rnRpats rpats `thenRn` \ (rpats', fvs) ->
+ returnRn (RecPatIn con' rpats', fvs `addOneFV` con')
\end{code}
************************************************************************
************************************************************************
\begin{code}
-rnMatch, rnMatch1 :: RdrNameMatch -> RnMS s (RenamedMatch, FreeVars)
+rnMatch :: RdrNameMatch -> RnMS s (RenamedMatch, FreeVars)
+
+rnMatch match@(Match _ pats maybe_rhs_sig grhss)
+ = pushSrcLocRn (getMatchLoc match) $
--- The only tricky bit here is that we want to do a single
--- bindLocalsRn for all the matches together, so that we spot
--- the repeated variable in
--- f x x = 1
+ -- Find the universally quantified type variables
+ -- in the pattern type signatures
+ getLocalNameEnv `thenRn` \ name_env ->
+ let
+ tyvars_in_sigs = rhs_sig_tyvars `unionLists` tyvars_in_pats
+ rhs_sig_tyvars = case maybe_rhs_sig of
+ Nothing -> []
+ Just ty -> extractHsTyVars ty
+ tyvars_in_pats = extractPatsTyVars pats
+ forall_tyvars = filter (not . (`elemFM` name_env)) tyvars_in_sigs
+ doc = text "a pattern type-signature"
+ in
+ bindTyVarsFVRn doc (map UserTyVar forall_tyvars) $ \ sig_tyvars ->
+
+ -- Note that we do a single bindLocalsRn for all the
+ -- matches together, so that we spot the repeated variable in
+ -- f x x = 1
+ bindLocalsFVRn "pattern" (collectPatsBinders pats) $ \ new_binders ->
+
+ mapAndUnzipRn rnPat pats `thenRn` \ (pats', pat_fvs_s) ->
+ rnGRHSs grhss `thenRn` \ (grhss', grhss_fvs) ->
+ (case maybe_rhs_sig of
+ Nothing -> returnRn (Nothing, emptyFVs)
+ Just ty | opt_GlasgowExts -> rnHsType doc ty `thenRn` \ (ty', ty_fvs) ->
+ returnRn (Just ty', ty_fvs)
+ | otherwise -> addErrRn (patSigErr ty) `thenRn_`
+ returnRn (Nothing, emptyFVs)
+ ) `thenRn` \ (maybe_rhs_sig', ty_fvs) ->
-rnMatch match
- = pushSrcLocRn (getMatchLoc match) $
- bindLocalsRn "pattern" (get_binders match) $ \ new_binders ->
- rnMatch1 match `thenRn` \ (match', fvs) ->
let
binder_set = mkNameSet new_binders
- unused_binders = binder_set `minusNameSet` fvs
- net_fvs = fvs `minusNameSet` binder_set
+ unused_binders = nameSetToList (binder_set `minusNameSet` grhss_fvs)
+ all_fvs = grhss_fvs `plusFV` plusFVs pat_fvs_s `plusFV` ty_fvs
in
warnUnusedMatches unused_binders `thenRn_`
- returnRn (match', net_fvs)
- where
- get_binders (GRHSMatch _) = []
- get_binders (PatMatch pat match) = collectPatBinders pat ++ get_binders match
-
-rnMatch1 (PatMatch pat match)
- = rnPat pat `thenRn` \ pat' ->
- rnMatch1 match `thenRn` \ (match', fvs) ->
- returnRn (PatMatch pat' match', fvs)
-
-rnMatch1 (GRHSMatch grhss_and_binds)
- = rnGRHSsAndBinds grhss_and_binds `thenRn` \ (grhss_and_binds', fvs) ->
- returnRn (GRHSMatch grhss_and_binds', fvs)
+ returnRn (Match sig_tyvars pats' maybe_rhs_sig' grhss', all_fvs)
+ -- The bindLocals and bindTyVars will remove the bound FVs
\end{code}
%************************************************************************
%* *
-\subsubsection{Guarded right-hand sides (GRHSsAndBinds)}
+\subsubsection{Guarded right-hand sides (GRHSs)}
%* *
%************************************************************************
\begin{code}
-rnGRHSsAndBinds :: RdrNameGRHSsAndBinds -> RnMS s (RenamedGRHSsAndBinds, FreeVars)
-
-rnGRHSsAndBinds (GRHSsAndBindsIn grhss binds)
- = rnBinds binds $ \ binds' ->
- rnGRHSs grhss `thenRn` \ (grhss', fvGRHS) ->
- returnRn (GRHSsAndBindsIn grhss' binds', fvGRHS)
- where
- rnGRHSs [] = returnRn ([], emptyNameSet)
+rnGRHSs :: RdrNameGRHSs -> RnMS s (RenamedGRHSs, FreeVars)
- rnGRHSs (grhs:grhss)
- = rnGRHS grhs `thenRn` \ (grhs', fvs) ->
- rnGRHSs grhss `thenRn` \ (grhss', fvss) ->
- returnRn (grhs' : grhss', fvs `unionNameSets` fvss)
+rnGRHSs (GRHSs grhss binds maybe_ty)
+ = ASSERT( not (maybeToBool maybe_ty) )
+ rnBinds binds $ \ binds' ->
+ mapAndUnzipRn rnGRHS grhss `thenRn` \ (grhss', fvGRHSs) ->
+ returnRn (GRHSs grhss' binds' Nothing, plusFVs fvGRHSs)
- rnGRHS (GRHS guarded locn)
- = pushSrcLocRn locn $
- (if not (opt_GlasgowExts || is_standard_guard guarded) then
+rnGRHS (GRHS guarded locn)
+ = pushSrcLocRn locn $
+ (if not (opt_GlasgowExts || is_standard_guard guarded) then
addWarnRn (nonStdGuardErr guarded)
- else
+ else
returnRn ()
- ) `thenRn_`
-
- rnStmts rnExpr guarded `thenRn` \ (guarded', fvs) ->
- returnRn (GRHS guarded' locn, fvs)
+ ) `thenRn_`
+ rnStmts rnExpr guarded `thenRn` \ (guarded', fvs) ->
+ returnRn (GRHS guarded' locn, fvs)
+ where
-- Standard Haskell 1.4 guards are just a single boolean
-- expression, rather than a list of qualifiers as in the
-- Glasgow extension
-- Now we do a "seq" on the free vars because typically it's small
-- or empty, especially in very long lists of constants
let
- acc' = acc `unionNameSets` fvExpr
+ acc' = acc `plusFV` fvExpr
in
(grubby_seqNameSet acc' rnExprs') exprs acc' `thenRn` \ (exprs', fvExprs) ->
returnRn (expr':exprs', fvExprs)
rnExpr (HsApp fun arg)
= rnExpr fun `thenRn` \ (fun',fvFun) ->
rnExpr arg `thenRn` \ (arg',fvArg) ->
- returnRn (HsApp fun' arg', fvFun `unionNameSets` fvArg)
+ returnRn (HsApp fun' arg', fvFun `plusFV` fvArg)
-rnExpr (OpApp e1 op@(HsVar op_name) _ e2)
+rnExpr (OpApp e1 op _ e2)
= rnExpr e1 `thenRn` \ (e1', fv_e1) ->
rnExpr e2 `thenRn` \ (e2', fv_e2) ->
- rnExpr op `thenRn` \ (op', fv_op) ->
+ rnExpr op `thenRn` \ (op'@(HsVar op_name), fv_op) ->
-- Deal with fixity
-- When renaming code synthesised from "deriving" declarations
lookupFixity op_name `thenRn` \ fixity ->
getModeRn `thenRn` \ mode ->
(case mode of
- SourceMode -> mkOpAppRn e1' op' fixity e2'
- InterfaceMode _ _ -> returnRn (OpApp e1' op' fixity e2')
+ SourceMode -> mkOpAppRn e1' op' fixity e2'
+ InterfaceMode _ -> returnRn (OpApp e1' op' fixity e2')
) `thenRn` \ final_e ->
returnRn (final_e,
- fv_e1 `unionNameSets` fv_op `unionNameSets` fv_e2)
+ fv_e1 `plusFV` fv_op `plusFV` fv_e2)
rnExpr (NegApp e n)
= rnExpr e `thenRn` \ (e', fv_e) ->
rnExpr (SectionL expr op)
= rnExpr expr `thenRn` \ (expr', fvs_expr) ->
rnExpr op `thenRn` \ (op', fvs_op) ->
- returnRn (SectionL expr' op', fvs_op `unionNameSets` fvs_expr)
+ returnRn (SectionL expr' op', fvs_op `plusFV` fvs_expr)
rnExpr (SectionR op expr)
= rnExpr op `thenRn` \ (op', fvs_op) ->
rnExpr expr `thenRn` \ (expr', fvs_expr) ->
- returnRn (SectionR op' expr', fvs_op `unionNameSets` fvs_expr)
+ returnRn (SectionR op' expr', fvs_op `plusFV` fvs_expr)
rnExpr (CCall fun args may_gc is_casm fake_result_ty)
-- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls
= pushSrcLocRn src_loc $
rnExpr expr `thenRn` \ (new_expr, e_fvs) ->
mapAndUnzipRn rnMatch ms `thenRn` \ (new_ms, ms_fvs) ->
- returnRn (HsCase new_expr new_ms src_loc, unionManyNameSets (e_fvs : ms_fvs))
+ returnRn (HsCase new_expr new_ms src_loc, plusFVs (e_fvs : ms_fvs))
rnExpr (HsLet binds expr)
= rnBinds binds $ \ binds' ->
rnExpr (RecordUpd expr rbinds)
= rnExpr expr `thenRn` \ (expr', fvExpr) ->
rnRbinds "update" rbinds `thenRn` \ (rbinds', fvRbinds) ->
- returnRn (RecordUpd expr' rbinds', fvExpr `unionNameSets` fvRbinds)
+ returnRn (RecordUpd expr' rbinds', fvExpr `plusFV` fvRbinds)
rnExpr (ExprWithTySig expr pty)
= rnExpr expr `thenRn` \ (expr', fvExpr) ->
- rnHsSigType (text "an expression") pty `thenRn` \ pty' ->
- returnRn (ExprWithTySig expr' pty', fvExpr)
+ rnHsSigType (text "an expression") pty `thenRn` \ (pty', fvTy) ->
+ returnRn (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy)
rnExpr (HsIf p b1 b2 src_loc)
= pushSrcLocRn src_loc $
rnExpr p `thenRn` \ (p', fvP) ->
rnExpr b1 `thenRn` \ (b1', fvB1) ->
rnExpr b2 `thenRn` \ (b2', fvB2) ->
- returnRn (HsIf p' b1' b2' src_loc, unionManyNameSets [fvP, fvB1, fvB2])
+ returnRn (HsIf p' b1' b2' src_loc, plusFVs [fvP, fvB1, fvB2])
rnExpr (ArithSeqIn seq)
= lookupImplicitOccRn enumClass_RDR `thenRn_`
rn_seq (FromThen expr1 expr2)
= rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
- returnRn (FromThen expr1' expr2', fvExpr1 `unionNameSets` fvExpr2)
+ returnRn (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
rn_seq (FromTo expr1 expr2)
= rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
- returnRn (FromTo expr1' expr2', fvExpr1 `unionNameSets` fvExpr2)
+ returnRn (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
rn_seq (FromThenTo expr1 expr2 expr3)
= rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
rnExpr expr3 `thenRn` \ (expr3', fvExpr3) ->
returnRn (FromThenTo expr1' expr2' expr3',
- unionManyNameSets [fvExpr1, fvExpr2, fvExpr3])
+ plusFVs [fvExpr1, fvExpr2, fvExpr3])
\end{code}
%************************************************************************
rnRbinds str rbinds
= mapRn field_dup_err dup_fields `thenRn_`
mapAndUnzipRn rn_rbind rbinds `thenRn` \ (rbinds', fvRbind_s) ->
- returnRn (rbinds', unionManyNameSets fvRbind_s)
+ returnRn (rbinds', plusFVs fvRbind_s)
where
(_, dup_fields) = removeDups compare [ f | (f,_,_) <- rbinds ]
rnRpats rpats
= mapRn field_dup_err dup_fields `thenRn_`
- mapRn rn_rpat rpats
+ mapAndUnzipRn rn_rpat rpats `thenRn` \ (rpats', fvs_s) ->
+ returnRn (rpats', plusFVs fvs_s)
where
(_, dup_fields) = removeDups compare [ f | (f,_,_) <- rpats ]
rn_rpat (field, pat, pun)
= lookupGlobalOccRn field `thenRn` \ fieldname ->
- rnPat pat `thenRn` \ pat' ->
- returnRn (fieldname, pat', pun)
+ rnPat pat `thenRn` \ (pat', fvs) ->
+ returnRn ((fieldname, pat', pun), fvs)
\end{code}
%************************************************************************
rnStmt rn_expr (BindStmt pat expr src_loc) thing_inside
= pushSrcLocRn src_loc $
rn_expr expr `thenRn` \ (expr', fv_expr) ->
- bindLocalsRn "pattern in do binding" binders $ \ new_binders ->
- rnPat pat `thenRn` \ pat' ->
-
+ bindLocalsFVRn "pattern in do binding" binders $ \ new_binders ->
+ rnPat pat `thenRn` \ (pat', fv_pat) ->
thing_inside (BindStmt pat' expr' src_loc) `thenRn` \ (result, fvs) ->
- returnRn (result, fv_expr `unionNameSets` (fvs `minusNameSet` mkNameSet new_binders))
+ returnRn (result, fv_expr `plusFV` fvs `plusFV` fv_pat)
where
binders = collectPatBinders pat
= pushSrcLocRn src_loc $
rn_expr expr `thenRn` \ (expr', fv_expr) ->
thing_inside (ExprStmt expr' src_loc) `thenRn` \ (result, fvs) ->
- returnRn (result, fv_expr `unionNameSets` fvs)
+ returnRn (result, fv_expr `plusFV` fvs)
rnStmt rn_expr (GuardStmt expr src_loc) thing_inside
= pushSrcLocRn src_loc $
rn_expr expr `thenRn` \ (expr', fv_expr) ->
thing_inside (GuardStmt expr' src_loc) `thenRn` \ (result, fvs) ->
- returnRn (result, fv_expr `unionNameSets` fvs)
+ returnRn (result, fv_expr `plusFV` fvs)
rnStmt rn_expr (ReturnStmt expr) thing_inside
= rn_expr expr `thenRn` \ (expr', fv_expr) ->
thing_inside (ReturnStmt expr') `thenRn` \ (result, fvs) ->
- returnRn (result, fv_expr `unionNameSets` fvs)
+ returnRn (result, fv_expr `plusFV` fvs)
rnStmt rn_expr (LetStmt binds) thing_inside
= rnBinds binds $ \ binds' ->
mkOpAppRn e1 op fix e2 -- Default case, no rearrangment
= ASSERT( if right_op_ok fix e2 then True
- else pprPanic "mkOpAppRn" (vcat [ppr e1, text "---", ppr op, text "---", ppr fix, text "---", ppr e2])
+ else pprPanic "mkOpAppRn" (vcat [ppr e1, text "---", ppr op,
+ text "---", ppr fix, text "---", ppr e2])
)
returnRn (OpApp e1 op fix e2)
\end{code}
\begin{code}
-checkPrecMatch :: Bool -> RdrName -> RdrNameMatch -> RnMS s ()
+checkPrecMatch :: Bool -> Name -> RenamedMatch -> RnMS s ()
checkPrecMatch False fn match
= returnRn ()
-checkPrecMatch True op (PatMatch p1 (PatMatch p2 (GRHSMatch _)))
+checkPrecMatch True op (Match _ [p1,p2] _ _)
= checkPrec op p1 False `thenRn_`
checkPrec op p2 True
-checkPrecMatch True op _
- = panic "checkPrecMatch"
+checkPrecMatch True op _ = panic "checkPrecMatch"
checkPrec op (ConOpPatIn _ op1 _ _) right
= lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
= hang (ptext SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)"))
4 (ppr guard)
+patSigErr ty
+ = hang (ptext SLIT("Illegal signature in pattern:") <+> ppr ty)
+ 4 (ptext SLIT("Use -fglasgow-exts to permit it"))
+
pp_op (op, fix) = hcat [ppr op, space, parens (ppr fix)]
\end{code}
#include "HsVersions.h"
-import RnEnv ( listTyCon_name, tupleTyCon_name )
-
import HsSyn
import HsPragmas ( InstancePragmas, GenPragmas, DataPragmas, ClassPragmas, ClassOpPragmas )
-import BasicTypes ( Unused )
-import Name ( Name )
+import TysWiredIn ( tupleTyCon, unboxedTupleTyCon,
+ listTyCon, charTyCon )
+import Name ( Name, getName )
import NameSet
import Util
import Outputable
\begin{code}
-type RenamedArithSeqInfo = ArithSeqInfo Unused Name RenamedPat
-type RenamedClassDecl = ClassDecl Unused Name RenamedPat
+type RenamedArithSeqInfo = ArithSeqInfo Name RenamedPat
type RenamedClassOpSig = Sig Name
type RenamedConDecl = ConDecl Name
type RenamedContext = Context Name
-type RenamedHsDecl = HsDecl Unused Name RenamedPat
+type RenamedHsDecl = HsDecl Name RenamedPat
+type RenamedTyClDecl = TyClDecl Name RenamedPat
type RenamedSpecDataSig = SpecDataSig Name
type RenamedDefaultDecl = DefaultDecl Name
type RenamedForeignDecl = ForeignDecl Name
-type RenamedFixityDecl = FixityDecl Name
-type RenamedGRHS = GRHS Unused Name RenamedPat
-type RenamedGRHSsAndBinds = GRHSsAndBinds Unused Name RenamedPat
-type RenamedHsBinds = HsBinds Unused Name RenamedPat
-type RenamedHsExpr = HsExpr Unused Name RenamedPat
-type RenamedHsModule = HsModule Unused Name RenamedPat
-type RenamedInstDecl = InstDecl Unused Name RenamedPat
-type RenamedMatch = Match Unused Name RenamedPat
-type RenamedMonoBinds = MonoBinds Unused Name RenamedPat
+type RenamedGRHS = GRHS Name RenamedPat
+type RenamedGRHSs = GRHSs Name RenamedPat
+type RenamedHsBinds = HsBinds Name RenamedPat
+type RenamedHsExpr = HsExpr Name RenamedPat
+type RenamedHsModule = HsModule Name RenamedPat
+type RenamedInstDecl = InstDecl Name RenamedPat
+type RenamedMatch = Match Name RenamedPat
+type RenamedMonoBinds = MonoBinds Name RenamedPat
type RenamedPat = InPat Name
type RenamedHsType = HsType Name
-type RenamedRecordBinds = HsRecordBinds Unused Name RenamedPat
+type RenamedRecordBinds = HsRecordBinds Name RenamedPat
type RenamedSig = Sig Name
-type RenamedStmt = Stmt Unused Name RenamedPat
-type RenamedTyDecl = TyDecl Name
+type RenamedStmt = Stmt Name RenamedPat
+type RenamedFixitySig = FixitySig Name
type RenamedClassOpPragmas = ClassOpPragmas Name
type RenamedClassPragmas = ClassPragmas Name
These free-variable finders returns tycons and classes too.
\begin{code}
+charTyCon_name, listTyCon_name :: 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)
+
extractHsTyNames :: RenamedHsType -> NameSet
extractHsTyNames ty
= get ty
getImportedInstDecls,
getSpecialInstModules, getDeferredDataDecls,
importDecl, recordSlurp,
- getImportVersions, getSlurpedNames, getRnStats,
+ getImportVersions, getSlurpedNames, getRnStats, getImportedFixities,
- checkUpToDate,
+ checkUpToDate, loadHomeInterface,
getDeclBinders,
mkSearchPath
import CmdLineOpts ( opt_PruneTyDecls, opt_PruneInstDecls,
opt_D_show_rn_imports, opt_IgnoreIfacePragmas
)
-import HsSyn ( HsDecl(..), TyDecl(..), ClassDecl(..), InstDecl(..), IfaceSig(..),
+import HsSyn ( HsDecl(..), TyClDecl(..), InstDecl(..), IfaceSig(..),
HsType(..), ConDecl(..), IE(..), ConDetails(..), Sig(..),
- hsDeclName
+ FixitySig(..),
+ hsDeclName, countTyClDecls, isDataDecl
)
import BasicTypes ( Version, NewOrData(..), IfaceFlavour(..) )
-import RdrHsSyn ( RdrNameHsDecl, RdrNameInstDecl, RdrNameTyDecl,
+import RdrHsSyn ( RdrNameHsDecl, RdrNameInstDecl, RdrNameTyClDecl,
RdrName(..), rdrNameOcc
)
-import RnEnv ( newImportedGlobalName, addImplicitOccsRn,
- ifaceFlavour, availName, availNames, addAvailToNameSet
+import RnEnv ( newImportedGlobalName, addImplicitOccsRn, pprAvail,
+ availName, availNames, addAvailToNameSet, ifaceFlavour
)
import RnSource ( rnHsSigType )
import RnMonad
lookupFM, addToFM, addToFM_C, addListToFM,
fmToList
)
-import Name ( Name {-instance NamedThing-}, OccName(..),
+import Name ( Name {-instance NamedThing-}, OccName,
nameModule, moduleString, pprModule, isLocallyDefined,
- isWiredInName, maybeWiredInTyConName,
+ isWiredInName, maybeWiredInTyConName, pprModule,
maybeWiredInIdName, nameUnique, NamedThing(..)
)
import NameSet
getRnStats all_decls
= getIfacesRn `thenRn` \ ifaces ->
let
- Ifaces this_mod mod_map decls_fm all_names imp_names (unslurped_insts,_) deferred_data_decls inst_mods = ifaces
- n_mods = sizeFM mod_map
+ n_mods = sizeFM (iModMap ifaces)
decls_imported = filter is_imported_decl all_decls
- decls_read = [decl | (name, (_, avail, decl)) <- fmToList decls_fm,
- name == availName avail,
+
+ decls_read = [decl | (_, avail, decl, True) <- nameEnvElts (iDecls ifaces),
-- Data, newtype, and class decls are in the decls_fm
-- under multiple names; the tycon/class, and each
-- constructor/class op too.
- not (isLocallyDefined name)
+ -- The 'True' selects just the 'main' decl
+ not (isLocallyDefined (availName avail))
]
(cd_rd, dd_rd, add_rd, nd_rd, and_rd, sd_rd, vd_rd, _) = count_decls decls_read
(cd_sp, dd_sp, add_sp, nd_sp, and_sp, sd_sp, vd_sp, id_sp) = count_decls decls_imported
+ (unslurped_insts, _) = iDefInsts ifaces
inst_decls_unslurped = length (bagToList unslurped_insts)
inst_decls_read = id_sp + inst_decls_unslurped
stats = vcat
[int n_mods <> text " interfaces read",
- hsep [int cd_sp, text "class decls imported, out of",
+ hsep [ int cd_sp, text "class decls imported, out of",
int cd_rd, text "read"],
- hsep [int dd_sp, text "data decls imported (of which", int add_sp, text "abstractly), out of",
+ hsep [ int dd_sp, text "data decls imported (of which", int add_sp,
+ text "abstractly), out of",
int dd_rd, text "read"],
- hsep [int nd_sp, text "newtype decls imported (of which", int and_sp, text "abstractly), out of",
+ hsep [ int nd_sp, text "newtype decls imported (of which", int and_sp,
+ text "abstractly), out of",
int nd_rd, text "read"],
hsep [int sd_sp, text "type synonym decls imported, out of",
int sd_rd, text "read"],
val_decls,
inst_decls)
where
- class_decls = length [() | ClD _ <- decls]
- data_decls = length [() | TyD (TyData DataType _ _ _ _ _ _ _) <- decls]
- newtype_decls = length [() | TyD (TyData NewType _ _ _ _ _ _ _) <- decls]
- abstract_data_decls = length [() | TyD (TyData DataType _ _ _ [] _ _ _) <- decls]
- abstract_newtype_decls = length [() | TyD (TyData NewType _ _ _ [] _ _ _) <- decls]
- syn_decls = length [() | TyD (TySynonym _ _ _ _) <- decls]
- val_decls = length [() | SigD _ <- decls]
- inst_decls = length [() | InstD _ <- decls]
+ tycl_decls = [d | TyClD d <- decls]
+ (class_decls, data_decls, newtype_decls, syn_decls) = countTyClDecls tycl_decls
+ abstract_data_decls = length [() | TyData DataType _ _ _ [] _ _ _ <- tycl_decls]
+ abstract_newtype_decls = length [() | TyData NewType _ _ _ [] _ _ _ <- tycl_decls]
+
+ val_decls = length [() | SigD _ <- decls]
+ inst_decls = length [() | InstD _ <- decls]
\end{code}
%*********************************************************
\begin{code}
+loadHomeInterface :: SDoc -> Name -> RnMG Ifaces
+loadHomeInterface doc_str name
+ = loadInterface doc_str (nameModule name) (ifaceFlavour name)
+
loadInterface :: SDoc -> Module -> IfaceFlavour -> RnMG Ifaces
loadInterface doc_str load_mod as_source
= getIfacesRn `thenRn` \ ifaces ->
let
- Ifaces this_mod mod_map decls
- all_names imp_names (insts, tycls_names)
- deferred_data_decls inst_mods = ifaces
+ this_mod = iMod ifaces
+ mod_map = iModMap ifaces
+ (insts, tycls_names) = iDefInsts ifaces
in
-- CHECK WHETHER WE HAVE IT ALREADY
case lookupFM mod_map load_mod of {
- Just (hif, _, _, _) | hif `as_good_as` as_source
- -> -- Already in the cache; don't re-read it
+ Just (hif, _, _) | hif `as_good_as` as_source
+ -> -- Already in the cache; don't re-read it
returnRn ifaces ;
other ->
Nothing -> -- Not found, so add an empty export env to the Ifaces map
-- so that we don't look again
let
- new_mod_map = addToFM mod_map load_mod (HiFile, 0, [],[])
- new_ifaces = Ifaces this_mod new_mod_map
- decls all_names imp_names (insts, tycls_names)
- deferred_data_decls inst_mods
+ new_mod_map = addToFM mod_map load_mod (HiFile, 0, [])
+ new_ifaces = ifaces { iModMap = new_mod_map }
in
setIfacesRn new_ifaces `thenRn_`
failWithRn new_ifaces (noIfaceErr load_mod) ;
-- Found and parsed!
- Just (ParsedIface _ mod_vers usages exports rd_inst_mods fixs rd_decls rd_insts) ->
+ Just (ParsedIface _ mod_vers usages exports rd_inst_mods rd_decls rd_insts) ->
-- LOAD IT INTO Ifaces
-- NB: *first* we do loadDecl, so that the provenance of all the locally-defined
--- names is done correctly (notably, whether this is an .hi file or .hi-boot file).
-- If we do loadExport first the wrong info gets into the cache (unless we
-- explicitly tag each export which seems a bit of a bore)
- foldlRn (loadDecl load_mod as_source) decls rd_decls `thenRn` \ new_decls ->
- mapRn loadExport exports `thenRn` \ avails_s ->
- foldlRn (loadInstDecl load_mod) insts rd_insts `thenRn` \ new_insts ->
+ foldlRn (loadDecl load_mod as_source)
+ (iDecls ifaces) rd_decls `thenRn` \ new_decls ->
+ foldlRn (loadFixDecl load_mod as_source)
+ (iFixes ifaces) rd_decls `thenRn` \ new_fixities ->
+ mapRn loadExport exports `thenRn` \ avails_s ->
+ foldlRn (loadInstDecl load_mod) insts rd_insts `thenRn` \ new_insts ->
let
- mod_details = (as_source, mod_vers, concat avails_s, fixs)
+ mod_details = (as_source, mod_vers, concat avails_s)
-- Exclude this module from the "special-inst" modules
- new_inst_mods = inst_mods `unionLists` (filter (/= this_mod) rd_inst_mods)
-
- new_ifaces = Ifaces this_mod
- (addToFM mod_map load_mod mod_details)
- new_decls
- all_names imp_names
- (new_insts, tycls_names)
- deferred_data_decls
- new_inst_mods
+ new_inst_mods = iInstMods ifaces `unionLists` (filter (/= this_mod) rd_inst_mods)
+
+ new_ifaces = ifaces { iModMap = addToFM mod_map load_mod mod_details,
+ iDecls = new_decls,
+ iFixes = new_fixities,
+ iDefInsts = (new_insts, tycls_names),
+ iInstMods = new_inst_mods }
in
setIfacesRn new_ifaces `thenRn_`
returnRn new_ifaces
mapRn new_name occs `thenRn` \ names ->
returnRn (AvailTC name names)
-loadDecl :: Module
- -> IfaceFlavour
- -> DeclsMap
+
+loadFixDecl :: Module -> IfaceFlavour -> FixityEnv
+ -> (Version, RdrNameHsDecl)
+ -> RnMG FixityEnv
+loadFixDecl mod as_source fixity_env (version, FixD (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
+ new_implicit_name mod as_source 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 as_source fixity_env other_decl = returnRn fixity_env
+
+loadDecl :: Module -> IfaceFlavour -> DeclsMap
-> (Version, RdrNameHsDecl)
-> RnMG DeclsMap
+
loadDecl mod as_source decls_map (version, decl)
- = getDeclBinders new_implicit_name decl `thenRn` \ avail ->
- returnRn (addListToFM decls_map
- [(name,(version,avail,decl')) | name <- availNames avail]
- )
+ = getDeclBinders new_name decl `thenRn` \ avail ->
+ getDeclSysBinders new_name decl `thenRn` \ sys_bndrs ->
+ let
+ main_name = availName avail
+ new_decls_map = foldl add_decl decls_map
+ [ (name, (version,avail,decl',name==main_name))
+ | name <- sys_bndrs ++ availNames avail]
+ add_decl decls_map (name, stuff)
+ = ASSERT2( not (name `elemNameEnv` decls_map), ppr name )
+ addToNameEnv decls_map name stuff
+ in
+ returnRn new_decls_map
where
+ new_name rdr_name loc = new_implicit_name mod as_source rdr_name
{-
- If a signature decl is being loaded and we're ignoring interface pragmas,
- toss away unfolding information.
+ If a signature decl is being loaded, and optIgnoreIfacePragmas is on,
+ we toss away unfolding information.
Also, if the signature is loaded from a module we're importing from source,
we do the same. This is to avoid situations when compiling a pair of mutually
recursive modules, peering at unfolding info in the interface file of the other,
e.g., you compile A, it looks at B's interface file and may as a result change
- it's interface file. Hence, B is recompiled, maybe changing it's interface file,
- which will the ufolding info used in A to become invalid. Simple way out is to
+ its interface file. Hence, B is recompiled, maybe changing its interface file,
+ which will the unfolding info used in A to become invalid. Simple way out is to
just ignore unfolding info.
-}
decl' =
SigD (IfaceSig name tp [] loc)
_ -> decl
- new_implicit_name rdr_name loc = newImportedGlobalName mod (rdrNameOcc rdr_name) as_source
-
from_hi_boot = case as_source of
HiBootFile -> True
other -> False
+new_implicit_name mod as_source rdr_name
+ = newImportedGlobalName mod (rdrNameOcc rdr_name) as_source
+
loadInstDecl :: Module
-> Bag IfaceInst
-> RdrNameInstDecl
other -> inst_ty
in
-- We find the gates by renaming the instance type with in a
- -- and returning the occurrence pool.
+ -- and returning the free variables of the type
initRnMS emptyRnEnv mod_name vanillaInterfaceMode (
- findOccurrencesRn (rnHsSigType (text "an instance decl") munged_inst_ty)
- ) `thenRn` \ gate_names ->
+ discardOccurrencesRn (rnHsSigType (text "an instance decl") munged_inst_ty)
+ ) `thenRn` \ (_, gate_names) ->
returnRn (((mod_name, decl), gate_names) `consBag` insts)
-vanillaInterfaceMode = InterfaceMode Compulsory (\_ -> False)
+vanillaInterfaceMode = InterfaceMode Compulsory
\end{code}
pprModule mod_name]) `thenRn_`
returnRn False
- Just (ParsedIface _ _ usages _ _ _ _ _)
+ Just (ParsedIface _ _ usages _ _ _ _)
-> -- Found it, so now check it
checkModUsage usages
where
checkModUsage ((mod, hif, old_mod_vers, whats_imported) : rest)
= loadInterface doc_str mod hif `thenRn` \ ifaces ->
let
- Ifaces _ mod_map decls _ _ _ _ _ = ifaces
- maybe_new_mod_vers = lookupFM mod_map mod
- Just (_, new_mod_vers, _, _) = maybe_new_mod_vers
+ maybe_new_mod_vers = lookupFM (iModMap ifaces) mod
+ Just (_, new_mod_vers, _) = maybe_new_mod_vers
in
-- If we can't find a version number for the old module then
-- bail out saying things aren't up to date
Specifically old_local_vers ->
-- Non-empty usage list, so check item by item
- checkEntityUsage mod decls old_local_vers `thenRn` \ up_to_date ->
+ checkEntityUsage mod (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
checkEntityUsage mod decls ((occ_name,old_vers) : rest)
= newImportedGlobalName mod occ_name HiFile `thenRn` \ name ->
- case lookupFM decls name of
+ case lookupNameEnv decls name of
Nothing -> -- We used it before, but it ain't there now
putDocRn (sep [ptext SLIT("No longer exported:"), ppr name]) `thenRn_`
returnRn False
- Just (new_vers,_,_) -- It's there, but is it up to date?
+ Just (new_vers,_,_,_) -- It's there, but is it up to date?
| new_vers == old_vers
-- Up to date, so check the rest
-> checkEntityUsage mod decls rest
else
getIfacesRn `thenRn` \ ifaces ->
let
- Ifaces this_mod _ _ _ _ _ _ _ = ifaces
mod = nameModule name
in
- if mod == this_mod then -- Don't bring in decls from
+ if mod == iMod ifaces then -- Don't bring in decls from
addWarnRn (importDeclWarn mod name loc) `thenRn_`
-- pprTrace "importDecl wierdness:" (ppr name) $
returnRn Nothing -- the renamed module's own interface file
\begin{code}
getNonWiredInDecl :: Name -> SrcLoc -> RnSMode -> RnMG (Maybe RdrNameHsDecl)
getNonWiredInDecl needed_name loc mode
- = traceRn doc_str `thenRn_`
- loadInterface doc_str mod (ifaceFlavour needed_name) `thenRn` \ (Ifaces _ _ decls _ _ _ _ _) ->
- case lookupFM decls needed_name of
+ = traceRn doc_str `thenRn_`
+ loadHomeInterface doc_str needed_name `thenRn` \ ifaces ->
+ case lookupNameEnv (iDecls ifaces) needed_name of
-- Special case for data/newtype type declarations
- Just (version, avail, TyD ty_decl) | is_data_or_newtype ty_decl
- -> getNonWiredDataDecl needed_name version avail ty_decl `thenRn` \ (avail', maybe_decl) ->
- recordSlurp (Just version) necessity avail' `thenRn_`
- returnRn maybe_decl
+ Just (version, avail, TyClD tycl_decl, _) | isDataDecl tycl_decl
+ -> getNonWiredDataDecl needed_name version avail tycl_decl `thenRn` \ (avail', maybe_decl) ->
+ recordSlurp (Just version) necessity avail' `thenRn_`
+ returnRn maybe_decl
- Just (version,avail,decl)
- -> recordSlurp (Just version) necessity avail `thenRn_`
- returnRn (Just decl)
+ Just (version,avail,decl,_)
+ -> recordSlurp (Just version) necessity avail `thenRn_`
+ returnRn (Just decl)
Nothing -> -- Can happen legitimately for "Optional" occurrences
case necessity of {
- Optional -> addWarnRn (getDeclWarn needed_name loc);
- other -> addErrRn (getDeclErr needed_name loc)
+ Optional -> addWarnRn (getDeclWarn needed_name loc);
+ other -> addErrRn (getDeclErr needed_name loc)
} `thenRn_`
returnRn Nothing
where
necessity = modeToNecessity mode
doc_str = sep [ptext SLIT("need decl for"), ppr needed_name, ptext SLIT("needed at"), ppr loc]
- mod = nameModule needed_name
-
- is_data_or_newtype (TyData _ _ _ _ _ _ _ _) = True
- is_data_or_newtype other = False
\end{code}
@getWiredInDecl@ maps a wired-in @Name@ to what it makes available.
(if not main_is_tc || mod == pREL_GHC then
returnRn ()
else
- loadInterface doc_str mod (ifaceFlavour main_name) `thenRn_`
+ loadHomeInterface doc_str main_name `thenRn_`
returnRn ()
- ) `thenRn_`
+ ) `thenRn_`
returnRn Nothing -- No declaration to process further
where
necessity = modeToNecessity mode
new_mode = case mode of
- InterfaceMode _ _ -> mode
- SourceMode -> vanillaInterfaceMode
+ InterfaceMode _ -> mode
+ SourceMode -> vanillaInterfaceMode
get_wired | is_tycon -- ... a type constructor
= get_wired_tycon the_tycon
%*********************************************************
\begin{code}
-getInterfaceExports :: Module -> IfaceFlavour -> RnMG (Avails, [(OccName,Fixity)])
+getInterfaceExports :: Module -> IfaceFlavour -> RnMG Avails
getInterfaceExports mod as_source
- = loadInterface doc_str mod as_source `thenRn` \ (Ifaces _ mod_map _ _ _ _ _ _) ->
- case lookupFM mod_map mod of
+ = loadInterface doc_str mod as_source `thenRn` \ ifaces ->
+ case lookupFM (iModMap ifaces) mod of
Nothing -> -- Not there; it must be that the interface file wasn't found;
-- the error will have been reported already.
-- (Actually loadInterface should put the empty export env in there
-- anyway, but this does no harm.)
- returnRn ([],[])
+ returnRn []
- Just (_, _, avails, fixities) -> returnRn (avails, fixities)
+ Just (_, _, avails) -> returnRn avails
where
doc_str = sep [pprModule mod, ptext SLIT("is directly imported")]
\end{code}
= -- Need the type constructor; so put it in the deferred set for now
getIfacesRn `thenRn` \ ifaces ->
let
- Ifaces this_mod mod_map decls_fm slurped_names imp_names
- unslurped_insts deferred_data_decls inst_mods = ifaces
-
- new_ifaces = Ifaces this_mod mod_map decls_fm slurped_names imp_names
- unslurped_insts new_deferred_data_decls inst_mods
+ deferred_data_decls = iDefData ifaces
+ new_ifaces = ifaces {iDefData = new_deferred_data_decls}
no_constr_ty_decl = TyData new_or_data [] tycon tyvars [] derivings pragmas src_loc
- new_deferred_data_decls = addToFM deferred_data_decls tycon_name no_constr_ty_decl
+ new_deferred_data_decls = addToNameEnv deferred_data_decls tycon_name
+ (nameModule tycon_name, no_constr_ty_decl)
-- Nota bene: we nuke both the constructors and the context in the deferred decl.
-- If we don't nuke the context then renaming the deferred data decls can give
-- new unresolved names (for the classes). This could be handled, but there's
= -- Need a data constructor, so delete the data decl from the deferred set if it's there
getIfacesRn `thenRn` \ ifaces ->
let
- Ifaces this_mod mod_map decls_fm slurped_names imp_names
- unslurped_insts deferred_data_decls inst_mods = ifaces
+ deferred_data_decls = iDefData ifaces
+ new_ifaces = ifaces {iDefData = new_deferred_data_decls}
- new_ifaces = Ifaces this_mod mod_map decls_fm slurped_names imp_names
- unslurped_insts new_deferred_data_decls inst_mods
-
- new_deferred_data_decls = delFromFM deferred_data_decls tycon_name
+ new_deferred_data_decls = delFromNameEnv deferred_data_decls tycon_name
in
setIfacesRn new_ifaces `thenRn_`
- returnRn (avail, Just (TyD ty_decl))
+ returnRn (avail, Just (TyClD ty_decl))
\end{code}
\begin{code}
-getDeferredDataDecls :: RnMG [(Name, RdrNameTyDecl)]
+getDeferredDataDecls :: RnMG [(Module, RdrNameTyClDecl)]
getDeferredDataDecls
- = getIfacesRn `thenRn` \ (Ifaces _ _ _ _ _ _ deferred_data_decls _) ->
+ = getIfacesRn `thenRn` \ ifaces ->
let
- deferred_list = fmToList deferred_data_decls
+ deferred_list = nameEnvElts (iDefData ifaces)
trace_msg = hang (text "Slurping abstract data/newtype decls for: ")
4 (ppr (map fst deferred_list))
in
-- removing them from the bag kept in Ifaces
getIfacesRn `thenRn` \ ifaces ->
let
- Ifaces this_mod mod_map decls slurped_names imp_names (insts, tycls_names) deferred_data_decls inst_mods = ifaces
+ (insts, tycls_names) = iDefInsts ifaces
-- An instance decl is ungated if all its gates have been slurped
select_ungated :: IfaceInst -- A gated inst decl
[IfaceInst]) -- Still gated, but with
-- depeleted gates
select_ungated (decl,gates) (ungated_decls, gated_decls)
- | null remaining_gates
+ | isEmptyNameSet remaining_gates
= (decl : ungated_decls, gated_decls)
| otherwise
= (ungated_decls, (decl, remaining_gates) : gated_decls)
where
- remaining_gates = filter (not . (`elemNameSet` tycls_names)) gates
+ remaining_gates = gates `minusNameSet` tycls_names
(un_gated_insts, still_gated_insts) = foldrBag select_ungated ([], []) insts
- new_ifaces = Ifaces this_mod mod_map decls slurped_names imp_names
- ((listToBag still_gated_insts), tycls_names)
- -- NB: don't throw away tycls_names; we may comre across more instance decls
- deferred_data_decls
- inst_mods
+ new_ifaces = ifaces {iDefInsts = (listToBag still_gated_insts, tycls_names)}
+ -- NB: don't throw away tycls_names;
+ -- we may comre across more instance decls
in
traceRn (sep [text "getInstDecls:", fsep (map ppr (nameSetToList tycls_names))]) `thenRn_`
setIfacesRn new_ifaces `thenRn_`
getSpecialInstModules :: RnMG [Module]
getSpecialInstModules
= getIfacesRn `thenRn` \ ifaces ->
- let
- Ifaces _ _ _ _ _ _ _ inst_mods = ifaces
- in
- returnRn inst_mods
+ returnRn (iInstMods ifaces)
+
+getImportedFixities :: RnMG FixityEnv
+getImportedFixities
+ = getIfacesRn `thenRn` \ ifaces ->
+ returnRn (iFixes ifaces)
\end{code}
getImportVersions this_mod exports
= getIfacesRn `thenRn` \ ifaces ->
let
- Ifaces _ mod_map _ _ imp_names _ _ _ = ifaces
+ mod_map = iModMap ifaces
+ imp_names = iVSlurp ifaces
- -- mv_map groups together all the things imported from a particular module.
- mv_map, mv_map_mod :: FiniteMap Module (WhatsImported Name)
+ -- mv_map groups together all the things imported from a particular module.
+ mv_map, mv_map_mod :: FiniteMap Module (WhatsImported Name)
- mv_map_mod = foldl add_mod emptyFM export_mods
+ mv_map_mod = foldl add_mod emptyFM export_mods
-- mv_map_mod records all the modules that have a "module M"
-- in this module's export list with an "Everything"
- mv_map = foldl add_mv mv_map_mod imp_names
+ mv_map = foldl add_mv mv_map_mod imp_names
-- mv_map adds the version numbers of things exported individually
- mk_version_info (mod, local_versions)
+ mk_version_info (mod, local_versions)
= case lookupFM mod_map mod of
- Just (hif, version, _, _) -> (mod, hif, version, local_versions)
+ Just (hif, version, _) -> (mod, hif, version, local_versions)
in
returnRn (map mk_version_info (fmToList mv_map))
where
\begin{code}
checkSlurped name
- = getIfacesRn `thenRn` \ (Ifaces _ _ _ slurped_names _ _ _ _) ->
- returnRn (name `elemNameSet` slurped_names)
+ = getIfacesRn `thenRn` \ ifaces ->
+ returnRn (name `elemNameSet` iSlurp ifaces)
getSlurpedNames :: RnMG NameSet
getSlurpedNames
= getIfacesRn `thenRn` \ ifaces ->
- let
- Ifaces _ _ _ slurped_names _ _ _ _ = ifaces
- in
- returnRn slurped_names
+ returnRn (iSlurp ifaces)
recordSlurp maybe_version necessity avail
= {- traceRn (hsep [text "Record slurp:", pprAvail avail,
-}
getIfacesRn `thenRn` \ ifaces ->
let
- Ifaces this_mod mod_map decls slurped_names imp_names
- (insts, tycls_names) deferred_data_decls inst_mods = ifaces
+ Ifaces { iSlurp = slurped_names,
+ iVSlurp = imp_names,
+ iDefInsts = (insts, tycls_names) } = ifaces
new_slurped_names = addAvailToNameSet slurped_names avail
-> tycls_names `addOneToNameSet` tc
otherwise -> tycls_names
- new_ifaces = Ifaces this_mod mod_map decls
- new_slurped_names
- new_imp_names
- (insts, new_tycls_names)
- deferred_data_decls
- inst_mods
+ new_ifaces = ifaces { iSlurp = new_slurped_names,
+ iVSlurp = new_imp_names,
+ iDefInsts = (insts, new_tycls_names) }
in
setIfacesRn new_ifaces
\end{code}
-> RdrNameHsDecl
-> RnMG AvailInfo
-getDeclBinders new_name (TyD (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 (AvailTC tycon_name (tycon_name : nub sub_names))
-- The "nub" is because getConFieldNames can legitimately return duplicates,
-- when a record declaration has the same field in multiple constructors
-getDeclBinders new_name (TyD (TySynonym tycon _ _ src_loc))
+getDeclBinders new_name (TyClD (TySynonym tycon _ _ src_loc))
= new_name tycon src_loc `thenRn` \ tycon_name ->
returnRn (AvailTC tycon_name [tycon_name])
-getDeclBinders new_name (ClD (ClassDecl _ cname _ sigs _ _ tname dname src_loc))
+getDeclBinders new_name (TyClD (ClassDecl _ cname _ sigs _ _ tname dname src_loc))
= new_name cname src_loc `thenRn` \ class_name ->
- new_name dname src_loc `thenRn` \ datacon_name ->
- new_name tname src_loc `thenRn` \ tycon_name ->
-- Record the names for the class ops
mapRn (getClassOpNames new_name) sigs `thenRn` \ sub_names ->
- returnRn (AvailTC class_name (class_name : datacon_name : tycon_name : sub_names))
+ returnRn (AvailTC class_name (class_name : sub_names))
getDeclBinders new_name (SigD (IfaceSig var ty prags src_loc))
= new_name var src_loc `thenRn` \ var_name ->
returnRn (Avail var_name)
+getDeclBinders new_name (FixD _) = returnRn NotAvailable
getDeclBinders new_name (ForD _) = returnRn NotAvailable
getDeclBinders new_name (DefD _) = returnRn NotAvailable
getDeclBinders new_name (InstD _) = returnRn NotAvailable
getClassOpNames new_name (ClassOpSig op _ _ src_loc) = new_name op src_loc
\end{code}
+@getDeclSysBinders@ gets the implicit binders introduced by a decl.
+A the moment that's just the tycon and datacon that come with a class decl.
+They aren'te returned by getDeclBinders because they aren't in scope;
+but they should be put into the DeclsMap of this module.
+
+\begin{code}
+getDeclSysBinders new_name (TyClD (ClassDecl _ cname _ sigs _ _ tname dname src_loc))
+ = new_name dname src_loc `thenRn` \ datacon_name ->
+ new_name tname src_loc `thenRn` \ tycon_name ->
+ returnRn [tycon_name, datacon_name]
+
+getDeclSysBinders new_name other_decl
+ = returnRn []
+\end{code}
%*********************************************************
%* *
trace_msg = sep [hsep [ptext SLIT("Reading"),
case as_source of { HiBootFile -> ptext SLIT("[boot]"); other -> empty},
ptext SLIT("interface for"),
- ptext mod_name <> semi],
+ pprModule mod_name <> semi],
nest 4 (ptext SLIT("reason:") <+> doc_str)]
\end{code}
cannaeReadFile file err
= hcat [ptext SLIT("Failed in reading file: "),
- text file,
+ text file,
ptext SLIT("; error="),
- text (show err)]
+ text (show err)]
getDeclErr name loc
- = sep [ptext SLIT("Failed to find interface decl for"),
- quotes (ppr name), ptext SLIT("needed at"), ppr loc]
+ = sep [ptext SLIT("Failed to find interface decl for") <+> quotes (ppr name),
+ ptext SLIT("needed at") <+> ppr loc]
getDeclWarn name loc
- = sep [ptext SLIT("Failed to find (optional) interface decl for"),
- quotes (ppr name), ptext SLIT("desired at"), ppr loc]
+ = sep [ptext SLIT("Failed to find (optional) interface decl for") <+> quotes (ppr name),
+ ptext SLIT("desired at") <+> ppr loc]
importDeclWarn mod name loc
= sep [ptext SLIT("Compiler tried to import decl from interface file with same name as module."),
import HsSyn
import RdrHsSyn
-import BasicTypes ( Version, pprModule, IfaceFlavour(..) )
+import RnHsSyn ( RenamedFixitySig )
+import BasicTypes ( Version, IfaceFlavour(..) )
import SrcLoc ( noSrcLoc )
import ErrUtils ( addShortErrLocLine, addShortWarnLocLine,
pprBagOfErrors, ErrMsg, WarnMsg
)
import Name ( Module, Name, OccName, PrintUnqualified,
- isLocallyDefinedName,
+ isLocallyDefinedName, pprModule,
modAndOcc, NamedThing(..)
)
import NameSet
import SrcLoc ( SrcLoc, mkGeneratedSrcLoc )
import Unique ( Unique )
import UniqFM ( UniqFM )
-import FiniteMap ( FiniteMap, emptyFM, bagToFM, lookupFM, addToFM, addListToFM_C, addToFM_C )
+import FiniteMap ( FiniteMap, emptyFM, bagToFM, lookupFM, addToFM, addListToFM,
+ addListToFM_C, addToFM_C, eltsFM
+ )
import Bag ( Bag, mapBag, emptyBag, isEmptyBag, snocBag )
import Maybes ( seqMaybe, mapMaybe )
import UniqSet
+import UniqFM
import UniqSupply
import Util
import Outputable
-- Common part
data RnDown s = RnDown
SrcLoc
- (SSTRef s (GenRnNameSupply s))
+ (SSTRef s RnNameSupply)
(SSTRef s (Bag WarnMsg, Bag ErrMsg))
(SSTRef s ([Occurrence],[Occurrence])) -- Occurrences: compulsory and optional resp
-- For renaming source code
data SDown s = SDown
- RnEnv -- Global envt
- NameEnv -- Local name envt (includes global name envt,
- -- but may shadow it)
+ RnEnv -- Global envt; the fixity component gets extended
+ -- with local fixity decls
+ LocalRdrEnv -- Local name envt
+ -- Does *not* includes global name envt; may shadow it
+ -- Includes both ordinary variables and type variables;
+ -- they are kept distinct because tyvar have a different
+ -- occurrence contructor (Name.TvOcc)
+ -- We still need the unsullied global name env so that
+ -- we can look up record field names
Module
RnSMode
-- we arrange that the type signature is read
-- in compulsory mode,
-- but the pragmas in optional mode.
- (Name -> PrintUnqualified) -- Tells whether the thing can be printed unqualified
type SearchPath = [(String,String)] -- List of (directory,suffix) pairs to search
-- for interface files.
type ModuleHiMap = FiniteMap String String
-- mapping from module name to the file path of its corresponding
-- interface file.
-
-type FreeVars = NameSet
\end{code}
===================================================
===================================================
\begin{code}
-type RnNameSupply = GenRnNameSupply RealWorld
+--------------------------------
+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
+
+emptyRdrEnv = emptyFM
+lookupRdrEnv = lookupFM
+addListToRdrEnv = addListToFM
+rdrEnvElts = eltsFM
+
+--------------------------------
+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
+extendNameEnv :: NameEnv a -> [(Name,a)] -> NameEnv a
+lookupNameEnv :: NameEnv a -> Name -> Maybe a
+delFromNameEnv :: NameEnv a -> Name -> NameEnv a
+elemNameEnv :: Name -> NameEnv a -> Bool
+
+emptyNameEnv = emptyUFM
+nameEnvElts = eltsUFM
+addToNameEnv_C = addToUFM_C
+addToNameEnv = addToUFM
+plusNameEnv = plusUFM
+extendNameEnv = addListToUFM
+lookupNameEnv = lookupUFM
+delFromNameEnv = delFromUFM
+elemNameEnv = elemUFM
+
+--------------------------------
+type FixityEnv = NameEnv RenamedFixitySig
+
+--------------------------------
+data RnEnv = RnEnv GlobalRdrEnv FixityEnv
+emptyRnEnv = RnEnv emptyRdrEnv emptyNameEnv
+\end{code}
-type GenRnNameSupply s
+\begin{code}
+--------------------------------
+type RnNameSupply
= ( UniqSupply
- , FiniteMap FAST_STRING (SSTRef s Int)
- , FiniteMap (Module,OccName) Name
- )
- -- Ensures that one (m,n) pair gets one unique
- -- The finite map on FAST_STRINGS is used to give a per-class unique to each
- -- instance declaration; it's really a separate name supply.
-
-data RnEnv = RnEnv GlobalNameEnv FixityEnv
-emptyRnEnv = RnEnv emptyNameEnv emptyFixityEnv
-type GlobalNameEnv = FiniteMap RdrName (Name, HowInScope)
-emptyGlobalNameEnv = emptyFM
+ , FiniteMap (OccName, OccName) Int
+ -- This is used as a name supply for dictionary functions
+ -- From the inst decl we derive a (class, tycon) pair;
+ -- this map then gives a unique int for each inst decl with that
+ -- (class, tycon) pair. (In Haskell 98 there can only be one,
+ -- but not so in more extended versions.)
+ --
+ -- We could just use one Int for all the instance decls, but this
+ -- way the uniques change less when you add an instance decl,
+ -- hence less recompilation
-data HowInScope -- Used for error messages only
- = FromLocalDefn SrcLoc
- | FromImportDecl Module SrcLoc
-
-type NameEnv = FiniteMap RdrName Name
-emptyNameEnv = emptyFM
+ , FiniteMap (Module,OccName) Name
+ -- Ensures that one (module,occname) pair gets one unique
+ )
-type FixityEnv = FiniteMap RdrName (Fixity, HowInScope)
-emptyFixityEnv = emptyFM
- -- It's possible to have a different fixity for B.op than for op:
- --
- -- module A( op ) where module B where
- -- import qualified B( op ) infixr 2 op
- -- infixl 9 `op` op = ...
- -- op a b = a `B.op` b
-data ExportEnv = ExportEnv Avails Fixities
-type Avails = [AvailInfo]
-type Fixities = [(OccName, Fixity)]
+--------------------------------
+data ExportEnv = ExportEnv Avails Fixities
+type Avails = [AvailInfo]
+type Fixities = [(Name, Fixity)]
-type ExportAvails = (FiniteMap Module Avails, -- Used to figure out "module M" export specifiers
- -- Includes avails only from *unqualified* imports
- -- (see 1.4 Report Section 5.1.1)
+type ExportAvails = (FiniteMap Module Avails, -- Used to figure out "module M" export specifiers
+ -- Includes avails only from *unqualified* imports
+ -- (see 1.4 Report Section 5.1.1)
- UniqFM AvailInfo) -- Used to figure out all other export specifiers.
- -- Maps a Name to the AvailInfo that contains it
- -- NB: Contain bindings for class ops but
- -- not constructors (see defn of availEntityNames)
+ NameEnv AvailInfo) -- Used to figure out all other export specifiers.
+ -- Maps a Name to the AvailInfo that contains it
data GenAvailInfo name = NotAvailable
data ParsedIface
= ParsedIface
- Module -- Module name
- Version -- Module version number
+ Module -- Module name
+ Version -- Module version number
[ImportVersion OccName] -- Usages
[ExportItem] -- Exports
[Module] -- Special instance modules
- [(OccName,Fixity)] -- Fixities
[(Version, RdrNameHsDecl)] -- Local definitions
[RdrNameInstDecl] -- Local instance declarations
type RdrNamePragma = () -- Fudge for now
-------------------
-data Ifaces = Ifaces
- Module -- Name of this module
- (FiniteMap Module (IfaceFlavour, -- Exports
- Version,
- Avails,
- [(OccName,Fixity)]))
- DeclsMap
+data Ifaces = Ifaces {
+ iMod :: Module, -- Name of this module
+
+ iModMap :: FiniteMap Module (IfaceFlavour, -- Exports
+ Version,
+ Avails),
- NameSet -- All the names (whether "big" or "small", whether wired-in or not,
+ iDecls :: DeclsMap, -- A single, global map of Names to decls
+
+ iFixes :: FixityEnv, -- A single, global map of Names to fixities
+
+ iSlurp :: NameSet, -- All the names (whether "big" or "small", whether wired-in or not,
-- whether locally defined or not) that have been slurped in so far.
- [(Name,Version)] -- All the (a) non-wired-in (b) "big" (c) non-locally-defined names that
- -- have been slurped in so far, with their versions.
- -- This is used to generate the "usage" information for this module.
- -- Subset of the previous field.
+ iVSlurp :: [(Name,Version)], -- All the (a) non-wired-in (b) "big" (c) non-locally-defined names that
+ -- have been slurped in so far, with their versions.
+ -- This is used to generate the "usage" information for this module.
+ -- Subset of the previous field.
- (Bag IfaceInst, NameSet) -- The as-yet un-slurped instance decls; this bag is depleted when we
+ iDefInsts :: (Bag IfaceInst, NameSet),
+ -- The as-yet un-slurped instance decls; this bag is depleted when we
-- slurp an instance decl so that we don't slurp the same one twice.
-- Together with them is the set of tycons/classes that may allow
-- the instance decls in.
- (FiniteMap Name RdrNameTyDecl)
+ iDefData :: NameEnv (Module, RdrNameTyClDecl),
-- Deferred data type declarations; each has the following properties
-- * it's a data type decl
-- * its TyCon is needed
-- * the decl may or may not have been slurped, depending on whether any
-- of the constrs are needed.
- [Module] -- Set of modules with "special" instance declarations
+ iInstMods :: [Module] -- Set of modules with "special" instance declarations
-- Excludes this module
+ }
+
+type DeclsMap = NameEnv (Version, AvailInfo, RdrNameHsDecl, Bool)
+ -- A DeclsMap contains a binding for each Name in the declaration
+ -- including the constructors of a type decl etc.
+ -- The Bool is True just for the 'main' Name.
-type DeclsMap = FiniteMap Name (Version, AvailInfo, RdrNameHsDecl)
-type IfaceInst = ((Module, RdrNameInstDecl), -- Instance decl
- [Name]) -- "Gate" names. Slurp this instance decl when this
- -- list becomes empty. It's depleted whenever we
+type IfaceInst = ((Module, RdrNameInstDecl), -- Instance decl
+ NameSet) -- "Gate" names. Slurp this instance decl when this
+ -- set becomes empty. It's depleted whenever we
-- slurp another type or class decl.
\end{code}
initRnMS :: RnEnv -> Module -> RnSMode -> RnMS RealWorld r -> RnMG r
initRnMS rn_env@(RnEnv name_env _) mod_name mode m rn_down g_down
= let
- s_down = SDown rn_env emptyNameEnv mod_name mode
+ s_down = SDown rn_env emptyRdrEnv mod_name mode
in
m rn_down s_down
emptyIfaces :: Module -> Ifaces
-emptyIfaces mod = Ifaces mod emptyFM emptyFM emptyNameSet [] (emptyBag, emptyNameSet) emptyFM []
+emptyIfaces mod = Ifaces { iMod = mod,
+ iModMap = emptyFM,
+ iDecls = emptyNameEnv,
+ iFixes = emptyNameEnv,
+ iSlurp = emptyNameSet,
+ iVSlurp = [],
+ iDefInsts = (emptyBag, emptyNameSet),
+ iDefData = emptyNameEnv,
+ iInstMods = []
+ }
builtins :: FiniteMap (Module,OccName) Name
builtins = bagToFM (mapBag (\ name -> (modAndOcc name, name)) builtinNames)
newMutVarSST ([],[]) `thenSST` \ occs_var ->
let
rn_down = RnDown mkGeneratedSrcLoc names_var errs_var occs_var
- s_down = SDown emptyRnEnv emptyNameEnv mod_name (InterfaceMode Compulsory (\_ -> False))
+ s_down = SDown emptyRnEnv emptyRdrEnv mod_name (InterfaceMode Compulsory)
in
m rn_down s_down `thenSST` \ result ->
addErrRn err = failWithRn () err
checkRn :: Bool -> ErrMsg -> RnM s d () -- Check that a condition is true
-checkRn False err = addErrRn err
-checkRn True err = returnRn ()
+checkRn False err = addErrRn err
+checkRn True err = returnRn ()
+
+warnCheckRn :: Bool -> ErrMsg -> RnM s d () -- Check that a condition is true
+warnCheckRn False err = addWarnRn err
+warnCheckRn True err = returnRn ()
addWarnRn :: WarnMsg -> RnM s d ()
addWarnRn warn = warnWithRn () warn
================ Name supply =====================
\begin{code}
-getNameSupplyRn :: RnM s d (GenRnNameSupply s)
+getNameSupplyRn :: RnM s d RnNameSupply
getNameSupplyRn (RnDown loc names_var errs_var occs_var) l_down
= readMutVarSST names_var
-setNameSupplyRn :: GenRnNameSupply s -> RnM s d ()
+setNameSupplyRn :: RnNameSupply -> RnM s d ()
setNameSupplyRn names' (RnDown loc names_var errs_var occs_var) l_down
= writeMutVarSST names_var names'
--- The "instance-decl unique supply", inst, is really a map from class names
--- to unique supplies. Having per-class unique numbers for instance decls helps
--- the recompilation checker.
-newInstUniq :: FAST_STRING -> RnM s d Int
-newInstUniq cname (RnDown loc names_var errs_var occs_var) l_down
+-- See comments with RnNameSupply above.
+newInstUniq :: (OccName, OccName) -> RnM s d Int
+newInstUniq key (RnDown loc names_var errs_var occs_var) l_down
= readMutVarSST names_var `thenSST` \ (us, mapInst, cache) ->
- case lookupFM mapInst cname of
- Just class_us ->
- readMutVarSST class_us `thenSST` \ v ->
- writeMutVarSST class_us (v+1) `thenSST_`
- returnSST v
- Nothing -> -- first time caller gets to add a unique supply
- -- to the finite map for that class.
- newMutVarSST 1 `thenSST` \ class_us ->
- let
- mapInst' = addToFM mapInst cname class_us
- in
- writeMutVarSST names_var (us, mapInst', cache) `thenSST_`
- returnSST 0
-
+ let
+ uniq = case lookupFM mapInst key of
+ Just x -> x+1
+ Nothing -> 0
+ mapInst' = addToFM mapInst key uniq
+ in
+ writeMutVarSST names_var (us, mapInst', cache) `thenSST_`
+ returnSST uniq
\end{code}
================ Occurrences =====================
= readMutVarSST occs_var `thenSST` \ occs ->
case (mode, occs) of
-- Find a compulsory occurrence
- (InterfaceMode Compulsory _, (comp:comps, opts))
+ (InterfaceMode Compulsory, (comp:comps, opts))
-> writeMutVarSST occs_var (comps, opts) `thenSST_`
returnSST (Just comp)
-- Find an optional occurrence
-- We shouldn't be looking unless we've done all the compulsories
- (InterfaceMode Optional _, (comps, opt:opts))
- -> ASSERT( null comps )
+ (InterfaceMode Optional, (comps, opt:opts))
+ -> ASSERT2( null comps, ppr comps )
writeMutVarSST occs_var (comps, opts) `thenSST_`
returnSST (Just opt)
-- No suitable occurrence
other -> returnSST Nothing
--- findOccurrencesRn does the enclosed thing with a *fresh* occurrences
--- variable, and returns the list of occurrences thus found. It's useful
+-- discardOccurrencesRn does the enclosed thing with a *fresh* occurrences
+-- variable, and discards the list of occurrences thus found. It's useful
-- when loading instance decls and specialisation signatures, when we want to
-- know the names of the things in the types, but we don't want to treat them
-- as occurrences.
-findOccurrencesRn :: RnM s d a -> RnM s d [Name]
-findOccurrencesRn enclosed_thing (RnDown loc names_var errs_var occs_var) l_down
+discardOccurrencesRn :: RnM s d a -> RnM s d a
+discardOccurrencesRn enclosed_thing (RnDown loc names_var errs_var occs_var) l_down
= newMutVarSST ([],[]) `thenSST` \ new_occs_var ->
- enclosed_thing (RnDown loc names_var errs_var new_occs_var) l_down `thenSST_`
- readMutVarSST new_occs_var `thenSST` \ (occs,_) ->
- returnSST (map fst occs)
+ enclosed_thing (RnDown loc names_var errs_var new_occs_var) l_down
\end{code}
================ RnEnv =====================
\begin{code}
--- Look in global env only
-lookupGlobalNameRn :: RdrName -> RnMS s (Maybe Name)
-lookupGlobalNameRn rdr_name rn_down (SDown (RnEnv global_env fixity_env) local_env mod_name mode)
- = case lookupFM global_env rdr_name of
- Just (name, _) -> returnSST (Just name)
- Nothing -> returnSST Nothing
-
--- Look in both local and global env
-lookupNameRn :: RdrName -> RnMS s (Maybe Name)
-lookupNameRn rdr_name rn_down (SDown (RnEnv global_env fixity_env) local_env mod_name mode)
- = case lookupFM local_env rdr_name of
- Just name -> returnSST (Just name)
- Nothing -> case lookupFM global_env rdr_name of
- Just (name, _) -> returnSST (Just name)
- Nothing -> returnSST Nothing
-
-getNameEnvs :: RnMS s (GlobalNameEnv, NameEnv)
+getNameEnvs :: RnMS s (GlobalRdrEnv, LocalRdrEnv)
getNameEnvs rn_down (SDown (RnEnv global_env fixity_env) local_env mod_name mode)
= returnSST (global_env, local_env)
-getLocalNameEnv :: RnMS s NameEnv
+getLocalNameEnv :: RnMS s LocalRdrEnv
getLocalNameEnv rn_down (SDown rn_env local_env mod_name mode)
= returnSST local_env
-setLocalNameEnv :: NameEnv -> RnMS s a -> RnMS s a
+setLocalNameEnv :: LocalRdrEnv -> RnMS s a -> RnMS s a
setLocalNameEnv local_env' m rn_down (SDown rn_env local_env mod_name mode)
= m rn_down (SDown rn_env local_env' mod_name mode)
getFixityEnv :: RnMS s FixityEnv
getFixityEnv rn_down (SDown (RnEnv name_env fixity_env) local_env mod_name mode)
= returnSST fixity_env
+
+extendFixityEnv :: [(Name, RenamedFixitySig)] -> RnMS s a -> RnMS s a
+extendFixityEnv fixes enclosed_scope
+ rn_down (SDown (RnEnv name_env fixity_env) local_env mod_name mode)
+ = let
+ new_fixity_env = extendNameEnv fixity_env fixes
+ in
+ enclosed_scope rn_down (SDown (RnEnv name_env new_fixity_env) local_env mod_name mode)
\end{code}
================ Module and Mode =====================
%************************************************************************
\begin{code}
-instance Outputable HowInScope where
- ppr (FromLocalDefn loc) = ptext SLIT("Defined at") <+> ppr loc
- ppr (FromImportDecl mod loc) = ptext SLIT("Imported from") <+> quotes (pprModule mod) <+>
- ptext SLIT("at") <+> ppr loc
-\end{code}
-
-
-\begin{code}
-modeToNecessity SourceMode = Compulsory
-modeToNecessity (InterfaceMode necessity _) = necessity
+modeToNecessity SourceMode = Compulsory
+modeToNecessity (InterfaceMode necessity) = necessity
\end{code}
opt_SourceUnchanged
)
-import HsSyn ( HsModule(..), ImportDecl(..), HsDecl(..),
+import HsSyn ( HsModule(..), ImportDecl(..), HsDecl(..), TyClDecl(..),
IE(..), ieName,
ForeignDecl(..), ExtName(..), ForKind(..),
- FixityDecl(..),
+ FixitySig(..), Sig(..),
collectTopBinders
)
import RdrHsSyn ( RdrName(..), RdrNameIE, RdrNameImportDecl,
- RdrNameHsModule, RdrNameFixityDecl,
+ RdrNameHsModule, RdrNameHsDecl,
rdrNameOcc, ieOcc
)
-import RnIfaces ( getInterfaceExports, getDeclBinders, recordSlurp, checkUpToDate )
+import RnIfaces ( getInterfaceExports, getDeclBinders, getImportedFixities,
+ recordSlurp, checkUpToDate, loadHomeInterface
+ )
import BasicTypes ( IfaceFlavour(..) )
import RnEnv
import RnMonad
import Bag ( bagToList )
import Maybes ( maybeToBool )
import Name
-import NameSet ( elemNameSet )
+import SrcLoc ( SrcLoc )
+import NameSet ( elemNameSet, emptyNameSet )
import Outputable
-import Util ( removeDups )
+import Unique ( getUnique )
+import Util ( removeDups, equivClassesByUniq )
+import List ( nubBy )
\end{code}
\begin{code}
getGlobalNames :: RdrNameHsModule
-> RnMG (Maybe (ExportEnv,
- RnEnv,
- FiniteMap Name HowInScope, -- Locally defined or explicitly imported
- Name -> PrintUnqualified))
+ RnEnv,
+ NameEnv AvailInfo -- Maps a name to its parent AvailInfo
+ -- Just for in-scope things only
+ ))
-- Nothing => no need to recompile
-getGlobalNames m@(HsModule this_mod _ exports imports _ _ mod_loc)
- = fixRn (\ ~(rec_exp_fn, _) ->
-
- -- PROCESS LOCAL DECLS
- -- Do these *first* so that the correct provenance gets
- -- into the global name cache.
- importsFromLocalDecls rec_exp_fn m `thenRn` \ (local_rn_env, local_mod_avails, local_info) ->
+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_exp_fn, _) ->
- -- PROCESS IMPORT DECLS
- mapAndUnzip3Rn importsFromImportDecl all_imports
- `thenRn` \ (imp_rn_envs, imp_avails_s, explicit_imports_s) ->
+ fixRn (\ ~(rec_rn_env, _) ->
+ let
+ rec_unqual_fn :: Name -> Bool -- Is this chap in scope unqualified?
+ rec_unqual_fn = mkPrintUnqualFn rec_rn_env
+ in
+ -- PROCESS LOCAL DECLS
+ -- Do these *first* so that the correct provenance gets
+ -- into the global name cache.
+ importsFromLocalDecls this_mod rec_exp_fn decls `thenRn` \ (local_gbl_env, local_mod_avails) ->
+
+ -- PROCESS IMPORT DECLS
+ mapAndUnzipRn (importsFromImportDecl rec_unqual_fn)
+ all_imports `thenRn` \ (imp_gbl_envs, imp_avails_s) ->
+
+ -- COMBINE RESULTS
+ -- We put the local env second, so that a local provenance
+ -- "wins", even if a module imports itself.
+ let
+ gbl_env :: GlobalRdrEnv
+ imp_gbl_env = foldr plusGlobalRdrEnv emptyRdrEnv imp_gbl_envs
+ gbl_env = imp_gbl_env `plusGlobalRdrEnv` local_gbl_env
- -- COMBINE RESULTS
- -- We put the local env second, so that a local provenance
- -- "wins", even if a module imports itself.
- foldlRn plusRnEnv emptyRnEnv imp_rn_envs `thenRn` \ imp_rn_env ->
- plusRnEnv imp_rn_env local_rn_env `thenRn` \ rn_env ->
+ export_avails :: ExportAvails
+ export_avails = foldr plusExportAvails local_mod_avails imp_avails_s
+ in
+ returnRn (gbl_env, export_avails)
+ ) `thenRn` \ (gbl_env, export_avails) ->
-- TRY FOR EARLY EXIT
-- We can't go for an early exit before this because we have to check
-- 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 plusRnEnv stuff to do the early-exit.
- checkEarlyExit this_mod `thenRn` \ up_to_date ->
+ checkEarlyExit this_mod `thenRn` \ up_to_date ->
if up_to_date then
- returnRn (error "early exit", Nothing)
+ returnRn (junk_exp_fn, Nothing)
else
-
- -- PROCESS EXPORT LISTS
+ -- FIXITIES
+ fixitiesFromLocalDecls gbl_env decls `thenRn` \ local_fixity_env ->
+ getImportedFixities `thenRn` \ imp_fixity_env ->
let
- export_avails :: ExportAvails
- export_avails = foldr plusExportAvails local_mod_avails imp_avails_s
-
- explicit_info :: FiniteMap Name HowInScope -- Locally defined or explicitly imported
- explicit_info = foldr plusFM local_info explicit_imports_s
+ fixity_env = imp_fixity_env `plusNameEnv` local_fixity_env
+ rn_env = RnEnv gbl_env fixity_env
+ (_, global_avail_env) = export_avails
in
- exportsFromAvail this_mod exports export_avails rn_env
- `thenRn` \ (export_fn, export_env) ->
+ traceRn (text "fixity env" <+> vcat (map ppr (nameEnvElts fixity_env))) `thenRn_`
- -- BUILD THE "IMPORT FN". It just tells whether a name is in
- -- scope in an unqualified form.
- let
- print_unqual = mkImportFn imp_rn_env
- in
+ -- PROCESS EXPORT LISTS
+ exportsFromAvail this_mod exports export_avails rn_env `thenRn` \ (export_fn, export_env) ->
- returnRn (export_fn, Just (export_env, rn_env, explicit_info, print_unqual))
+ -- DONE
+ returnRn (export_fn, Just (export_env, rn_env, global_avail_env))
) `thenRn` \ (_, result) ->
returnRn result
where
\end{code}
\begin{code}
-importsFromImportDecl :: RdrNameImportDecl
- -> RnMG (RnEnv,
- ExportAvails,
- FiniteMap Name HowInScope) -- Records the explicitly-imported things
-
-importsFromImportDecl (ImportDecl mod qual_only as_source as_mod import_spec loc)
- = pushSrcLocRn loc $
- getInterfaceExports mod as_source `thenRn` \ (avails, fixities) ->
+importsFromImportDecl :: (Name -> Bool) -- True => print unqualified
+ -> RdrNameImportDecl
+ -> RnMG (GlobalRdrEnv,
+ ExportAvails)
+
+importsFromImportDecl rec_unqual_fn (ImportDecl mod qual_only as_source as_mod import_spec iloc)
+ = pushSrcLocRn iloc $
+ getInterfaceExports mod as_source `thenRn` \ avails ->
+
+ if null avails then
+ -- If there's an error in getInterfaceExports, (e.g. interface
+ -- file not found) then avail might be NotAvailable, so availName
+ -- in home_modules fails. Hence the guard here. Also we get lots
+ -- of spurious errors from 'filterImports' if we don't find the interface file
+ returnRn (emptyRdrEnv, mkEmptyExportAvails mod)
+ else
+
filterImports mod import_spec avails `thenRn` \ (filtered_avails, hides, explicits) ->
+
+ -- Load all the home modules for the things being
+ -- bought into scope. This makes sure their fixities
+ -- are loaded before we grab the FixityEnv from Ifaces
let
- how_in_scope = FromImportDecl mod loc
- explicit_info = listToFM [(name, how_in_scope)
- | avail <- explicits,
- name <- availNames avail
- ]
+ home_modules = [name | avail <- filtered_avails,
+ -- Doesn't take account of hiding, but that doesn't matter
+
+ let name = availName avail,
+ nameModule name /= mod]
+ -- This predicate is a bit of a hack.
+ -- PrelBase imports error from PrelErr.hi-boot; but error is
+ -- wired in, so its provenance doesn't say it's from an hi-boot
+ -- file. Result: disaster when PrelErr.hi doesn't exist.
+
+ same_module n1 n2 = nameModule n1 == nameModule n2
+ load n = loadHomeInterface (doc_str n) n
+ doc_str n = ptext SLIT("Need fixities from") <+> ppr (nameModule n) <+> parens (ppr n)
+ in
+ mapRn load (nubBy same_module home_modules) `thenRn_`
+
+ -- We 'improve' the provenance by setting
+ -- (a) the import-reason field, so that the Name says how it came into scope
+ -- including whether it's explicitly imported
+ -- (b) the print-unqualified field
+ -- But don't fiddle with wired-in things or we get in a twist
+ let
+ improve_prov name | isWiredInName name = name
+ | otherwise = setNameProvenance name (mk_new_prov name)
+
+ is_explicit name = name `elemNameSet` explicits
+ mk_new_prov name = NonLocalDef (UserImport mod iloc (is_explicit name))
+ as_source
+ (rec_unqual_fn name)
in
qualifyImports mod
- True -- Want qualified names
(not qual_only) -- Maybe want unqualified names
- as_mod
- hides
- filtered_avails (\n -> how_in_scope)
- [ (occ,(fixity,how_in_scope)) | (occ,fixity) <- fixities ]
- `thenRn` \ (rn_env, mod_avails) ->
- returnRn (rn_env, mod_avails, explicit_info)
+ as_mod hides
+ filtered_avails improve_prov `thenRn` \ (rdr_name_env, mod_avails) ->
+
+ returnRn (rdr_name_env, mod_avails)
\end{code}
\begin{code}
-importsFromLocalDecls rec_exp_fn (HsModule mod _ _ _ fix_decls decls _)
- = foldlRn getLocalDeclBinders [] decls `thenRn` \ avails ->
+importsFromLocalDecls mod rec_exp_fn decls
+ = mapRn (getLocalDeclBinders newLocalName) decls `thenRn` \ avails_s ->
- -- Record that locally-defined things are available
- mapRn (recordSlurp Nothing Compulsory) avails `thenRn_`
+ let
+ avails = concat avails_s
- -- Fixities
- mapRn fixityFromFixDecl fix_decls `thenRn` \ fixities ->
+ all_names :: [Name] -- All the defns; no dups eliminated
+ all_names = [name | avail <- avails, name <- availNames avail]
- -- Record where the available stuff came from
- let
- explicit_info = listToFM [(name, FromLocalDefn (getSrcLoc name))
- | avail <- avails,
- name <- availNames avail
- ]
+ dups :: [[Name]]
+ dups = filter non_singleton (equivClassesByUniq getUnique all_names)
+ where
+ non_singleton (x1:x2:xs) = True
+ non_singleton other = False
in
+ -- Check for duplicate definitions
+ mapRn (addErrRn . dupDeclErr) dups `thenRn_`
+
+ -- Record that locally-defined things are available
+ mapRn (recordSlurp Nothing Compulsory) avails `thenRn_`
+
+ -- Build the environment
qualifyImports mod
- False -- Don't want qualified names
True -- Want unqualified names
- Nothing -- No "as M" part
+ Nothing -- no 'as M'
[] -- Hide nothing
- avails (\n -> FromLocalDefn (getSrcLoc n))
- fixities
- `thenRn` \ (rn_env, mod_avails) ->
- returnRn (rn_env, mod_avails, explicit_info)
- where
- newLocalName rdr_name loc
- = newLocallyDefinedGlobalName mod (rdrNameOcc rdr_name) rec_exp_fn loc
+ avails
+ (\n -> n)
- getLocalDeclBinders avails (ValD binds)
- = mapRn do_one (bagToList (collectTopBinders binds)) `thenRn` \ val_avails ->
- returnRn (val_avails ++ avails)
+ where
+ newLocalName rdr_name loc = newLocallyDefinedGlobalName mod (rdrNameOcc rdr_name)
+ rec_exp_fn loc
+
+getLocalDeclBinders :: (RdrName -> SrcLoc -> RnMG Name) -- New-name function
+ -> RdrNameHsDecl
+ -> RnMG Avails
+getLocalDeclBinders new_name (ValD binds)
+ = mapRn do_one (bagToList (collectTopBinders binds))
+ where
+ do_one (rdr_name, loc) = new_name rdr_name loc `thenRn` \ name ->
+ returnRn (Avail name)
-- foreign import declaration
- getLocalDeclBinders avails (ForD (ForeignDecl nm (FoImport _) _ _ _ loc))
- = do_one (nm,loc) `thenRn` \ for_avail ->
- returnRn (for_avail : avails)
+getLocalDeclBinders new_name (ForD (ForeignDecl nm kind _ _ _ loc))
+ | binds_haskell_name kind
+ = new_name nm loc `thenRn` \ name ->
+ returnRn [Avail name]
+
+ | otherwise
+ = returnRn []
+
+getLocalDeclBinders new_name decl
+ = getDeclBinders new_name decl `thenRn` \ avail ->
+ case avail of
+ NotAvailable -> returnRn [] -- Instance decls and suchlike
+ other -> returnRn [avail]
+
+binds_haskell_name (FoImport _) = True
+binds_haskell_name FoLabel = True
+binds_haskell_name FoExport = False
+
+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
- -- foreign import declaration
- getLocalDeclBinders avails (ForD (ForeignDecl nm FoLabel _ _ _ loc))
- = do_one (nm,loc) `thenRn` \ for_avail ->
- returnRn (for_avail : avails)
-
- -- foreign export dynamic declaration
- getLocalDeclBinders avails (ForD (ForeignDecl nm FoExport _ Dynamic _ loc))
- = do_one (nm,loc) `thenRn` \ for_avail ->
- returnRn (for_avail : avails)
-
- getLocalDeclBinders avails decl
- = getDeclBinders newLocalName decl `thenRn` \ avail ->
- case avail of
- NotAvailable -> returnRn avails -- Instance decls and suchlike
- other -> returnRn (avail : avails)
-
- do_one (rdr_name, loc)
- = newLocalName rdr_name loc `thenRn` \ name ->
- returnRn (Avail name)
+ 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 (FixitySig rdr_name fixity loc)
+ = -- Check for fixity decl for something not declared
+ case lookupRdrEnv gbl_env rdr_name of {
+ Nothing -> pushSrcLocRn loc $
+ addWarnRn (unusedFixityDecl rdr_name fixity) `thenRn_`
+ 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}
%************************************************************************
\begin{code}
filterImports :: Module
- -> Maybe (Bool, [RdrNameIE]) -- Import spec; True => hidin
- -> [AvailInfo] -- What's available
- -> RnMG ([AvailInfo], -- What's actually imported
- [AvailInfo], -- What's to be hidden (the unqualified version, that is)
- [AvailInfo]) -- What was imported explicitly
+ -> Maybe (Bool, [RdrNameIE]) -- Import spec; True => hiding
+ -> [AvailInfo] -- What's available
+ -> RnMG ([AvailInfo], -- What's actually imported
+ [AvailInfo], -- What's to be hidden (the unqualified version, that is)
+ NameSet) -- What was imported explicitly
-- Complains if import spec mentions things that the module doesn't export
-- Warns/informs if import spec contains duplicates.
filterImports mod Nothing imports
- = returnRn (imports, [], [])
+ = returnRn (imports, [], emptyNameSet)
filterImports mod (Just (want_hiding, import_items)) avails
= mapRn check_item import_items `thenRn` \ item_avails ->
if want_hiding
then
- returnRn (avails, item_avails, []) -- All imported; item_avails to be hidden
+ -- All imported; item_avails to be hidden
+ returnRn (avails, item_avails, emptyNameSet)
else
- returnRn (item_avails, [], item_avails) -- Just item_avails imported; nothing to be hidden
+ -- Just item_avails imported; nothing to be hidden
+ returnRn (item_avails, [], availsToNameSet item_avails)
where
import_fm :: FiniteMap OccName AvailInfo
import_fm = listToFM [ (nameOccName name, avail)
| avail <- avails,
- name <- availEntityNames avail]
+ name <- availNames avail]
+ -- Even though availNames returns data constructors too,
+ -- they won't make any difference because naked entities like T
+ -- in an import list map to TCOccs, not VarOccs.
check_item item@(IEModuleContents _)
= addErrRn (badImportItemErr mod item) `thenRn_`
fully fledged @Names@.
\begin{code}
-qualifyImports :: Module -- Imported module
- -> Bool -- True <=> want qualified import
- -> Bool -- True <=> want unqualified import
- -> Maybe Module -- Optional "as M" part
- -> [AvailInfo] -- What's to be hidden
- -> Avails -> (Name -> HowInScope) -- Whats imported and how
- -> [(OccName, (Fixity, HowInScope))] -- Ditto for fixities
- -> RnMG (RnEnv, ExportAvails)
-
-qualifyImports this_mod qual_imp unqual_imp as_mod hides
- avails name_to_his fixities
+qualifyImports :: Module -- Imported module
+ -> Bool -- True <=> want unqualified import
+ -> Maybe Module -- Optional "as M" part
+ -> [AvailInfo] -- What's to be hidden
+ -> Avails -- Whats imported and how
+ -> (Name -> Name) -- Improves the provenance on imported things
+ -> RnMG (GlobalRdrEnv, ExportAvails)
+ -- NB: the Names in ExportAvails don't have the improve-provenance
+ -- function applied to them
+ -- We could fix that, but I don't think it matters
+
+qualifyImports this_mod unqual_imp as_mod hides
+ avails improve_prov
=
- -- Make the name environment. Even though we're talking about a
- -- single import module there might still be name clashes,
- -- because it might be the module being compiled.
- foldlRn add_avail emptyGlobalNameEnv avails `thenRn` \ name_env1 ->
+ -- Make the name environment. We're talking about a
+ -- single module here, so there must be no name clashes.
+ -- In practice there only ever will be if it's the module
+ -- being compiled.
let
+ -- Add the things that are available
+ name_env1 = foldl add_avail emptyRdrEnv avails
+
-- Delete things that are hidden
name_env2 = foldl del_avail name_env1 hides
- -- Create the fixity env
- fixity_env = foldl (add_fixity name_env2) emptyFixityEnv fixities
-
-- Create the export-availability info
export_avails = mkExportAvails qual_mod unqual_imp name_env2 avails
in
- returnRn (RnEnv name_env2 fixity_env, export_avails)
+ returnRn (name_env2, export_avails)
+
where
qual_mod = case as_mod of
Nothing -> this_mod
Just another_name -> another_name
- add_avail :: GlobalNameEnv -> AvailInfo -> RnMG GlobalNameEnv
- add_avail env avail = foldlRn add_name env (availNames avail)
+ add_avail :: GlobalRdrEnv -> AvailInfo -> GlobalRdrEnv
+ add_avail env avail = foldl add_name env (availNames avail)
- add_name env name = add qual_imp env (Qual qual_mod occ err_hif) `thenRn` \ env1 ->
- add unqual_imp env1 (Unqual occ)
- where
- add False env rdr_name = returnRn env
- add True env rdr_name = addOneToGlobalNameEnv env rdr_name (name, name_to_his name)
- occ = nameOccName name
+ add_name env name
+ | unqual_imp = env2
+ | otherwise = env1
+ where
+ env1 = addOneToGlobalRdrEnv env (Qual qual_mod occ err_hif) better_name
+ env2 = addOneToGlobalRdrEnv env1 (Unqual occ) better_name
+ occ = nameOccName name
+ better_name = improve_prov name
- del_avail env avail = foldl delOneFromGlobalNameEnv env rdr_names
+ del_avail env avail = foldl delOneFromGlobalRdrEnv env rdr_names
where
rdr_names = map (Unqual . nameOccName) (availNames avail)
- add_fixity name_env fix_env (occ_name, fixity)
- = add qual $ add unqual $ fix_env
- where
- qual = Qual qual_mod occ_name err_hif
- unqual = Unqual occ_name
-
- add rdr_name fix_env | maybeToBool (lookupFM name_env rdr_name)
- = addOneToFixityEnv fix_env rdr_name fixity
- | otherwise
- = fix_env
-
err_hif = error "qualifyImports: hif" -- Not needed in key to mapping
\end{code}
-unQualify adds an Unqual binding for every existing Qual binding.
-
-\begin{code}
-unQualify :: FiniteMap RdrName elt -> FiniteMap RdrName elt
-unQualify fm = addListToFM fm [(Unqual occ, elt) | (Qual _ occ _, elt) <- fmToList fm]
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Local declarations}
-%* *
-%************************************************************************
-
-
-\begin{code}
-fixityFromFixDecl :: RdrNameFixityDecl -> RnMG (OccName, (Fixity, HowInScope))
-
-fixityFromFixDecl (FixityDecl rdr_name fixity loc)
- = returnRn (rdrNameOcc rdr_name, (fixity, FromLocalDefn loc))
-\end{code}
-
%************************************************************************
%* *
%* *
%************************************************************************
-The @AvailEnv@ type is just used internally in @exportsFromAvail@.
-When exporting we need to combine the availabilities for a particular
-exported thing, and we also need to check for name clashes -- that
-is: two exported things must have different @OccNames@.
-
-\begin{code}
-type AvailEnv = FiniteMap OccName (RdrNameIE, AvailInfo, Int{-no. of clashes-})
- -- The FM maps each OccName to the RdrNameIE that gave rise to it,
- -- for error reporting, as well as to its AvailInfo
-
-emptyAvailEnv = emptyFM
-
-{-
- Add new entry to environment. Checks for name clashes, i.e.,
- plain duplicates or exported entity pairs that have different OccNames.
- (c.f. 5.1.1 of Haskell 1.4 report.)
--}
-addAvailEnv :: Bool -> RdrNameIE -> AvailEnv -> AvailInfo -> RnM s d AvailEnv
-addAvailEnv warn_dups ie env NotAvailable = returnRn env
-addAvailEnv warn_dups ie env (AvailTC _ []) = returnRn env
-addAvailEnv warn_dups ie env avail
- | warn_dups = mapMaybeRn (addErrRn . availClashErr) () conflict `thenRn_`
- returnRn (addToFM_C addAvail env key elt)
- | otherwise = returnRn (addToFM_C addAvail env key elt)
- where
- occ_avail = nameOccName (availName avail)
- occ_ie = ieOcc ie
- key
- | not warn_dups || occ_ie == occ_avail = occ_avail
- | otherwise = occ_ie
- -- export item is a class method, use export occ name instead.
- -- (this is only needed to get more precise warnings about
- -- duplicates.)
- elt = (ie,avail,reports_on)
-
- reports_on
- | maybeToBool dup = 1
- | otherwise = 0
-
- conflict = conflictFM bad_avail env key elt
- dup
- | warn_dups = conflictFM dup_avail env key elt
- | otherwise = Nothing
-
-addListToAvailEnv :: AvailEnv -> RdrNameIE -> [AvailInfo] -> RnM s d AvailEnv
-addListToAvailEnv env ie items
- = foldlRn (addAvailEnv False{-don't warn about dups-} ie) env items
-
-bad_avail (ie1,avail1,r1) (ie2,avail2,r2)
- = availName avail1 /= availName avail2 -- Same OccName, different Name
-dup_avail (ie1,avail1,r1) (ie2,avail2,r2)
- = availName avail1 == availName avail2 -- Same OccName & avail.
-
-addAvail (ie1,a1,r1) (ie2,a2,r2) = (ie1, a1 `plusAvail` a2, r1 + r2)
-\end{code}
-
Processing the export list.
You might think that we should record things that appear in the export list as
includes ConcBase.StateAndSynchVar#, and so on...
\begin{code}
+type ExportAccum -- The type of the accumulating parameter of
+ -- the main worker function in exportsFromAvail
+ = ([Module], -- 'module M's seen so far
+ ExportOccMap, -- Tracks exported occurrence names
+ NameEnv AvailInfo) -- The accumulated exported stuff, kept in an env
+ -- so we can common-up related AvailInfos
+
+type ExportOccMap = FiniteMap OccName (Name, RdrNameIE)
+ -- Tracks what a particular exported OccName
+ -- in an export list refers to, and which item
+ -- it came from. It's illegal to export two distinct things
+ -- that have the same occurrence name
+
+
exportsFromAvail :: Module
-> Maybe [RdrNameIE] -- Export spec
-> ExportAvails
exportsFromAvail this_mod (Just export_items)
(mod_avail_env, entity_avail_env)
(RnEnv global_name_env fixity_env)
- = checkForModuleExportDups export_items `thenRn` \ export_items' ->
- foldlRn exports_from_item emptyAvailEnv export_items' `thenRn` \ export_avail_env ->
+ = foldlRn exports_from_item
+ ([], emptyFM, emptyNameEnv) export_items `thenRn` \ (_, _, export_avail_map) ->
let
- dup_entries = fmToList (filterFM (\ _ (_,_,clashes) -> clashes > 0) export_avail_env)
- in
- mapRn (addWarnRn . dupExportWarn) dup_entries `thenRn_`
- let
- export_avails = map (\ (_,a,_) -> a) (eltsFM export_avail_env)
- export_fixities = mk_exported_fixities (availsToNameSet export_avails)
- export_fn = mk_export_fn export_avails
+ export_avails :: [AvailInfo]
+ export_avails = nameEnvElts export_avail_map
+
+ export_names :: NameSet
+ export_names = availsToNameSet export_avails
+
+ -- Export only those fixities that are for names that are
+ -- (a) defined in this module
+ -- (b) exported
+ export_fixities :: [(Name,Fixity)]
+ export_fixities = [ (name,fixity)
+ | FixitySig name fixity _ <- nameEnvElts fixity_env,
+ name `elemNameSet` export_names,
+ isLocallyDefined name
+ ]
+
+ export_fn :: Name -> ExportFlag
+ export_fn = mk_export_fn export_names
in
returnRn (export_fn, ExportEnv export_avails export_fixities)
where
- exports_from_item :: AvailEnv -> RdrNameIE -> RnMG AvailEnv
- exports_from_item export_avail_env ie@(IEModuleContents mod)
- = case lookupFM mod_avail_env mod of
- Nothing -> failWithRn export_avail_env (modExportErr mod)
- Just avails -> addListToAvailEnv export_avail_env ie avails
+ exports_from_item :: ExportAccum -> RdrNameIE -> RnMG ExportAccum
- exports_from_item export_avail_env ie
+ exports_from_item acc@(mods, occs, avails) ie@(IEModuleContents mod)
+ | mod `elem` mods -- Duplicate export of M
+ = warnCheckRn opt_WarnDuplicateExports
+ (dupModuleExport mod) `thenRn_`
+ returnRn acc
+
+ | otherwise
+ = case lookupFM mod_avail_env mod of
+ Nothing -> failWithRn acc (modExportErr mod)
+ Just mod_avails -> foldlRn (check_occs ie) occs mod_avails `thenRn` \ occs' ->
+ let
+ avails' = foldl add_avail avails mod_avails
+ in
+ returnRn (mod:mods, occs', avails')
+
+ exports_from_item acc@(mods, occs, avails) ie
| not (maybeToBool maybe_in_scope)
- = failWithRn export_avail_env (unknownNameErr (ieName ie))
+ = failWithRn acc (unknownNameErr (ieName ie))
+
+ | not (null dup_names)
+ = addNameClashErrRn rdr_name (name:dup_names) `thenRn_`
+ returnRn acc
#ifdef DEBUG
-- I can't see why this should ever happen; if the thing is in scope
-- at all it ought to have some availability
| not (maybeToBool maybe_avail)
= pprTrace "exportsFromAvail: curious Nothing:" (ppr name)
- returnRn export_avail_env
+ returnRn acc
#endif
| not enough_avail
- = failWithRn export_avail_env (exportItemErr ie export_avail)
+ = failWithRn acc (exportItemErr ie export_avail)
+
+ | otherwise -- Phew! It's OK! Now to check the occurrence stuff!
+ = check_occs ie occs export_avail `thenRn` \ occs' ->
+ returnRn (mods, occs', add_avail avails export_avail)
- | otherwise -- Phew! It's OK!
- = addAvailEnv opt_WarnDuplicateExports ie export_avail_env export_avail
where
- maybe_in_scope = lookupFM global_name_env (ieName ie)
- Just (name,_) = maybe_in_scope
+ rdr_name = ieName ie
+ maybe_in_scope = lookupFM global_name_env rdr_name
+ Just (name:dup_names) = maybe_in_scope
maybe_avail = lookupUFM entity_avail_env name
Just avail = maybe_avail
export_avail = filterAvail ie avail
enough_avail = case export_avail of {NotAvailable -> False; other -> True}
- -- We export a fixity iff we export a thing with the same (qualified) RdrName
- mk_exported_fixities :: NameSet -> [(OccName, Fixity)]
- mk_exported_fixities exports
- = fmToList (foldr (perhaps_add_fixity exports)
- emptyFM
- (fmToList fixity_env))
-
- perhaps_add_fixity :: NameSet -> (RdrName, (Fixity, HowInScope))
- -> FiniteMap OccName Fixity
- -> FiniteMap OccName Fixity
- perhaps_add_fixity exports (rdr_name, (fixity, how_in_scope)) fix_env
- = let
- do_nothing = fix_env -- The default is to pass on the env unchanged
- in
- -- Step 1: check whether the rdr_name is in scope; if so find its Name
- case lookupFM global_name_env rdr_name of {
- Nothing -> do_nothing;
- Just (fixity_name,_) ->
-
- -- Step 2: check whether the fixity thing is exported
- if not (fixity_name `elemNameSet` exports) then
- do_nothing
- else
-
- -- Step 3: check whether we already have a fixity for the
- -- Name's OccName in the fix_env we are building up. This can easily
- -- happen. the original fixity_env might contain bindings for
- -- M.a and N.a, if a was imported via M and N.
- -- If this does happen, we expect the fixity to be the same either way.
- let
- occ_name = rdrNameOcc rdr_name
- in
- case lookupFM fix_env occ_name of {
- Just fixity1 -> -- Got it already
- ASSERT( fixity == fixity1 )
- do_nothing;
- Nothing ->
-
- -- Step 3: add it to the outgoing fix_env
- addToFM fix_env occ_name fixity
- }}
-
-{- warn and weed out duplicate module entries from export list. -}
-checkForModuleExportDups :: [RdrNameIE] -> RnMG [RdrNameIE]
-checkForModuleExportDups ls
- | opt_WarnDuplicateExports = check_modules ls
- | otherwise = returnRn ls
+add_avail avails avail = addToNameEnv_C plusAvail avails (availName avail) avail
+
+check_occs :: RdrNameIE -> ExportOccMap -> AvailInfo -> RnMG ExportOccMap
+check_occs ie occs avail
+ = foldlRn check occs (availNames avail)
where
- -- NOTE: reorders the export list by moving all module-contents
- -- exports to the end (removing duplicates in the process.)
- check_modules ls =
- (case dups of
- [] -> returnRn ()
- ls -> mapRn (\ ds@(IEModuleContents x:_) ->
- addWarnRn (dupModuleExport x (length ds))) ls `thenRn_`
- returnRn ()) `thenRn_`
- returnRn (ls_no_modules ++ no_module_dups)
- where
- (ls_no_modules,modules) = foldr split_mods ([],[]) ls
-
- split_mods i@(IEModuleContents _) (no_ms,ms) = (no_ms,i:ms)
- split_mods i (no_ms,ms) = (i:no_ms,ms)
-
- (no_module_dups, dups) = removeDups cmp_mods modules
-
- cmp_mods (IEModuleContents m1) (IEModuleContents m2) = m1 `compare` m2
-
-mk_export_fn :: [AvailInfo] -> (Name -> ExportFlag)
-mk_export_fn avails
+ check occs name
+ = case lookupFM occs name_occ of
+ Nothing -> returnRn (addToFM occs name_occ (name, ie))
+ Just (name', ie')
+ | name == name' -> -- Duplicate export
+ warnCheckRn opt_WarnDuplicateExports
+ (dupExportWarn name_occ ie ie') `thenRn_`
+ returnRn occs
+
+ | otherwise -> -- Same occ name but different names: an error
+ failWithRn occs (exportClashErr name_occ ie ie')
+ where
+ name_occ = nameOccName name
+
+mk_export_fn :: NameSet -> (Name -> ExportFlag)
+mk_export_fn exported_names
= \name -> if name `elemNameSet` exported_names
then Exported
else NotExported
- where
- exported_names :: NameSet
- exported_names = availsToNameSet avails
\end{code}
%************************************************************************
4 (vcat [hsep [ptext SLIT("Wanted: "), ppr export_item],
hsep [ptext SLIT("Available:"), ppr (ieOcc export_item), pprAvail avail]])
-availClashErr (occ_name, ((ie1,avail1,_), (ie2,avail2,_)))
+exportClashErr occ_name ie1 ie2
= hsep [ptext SLIT("The export items"), quotes (ppr ie1), ptext SLIT("and"), quotes (ppr ie2),
ptext SLIT("create conflicting exports for"), quotes (ppr occ_name)]
-dupExportWarn (occ_name, (_,_,times))
+dupDeclErr (n:ns)
+ = vcat [ptext SLIT("Multiple declarations of") <+> quotes (ppr n),
+ nest 4 (vcat (map pp (n:ns)))]
+ where
+ pp n = pprProvenance (getNameProvenance n)
+
+dupExportWarn occ_name ie1 ie2
= hsep [quotes (ppr occ_name),
- ptext SLIT("mentioned"), speakNTimes (times+1),
- ptext SLIT("in export list")]
+ ptext SLIT("is exported by"), quotes (ppr ie1),
+ ptext SLIT("and"), quotes (ppr ie2)]
-dupModuleExport mod times
- = hsep [ptext SLIT("Module"), quotes (pprModule mod),
- ptext SLIT("mentioned"), speakNTimes times,
+dupModuleExport mod
+ = hsep [ptext SLIT("Duplicate"),
+ quotes (ptext SLIT("Module") <+> pprModule mod),
ptext SLIT("in export list")]
-\end{code}
+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}
_interface_ RnSource 1
_exports_
-RnSource rnHsSigType;
+RnSource rnHsType rnHsSigType;
_declarations_
1 rnHsSigType _:_ _forall_ [a] => (Outputable.SDoc)
-> RdrHsSyn.RdrNameHsType
- -> RnMonad.RnMS a RnHsSyn.RenamedHsType ;;
+ -> RnMonad.RnMS a (RnHsSyn.RenamedHsType, RnEnv.FreeVars) ;;
+1 rnHsType _:_ _forall_ [a] => (Outputable.SDoc)
+ -> RdrHsSyn.RdrNameHsType
+ -> RnMonad.RnMS a (RnHsSyn.RenamedHsType, RnEnv.FreeVars) ;;
\section[RnSource]{Main pass of renamer}
\begin{code}
-module RnSource ( rnDecl, rnHsSigType ) where
+module RnSource ( rnIfaceDecl, rnSourceDecls, rnHsType, rnHsSigType ) where
#include "HsVersions.h"
import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs )
import RnEnv ( bindTyVarsRn, lookupBndrRn, lookupOccRn,
lookupImplicitOccRn, addImplicitOccRn,
- bindLocalsRn,
- newDfunName, checkDupOrQualNames, checkDupNames,
+ bindLocalsRn,
+ bindTyVarsFVRn, bindTyVarsFV2Rn, extendTyVarEnvRn,
+ checkDupOrQualNames, checkDupNames,
newLocallyDefinedGlobalName, newImportedGlobalName,
- ifaceFlavour, listTyCon_name, tupleTyCon_name )
+ newImportedGlobalFromRdrName,
+ ifaceFlavour, newDFunName,
+ FreeVars, emptyFVs, plusFV, plusFVs, unitFV, addOneFV
+ )
import RnMonad
-import Name ( Name, OccName(..), occNameString, prefixOccName,
- ExportFlag(..), Provenance(..),
- nameOccName, NamedThing(..), isLexCon,
- mkDefaultMethodName
+import Name ( Name, OccName,
+ ExportFlag(..), Provenance(..),
+ nameOccName, NamedThing(..), isConOcc,
+ mkDefaultMethodOcc, mkDFunOcc
)
import NameSet
-import BasicTypes ( TopLevelFlag(..) )
+import BasicTypes ( TopLevelFlag(..), IfaceFlavour(..) )
+import TysWiredIn ( tupleTyCon, unboxedTupleTyCon, listTyCon )
+import Type ( funTyCon )
import FiniteMap ( elemFM )
import PrelInfo ( derivingOccurrences, numClass_RDR,
deRefStablePtr_NAME, makeStablePtr_NAME,
%*********************************************************
\begin{code}
-rnDecl :: RdrNameHsDecl -> RnMS s RenamedHsDecl
+rnSourceDecls :: [RdrNameHsDecl] -> RnMS s ([RenamedHsDecl], FreeVars)
+ -- The decls get reversed, but that's ok
-rnDecl (ValD binds) = rnTopBinds binds `thenRn` \ new_binds ->
- returnRn (ValD new_binds)
+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
+
+rnIfaceDecl :: RdrNameHsDecl -> RnMS s RenamedHsDecl
+rnIfaceDecl d
+ = rnDecl d `thenRn` \ (d', fvs) ->
+ returnRn d'
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Value declarations}
+%* *
+%*********************************************************
+
+\begin{code}
+-- rnDecl does all the work
+rnDecl :: RdrNameHsDecl -> RnMS s (RenamedHsDecl, FreeVars)
+
+rnDecl (ValD binds) = rnTopBinds binds `thenRn` \ (new_binds, fvs) ->
+ returnRn (ValD new_binds, fvs)
rnDecl (SigD (IfaceSig name ty id_infos loc))
= pushSrcLocRn loc $
lookupBndrRn name `thenRn` \ name' ->
- rnHsType doc_str ty `thenRn` \ ty' ->
+ rnIfaceType doc_str ty `thenRn` \ ty' ->
-- Get the pragma info (if any).
- getModeRn `thenRn` \ (InterfaceMode _ print_unqual) ->
- setModeRn (InterfaceMode Optional print_unqual) $
+ setModeRn (InterfaceMode Optional) $
-- In all the rest of the signature we read in optional mode,
-- so that (a) we don't die
mapRn rnIdInfo id_infos `thenRn` \ id_infos' ->
- returnRn (SigD (IfaceSig name' ty' id_infos' loc))
+ returnRn (SigD (IfaceSig name' ty' id_infos' loc), emptyFVs)
+ -- Don't need free-var info for iface binds
where
doc_str = text "the interface signature for" <+> quotes (ppr name)
\end{code}
checks at the same time.
\begin{code}
-rnDecl (TyD (TyData new_or_data context tycon tyvars condecls derivings pragmas src_loc))
+rnDecl (TyClD (TyData new_or_data context tycon tyvars condecls derivings pragmas src_loc))
= pushSrcLocRn src_loc $
lookupBndrRn tycon `thenRn` \ tycon' ->
- bindTyVarsRn data_doc tyvars $ \ tyvars' ->
- rnContext data_doc context `thenRn` \ context' ->
+ bindTyVarsFVRn data_doc tyvars $ \ tyvars' ->
+ rnContext data_doc context `thenRn` \ (context', cxt_fvs) ->
checkDupOrQualNames data_doc con_names `thenRn_`
- mapRn rnConDecl condecls `thenRn` \ condecls' ->
- rnDerivs derivings `thenRn` \ derivings' ->
+ mapAndUnzipRn rnConDecl condecls `thenRn` \ (condecls', con_fvs_s) ->
+ rnDerivs derivings `thenRn` \ (derivings', deriv_fvs) ->
ASSERT(isNoDataPragmas pragmas)
- returnRn (TyD (TyData new_or_data context' tycon' tyvars' condecls' derivings' noDataPragmas src_loc))
+ returnRn (TyClD (TyData new_or_data context' tycon' tyvars' condecls' derivings' noDataPragmas src_loc),
+ cxt_fvs `plusFV` plusFVs con_fvs_s `plusFV` deriv_fvs)
where
- data_doc = text "the data type declaration for" <+> ppr tycon
+ data_doc = text "the data typecodeGen/ declaration for" <+> ppr tycon
con_names = map conDeclName condecls
-rnDecl (TyD (TySynonym name tyvars ty src_loc))
+rnDecl (TyClD (TySynonym name tyvars ty src_loc))
= pushSrcLocRn src_loc $
lookupBndrRn name `thenRn` \ name' ->
- bindTyVarsRn syn_doc tyvars $ \ tyvars' ->
- rnHsType syn_doc ty `thenRn` \ ty' ->
- returnRn (TyD (TySynonym name' tyvars' ty' src_loc))
+ bindTyVarsFVRn syn_doc tyvars $ \ tyvars' ->
+ rnHsType syn_doc 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)
-\end{code}
-%*********************************************************
-%* *
-\subsection{Class declarations}
-%* *
-%*********************************************************
-
-@rnClassDecl@ uses the `global name function' to create a new
-class declaration in which local names have been replaced by their
-original names, reporting any unknown names.
-
-\begin{code}
-rnDecl (ClD (ClassDecl context cname tyvars sigs mbinds pragmas tname dname src_loc))
+rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas tname dname src_loc))
= pushSrcLocRn src_loc $
lookupBndrRn cname `thenRn` \ cname' ->
- lookupBndrRn tname `thenRn` \ tname' ->
- lookupBndrRn dname `thenRn` \ dname' ->
- bindTyVarsRn cls_doc tyvars ( \ tyvars' ->
- rnContext cls_doc context `thenRn` \ context' ->
+ -- Deal with the implicit tycon and datacon name
+ -- They aren't in scope (because they aren't visible to the user)
+ -- and what we want to do is simply look them up in the cache;
+ -- we jolly well ought to get a 'hit' there!
+ -- So the 'Imported' part of this call is not relevant.
+ -- Unclean; but since these two are the only place this happens
+ -- I can't work up the energy to do it more beautifully
+ newImportedGlobalFromRdrName tname `thenRn` \ tname' ->
+ newImportedGlobalFromRdrName dname `thenRn` \ dname' ->
- -- Check the signatures
- let
- clas_tyvar_names = map getTyVarName tyvars'
- in
- checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenRn_`
- mapRn (rn_op cname' clas_tyvar_names) sigs `thenRn` \ sigs' ->
- returnRn (tyvars', context', sigs')
- ) `thenRn` \ (tyvars', context', sigs') ->
+ -- Tyvars scope over bindings and context
+ bindTyVarsFV2Rn cls_doc tyvars ( \ clas_tyvar_names tyvars' ->
+
+ -- Check the superclasses
+ rnContext cls_doc context `thenRn` \ (context', cxt_fvs) ->
+
+ -- Check the signatures
+ let
+ -- Filter out fixity signatures;
+ -- they are done at top level
+ nofix_sigs = nonFixitySigs sigs
+ in
+ checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenRn_`
+ mapAndUnzipRn (rn_op cname' clas_tyvar_names) nofix_sigs `thenRn` \ (sigs', sig_fvs_s) ->
-- Check the methods
checkDupOrQualNames meth_doc meth_rdr_names_w_locs `thenRn_`
- rnMethodBinds mbinds `thenRn` \ mbinds' ->
+ rnMethodBinds mbinds `thenRn` \ (mbinds', meth_fvs) ->
-- Typechecker is responsible for checking that we only
-- give default-method bindings for things in this class.
-- for instance decls.
ASSERT(isNoClassPragmas pragmas)
- returnRn (ClD (ClassDecl context' cname' tyvars' sigs' mbinds' NoClassPragmas tname' dname' src_loc))
+ returnRn (TyClD (ClassDecl context' cname' tyvars' sigs' mbinds' NoClassPragmas tname' dname' src_loc),
+ plusFVs sig_fvs_s `plusFV` cxt_fvs `plusFV` meth_fvs)
+ )
where
cls_doc = text "the declaration for class" <+> ppr cname
sig_doc = text "the signatures for class" <+> ppr cname
rn_op clas clas_tyvars sig@(ClassOpSig op maybe_dm ty locn)
= pushSrcLocRn locn $
lookupBndrRn op `thenRn` \ op_name ->
- rnHsSigType (quotes (ppr op)) ty `thenRn` \ new_ty ->
+
+ -- Check the signature
+ rnHsSigType (quotes (ppr op)) ty `thenRn` \ (new_ty, op_ty_fvs) ->
+ let
+ check_in_op_ty clas_tyvar = checkRn (clas_tyvar `elemNameSet` op_ty_fvs)
+ (classTyVarNotInOpTyErr clas_tyvar sig)
+ in
+ mapRn check_in_op_ty clas_tyvars `thenRn_`
-- Make the default-method name
let
- dm_occ = mkDefaultMethodName (rdrNameOcc op)
+ dm_occ = mkDefaultMethodOcc (rdrNameOcc op)
in
getModuleRn `thenRn` \ mod_name ->
getModeRn `thenRn` \ mode ->
(\_ -> Exported) locn `thenRn` \ dm_name ->
returnRn (Just dm_name)
- (InterfaceMode _ _, Just _)
+ (InterfaceMode _, Just _)
-> -- Imported class that has a default method decl
newImportedGlobalName mod_name dm_occ (ifaceFlavour clas) `thenRn` \ dm_name ->
addOccurrenceName dm_name `thenRn_`
other -> returnRn Nothing
) `thenRn` \ maybe_dm_name ->
- -- Check that each class tyvar appears in op_ty
- let
- (ctxt, op_ty) = case new_ty of
- HsForAllTy tvs ctxt op_ty -> (ctxt, op_ty)
- other -> ([], new_ty)
- ctxt_fvs = extractHsCtxtTyNames ctxt -- Includes tycons/classes but we
- op_ty_fvs = extractHsTyNames op_ty -- don't care about that
- check_in_op_ty clas_tyvar = checkRn (clas_tyvar `elemNameSet` op_ty_fvs)
- (classTyVarNotInOpTyErr clas_tyvar sig)
- in
- mapRn check_in_op_ty clas_tyvars `thenRn_`
-
- returnRn (ClassOpSig op_name maybe_dm_name new_ty locn)
+ returnRn (ClassOpSig op_name maybe_dm_name new_ty locn, op_ty_fvs)
\end{code}
\begin{code}
rnDecl (InstD (InstDecl inst_ty mbinds uprags maybe_dfun src_loc))
= pushSrcLocRn src_loc $
- rnHsSigType (text "an instance decl") inst_ty `thenRn` \ inst_ty' ->
-
+ rnHsSigType (text "an instance decl") inst_ty `thenRn` \ (inst_ty', inst_fvs) ->
+ let
+ inst_tyvars = case inst_ty' of
+ HsForAllTy inst_tyvars _ _ -> inst_tyvars
+ other -> []
+ -- (Slightly strangely) the forall-d tyvars scope over
+ -- the method bindings too
+ in
+ extendTyVarEnvRn inst_tyvars $
-- Rename the bindings
-- NB meth_names can be qualified!
checkDupNames meth_doc meth_names `thenRn_`
- rnMethodBinds mbinds `thenRn` \ mbinds' ->
+ rnMethodBinds mbinds `thenRn` \ (mbinds', meth_fvs) ->
let
binders = mkNameSet (map fst (bagToList (collectMonoBinders mbinds')))
in
renameSigs NotTopLevel True binders uprags `thenRn` \ new_uprags ->
-
- let
- -- We use the class name and the name of the first
- -- type constructor the class is applied to.
- (cl_nm, tycon_nm) = mkDictPrefix inst_ty'
-
- mkDictPrefix (MonoDictTy cl tys) =
- case tys of
- [] -> (c_nm, nilOccName )
- (ty:_) -> (c_nm, getInstHeadTy ty)
- where
- c_nm = nameOccName (getName cl)
-
- mkDictPrefix (HsForAllTy _ _ ty) = mkDictPrefix ty -- can this
- mkDictPrefix _ = (nilOccName, nilOccName)
-
- getInstHeadTy t
- = case t of
- MonoTyVar tv -> nameOccName (getName tv)
- MonoTyApp t _ -> getInstHeadTy t
- _ -> nilOccName
- -- I cannot see how the rest of HsType constructors
- -- can occur, but this isn't really a failure condition,
- -- so we return silently.
-
- nilOccName = (VarOcc _NIL_) -- ToDo: add OccName constructor fun for this.
- in
- newDfunName cl_nm tycon_nm maybe_dfun src_loc `thenRn` \ dfun_name ->
- addOccurrenceName dfun_name `thenRn_`
+ mkDFunName inst_ty' maybe_dfun src_loc `thenRn` \ dfun_name ->
+ addOccurrenceName dfun_name `thenRn_`
-- The dfun is not optional, because we use its version number
-- to identify the version of the instance declaration
-- The typechecker checks that all the bindings are for the right class.
- returnRn (InstD (InstDecl inst_ty' mbinds' new_uprags (Just dfun_name) src_loc))
+ returnRn (InstD (InstDecl inst_ty' mbinds' new_uprags (Just dfun_name) src_loc),
+ inst_fvs `plusFV` meth_fvs)
where
meth_doc = text "the bindings in an instance declaration"
meth_names = bagToList (collectMonoBinders mbinds)
\begin{code}
rnDecl (DefD (DefaultDecl tys src_loc))
= pushSrcLocRn src_loc $
- mapRn (rnHsType doc_str) tys `thenRn` \ tys' ->
+ rnHsTypes doc_str tys `thenRn` \ (tys', fvs) ->
lookupImplicitOccRn numClass_RDR `thenRn_`
- returnRn (DefD (DefaultDecl tys' src_loc))
+ returnRn (DefD (DefaultDecl tys' src_loc), fvs)
where
doc_str = text "a `default' declaration"
\end{code}
addImplicitOccRn bindIO_NAME `thenRn_`
returnRn name'
_ -> returnRn name') `thenRn_`
- rnHsSigType fo_decl_msg ty `thenRn` \ ty' ->
- returnRn (ForD (ForeignDecl name' imp_exp ty' ext_nm cconv src_loc))
+ rnHsSigType fo_decl_msg ty `thenRn` \ (ty', fvs) ->
+ returnRn (ForD (ForeignDecl name' imp_exp ty' ext_nm cconv src_loc), fvs)
where
fo_decl_msg = ptext SLIT("a foreign declaration")
isDyn = isDynamic ext_nm
%*********************************************************
\begin{code}
-rnDerivs :: Maybe [RdrName] -> RnMS s (Maybe [Name])
+rnDerivs :: Maybe [RdrName] -> RnMS s (Maybe [Name], FreeVars)
rnDerivs Nothing -- derivs not specified
- = returnRn Nothing
+ = returnRn (Nothing, emptyFVs)
rnDerivs (Just ds)
= mapRn rn_deriv ds `thenRn` \ derivs ->
- returnRn (Just derivs)
+ returnRn (Just derivs, mkNameSet derivs)
where
rn_deriv clas
= lookupOccRn clas `thenRn` \ clas_name ->
Just occs -> mapRn lookupImplicitOccRn occs `thenRn_`
returnRn clas_name
+
\end{code}
\begin{code}
conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc)
conDeclName (ConDecl n _ _ _ l) = (n,l)
-rnConDecl :: RdrNameConDecl -> RnMS s RenamedConDecl
+rnConDecl :: RdrNameConDecl -> RnMS s (RenamedConDecl, FreeVars)
rnConDecl (ConDecl name tvs cxt details locn)
= pushSrcLocRn locn $
checkConName name `thenRn_`
lookupBndrRn name `thenRn` \ new_name ->
- bindTyVarsRn doc tvs $ \ new_tyvars ->
- rnContext doc cxt `thenRn` \ new_context ->
- rnConDetails doc locn details `thenRn` \ new_details ->
- returnRn (ConDecl new_name new_tyvars new_context new_details locn)
+ bindTyVarsFVRn doc tvs $ \ new_tyvars ->
+ rnContext doc cxt `thenRn` \ (new_context, cxt_fvs) ->
+ rnConDetails doc locn details `thenRn` \ (new_details, det_fvs) ->
+ returnRn (ConDecl new_name new_tyvars new_context new_details locn,
+ cxt_fvs `plusFV` det_fvs)
where
doc = text "the definition of data constructor" <+> quotes (ppr name)
rnConDetails doc locn (VanillaCon tys)
- = mapRn (rnBangTy doc) tys `thenRn` \ new_tys ->
- returnRn (VanillaCon new_tys)
+ = mapAndUnzipRn (rnBangTy doc) tys `thenRn` \ (new_tys, fvs_s) ->
+ returnRn (VanillaCon new_tys, plusFVs fvs_s)
rnConDetails doc locn (InfixCon ty1 ty2)
- = rnBangTy doc ty1 `thenRn` \ new_ty1 ->
- rnBangTy doc ty2 `thenRn` \ new_ty2 ->
- returnRn (InfixCon new_ty1 new_ty2)
+ = rnBangTy doc ty1 `thenRn` \ (new_ty1, fvs1) ->
+ rnBangTy doc ty2 `thenRn` \ (new_ty2, fvs2) ->
+ returnRn (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2)
rnConDetails doc locn (NewCon ty)
- = rnHsType doc ty `thenRn` \ new_ty ->
- returnRn (NewCon new_ty)
+ = rnHsType doc ty `thenRn` \ (new_ty, fvs) ->
+ returnRn (NewCon new_ty, fvs)
rnConDetails doc locn (RecCon fields)
= checkDupOrQualNames doc field_names `thenRn_`
- mapRn (rnField doc) fields `thenRn` \ new_fields ->
- returnRn (RecCon new_fields)
+ mapAndUnzipRn (rnField doc) fields `thenRn` \ (new_fields, fvs_s) ->
+ returnRn (RecCon new_fields, plusFVs fvs_s)
where
field_names = [(fld, locn) | (flds, _) <- fields, fld <- flds]
rnField doc (names, ty)
= mapRn lookupBndrRn names `thenRn` \ new_names ->
- rnBangTy doc ty `thenRn` \ new_ty ->
- returnRn (new_names, new_ty)
+ rnBangTy doc ty `thenRn` \ (new_ty, fvs) ->
+ returnRn ((new_names, new_ty), fvs)
rnBangTy doc (Banged ty)
- = rnHsType doc ty `thenRn` \ new_ty ->
- returnRn (Banged new_ty)
+ = rnHsType doc ty `thenRn` \ (new_ty, fvs) ->
+ returnRn (Banged new_ty, fvs)
rnBangTy doc (Unbanged ty)
- = rnHsType doc ty `thenRn` \ new_ty ->
- returnRn (Unbanged new_ty)
+ = rnHsType doc ty `thenRn` \ (new_ty, fvs) ->
+ returnRn (Unbanged new_ty, fvs)
-- This data decl will parse OK
-- data T = a Int
-- from interface files, which always print in prefix form
checkConName name
- = checkRn (isLexCon (occNameString (rdrNameOcc name)))
+ = checkRn (isConOcc (rdrNameOcc name))
(badDataCon name)
\end{code}
%*********************************************************
%* *
-\subsection{Support code to rename types}
+\subsection{Naming a dfun}
%* *
%*********************************************************
+Make a name for the dict fun for an instance decl
+
\begin{code}
-rnHsSigType :: SDoc -> RdrNameHsType -> RnMS s RenamedHsType
- -- rnHsSigType is used for source-language type signatures,
- -- which use *implicit* universal quantification.
-rnHsSigType doc_str ty = rnHsType (text "the type signature for" <+> doc_str) ty
+mkDFunName :: RenamedHsType -- Instance type
+ -> Maybe RdrName -- Dfun thing from decl; Nothing <=> source
+ -> SrcLoc
+ -> RnMS s Name
+mkDFunName inst_ty maybe_df src_loc
+ = newDFunName cl_occ tycon_occ maybe_df src_loc
+ where
+ (cl_occ, tycon_occ) = get_key inst_ty
+
+ get_key (HsForAllTy _ _ ty) = get_key ty
+ get_key (MonoFunTy _ ty) = get_key ty
+ get_key (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
+\end{code}
+%*********************************************************
+%* *
+\subsection{Support code to rename types}
+%* *
+%*********************************************************
+
+\begin{code}
+rnHsSigType :: SDoc -> RdrNameHsType -> RnMS s (RenamedHsType, FreeVars)
+ -- rnHsSigType is used for source-language type signatures,
+ -- which use *implicit* universal quantification.
+rnHsSigType doc_str ty
+ = rnHsType (text "the type signature for" <+> doc_str) ty
+
+rnIfaceType :: SDoc -> RdrNameHsType -> RnMS s RenamedHsType
+rnIfaceType doc ty
+ = rnHsType doc ty `thenRn` \ (ty,_) ->
+ returnRn ty
-rnHsType :: SDoc -> RdrNameHsType -> RnMS s RenamedHsType
+rnHsType :: SDoc -> RdrNameHsType -> RnMS s (RenamedHsType, FreeVars)
rnHsType doc (HsForAllTy [] ctxt ty)
-- From source code (no kinds on tyvars)
mapRn (ctxtErr1 doc forall_tyvars ty) non_poly_constraints `thenRn_`
mapRn (ctxtErr2 doc ty) non_mentioned_constraints `thenRn_`
- (bindTyVarsRn doc (map UserTyVar forall_tyvars) $ \ new_tyvars ->
- rnContext doc ctxt' `thenRn` \ new_ctxt ->
- rnHsType doc ty `thenRn` \ new_ty ->
- returnRn (mkHsForAllTy new_tyvars new_ctxt new_ty))
+ (bindTyVarsFVRn doc (map UserTyVar forall_tyvars) $ \ new_tyvars ->
+ rnContext doc ctxt' `thenRn` \ (new_ctxt, cxt_fvs) ->
+ rnHsType doc ty `thenRn` \ (new_ty, ty_fvs) ->
+ returnRn (mkHsForAllTy new_tyvars new_ctxt new_ty,
+ cxt_fvs `plusFV` ty_fvs)
+ )
rnHsType doc (HsForAllTy tvs ctxt ty)
-- tvs are non-empty, hence must be from an interface file
-- (tyvars may be kinded)
- = bindTyVarsRn doc tvs $ \ new_tyvars ->
- rnContext doc ctxt `thenRn` \ new_ctxt ->
- rnHsType doc ty `thenRn` \ new_ty ->
- returnRn (mkHsForAllTy new_tyvars new_ctxt new_ty)
-
+ = bindTyVarsFVRn doc tvs $ \ new_tyvars ->
+ rnContext doc ctxt `thenRn` \ (new_ctxt, cxt_fvs) ->
+ rnHsType doc ty `thenRn` \ (new_ty, ty_fvs) ->
+ returnRn (mkHsForAllTy new_tyvars new_ctxt new_ty,
+ cxt_fvs `plusFV` ty_fvs)
rnHsType doc (MonoTyVar tyvar)
= lookupOccRn tyvar `thenRn` \ tyvar' ->
- returnRn (MonoTyVar tyvar')
+ returnRn (MonoTyVar tyvar', unitFV tyvar')
rnHsType doc (MonoFunTy ty1 ty2)
- = andRn MonoFunTy (rnHsType doc ty1) (rnHsType doc ty2)
+ = rnHsType doc ty1 `thenRn` \ (ty1', fvs1) ->
+ rnHsType doc ty2 `thenRn` \ (ty2', fvs2) ->
+ returnRn (MonoFunTy ty1' ty2', fvs1 `plusFV` fvs2)
rnHsType doc (MonoListTy ty)
= addImplicitOccRn listTyCon_name `thenRn_`
- rnHsType doc ty `thenRn` \ ty' ->
- returnRn (MonoListTy ty')
+ rnHsType doc ty `thenRn` \ (ty', fvs) ->
+ returnRn (MonoListTy ty', fvs `addOneFV` listTyCon_name)
rnHsType doc (MonoTupleTy tys boxed)
- = addImplicitOccRn (tupleTyCon_name boxed (length tys)) `thenRn_`
- mapRn (rnHsType doc) tys `thenRn` \ tys' ->
- returnRn (MonoTupleTy tys' boxed)
+ = addImplicitOccRn tup_con_name `thenRn_`
+ rnHsTypes 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' ->
- rnHsType doc ty2 `thenRn` \ ty2' ->
- returnRn (MonoTyApp ty1' ty2')
+ = rnHsType doc ty1 `thenRn` \ (ty1', fvs1) ->
+ rnHsType doc ty2 `thenRn` \ (ty2', fvs2) ->
+ returnRn (MonoTyApp ty1' ty2', fvs1 `plusFV` fvs2)
rnHsType doc (MonoDictTy clas tys)
= lookupOccRn clas `thenRn` \ clas' ->
- mapRn (rnHsType doc) tys `thenRn` \ tys' ->
- returnRn (MonoDictTy clas' tys')
+ rnHsTypes doc tys `thenRn` \ (tys', fvs) ->
+ returnRn (MonoDictTy clas' tys', fvs `addOneFV` clas')
+
+rnHsTypes doc tys
+ = mapAndUnzipRn (rnHsType doc) tys `thenRn` \ (tys, fvs_s) ->
+ returnRn (tys, plusFVs fvs_s)
\end{code}
\begin{code}
-rnContext :: SDoc -> RdrNameContext -> RnMS s RenamedContext
+rnContext :: SDoc -> RdrNameContext -> RnMS s (RenamedContext, FreeVars)
rnContext doc ctxt
- = mapRn rn_ctxt ctxt `thenRn` \ theta ->
+ = mapAndUnzipRn rn_ctxt ctxt `thenRn` \ (theta, fvs_s) ->
let
(_, dup_asserts) = removeDups cmp_assert theta
in
-- If this isn't an error, then it ought to be:
mapRn (addWarnRn . dupClassAssertWarn theta) dup_asserts `thenRn_`
- returnRn theta
+ returnRn (theta, plusFVs fvs_s)
where
rn_ctxt (clas, tys)
- = lookupBndrRn clas `thenRn` \ clas_name ->
- addOccurrenceName clas_name `thenRn_`
- mapRn (rnHsType doc) tys `thenRn` \ tys' ->
- returnRn (clas_name, tys')
+ = lookupOccRn clas `thenRn` \ clas_name ->
+ rnHsTypes doc tys `thenRn` \ (tys', fvs) ->
+ returnRn ((clas_name, tys'), fvs `addOneFV` clas_name)
cmp_assert (c1,tys1) (c2,tys2)
= (c1 `compare` c2) `thenCmp` (cmpHsTypes compare tys1 tys2)
rnIdInfo (HsSpecialise tyvars tys expr)
= bindTyVarsRn doc tyvars $ \ tyvars' ->
rnCoreExpr expr `thenRn` \ expr' ->
- mapRn (rnHsType doc) tys `thenRn` \ tys' ->
+ mapRn (rnIfaceType doc) tys `thenRn` \ tys' ->
returnRn (HsSpecialise tyvars' tys' expr')
where
doc = text "Specialise in interface pragma"
\begin{code}
rnCoreExpr (UfType ty)
- = rnHsType (text "unfolding type") ty `thenRn` \ ty' ->
+ = rnIfaceType (text "unfolding type") ty `thenRn` \ ty' ->
returnRn (UfType ty')
rnCoreExpr (UfVar v)
\begin{code}
rnCoreBndr (UfValBinder name ty) thing_inside
- = rnHsType (text str) ty `thenRn` \ ty' ->
+ = rnIfaceType (text str) ty `thenRn` \ ty' ->
bindLocalsRn str [name] $ \ [name'] ->
thing_inside (UfValBinder name' ty')
where
thing_inside (UfTyBinder name' kind)
rnCoreBndrs bndrs thing_inside -- Expect them all to be ValBinders
- = mapRn (rnHsType (text str)) tys `thenRn` \ tys' ->
+ = mapRn (rnIfaceType (text str)) tys `thenRn` \ tys' ->
bindLocalsRn str names $ \ names' ->
thing_inside (zipWith UfValBinder names' tys')
where
rnNote (UfCoerce ty)
- = rnHsType (text "unfolding coerce") ty `thenRn` \ ty' ->
+ = rnIfaceType (text "unfolding coerce") ty `thenRn` \ ty' ->
returnRn (UfCoerce ty')
rnNote (UfSCC cc) = returnRn (UfSCC cc)
= returnRn (UfLitCon lit)
rnUfCon (UfLitLitCon lit ty)
- = rnHsType (text "litlit") ty `thenRn` \ ty' ->
+ = rnIfaceType (text "litlit") ty `thenRn` \ ty' ->
returnRn (UfLitLitCon lit ty')
rnUfCon (UfPrimOp op)
-- Just a stub for now
import CoreSyn ( CoreBind )
-import Util ( panic )
+import Panic ( panic )
--import Util
--import Id ( addIdFBTypeInfo )
#include "HsVersions.h"
import IdInfo ( InlinePragInfo(..), OccInfo(..) )
-import Util ( panic )
import GlaExts ( Int(..), (+#) )
import Outputable
\end{code}
(i1 + i2) only if it results in a valid Float.
\begin{code}
-module ConFold ( cleverMkPrimApp ) where
+module ConFold ( tryPrimOp ) where
#include "HsVersions.h"
\end{code}
\begin{code}
-cleverMkPrimApp :: PrimOp -> [CoreArg] -> CoreExpr
+tryPrimOp :: PrimOp -> [CoreArg] -- op arg1 ... argn
+ -- Args are already simplified
+ -> Maybe CoreExpr -- Nothing => no transformation
+ -- Just e => transforms to e
\end{code}
In the parallel world, we use _seq_ to control the order in which
The second case must never be floated outside of the first!
\begin{code}p
-cleverMkPrimApp SeqOp [Type ty, Con (Literal lit) _]
- = Con (Literal (mkMachInt 1)) []
+tryPrimOp SeqOp [Type ty, Con (Literal lit) _]
+ = Just (Con (Literal (mkMachInt 1)) [])
-cleverMkPrimApp SeqOp args@[Type ty, Var var]
- | isEvaluated (getIdUnfolding var) = Con (Literal (mkMachInt 1)) []) -- var is eval'd
- | otherwise = Con (PrimOp op) args -- var not eval'd
+tryPrimOp SeqOp args@[Type ty, Var var]
+ | isEvaluated (getIdUnfolding var) = Just (Con (Literal (mkMachInt 1)) [])) -- var is eval'd
+ | otherwise = Nothing -- var not eval'd
\end{code}
\begin{code}
-cleverMkPrimApp op args
+tryPrimOp op args
= case args of
[Con (Literal (MachChar char_lit)) _] -> oneCharLit op char_lit
[Con (Literal (MachInt int_lit signed)) _] -> (if signed then oneIntLit else oneWordLit)
other -> give_up
where
- give_up = Con (PrimOp op) args
+ give_up = Nothing
- return_char c = Con (Literal (MachChar c)) []
- return_int i = Con (Literal (mkMachInt i)) []
- return_word i = Con (Literal (mkMachWord i)) []
- return_float f = Con (Literal (MachFloat f)) []
- return_double d = Con (Literal (MachDouble d)) []
- return_lit lit = Con (Literal lit) []
+ return_char c = Just (Con (Literal (MachChar c)) [])
+ return_int i = Just (Con (Literal (mkMachInt i)) [])
+ return_word i = Just (Con (Literal (mkMachWord i)) [])
+ return_float f = Just (Con (Literal (MachFloat f)) [])
+ return_double d = Just (Con (Literal (MachDouble d)) [])
+ return_lit lit = Just (Con (Literal lit) [])
- return_bool True = trueVal
- return_bool False = falseVal
+ return_bool True = Just trueVal
+ return_bool False = Just falseVal
return_prim_case var lit val_if_eq val_if_neq
- = Case (Var var) var [(Literal lit, [], val_if_eq),
- (DEFAULT, [], val_if_neq)]
+ = Just (Case (Var var) var [(Literal lit, [], val_if_eq),
+ (DEFAULT, [], val_if_neq)])
--------- Ints --------------
oneIntLit IntNegOp i = return_int (-i)
litVar other_op lit var = give_up
- checkRange :: Integer -> CoreExpr
+ checkRange :: Integer -> Maybe CoreExpr
checkRange val
| (val > fromInt maxInt) || (val < fromInt minInt) =
-- Better tell the user that we've overflowed...
-- Just a stub for now
import CoreSyn ( CoreBind )
import UniqSupply ( UniqSupply )
-import Util ( panic )
+import Panic ( panic )
--import Type ( cloneTyVarFromTemplate, mkTyVarTy,
-- splitFunTyExpandingDicts, eqTyCon, mkForallTy )
import Type ( mkFunTys )
import TysWiredIn ( mkListTy )
import Unique ( Unique{-instances-} )
-import Util ( assoc, zipWith3Equal, nOfThem, panic )
+import Util ( assoc, zipWith3Equal, nOfThem )
+import Panic ( panic )
\end{code}
%************************************************************************
#include "HsVersions.h"
-import Util ( panic )
+import Panic ( panic )
doStaticArgs = panic "SAT.doStaticArgs (ToDo)"
#include "HsVersions.h"
-import Util ( panic )
+import Panic ( panic )
junk_from_SATMonad = panic "SATMonad.junk"
-- top-level or exported somehow.)
-- A better fix is to use binder directly but with the TopLevel
-- tag (or Exported tag) modified.
- fake_binder = mkSysLocal
+ fake_binder = mkSysLocal SLIT("sat")
(getUnique binder)
(idType binder)
rec_body = mkValLam non_static_args
import CoreUtils ( coreExprType, exprIsTrivial, idFreeVars, exprIsBottom
)
import FreeVars -- all of it
-import Id ( Id, idType, mkUserLocal )
-import Name ( varOcc )
+import Id ( Id, idType, mkSysLocal )
import Var ( IdOrTyVar )
import VarEnv
import VarSet
import UniqSupply ( initUs, thenUs, returnUs, mapUs, mapAndUnzipUs, getUniqueUs,
mapAndUnzip3Us, UniqSM, UniqSupply )
import Maybes ( maybeToBool )
-import Util ( zipWithEqual, zipEqual, panic, assertPanic )
+import Util ( zipWithEqual, zipEqual )
import Outputable
isLeakFreeType x y = False -- safe option; ToDo
\begin{code}
newLvlVar :: Type -> LvlM Id
newLvlVar ty = getUniqueUs `thenLvl` \ uniq ->
- returnUs (mkUserLocal (varOcc SLIT("lvl")) uniq ty)
+ returnUs (mkSysLocal SLIT("lvl") uniq ty)
\end{code}
import ErrUtils ( dumpIfSet )
import FloatIn ( floatInwards )
import FloatOut ( floatOutwards )
-import Id ( Id, mkSysLocal, mkUserId,
- setIdVisibility, setIdUnfolding,
- getIdSpecialisation, setIdSpecialisation,
- getInlinePragma, setInlinePragma,
- idType, setIdType
+import Id ( Id, mkSysLocal, mkUserId, isBottomingId,
+ idType, setIdType, idName, idInfo, idDetails
+ )
+import IdInfo ( InlinePragInfo(..), specInfo, setSpecInfo,
+ inlinePragInfo, setInlinePragInfo,
+ setUnfoldingInfo
)
-import IdInfo ( InlinePragInfo(..) )
import VarEnv
import VarSet
-import Name ( isExported, mkSysLocalName,
- Module, NamedThing(..), OccName(..)
+import Name ( mkLocalName, tidyOccName, tidyTopName, initTidyOccEnv, isExported,
+ Module, NamedThing(..), OccName
)
import TyCon ( TyCon, isDataTyCon )
import PrimOp ( PrimOp(..) )
int2IntegerId, addr2IntegerId
)
import Type ( Type, splitAlgTyConApp_maybe,
- isUnLiftedType, mkTyVarTy, Type )
+ isUnLiftedType, mkTyVarTy,
+ tidyType, tidyTypes, tidyTopType, tidyTyVar, tidyTyVars,
+ Type
+ )
+import Class ( Class, classSelIds )
import TysWiredIn ( isIntegerTy )
import LiberateCase ( liberateCase )
-import PprType ( nmbrType )
import SAT ( doStaticArgs )
import Specialise ( specProgram)
import SpecEnv ( specEnvToList, specEnvFromList )
import StrictAnal ( saWwTopBinds )
-import Var ( TyVar, setTyVarName )
+import Var ( TyVar, mkId )
import Unique ( Unique, Uniquable(..),
ratioTyConKey, mkUnique, incrUnique, initTidyUniques
)
-import UniqSupply ( UniqSupply, splitUniqSupply )
+import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply )
import Constants ( tARGET_MIN_INT, tARGET_MAX_INT )
+import Util ( mapAccumL )
import Bag
import Maybes
import IO ( hPutStr, stderr )
\begin{code}
core2core :: [CoreToDo] -- Spec of what core-to-core passes to do
- -> FAST_STRING -- Module name (profiling only)
+ -> Module -- Module name (profiling only)
+ -> [Class] -- Local classes
-> UniqSupply -- A name supply
-> [CoreBind] -- Input
-> IO [CoreBind] -- Result
-core2core core_todos module_name us binds
+core2core core_todos module_name classes us binds
= do
+ let (us1, us2) = splitUniqSupply us
+
-- Do the main business
- processed_binds <- doCorePasses us binds core_todos
+ processed_binds <- doCorePasses us1 binds core_todos
+
+ -- Do the post-simplification business
+ post_simpl_binds <- doPostSimplification us2 processed_binds
-- Do the final tidy-up
- final_binds <- tidyCorePgm module_name processed_binds
+ final_binds <- tidyCorePgm module_name classes post_simpl_binds
-- Return results
return final_binds
%************************************************************************
%* *
-\subsection[SimplCore-indirections]{Eliminating indirections in Core code, and globalising}
+\subsection{Tidying core}
%* *
%************************************************************************
Several tasks are done by @tidyCorePgm@
-----------------
- [March 98] Indirections are now elimianted by the occurrence analyser
- -- 1. Eliminate indirections. The point here is to transform
- -- x_local = E
- -- x_exported = x_local
- -- ==>
- -- x_exported = E
-
-2. Make certain top-level bindings into Globals. The point is that
+1. Make certain top-level bindings into Globals. The point is that
Global things get externally-visible labels at code generation
time
-3. Make the representation of NoRep literals explicit, and
+
+2. Give all binders a nice print-name. Their uniques aren't changed;
+ rather we give them lexically unique occ-names, so that we can
+ safely print the OccNae only in the interface file. [Bad idea to
+ change the uniques, because the code generator makes global labels
+ from the uniques for local thunks etc.]
+
+
+\begin{code}
+tidyCorePgm :: Module -> [Class] -> [CoreBind] -> IO [CoreBind]
+tidyCorePgm mod local_classes binds_in
+ = do
+ beginPass "Tidy Core"
+ let (_, binds_out) = mapAccumL (tidyBind (Just mod)) init_tidy_env binds_in
+ endPass "Tidy Core" (opt_D_dump_simpl || opt_D_verbose_core2core) binds_out
+ where
+ -- Make sure to avoid the names of class operations
+ -- They don't have top-level bindings, so we won't see them
+ -- in binds_in; so we must initialise the tidy_env appropriately
+ --
+ -- We also make sure to avoid any exported binders. Consider
+ -- f{-u1-} = 1 -- Local decl
+ -- ...
+ -- f{-u2-} = 2 -- Exported decl
+ --
+ -- The second exported decl must 'get' the name 'f', so we
+ -- have to put 'f' in the avoids list before we get to the first
+ -- decl. Name.tidyName then does a no-op on exported binders.
+ init_tidy_env = (initTidyOccEnv avoids, emptyVarEnv)
+ avoids = [getOccName sel_id | cls <- local_classes,
+ sel_id <- classSelIds cls]
+ ++
+ [getOccName bndr | bind <- binds_in,
+ bndr <- bindersOf bind,
+ isExported bndr]
+
+tidyBind :: Maybe Module -- (Just m) for top level, Nothing for nested
+ -> TidyEnv
+ -> CoreBind
+ -> (TidyEnv, CoreBind)
+tidyBind maybe_mod env (NonRec bndr rhs)
+ = let
+ (env', bndr') = tidyBndr maybe_mod env bndr
+ rhs' = tidyExpr env rhs
+ in
+ (env', NonRec bndr' rhs')
+
+tidyBind maybe_mod env (Rec pairs)
+ = let
+ -- We use env' when tidying the rhss
+ -- When tidying the binder itself we may tidy it's
+ -- specialisations; if any of these mention other binders
+ -- in the group we should really feed env' to them too;
+ -- but that seems (a) unlikely and (b) a bit tiresome.
+ -- So I left it out for now
+
+ (bndrs, rhss) = unzip pairs
+ (env', bndrs') = mapAccumL (tidyBndr maybe_mod) env bndrs
+ rhss' = map (tidyExpr env') rhss
+ in
+ (env', Rec (zip bndrs' rhss'))
+
+tidyExpr env (Type ty) = Type (tidyType env ty)
+tidyExpr env (Con con args) = Con con (map (tidyExpr env) args)
+tidyExpr env (App f a) = App (tidyExpr env f) (tidyExpr env a)
+tidyExpr env (Note n e) = Note (tidyNote env n) (tidyExpr env e)
+
+tidyExpr env (Let b e) = Let b' (tidyExpr env' e)
+ where
+ (env', b') = tidyBind Nothing env b
+
+tidyExpr env (Case e b alts) = Case (tidyExpr env e) b' (map (tidyAlt env') alts)
+ where
+ (env', b') = tidyNestedBndr env b
+
+tidyExpr env (Var v) = case lookupVarEnv var_env v of
+ Just v' -> Var v'
+ Nothing -> Var v
+ where
+ (_, var_env) = env
+
+tidyExpr env (Lam b e) = Lam b' (tidyExpr env' e)
+ where
+ (env', b') = tidyNestedBndr env b
+
+tidyAlt env (con, vs, rhs) = (con, vs', tidyExpr env' rhs)
+ where
+ (env', vs') = mapAccumL tidyNestedBndr env vs
+
+tidyNote env (Coerce t1 t2) = Coerce (tidyType env t1) (tidyType env t2)
+\end{code}
+
+\begin{code}
+tidyBndr (Just mod) env id = tidyTopBndr mod env id
+tidyBndr Nothing env var = tidyNestedBndr env var
+
+tidyNestedBndr env tyvar
+ | isTyVar tyvar
+ = tidyTyVar env tyvar
+
+tidyNestedBndr env@(tidy_env, var_env) id
+ = -- Non-top-level variables
+ let
+ -- Give the Id a fresh print-name, *and* rename its type
+ name' = mkLocalName (getUnique id) occ'
+ (tidy_env', occ') = tidyOccName tidy_env (getOccName id)
+ ty' = tidyType env (idType id)
+ id' = mkUserId name' ty'
+ -- NB: This throws away the IdInfo of the Id, which we
+ -- no longer need. That means we don't need to
+ -- run over it with env, nor renumber it.
+ var_env' = extendVarEnv var_env id id'
+ in
+ ((tidy_env', var_env'), id')
+
+tidyTopBndr mod env@(tidy_env, var_env) id
+ = -- Top level variables
+ let
+ (tidy_env', name') = tidyTopName mod tidy_env (idName id)
+ ty' = tidyTopType (idType id)
+ idinfo' = tidyIdInfo env (idInfo id)
+ id' = mkId name' ty' (idDetails id) idinfo'
+ var_env' = extendVarEnv var_env id id'
+ in
+ ((tidy_env', var_env'), id')
+
+-- tidyIdInfo does these things:
+-- a) tidy the specialisation info (if any)
+-- b) zap a complicated ICanSafelyBeINLINEd pragma,
+-- c) zap the unfolding
+-- The latter two are to avoid space leaks
+
+tidyIdInfo env info
+ = info3
+ where
+ spec_items = specEnvToList (specInfo info)
+ spec_env' = specEnvFromList (map tidy_item spec_items)
+ info1 | null spec_items = info
+ | otherwise = spec_env' `setSpecInfo` info
+
+ info2 = case inlinePragInfo info of
+ ICanSafelyBeINLINEd _ _ -> NoInlinePragInfo `setInlinePragInfo` info1
+ other -> info1
+
+ info3 = noUnfolding `setUnfoldingInfo` info2
+
+ tidy_item (tyvars, tys, rhs)
+ = (tyvars', tidyTypes env' tys, tidyExpr env rhs)
+ where
+ (env', tyvars') = tidyTyVars env tyvars
+\end{code}
+
+
+
+%************************************************************************
+%* *
+\subsection{PostSimplification}
+%* *
+%************************************************************************
+
+Several tasks are performed by the post-simplification pass
+
+1. Make the representation of NoRep literals explicit, and
float their bindings to the top level. We only do the floating
part for NoRep lits inside a lambda (else no gain). We need to
take care with let x = "foo" in e
let x = y in e
with a floated "foo". What a bore.
-4. Convert
- case x of {...; x' -> ...x'...}
- ==>
- case x of {...; _ -> ...x... }
- See notes in SimplCase.lhs, near simplDefault for the reasoning here.
-
-5. *Mangle* cases involving par# in the discriminant. The unfolding
+2. *Mangle* cases involving par# in the discriminant. The unfolding
for par in PrelConc.lhs include case expressions with integer
results solely to fool the strictness analyzer, the simplifier,
and anyone else who might want to fool with the evaluation order.
way of the above scheme. And anyway, IO is the only guaranteed
way to enforce ordering --SDM.
-6. Mangle cases involving seq# in the discriminant. Up to this
+3. Mangle cases involving seq# in the discriminant. Up to this
point, seq# will appear like this:
case seq# e of
_ -> ...
where the 0# branch is purely to bamboozle the strictness analyser
- (see case 5 above). This code comes from an unfolding for 'seq'
+ (see case 4 above). This code comes from an unfolding for 'seq'
in Prelude.hs. We translate this into
case e of
_ -> ...
- Now that the evaluation order is safe. The code generator knows
- how to push a seq frame on the stack if 'e' is of function type,
- or is polymorphic.
-
+ Now that the evaluation order is safe.
-7. Do eta reduction for lambda abstractions appearing in:
+4. Do eta reduction for lambda abstractions appearing in:
- the RHS of case alternatives
- the body of a let
These will otherwise turn into local bindings during Core->STG;
better to nuke them if possible. (In general the simplifier does
- eta expansion not eta reduction, up to this point.)
+ eta expansion not eta reduction, up to this point. It does eta
+ on the RHSs of bindings but not the RHSs of case alternatives and
+ let bodies)
-9. Give all binders a nice print-name. Their uniques aren't changed;
- rather we give them lexically unique occ-names, so that we can
- safely print the OccNae only in the interface file. [Bad idea to
- change the uniques, because the code generator makes global labels
- from the uniques for local thunks etc.]
+------------------- NOT DONE ANY MORE ------------------------
+[March 98] Indirections are now elimianted by the occurrence analyser
+1. Eliminate indirections. The point here is to transform
+ x_local = E
+ x_exported = x_local
+ ==>
+ x_exported = E
+
+[Dec 98] [Not now done because there is no penalty in the code
+ generator for using the former form]
+2. Convert
+ case x of {...; x' -> ...x'...}
+ ==>
+ case x of {...; _ -> ...x... }
+ See notes in SimplCase.lhs, near simplDefault for the reasoning here.
+--------------------------------------------------------------
Special case
~~~~~~~~~~~~
and we can safely ignore f as a CAF, since it can only ever be entered once.
-\begin{code}
-tidyCorePgm :: Module -> [CoreBind] -> IO [CoreBind]
-
-tidyCorePgm mod binds_in
- = do
- beginPass "Tidy Core"
- let binds_out = bagToList (initTM mod (tidyTopBindings binds_in))
-
- endPass "Tidy Core" (opt_D_dump_simpl || opt_D_verbose_core2core) binds_out
-\end{code}
-
-Top level bindings
-~~~~~~~~~~~~~~~~~~
\begin{code}
-tidyTopBindings [] = returnTM emptyBag
-tidyTopBindings (b:bs)
- = tidyTopBinding b $
- tidyTopBindings bs
-
-tidyTopBinding :: CoreBind
- -> TopTidyM (Bag CoreBind)
- -> TopTidyM (Bag CoreBind)
-
-tidyTopBinding (NonRec bndr rhs) thing_inside
- = initNestedTM (tidyCoreExpr rhs) `thenTM` \ (rhs',floats) ->
- tidyTopBinder bndr $ \ bndr' ->
- thing_inside `thenTM` \ binds ->
- let
- this_bind {- | isBottomingId bndr
- = unitBag (NonRec bndr' (foldrBag Let rhs' floats))
- | otherwise -}
- = floats `snocBag` NonRec bndr' rhs'
- in
- returnTM (this_bind `unionBags` binds)
-
-tidyTopBinding (Rec pairs) thing_inside
- = tidyTopBinders binders $ \ binders' ->
- initNestedTM (mapTM tidyCoreExpr rhss) `thenTM` \ (rhss', floats) ->
- thing_inside `thenTM` \ binds_inside ->
- returnTM ((floats `snocBag` Rec (binders' `zip` rhss')) `unionBags` binds_inside)
+doPostSimplification :: UniqSupply -> [CoreBind] -> IO [CoreBind]
+doPostSimplification us binds_in
+ = do
+ beginPass "Post-simplification pass"
+ let binds_out = initPM us (postSimplTopBinds binds_in)
+ endPass "Post-simplification pass" opt_D_verbose_core2core binds_out
+
+postSimplTopBinds :: [CoreBind] -> PostM [CoreBind]
+postSimplTopBinds binds
+ = mapPM postSimplTopBind binds `thenPM` \ binds' ->
+ returnPM (bagToList (unionManyBags binds'))
+
+postSimplTopBind :: CoreBind -> PostM (Bag CoreBind)
+postSimplTopBind (NonRec bndr rhs)
+ | isBottomingId bndr -- Don't lift out floats for bottoming Ids
+ -- See notes above
+ = getFloatsPM (postSimplExpr rhs) `thenPM` \ (rhs', floats) ->
+ returnPM (unitBag (NonRec bndr (foldrBag Let rhs' floats)))
+
+postSimplTopBind bind
+ = getFloatsPM (postSimplBind bind) `thenPM` \ (bind', floats) ->
+ returnPM (floats `snocBag` bind')
+
+postSimplBind (NonRec bndr rhs)
+ = postSimplExpr rhs `thenPM` \ rhs' ->
+ returnPM (NonRec bndr rhs')
+
+postSimplBind (Rec pairs)
+ = mapPM postSimplExpr rhss `thenPM` \ rhss' ->
+ returnPM (Rec (bndrs `zip` rhss'))
where
- (binders, rhss) = unzip pairs
+ (bndrs, rhss) = unzip pairs
\end{code}
-\begin{code}
-tidyTopBinder :: Id -> (Id -> TopTidyM (Bag CoreBind)) -> TopTidyM (Bag CoreBind)
-tidyTopBinder id thing_inside
- = mungeTopBndr id $ \ id' ->
- let
- spec_items = specEnvToList (getIdSpecialisation id')
- in
- if null spec_items then
-
- -- Common case, no specialisations to tidy
- thing_inside id'
- else
-
- -- Oh well, tidy those specialisations
- initNestedTM (mapTM tidySpecItem spec_items) `thenTM` \ (spec_items', floats) ->
- let
- id'' = setIdSpecialisation id' (specEnvFromList spec_items')
- in
- extendEnvTM id (Var id'') $
- thing_inside id'' `thenTM` \ binds ->
- returnTM (floats `unionBags` binds)
-
-tidyTopBinders [] k = k []
-tidyTopBinders (b:bs) k = tidyTopBinder b $ \ b' ->
- tidyTopBinders bs $ \ bs' ->
- k (b' : bs')
-
-tidySpecItem (tyvars, tys, rhs)
- = newBndrs tyvars $ \ tyvars' ->
- mapTM tidyTy tys `thenTM` \ tys' ->
- tidyCoreExpr rhs `thenTM` \ rhs' ->
- returnTM (tyvars', tys', rhs')
-\end{code}
Expressions
~~~~~~~~~~~
\begin{code}
-tidyCoreExpr (Var v) = lookupId v
-
-tidyCoreExpr (Type ty)
- = tidyTy ty `thenTM` \ ty' ->
- returnTM (Type ty')
+postSimplExpr (Var v) = returnPM (Var v)
+postSimplExpr (Type ty) = returnPM (Type ty)
-tidyCoreExpr (App fun arg)
- = tidyCoreExpr fun `thenTM` \ fun' ->
- tidyCoreExpr arg `thenTM` \ arg' ->
- returnTM (App fun' arg')
+postSimplExpr (App fun arg)
+ = postSimplExpr fun `thenPM` \ fun' ->
+ postSimplExpr arg `thenPM` \ arg' ->
+ returnPM (App fun' arg')
-tidyCoreExpr (Con (Literal lit) args)
+postSimplExpr (Con (Literal lit) args)
= ASSERT( null args )
- litToRep lit `thenTM` \ (lit_ty, lit_expr) ->
- getInsideLambda `thenTM` \ in_lam ->
+ litToRep lit `thenPM` \ (lit_ty, lit_expr) ->
+ getInsideLambda `thenPM` \ in_lam ->
if in_lam && not (exprIsTrivial lit_expr) then
-- It must have been a no-rep literal with a
-- non-trivial representation; and we're inside a lambda;
-- so float it to the top
- addTopFloat lit_ty lit_expr `thenTM` \ v ->
- returnTM (Var v)
+ addTopFloat lit_ty lit_expr `thenPM` \ v ->
+ returnPM (Var v)
else
- returnTM lit_expr
-
-tidyCoreExpr (Con con args)
- = mapTM tidyCoreExpr args `thenTM` \ args' ->
- returnTM (Con con args')
-
-tidyCoreExpr (Lam bndr body)
- = newBndr bndr $ \ bndr' ->
- insideLambda bndr $
- tidyCoreExpr body `thenTM` \ body' ->
- returnTM (Lam bndr' body')
-
-tidyCoreExpr (Let (NonRec bndr rhs) body)
- = tidyCoreExpr rhs `thenTM` \ rhs' ->
- tidyBindNonRec bndr rhs' body
-
-tidyCoreExpr (Let (Rec pairs) body)
- = newBndrs bndrs $ \ bndrs' ->
- mapTM tidyCoreExpr rhss `thenTM` \ rhss' ->
- tidyCoreExprEta body `thenTM` \ body' ->
- returnTM (Let (Rec (bndrs' `zip` rhss')) body')
- where
- (bndrs, rhss) = unzip pairs
+ returnPM lit_expr
+
+postSimplExpr (Con con args)
+ = mapPM postSimplExpr args `thenPM` \ args' ->
+ returnPM (Con con args')
-tidyCoreExpr (Note (Coerce to_ty from_ty) body)
- = tidyCoreExprEta body `thenTM` \ body' ->
- tidyTy to_ty `thenTM` \ to_ty' ->
- tidyTy from_ty `thenTM` \ from_ty' ->
- returnTM (Note (Coerce to_ty' from_ty') body')
+postSimplExpr (Lam bndr body)
+ = insideLambda bndr $
+ postSimplExpr body `thenPM` \ body' ->
+ returnPM (Lam bndr body')
-tidyCoreExpr (Note note body)
- = tidyCoreExprEta body `thenTM` \ body' ->
- returnTM (Note note body')
+postSimplExpr (Let bind body)
+ = postSimplBind bind `thenPM` \ bind' ->
+ postSimplExprEta body `thenPM` \ body' ->
+ returnPM (Let bind' body')
+
+postSimplExpr (Note note body)
+ = postSimplExprEta body `thenPM` \ body' ->
+ returnPM (Note note body')
-- seq#: see notes above.
-tidyCoreExpr (Case scrut@(Con (PrimOp SeqOp) [Type _, e]) bndr alts)
- = tidyCoreExpr e `thenTM` \ e' ->
- newBndr bndr $ \ bndr' ->
- let new_bndr = setIdType bndr' (coreExprType e') in
- tidyCoreExprEta default_rhs `thenTM` \ rhs' ->
- returnTM (Case e' new_bndr [(DEFAULT,[],rhs')])
+-- NB: seq# :: forall a. a -> Int#
+postSimplExpr (Case scrut@(Con (PrimOp SeqOp) [Type ty, e]) bndr alts)
+ = postSimplExpr e `thenPM` \ e' ->
+ let
+ -- The old binder can't have been used, so we
+ -- can gaily re-use it (yuk!)
+ new_bndr = setIdType bndr ty
+ in
+ postSimplExprEta default_rhs `thenPM` \ rhs' ->
+ returnPM (Case e' new_bndr [(DEFAULT,[],rhs')])
where
(other_alts, maybe_default) = findDefault alts
Just default_rhs = maybe_default
-- par#: see notes above.
-tidyCoreExpr (Case scrut@(Con (PrimOp op) args) bndr alts)
+postSimplExpr (Case scrut@(Con (PrimOp op) args) bndr alts)
| funnyParallelOp op && maybeToBool maybe_default
- = tidyCoreExpr scrut `thenTM` \ scrut' ->
- newBndr bndr $ \ bndr' ->
- tidyCoreExprEta default_rhs `thenTM` \ rhs' ->
- returnTM (Case scrut' bndr' [(DEFAULT,[],rhs')])
+ = postSimplExpr scrut `thenPM` \ scrut' ->
+ postSimplExprEta default_rhs `thenPM` \ rhs' ->
+ returnPM (Case scrut' bndr [(DEFAULT,[],rhs')])
where
(other_alts, maybe_default) = findDefault alts
Just default_rhs = maybe_default
-tidyCoreExpr (Case scrut case_bndr alts)
- = tidyCoreExpr scrut `thenTM` \ scrut' ->
- newBndr case_bndr $ \ case_bndr' ->
- mapTM tidy_alt alts `thenTM` \ alts' ->
- returnTM (Case scrut' case_bndr' alts')
+postSimplExpr (Case scrut case_bndr alts)
+ = postSimplExpr scrut `thenPM` \ scrut' ->
+ mapPM ps_alt alts `thenPM` \ alts' ->
+ returnPM (Case scrut' case_bndr alts')
where
- tidy_alt (con,bndrs,rhs) = newBndrs bndrs $ \ bndrs' ->
- tidyCoreExprEta rhs `thenTM` \ rhs' ->
- returnTM (con, bndrs', rhs')
-
-tidyCoreExprEta e = tidyCoreExpr e `thenTM` \ e' ->
- returnTM (etaCoreExpr e')
-
-tidyBindNonRec bndr val' body
- | exprIsTrivial val'
- = extendEnvTM bndr val' (tidyCoreExpr body)
+ ps_alt (con,bndrs,rhs) = postSimplExprEta rhs `thenPM` \ rhs' ->
+ returnPM (con, bndrs, rhs')
- | otherwise
- = newBndr bndr $ \ bndr' ->
- tidyCoreExpr body `thenTM` \ body' ->
- returnTM (Let (NonRec bndr' val') body')
+postSimplExprEta e = postSimplExpr e `thenPM` \ e' ->
+ returnPM (etaCoreExpr e')
\end{code}
+\begin{code}
+funnyParallelOp ParOp = True
+funnyParallelOp _ = False
+\end{code}
+
%************************************************************************
%* *
binding out to the top level.
\begin{code}
-
-litToRep :: Literal -> NestTidyM (Type, CoreExpr)
+litToRep :: Literal -> PostM (Type, CoreExpr)
litToRep (NoRepStr s ty)
- = returnTM (ty, rhs)
+ = returnPM (ty, rhs)
where
rhs = if (any is_NUL (_UNPK_ s))
\begin{code}
litToRep (NoRepInteger i integer_ty)
- = returnTM (integer_ty, rhs)
+ = returnPM (integer_ty, rhs)
where
rhs | i == 0 = Var integerZeroId -- Extremely convenient to look out for
| i == 1 = Var integerPlusOneId -- a few very common Integer literals!
litToRep (NoRepRational r rational_ty)
- = tidyCoreExpr (mkLit (NoRepInteger (numerator r) integer_ty)) `thenTM` \ num_arg ->
- tidyCoreExpr (mkLit (NoRepInteger (denominator r) integer_ty)) `thenTM` \ denom_arg ->
- returnTM (rational_ty, mkConApp ratio_data_con [Type integer_ty, num_arg, denom_arg])
+ = postSimplExpr (mkLit (NoRepInteger (numerator r) integer_ty)) `thenPM` \ num_arg ->
+ postSimplExpr (mkLit (NoRepInteger (denominator r) integer_ty)) `thenPM` \ denom_arg ->
+ returnPM (rational_ty, mkConApp ratio_data_con [Type integer_ty, num_arg, denom_arg])
where
(ratio_data_con, integer_ty)
= case (splitAlgTyConApp_maybe rational_ty) of
_ -> (panic "ratio_data_con", panic "integer_ty")
-litToRep other_lit = returnTM (literalType other_lit, mkLit other_lit)
+litToRep other_lit = returnPM (literalType other_lit, mkLit other_lit)
\end{code}
-\begin{code}
-funnyParallelOp ParOp = True
-funnyParallelOp _ = False
-\end{code}
-
%************************************************************************
%* *
%************************************************************************
\begin{code}
-type TidyM a state = Module
- -> Bool -- True <=> inside a *value* lambda
- -> (TyVarEnv Type, IdEnv CoreExpr, IdOrTyVarSet)
- -- Substitution and in-scope binders
- -> state
- -> (a, state)
-
-type TopTidyM a = TidyM a Unique
-type NestTidyM a = TidyM a (Unique, -- Global names
- Unique, -- Local names
- Bag CoreBind) -- Floats
-
-
-(initialTopTidyUnique, initialNestedTidyUnique) = initTidyUniques
+type PostM a = Bool -- True <=> inside a *value* lambda
+ -> (UniqSupply, Bag CoreBind) -- Unique supply and Floats in
+ -> (a, (UniqSupply, Bag CoreBind))
-initTM :: Module -> TopTidyM a -> a
-initTM mod m
- = case m mod False {- not inside lambda -} empty_env initialTopTidyUnique of
+initPM :: UniqSupply -> PostM a -> a
+initPM us m
+ = case m False {- not inside lambda -} (us, emptyBag) of
(result, _) -> result
- where
- empty_env = (emptyVarEnv, emptyVarEnv, emptyVarSet)
-
-initNestedTM :: NestTidyM a -> TopTidyM (a, Bag CoreBind)
-initNestedTM m mod in_lam env global_us
- = case m mod in_lam env (global_us, initialNestedTidyUnique, emptyBag) of
- (result, (global_us', _, floats)) -> ((result, floats), global_us')
-returnTM v mod in_lam env usf = (v, usf)
-thenTM m k mod in_lam env usf = case m mod in_lam env usf of
- (r, usf') -> k r mod in_lam env usf'
+returnPM v in_lam usf = (v, usf)
+thenPM m k in_lam usf = case m in_lam usf of
+ (r, usf') -> k r in_lam usf'
-mapTM f [] = returnTM []
-mapTM f (x:xs) = f x `thenTM` \ r ->
- mapTM f xs `thenTM` \ rs ->
- returnTM (r:rs)
+mapPM f [] = returnPM []
+mapPM f (x:xs) = f x `thenPM` \ r ->
+ mapPM f xs `thenPM` \ rs ->
+ returnPM (r:rs)
-insideLambda :: CoreBndr -> NestTidyM a -> NestTidyM a
-insideLambda bndr m mod in_lam env usf | isId bndr = m mod True env usf
- | otherwise = m mod in_lam env usf
-
-getInsideLambda :: NestTidyM Bool
-getInsideLambda mod in_lam env usf = (in_lam, usf)
-\end{code}
+insideLambda :: CoreBndr -> PostM a -> PostM a
+insideLambda bndr m in_lam usf | isId bndr = m True usf
+ | otherwise = m in_lam usf
-Need to extend the environment when we munge a binder, so that
-occurrences of the binder will print the correct way (e.g. as a global
-not a local).
+getInsideLambda :: PostM Bool
+getInsideLambda in_lam usf = (in_lam, usf)
-In cases where we don't clone the binder (because it's an exported
-id), we still zap the unfolding and inline pragma info so that
-unnecessary gumph isn't carried into the code generator. This fixes a
-nasty space leak.
-
-\begin{code}
-mungeTopBndr id thing_inside mod in_lam env@(ty_env, val_env, in_scope) us
- = thing_inside id' mod in_lam (ty_env, val_env', in_scope') us'
- where
- (id', us') | isExported id = (zapSomeIdInfo id, us)
- | otherwise = (zapSomeIdInfo (setIdVisibility (Just mod) us id),
- incrUnique us)
- val_env' = extendVarEnv val_env id (Var id')
- in_scope' = extendVarSet in_scope id'
-
-zapSomeIdInfo id = id `setIdUnfolding` noUnfolding `setInlinePragma` new_ip
- where new_ip = case getInlinePragma id of
- ICanSafelyBeINLINEd _ _ -> NoInlinePragInfo
- something_else -> something_else
-
-addTopFloat :: Type -> CoreExpr -> NestTidyM Id
-addTopFloat lit_ty lit_rhs mod in_lam env (gus, lus, floats)
+getFloatsPM :: PostM a -> PostM (a, Bag CoreBind)
+getFloatsPM m in_lam (us, floats)
= let
- gus' = incrUnique gus
- lit_local = mkSysLocal gus lit_ty
- lit_id = setIdVisibility (Just mod) gus lit_local
+ (a, (us', floats')) = m in_lam (us, emptyBag)
in
- (lit_id, (gus', lus, floats `snocBag` NonRec lit_id lit_rhs))
-
-lookupId :: Id -> TidyM CoreExpr state
-lookupId v mod in_lam (_, val_env, _) usf
- = case lookupVarEnv val_env v of
- Nothing -> (Var v, usf)
- Just e -> (e, usf)
-
-extendEnvTM :: Id -> CoreExpr -> (TidyM a state) -> TidyM a state
-extendEnvTM v e m mod in_lam (ty_env, val_env, in_scope) usf
- = m mod in_lam (ty_env, extendVarEnv val_env v e, in_scope) usf
-\end{code}
+ ((a, floats'), (us', floats))
-
-Making new local binders
-~~~~~~~~~~~~~~~~~~~~~~~~
-\begin{code}
-newBndr tyvar thing_inside mod in_lam (ty_env, val_env, in_scope) (gus, local_uniq, floats)
- | isTyVar tyvar
+addTopFloat :: Type -> CoreExpr -> PostM Id
+addTopFloat lit_ty lit_rhs in_lam (us, floats)
= let
- local_uniq' = incrUnique local_uniq
- tyvar' = setTyVarName tyvar (mkSysLocalName local_uniq)
- ty_env' = extendVarEnv ty_env tyvar (mkTyVarTy tyvar')
- in_scope' = extendVarSet in_scope tyvar'
- in
- thing_inside tyvar' mod in_lam (ty_env', val_env, in_scope') (gus, local_uniq', floats)
-
-newBndr id thing_inside mod in_lam (ty_env, val_env, in_scope) (gus, local_uniq, floats)
- | isId id
- = let
- -- Give the Id a fresh print-name, *and* rename its type
- local_uniq' = incrUnique local_uniq
- name' = mkSysLocalName local_uniq
- ty' = nmbrType ty_env local_uniq' (idType id)
-
- id' = mkUserId name' ty'
- -- NB: This throws away the IdInfo of the Id, which we
- -- no longer need. That means we don't need to
- -- run over it with env, nor renumber it.
-
- val_env' = extendVarEnv val_env id (Var id')
- in_scope' = extendVarSet in_scope id'
+ (us1, us2) = splitUniqSupply us
+ uniq = uniqFromSupply us1
+ lit_id = mkSysLocal SLIT("lf") uniq lit_ty
in
- thing_inside id' mod in_lam (ty_env, val_env', in_scope') (gus, local_uniq', floats)
-
-newBndrs [] thing_inside
- = thing_inside []
-newBndrs (bndr:bndrs) thing_inside
- = newBndr bndr $ \ bndr' ->
- newBndrs bndrs $ \ bndrs' ->
- thing_inside (bndr' : bndrs')
-\end{code}
-
-Re-numbering types
-~~~~~~~~~~~~~~~~~~
-\begin{code}
-tidyTy ty mod in_lam (ty_env, val_env, in_scope) usf@(_, local_uniq, _)
- = (nmbrType ty_env local_uniq ty, usf)
- -- We can use local_uniq as a base for renaming forall'd variables
- -- in the type; we don't need to know how many are consumed.
+ (lit_id, (us2, floats `snocBag` NonRec lit_id lit_rhs))
\end{code}
--- Get rid of this function when we move to the new code generator.
-\begin{code}
-typeOkForCase :: Type -> Bool
-typeOkForCase ty
- | isUnLiftedType ty -- Primitive case
- = True
-
- | otherwise
- = case (splitAlgTyConApp_maybe ty) of
- Just (tycon, ty_args, []) -> False
- Just (tycon, ty_args, non_null_data_cons) | isDataTyCon tycon -> True
- other -> False
- -- Null data cons => type is abstract, which code gen can't
- -- currently handle. (ToDo: when return-in-heap is universal we
- -- don't need to worry about this.)
-\end{code}
module SimplMonad (
InId, InBind, InExpr, InAlt, InArg, InType, InBinder,
OutId, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBinder,
+ OutExprStuff, OutStuff,
-- The continuation type
- SimplCont(..), DupFlag(..), contIsDupable,
+ SimplCont(..), DupFlag(..), contIsDupable, contResultType,
-- The monad
SimplM,
import Id ( Id, mkSysLocal, idMustBeINLINEd )
import IdInfo ( InlinePragInfo(..) )
+import Demand ( Demand )
import CoreSyn
-import CoreUtils ( IdSubst, SubstCoreExpr )
+import CoreUtils ( IdSubst, SubstCoreExpr, coreExprType, coreAltsType )
import CostCentre ( CostCentreStack, subsumedCCS )
import Var ( TyVar )
import VarEnv
import VarSet
-import Type ( Type, TyVarSubst )
+import Type ( Type, TyVarSubst, funResultTy, fullSubstTy, applyTy )
import UniqSupply ( uniqsFromSupply, uniqFromSupply, splitUniqSupply,
UniqSupply
)
%************************************************************************
\begin{code}
-data SimplCont
+type OutExprStuff = OutStuff (InScopeEnv, OutExpr)
+type OutStuff a = ([OutBind], a)
+ -- We return something equivalent to (let b in e), but
+ -- in pieces to avoid the quadratic blowup when floating
+ -- incrementally. Comments just before simplExprB in Simplify.lhs
+
+data SimplCont -- Strict contexts
= Stop
| CoerceIt DupFlag
InId [InAlt] SubstEnv -- The case binder, alts, and subst-env
SimplCont
+ | ArgOf DupFlag -- An arbitrary strict context: the argument
+ (OutExpr -> SimplM OutExprStuff) -- of a strict function, or a primitive-arg fn
+ -- or a PrimOp
+ OutType -- Type of the result of the whole thing
+
instance Outputable SimplCont where
ppr Stop = ptext SLIT("Stop")
ppr (ApplyTo dup arg se cont) = (ptext SLIT("ApplyTo") <+> ppr dup <+> ppr arg) $$ ppr cont
+ ppr (ArgOf dup cont_fn _) = ptext SLIT("ArgOf...") <+> ppr dup
ppr (Select dup bndr alts se cont) = (ptext SLIT("Select") <+> ppr dup <+> ppr bndr) $$
(nest 4 (ppr alts)) $$ ppr cont
ppr (CoerceIt dup ty se cont) = (ptext SLIT("CoerceIt") <+> ppr dup <+> ppr ty) $$ ppr cont
ppr NoDup = ptext SLIT("nodup")
contIsDupable :: SimplCont -> Bool
-contIsDupable Stop = True
-contIsDupable (ApplyTo OkToDup _ _ _) = True
-contIsDupable (Select OkToDup _ _ _ _) = True
-contIsDupable (CoerceIt OkToDup _ _ _) = True
-contIsDupable other = False
+contIsDupable Stop = True
+contIsDupable (ApplyTo OkToDup _ _ _) = True
+contIsDupable (ArgOf OkToDup _ _) = True
+contIsDupable (Select OkToDup _ _ _ _) = True
+contIsDupable (CoerceIt OkToDup _ _ _) = True
+contIsDupable other = False
+
+contResultType :: InScopeEnv -> Type -> SimplCont -> Type
+contResultType in_scope e_ty cont
+ = go e_ty cont
+ where
+ go e_ty Stop = e_ty
+ go e_ty (ApplyTo _ (Type ty) se cont) = go (applyTy e_ty (simpl se ty)) cont
+ go e_ty (ApplyTo _ val_arg _ cont) = go (funResultTy e_ty) cont
+ go e_ty (ArgOf _ fun cont_ty) = cont_ty
+ go e_ty (CoerceIt _ ty se cont) = go (simpl se ty) cont
+ go e_ty (Select _ _ alts se cont) = go (simpl se (coreAltsType alts)) cont
+
+ simpl (ty_subst, _) ty = fullSubstTy ty_subst in_scope ty
\end{code}
= case splitUniqSupply us of
(us1, us2) -> m v (env {seInScope = extendVarSet in_scope v}) us2 sc
where
- v = mkSysLocal (uniqFromSupply us1) ty
+ v = mkSysLocal SLIT("s") (uniqFromSupply us1) ty
newIds :: [Type] -> ([Id] -> SimplM a) -> SimplM a
newIds tys m env@(SimplEnv {seInScope = in_scope}) us sc
= case splitUniqSupply us of
(us1, us2) -> m vs (env {seInScope = foldl extendVarSet in_scope vs}) us2 sc
where
- vs = zipWithEqual "newIds" mkSysLocal (uniqsFromSupply (length tys) us1) tys
+ vs = zipWithEqual "newIds" (mkSysLocal SLIT("s"))
+ (uniqsFromSupply (length tys) us1) tys
\end{code}
FormSummary(..),
substId, substIds
)
-import Id ( Id, idType, isBottomingId, getIdArity, isId, idName,
+import Id ( Id, idType, getIdArity, isId, idName,
getInlinePragma, setInlinePragma,
getIdDemandInfo
)
import IdInfo ( arityLowerBound, InlinePragInfo(..) )
-import Demand ( isStrict )
import Maybes ( maybeToBool )
import Const ( Con(..) )
import Name ( isLocalName )
check (b : bs) (App fun arg)
| (varToCoreExpr b `cheapEqExpr` arg)
- && not (is_strict_binder b)
= check bs fun
check _ _ = expr -- Bale out
- -- We don't want to eta-abstract (\x -> f x) if x carries a "strict"
- -- demand info. That demand info conveys useful information to the
- -- call site, via the let-to-case transform, so we don't want to discard it.
- is_strict_binder b = isId b && isStrict (getIdDemandInfo b)
-
etaCoreExpr expr = expr -- The common case
\end{code}
-> Int -- How many args it can safely be applied to
eta_fun (App fun (Type ty)) = eta_fun fun
-
-eta_fun (Var v)
- | isBottomingId v -- Bottoming ids have "infinite arity"
- = 10000 -- Blargh. Infinite enough!
-
-eta_fun (Var v) = arityLowerBound (getIdArity v)
-
-eta_fun other = 0 -- Give up
+eta_fun (Var v) = arityLowerBound (getIdArity v)
+eta_fun other = 0 -- Give up
\end{code}
-%
+
% (c) The AQUA Project, Glasgow University, 1993-1998
%
\section[Simplify]{The main module of the simplifier}
\begin{code}
-module Simplify ( simplExpr, simplBind ) where
+module Simplify ( simplBind ) where
#include "HsVersions.h"
-import CmdLineOpts ( switchIsOn, opt_SccProfilingOn,
+import CmdLineOpts ( switchIsOn, opt_SccProfilingOn, opt_PprStyle_Debug,
opt_NoPreInlining, opt_DictsStrict, opt_D_dump_inlinings,
SimplifierSwitch(..)
)
getIdUnfolding, setIdUnfolding,
getIdSpecialisation, setIdSpecialisation,
getIdDemandInfo, setIdDemandInfo,
- getIdArity, setIdArity,
+ getIdArity, setIdArity,
+ getIdStrictness,
setInlinePragma, getInlinePragma, idMustBeINLINEd,
idWantsToBeINLINEd
)
-import IdInfo ( InlinePragInfo(..), OccInfo(..),
+import IdInfo ( InlinePragInfo(..), OccInfo(..), StrictnessInfo(..),
ArityInfo, atLeastArity, arityLowerBound, unknownArity
)
import Demand ( Demand, isStrict, wwLazy )
import Const ( isWHNFCon, conOkForAlt )
-import ConFold ( cleverMkPrimApp )
+import ConFold ( tryPrimOp )
import PrimOp ( PrimOp )
import DataCon ( DataCon, dataConNumInstArgs, dataConStrictMarks, dataConSig, dataConArgTys )
import Const ( Con(..) )
)
import CoreUtils ( IdSubst, SubstCoreExpr(..),
cheapEqExpr, exprIsDupable, exprIsWHNF, exprIsTrivial,
- coreExprType, exprIsCheap, substExpr,
+ coreExprType, coreAltsType, exprIsCheap, substExpr,
FormSummary(..), mkFormSummary, whnfOrBottom
)
import SpecEnv ( lookupSpecEnv, isEmptySpecEnv, substSpecEnv )
import CostCentre ( isSubsumedCCS, currentCCS, isEmptyCC )
-import Type ( Type, mkTyVarTy, mkTyVarTys, isUnLiftedType, fullSubstTy, applyTys,
- mkFunTy, splitFunTys, splitTyConApp_maybe, funResultTy )
+import Type ( Type, mkTyVarTy, mkTyVarTys, isUnLiftedType, fullSubstTy,
+ mkFunTy, splitFunTys, splitTyConApp_maybe, splitFunTy_maybe,
+ applyTy, applyTys, funResultTy
+ )
import TyCon ( isDataTyCon, tyConDataCons, tyConClass_maybe, tyConArity, isDataTyCon )
import TysPrim ( realWorldStatePrimTy )
import PrelVals ( realWorldPrimId )
%************************************************************************
\begin{code}
+addBind :: CoreBind -> OutStuff a -> OutStuff a
+addBind bind (binds, res) = (bind:binds, res)
+
+addBinds :: [CoreBind] -> OutStuff a -> OutStuff a
+addBinds [] stuff = stuff
+addBinds binds1 (binds2, res) = (binds1++binds2, res)
+\end{code}
+
+The reason for this OutExprStuff stuff is that we want to float *after*
+simplifying a RHS, not before. If we do so naively we get quadratic
+behaviour as things float out.
+
+To see why it's important to do it after, consider this (real) example:
+
+ let t = f x
+ in fst t
+==>
+ let t = let a = e1
+ b = e2
+ in (a,b)
+ in fst t
+==>
+ let a = e1
+ b = e2
+ t = (a,b)
+ in
+ a -- Can't inline a this round, cos it appears twice
+==>
+ e1
+
+Each of the ==> steps is a round of simplification. We'd save a
+whole round if we float first. This can cascade. Consider
+
+ let f = g d
+ in \x -> ...f...
+==>
+ let f = let d1 = ..d.. in \y -> e
+ in \x -> ...f...
+==>
+ let d1 = ..d..
+ in \x -> ...(\y ->e)...
+
+Only in this second round can the \y be applied, and it
+might do the same again.
+
+
+\begin{code}
simplExpr :: CoreExpr -> SimplCont -> SimplM CoreExpr
+simplExpr expr cont = simplExprB expr cont `thenSmpl` \ (binds, (_, body)) ->
+ returnSmpl (mkLetBinds binds body)
-simplExpr (Note InlineCall (Var v)) cont
+simplExprB :: InExpr -> SimplCont -> SimplM OutExprStuff
+
+simplExprB (Note InlineCall (Var v)) cont
= simplVar True v cont
-simplExpr (Var v) cont
+simplExprB (Var v) cont
= simplVar False v cont
-simplExpr (Con (PrimOp op) args) cont
- = mapSmpl simplArg args `thenSmpl` \ args' ->
- rebuild (cleverMkPrimApp op args') cont
+simplExprB expr@(Con (PrimOp op) args) cont
+ = simplType (coreExprType expr) `thenSmpl` \ expr_ty ->
+ getInScope `thenSmpl` \ in_scope ->
+ getSubstEnv `thenSmpl` \ se ->
+ let
+ -- Main game plan: loop through the arguments, simplifying
+ -- each of them with an ArgOf continuation. Getting the right
+ -- cont_ty in the ArgOf continuation is a bit of a nuisance.
+ go [] args' = rebuild_primop (reverse args')
+ go (arg:args) args' = setSubstEnv se (simplExprB arg (mk_cont args args'))
+
+ cont_ty = contResultType in_scope expr_ty cont
+ mk_cont args args' = ArgOf NoDup (\ arg' -> go args (arg':args')) cont_ty
+ in
+ go args []
+ where
-simplExpr (Con con@(DataCon _) args) cont
+ rebuild_primop args'
+ = -- Try the prim op simplification
+ -- It's really worth trying simplExpr again if it succeeds,
+ -- because you can find
+ -- case (eqChar# x 'a') of ...
+ -- ==>
+ -- case (case x of 'a' -> True; other -> False) of ...
+ case tryPrimOp op args' of
+ Just e' -> zapSubstEnv (simplExprB e' cont)
+ Nothing -> rebuild (Con (PrimOp op) args') cont
+
+simplExprB (Con con@(DataCon _) args) cont
= simplConArgs args $ \ args' ->
rebuild (Con con args') cont
-simplExpr expr@(Con con@(Literal _) args) cont
+simplExprB expr@(Con con@(Literal _) args) cont
= ASSERT( null args )
rebuild expr cont
-simplExpr (App fun arg) cont
+simplExprB (App fun arg) cont
= getSubstEnv `thenSmpl` \ se ->
- simplExpr fun (ApplyTo NoDup arg se cont)
+ simplExprB fun (ApplyTo NoDup arg se cont)
-simplExpr (Case scrut bndr alts) cont
+simplExprB (Case scrut bndr alts) cont
= getSubstEnv `thenSmpl` \ se ->
- simplExpr scrut (Select NoDup bndr alts se cont)
+ simplExprB scrut (Select NoDup bndr alts se cont)
-simplExpr (Note (Coerce to from) e) cont
- | to == from = simplExpr e cont
+simplExprB (Note (Coerce to from) e) cont
+ | to == from = simplExprB e cont
| otherwise = getSubstEnv `thenSmpl` \ se ->
- simplExpr e (CoerceIt NoDup to se cont)
+ simplExprB e (CoerceIt NoDup to se cont)
-- hack: we only distinguish subsumed cost centre stacks for the purposes of
-- inlining. All other CCCSs are mapped to currentCCS.
-simplExpr (Note (SCC cc) e) cont
+simplExprB (Note (SCC cc) e) cont
= setEnclosingCC currentCCS $
simplExpr e Stop `thenSmpl` \ e ->
rebuild (mkNote (SCC cc) e) cont
-simplExpr (Note note e) cont
+simplExprB (Note note e) cont
= simplExpr e Stop `thenSmpl` \ e' ->
rebuild (mkNote note e') cont
-- Let to case, but only if the RHS isn't a WHNF
-simplExpr (Let (NonRec bndr rhs) body) cont
+simplExprB (Let (NonRec bndr rhs) body) cont
= getSubstEnv `thenSmpl` \ se ->
simplBeta bndr rhs se body cont
-simplExpr (Let bind body) cont
- = (simplBind bind $
- simplExpr body cont) `thenSmpl` \ (binds', e') ->
- returnSmpl (mkLets binds' e')
+simplExprB (Let bind body) cont
+ = simplBind bind (simplExprB body cont) `thenSmpl` \ (binds, stuff) ->
+ returnSmpl (addBinds binds stuff)
-- Type-beta reduction
-simplExpr expr@(Lam bndr body) cont@(ApplyTo _ (Type ty_arg) arg_se body_cont)
+simplExprB expr@(Lam bndr body) cont@(ApplyTo _ (Type ty_arg) arg_se body_cont)
= ASSERT( isTyVar bndr )
tick BetaReduction `thenSmpl_`
setSubstEnv arg_se (simplType ty_arg) `thenSmpl` \ ty' ->
extendTySubst bndr ty' $
- simplExpr body body_cont
+ simplExprB body body_cont
-- Ordinary beta reduction
-simplExpr expr@(Lam bndr body) cont@(ApplyTo _ arg arg_se body_cont)
+simplExprB expr@(Lam bndr body) cont@(ApplyTo _ arg arg_se body_cont)
= tick BetaReduction `thenSmpl_`
simplBeta bndr' arg arg_se body body_cont
where
bndr' = zapLambdaBndr bndr body body_cont
-simplExpr (Lam bndr body) cont
+simplExprB (Lam bndr body) cont
= simplBinder bndr $ \ bndr' ->
simplExpr body Stop `thenSmpl` \ body' ->
rebuild (Lam bndr' body') cont
-
-simplExpr (Type ty) cont
- = ASSERT( case cont of { Stop -> True; other -> False } )
+simplExprB (Type ty) cont
+ = ASSERT( case cont of { Stop -> True; ArgOf _ _ _ -> True; other -> False } )
simplType ty `thenSmpl` \ ty' ->
- returnSmpl (Type ty')
+ rebuild (Type ty') cont
\end{code}
That means it may generate some Lets, hence the
\begin{code}
-simplConArgs :: [InArg] -> ([OutArg] -> SimplM CoreExpr) -> SimplM CoreExpr
+simplConArgs :: [InArg] -> ([OutArg] -> SimplM OutExprStuff) -> SimplM OutExprStuff
simplConArgs [] thing_inside
= thing_inside []
-- Simplify the RHS with inlining switched off, so that
-- only absolutely essential things will happen.
- simplConArgs args $ \ args' ->
+ simplConArgs args $ \ args' ->
-- If the argument ain't trivial, then let-bind it
if exprIsTrivial arg' then
thing_inside (arg' : args')
else
- newId (coreExprType arg') $ \ arg_id ->
+ newId (coreExprType arg') $ \ arg_id ->
thing_inside (Var arg_id : args') `thenSmpl` \ res ->
- returnSmpl (bindNonRec arg_id arg' res)
+ returnSmpl (addBind (NonRec arg_id arg') res)
\end{code}
+
---------------------------------
\begin{code}
simplType :: InType -> SimplM OutType
= getValEnv `thenSmpl` \ (id_subst, in_scope) ->
case lookupVarEnv id_subst var of
Just (Done e)
- -> zapSubstEnv (simplExpr e cont)
+ -> zapSubstEnv (simplExprB e cont)
Just (SubstMe e ty_subst id_subst)
- -> setSubstEnv (ty_subst, id_subst) (simplExpr e cont)
+ -> setSubstEnv (ty_subst, id_subst) (simplExprB e cont)
Nothing -> let
var' = case lookupVarSet in_scope var of
completeVar sw_chkr in_scope inline_call var' cont
completeVar sw_chkr in_scope inline_call var cont
+
+{- MAGIC UNFOLDINGS NOT USED NOW
| maybeToBool maybe_magic_result
= tick MagicUnfold `thenSmpl_`
magic_result
-
+-}
-- Look for existing specialisations before trying inlining
| maybeToBool maybe_specialisation
= tick SpecialisationDone `thenSmpl_`
setSubstEnv (spec_bindings, emptyVarEnv) (
-- See note below about zapping the substitution here
- simplExpr spec_template remaining_cont
+ simplExprB spec_template remaining_cont
)
-- Don't actually inline the scrutinee when we see
-- and x has unfolding (C a b). Why not? Because
-- we get a silly binding y = C a b. If we don't
-- inline knownCon can directly substitute x for y instead.
- | has_unfolding && is_case_scrutinee && unfolding_is_constr
+ | has_unfolding && var_is_case_scrutinee && unfolding_is_constr
= knownCon (Var var) con con_args cont
-- Look for an unfolding. There's a binding for the
#ifdef DEBUG
if opt_D_dump_inlinings then
pprTrace "Inlining:" (ppr var <+> ppr unf_template) $
- simplExpr unf_template cont
+ simplExprB unf_template cont
else
#endif
- simplExpr unf_template cont
+ simplExprB unf_template cont
)
else
#ifdef DEBUG
where
unfolding = getIdUnfolding var
+{- MAGIC UNFOLDINGS NOT USED CURRENTLY
---------- Magic unfolding stuff
maybe_magic_result = case unfolding of
MagicUnfolding _ magic_fn -> applyMagicUnfoldingFun magic_fn
cont
other -> Nothing
Just magic_result = maybe_magic_result
+-}
---------- Unfolding stuff
has_unfolding = case unfolding of
drop_ty_args other_cont = other_cont
---------- Switches
- ok_to_inline = okToInline essential_unfoldings_only is_case_scrutinee var form guidance cont
- essential_unfoldings_only = switchIsOn sw_chkr EssentialUnfoldingsOnly
+ ok_to_inline = okToInline sw_chkr in_scope var form guidance cont
- is_case_scrutinee = case cont of
- Select _ _ _ _ _ -> True
- other -> False
+ var_is_case_scrutinee = case cont of
+ Select _ _ _ _ _ -> True
+ other -> False
----------- costCentreOk
-- costCentreOk checks that it's ok to inline this thing
simplBind :: CoreBind -> SimplM a -> SimplM ([CoreBind], a)
simplBind (NonRec bndr rhs) thing_inside
- = simplTopRhs bndr rhs `thenSmpl` \ (binds, rhs', arity, in_scope) ->
+ = simplTopRhs bndr rhs `thenSmpl` \ (binds, in_scope, rhs', arity) ->
setInScope in_scope $
completeBindNonRec (bndr `setIdArity` arity) rhs' thing_inside `thenSmpl` \ (maybe_bind, res) ->
let
binds' = case maybe_bind of
- Just (bndr,rhs) -> binds ++ [NonRec bndr rhs]
- Nothing -> binds
+ Just bind -> binds ++ [bind]
+ Nothing -> binds
in
returnSmpl (binds', res)
returnSmpl ([], res)
go (((bndr, rhs), bndr') : pairs)
- = simplTopRhs bndr rhs `thenSmpl` \ (rhs_binds, rhs', arity, in_scope) ->
- setInScope in_scope $
+ = simplTopRhs bndr rhs `thenSmpl` \ (rhs_binds, in_scope, rhs', arity) ->
+ setInScope in_scope $
completeBindRec bndr (bndr' `setIdArity` arity)
- rhs' (go pairs) `thenSmpl` \ (pairs', res) ->
+ rhs' (go pairs) `thenSmpl` \ (pairs', res) ->
returnSmpl (flatten rhs_binds pairs', res)
flatten (NonRec b r : binds) prs = (b,r) : flatten binds prs
| postInlineUnconditionally bndr etad_rhs
-- NB: a loop breaker never has postInlineUnconditionally True
-- and non-loop-breakers only have *forward* references
+ -- Hence, it's safe to discard the binding
= tick PostInlineUnconditionally `thenSmpl_`
extendIdSubst bndr (Done etad_rhs) thing_inside
\begin{code}
simplTopRhs :: InId -> InExpr
- -> SimplM ([OutBind], OutExpr, ArityInfo, InScopeEnv)
-simplTopRhs bndr rhs
- = getSubstEnv `thenSmpl` \ bndr_se ->
+ -> SimplM ([OutBind], InScopeEnv, OutExpr, ArityInfo)
+simplTopRhs bndr rhs
+ = getSubstEnv `thenSmpl` \ bndr_se ->
simplRhs bndr bndr_se rhs
-simplRhs :: InId -> SubstEnv -> InExpr
- -> SimplM ([OutBind], OutExpr, ArityInfo, InScopeEnv)
-
simplRhs bndr bndr_se rhs
| idWantsToBeINLINEd bndr -- Don't inline in the RHS of something that has an
-- inline pragma. But be careful that the InScopeEnv that
-- we return does still have inlinings on!
= switchOffInlining (simplExpr rhs Stop) `thenSmpl` \ rhs' ->
getInScope `thenSmpl` \ in_scope ->
- returnSmpl ([], rhs', unknownArity, in_scope)
-
- | float_exposes_hnf rhs
- = mkRhsTyLam rhs `thenSmpl` \ rhs' ->
- -- Swizzle the inner lets past the big lambda (if any)
- float rhs'
+ returnSmpl ([], in_scope, rhs', unknownArity)
| otherwise
- = finish rhs
- where
- float (Let bind body) = tick LetFloatFromLet `thenSmpl_`
- simplBind bind (float body) `thenSmpl` \ (binds1, (binds2, body', arity, in_scope)) ->
- returnSmpl (binds1 ++ binds2, body', arity, in_scope)
- float body = finish body
-
-
- finish rhs = simplRhs2 bndr bndr_se rhs `thenSmpl` \ (rhs', arity) ->
- getInScope `thenSmpl` \ in_scope ->
- returnSmpl ([], rhs', arity, in_scope)
-
- float_exposes_hnf (Lam b e) | isTyVar b
- = float_exposes_hnf e -- Ignore leading big lambdas
- float_exposes_hnf (Let _ e) = try e -- Now look for nested lets
- float_exposes_hnf e = False -- Don't bother if no lets!
-
- try (Let _ e) = try e
- try e = exprIsWHNF e
+ = -- Swizzle the inner lets past the big lambda (if any)
+ mkRhsTyLam rhs `thenSmpl` \ rhs' ->
+
+ -- Simplify the swizzled RHS
+ simplRhs2 bndr bndr_se rhs `thenSmpl` \ stuff@(floats, in_scope, rhs', arity) ->
+
+ if not (null floats) && exprIsWHNF rhs' then -- Do the float
+ tick LetFloatFromLet `thenSmpl_`
+ returnSmpl stuff
+ else -- Don't do it
+ getInScope `thenSmpl` \ in_scope ->
+ returnSmpl ([], in_scope, mkLetBinds floats rhs', arity)
\end{code}
---------------------------------------------------------
from simplExpr for an applied lambda). The binder needs to
\begin{code}
+simplRhs2 bndr bndr_se (Let bind body)
+ = simplBind bind (
+ simplRhs2 bndr bndr_se body
+ ) `thenSmpl` \ (binds1, (binds2, in_scope, rhs', arity)) ->
+ returnSmpl (binds1 ++ binds2, in_scope, rhs', arity)
+
simplRhs2 bndr bndr_se rhs
+ | null ids -- Prevent eta expansion for both thunks
+ -- (would lose sharing) and variables (nothing gained).
+ -- To see why we ignore it for thunks, consider
+ -- let f = lookup env key in (f 1, f 2)
+ -- We'd better not eta expand f just because it is
+ -- always applied!
+ --
+ -- Also if there isn't a lambda at the top we use
+ -- simplExprB so that we can do (more) let-floating
+ = simplExprB rhs Stop `thenSmpl` \ (binds, (in_scope, rhs')) ->
+ returnSmpl (binds, in_scope, rhs', unknownArity)
+
+ | otherwise -- Consider eta expansion
= getSwitchChecker `thenSmpl` \ sw_chkr ->
+ getInScope `thenSmpl` \ in_scope ->
simplBinders tyvars $ \ tyvars' ->
simplBinders ids $ \ ids' ->
if switchIsOn sw_chkr SimplDoLambdaEtaExpansion
- && not (null ids) -- Prevent eta expansion for both thunks
- -- (would lose sharing) and variables (nothing gained).
- -- To see why we ignore it for thunks, consider
- -- let f = lookup env key in (f 1, f 2)
- -- We'd better not eta expand f just because it is
- -- always applied!
&& not (null extra_arg_tys)
then
tick EtaExpansion `thenSmpl_`
`thenSmpl` \ extra_arg_tys' ->
newIds extra_arg_tys' $ \ extra_bndrs' ->
simplExpr body (mk_cont extra_bndrs') `thenSmpl` \ body' ->
- returnSmpl ( mkLams tyvars'
+ returnSmpl ( [], in_scope,
+ mkLams tyvars'
$ mkLams ids'
$ mkLams extra_bndrs' body',
atLeastArity (no_of_ids + no_of_extras))
else
simplExpr body Stop `thenSmpl` \ body' ->
- returnSmpl ( mkLams tyvars'
+ returnSmpl ( [], in_scope,
+ mkLams tyvars'
$ mkLams ids' body',
atLeastArity no_of_ids)
simplBeta :: InId -- Binder
-> InExpr -> SubstEnv -- Arg, with its subst-env
-> InExpr -> SimplCont -- Lambda body
- -> SimplM OutExpr
+ -> SimplM OutExprStuff
#ifdef DEBUG
simplBeta bndr rhs rhs_se body cont
| isTyVar bndr
= tick Let2Case `thenSmpl_`
getSubstEnv `thenSmpl` \ body_se ->
setSubstEnv rhs_se $
- simplExpr rhs (Select NoDup bndr [(DEFAULT, [], body)] body_se cont)
+ simplExprB rhs (Select NoDup bndr [(DEFAULT, [], body)] body_se cont)
| preInlineUnconditionally bndr && not opt_NoPreInlining
= tick PreInlineUnconditionally `thenSmpl_`
case rhs_se of { (ty_subst, id_subst) ->
extendIdSubst bndr (SubstMe rhs ty_subst id_subst) $
- simplExpr body cont }
+ simplExprB body cont }
| otherwise
= getSubstEnv `thenSmpl` \ bndr_se ->
setSubstEnv rhs_se (simplRhs bndr bndr_se rhs)
- `thenSmpl` \ (floats, rhs', arity, in_scope) ->
+ `thenSmpl` \ (floats, in_scope, rhs', arity) ->
setInScope in_scope $
completeBindNonRecE (bndr `setIdArity` arity) rhs' (
- simplExpr body cont
- ) `thenSmpl` \ body' ->
- returnSmpl (mkLets floats body')
+ simplExprB body cont
+ ) `thenSmpl` \ res ->
+ returnSmpl (addBinds floats res)
where
-- Return true only for dictionary types where the dictionary
-- has more than one component (else we risk poking on the component
completeBindNonRec :: InId -- Binder
-> OutExpr -- Simplified RHS
-> SimplM a -- Thing inside
- -> SimplM (Maybe (OutId, OutExpr), a)
+ -> SimplM (Maybe OutBind, a)
completeBindNonRec bndr rhs thing_inside
| isDeadBinder bndr -- This happens; for example, the case_bndr during case of
-- known constructor: case (a,b) of x { (p,q) -> ... }
| otherwise -- Note that we use etad_rhs here
-- This gives maximum chance for a remaining binding
-- to be zapped by the indirection zapper in OccurAnal
- = simplBinder bndr $ \ bndr' ->
- simplPrags bndr bndr' etad_rhs `thenSmpl` \ bndr'' ->
- modifyInScope bndr'' $
- thing_inside `thenSmpl` \ res ->
- returnSmpl (Just (bndr'', etad_rhs), res)
+ = simplBinder bndr $ \ bndr' ->
+ simplPrags bndr bndr' etad_rhs `thenSmpl` \ bndr'' ->
+ modifyInScope bndr'' $
+ thing_inside `thenSmpl` \ res ->
+ returnSmpl (Just (NonRec bndr' etad_rhs), res)
where
etad_rhs = etaCoreExpr rhs
-completeBindNonRecE :: InId -> OutExpr -> SimplM OutExpr -> SimplM OutExpr
+completeBindNonRecE :: InId -> OutExpr
+ -> SimplM (OutStuff a)
+ -> SimplM (OutStuff a)
completeBindNonRecE bndr rhs thing_inside
- = completeBindNonRec bndr rhs thing_inside `thenSmpl` \ (maybe_bind, body) ->
- returnSmpl (case maybe_bind of
- Nothing -> body
- Just (bndr, rhs) -> bindNonRec bndr rhs body)
+ = completeBindNonRec bndr rhs thing_inside `thenSmpl` \ (maybe_bind, stuff) ->
+ case maybe_bind of
+ Nothing -> returnSmpl stuff
+ Just bind -> returnSmpl (addBind bind stuff)
-- (simplPrags old_bndr new_bndr new_rhs) does two things
-- (a) it attaches the new unfolding to new_bndr
It's a very important function that embodies lots of heuristics.
\begin{code}
-okToInline :: Bool -- True <-> essential unfoldings only
- -> Bool -- Case scrutinee
+okToInline :: SwitchChecker
+ -> InScopeEnv
-> Id -- The Id
-> FormSummary -- The thing is WHNF or bottom;
-> UnfoldingGuidance
-- If the thing is in WHNF, there's no danger of duplicating work,
-- so we can inline if it occurs once, or is small
-okToInline essential_unfoldings_only is_case_scrutinee id form guidance cont
+okToInline sw_chkr in_scope id form guidance cont
| essential_unfoldings_only
= idMustBeINLINEd id
-- If "essential_unfoldings_only" is true we do no inlinings at all,
IAmASpecPragmaId -> False
IMustNotBeINLINEd -> False
IAmALoopBreaker -> False
-
IMustBeINLINEd -> True
-
- IWantToBeINLINEd -> True --some_benefit -- Even INLINE pragmas don't *always*
- -- cause inlining
+ IWantToBeINLINEd -> True
ICanSafelyBeINLINEd inside_lam one_branch
-> --pprTrace "inline (occurs once): " (ppr id <+> ppr small_enough <+> ppr one_branch <+> ppr whnf <+> ppr some_benefit <+> ppr not_inside_lam) $
where
not_inside_lam = case inside_lam of {InsideLam -> False; other -> True}
- other -> --pprTrace "inline: " (ppr id <+> ppr small_enough <+> ppr whnf <+> ppr some_benefit) $
+ other -> (if opt_PprStyle_Debug then
+ pprTrace "inline:" (ppr id <+> ppr small_enough <+> ppr whnf <+> ppr some_benefit)
+ else (\x -> x))
whnf && small_enough && some_benefit
-- We could consider using exprIsCheap here,
-- as in postInlineUnconditionally, but unlike the latter we wouldn't
-- us that.
where
whnf = whnfOrBottom form
- small_enough = smallEnoughToInline id arg_evals is_case_scrutinee guidance
- val_args = get_val_args cont
- arg_evals = map is_evald val_args
+ small_enough = smallEnoughToInline id arg_evals result_scrut guidance
+ (arg_evals, result_scrut) = get_evals cont
+ -- some_benefit checks that *something* interesting happens to
+ -- the variable after it's inlined.
some_benefit = contIsInteresting cont
- is_evald (Var v) = isEvaldUnfolding (getIdUnfolding v)
- is_evald (Con con _) = isWHNFCon con
- is_evald other = False
+ -- Finding out whether the args are evaluated. This isn't completely easy
+ -- because the args are not yet simplified, so we have to peek into them.
+ get_evals (ApplyTo _ arg (te,ve) cont)
+ | isValArg arg = case get_evals cont of
+ (args, res) -> (get_arg_eval arg ve : args, res)
+ | otherwise = get_evals cont
+
+ get_evals (Select _ _ _ _ _) = ([], True)
+ get_evals other = ([], False)
+
+ get_arg_eval (Con con _) ve = isWHNFCon con
+ get_arg_eval (Var v) ve = case lookupVarEnv ve v of
+ Just (SubstMe e' _ ve') -> get_arg_eval e' ve'
+ Just (Done (Con con _)) -> isWHNFCon con
+ Just (Done (Var v')) -> get_var_eval v'
+ Just (Done other) -> False
+ Nothing -> get_var_eval v
+ get_arg_eval other ve = False
+
+ get_var_eval v = case lookupVarSet in_scope v of
+ Just v' -> isEvaldUnfolding (getIdUnfolding v')
+ Nothing -> isEvaldUnfolding (getIdUnfolding v)
- get_val_args (ApplyTo _ arg _ cont)
- | isValArg arg = arg : get_val_args cont
- | otherwise = get_val_args cont
- get_val_args other = []
+ essential_unfoldings_only = switchIsOn sw_chkr EssentialUnfoldingsOnly
contIsInteresting :: SimplCont -> Bool
-contIsInteresting Stop = False
-contIsInteresting (Select _ _ [(DEFAULT,_,_)] _ _) = False
+contIsInteresting Stop = False
+contIsInteresting (ArgOf _ _ _) = False
contIsInteresting (ApplyTo _ (Type _) _ cont) = contIsInteresting cont
-contIsInteresting _ = True
+contIsInteresting (CoerceIt _ _ _ cont) = contIsInteresting cont
+
+-- Even a case with only a default case is a bit interesting;
+-- we may be able to eliminate it after inlining.
+-- contIsInteresting (Select _ _ [(DEFAULT,_,_)] _ _) = False
+
+contIsInteresting _ = True
\end{code}
Comment about some_benefit above
\begin{code}
-------------------------------------------------------------------
-rebuild :: OutExpr -> SimplCont -> SimplM OutExpr
+rebuild :: OutExpr -> SimplCont -> SimplM OutExprStuff
rebuild expr cont
- = tick LeavesExamined `thenSmpl_`
- getSwitchChecker `thenSmpl` \ chkr ->
- do_rebuild chkr expr (mkFormSummary expr) cont
+ = tick LeavesExamined `thenSmpl_`
+ do_rebuild expr cont
+
+rebuild_done expr
+ = getInScope `thenSmpl` \ in_scope ->
+ returnSmpl ([], (in_scope, expr))
---------------------------------------------------------
-- Stop continuation
-do_rebuild sw_chkr expr form Stop = returnSmpl expr
+do_rebuild expr Stop = rebuild_done expr
---------------------------------------------------------
--- Coerce continuation
-
-do_rebuild sw_chkr expr form (CoerceIt _ to_ty se cont)
- = setSubstEnv se $
- simplType to_ty `thenSmpl` \ to_ty' ->
- do_rebuild sw_chkr (mk_coerce to_ty' expr) form cont
- where
- mk_coerce to_ty' (Note (Coerce _ from_ty) expr) = Note (Coerce to_ty' from_ty) expr
- mk_coerce to_ty' expr = Note (Coerce to_ty' (coreExprType expr)) expr
+-- ArgOf continuation
+do_rebuild expr (ArgOf _ cont_fn _) = cont_fn expr
---------------------------------------------------------
--- Dealing with
--- * case (error "hello") of { ... }
-
--- ToDo: deal with
--- * (error "Hello") arg
-
-do_rebuild sw_chkr expr BottomForm cont@(Select _ _ _ _ _)
- = tick CaseOfError `thenSmpl_`
- getInScope `thenSmpl` \ in_scope ->
- let
- (cont', result_ty) = find_result_ty in_scope cont
- in
- do_rebuild sw_chkr (mkNote (Coerce result_ty expr_ty) expr) BottomForm cont'
+-- ApplyTo continuation
+
+do_rebuild expr cont@(ApplyTo _ arg se cont')
+ = case expr of
+ Var v -> case getIdStrictness v of
+ NoStrictnessInfo -> non_strict_case
+ StrictnessInfo demands result_bot _ -> ASSERT( not (null demands) || result_bot )
+ -- If this happened we'd get an infinite loop
+ rebuild_strict demands result_bot expr (idType v) cont
+ other -> non_strict_case
where
- expr_ty = coreExprType expr
- find_result_ty in_scope (ApplyTo _ _ _ cont)
- = (cont, funResultTy expr_ty)
- find_result_ty in_scope (Select _ _ ((_,_,rhs1):_) (ty_subst,_) cont)
- = (cont, fullSubstTy ty_subst in_scope (coreExprType rhs1))
+ non_strict_case = setSubstEnv se (simplArg arg) `thenSmpl` \ arg' ->
+ do_rebuild (App expr arg') cont'
+
-
---------------------------------------------------------
--- Ordinary application
+-- Coerce continuation
-do_rebuild sw_chkr expr form cont@(ApplyTo _ _ _ _)
- = go expr cont
- where -- This loop just saves repeated calculation of mkFormSummary
- go e (ApplyTo _ arg se cont) = setSubstEnv se (simplArg arg) `thenSmpl` \ arg' ->
- go (App e arg') cont
- go e cont = do_rebuild sw_chkr e (mkFormSummary e) cont
+do_rebuild expr (CoerceIt _ to_ty se cont)
+ = setSubstEnv se $
+ simplType to_ty `thenSmpl` \ to_ty' ->
+ do_rebuild (mk_coerce to_ty' expr) cont
+ where
+ mk_coerce to_ty' (Note (Coerce _ from_ty) expr) = Note (Coerce to_ty' from_ty) expr
+ mk_coerce to_ty' expr = Note (Coerce to_ty' (coreExprType expr)) expr
---------------------------------------------------------
-- Case of known constructor or literal
-do_rebuild sw_chkr expr@(Con con args) form cont@(Select _ _ _ _ _)
+do_rebuild expr@(Con con args) cont@(Select _ _ _ _ _)
| conOkForAlt con -- Knocks out PrimOps and NoRepLits
= knownCon expr con args cont
+
---------------------------------------------------------
-- Case of other value (e.g. a partial application or lambda)
-- Turn it back into a let
-do_rebuild sw_chkr expr ValueForm (Select _ bndr ((DEFAULT, bs, rhs):alts) se cont)
+do_rebuild expr (Select _ bndr ((DEFAULT, bs, rhs):alts) se cont)
+ | case mkFormSummary expr of { ValueForm -> True; other -> False }
= ASSERT( null bs && null alts )
tick Case2Let `thenSmpl_`
setSubstEnv se (
completeBindNonRecE bndr expr $
- simplExpr rhs cont
+ simplExprB rhs cont
)
---------------------------------------------------------
--- Case of something else; eliminating the case altogether
--- See the extensive notes on case-elimination below
+-- The other Select cases
-do_rebuild sw_chkr scrut form (Select _ bndr alts se cont)
- | switchIsOn sw_chkr SimplDoCaseElim
- && all (cheapEqExpr rhs1) other_rhss
- && inlineCase bndr scrut
- && all binders_unused alts
+do_rebuild scrut (Select _ bndr alts se cont)
+ = getSwitchChecker `thenSmpl` \ chkr ->
- = -- Get rid of the case altogether
+ if all (cheapEqExpr rhs1) other_rhss
+ && inlineCase bndr scrut
+ && all binders_unused alts
+ && switchIsOn chkr SimplDoCaseElim
+ then
+ -- Get rid of the case altogether
+ -- See the extensive notes on case-elimination below
-- Remember to bind the binder though!
- tick CaseElim `thenSmpl_`
- setSubstEnv se (
- extendIdSubst bndr (Done scrut) $
- simplExpr rhs1 cont
- )
- where
- (rhs1:other_rhss) = [rhs | (_,_,rhs) <- alts]
+ tick CaseElim `thenSmpl_`
+ setSubstEnv se (
+ extendIdSubst bndr (Done scrut) $
+ simplExprB rhs1 cont
+ )
+ else
+ rebuild_case chkr scrut bndr alts se cont
+ where
+ (rhs1:other_rhss) = [rhs | (_,_,rhs) <- alts]
binders_unused (_, bndrs, _) = all isDeadBinder bndrs
+
+---------------------------------------------------------
+-- Rebuiling a function with strictness info
+
+rebuild_strict :: [Demand] -> Bool -- Stricness info
+ -> OutExpr -> OutType -- Function and type
+ -> SimplCont -- Continuation
+ -> SimplM OutExprStuff
+
+rebuild_strict [] True fun fun_ty cont = rebuild_bot fun fun_ty cont
+rebuild_strict [] False fun fun_ty cont = do_rebuild fun cont
+
+rebuild_strict ds result_bot fun fun_ty (ApplyTo _ (Type ty_arg) se cont)
+ -- Type arg; don't consume a demand
+ = setSubstEnv se (simplType ty_arg) `thenSmpl` \ ty_arg' ->
+ rebuild_strict ds result_bot (App fun (Type ty_arg'))
+ (applyTy fun_ty ty_arg') cont
+
+rebuild_strict (d:ds) result_bot fun fun_ty (ApplyTo _ val_arg se cont)
+ | not (isStrict d) -- Lazy value argument
+ = setSubstEnv se (simplArg val_arg) `thenSmpl` \ val_arg' ->
+ rebuild_strict ds result_bot (App fun val_arg') res_ty cont
+
+ | otherwise -- Strict value argument
+ = getInScope `thenSmpl` \ in_scope ->
+ let
+ cont_ty = contResultType in_scope res_ty cont
+ in
+ setSubstEnv se (simplExprB val_arg (ArgOf NoDup cont_fn cont_ty))
+ where
+ Just (arg_ty, res_ty) = splitFunTy_maybe fun_ty
+ cont_fn arg' = rebuild_strict ds result_bot
+ (App fun arg') res_ty
+ cont
+
+rebuild_strict ds result_bot fun fun_ty cont = do_rebuild fun cont
+
+---------------------------------------------------------
+-- Dealing with
+-- * case (error "hello") of { ... }
+-- * (error "Hello") arg
+-- etc
+
+rebuild_bot expr expr_ty Stop -- No coerce needed
+ = rebuild_done expr
+
+rebuild_bot expr expr_ty (CoerceIt _ to_ty se Stop) -- Don't "tick" on this,
+ -- else simplifier never stops
+ = setSubstEnv se $
+ simplType to_ty `thenSmpl` \ to_ty' ->
+ rebuild_done (mkNote (Coerce to_ty' expr_ty) expr)
+
+rebuild_bot expr expr_ty cont
+ = tick CaseOfError `thenSmpl_`
+ getInScope `thenSmpl` \ in_scope ->
+ let
+ result_ty = contResultType in_scope expr_ty cont
+ in
+ rebuild_done (mkNote (Coerce result_ty expr_ty) expr)
+\end{code}
+
+Blob of helper functions for the "case-of-something-else" situation.
+
+\begin{code}
---------------------------------------------------------
-- Case of something else
-do_rebuild sw_chkr scrut form (Select _ case_bndr alts se cont)
- = -- Prepare the continuation and case alternatives
+rebuild_case sw_chkr scrut case_bndr alts se cont
+ = -- Prepare case alternatives
prepareCaseAlts (splitTyConApp_maybe (idType case_bndr))
scrut_cons alts `thenSmpl` \ better_alts ->
- prepareCaseCont better_alts cont $ \ cont' ->
-- Set the new subst-env in place (before dealing with the case binder)
setSubstEnv se $
-
- -- Deal with the case binder
+
+ -- Deal with the case binder, and prepare the continuation;
+ -- The new subst_env is in place
simplBinder case_bndr $ \ case_bndr' ->
+ prepareCaseCont better_alts cont $ \ cont' ->
+
-- Deal with variable scrutinee
substForVarScrut scrut case_bndr' $ \ zap_occ_info ->
in
-- Deal with the case alternaatives
- simplAlts zap_occ_info scrut_cons case_bndr'' better_alts cont' `thenSmpl` \ alts' ->
+ simplAlts zap_occ_info scrut_cons
+ case_bndr'' better_alts cont' `thenSmpl` \ alts' ->
- getSwitchChecker `thenSmpl` \ sw_chkr ->
- mkCase sw_chkr scrut case_bndr'' alts'
+ mkCase sw_chkr scrut case_bndr'' alts' `thenSmpl` \ case_expr ->
+ rebuild_done case_expr
where
-- scrut_cons tells what constructors the scrutinee can't possibly match
scrut_cons = case scrut of
OtherCon cons -> cons
other -> []
other -> []
-\end{code}
-Blob of helper functions for the "case-of-something-else" situation.
-\begin{code}
knownCon expr con args (Select _ bndr alts se cont)
= tick KnownBranch `thenSmpl_`
setSubstEnv se (
case findAlt con alts of
(DEFAULT, bs, rhs) -> ASSERT( null bs )
completeBindNonRecE bndr expr $
- simplExpr rhs cont
+ simplExprB rhs cont
(Literal lit, bs, rhs) -> ASSERT( null bs )
extendIdSubst bndr (Done expr) $
-- be a variable or a literal. It can't be a
-- NoRep literal because they don't occur in
-- case patterns.
- simplExpr rhs cont
+ simplExprB rhs cont
(DataCon dc, bs, rhs) -> completeBindNonRecE bndr expr $
extend bs real_args $
- simplExpr rhs cont
+ simplExprB rhs cont
where
real_args = drop (dataConNumInstArgs dc) args
)
\end{code}
\begin{code}
+prepareCaseCont :: [InAlt] -> SimplCont
+ -> (SimplCont -> SimplM (OutStuff a))
+ -> SimplM (OutStuff a)
+ -- Polymorphic recursion here!
+
prepareCaseCont [alt] cont thing_inside = thing_inside cont
-prepareCaseCont alts cont thing_inside = mkDupableCont cont thing_inside
+prepareCaseCont alts cont thing_inside = mkDupableCont (coreAltsType alts) cont thing_inside
\end{code}
substForVarScrut checks whether the scrutinee is a variable, v.
%************************************************************************
\begin{code}
-mkDupableCont :: SimplCont
- -> (SimplCont -> SimplM CoreExpr)
- -> SimplM CoreExpr
-mkDupableCont cont thing_inside
+mkDupableCont :: InType -- Type of the thing to be given to the continuation
+ -> SimplCont
+ -> (SimplCont -> SimplM (OutStuff a))
+ -> SimplM (OutStuff a)
+mkDupableCont ty cont thing_inside
| contIsDupable cont
= thing_inside cont
-mkDupableCont (CoerceIt _ ty se cont) thing_inside
- = mkDupableCont cont $ \ cont' ->
+mkDupableCont _ (CoerceIt _ ty se cont) thing_inside
+ = mkDupableCont ty cont $ \ cont' ->
thing_inside (CoerceIt OkToDup ty se cont')
-mkDupableCont (ApplyTo _ arg se cont) thing_inside
- = mkDupableCont cont $ \ cont' ->
- setSubstEnv se (simplExpr arg Stop) `thenSmpl` \ arg' ->
+mkDupableCont join_arg_ty (ArgOf _ cont_fn res_ty) thing_inside
+ = -- Build the RHS of the join point
+ simplType join_arg_ty `thenSmpl` \ join_arg_ty' ->
+ newId join_arg_ty' ( \ arg_id ->
+ getSwitchChecker `thenSmpl` \ chkr ->
+ cont_fn (Var arg_id) `thenSmpl` \ (binds, (_, rhs)) ->
+ returnSmpl (Lam arg_id (mkLetBinds binds rhs))
+ ) `thenSmpl` \ join_rhs ->
+
+ -- Build the join Id and continuation
+ newId (coreExprType join_rhs) $ \ join_id ->
+ let
+ new_cont = ArgOf OkToDup
+ (\arg' -> rebuild_done (App (Var join_id) arg'))
+ res_ty
+ in
+
+ -- Do the thing inside
+ thing_inside new_cont `thenSmpl` \ res ->
+ returnSmpl (addBind (NonRec join_id join_rhs) res)
+
+mkDupableCont ty (ApplyTo _ arg se cont) thing_inside
+ = mkDupableCont (funResultTy ty) cont $ \ cont' ->
+ setSubstEnv se (simplArg arg) `thenSmpl` \ arg' ->
if exprIsDupable arg' then
thing_inside (ApplyTo OkToDup arg' emptySubstEnv cont')
else
newId (coreExprType arg') $ \ bndr ->
thing_inside (ApplyTo OkToDup (Var bndr) emptySubstEnv cont') `thenSmpl` \ res ->
- returnSmpl (bindNonRec bndr arg' res)
+ returnSmpl (addBind (NonRec bndr arg') res)
-mkDupableCont (Select _ case_bndr alts se cont) thing_inside
+mkDupableCont ty (Select _ case_bndr alts se cont) thing_inside
= tick CaseOfCase `thenSmpl_` (
- mkDupableCont cont $ \ cont' ->
-
setSubstEnv se (
- simplBinder case_bndr $ \ case_bndr' ->
+ simplBinder case_bndr $ \ case_bndr' ->
+ prepareCaseCont alts cont $ \ cont' ->
mapAndUnzipSmpl (mkDupableAlt case_bndr' cont') alts `thenSmpl` \ (alt_binds_s, alts') ->
- returnSmpl (concat alt_binds_s, case_bndr', alts')
- ) `thenSmpl` \ (alt_binds, case_bndr', alts') ->
+ returnSmpl (concat alt_binds_s, (case_bndr', alts'))
+ ) `thenSmpl` \ (alt_binds, (case_bndr', alts')) ->
extendInScopes [b | NonRec b _ <- alt_binds] $
thing_inside (Select OkToDup case_bndr' alts' emptySubstEnv Stop) `thenSmpl` \ res ->
- returnSmpl (mkLets alt_binds res)
+ returnSmpl (addBinds alt_binds res)
)
-mkDupableAlt :: OutId -> SimplCont -> InAlt -> SimplM ([CoreBind], CoreAlt)
+mkDupableAlt :: OutId -> SimplCont -> InAlt -> SimplM (OutStuff CoreAlt)
mkDupableAlt case_bndr' cont alt@(con, bndrs, rhs)
= simplBinders bndrs $ \ bndrs' ->
simplExpr rhs cont `thenSmpl` \ rhs' ->
import StgSyn
import Bag ( Bag, emptyBag, unionBags, unitBag, snocBag, bagToList )
-import Id ( mkSysLocal, idType, setIdArity,
- setIdVisibility, Id
- )
+import Id ( mkUserId, idType, setIdArity, Id )
import VarSet
import VarEnv
import IdInfo ( exactArity )
-import Name ( Module )
+import Name ( Module, mkTopName )
import Type ( splitForAllTys, mkForAllTys, mkFunTys, Type )
import UniqSupply ( uniqFromSupply, splitUniqSupply, UniqSupply )
-import Util ( zipEqual, panic, assertPanic )
+import Util ( zipEqual )
+import Panic ( panic, assertPanic )
\end{code}
This is the lambda lifter. It turns lambda abstractions into
-> LiftM Id
newSupercombinator ty arity mod ci us idenv
- = setIdVisibility (Just mod) uniq (mkSysLocal uniq ty)
+ = mkUserId (mkTopName uniq mod SLIT("_ll")) ty
`setIdArity` exactArity arity
-- ToDo: rm the setIdArity? Just let subsequent stg-saturation pass do it?
where
module SRT where
import Id ( Id, setIdCafInfo, getIdCafInfo, externallyVisibleId,
- isBottomingId )
+ idAppIsBottom )
import IdInfo ( CafInfo(..) )
import StgSyn
| otherwise = MayHaveCafRefs -- otherwise, treat as a CAF
isBottomingExpr (StgLet bind expr) = isBottomingExpr expr
-isBottomingExpr (StgApp f args) = isBottomingId f
-isBottomingExpr _ = False
+isBottomingExpr (StgApp f args) = idAppIsBottom f (length args)
+isBottomingExpr _ = False
\end{code}
-----------------------------------------------------------------------------
StgToDo(..)
)
import Id ( Id )
+import OccName ( Module, moduleString )
import VarEnv
import ErrUtils ( doIfSet )
import UniqSupply ( splitUniqSupply, UniqSupply )
-import Util ( panic, assertPanic, trace )
import IO ( hPutStr, stderr )
import Outputable
\end{code}
\begin{code}
stg2stg :: [StgToDo] -- spec of what stg-to-stg passes to do
- -> FAST_STRING -- module name (profiling only)
+ -> Module -- module name (profiling only)
-> UniqSupply -- a name supply
-> [StgBinding] -- input...
-> IO
grp_name = case (opt_SccGroup) of
Just xx -> _PK_ xx
- Nothing -> module_name -- default: module name
+ Nothing -> _PK_ (moduleString module_name) -- default: module name
-------------
stg_linter = if opt_DoStgLinting
import Name ( isLocallyDefined )
import Type ( splitFunTys, splitSigmaTy )
import Unique ( getBuiltinUniques )
-import Util ( panic )
+import Panic ( panic )
\end{code}
where
(c,b,_) = foldl doApp f ids
ids = map mkid (getBuiltinUniques arity)
- mkid u = mkSysLocal u noType
+ mkid u = mkSysLocal SLIT("upd") u noType
countUses u = if u `elemRefs` b then 2 else min (lookupc c u) 2
noType = panic "UpdAnal: no type!"
import Var ( TyVar )
import VarEnv
import VarSet
-import Type ( Type, GenType, fullSubstTy, substTyVar )
+import Type ( Type, fullSubstTy, substTyVar )
import Unify ( unifyTyListsX, matchTys )
import Outputable
import Maybes
-import Util ( assertPanic )
\end{code}
\begin{code}
lookupSpecEnv :: SDoc -- For error report
-> SpecEnv value -- The envt
- -> [GenType flexi] -- Key
- -> Maybe (TyVarEnv (GenType flexi), value)
+ -> [Type] -- Key
+ -> Maybe (TyVarEnv Type, value)
lookupSpecEnv doc EmptySE key = Nothing
lookupSpecEnv doc (SpecEnv alist) key
#include "HsVersions.h"
import CmdLineOpts ( opt_D_verbose_core2core, opt_D_dump_spec )
-import Id ( Id, idType, mkTemplateLocals, mkUserLocal,
+import Id ( Id, idName, idType, mkTemplateLocals, mkUserLocal,
getIdSpecialisation, setIdSpecialisation,
isSpecPragmaId,
)
UniqSM, initUs, thenUs, thenUs_, returnUs, getUniqueUs,
getUs, setUs, uniqFromSupply, splitUniqSupply, mapUs
)
-import Name ( NamedThing(getOccName) )
+import Name ( nameOccName )
import FiniteMap
import Maybes ( MaybeErr(..), catMaybes )
import Bag
newIdSM old_id new_ty
= getUniqSM `thenSM` \ uniq ->
- returnSM (mkUserLocal (getOccName old_id)
- uniq
- new_ty
- )
+ let
+ -- Give the new Id a similar occurrence name to the old one
+ new_id = mkUserLocal (nameOccName name) uniq new_ty
+ name = idName old_id
+ in
+ returnSM new_id
newTyVarSM
= getUniqSM `thenSM` \ uniq ->
import CoreUtils ( coreExprType )
import SimplUtils ( findDefault )
import CostCentre ( noCCS )
-import Id ( Id, mkUserLocal, idType,
+import Id ( Id, mkSysLocal, idType,
externallyVisibleId, setIdUnique
)
-import Name ( varOcc )
import VarEnv
import Const ( Con(..), isWHNFCon, Literal(..) )
import PrimOp ( PrimOp(..) )
alg_alt_to_stg env (DataCon con, bs, rhs)
= coreExprToStg env rhs `thenUs` \ stg_rhs ->
- returnUs (con, bs, [ True | b <- bs ]{-bogus use mask-}, stg_rhs)
+ returnUs (con, filter isId bs, [ True | b <- bs ]{-bogus use mask-}, stg_rhs)
+ -- NB the filter isId. Some of the binders may be
+ -- existential type variables, which STG doesn't care about
prim_alt_to_stg env (Literal lit, args, rhs)
= ASSERT( null args )
newStgVar :: Type -> UniqSM Id
newStgVar ty
= getUniqueUs `thenUs` \ uniq ->
- returnUs (mkUserLocal (varOcc SLIT("stg")) uniq ty)
+ returnUs (mkSysLocal SLIT("stg") uniq ty)
\end{code}
\begin{code}
isUnLiftedType, isTyVarTy, Type
)
import TyCon ( TyCon, isDataTyCon )
-import Util ( zipEqual, trace )
+import Util ( zipEqual )
import Outputable
infixr 9 `thenL`, `thenL_`, `thenMaybeL`, `thenMaybeL_`
= sep (punctuate comma (map pp_binder bs))
where
pp_binder b
- = hsep [ppr b, ptext SLIT("::"), ppr (idType b)]
+ = hsep [ppr b, dcolon, ppr (idType b)]
\end{code}
\begin{code}
pprStgExpr (StgCase expr lvs_whole lvs_rhss bndr srt alts)
= sep [sep [ptext SLIT("case"),
nest 4 (hsep [pprStgExpr expr,
- ifPprDebug (ptext SLIT("::") <> pp_ty alts)]),
+ ifPprDebug (dcolon <+> pp_ty alts)]),
ptext SLIT("of"), ppr bndr, char '{'],
ifPprDebug (
nest 4 (
absEval anal (Con (PrimOp _) args) env
= -- PrimOps evaluate all their arguments
- if any anyBot [absEval anal arg env | arg <- args]
+ if any (what_bot anal) [absEval anal arg env | arg <- args]
then AbsBot
else AbsTop
+ where
+ what_bot StrAnal = isBot -- Primops are strict
+ what_bot AbsAnal = anyBot -- Look for poison anywhere
absEval anal (Con (DataCon con) args) env
| isProductTyCon (dataConTyCon con)
See notes on @addStrictnessInfoToId@.
\begin{code}
-findStrictness :: [Type] -- Types of args in which strictness is wanted
- -> AbsVal -- Abstract strictness value of function
- -> AbsVal -- Abstract absence value of function
- -> [Demand] -- Resulting strictness annotation
+findStrictness :: [Type] -- Types of args in which strictness is wanted
+ -> AbsVal -- Abstract strictness value of function
+ -> AbsVal -- Abstract absence value of function
+ -> ([Demand], Bool) -- Resulting strictness annotation
findStrictness tys str_val abs_val
- = map find_str tys_w_index
+ = (map find_str tys_w_index, isBot (foldl (absApply StrAnal) str_val all_tops))
where
tys_w_index = tys `zip` [1..]
mk_arg val n (_,m) | m==n = val
| otherwise = AbsTop
+
+ all_tops = [AbsTop | _ <- tys]
\end{code}
[Demand] -- approximation to a function value. It's an
AbsVal -- abstract function which is strict in its
-- arguments if the Demand so indicates.
+ -- INVARIANT: the [Demand] is non-empty
-- AbsApproxFun has to take a *list* of demands, no just one,
-- because function spaces are now lifted. Hence, (f bot top)
ptext SLIT("???"), -- text "}{env:", ppr (keysFM env `zip` eltsFM env),
char '}' ]
ppr (AbsApproxFun demands val)
- = hsep [ptext SLIT("AbsApprox "), pprDemands demands, ppr val]
+ = hsep [ptext SLIT("AbsApprox "), hcat (map ppr demands), ppr val]
\end{code}
%-----------
\begin{code}
absValFromStrictness :: AnalysisKind -> StrictnessInfo -> AbsVal
-absValFromStrictness anal NoStrictnessInfo = AbsTop
-
-absValFromStrictness StrAnal BottomGuaranteed = AbsBot -- Guaranteed bottom
-absValFromStrictness AbsAnal BottomGuaranteed = AbsTop -- Check for poison in
- -- arguments (if any)
-absValFromStrictness anal (StrictnessInfo args_info _) = AbsApproxFun args_info AbsTop
+absValFromStrictness anal NoStrictnessInfo = AbsTop
+absValFromStrictness anal (StrictnessInfo args_info bot_result _)
+ = case args_info of -- Check the invariant that the arg list on
+ [] -> res -- AbsApproxFun is non-empty
+ _ -> AbsApproxFun args_info res
+ where
+ res | not bot_result = AbsTop
+ | otherwise = case anal of
+ StrAnal -> AbsBot
+ AbsAnal -> AbsTop
\end{code}
getIdDemandInfo, setIdDemandInfo,
Id
)
-import IdInfo ( mkStrictnessInfo, mkBottomStrictnessInfo )
+import IdInfo ( mkStrictnessInfo )
import CoreLint ( beginPass, endPass )
import ErrUtils ( dumpIfSet )
import SaAbsInt
-> Id -- Augmented with strictness
addStrictnessInfoToId str_val abs_val binder body
-
- | isBot str_val
- = binder `setIdStrictness` mkBottomStrictnessInfo
-
- | otherwise
= case (collectTyAndValBinders body) of
- (_, [], rhs) -> binder
(_, lambda_bounds, rhs) -> binder `setIdStrictness`
- mkStrictnessInfo strictness False
+ mkStrictnessInfo strictness False
where
tys = map idType lambda_bounds
strictness = findStrictness tys str_val abs_val
let
work_rhs = work_fn body
work_id = mkWorkerId work_uniq fn_id (coreExprType work_rhs) `setIdStrictness`
- mkStrictnessInfo work_demands False
+ mkStrictnessInfo (work_demands, result_bot) False
wrap_rhs = wrap_fn work_id
- wrap_id = fn_id `setIdStrictness` mkStrictnessInfo revised_wrap_args_info True
+ wrap_id = fn_id `setIdStrictness` mkStrictnessInfo (revised_wrap_args_info, result_bot) True
`setInlinePragma` IWantToBeINLINEd
-- Add info to the wrapper:
-- (a) we want to inline it everywhere
where
strictness_info = getIdStrictness fn_id
has_strictness_info = case strictness_info of
- StrictnessInfo _ _ -> True
- other -> False
+ StrictnessInfo _ _ _ -> True
+ other -> False
- wrap_args_info = case strictness_info of
- StrictnessInfo args_info _ -> args_info
+ StrictnessInfo wrap_args_info result_bot _ = strictness_info
+
revised_wrap_args_info = setUnpackStrategy wrap_args_info
unfold_guidance = calcUnfoldingGuidance opt_UnfoldingCreationThreshold rhs
where
worth_it (WwLazy True) = True -- Absent arg
worth_it (WwUnpack _ True _) = True -- Arg to unpack
- worth_it WwStrict = True
+ worth_it WwStrict = False -- Don't w/w just because of strictness
worth_it other = False
allAbsent :: [Demand] -> Bool
con_args = map Type con_tys ++ map Var unpk_args
-mk_ww_local uniq ty = mkSysLocal uniq ty
+mk_ww_local uniq ty = mkSysLocal SLIT("ww") uniq ty
\end{code}
import HsSyn ( HsLit(..), HsExpr(..) )
import RnHsSyn ( RenamedArithSeqInfo, RenamedHsExpr, RenamedPat )
-import TcHsSyn ( TcExpr, TcIdOcc(..), TcIdBndr,
- mkHsTyApp, mkHsDictApp, tcIdTyVars, zonkTcId
+import TcHsSyn ( TcExpr, TcId,
+ mkHsTyApp, mkHsDictApp, zonkId
)
import TcMonad
-import TcEnv ( TcIdSet, tcLookupGlobalValueByKey, tcLookupTyConByKey,
- tidyType, tidyTypes
- )
+import TcEnv ( TcIdSet, tcLookupValueByKey, tcLookupTyConByKey )
import TcType ( TcThetaType,
TcType, TcTauType, TcTyVarSet,
zonkTcType, zonkTcTypes,
import Class ( classInstEnv,
Class, ClassInstEnv
)
-import Id ( Id, idType, mkUserLocal, mkSysLocal )
+import Id ( Id, idFreeTyVars, idType, mkUserLocal, mkSysLocal )
import VarSet ( elemVarSet )
import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass )
-import Name ( OccName(..), Name, occNameString, getOccName )
+import Name ( OccName, Name, mkDictOcc, getOccName )
import PprType ( pprConstraint )
import SpecEnv ( SpecEnv, lookupSpecEnv )
import SrcLoc ( SrcLoc )
import Type ( Type, ThetaType, substTy,
isTyVarTy, mkDictTy, splitForAllTys, splitSigmaTy,
splitRhoTy, tyVarsOfType, tyVarsOfTypes,
- mkSynTy, substFlexiTy, substFlexiTheta
+ mkSynTy, substTopTy, substTopTheta,
+ tidyOpenType, tidyOpenTypes
)
import TyCon ( TyCon )
-import VarEnv ( zipVarEnv, lookupVarEnv )
+import VarEnv ( zipVarEnv, lookupVarEnv, TidyEnv )
import VarSet ( unionVarSet )
import TysPrim ( intPrimTy, floatPrimTy, doublePrimTy )
import TysWiredIn ( intDataCon, isIntTy, inIntRange,
%************************************************************************
\begin{code}
-type LIE s = Bag (Inst s)
+type LIE = Bag Inst
isEmptyLIE = isEmptyBag
emptyLIE = emptyBag
consLIE inst lie = inst `consBag` lie
plusLIEs lies = unionManyBags lies
-zonkLIE :: LIE s -> NF_TcM s (LIE s)
+zonkLIE :: LIE -> NF_TcM s LIE
zonkLIE lie = mapBagNF_Tc zonkInst lie
-pprInsts :: [Inst s] -> SDoc
+pprInsts :: [Inst] -> SDoc
pprInsts insts = parens (hsep (punctuate comma (map pprInst insts)))
Method 34 doubleId [Int] origin
\begin{code}
-data Inst s
+data Inst
= Dict
Unique
Class -- The type of the dict is (c ts), where
- [TcType s] -- c is the class and ts the types;
- (InstOrigin s)
+ [TcType] -- c is the class and ts the types;
+ InstOrigin
SrcLoc
| Method
Unique
- (TcIdOcc s) -- The overloaded function
+ TcId -- The overloaded function
-- This function will be a global, local, or ClassOpId;
-- inside instance decls (only) it can also be an InstId!
-- The id needn't be completely polymorphic.
-- You'll probably find its name (for documentation purposes)
-- inside the InstOrigin
- [TcType s] -- The types to which its polymorphic tyvars
+ [TcType] -- The types to which its polymorphic tyvars
-- should be instantiated.
-- These types must saturate the Id's foralls.
- (TcThetaType s) -- The (types of the) dictionaries to which the function
+ TcThetaType -- The (types of the) dictionaries to which the function
-- must be applied to get the method
- (TcTauType s) -- The type of the method
+ TcTauType -- The type of the method
- (InstOrigin s)
+ InstOrigin
SrcLoc
-- INVARIANT: in (Method u f tys theta tau loc)
| LitInst
Unique
OverloadedLit
- (TcType s) -- The type at which the literal is used
- (InstOrigin s) -- Always a literal; but more convenient to carry this around
+ TcType -- The type at which the literal is used
+ InstOrigin -- Always a literal; but more convenient to carry this around
SrcLoc
data OverloadedLit
maps to do their stuff.
\begin{code}
-instance Ord (Inst s) where
+instance Ord Inst where
compare = cmpInst
-instance Eq (Inst s) where
+instance Eq Inst where
(==) i1 i2 = case i1 `cmpInst` i2 of
EQ -> True
other -> False
getDictClassTys (Dict u clas tys _ _) = (clas, tys)
-tyVarsOfInst :: Inst s -> TcTyVarSet s
+tyVarsOfInst :: Inst -> TcTyVarSet
tyVarsOfInst (Dict _ _ tys _ _) = tyVarsOfTypes tys
-tyVarsOfInst (Method _ id tys _ _ _ _) = tyVarsOfTypes tys `unionVarSet` tcIdTyVars id
- -- The id might not be a RealId; in the case of
+tyVarsOfInst (Method _ id tys _ _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
+ -- The id might have free type variables; in the case of
-- locally-overloaded class methods, for example
tyVarsOfInst (LitInst _ _ ty _ _) = tyVarsOfType ty
\end{code}
Predicates
~~~~~~~~~~
\begin{code}
-isDict :: Inst s -> Bool
+isDict :: Inst -> Bool
isDict (Dict _ _ _ _ _) = True
isDict other = False
-isMethodFor :: TcIdSet s -> Inst s -> Bool
-isMethodFor ids (Method uniq (TcId id) tys _ _ orig loc)
+isMethodFor :: TcIdSet -> Inst -> Bool
+isMethodFor ids (Method uniq id tys _ _ orig loc)
= id `elemVarSet` ids
isMethodFor ids inst
= False
-isTyVarDict :: Inst s -> Bool
+isTyVarDict :: Inst -> Bool
isTyVarDict (Dict _ _ tys _ _) = all isTyVarTy tys
isTyVarDict other = False
@Inst@ can be generalised over.
\begin{code}
-instBindingRequired :: Inst s -> Bool
+instBindingRequired :: Inst -> Bool
instBindingRequired (Dict _ clas _ _ _) = not (isNoDictClass clas)
instBindingRequired other = True
-instCanBeGeneralised :: Inst s -> Bool
+instCanBeGeneralised :: Inst -> Bool
instCanBeGeneralised (Dict _ clas _ _ _) = not (isCcallishClass clas)
instCanBeGeneralised other = True
\end{code}
~~~~~~~~~~~~
\begin{code}
-newDicts :: InstOrigin s
- -> TcThetaType s
- -> NF_TcM s (LIE s, [TcIdOcc s])
+newDicts :: InstOrigin
+ -> TcThetaType
+ -> NF_TcM s (LIE, [TcId])
newDicts orig theta
= tcGetSrcLoc `thenNF_Tc` \ loc ->
newDictsAtLoc orig loc theta `thenNF_Tc` \ (dicts, ids) ->
-- Local function, similar to newDicts,
-- but with slightly different interface
-newDictsAtLoc :: InstOrigin s
+newDictsAtLoc :: InstOrigin
-> SrcLoc
- -> TcThetaType s
- -> NF_TcM s ([Inst s], [TcIdOcc s])
+ -> TcThetaType
+ -> NF_TcM s ([Inst], [TcId])
newDictsAtLoc orig loc theta =
tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs ->
let
in
returnNF_Tc (dicts, map instToId dicts)
-newDictFromOld :: Inst s -> Class -> [TcType s] -> NF_TcM s (Inst s)
+newDictFromOld :: Inst -> Class -> [TcType] -> NF_TcM s Inst
newDictFromOld (Dict _ _ _ orig loc) clas tys
= tcGetUnique `thenNF_Tc` \ uniq ->
returnNF_Tc (Dict uniq clas tys orig loc)
-newMethod :: InstOrigin s
- -> TcIdOcc s
- -> [TcType s]
- -> NF_TcM s (LIE s, TcIdOcc s)
+newMethod :: InstOrigin
+ -> TcId
+ -> [TcType]
+ -> NF_TcM s (LIE, TcId)
newMethod orig id tys
= -- Get the Id type and instantiate it at the specified types
- (case id of
- RealId id -> let
- (tyvars, rho) = splitForAllTys (idType id)
- in
- ASSERT( length tyvars == length tys)
- returnNF_Tc (substFlexiTy (zipVarEnv tyvars tys) rho)
-
- TcId id -> let
- (tyvars, rho) = splitForAllTys (idType id)
- in
- returnNF_Tc (substTy (zipVarEnv tyvars tys) rho)
- ) `thenNF_Tc` \ rho_ty ->
let
+ (tyvars, rho) = splitForAllTys (idType id)
+ rho_ty = substTy (zipVarEnv tyvars tys) rho
(theta, tau) = splitRhoTy rho_ty
in
newMethodWithGivenTy orig id tys theta tau `thenNF_Tc` \ meth_inst ->
in
returnNF_Tc meth_inst
-newMethodAtLoc :: InstOrigin s -> SrcLoc
- -> Id -> [TcType s]
- -> NF_TcM s (Inst s, TcIdOcc s)
+newMethodAtLoc :: InstOrigin -> SrcLoc
+ -> Id -> [TcType]
+ -> NF_TcM s (Inst, TcId)
newMethodAtLoc orig loc real_id tys -- Local function, similar to newMethod but with
-- slightly different interface
= -- Get the Id type and instantiate it at the specified types
let
(tyvars,rho) = splitForAllTys (idType real_id)
rho_ty = ASSERT( length tyvars == length tys )
- substFlexiTy (zipVarEnv tyvars tys) rho
+ substTopTy (zipVarEnv tyvars tys) rho
(theta, tau) = splitRhoTy rho_ty
- meth_inst = Method new_uniq (RealId real_id) tys theta tau orig loc
+ meth_inst = Method new_uniq real_id tys theta tau orig loc
in
returnNF_Tc (meth_inst, instToId meth_inst)
\end{code}
cases (the rest are caught in lookupInst).
\begin{code}
-newOverloadedLit :: InstOrigin s
+newOverloadedLit :: InstOrigin
-> OverloadedLit
- -> TcType s
- -> NF_TcM s (TcExpr s, LIE s)
+ -> TcType
+ -> NF_TcM s (TcExpr, LIE)
newOverloadedLit orig (OverloadedIntegral i) ty
| isIntTy ty && inIntRange i -- Short cut for Int
= returnNF_Tc (int_lit, emptyLIE)
\begin{code}
-instToId :: Inst s -> TcIdOcc s
-instToId inst = TcId (instToIdBndr inst)
+instToId :: Inst -> TcId
+instToId inst = instToIdBndr inst
-instToIdBndr :: Inst s -> TcIdBndr s
+instToIdBndr :: Inst -> TcId
instToIdBndr (Dict u clas ty orig loc)
- = mkUserLocal occ u (mkDictTy clas ty)
- where
- occ = VarOcc (SLIT("d.") _APPEND_ (occNameString (getOccName clas)))
+ = mkUserLocal (mkDictOcc (getOccName clas)) u (mkDictTy clas ty)
instToIdBndr (Method u id tys theta tau orig loc)
= mkUserLocal (getOccName id) u tau
instToIdBndr (LitInst u list ty orig loc)
- = mkSysLocal u ty
+ = mkSysLocal SLIT("lit") u ty
\end{code}
need, and it's a lot of extra work.
\begin{code}
-zonkInst :: Inst s -> NF_TcM s (Inst s)
+zonkInst :: Inst -> NF_TcM s Inst
zonkInst (Dict u clas tys orig loc)
= zonkTcTypes tys `thenNF_Tc` \ new_tys ->
returnNF_Tc (Dict u clas new_tys orig loc)
zonkInst (Method u id tys theta tau orig loc)
- = zonkTcId id `thenNF_Tc` \ new_id ->
- -- Essential to zonk the id in case it's a local variable
+ = zonkId id `thenNF_Tc` \ new_id ->
+ -- Essential to zonk the id in case it's a local variable
+ -- Can't use zonkIdOcc because the id might itself be
+ -- an InstId, in which case it won't be in scope
+
zonkTcTypes tys `thenNF_Tc` \ new_tys ->
zonkTcThetaType theta `thenNF_Tc` \ new_theta ->
zonkTcType tau `thenNF_Tc` \ new_tau ->
relevant in error messages.
\begin{code}
-instance Outputable (Inst s) where
+instance Outputable Inst where
ppr inst = pprInst inst
pprInst (LitInst u lit ty orig loc)
brackets (interppSP tys),
show_uniq u]
-tidyInst :: TidyTypeEnv s -> Inst s -> (TidyTypeEnv s, Inst s)
+tidyInst :: TidyEnv -> Inst -> (TidyEnv, Inst)
tidyInst env (LitInst u lit ty orig loc)
= (env', LitInst u lit ty' orig loc)
where
- (env', ty') = tidyType env ty
+ (env', ty') = tidyOpenType env ty
tidyInst env (Dict u clas tys orig loc)
= (env', Dict u clas tys' orig loc)
where
- (env', tys') = tidyTypes env tys
+ (env', tys') = tidyOpenTypes env tys
tidyInst env (Method u id tys theta tau orig loc)
= (env', Method u id tys' theta tau orig loc)
-- Leave theta, tau alone cos we don't print them
where
- (env', tys') = tidyTypes env tys
+ (env', tys') = tidyOpenTypes env tys
tidyInsts env insts = mapAccumL tidyInst env insts
\begin{code}
data LookupInstResult s
= NoInstance
- | SimpleInst (TcExpr s) -- Just a variable, type application, or literal
- | GenInst [Inst s] (TcExpr s) -- The expression and its needed insts
+ | SimpleInst TcExpr -- Just a variable, type application, or literal
+ | GenInst [Inst] TcExpr -- The expression and its needed insts
-lookupInst :: Inst s
+lookupInst :: Inst
-> NF_TcM s (LookupInstResult s)
-- Dictionaries
(tyvars, rho) = splitForAllTys (idType dfun_id)
ty_args = map (expectJust "Inst" . lookupVarEnv tenv) tyvars
-- tenv should bind all the tyvars
- dfun_rho = substFlexiTy tenv rho
+ dfun_rho = substTopTy tenv rho
(theta, tau) = splitRhoTy dfun_rho
- ty_app = mkHsTyApp (HsVar (RealId dfun_id)) ty_args
+ ty_app = mkHsTyApp (HsVar dfun_id) ty_args
in
if null theta then
returnNF_Tc (SimpleInst ty_app)
= returnNF_Tc (GenInst [] integer_lit)
| in_int_range -- It's overloaded but small enough to fit into an Int
- = tcLookupGlobalValueByKey fromIntClassOpKey `thenNF_Tc` \ from_int ->
+ = tcLookupValueByKey fromIntClassOpKey `thenNF_Tc` \ from_int ->
newMethodAtLoc orig loc from_int [ty] `thenNF_Tc` \ (method_inst, method_id) ->
returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) int_lit))
| otherwise -- Alas, it is overloaded and a big literal!
- = tcLookupGlobalValueByKey fromIntegerClassOpKey `thenNF_Tc` \ from_integer ->
+ = tcLookupValueByKey fromIntegerClassOpKey `thenNF_Tc` \ from_integer ->
newMethodAtLoc orig loc from_integer [ty] `thenNF_Tc` \ (method_inst, method_id) ->
returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) integer_lit))
where
| isDoubleTy ty = returnNF_Tc (GenInst [] double_lit)
| otherwise
- = tcLookupGlobalValueByKey fromRationalClassOpKey `thenNF_Tc` \ from_rational ->
+ = tcLookupValueByKey fromRationalClassOpKey `thenNF_Tc` \ from_rational ->
-- The type Rational isn't wired in so we have to conjure it up
tcLookupTyConByKey rationalTyConKey `thenNF_Tc` \ rational_tycon ->
Nothing -> returnNF_Tc Nothing
Just (tenv, dfun)
- -> returnNF_Tc (Just (substFlexiTheta tenv theta))
+ -> returnNF_Tc (Just (substTopTheta tenv theta))
where
(_, theta, _) = splitSigmaTy (idType dfun)
\end{code}
don't appear in the original source code. Doubtless this type will evolve...
\begin{code}
-data InstOrigin s
- = OccurrenceOf (TcIdOcc s) -- Occurrence of an overloaded identifier
+data InstOrigin
+ = OccurrenceOf TcId -- Occurrence of an overloaded identifier
| OccurrenceOfCon Id -- Occurrence of a data constructor
| RecordUpdOrigin
\end{code}
\begin{code}
-pprOrigin :: Inst s -> SDoc
+pprOrigin :: Inst -> SDoc
pprOrigin inst
= hsep [text "arising from", pp_orig orig, text "at", ppr locn]
where
#include "HsVersions.h"
-import {-# SOURCE #-} TcGRHSs ( tcGRHSsAndBinds )
+import {-# SOURCE #-} TcMatches ( tcGRHSs, tcMatchesFun )
import {-# SOURCE #-} TcExpr ( tcExpr )
import HsSyn ( HsExpr(..), HsBinds(..), MonoBinds(..), Sig(..), InPat(..), StmtCtxt(..),
collectMonoBinders, andMonoBindList, andMonoBinds
)
import RnHsSyn ( RenamedHsBinds, RenamedSig, RenamedMonoBinds )
-import TcHsSyn ( TcHsBinds, TcMonoBinds,
- TcIdOcc(..), TcIdBndr,
- tcIdType, zonkId
- )
+import TcHsSyn ( TcHsBinds, TcMonoBinds, TcId, zonkId )
import TcMonad
import Inst ( Inst, LIE, emptyLIE, mkLIE, plusLIE, plusLIEs, InstOrigin(..),
newDicts, tyVarsOfInst, instToId,
)
-import TcEnv ( tcExtendLocalValEnv, tcExtendEnvWithPat,
- tcLookupLocalValueOK,
+import TcEnv ( tcExtendLocalValEnv,
newSpecPragmaId,
tcGetGlobalTyVars, tcExtendGlobalTyVars
)
-import TcMatches ( tcMatchesFun )
import TcSimplify ( tcSimplify, tcSimplifyAndCheck )
-import TcMonoType ( tcHsTcType, checkSigTyVars,
+import TcMonoType ( tcHsType, checkSigTyVars,
TcSigInfo(..), tcTySig, maybeSig, sigCtxt
)
import TcPat ( tcVarPat, tcPat )
import TcSimplify ( bindInstsOfLocalFuns )
import TcType ( TcType, TcThetaType,
TcTyVar,
- newTyVarTy, newTcTyVar, tcInstTcType,
- zonkTcType, zonkTcTypes, zonkTcThetaType )
+ newTyVarTy, newTyVar, newTyVarTy_OpenKind, tcInstTcType,
+ zonkTcType, zonkTcTypes, zonkTcThetaType, zonkTcTyVarToTyVar
+ )
import TcUnify ( unifyTauTy, unifyTauTyLists )
import Id ( mkUserId )
import Type ( mkTyVarTy, tyVarsOfTypes,
splitSigmaTy, mkForAllTys, mkFunTys, getTyVar,
mkDictTy, splitRhoTy, mkForAllTy, isUnLiftedType,
- isUnboxedType, openTypeKind,
- unboxedTypeKind, boxedTypeKind
+ isUnboxedType, unboxedTypeKind, boxedTypeKind
)
import Var ( TyVar, tyVarKind )
import VarSet
\begin{code}
tcTopBindsAndThen, tcBindsAndThen
- :: (RecFlag -> TcMonoBinds s -> thing -> thing) -- Combinator
+ :: (RecFlag -> TcMonoBinds -> thing -> thing) -- Combinator
-> RenamedHsBinds
- -> TcM s (thing, LIE s)
- -> TcM s (thing, LIE s)
+ -> TcM s (thing, LIE)
+ -> TcM s (thing, LIE)
tcTopBindsAndThen = tc_binds_and_then TopLevel
tcBindsAndThen = tc_binds_and_then NotTopLevel
tc_ty_sigs is_rec prag_info_fn `thenTc` \ (poly_binds, poly_lie, poly_ids) ->
-- Extend the environment to bind the new polymorphic Ids
- tcExtendLocalValEnv (map idName poly_ids) poly_ids $
+ tcExtendLocalValEnv [(idName poly_id, poly_id) | poly_id <- poly_ids] $
-- Build bindings and IdInfos corresponding to user pragmas
tcPragmaSigs sigs `thenTc` \ (prag_info_fn, prag_binds, prag_lie) ->
\begin{pseudocode}
% tcBindsAndThen
% :: RenamedHsBinds
-% -> TcM s (thing, LIE s, thing_ty))
-% -> TcM s ((TcHsBinds s, thing), LIE s, thing_ty)
+% -> TcM s (thing, LIE, thing_ty))
+% -> TcM s ((TcHsBinds, thing), LIE, thing_ty)
%
% tcBindsAndThen EmptyBinds do_next
% = do_next `thenTc` \ (thing, lie, thing_ty) ->
tcBindWithSigs
:: TopLevelFlag
-> RenamedMonoBinds
- -> [TcSigInfo s]
+ -> [TcSigInfo]
-> RecFlag
-> (Name -> IdInfo)
- -> TcM s (TcMonoBinds s, LIE s, [TcIdBndr s])
+ -> TcM s (TcMonoBinds, LIE, [TcId])
tcBindWithSigs top_lvl mbind tc_ty_sigs is_rec prag_info_fn
= recoverTc (
-- If typechecking the binds fails, then return with each
-- signature-less binder given type (forall a.a), to minimise subsequent
-- error messages
- newTcTyVar boxedTypeKind `thenNF_Tc` \ alpha_tv ->
+ newTyVar boxedTypeKind `thenNF_Tc` \ alpha_tv ->
let
forall_a_a = mkForAllTy alpha_tv (mkTyVarTy alpha_tv)
binder_names = map fst (bagToList (collectMonoBinders mbind))
-- restriction means we can't generalise them nevertheless
getTyVarsToGen is_unrestricted mono_id_tys lie_req `thenNF_Tc` \ (tyvars_not_to_gen, tyvars_to_gen) ->
- -- DEAL WITH TYPE VARIABLE KINDS
- -- **** This step can do unification => keep other zonking after this ****
- mapTc defaultUncommittedTyVar (varSetElems tyvars_to_gen) `thenTc` \ real_tyvars_to_gen_list ->
+ -- Finally, zonk the generalised type variables to real TyVars
+ -- This commits any unbound kind variables to boxed kind
+ -- I'm a little worried that such a kind variable might be
+ -- free in the environment, but I don't think it's possible for
+ -- this to happen when the type variable is not free in the envt
+ -- (which it isn't). SLPJ Nov 98
+ mapTc zonkTcTyVarToTyVar (varSetElems tyvars_to_gen) `thenTc` \ real_tyvars_to_gen_list ->
let
real_tyvars_to_gen = mkVarSet real_tyvars_to_gen_list
-- It's important that the final list
mapNF_Tc zonkId mono_ids `thenNF_Tc` \ zonked_mono_ids ->
let
exports = zipWith mk_export binder_names zonked_mono_ids
- dict_tys = map tcIdType dicts_bound
+ dict_tys = map idType dicts_bound
mk_export binder_name zonked_mono_id
= (tyvars,
- TcId (setIdInfo poly_id (prag_info_fn binder_name)),
- TcId zonked_mono_id)
+ setIdInfo poly_id (prag_info_fn binder_name),
+ zonked_mono_id)
where
(tyvars, poly_id) =
case maybeSig tc_ty_sigs binder_name of
exports
(dict_binds `andMonoBinds` mbind'),
lie_free,
- [poly_id | (_, TcId poly_id, _) <- exports]
+ [poly_id | (_, poly_id, _) <- exports]
)
where
tysig_names = [name | (TySigInfo name _ _ _ _ _ _ _) <- tc_ty_sigs]
is_elem v vs = isIn "isUnResMono" v vs
isUnRestrictedGroup sigs (PatMonoBind (VarPatIn v) _ _) = v `is_elem` sigs
-isUnRestrictedGroup sigs (PatMonoBind other _ _) = False
+isUnRestrictedGroup sigs (PatMonoBind other _ _) = False
isUnRestrictedGroup sigs (VarMonoBind v _) = v `is_elem` sigs
isUnRestrictedGroup sigs (FunMonoBind _ _ _ _) = True
isUnRestrictedGroup sigs (AndMonoBinds mb1 mb2) = isUnRestrictedGroup sigs mb1 &&
isUnRestrictedGroup sigs EmptyMonoBinds = True
\end{code}
-@defaultUncommittedTyVar@ checks for generalisation over unboxed
-types, and defaults any TypeKind TyVars to BoxedTypeKind.
-
-\begin{code}
-defaultUncommittedTyVar tyvar
- | tyVarKind tyvar == openTypeKind
- = newTcTyVar boxedTypeKind `thenNF_Tc` \ boxed_tyvar ->
- unifyTauTy (mkTyVarTy tyvar) (mkTyVarTy boxed_tyvar) `thenTc_`
- returnTc boxed_tyvar
-
- | otherwise
- = returnTc tyvar
-\end{code}
-
%************************************************************************
%* *
\begin{code}
tcMonoBinds :: RenamedMonoBinds
- -> [TcSigInfo s]
+ -> [TcSigInfo]
-> RecFlag
- -> TcM s (TcMonoBinds s,
- LIE s, -- LIE required
+ -> TcM s (TcMonoBinds,
+ LIE, -- LIE required
[Name], -- Bound names
- [TcIdBndr s]) -- Corresponding monomorphic bound things
+ [TcId]) -- Corresponding monomorphic bound things
tcMonoBinds mbinds tc_ty_sigs is_rec
= tc_mb_pats mbinds `thenTc` \ (complete_it, lie_req_pat, tvs, ids, lie_avail) ->
let
tv_list = bagToList tvs
- (names, mono_ids) = unzip (bagToList ids)
+ id_list = bagToList ids
+ (names, mono_ids) = unzip id_list
+
+ -- This last defn is the key one:
+ -- extend the val envt with bindings for the
+ -- things bound in this group, overriding the monomorphic
+ -- ids with the polymorphic ones from the pattern
+ extra_val_env = case is_rec of
+ Recursive -> map mk_bind id_list
+ NonRecursive -> []
in
-- Don't know how to deal with pattern-bound existentials yet
checkTc (isEmptyBag tvs && isEmptyBag lie_avail)
(existentialExplode mbinds) `thenTc_`
- -- *Before* checking the RHSs, but *after* checking *all* the patterns,
+ -- *Before* checking the RHSs, but *after* checking *all* the patterns,
-- extend the envt with bindings for all the bound ids;
-- and *then* override with the polymorphic Ids from the signatures
-- That is the whole point of the "complete_it" stuff.
- tcExtendEnvWithPat ids (tcExtendEnvWithPat sig_ids
- complete_it
- ) `thenTc` \ (mbinds', lie_req_rhss) ->
+ --
+ -- There's a further wrinkle: we have to delay extending the environment
+ -- until after we've dealt with any pattern-bound signature type variables
+ -- Consider f (x::a) = ...f...
+ -- We're going to check that a isn't unified with anything in the envt,
+ -- so f itself had better not be! So we pass the envt binding f into
+ -- complete_it, which extends the actual envt in TcMatches.tcMatch, after
+ -- dealing with the signature tyvars
+
+ complete_it extra_val_env `thenTc` \ (mbinds', lie_req_rhss) ->
+
returnTc (mbinds', lie_req_pat `plusLIE` lie_req_rhss, names, mono_ids)
where
sig_fn name = case maybeSig tc_ty_sigs name of
Nothing -> Nothing
Just (TySigInfo _ _ _ _ _ mono_id _ _) -> Just mono_id
- sig_ids = listToBag [(name,poly_id) | TySigInfo name poly_id _ _ _ _ _ _ <- tc_ty_sigs]
-
- kind = case is_rec of
- Recursive -> boxedTypeKind -- Recursive, so no unboxed types
- NonRecursive -> openTypeKind -- Non-recursive, so we permit unboxed types
+ mk_bind (name, mono_id) = case maybeSig tc_ty_sigs name of
+ Nothing -> (name, mono_id)
+ Just (TySigInfo name poly_id _ _ _ _ _ _) -> (name, poly_id)
tc_mb_pats EmptyMonoBinds
- = returnTc (returnTc (EmptyMonoBinds, emptyLIE), emptyLIE, emptyBag, emptyBag, emptyLIE)
+ = returnTc (\ xve -> returnTc (EmptyMonoBinds, emptyLIE), emptyLIE, emptyBag, emptyBag, emptyLIE)
tc_mb_pats (AndMonoBinds mb1 mb2)
= tc_mb_pats mb1 `thenTc` \ (complete_it1, lie_req1, tvs1, ids1, lie_avail1) ->
tc_mb_pats mb2 `thenTc` \ (complete_it2, lie_req2, tvs2, ids2, lie_avail2) ->
let
- complete_it = complete_it1 `thenTc` \ (mb1', lie1) ->
- complete_it2 `thenTc` \ (mb2', lie2) ->
- returnTc (AndMonoBinds mb1' mb2', lie1 `plusLIE` lie2)
+ complete_it xve = complete_it1 xve `thenTc` \ (mb1', lie1) ->
+ complete_it2 xve `thenTc` \ (mb2', lie2) ->
+ returnTc (AndMonoBinds mb1' mb2', lie1 `plusLIE` lie2)
in
returnTc (complete_it,
lie_req1 `plusLIE` lie_req2,
lie_avail1 `plusLIE` lie_avail2)
tc_mb_pats (FunMonoBind name inf matches locn)
- = newTyVarTy boxedTypeKind `thenNF_Tc` \ pat_ty ->
- tcVarPat sig_fn name pat_ty `thenTc` \ bndr_id ->
+ = newTyVarTy boxedTypeKind `thenNF_Tc` \ bndr_ty ->
+ tcVarPat sig_fn name bndr_ty `thenTc` \ bndr_id ->
let
- complete_it = tcAddSrcLoc locn $
- tcMatchesFun name pat_ty matches `thenTc` \ (matches', lie) ->
- returnTc (FunMonoBind (TcId bndr_id) inf matches' locn, lie)
+ complete_it xve = tcAddSrcLoc locn $
+ tcMatchesFun xve name bndr_ty matches `thenTc` \ (matches', lie) ->
+ returnTc (FunMonoBind bndr_id inf matches' locn, lie)
in
returnTc (complete_it, emptyLIE, emptyBag, unitBag (name, bndr_id), emptyLIE)
- tc_mb_pats bind@(PatMonoBind pat grhss_and_binds locn)
+ tc_mb_pats bind@(PatMonoBind pat grhss locn)
= tcAddSrcLoc locn $
- newTyVarTy kind `thenNF_Tc` \ pat_ty ->
+
+ -- Figure out the appropriate kind for the pattern,
+ -- and generate a suitable type variable
+ (case is_rec of
+ Recursive -> newTyVarTy boxedTypeKind -- Recursive, so no unboxed types
+ NonRecursive -> newTyVarTy_OpenKind -- Non-recursive, so we permit unboxed types
+ ) `thenNF_Tc` \ pat_ty ->
+
+ -- Now typecheck the pattern
+ -- We don't support binding fresh type variables in the
+ -- pattern of a pattern binding. For example, this is illegal:
+ -- (x::a, y::b) = e
+ -- whereas this is ok
+ -- (x::Int, y::Bool) = e
+ --
+ -- We don't check explicitly for this problem. Instead, we simply
+ -- type check the pattern with tcPat. If the pattern mentions any
+ -- fresh tyvars we simply get an out-of-scope type variable error
tcPat sig_fn pat pat_ty `thenTc` \ (pat', lie_req, tvs, ids, lie_avail) ->
let
- complete_it = tcAddSrcLoc locn $
- tcAddErrCtxt (patMonoBindsCtxt bind) $
- tcGRHSsAndBinds grhss_and_binds pat_ty PatBindRhs `thenTc` \ (grhss_and_binds', lie) ->
- returnTc (PatMonoBind pat' grhss_and_binds' locn, lie)
+ complete_it xve = tcAddSrcLoc locn $
+ tcAddErrCtxt (patMonoBindsCtxt bind) $
+ tcExtendLocalValEnv xve $
+ tcGRHSs grhss pat_ty PatBindRhs `thenTc` \ (grhss', lie) ->
+ returnTc (PatMonoBind pat' grhss' locn, lie)
in
returnTc (complete_it, lie_req, tvs, ids, lie_avail)
\end{code}
check_one_sig (TySigInfo _ id sig_tyvars _ sig_tau _ _ src_loc)
= tcAddSrcLoc src_loc $
- tcAddErrCtxtM (sigCtxt (quotes (ppr id)) sig_tau) $
+ tcAddErrCtxtM (sigCtxt (sig_msg id) (idType id)) $
checkSigTyVars sig_tyvars
mk_dict_tys theta = [mkDictTy c ts | (c,ts) <- theta]
+
+ sig_msg id tidy_ty = sep [ptext SLIT("When checking the type signature"),
+ nest 4 (ppr id <+> dcolon <+> ppr tidy_ty)]
\end{code}
\begin{code}
tcPragmaSigs :: [RenamedSig] -- The pragma signatures
-> TcM s (Name -> IdInfo, -- Maps name to the appropriate IdInfo
- TcMonoBinds s,
- LIE s)
+ TcMonoBinds,
+ LIE)
tcPragmaSigs sigs
= mapAndUnzip3Tc tcPragmaSig sigs `thenTc` \ (maybe_info_modifiers, binds, lies) ->
a bit of overkill.
\begin{code}
-tcPragmaSig :: RenamedSig -> TcM s (Maybe (Name, IdInfo -> IdInfo), TcMonoBinds s, LIE s)
+tcPragmaSig :: RenamedSig -> TcM s (Maybe (Name, IdInfo -> IdInfo), TcMonoBinds, LIE)
tcPragmaSig (Sig _ _ _) = returnTc (Nothing, EmptyMonoBinds, emptyLIE)
tcPragmaSig (SpecInstSig _ _) = returnTc (Nothing, EmptyMonoBinds, emptyLIE)
tcAddErrCtxt (valSpecSigCtxt name poly_ty) $
-- Get and instantiate its alleged specialised type
- tcHsTcType poly_ty `thenTc` \ sig_ty ->
+ tcHsType poly_ty `thenTc` \ sig_ty ->
-- Check that f has a more general type, and build a RHS for
-- the spec-pragma-id at the same time
-- It is the thing that makes sure we don't prematurely
-- dead-code-eliminate the binding we are really interested in.
newSpecPragmaId name sig_ty `thenNF_Tc` \ spec_id ->
- returnTc (Nothing, VarMonoBind (TcId spec_id) spec_expr, spec_lie)
+ returnTc (Nothing, VarMonoBind spec_id spec_expr, spec_lie)
Just g_name -> -- Don't create a SpecPragmaId. Instead add some suitable IdIfo
-- Get the type of f, and find out what types
-- f has to be instantiated at to give the signature type
- tcLookupLocalValueOK "tcPragmaSig" name `thenNF_Tc` \ f_id ->
+ tcLookupValue name `thenNF_Tc` \ f_id ->
tcInstTcType (idType f_id) `thenNF_Tc` \ (f_tyvars, f_rho) ->
let
-----------------------------------------------
valSpecSigCtxt v ty
= sep [ptext SLIT("In a SPECIALIZE pragma for a value:"),
- nest 4 (ppr v <+> ptext SLIT(" ::") <+> ppr ty)]
+ nest 4 (ppr v <+> dcolon <+> ppr ty)]
-----------------------------------------------
notAsPolyAsSigErr sig_tau mono_tyvars
\section[TcClassDcl]{Typechecking class declarations}
\begin{code}
-module TcClassDcl ( tcClassDecl1, tcClassDecls2, tcMethodBind, badMethodErr ) where
+module TcClassDcl ( kcClassDecl, tcClassDecl1, tcClassDecls2, tcMethodBind, badMethodErr ) where
#include "HsVersions.h"
-import HsSyn ( HsDecl(..), ClassDecl(..), Sig(..), MonoBinds(..),
- InPat(..), HsBinds(..), GRHSsAndBinds(..),
+import HsSyn ( HsDecl(..), TyClDecl(..), Sig(..), MonoBinds(..),
+ InPat(..), HsBinds(..), GRHSs(..),
HsExpr(..), HsLit(..), HsType(..), pprClassAssertion,
- unguardedRHS, andMonoBinds, andMonoBindList, getTyVarName
+ unguardedRHS, andMonoBinds, andMonoBindList, getTyVarName,
+ isClassDecl
)
import HsPragmas ( ClassPragmas(..) )
import BasicTypes ( NewOrData(..), TopLevelFlag(..), RecFlag(..), StrictnessMark(..) )
-import RnHsSyn ( RenamedClassDecl, RenamedClassPragmas,
+import RnHsSyn ( RenamedTyClDecl, RenamedClassPragmas,
RenamedClassOpSig, RenamedMonoBinds,
RenamedContext, RenamedHsDecl, RenamedSig
)
import TcHsSyn ( TcMonoBinds )
import Inst ( Inst, InstOrigin(..), LIE, emptyLIE, plusLIE, newDicts, newMethod )
-import TcEnv ( TcIdOcc(..), GlobalValueEnv, tcAddImportedIdInfo,
- tcLookupClass, tcLookupTyVar,
- tcExtendGlobalTyVars, tcExtendLocalValEnv
+import TcEnv ( TcId, ValueEnv, TcTyThing(..), tcAddImportedIdInfo,
+ tcLookupClass, tcLookupTy, tcExtendTyVarEnvForMeths, tcExtendGlobalTyVars,
+ tcExtendLocalValEnv
)
import TcBinds ( tcBindWithSigs, tcPragmaSigs )
import TcUnify ( unifyKinds )
import TcMonad
-import TcMonoType ( tcHsType, tcContext, checkSigTyVars, sigCtxt, mkTcSig )
+import TcMonoType ( tcHsType, tcHsTopType, tcExtendTopTyVarScope,
+ tcContext, checkSigTyVars, sigCtxt, mkTcSig
+ )
import TcSimplify ( tcSimplifyAndCheck, bindInstsOfLocalFuns )
-import TcType ( TcType, TcTyVar, tcInstTyVars, zonkTcTyVarBndr )
+import TcType ( TcType, TcTyVar, tcInstTyVars, zonkTcTyVarBndr, tcGetTyVar )
import PrelVals ( nO_METHOD_BINDING_ERROR_ID )
import FieldLabel ( firstFieldLabelTag )
import Bag ( unionManyBags )
Death to "ExpandingDicts".
+%************************************************************************
+%* *
+\subsection{Kind checking}
+%* *
+%************************************************************************
+
\begin{code}
-tcClassDecl1 rec_env rec_inst_mapper
- (ClassDecl context class_name
+kcClassDecl (ClassDecl context class_name
tyvar_names class_sigs def_methods pragmas
tycon_name datacon_name src_loc)
- = tcAddSrcLoc src_loc $
- tcAddErrCtxt (classDeclCtxt class_name) $
-
- -- CHECK ARITY 1 FOR HASKELL 1.4
+ = -- CHECK ARITY 1 FOR HASKELL 1.4
checkTc (opt_GlasgowExts || length tyvar_names == 1)
(classArityErr class_name) `thenTc_`
- -- LOOK THINGS UP IN THE ENVIRONMENT
- tcLookupClass class_name `thenTc` \ (class_kinds, rec_class) ->
- mapAndUnzipNF_Tc (tcLookupTyVar . getTyVarName) tyvar_names
- `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
+ -- Get the (mutable) class kind
+ tcLookupTy class_name `thenNF_Tc` \ (kind, _, _) ->
+
+ -- Make suitable tyvars and do kind checking
+ -- The net effect is to mutate the class kind
+ tcExtendTopTyVarScope kind tyvar_names $ \ _ _ ->
+ tcContext context `thenTc_`
+ mapTc kc_sig class_sigs `thenTc_`
+
+ returnTc ()
+ where
+ kc_sig (ClassOpSig _ _ op_ty loc) = tcAddSrcLoc loc (tcHsType op_ty)
+\end{code}
- -- FORCE THE CLASS AND ITS TYVAR TO HAVE SAME KIND
- unifyKinds class_kinds tyvar_kinds `thenTc_`
+%************************************************************************
+%* *
+\subsection{Type checking}
+%* *
+%************************************************************************
+
+\begin{code}
+tcClassDecl1 rec_env rec_inst_mapper
+ (ClassDecl context class_name
+ tyvar_names class_sigs def_methods pragmas
+ tycon_name datacon_name src_loc)
+ = -- LOOK THINGS UP IN THE ENVIRONMENT
+ tcLookupTy class_name `thenTc` \ (class_kind, _, AClass rec_class) ->
+ tcExtendTopTyVarScope class_kind tyvar_names $ \ tyvars _ ->
+ -- The class kind is by now immutable
+
-- CHECK THE CONTEXT
- tcClassContext class_name rec_class rec_tyvars context pragmas
+-- traceTc (text "tcClassCtxt" <+> ppr class_name) `thenTc_`
+ tcClassContext class_name rec_class tyvars context pragmas
`thenTc` \ (sc_theta, sc_tys, sc_sel_ids) ->
+-- traceTc (text "tcClassCtxt done" <+> ppr class_name) `thenTc_`
-- CHECK THE CLASS SIGNATURES,
- mapTc (tcClassSig rec_env rec_class rec_tyvars) class_sigs
+ mapTc (tcClassSig rec_env rec_class tyvars) class_sigs
`thenTc` \ sig_stuff ->
-- MAKE THE CLASS OBJECT ITSELF
let
(op_tys, op_sel_ids, defm_ids) = unzip3 sig_stuff
rec_class_inst_env = rec_inst_mapper rec_class
- clas = mkClass (getName class_name) rec_tyvars
+ clas = mkClass class_name tyvars
sc_theta sc_sel_ids op_sel_ids defm_ids
tycon
rec_class_inst_env
dict_con = mkDataCon datacon_name
[NotMarkedStrict | _ <- dict_component_tys]
[{- No labelled fields -}]
- rec_tyvars
+ tyvars
[{-No context-}]
[{-No existential tyvars-}] [{-Or context-}]
dict_component_tys
dict_con_id = mkDataConId dict_con
tycon = mkAlgTyCon tycon_name
- (foldr (mkArrowKind . tyVarKind) boxedTypeKind rec_tyvars)
- rec_tyvars
+ class_kind
+ tyvars
[] -- No context
[dict_con] -- Constructors
[] -- No derivings
is_tyvar other = False
-tcClassSig :: GlobalValueEnv -- Knot tying only!
+tcClassSig :: ValueEnv -- Knot tying only!
-> Class -- ...ditto...
-> [TyVar] -- The class type variable, used for error check only
-> RenamedClassOpSig
-- NB: Renamer checks that the class type variable is mentioned in local_ty,
-- and that it is not constrained by theta
- tcHsType op_ty `thenTc` \ local_ty ->
+-- traceTc (text "tcClassSig" <+> ppr op_name) `thenTc_`
+ tcHsTopType op_ty `thenTc` \ local_ty ->
let
global_ty = mkSigmaTy rec_clas_tyvars
[(rec_clas, mkTyVarTys rec_clas_tyvars)]
local_ty
- in
-- Build the selector id and default method id
- let
sel_id = mkMethodSelId op_name rec_clas global_ty
maybe_dm_id = case maybe_dm_name of
Nothing -> Nothing
in
Just (tcAddImportedIdInfo rec_env dm_id)
in
+-- traceTc (text "tcClassSig done" <+> ppr op_name) `thenTc_`
returnTc (local_ty, sel_id, maybe_dm_id)
\end{code}
\begin{code}
tcClassDecls2 :: [RenamedHsDecl]
- -> NF_TcM s (LIE s, TcMonoBinds s)
+ -> NF_TcM s (LIE, TcMonoBinds)
tcClassDecls2 decls
= foldr combine
(returnNF_Tc (emptyLIE, EmptyMonoBinds))
- [tcClassDecl2 cls_decl | ClD cls_decl <- decls]
+ [tcClassDecl2 cls_decl | TyClD cls_decl <- decls, isClassDecl cls_decl]
where
combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) ->
tc2 `thenNF_Tc` \ (lie2, binds2) ->
@tcClassDecl2@ is the business end of things.
\begin{code}
-tcClassDecl2 :: RenamedClassDecl -- The class declaration
- -> NF_TcM s (LIE s, TcMonoBinds s)
+tcClassDecl2 :: RenamedTyClDecl -- The class declaration
+ -> NF_TcM s (LIE, TcMonoBinds)
tcClassDecl2 (ClassDecl context class_name
tyvar_names class_sigs default_binds pragmas _ _ src_loc)
tcAddSrcLoc src_loc $
-- Get the relevant class
- tcLookupClass class_name `thenTc` \ (_, clas) ->
+ tcLookupClass class_name `thenNF_Tc` \ clas ->
let
(tyvars, sc_theta, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas
-- The selector binds are already in the selector Id's unfoldings
--- sel_binds = [ CoreMonoBind (RealId sel_id) (getUnfoldingTemplate (getIdUnfolding sel_id))
+-- sel_binds = [ CoreMonoBind sel_id (getUnfoldingTemplate (getIdUnfolding sel_id))
-- | sel_id <- sc_sel_ids ++ op_sel_ids,
-- isLocallyDefined sel_id
-- ]
tcDefaultMethodBinds
:: Class
-> RenamedMonoBinds
- -> TcM s (LIE s, TcMonoBinds s)
+ -> TcM s (LIE, TcMonoBinds)
tcDefaultMethodBinds clas default_binds
= -- Construct suitable signatures
-- Typecheck the default bindings
let
+ theta = [(clas,inst_tys)]
tc_dm sel_id_w_dm@(_, Just dm_id)
- = tcMethodBind clas origin inst_tys clas_tyvars
+ = tcMethodBind clas origin clas_tyvars inst_tys theta
default_binds [{-no prags-}] False
sel_id_w_dm `thenTc` \ (bind, insts, (_, local_dm_id)) ->
- returnTc (bind, insts, (clas_tyvars, RealId dm_id, local_dm_id))
- in
- mapAndUnzip3Tc tc_dm sel_ids_w_dms `thenTc` \ (defm_binds, insts_needed, abs_bind_stuff) ->
+ returnTc (bind, insts, (clas_tyvars, dm_id, local_dm_id))
+ in
+ tcExtendTyVarEnvForMeths tyvars clas_tyvars (
+ mapAndUnzip3Tc tc_dm sel_ids_w_dms
+ ) `thenTc` \ (defm_binds, insts_needed, abs_bind_stuff) ->
+
-- Check the context
- newDicts origin [(clas,inst_tys)] `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
+ newDicts origin theta `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
let
avail_insts = this_dict
in
- tcAddErrCtxt (classDeclCtxt clas) $
+ tcAddErrCtxt (defltMethCtxt clas) $
-- tcMethodBind has checked that the class_tyvars havn't
-- been unified with each other or another type, but we must
- -- still zonk them
+ -- still zonk them before passing them to tcSimplifyAndCheck
mapNF_Tc zonkTcTyVarBndr clas_tyvars `thenNF_Tc` \ clas_tyvars' ->
tcSimplifyAndCheck
\begin{code}
tcMethodBind
:: Class
- -> InstOrigin s
- -> [TcType s] -- Instance types
- -> [TcTyVar s] -- Free variables of those instance types
- -- they'll be signature tyvars, and we
- -- want to check that they don't bound
+ -> InstOrigin
+ -> [TcTyVar] -- Instantiated type variables for the
+ -- enclosing class/instance decl.
+ -- They'll be signature tyvars, and we
+ -- want to check that they don't get bound
+ -> [TcType] -- Instance types
+ -> TcThetaType -- Available theta; this could be used to check
+ -- the method signature, but actually that's done by
+ -- the caller; here, it's just used for the error message
-> RenamedMonoBinds -- Method binding (pick the right one from in here)
-> [RenamedSig] -- Pramgas (just for this one)
-> Bool -- True <=> supply default decl if no explicit decl
-- This is true for instance decls,
-- false for class decls
-> (Id, Maybe Id) -- The method selector and default-method Id
- -> TcM s (TcMonoBinds s, LIE s, (LIE s, TcIdOcc s))
+ -> TcM s (TcMonoBinds, LIE, (LIE, TcId))
-tcMethodBind clas origin inst_tys inst_tyvars
+tcMethodBind clas origin inst_tyvars inst_tys inst_theta
meth_binds prags supply_default_bind
(sel_id, maybe_dm_id)
= tcGetSrcLoc `thenNF_Tc` \ loc ->
- newMethod origin (RealId sel_id) inst_tys `thenNF_Tc` \ meth@(_, TcId meth_id) ->
- mkTcSig meth_id loc `thenNF_Tc` \ sig_info ->
+ newMethod origin sel_id inst_tys `thenNF_Tc` \ meth@(_, meth_id) ->
+ mkTcSig meth_id loc `thenNF_Tc` \ sig_info ->
let
meth_name = idName meth_id
(omittedMethodWarn sel_id clas) `thenNF_Tc_`
-- Check the pragmas
- tcExtendLocalValEnv [meth_name] [meth_id] (
+ tcExtendLocalValEnv [(meth_name, meth_id)] (
tcPragmaSigs meth_prags
) `thenTc` \ (prag_info_fn, prag_binds1, prag_lie) ->
- -- Check the bindings
+ -- Check the bindings; first add inst_tyvars to the envt
+ -- so that we don't quantify over them in nested places
+ -- The *caller* put the class/inst decl tyvars into the envt
tcExtendGlobalTyVars (mkVarSet inst_tyvars) (
tcAddErrCtxt (methodCtxt sel_id) $
tcBindWithSigs NotTopLevel meth_bind [sig_info]
NonRecursive prag_info_fn
- ) `thenTc` \ (binds, insts, _) ->
+ ) `thenTc` \ (binds, insts, _) ->
-- The prag_lie for a SPECIALISE pragma will mention the function
-- Now check that the instance type variables
-- (or, in the case of a class decl, the class tyvars)
-- have not been unified with anything in the environment
- tcAddErrCtxtM (sigCtxt (quotes (ppr sel_id)) (idType meth_id)) (
+ tcAddErrCtxtM (sigCtxt sig_msg (mkSigmaTy inst_tyvars inst_theta (idType meth_id))) $
checkSigTyVars inst_tyvars `thenTc_`
returnTc (binds `AndMonoBinds` prag_binds1 `AndMonoBinds` prag_binds2,
insts `plusLIE` prag_lie',
- meth))
-
+ meth)
where
+ sig_msg ty = sep [ptext SLIT("When checking the expected type for"),
+ nest 4 (ppr sel_name <+> dcolon <+> ppr ty)]
+
sel_name = idName sel_id
-- The renamer just puts the selector ID as the binder in the method binding
-- but we must use the method name; so we substitute it here. Crude but simple.
find_bind meth_name (FunMonoBind op_name fix matches loc)
| op_name == sel_name = Just (FunMonoBind meth_name fix matches loc)
- find_bind meth_name (PatMonoBind (VarPatIn op_name) rhs loc)
- | op_name == sel_name = Just (PatMonoBind (VarPatIn meth_name) rhs loc)
+ find_bind meth_name (PatMonoBind (VarPatIn op_name) grhss loc)
+ | op_name == sel_name = Just (PatMonoBind (VarPatIn meth_name) grhss loc)
find_bind meth_name (AndMonoBinds b1 b2)
= find_bind meth_name b1 `seqMaybe` find_bind meth_name b2
find_bind meth_name other = Nothing -- Default case
mk_default_bind local_meth_name loc
= PatMonoBind (VarPatIn local_meth_name)
- (GRHSsAndBindsIn (unguardedRHS (default_expr loc) loc) EmptyBinds)
+ (GRHSs (unguardedRHS (default_expr loc) loc) EmptyBinds Nothing)
loc
default_expr loc
classArityErr class_name
= ptext SLIT("Too many parameters for class") <+> quotes (ppr class_name)
-classDeclCtxt class_name
- = ptext SLIT("In the class declaration for") <+> quotes (ppr class_name)
-
superClassErr class_name sc
= ptext SLIT("Illegal superclass constraint") <+> quotes (pprClassAssertion sc)
<+> ptext SLIT("in declaration for class") <+> quotes (ppr class_name)
+defltMethCtxt class_name
+ = ptext SLIT("When checking the default methods for class") <+> quotes (ppr class_name)
+
methodCtxt sel_id
= ptext SLIT("In the definition for method") <+> quotes (ppr sel_id)
import HsSyn ( HsBinds(..), MonoBinds(..), collectMonoBinders )
import RdrHsSyn ( RdrName, RdrNameMonoBinds )
import RnHsSyn ( RenamedHsBinds, RenamedMonoBinds )
+import CmdLineOpts ( opt_D_dump_deriv )
import TcMonad
import Inst ( InstanceMapper )
-import TcEnv ( getEnv_TyCons )
+import TcEnv ( getEnvTyCons )
import TcGenDeriv -- Deriv stuff
import TcInstUtil ( InstInfo(..), buildInstanceEnvs )
import TcSimplify ( tcSimplifyThetas )
import RnBinds ( rnMethodBinds, rnTopMonoBinds )
-import RnEnv ( newDfunName, bindLocatedLocalsRn )
+import RnEnv ( newDFunName, bindLocatedLocalsRn )
import RnMonad ( RnNameSupply,
renameSourceCode, thenRn, mapRn, returnRn )
import Bag ( Bag, emptyBag, unionBags, listToBag )
import Class ( classKey, Class )
-import ErrUtils ( ErrMsg )
+import ErrUtils ( ErrMsg, dumpIfSet )
import MkId ( mkDictFunId )
import Id ( mkVanillaId )
import DataCon ( dataConArgTys, isNullaryDataCon )
tyConTheta, maybeTyConSingleCon, isDataTyCon,
isEnumerationTyCon, isAlgTyCon, TyCon
)
-import Type ( GenType(..), TauType, mkTyVarTys, mkTyConApp,
+import Type ( TauType, mkTyVarTys, mkTyConApp,
mkSigmaTy, mkDictTy, isUnboxedType,
splitAlgTyConApp
)
-> RnNameSupply -- for "renaming" bits of generated code
-> Bag InstInfo -- What we already know about instances
-> TcM s (Bag InstInfo, -- The generated "instance decls".
- RenamedHsBinds, -- Extra generated bindings
- SDoc) -- Printable derived instance decls;
- -- for debugging via -ddump-derivings.
+ RenamedHsBinds) -- Extra generated bindings
tcDeriving modname rn_name_supply inst_decl_infos_in
- = recoverTc (returnTc (emptyBag, EmptyBinds, empty)) $
+ = recoverTc (returnTc (emptyBag, EmptyBinds)) $
-- Fish the "deriving"-related information out of the TcEnv
-- and make the necessary "equations".
makeDerivEqns `thenTc` \ eqns ->
if null eqns then
- returnTc (emptyBag, EmptyBinds, text "No derivings")
+ returnTc (emptyBag, EmptyBinds)
else
-- Take the equation list and solve it, to deliver a list of
(dfun_names_w_method_binds, rn_extra_binds)
= renameSourceCode modname rn_name_supply (
bindLocatedLocalsRn (ptext (SLIT("deriving"))) mbinders $ \ _ ->
- rnTopMonoBinds extra_mbinds [] `thenRn` \ rn_extra_binds ->
+ rnTopMonoBinds extra_mbinds [] `thenRn` \ (rn_extra_binds, _) ->
mapRn rn_one method_binds_s `thenRn` \ dfun_names_w_method_binds ->
returnRn (dfun_names_w_method_binds, rn_extra_binds)
)
rn_one (cl_nm, tycon_nm, meth_binds)
- = newDfunName cl_nm tycon_nm
+ = newDFunName cl_nm tycon_nm
Nothing mkGeneratedSrcLoc `thenRn` \ dfun_name ->
- rnMethodBinds meth_binds `thenRn` \ rn_meth_binds ->
+ rnMethodBinds meth_binds `thenRn` \ (rn_meth_binds, _) ->
returnRn (dfun_name, rn_meth_binds)
really_new_inst_infos = map (gen_inst_info modname)
ddump_deriv = ddump_deriving really_new_inst_infos rn_extra_binds
in
- --pprTrace "derived:\n" (ddump_deriv) $
+ ioToTc (dumpIfSet opt_D_dump_deriv "Derived instances" ddump_deriv) `thenTc_`
- returnTc (listToBag really_new_inst_infos,
- rn_extra_binds,
- ddump_deriv)
+ returnTc (listToBag really_new_inst_infos, rn_extra_binds)
where
ddump_deriving :: [InstInfo] -> RenamedHsBinds -> SDoc
-
ddump_deriving inst_infos extra_binds
- = vcat ((map pp_info inst_infos) ++ [ppr extra_binds])
+ = vcat (map pp_info inst_infos) $$ ppr extra_binds
where
pp_info (InstInfo clas tvs [ty] inst_decl_theta _ mbinds _ _)
- = ($$) (ppr (mkSigmaTy tvs inst_decl_theta (mkDictTy clas [ty])))
- (ppr mbinds)
+ = ppr (mkSigmaTy tvs inst_decl_theta (mkDictTy clas [ty]))
+ $$
+ ppr mbinds
\end{code}
= tcGetEnv `thenNF_Tc` \ env ->
let
local_data_tycons = filter (\tc -> isLocallyDefined tc && isAlgTyCon tc)
- (getEnv_TyCons env)
+ (getEnvTyCons env)
think_about_deriving = need_deriving local_data_tycons
(derive_these, _) = removeDups cmp_deriv think_about_deriving
_exports_
TcEnv TcEnv;
_declarations_
-1 data TcEnv a;
+1 data TcEnv;
\begin{code}
module TcEnv(
- TcIdOcc(..), TcIdBndr, TcIdSet, tcIdType, tcIdTyVars, tcInstId,
+ TcId, TcIdSet, tcInstId,
tcLookupDataCon,
- TcEnv, GlobalValueEnv,
+ TcEnv, ValueEnv, TcTyThing(..),
- initEnv, getEnv_TyCons, getEnv_Classes,
+ initEnv, getEnvTyCons, getEnvClasses,
- tcExtendTyVarEnv, tcLookupTyVar, tcLookupTyVarBndrs,
+ tcExtendTyVarEnv, tcExtendTyVarEnvForMeths, tcExtendTypeEnv, tcGetInScopeTyVars,
- tcExtendTyConEnv, tcLookupTyCon, tcLookupTyConByKey,
- tcExtendClassEnv, tcLookupClass, tcLookupClassByKey,
- tcGetTyConsAndClasses,
+ tcLookupTy,
+ tcLookupTyCon, tcLookupTyConByKey,
+ tcLookupClass, tcLookupClassByKey,
- tcExtendGlobalValEnv, tcExtendLocalValEnv, tcExtendEnvWithPat,
- tcGetGlobalValEnv, tcSetGlobalValEnv, lookupGlobalByKey,
- tcLookupLocalValue, tcLookupLocalValueOK, tcLookupLocalValueByKey,
- tcLookupGlobalValue, tcLookupGlobalValueByKey, tcLookupGlobalValueMaybe,
- tcAddImportedIdInfo, tcExplicitLookupGlobal,
- tcLookupGlobalValueByKeyMaybe,
+ tcExtendGlobalValEnv, tcExtendLocalValEnv,
+ tcGetValueEnv, tcSetValueEnv,
+ tcAddImportedIdInfo,
+
+ tcLookupValue, tcLookupValueMaybe,
+ tcLookupValueByKey, tcLookupValueByKeyMaybe,
+ explicitLookupValueByKey, explicitLookupValue,
newLocalIds, newLocalId, newSpecPragmaId,
tcGetGlobalTyVars, tcExtendGlobalTyVars,
- tidyType, tidyTypes, tidyTyVar,
-
badCon, badPrimOp
) where
#include "HsVersions.h"
-import HsTypes ( getTyVarName )
+import HsTypes ( HsTyVar, getTyVarName )
import Id ( mkUserLocal, isDataConId_maybe )
import MkId ( mkSpecPragmaId )
-import Var ( TyVar, Id, GenId, setVarName,
- idType, setIdInfo, idInfo
+import Var ( TyVar, Id, setVarName,
+ idType, setIdInfo, idInfo, tyVarKind
)
-import TcType ( TcType, TcTyVar, TcTyVarSet, TcThetaType, TcBox,
+import TcType ( TcType, TcTyVar, TcTyVarSet, TcThetaType,
tcInstTyVars, zonkTcTyVars,
TcKind, kindToTcKind
)
import VarEnv
import VarSet
-import Type ( Kind,
+import Type ( Kind, superKind,
tyVarsOfType, tyVarsOfTypes, mkTyVarTy, substTy,
- splitForAllTys, splitRhoTy, splitFunTys, substFlexiTy,
+ splitForAllTys, splitRhoTy, splitFunTys, substTopTy,
splitAlgTyConApp_maybe, getTyVar
)
import DataCon ( DataCon )
import BasicTypes ( Arity )
import IdInfo ( noIdInfo )
-import Name ( Name, OccName(..), nameOccName, occNameString, mkLocalName,
+import Name ( Name, OccName, nameOccName, occNameString, mkLocalName,
maybeWiredInTyConName, maybeWiredInIdName, isLocallyDefined,
isSysLocalName,
NamedThing(..)
import Util ( zipEqual, zipWith3Equal, mapAccumL )
import Bag ( bagToList )
import Maybes ( maybeToBool )
+import FastString ( FastString )
import Outputable
\end{code}
%************************************************************************
%* *
-\subsection{TcId, TcIdOcc}
+\subsection{TcId}
%* *
%************************************************************************
\begin{code}
-type TcIdBndr s = GenId (TcBox s) -- Binders are all TcTypes
-data TcIdOcc s = TcId (TcIdBndr s) -- Bindees may be either
- | RealId Id
-
-type TcIdSet s = GenIdSet (TcBox s)
-
-instance Eq (TcIdOcc s) where
- (TcId id1) == (TcId id2) = id1 == id2
- (RealId id1) == (RealId id2) = id1 == id2
- _ == _ = False
-
-instance Ord (TcIdOcc s) where
- (TcId id1) `compare` (TcId id2) = id1 `compare` id2
- (RealId id1) `compare` (RealId id2) = id1 `compare` id2
- (TcId _) `compare` (RealId _) = LT
- (RealId _) `compare` (TcId _) = GT
-
-instance Outputable (TcIdOcc s) where
- ppr (TcId id) = ppr id
- ppr (RealId id) = ppr id
-
-instance NamedThing (TcIdOcc s) where
- getName (TcId id) = getName id
- getName (RealId id) = getName id
+type TcId = Id -- Type may be a TcType
+type TcIdSet = IdSet
-
-tcIdType :: TcIdOcc s -> TcType s
-tcIdType (TcId id) = idType id
-tcIdType (RealId id) = pprPanic "tcIdType:" (ppr id)
-
-tcIdTyVars (TcId id) = tyVarsOfType (idType id)
-tcIdTyVars (RealId _) = emptyVarSet -- Top level Ids have no free type variables
-
-
-tcLookupDataCon :: Name -> TcM s (DataCon, [TcType s], TcType s)
+tcLookupDataCon :: Name -> TcM s (DataCon, [TcType], TcType)
tcLookupDataCon con_name
- = tcLookupGlobalValue con_name `thenNF_Tc` \ con_id ->
+ = tcLookupValue con_name `thenNF_Tc` \ con_id ->
case isDataConId_maybe con_id of {
Nothing -> failWithTc (badCon con_id);
Just data_con ->
-- A useful function that takes an occurrence of a global thing
-- and instantiates its type with fresh type variables
tcInstId :: Id
- -> NF_TcM s ([TcTyVar s], -- It's instantiated type
- TcThetaType s, --
- TcType s) --
-
+ -> NF_TcM s ([TcTyVar], -- It's instantiated type
+ TcThetaType, --
+ TcType) --
tcInstId id
= let
(tyvars, rho) = splitForAllTys (idType id)
in
tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', arg_tys, tenv) ->
let
- rho' = substFlexiTy tenv rho
+ rho' = substTopTy tenv rho
(theta', tau') = splitRhoTy rho'
in
returnNF_Tc (tyvars', theta', tau')
\end{code}
-tidyTy tidies up a type for printing in an error message.
-
-\begin{code}
-tidyType :: TidyTypeEnv s -> TcType s -> (TidyTypeEnv s, TcType s)
-tidyType env ty
- = (env', substTy subst' ty)
- where
- env'@(_, subst') = foldl go env (varSetElems (tyVarsOfType ty))
- go env tyvar = fst (tidyTyVar env tyvar)
-
-tidyTypes :: TidyTypeEnv s -> [TcType s] -> (TidyTypeEnv s, [TcType s])
-tidyTypes env tys = mapAccumL tidyType env tys
-
-tidyTyVar :: TidyTypeEnv s -> TcTyVar s -> (TidyTypeEnv s, TcTyVar s)
-tidyTyVar (supply,subst) tyvar
- = case lookupVarEnv subst tyvar of
- Just ty -> -- Already substituted
- ((supply,subst), getTyVar "tidyTyVar" ty)
- Nothing -> -- Make a new nice name for it
- ((addToFM supply str next,
- extendVarEnv subst tyvar (mkTyVarTy new_tyvar)),
- new_tyvar)
- where
- tyvar_name = getName tyvar
- is_sys = isSysLocalName tyvar_name
-
- str | is_sys = SLIT("$")
- | otherwise = occNameString (nameOccName tyvar_name)
-
- next = case lookupFM supply str of
- Nothing -> 0
- Just n -> n+1
-
- new_tyvar = mkNewTv str is_sys next tyvar
-
-mkNewTv :: FastString -> Bool -> Int -> TcTyVar s -> TcTyVar s
-mkNewTv str False 0 tv = tv -- Leave first non-sys thing alone
-mkNewTv str is_sys n tv = setVarName tv (mkLocalName (getUnique tv)
- (TvOcc (_PK_ ((_UNPK_ str) ++ show n))))
-\end{code}
-
%************************************************************************
%* *
~~~~~~~~~~~~~~~~~~~~~
\begin{code}
-data TcEnv s = TcEnv
- (TcTyVarEnv s)
- (TyConEnv s)
- (ClassEnv s)
- GlobalValueEnv
- (ValueEnv (TcIdBndr s)) -- Locals
- (TcRef s (TcTyVarSet s)) -- Free type variables of locals
- -- ...why mutable? see notes with tcGetGlobalTyVars
-
-type TcTyVarEnv s = UniqFM (TcKind s, TyVar)
-type TyConEnv s = UniqFM (TcKind s, Maybe Arity, TyCon) -- Arity present for Synonyms only
-type ClassEnv s = UniqFM ([TcKind s], Class) -- The kinds are the kinds of the args
- -- to the class
-type ValueEnv id = UniqFM id
-type GlobalValueEnv = ValueEnv Id -- Globals
-
-initEnv :: TcRef s (TcTyVarSet s) -> TcEnv s
-initEnv mut = TcEnv emptyUFM emptyUFM emptyUFM emptyUFM emptyUFM mut
-
-getEnv_TyCons (TcEnv _ ts _ _ _ _) = [tycon | (_, _, tycon) <- eltsUFM ts]
-getEnv_Classes (TcEnv _ _ cs _ _ _) = [clas | (_, clas) <- eltsUFM cs]
-\end{code}
-
-Type variable env
-~~~~~~~~~~~~~~~~~
-\begin{code}
-tcExtendTyVarEnv :: [Name] -> [(TcKind s, TyVar)] -> TcM s r -> TcM s r
-tcExtendTyVarEnv names kinds_w_types scope
- = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
- let
- tve' = addListToUFM tve (zipEqual "tcTyVarScope" names kinds_w_types)
- in
- tcSetEnv (TcEnv tve' tce ce gve lve gtvs) scope
-\end{code}
+data TcEnv = TcEnv
+ TypeEnv
+ ValueEnv
+ (TcTyVarSet, -- The in-scope TyVars
+ TcRef TcTyVarSet) -- Free type variables of the value env
+ -- ...why mutable? see notes with tcGetGlobalTyVars
+ -- Includes the in-scope tyvars
-The Kind, TyVar, Class and TyCon envs
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+type NameEnv val = UniqFM val -- Keyed by Names
-Extending the environments.
+type TypeEnv = NameEnv (TcKind, Maybe Arity, TcTyThing)
+type ValueEnv = NameEnv Id
-\begin{code}
-tcExtendTyConEnv :: [(Name, (TcKind s, Maybe Arity, TyCon))] -> TcM s r -> TcM s r
+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
-tcExtendTyConEnv bindings scope
- = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
- let
- tce' = addListToUFM tce bindings
- in
- tcSetEnv (TcEnv tve tce' ce gve lve gtvs) scope
+initEnv :: TcRef TcTyVarSet -> TcEnv
+initEnv mut = TcEnv emptyUFM emptyUFM (emptyVarSet, mut)
-tcExtendClassEnv :: [(Name, ([TcKind s], Class))] -> TcM s r -> TcM s r
-tcExtendClassEnv bindings scope
- = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
- let
- ce' = addListToUFM ce bindings
- in
- tcSetEnv (TcEnv tve tce ce' gve lve gtvs) scope
+getEnvTyCons (TcEnv te _ _) = [tc | (_, _, ATyCon tc) <- eltsUFM te]
+getEnvClasses (TcEnv te _ _) = [cl | (_, _, AClass cl) <- eltsUFM te]
\end{code}
+The TypeEnv
+~~~~~~~~~~~~
-Looking up in the environments.
+Extending the type environment.
\begin{code}
-tcLookupTyVarBndrs tyvar_bndrs -- [HsTyVar name]
- = mapAndUnzipNF_Tc (tcLookupTyVar . getTyVarName) tyvar_bndrs
-
-tcLookupTyVar name
- = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
- returnNF_Tc (lookupWithDefaultUFM tve (pprPanic "tcLookupTyVar:" (ppr name)) name)
-
-
-tcLookupTyCon name
- = -- Try for a wired-in tycon
- case maybeWiredInTyConName name of {
- Just tc | isSynTyCon tc -> returnTc (kind, Just (tyConArity tc), tc)
- | otherwise -> returnTc (kind, Nothing, tc)
- where {
- kind = kindToTcKind (tyConKind tc)
- };
-
- Nothing ->
-
- -- Try in the environment
- tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
- case lookupUFM tce name of {
- Just stuff -> returnTc stuff;
-
- Nothing ->
-
- -- Could be that he's using a class name as a type constructor
- case lookupUFM ce name of
- Just _ -> failWithTc (classAsTyConErr name)
- Nothing -> pprPanic "tcLookupTyCon:" (ppr name)
- } }
-
-tcLookupTyConByKey uniq
- = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
- let
- (kind, arity, tycon) = lookupWithDefaultUFM_Directly tce
- (pprPanic "tcLookupTyConByKey:" (pprUnique10 uniq))
- uniq
- in
- returnNF_Tc tycon
-
-tcLookupClass name
- = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
- case lookupUFM ce name of
- Just stuff -- Common case: it's ok
- -> returnTc stuff
-
- Nothing -- Could be that he's using a type constructor as a class
- | maybeToBool (maybeWiredInTyConName name)
- || maybeToBool (lookupUFM tce name)
- -> failWithTc (tyConAsClassErr name)
-
- | otherwise -- Wierd! Renamer shouldn't let this happen
- -> pprPanic "tcLookupClass" (ppr name)
-
-tcLookupClassByKey uniq
- = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
+tcExtendTyVarEnv :: [TyVar] -> TcM s r -> TcM s r
+tcExtendTyVarEnv tyvars scope
+ = tcGetEnv `thenNF_Tc` \ (TcEnv te ve (in_scope_tvs, gtvs)) ->
let
- (kind, clas) = lookupWithDefaultUFM_Directly ce
- (pprPanic "tcLookupClassByKey:" (pprUnique10 uniq))
- uniq
+ extend_list = [ (getName tv, (kindToTcKind (tyVarKind tv), Nothing, ATyVar tv))
+ | tv <- tyvars
+ ]
+ te' = addListToUFM te extend_list
+ new_tv_set = mkVarSet tyvars
+ in_scope_tvs' = in_scope_tvs `unionVarSet` new_tv_set
in
- returnNF_Tc clas
-
-tcGetTyConsAndClasses :: NF_TcM s ([TyCon], [Class])
-tcGetTyConsAndClasses
- = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
- returnNF_Tc ([tc | (_, _, tc) <- eltsUFM tce],
- [c | (_, c) <- eltsUFM ce])
-\end{code}
-
-
-
-Extending and consulting the value environment
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-\begin{code}
-tcExtendGlobalValEnv ids scope
- = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
+ -- It's important to add the in-scope tyvars to the global tyvar set
+ -- as well. Consider
+ -- f (x::r) = let g y = y::r in ...
+ -- Here, g mustn't be generalised. This is also important during
+ -- class and instance decls, when we mustn't generalise the class tyvars
+ -- when typechecking the methods.
+ tc_extend_gtvs gtvs new_tv_set `thenNF_Tc` \ gtvs' ->
+ tcSetEnv (TcEnv te' ve (in_scope_tvs', gtvs')) scope
+
+-- This variant, tcExtendTyVarEnvForMeths, takes *two* bunches of tyvars:
+-- the signature tyvars contain the original names
+-- the instance tyvars are what those names should be mapped to
+-- It's needed when typechecking the method bindings of class and instance decls
+-- It does *not* extend the global tyvars; tcMethodBind does that for itself
+
+tcExtendTyVarEnvForMeths :: [TyVar] -> [TcTyVar] -> TcM s r -> TcM s r
+tcExtendTyVarEnvForMeths sig_tyvars inst_tyvars thing_inside
+ = tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
let
- gve' = addListToUFM_Directly gve [(getUnique id, id) | id <- ids]
+ te' = addListToUFM te stuff
in
- tcSetEnv (TcEnv tve tce ce gve' lve gtvs) scope
-
-tcExtendLocalValEnv names ids scope
- = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
- tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
- let
- lve' = addListToUFM lve (zipEqual "tcExtendLocalValEnv" names ids)
- extra_global_tyvars = tyVarsOfTypes (map idType ids)
- new_global_tyvars = global_tvs `unionVarSet` extra_global_tyvars
- in
- tcNewMutVar new_global_tyvars `thenNF_Tc` \ gtvs' ->
+ tcSetEnv (TcEnv te' ve gtvs) thing_inside
+ where
+ stuff = [ (getName sig_tv, (kindToTcKind (tyVarKind inst_tv), Nothing, ATyVar inst_tv))
+ | (sig_tv, inst_tv) <- zipEqual "tcMeth" sig_tyvars inst_tyvars
+ ]
- tcSetEnv (TcEnv tve tce ce gve lve' gtvs') scope
+tcExtendGlobalTyVars extra_global_tvs scope
+ = tcGetEnv `thenNF_Tc` \ (TcEnv te ve (in_scope,gtvs)) ->
+ tc_extend_gtvs gtvs extra_global_tvs `thenNF_Tc` \ gtvs' ->
+ tcSetEnv (TcEnv te ve (in_scope,gtvs')) scope
-tcExtendEnvWithPat names_w_ids scope
- = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
- tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
+tc_extend_gtvs gtvs extra_global_tvs
+ = tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
let
- names_w_ids_list = bagToList names_w_ids
- lve' = addListToUFM lve names_w_ids_list
- extra_global_tyvars = tyVarsOfTypes (map (idType . snd) names_w_ids_list)
- new_global_tyvars = global_tvs `unionVarSet` extra_global_tyvars
+ new_global_tyvars = global_tvs `unionVarSet` extra_global_tvs
in
- tcNewMutVar new_global_tyvars `thenNF_Tc` \ gtvs' ->
-
- tcSetEnv (TcEnv tve tce ce gve lve' gtvs') scope
+ tcNewMutVar new_global_tyvars
\end{code}
@tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
the environment.
\begin{code}
-tcGetGlobalTyVars :: NF_TcM s (TcTyVarSet s)
+tcGetGlobalTyVars :: NF_TcM s TcTyVarSet
tcGetGlobalTyVars
- = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
+ = tcGetEnv `thenNF_Tc` \ (TcEnv te ve (_,gtvs)) ->
tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
zonkTcTyVars (varSetElems global_tvs) `thenNF_Tc` \ global_tys' ->
let
tcWriteMutVar gtvs global_tvs' `thenNF_Tc_`
returnNF_Tc global_tvs'
-tcExtendGlobalTyVars extra_global_tvs scope
- = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
- tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
+tcGetInScopeTyVars :: NF_TcM s [TcTyVar]
+tcGetInScopeTyVars
+ = tcGetEnv `thenNF_Tc` \ (TcEnv te ve (in_scope_tvs, gtvs)) ->
+ returnNF_Tc (varSetElems in_scope_tvs)
+\end{code}
+
+
+Type constructors and classes
+
+\begin{code}
+tcExtendTypeEnv :: [(Name, (TcKind, Maybe Arity, TcTyThing))] -> TcM s r -> TcM s r
+tcExtendTypeEnv bindings scope
+ = ASSERT( null [tv | (_, (_,_,ATyVar tv)) <- bindings] )
+ -- Not for tyvars; use tcExtendTyVarEnv
+ tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
let
- new_global_tyvars = global_tvs `unionVarSet` extra_global_tvs
+ te' = addListToUFM te bindings
in
- tcNewMutVar new_global_tyvars `thenNF_Tc` \ gtvs' ->
- tcSetEnv (TcEnv tve tce ce gve lve gtvs') scope
+ tcSetEnv (TcEnv te' ve gtvs) scope
\end{code}
+
+Looking up in the environments.
+
\begin{code}
-tcLookupLocalValue :: Name -> NF_TcM s (Maybe (TcIdBndr s))
-tcLookupLocalValue name
- = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
- returnNF_Tc (lookupUFM lve name)
+tcLookupTy :: Name -> NF_TcM s (TcKind, Maybe Arity, TcTyThing)
+tcLookupTy name
+ = tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
+ case lookupUFM te name of {
+ Just thing -> returnNF_Tc thing ;
+ 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
+
+ Nothing -> pprPanic "tcLookupTy" (ppr 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 te ve gtvs) ->
+ case lookupUFM_Directly te key of
+ Just (_, _, AClass cl) -> returnNF_Tc cl
+ other -> pprPanic "tcLookupClassByKey:" (pprUnique10 key)
+
+tcLookupTyConByKey :: Unique -> NF_TcM s TyCon
+tcLookupTyConByKey key
+ = tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
+ case lookupUFM_Directly te key of
+ Just (_, _, ATyCon tc) -> returnNF_Tc tc
+ other -> pprPanic "tcLookupTyConByKey:" (pprUnique10 key)
+\end{code}
-tcLookupLocalValueByKey :: Unique -> NF_TcM s (Maybe (TcIdBndr s))
-tcLookupLocalValueByKey uniq
- = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
- returnNF_Tc (lookupUFM_Directly lve uniq)
-tcLookupLocalValueOK :: String -> Name -> NF_TcM s (TcIdBndr s)
-tcLookupLocalValueOK err name
- = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
- returnNF_Tc (lookupWithDefaultUFM lve (panic err) name)
-tcLookupGlobalValue :: Name -> NF_TcM s Id
-tcLookupGlobalValue name
+%************************************************************************
+%* *
+\subsection{The value environment}
+%* *
+%************************************************************************
+
+\begin{code}
+tcExtendGlobalValEnv :: [Id] -> TcM s a -> TcM s a
+tcExtendGlobalValEnv ids scope
+ = tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
+ let
+ ve' = addListToUFM_Directly ve [(getUnique id, id) | id <- ids]
+ in
+ tcSetEnv (TcEnv te ve' gtvs) scope
+
+tcExtendLocalValEnv :: [(Name,TcId)] -> TcM s a -> TcM s a
+tcExtendLocalValEnv names_w_ids scope
+ = tcGetEnv `thenNF_Tc` \ (TcEnv te ve (in_scope_tvs,gtvs)) ->
+ tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
+ let
+ ve' = addListToUFM ve names_w_ids
+ extra_global_tyvars = tyVarsOfTypes (map (idType . snd) names_w_ids)
+ in
+ tc_extend_gtvs gtvs extra_global_tyvars `thenNF_Tc` \ gtvs' ->
+ tcSetEnv (TcEnv te ve' (in_scope_tvs,gtvs')) scope
+\end{code}
+
+
+\begin{code}
+tcLookupValue :: Name -> NF_TcM s Id -- Panics if not found
+tcLookupValue name
= case maybeWiredInIdName name of
Just id -> returnNF_Tc id
- Nothing -> tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
- returnNF_Tc (lookupWithDefaultUFM gve def name)
+ Nothing -> tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
+ returnNF_Tc (lookupWithDefaultUFM ve def name)
where
- def = pprPanic "tcLookupGlobalValue:" (ppr name)
+ def = pprPanic "tcLookupValue:" (ppr name)
-tcLookupGlobalValueMaybe :: Name -> NF_TcM s (Maybe Id)
-tcLookupGlobalValueMaybe name
+tcLookupValueMaybe :: Name -> NF_TcM s (Maybe Id)
+tcLookupValueMaybe name
= case maybeWiredInIdName name of
Just id -> returnNF_Tc (Just id)
- Nothing -> tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
- returnNF_Tc (lookupUFM gve name)
-
-
-tcLookupGlobalValueByKey :: Unique -> NF_TcM s Id
-tcLookupGlobalValueByKey uniq
- = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
- returnNF_Tc (lookupGlobalByKey gve uniq)
-
-lookupGlobalByKey :: GlobalValueEnv -> Unique -> Id
-lookupGlobalByKey gve uniq
- = lookupWithDefaultUFM_Directly gve def uniq
- where
-#ifdef DEBUG
- def = pprPanic "tcLookupGlobalValueByKey:" (pprUnique10 uniq)
-#else
- def = panic "tcLookupGlobalValueByKey"
-#endif
+ Nothing -> tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
+ returnNF_Tc (lookupUFM ve name)
-tcLookupGlobalValueByKeyMaybe :: Unique -> NF_TcM s (Maybe Id)
-tcLookupGlobalValueByKeyMaybe uniq
- = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
- returnNF_Tc (lookupUFM_Directly gve uniq)
+tcLookupValueByKey :: Unique -> NF_TcM s Id -- Panics if not found
+tcLookupValueByKey key
+ = tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
+ returnNF_Tc (explicitLookupValueByKey ve key)
-tcGetGlobalValEnv :: NF_TcM s GlobalValueEnv
-tcGetGlobalValEnv
- = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
- returnNF_Tc gve
+tcLookupValueByKeyMaybe :: Unique -> NF_TcM s (Maybe Id)
+tcLookupValueByKeyMaybe key
+ = tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
+ returnNF_Tc (lookupUFM_Directly ve key)
-tcSetGlobalValEnv :: GlobalValueEnv -> TcM s a -> TcM s a
-tcSetGlobalValEnv gve scope
- = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce _ lve gtvs) ->
- tcSetEnv (TcEnv tve tce ce gve lve gtvs) scope
+tcGetValueEnv :: NF_TcM s ValueEnv
+tcGetValueEnv
+ = tcGetEnv `thenNF_Tc` \ (TcEnv te ve gtvs) ->
+ returnNF_Tc ve
+tcSetValueEnv :: ValueEnv -> TcM s a -> TcM s a
+tcSetValueEnv ve scope
+ = tcGetEnv `thenNF_Tc` \ (TcEnv te _ gtvs) ->
+ tcSetEnv (TcEnv te ve gtvs) scope
-- Non-monadic version, environment given explicitly
-tcExplicitLookupGlobal :: GlobalValueEnv -> Name -> Maybe Id
-tcExplicitLookupGlobal gve name
+explicitLookupValueByKey :: ValueEnv -> Unique -> Id
+explicitLookupValueByKey ve key
+ = lookupWithDefaultUFM_Directly ve def key
+ where
+ def = pprPanic "lookupValueByKey:" (pprUnique10 key)
+
+explicitLookupValue :: ValueEnv -> Name -> Maybe Id
+explicitLookupValue ve name
= case maybeWiredInIdName name of
Just id -> Just id
- Nothing -> lookupUFM gve name
+ Nothing -> lookupUFM ve name
-- Extract the IdInfo from an IfaceSig imported from an interface file
-tcAddImportedIdInfo :: GlobalValueEnv -> Id -> Id
+tcAddImportedIdInfo :: ValueEnv -> Id -> Id
tcAddImportedIdInfo unf_env id
| isLocallyDefined id -- Don't look up locally defined Ids, because they
-- have explicit local definitions, so we get a black hole!
-- The Id must be returned without a data dependency on maybe_id
where
new_info = -- pprTrace "tcAdd" (ppr id) $
- case tcExplicitLookupGlobal unf_env (getName id) of
+ case explicitLookupValue unf_env (getName id) of
Nothing -> noIdInfo
Just imported_id -> idInfo imported_id
-- ToDo: could check that types are the same
\end{code}
-Constructing new Ids
-~~~~~~~~~~~~~~~~~~~~
+%************************************************************************
+%* *
+\subsection{Constructing new Ids}
+%* *
+%************************************************************************
\begin{code}
-newLocalId :: OccName -> TcType s -> NF_TcM s (TcIdBndr s)
+newLocalId :: OccName -> TcType -> NF_TcM s TcId
newLocalId name ty
= tcGetUnique `thenNF_Tc` \ uniq ->
returnNF_Tc (mkUserLocal name uniq ty)
-newLocalIds :: [OccName] -> [TcType s] -> NF_TcM s [TcIdBndr s]
+newLocalIds :: [OccName] -> [TcType] -> NF_TcM s [TcId]
newLocalIds names tys
= tcGetUniques (length names) `thenNF_Tc` \ uniqs ->
let
in
returnNF_Tc new_ids
-newSpecPragmaId :: Name -> TcType s -> NF_TcM s (TcIdBndr s)
+newSpecPragmaId :: Name -> TcType -> NF_TcM s TcId
newSpecPragmaId name ty
= tcGetUnique `thenNF_Tc` \ uniq ->
returnNF_Tc (mkSpecPragmaId (nameOccName name) uniq ty)
\end{code}
-\begin{code}
-classAsTyConErr name
- = ptext SLIT("Class used as a type constructor:") <+> ppr name
-
-tyConAsClassErr name
- = ptext SLIT("Type constructor used as a class:") <+> ppr name
+%************************************************************************
+%* *
+\subsection{Errors}
+%* *
+%************************************************************************
+\begin{code}
badCon con_id
= quotes (ppr con_id) <+> ptext SLIT("is not a data constructor")
badPrimOp op
_declarations_
1 tcExpr _:_ _forall_ [s] =>
RnHsSyn.RenamedHsExpr
- -> TcMonad.TcType s
- -> TcMonad.TcM s (TcHsSyn.TcExpr s, Inst.LIE s) ;;
+ -> TcMonad.TcType
+ -> TcMonad.TcM s (TcHsSyn.TcExpr, Inst.LIE) ;;
LIE, emptyLIE, unitLIE, plusLIE, plusLIEs, newOverloadedLit,
newMethod, newMethodWithGivenTy, newDicts, instToId )
import TcBinds ( tcBindsAndThen )
-import TcEnv ( TcIdOcc(..), tcInstId, tidyType,
- tcLookupLocalValue, tcLookupGlobalValue, tcLookupClassByKey,
- tcLookupGlobalValueByKey,
- tcExtendGlobalTyVars, tcLookupGlobalValueMaybe,
+import TcEnv ( tcInstId,
+ tcLookupValue, tcLookupClassByKey,
+ tcLookupValueByKey,
+ tcExtendGlobalTyVars, tcLookupValueMaybe,
tcLookupTyCon, tcLookupDataCon
)
-import TcMatches ( tcMatchesCase, tcMatchExpected )
-import TcGRHSs ( tcStmts )
-import TcMonoType ( tcHsTcType, checkSigTyVars, sigCtxt )
+import TcMatches ( tcMatchesCase, tcMatchLambda, tcStmts )
+import TcMonoType ( tcHsType, checkSigTyVars, sigCtxt )
import TcPat ( badFieldCon )
import TcSimplify ( tcSimplifyAndCheck )
-import TcType ( TcType, TcTauType, TcMaybe(..),
+import TcType ( TcType, TcTauType,
tcInstTyVars,
tcInstTcType, tcSplitRhoTy,
- newTyVarTy, zonkTcType )
+ newTyVarTy, newTyVarTy_OpenKind, zonkTcType )
import Class ( Class )
import FieldLabel ( FieldLabel, fieldLabelName, fieldLabelType )
splitForAllTys, splitRhoTy,
isTauTy, tyVarsOfType, tyVarsOfTypes,
isForAllTy, splitAlgTyConApp, splitAlgTyConApp_maybe,
- boxedTypeKind, openTypeKind, mkArrowKind,
- substFlexiTheta
+ boxedTypeKind, mkArrowKind,
+ substTopTheta, tidyOpenType
)
import VarEnv ( zipVarEnv )
import VarSet ( elemVarSet, mkVarSet )
%************************************************************************
\begin{code}
-tcExpr :: RenamedHsExpr -- Expession to type check
- -> TcType s -- Expected type (could be a polytpye)
- -> TcM s (TcExpr s, LIE s)
+tcExpr :: RenamedHsExpr -- Expession to type check
+ -> TcType -- Expected type (could be a polytpye)
+ -> TcM s (TcExpr, LIE)
tcExpr expr ty | isForAllTy ty = -- Polymorphic case
tcPolyExpr expr ty `thenTc` \ (expr', lie, _, _, _) ->
-- tcPolyExpr is like tcMonoExpr, except that the expected type
-- can be a polymorphic one.
tcPolyExpr :: RenamedHsExpr
- -> TcType s -- Expected type
- -> TcM s (TcExpr s, LIE s, -- Generalised expr with expected type, and LIE
- TcExpr s, TcTauType s, LIE s) -- Same thing, but instantiated; tau-type returned
+ -> TcType -- Expected type
+ -> TcM s (TcExpr, LIE, -- Generalised expr with expected type, and LIE
+ TcExpr, TcTauType, LIE) -- Same thing, but instantiated; tau-type returned
tcPolyExpr arg expected_arg_ty
= -- Ha! The argument type of the function is a for-all type,
(sig_theta, sig_tau) = splitRhoTy sig_rho
in
-- Type-check the arg and unify with expected type
- tcExtendGlobalTyVars (mkVarSet sig_tyvars) (
- tcMonoExpr arg sig_tau
- ) `thenTc` \ (arg', lie_arg) ->
+ tcMonoExpr arg sig_tau `thenTc` \ (arg', lie_arg) ->
- -- Check that the arg_tyvars havn't been constrained
+ -- Check that the sig_tyvars havn't been constrained
-- The interesting bit here is that we must include the free variables
-- of the expected arg ty. Here's an example:
-- runST (newVar True)
-- list of "free vars" for the signature check.
tcExtendGlobalTyVars (tyVarsOfType expected_arg_ty) $
- tcAddErrCtxtM (sigCtxt (text "an expression") sig_tau) $
+ tcAddErrCtxtM (sigCtxt sig_msg expected_arg_ty) $
checkSigTyVars sig_tyvars `thenTc` \ zonked_sig_tyvars ->
in
returnTc ( generalised_arg, free_insts,
arg', sig_tau, lie_arg )
+ where
+ sig_msg ty = ptext SLIT("In an expression with expected type:") <+> ppr ty
\end{code}
%************************************************************************
\begin{code}
tcMonoExpr :: RenamedHsExpr -- Expession to type check
- -> TcTauType s -- Expected type (could be a type variable)
- -> TcM s (TcExpr s, LIE s)
+ -> TcTauType -- Expected type (could be a type variable)
+ -> TcM s (TcExpr, LIE)
tcMonoExpr (HsVar name) res_ty
= tcId name `thenNF_Tc` \ (expr', lie, id_ty) ->
= tcMonoExpr (HsApp neg expr) res_ty
tcMonoExpr (HsLam match) res_ty
- = tcMatchExpected match res_ty LambdaBody `thenTc` \ (match',lie) ->
+ = tcMatchLambda match res_ty `thenTc` \ (match',lie) ->
returnTc (HsLam match', lie)
tcMonoExpr (HsApp e1 e2) res_ty = accum e1 [e2]
= -- Get the callable and returnable classes.
tcLookupClassByKey cCallableClassKey `thenNF_Tc` \ cCallableClass ->
tcLookupClassByKey cReturnableClassKey `thenNF_Tc` \ cReturnableClass ->
- tcLookupTyCon ioTyCon_NAME `thenTc` \ (_,_,ioTyCon) ->
+ tcLookupTyCon ioTyCon_NAME `thenNF_Tc` \ ioTyCon ->
let
new_arg_dict (arg, arg_ty)
= newDicts (CCallOrigin (_UNPK_ lbl) (Just arg))
in
-- Arguments
- mapNF_Tc (\ _ -> newTyVarTy openTypeKind)
- [1..(length args)] `thenNF_Tc` \ ty_vars ->
- tcMonoExprs args ty_vars `thenTc` \ (args', args_lie) ->
+ mapNF_Tc (\ _ -> newTyVarTy_OpenKind) [1..(length args)] `thenNF_Tc` \ arg_tys ->
+ tcMonoExprs args arg_tys `thenTc` \ (args', args_lie) ->
-- The argument types can be unboxed or boxed; the result
-- type must, however, be boxed since it's an argument to the IO
-- Construct the extra insts, which encode the
-- constraints on the argument and result types.
- mapNF_Tc new_arg_dict (zipEqual "tcMonoExpr:CCall" args ty_vars) `thenNF_Tc` \ ccarg_dicts_s ->
- newDicts result_origin [(cReturnableClass, [result_ty])] `thenNF_Tc` \ (ccres_dict, _) ->
+ mapNF_Tc new_arg_dict (zipEqual "tcMonoExpr:CCall" args arg_tys) `thenNF_Tc` \ ccarg_dicts_s ->
+ newDicts result_origin [(cReturnableClass, [result_ty])] `thenNF_Tc` \ (ccres_dict, _) ->
- returnTc (HsApp (HsVar (RealId (dataConId ioDataCon)) `TyApp` [result_ty])
+ returnTc (HsApp (HsVar (dataConId ioDataCon) `TyApp` [result_ty])
(CCall lbl args' may_gc is_asm result_ty),
-- do the wrapping in the newtype constructor here
foldr plusLIE ccres_dict ccarg_dicts_s `plusLIE` args_lie)
-- case (map f) of
-- (x:xs) -> ...
-- will report that map is applied to too few arguments
+ --
+ -- Not only that, but it's better to check the matches on their
+ -- own, so that we get the expected results for scoped type variables.
+ -- f x = case x of
+ -- (p::a, q::b) -> (q,p)
+ -- The above should work: the match (p,q) -> (q,p) is polymorphic as
+ -- claimed by the pattern signatures. But if we typechecked the
+ -- match with x in scope and x's type as the expected type, we'd be hosed.
- tcMatchesCase res_ty matches `thenTc` \ (scrut_ty, matches', lie2) ->
+ tcMatchesCase matches res_ty `thenTc` \ (scrut_ty, matches', lie2) ->
tcAddErrCtxt (caseScrutCtxt scrut) (
tcMonoExpr scrut scrut_ty
let
((first_field_name, _, _) : rest) = rbinds
in
- tcLookupGlobalValueMaybe first_field_name `thenNF_Tc` \ maybe_sel_id ->
+ tcLookupValueMaybe first_field_name `thenNF_Tc` \ maybe_sel_id ->
(case maybe_sel_id of
Just sel_id | isRecordSelector sel_id -> returnTc sel_id
other -> failWithTc (notSelector first_field_name)
-- WARNING: this code assumes that all data_cons in a common tycon
-- have FieldLabels abstracted over the same tyvars.
let
- upd_field_lbls = [recordSelectorFieldLabel sel_id | (RealId sel_id, _, _) <- rbinds']
+ upd_field_lbls = [recordSelectorFieldLabel sel_id | (sel_id, _, _) <- rbinds']
con_field_lbls_s = map dataConFieldLabels data_cons
-- A constructor is only relevant to this process if
let
(tyvars, theta, _, _, _, _) = dataConSig (head data_cons)
inst_env = zipVarEnv tyvars result_inst_tys
- theta' = substFlexiTheta inst_env theta
+ theta' = substTopTheta inst_env theta
in
newDicts RecordUpdOrigin theta' `thenNF_Tc` \ (con_lie, dicts) ->
con_lie `plusLIE` record_lie `plusLIE` rbinds_lie)
tcMonoExpr (ArithSeqIn seq@(From expr)) res_ty
- = unifyListTy res_ty `thenTc` \ elt_ty ->
- tcMonoExpr expr elt_ty `thenTc` \ (expr', lie1) ->
+ = unifyListTy res_ty `thenTc` \ elt_ty ->
+ tcMonoExpr expr elt_ty `thenTc` \ (expr', lie1) ->
- tcLookupGlobalValueByKey enumFromClassOpKey `thenNF_Tc` \ sel_id ->
+ tcLookupValueByKey enumFromClassOpKey `thenNF_Tc` \ sel_id ->
newMethod (ArithSeqOrigin seq)
- (RealId sel_id) [elt_ty] `thenNF_Tc` \ (lie2, enum_from_id) ->
+ sel_id [elt_ty] `thenNF_Tc` \ (lie2, enum_from_id) ->
returnTc (ArithSeqOut (HsVar enum_from_id) (From expr'),
lie1 `plusLIE` lie2)
unifyListTy res_ty `thenTc` \ elt_ty ->
tcMonoExpr expr1 elt_ty `thenTc` \ (expr1',lie1) ->
tcMonoExpr expr2 elt_ty `thenTc` \ (expr2',lie2) ->
- tcLookupGlobalValueByKey enumFromThenClassOpKey `thenNF_Tc` \ sel_id ->
+ tcLookupValueByKey enumFromThenClassOpKey `thenNF_Tc` \ sel_id ->
newMethod (ArithSeqOrigin seq)
- (RealId sel_id) [elt_ty] `thenNF_Tc` \ (lie3, enum_from_then_id) ->
+ sel_id [elt_ty] `thenNF_Tc` \ (lie3, enum_from_then_id) ->
returnTc (ArithSeqOut (HsVar enum_from_then_id)
(FromThen expr1' expr2'),
unifyListTy res_ty `thenTc` \ elt_ty ->
tcMonoExpr expr1 elt_ty `thenTc` \ (expr1',lie1) ->
tcMonoExpr expr2 elt_ty `thenTc` \ (expr2',lie2) ->
- tcLookupGlobalValueByKey enumFromToClassOpKey `thenNF_Tc` \ sel_id ->
+ tcLookupValueByKey enumFromToClassOpKey `thenNF_Tc` \ sel_id ->
newMethod (ArithSeqOrigin seq)
- (RealId sel_id) [elt_ty] `thenNF_Tc` \ (lie3, enum_from_to_id) ->
+ sel_id [elt_ty] `thenNF_Tc` \ (lie3, enum_from_to_id) ->
returnTc (ArithSeqOut (HsVar enum_from_to_id)
(FromTo expr1' expr2'),
tcMonoExpr expr1 elt_ty `thenTc` \ (expr1',lie1) ->
tcMonoExpr expr2 elt_ty `thenTc` \ (expr2',lie2) ->
tcMonoExpr expr3 elt_ty `thenTc` \ (expr3',lie3) ->
- tcLookupGlobalValueByKey enumFromThenToClassOpKey `thenNF_Tc` \ sel_id ->
+ tcLookupValueByKey enumFromThenToClassOpKey `thenNF_Tc` \ sel_id ->
newMethod (ArithSeqOrigin seq)
- (RealId sel_id) [elt_ty] `thenNF_Tc` \ (lie4, eft_id) ->
+ sel_id [elt_ty] `thenNF_Tc` \ (lie4, eft_id) ->
returnTc (ArithSeqOut (HsVar eft_id)
(FromThenTo expr1' expr2' expr3'),
\begin{code}
tcMonoExpr in_expr@(ExprWithTySig expr poly_ty) res_ty
= tcSetErrCtxt (exprSigCtxt in_expr) $
- tcHsTcType poly_ty `thenTc` \ sig_tc_ty ->
+ tcHsType poly_ty `thenTc` \ sig_tc_ty ->
if not (isForAllTy sig_tc_ty) then
-- Easy case
\begin{code}
tcExpr_id :: RenamedHsExpr
- -> TcM s (TcExpr s,
- LIE s,
- TcType s)
+ -> TcM s (TcExpr,
+ LIE,
+ TcType)
tcExpr_id id_expr
= case id_expr of
- HsVar name -> tcId name `thenNF_Tc` \ stuff ->
+ HsVar name -> tcId name `thenNF_Tc` \ stuff ->
returnTc stuff
- other -> newTyVarTy openTypeKind `thenNF_Tc` \ id_ty ->
- tcMonoExpr id_expr id_ty `thenTc` \ (id_expr', lie_id) ->
+ other -> newTyVarTy_OpenKind `thenNF_Tc` \ id_ty ->
+ tcMonoExpr id_expr id_ty `thenTc` \ (id_expr', lie_id) ->
returnTc (id_expr', lie_id, id_ty)
\end{code}
\begin{code}
tcApp :: RenamedHsExpr -> [RenamedHsExpr] -- Function and args
- -> TcType s -- Expected result type of application
- -> TcM s (TcExpr s, [TcExpr s], -- Translated fun and args
- LIE s)
+ -> TcType -- Expected result type of application
+ -> TcM s (TcExpr, [TcExpr], -- Translated fun and args
+ LIE)
tcApp fun args res_ty
= -- First type-check the function
= zonkTcType expected_res_ty `thenNF_Tc` \ exp_ty' ->
zonkTcType actual_res_ty `thenNF_Tc` \ act_ty' ->
let
- (env1, exp_ty'') = tidyType tidy_env exp_ty'
- (env2, act_ty'') = tidyType env1 act_ty'
+ (env1, exp_ty'') = tidyOpenType tidy_env exp_ty'
+ (env2, act_ty'') = tidyOpenType env1 act_ty'
(exp_args, _) = splitFunTys exp_ty''
(act_args, _) = splitFunTys act_ty''
returnNF_Tc (env2, message)
-split_fun_ty :: TcType s -- The type of the function
+split_fun_ty :: TcType -- The type of the function
-> Int -- Number of arguments
- -> TcM s ([TcType s], -- Function argument types
- TcType s) -- Function result types
+ -> TcM s ([TcType], -- Function argument types
+ TcType) -- Function result types
split_fun_ty fun_ty 0
= returnTc ([], fun_ty)
\begin{code}
tcArg :: RenamedHsExpr -- The function (for error messages)
- -> (RenamedHsExpr, TcType s, Int) -- Actual argument and expected arg type
- -> TcM s (TcExpr s, LIE s) -- Resulting argument and LIE
+ -> (RenamedHsExpr, TcType, Int) -- Actual argument and expected arg type
+ -> TcM s (TcExpr, LIE) -- Resulting argument and LIE
tcArg the_fun (arg, expected_arg_ty, arg_no)
= tcAddErrCtxt (funAppCtxt the_fun arg arg_no) $
%************************************************************************
\begin{code}
-tcId :: Name -> NF_TcM s (TcExpr s, LIE s, TcType s)
+tcId :: Name -> NF_TcM s (TcExpr, LIE, TcType)
tcId name
= -- Look up the Id and instantiate its type
- tcLookupLocalValue name `thenNF_Tc` \ maybe_local ->
+ tcLookupValueMaybe name `thenNF_Tc` \ maybe_local ->
case maybe_local of
- Just tc_id -> instantiate_it (TcId tc_id) (idType tc_id)
+ Just tc_id -> instantiate_it tc_id (idType tc_id)
- Nothing -> tcLookupGlobalValue name `thenNF_Tc` \ id ->
+ Nothing -> tcLookupValue name `thenNF_Tc` \ id ->
tcInstId id `thenNF_Tc` \ (tyvars, theta, tau) ->
- instantiate_it2 (RealId id) tyvars theta tau
+ instantiate_it2 id tyvars theta tau
where
-- The instantiate_it loop runs round instantiating the Id.
-- then = then
-- where the second "then" sees that it already exists in the "available" stuff.
--
- tcLookupGlobalValueByKey returnMClassOpKey `thenNF_Tc` \ return_sel_id ->
- tcLookupGlobalValueByKey thenMClassOpKey `thenNF_Tc` \ then_sel_id ->
- tcLookupGlobalValueByKey zeroClassOpKey `thenNF_Tc` \ zero_sel_id ->
- newMethod DoOrigin
- (RealId return_sel_id) [m] `thenNF_Tc` \ (return_lie, return_id) ->
- newMethod DoOrigin
- (RealId then_sel_id) [m] `thenNF_Tc` \ (then_lie, then_id) ->
- newMethod DoOrigin
- (RealId zero_sel_id) [m] `thenNF_Tc` \ (zero_lie, zero_id) ->
+ tcLookupValueByKey returnMClassOpKey `thenNF_Tc` \ return_sel_id ->
+ tcLookupValueByKey thenMClassOpKey `thenNF_Tc` \ then_sel_id ->
+ tcLookupValueByKey zeroClassOpKey `thenNF_Tc` \ zero_sel_id ->
+ newMethod DoOrigin return_sel_id [m] `thenNF_Tc` \ (return_lie, return_id) ->
+ newMethod DoOrigin then_sel_id [m] `thenNF_Tc` \ (then_lie, then_id) ->
+ newMethod DoOrigin zero_sel_id [m] `thenNF_Tc` \ (zero_lie, zero_id) ->
let
monad_lie = then_lie `plusLIE` return_lie `plusLIE` perhaps_zero_lie
perhaps_zero_lie | all failure_free stmts' = emptyLIE
\begin{code}
tcRecordBinds
- :: TcType s -- Expected type of whole record
+ :: TcType -- Expected type of whole record
-> RenamedRecordBinds
- -> TcM s (TcRecordBinds s, LIE s)
+ -> TcM s (TcRecordBinds, LIE)
tcRecordBinds expected_record_ty rbinds
= mapAndUnzipTc do_bind rbinds `thenTc` \ (rbinds', lies) ->
returnTc (rbinds', plusLIEs lies)
where
do_bind (field_label, rhs, pun_flag)
- = tcLookupGlobalValue field_label `thenNF_Tc` \ sel_id ->
+ = tcLookupValue field_label `thenNF_Tc` \ sel_id ->
ASSERT( isRecordSelector sel_id )
-- This lookup and assertion will surely succeed, because
-- we check that the fields are indeed record selectors
in
unifyTauTy expected_record_ty record_ty `thenTc_`
tcPolyExpr rhs field_ty `thenTc` \ (rhs', lie, _, _, _) ->
- returnTc ((RealId sel_id, rhs', pun_flag), lie)
+ returnTc ((sel_id, rhs', pun_flag), lie)
badFields rbinds data_con
= [field_name | (field_name, _, _) <- rbinds,
%************************************************************************
\begin{code}
-tcMonoExprs :: [RenamedHsExpr] -> [TcType s] -> TcM s ([TcExpr s], LIE s)
+tcMonoExprs :: [RenamedHsExpr] -> [TcType] -> TcM s ([TcExpr], LIE)
tcMonoExprs [] [] = returnTc ([], emptyLIE)
tcMonoExprs (expr:exprs) (ty:tys)
import RnHsSyn ( RenamedHsDecl, RenamedForeignDecl )
import TcMonad
-import TcEnv ( tcLookupClassByKey, newLocalId, tcLookupGlobalValue )
+import TcEnv ( newLocalId )
import TcType ( tcInstTcType, typeToTcType, tcSplitRhoTy, zonkTcTypeToType )
import TcMonoType ( tcHsType )
-import TcHsSyn ( TcMonoBinds, maybeBoxedPrimType, TypecheckedForeignDecl, TcIdOcc(..),
+import TcHsSyn ( TcMonoBinds, maybeBoxedPrimType, TypecheckedForeignDecl,
TcForeignExportDecl )
import TcExpr ( tcId, tcPolyExpr )
import Inst ( emptyLIE, LIE, plusLIE )
tcForeignImports decls =
mapAndUnzipTc tcFImport [ foreign_decl | ForD foreign_decl <- decls, isForeignImport foreign_decl]
-tcForeignExports :: [RenamedHsDecl] -> TcM s (LIE s, TcMonoBinds s, [TcForeignExportDecl s])
+tcForeignExports :: [RenamedHsDecl] -> TcM s (LIE, TcMonoBinds, [TcForeignExportDecl])
tcForeignExports decls =
foldlTc combine (emptyLIE, EmptyMonoBinds, [])
[ foreign_decl | ForD foreign_decl <- decls, isForeignExport foreign_decl]
let i = (mkUserId nm ty) in
returnTc (i, (ForeignDecl i imp_exp undefined ext_nm cconv src_loc))
-tcFExport :: RenamedForeignDecl -> TcM s (LIE s, TcMonoBinds s, TcForeignExportDecl s)
+tcFExport :: RenamedForeignDecl -> TcM s (LIE, TcMonoBinds, TcForeignExportDecl)
tcFExport fo@(ForeignDecl nm imp_exp hs_ty ext_nm cconv src_loc) =
tcAddSrcLoc src_loc $
tcAddErrCtxt (foreignDeclCtxt fo) $
-- at a particular type (and, maybe, overloading).
newLocalId (nameOccName nm) sig_tc_ty `thenNF_Tc` \ i ->
let
- i2 = TcId i
- bind = VarMonoBind i2 rhs
+ bind = VarMonoBind i rhs
in
- returnTc (lie, bind, ForeignDecl i2 imp_exp undefined ext_nm cconv src_loc)
+ returnTc (lie, bind, ForeignDecl i imp_exp undefined ext_nm cconv src_loc)
-- ^^^^^^^^^
-- ToDo: fill the type field in with something sensible.
+++ /dev/null
-_interface_ TcGRHSs 2
-_exports_
-TcGRHSs tcGRHSsAndBinds;
-_declarations_
-2 tcGRHSsAndBinds _:_ _forall_ [s] =>
- RnHsSyn.RenamedGRHSsAndBinds
- -> TcMonad.TcType s
- -> HsExpr.StmtCtxt
- -> TcMonad.TcM s (TcHsSyn.TcGRHSsAndBinds s, Inst.LIE s) ;;
-
+++ /dev/null
-__interface TcGRHSs 2 0 where
-__export TcGRHSs tcGRHSsAndBinds;
-2 tcGRHSsAndBinds :: __forall [_s] =>
- RnHsSyn.RenamedGRHSsAndBinds
- -> TcMonad.TcType _s
- -> HsExpr.StmtCtxt
- -> TcMonad.TcM _s (TcHsSyn.TcGRHSsAndBinds _s, Inst.LIE _s) ;
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
-\section[TcGRHSs]{Typecheck guarded right-hand-sides}
-
-\begin{code}
-module TcGRHSs ( tcGRHSsAndBinds, tcStmts ) where
-
-#include "HsVersions.h"
-
-import {-# SOURCE #-} TcExpr( tcExpr )
-
-import HsSyn ( HsBinds(..), GRHSsAndBinds(..), GRHS(..), StmtCtxt(..),
- Stmt(..)
- )
-import RnHsSyn ( RenamedGRHSsAndBinds, RenamedGRHS, RenamedStmt )
-import TcHsSyn ( TcGRHSsAndBinds, TcGRHS, TcStmt )
-
-import TcEnv ( tcExtendGlobalTyVars, tcExtendEnvWithPat )
-import TcMonad
-import Inst ( LIE, plusLIE )
-import TcBinds ( tcBindsAndThen )
-import TcSimplify ( tcSimplifyAndCheck )
-import TcPat ( tcPat )
-import TcMonoType ( checkSigTyVars, noSigs, existentialPatCtxt )
-import TcType ( TcType, newTyVarTy )
-import TysWiredIn ( boolTy )
-import Type ( tyVarsOfType, openTypeKind, boxedTypeKind )
-import BasicTypes ( RecFlag(..) )
-import VarSet
-import Bag
-import Outputable
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{GRHSs}
-%* *
-%************************************************************************
-
-\begin{code}
-tcGRHSs :: [RenamedGRHS] -> TcType s -> StmtCtxt -> TcM s ([TcGRHS s], LIE s)
-
-tcGRHSs [grhs] expected_ty ctxt
- = tcGRHS grhs expected_ty ctxt `thenTc` \ (grhs', lie) ->
- returnTc ([grhs'], lie)
-
-tcGRHSs (grhs:grhss) expected_ty ctxt
- = tcGRHS grhs expected_ty ctxt `thenTc` \ (grhs', lie1) ->
- tcGRHSs grhss expected_ty ctxt `thenTc` \ (grhss', lie2) ->
- returnTc (grhs' : grhss', lie1 `plusLIE` lie2)
-
-tcGRHS (GRHS guarded locn) expected_ty ctxt
- = tcAddSrcLoc locn $
- tcStmts ctxt (\ty -> ty) guarded expected_ty `thenTc` \ (guarded', lie) ->
- returnTc (GRHS guarded' locn, lie)
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{GRHSsAndBinds}
-%* *
-%************************************************************************
-
-@tcGRHSsAndBinds@ typechecks (grhss where binds), returning suitable
-pieces.
-
-\begin{code}
-tcGRHSsAndBinds :: RenamedGRHSsAndBinds
- -> TcType s -- Expected type of RHSs
- -> StmtCtxt
- -> TcM s (TcGRHSsAndBinds s, LIE s)
-
-tcGRHSsAndBinds (GRHSsAndBindsIn grhss binds) expected_ty ctxt
- = tcBindsAndThen
- combiner binds
- (tcGRHSs grhss expected_ty ctxt `thenTc` \ (grhss, lie) ->
- returnTc (GRHSsAndBindsOut grhss EmptyBinds expected_ty, lie))
- where
- combiner is_rec mbinds (GRHSsAndBindsOut grhss binds expected_ty)
- = GRHSsAndBindsOut grhss (MonoBind mbinds [] is_rec `ThenBinds` binds) expected_ty
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Record bindings}
-%* *
-%************************************************************************
-
-
-\begin{code}
-tcStmts :: StmtCtxt
- -> (TcType s -> TcType s) -- m, the relationship type of pat and rhs in pat <- rhs
- -> [RenamedStmt]
- -> TcType s -- elt_ty, where type of the comprehension is (m elt_ty)
- -> TcM s ([TcStmt s], LIE s)
-
-tcStmts do_or_lc m (stmt@(ReturnStmt exp) : stmts) elt_ty
- = ASSERT( null stmts )
- tcSetErrCtxt (stmtCtxt do_or_lc stmt) $
- tcExpr exp elt_ty `thenTc` \ (exp', exp_lie) ->
- returnTc ([ReturnStmt exp'], exp_lie)
-
- -- ExprStmt at the end
-tcStmts do_or_lc m [stmt@(ExprStmt exp src_loc)] elt_ty
- = tcSetErrCtxt (stmtCtxt do_or_lc stmt) $
- tcExpr exp (m elt_ty) `thenTc` \ (exp', exp_lie) ->
- returnTc ([ExprStmt exp' src_loc], exp_lie)
-
- -- ExprStmt not at the end
-tcStmts do_or_lc m (stmt@(ExprStmt exp src_loc) : stmts) elt_ty
- = ASSERT( isDoStmt do_or_lc )
- tcAddSrcLoc src_loc (
- tcSetErrCtxt (stmtCtxt do_or_lc stmt) $
- -- exp has type (m tau) for some tau (doesn't matter what)
- newTyVarTy openTypeKind `thenNF_Tc` \ any_ty ->
- tcExpr exp (m any_ty)
- ) `thenTc` \ (exp', exp_lie) ->
- tcStmts do_or_lc m stmts elt_ty `thenTc` \ (stmts', stmts_lie) ->
- returnTc (ExprStmt exp' src_loc : stmts',
- exp_lie `plusLIE` stmts_lie)
-
-tcStmts do_or_lc m (stmt@(GuardStmt exp src_loc) : stmts) elt_ty
- = ASSERT( not (isDoStmt do_or_lc) )
- tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
- tcAddSrcLoc src_loc $
- tcExpr exp boolTy
- ) `thenTc` \ (exp', exp_lie) ->
- tcStmts do_or_lc m stmts elt_ty `thenTc` \ (stmts', stmts_lie) ->
- returnTc (GuardStmt exp' src_loc : stmts',
- exp_lie `plusLIE` stmts_lie)
-
-tcStmts do_or_lc m (stmt@(BindStmt pat exp src_loc) : stmts) elt_ty
- = tcAddSrcLoc src_loc (
- tcSetErrCtxt (stmtCtxt do_or_lc stmt) $
- newTyVarTy boxedTypeKind `thenNF_Tc` \ pat_ty ->
- tcPat noSigs pat pat_ty `thenTc` \ (pat', pat_lie, pat_tvs, pat_ids, avail) ->
- tcExpr exp (m pat_ty) `thenTc` \ (exp', exp_lie) ->
- returnTc (pat', exp',
- pat_lie `plusLIE` exp_lie,
- pat_tvs, pat_ids, avail)
- ) `thenTc` \ (pat', exp', lie_req, pat_tvs, pat_ids, lie_avail) ->
-
- -- Do the rest; we don't need to add the pat_tvs to the envt
- -- because they all appear in the pat_ids's types
- tcExtendEnvWithPat pat_ids (
- tcStmts do_or_lc m stmts elt_ty
- ) `thenTc` \ (stmts', stmts_lie) ->
-
-
- -- Reinstate context for existential checks
- tcSetErrCtxt (stmtCtxt do_or_lc stmt) $
- tcExtendGlobalTyVars (tyVarsOfType (m elt_ty)) $
- tcAddErrCtxtM (existentialPatCtxt pat_tvs pat_ids) $
-
- checkSigTyVars (bagToList pat_tvs) `thenTc` \ zonked_pat_tvs ->
-
- tcSimplifyAndCheck
- (text ("the existential context of a data constructor"))
- (mkVarSet zonked_pat_tvs)
- lie_avail stmts_lie `thenTc` \ (final_lie, dict_binds) ->
-
- returnTc (BindStmt pat' exp' src_loc :
- LetStmt (MonoBind dict_binds [] Recursive) :
- stmts',
- lie_req `plusLIE` final_lie)
-
-tcStmts do_or_lc m (LetStmt binds : stmts) elt_ty
- = tcBindsAndThen -- No error context, but a binding group is
- combine -- rather a large thing for an error context anyway
- binds
- (tcStmts do_or_lc m stmts elt_ty)
- where
- combine is_rec binds' stmts' = LetStmt (MonoBind binds' [] is_rec) : stmts'
-
-
-isDoStmt DoStmt = True
-isDoStmt other = False
-
-stmtCtxt do_or_lc stmt
- = hang (ptext SLIT("In") <+> what <> colon)
- 4 (ppr stmt)
- where
- what = case do_or_lc of
- ListComp -> ptext SLIT("a list-comprehension qualifier")
- DoStmt -> ptext SLIT("a do statement:")
- PatBindRhs -> thing <+> ptext SLIT("a pattern binding")
- FunRhs f -> thing <+> ptext SLIT("an equation for") <+> quotes (ppr f)
- CaseAlt -> thing <+> ptext SLIT("a case alternative")
- LambdaBody -> thing <+> ptext SLIT("a lambda abstraction")
- thing = case stmt of
- BindStmt _ _ _ -> ptext SLIT("a pattern guard for")
- GuardStmt _ _ -> ptext SLIT("a guard for")
- ExprStmt _ _ -> ptext SLIT("the right-hand side of")
-\end{code}
#include "HsVersions.h"
import HsSyn ( InPat(..), HsExpr(..), MonoBinds(..),
- Match(..), GRHSsAndBinds(..), Stmt(..), HsLit(..),
+ Match(..), GRHSs(..), Stmt(..), HsLit(..),
HsBinds(..), StmtCtxt(..),
- unguardedRHS
+ unguardedRHS, mkSimpleMatch
)
import RdrHsSyn ( RdrName(..), varUnqual, mkOpApp,
RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat
floatPrimTy, doublePrimTy
)
import Util ( mapAccumL, zipEqual, zipWithEqual,
- zipWith3Equal, nOfThem, panic, assertPanic )
+ zipWith3Equal, nOfThem )
+import Panic ( panic, assertPanic )
import Maybes ( maybeToBool )
import List ( partition, intersperse )
\end{code}
[a_Pat, b_Pat]
[cmp_eq]
(if maybeToBool (maybeTyConSingleCon tycon) then
- cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
+
+-- cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
+-- Wierd. Was: case (cmp a b) of { LT -> LT; EQ -> EQ; GT -> GT }
+
+ cmp_eq_Expr a_Expr b_Expr
else
untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)]
(cmp_tags_Expr eqH_Int_RDR ah_RDR bh_RDR
(if isEnumerationTyCon tycon then
eqTag_Expr
else
- cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
+-- cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
+-- Ditto
+ cmp_eq_Expr a_Expr b_Expr
)
-- False case; they aren't equal
-- So we need to do a less-than comparison on the tags
untag_Expr tycon [(a_RDR, ah_RDR)] (
untag_Expr tycon [(d_RDR, dh_RDR)] (
let
- grhs = unguardedRHS (mk_easy_App mkInt_RDR [c_RDR]) tycon_loc
+ rhs = mk_easy_App mkInt_RDR [c_RDR]
in
HsCase
(genOpApp (HsVar dh_RDR) minusH_RDR (HsVar ah_RDR))
- [PatMatch (VarPatIn c_RDR)
- (GRHSMatch (GRHSsAndBindsIn grhs EmptyBinds))]
+ [mkSimpleMatch [VarPatIn c_RDR] rhs Nothing tycon_loc]
tycon_loc
))
) {-else-} (
-- (label, '=' and field)*n, (n-1)*',' + '{' + '}'
con_qual
= BindStmt
- (TuplePatIn [LitPatIn (HsString data_con_str),
+ (TuplePatIn [LitPatIn (mkHsString data_con_str),
d_Pat] True)
(HsApp (HsVar lex_RDR) c_Expr)
tycon_loc
str_qual str res draw_from
= BindStmt
- (TuplePatIn [LitPatIn (HsString str), VarPatIn res] True)
+ (TuplePatIn [LitPatIn (mkHsString str), VarPatIn res] True)
(HsApp (HsVar lex_RDR) draw_from)
tycon_loc
read_label f
= let nm = occNameString (getOccName (fieldLabelName f))
in
- [str_qual nm, str_qual SLIT("=")]
+ [str_qual nm, str_qual "="]
-- There might be spaces between the label and '='
field_quals
snd $
mapAccumL mk_qual d_Expr
(zipEqual "bs_needed"
- ((str_qual (SLIT("{")):
+ ((str_qual "{":
concat (
- intersperse ([str_qual (_CONS_ ',' _NIL_)]) $
+ intersperse [str_qual ","] $
zipWithEqual
"field_quals"
(\ as b -> as ++ [b])
-- The labels
(map read_label labels)
-- The fields
- (map mk_read_qual as_needed))) ++ [str_qual (SLIT("}"))])
+ (map mk_read_qual as_needed))) ++ [str_qual "}"])
bs_needed)
mk_qual draw_from (f, str_left)
show_con
= let nm = occNameString (getOccName data_con)
space_ocurly_maybe
- | nullary_con = _NIL_
- | lab_fields == 0 = SLIT(" ")
- | otherwise = SLIT("{")
+ | nullary_con = ""
+ | lab_fields == 0 = " "
+ | otherwise = "{"
in
- mk_showString_app (nm _APPEND_ space_ocurly_maybe)
+ mk_showString_app (nm ++ space_ocurly_maybe)
show_all con fs
= let
ccurly_maybe
- | lab_fields > 0 = [mk_showString_app (SLIT("}"))]
+ | lab_fields > 0 = [mk_showString_app "}"]
| otherwise = []
in
con:fs ++ ccurly_maybe
show_label l
= let nm = occNameString (getOccName (fieldLabelName l))
in
- mk_showString_app (nm _APPEND_ SLIT("="))
+ mk_showString_app (nm ++ "=")
mk_showString_app str = HsApp (HsVar showString_RDR)
- (HsLit (HsString str))
+ (HsLit (mkHsString str))
real_show_thingies =
[ HsApp (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 10))) (HsVar b)
| otherwise = --Assumption: no of fields == no of labelled fields
-- (and in same order)
concat $
- intersperse ([mk_showString_app (_CONS_ ',' _NIL_)]) $ -- Using SLIT()s containing ,s spells trouble.
+ intersperse ([mk_showString_app ","]) $ -- Using SLIT()s containing ,s spells trouble.
zipWithEqual "gen_Show_binds"
(\ a b -> [a,b])
(map show_label labels)
loc
mk_match loc pats expr binds
- = foldr PatMatch
- (GRHSMatch (GRHSsAndBindsIn (unguardedRHS expr loc) binds))
- (map paren pats)
+ = Match [] (map paren pats) Nothing
+ (GRHSs (unguardedRHS expr loc) binds Nothing)
where
paren p@(VarPatIn _) = p
paren other_p = ParPatIn other_p
ToDo: Better SrcLocs.
\begin{code}
-compare_Case, cmp_eq_Expr ::
+compare_Case ::
RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
-> RdrNameHsExpr -> RdrNameHsExpr
-> RdrNameHsExpr
-> RdrNameHsExpr
compare_Case = compare_gen_Case compare_RDR
-cmp_eq_Expr = compare_gen_Case cmp_eq_RDR
+cmp_eq_Expr a b = HsApp (HsApp (HsVar cmp_eq_RDR) a) b
+ -- Was: compare_gen_Case cmp_eq_RDR
compare_gen_Case fun lt eq gt a b
= HsCase (HsPar (HsApp (HsApp (HsVar fun) a) b)) {-of-}
- [PatMatch (ConPatIn ltTag_RDR [])
- (GRHSMatch (GRHSsAndBindsIn (unguardedRHS lt mkGeneratedSrcLoc) EmptyBinds)),
-
- PatMatch (ConPatIn eqTag_RDR [])
- (GRHSMatch (GRHSsAndBindsIn (unguardedRHS eq mkGeneratedSrcLoc) EmptyBinds)),
-
- PatMatch (ConPatIn gtTag_RDR [])
- (GRHSMatch (GRHSsAndBindsIn (unguardedRHS gt mkGeneratedSrcLoc) EmptyBinds))]
- mkGeneratedSrcLoc
+ [mkSimpleMatch [ConPatIn ltTag_RDR []] lt Nothing mkGeneratedSrcLoc,
+ mkSimpleMatch [ConPatIn eqTag_RDR []] eq Nothing mkGeneratedSrcLoc,
+ mkSimpleMatch [ConPatIn gtTag_RDR []] gt Nothing mkGeneratedSrcLoc]
+ mkGeneratedSrcLoc
careful_compare_Case ty lt eq gt a b
= if not (isUnboxedType ty) then
untag_Expr tycon [] expr = expr
untag_Expr tycon ((untag_this, put_tag_here) : more) expr
= HsCase (HsPar (HsApp (con2tag_Expr tycon) (HsVar untag_this))) {-of-}
- [PatMatch (VarPatIn put_tag_here)
- (GRHSMatch (GRHSsAndBindsIn grhs EmptyBinds))]
+ [mkSimpleMatch [VarPatIn put_tag_here] (untag_Expr tycon more expr) Nothing mkGeneratedSrcLoc]
mkGeneratedSrcLoc
- where
- grhs = unguardedRHS (untag_Expr tycon more expr) mkGeneratedSrcLoc
cmp_tags_Expr :: RdrName -- Comparison op
-> RdrName -> RdrName -- Things to compare
bs_RDRs = [ varUnqual (_PK_ ("b"++show i)) | i <- [(1::Int) .. ] ]
cs_RDRs = [ varUnqual (_PK_ ("c"++show i)) | i <- [(1::Int) .. ] ]
+mkHsString s = HsString (_PK_ s)
+
a_Expr = HsVar a_RDR
b_Expr = HsVar b_RDR
c_Expr = HsVar c_RDR
con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
-con2tag_RDR tycon = varUnqual (SLIT("con2tag_") _APPEND_ occNameString (getOccName tycon) _APPEND_ SLIT("#"))
-tag2con_RDR tycon = varUnqual (SLIT("tag2con_") _APPEND_ occNameString (getOccName tycon) _APPEND_ SLIT("#"))
-maxtag_RDR tycon = varUnqual (SLIT("maxtag_") _APPEND_ occNameString (getOccName tycon) _APPEND_ SLIT("#"))
+con2tag_RDR tycon = varUnqual (_PK_ ("con2tag_" ++ occNameString (getOccName tycon) ++ "#"))
+tag2con_RDR tycon = varUnqual (_PK_ ("tag2con_" ++ occNameString (getOccName tycon) ++ "#"))
+maxtag_RDR tycon = varUnqual (_PK_ ("maxtag_" ++ occNameString (getOccName tycon) ++ "#"))
\end{code}
\begin{code}
module TcHsSyn (
TcMonoBinds, TcHsBinds, TcPat,
- TcExpr, TcGRHSsAndBinds, TcGRHS, TcMatch,
+ TcExpr, TcGRHSs, TcGRHS, TcMatch,
TcStmt, TcArithSeqInfo, TcRecordBinds,
TcHsModule, TcCoreExpr, TcDictBinds,
TcForeignExportDecl,
TypecheckedHsExpr, TypecheckedArithSeqInfo,
TypecheckedStmt, TypecheckedForeignDecl,
TypecheckedMatch, TypecheckedHsModule,
- TypecheckedGRHSsAndBinds, TypecheckedGRHS,
+ TypecheckedGRHSs, TypecheckedGRHS,
TypecheckedRecordBinds, TypecheckedDictBinds,
mkHsTyApp, mkHsDictApp,
mkHsTyLam, mkHsDictLam,
-- re-exported from TcEnv
- TcIdOcc(..), TcIdBndr, tcIdType, tcIdTyVars, tcInstId,
+ TcId, tcInstId,
maybeBoxedPrimType,
- zonkTopBinds, zonkTcId, zonkId,
+ zonkTopBinds, zonkId, zonkIdOcc,
zonkForeignExports
) where
import HsSyn -- oodles of it
-- others:
-import Id ( idType, setIdType, Id )
+import Id ( idName, idType, setIdType, omitIfaceSigForId, Id )
import DataCon ( DataCon, dataConArgTys )
-import Name ( NamedThing(..) )
-import BasicTypes ( Unused )
-import TcEnv ( tcLookupGlobalValueMaybe, tcExtendGlobalValEnv, tcGetGlobalValEnv,
- TcIdOcc(..), TcIdBndr, GlobalValueEnv,
- tcIdType, tcIdTyVars, tcInstId
+import TcEnv ( tcLookupValueMaybe, tcExtendGlobalValEnv, tcGetValueEnv,
+ ValueEnv, TcId, tcInstId
)
import TcMonad
-import TcType ( TcType, TcTyVar, TcBox,
- zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType
+import TcType ( TcType, TcTyVar,
+ zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcTyVarBndr, zonkTcType
)
import TyCon ( isDataTyCon )
import Type ( mkTyVarTy, splitAlgTyConApp_maybe, isUnLiftedType, Type )
+import Name ( isLocallyDefined )
import Var ( TyVar )
import VarEnv ( TyVarEnv, emptyVarEnv, extendVarEnvList )
-import TysWiredIn ( voidTy )
+import VarSet ( isEmptyVarSet )
import CoreSyn ( Expr )
import Bag
import UniqFM
which have immutable type variables in them.
\begin{code}
-type TcHsBinds s = HsBinds (TcBox s) (TcIdOcc s) (TcPat s)
-type TcMonoBinds s = MonoBinds (TcBox s) (TcIdOcc s) (TcPat s)
-type TcDictBinds s = TcMonoBinds s
-type TcPat s = OutPat (TcBox s) (TcIdOcc s)
-type TcExpr s = HsExpr (TcBox s) (TcIdOcc s) (TcPat s)
-type TcGRHSsAndBinds s = GRHSsAndBinds (TcBox s) (TcIdOcc s) (TcPat s)
-type TcGRHS s = GRHS (TcBox s) (TcIdOcc s) (TcPat s)
-type TcMatch s = Match (TcBox s) (TcIdOcc s) (TcPat s)
-type TcStmt s = Stmt (TcBox s) (TcIdOcc s) (TcPat s)
-type TcArithSeqInfo s = ArithSeqInfo (TcBox s) (TcIdOcc s) (TcPat s)
-type TcRecordBinds s = HsRecordBinds (TcBox s) (TcIdOcc s) (TcPat s)
-type TcHsModule s = HsModule (TcBox s) (TcIdOcc s) (TcPat s)
-
-type TcCoreExpr s = Expr (TcIdOcc s) (TcBox s)
-type TcForeignExportDecl s = ForeignDecl (TcIdOcc s)
-
-type TypecheckedPat = OutPat Unused Id
-type TypecheckedMonoBinds = MonoBinds Unused Id TypecheckedPat
+type TcHsBinds = HsBinds TcId TcPat
+type TcMonoBinds = MonoBinds TcId TcPat
+type TcDictBinds = TcMonoBinds
+type TcPat = OutPat TcId
+type TcExpr = HsExpr TcId TcPat
+type TcGRHSs = GRHSs TcId TcPat
+type TcGRHS = GRHS TcId TcPat
+type TcMatch = Match TcId TcPat
+type TcStmt = Stmt TcId TcPat
+type TcArithSeqInfo = ArithSeqInfo TcId TcPat
+type TcRecordBinds = HsRecordBinds TcId TcPat
+type TcHsModule = HsModule TcId TcPat
+
+type TcCoreExpr = Expr TcId
+type TcForeignExportDecl = ForeignDecl TcId
+
+type TypecheckedPat = OutPat Id
+type TypecheckedMonoBinds = MonoBinds Id TypecheckedPat
type TypecheckedDictBinds = TypecheckedMonoBinds
-type TypecheckedHsBinds = HsBinds Unused Id TypecheckedPat
-type TypecheckedHsExpr = HsExpr Unused Id TypecheckedPat
-type TypecheckedArithSeqInfo = ArithSeqInfo Unused Id TypecheckedPat
-type TypecheckedStmt = Stmt Unused Id TypecheckedPat
-type TypecheckedMatch = Match Unused Id TypecheckedPat
-type TypecheckedGRHSsAndBinds = GRHSsAndBinds Unused Id TypecheckedPat
-type TypecheckedGRHS = GRHS Unused Id TypecheckedPat
-type TypecheckedRecordBinds = HsRecordBinds Unused Id TypecheckedPat
-type TypecheckedHsModule = HsModule Unused Id TypecheckedPat
+type TypecheckedHsBinds = HsBinds Id TypecheckedPat
+type TypecheckedHsExpr = HsExpr Id TypecheckedPat
+type TypecheckedArithSeqInfo = ArithSeqInfo Id TypecheckedPat
+type TypecheckedStmt = Stmt Id TypecheckedPat
+type TypecheckedMatch = Match Id TypecheckedPat
+type TypecheckedGRHSs = GRHSs Id TypecheckedPat
+type TypecheckedGRHS = GRHS Id TypecheckedPat
+type TypecheckedRecordBinds = HsRecordBinds Id TypecheckedPat
+type TypecheckedHsModule = HsModule Id TypecheckedPat
type TypecheckedForeignDecl = ForeignDecl Id
\end{code}
%* *
%************************************************************************
-@zonkTcId@ just works on TcIdOccs. It's used when zonking Method insts.
-
-\begin{code}
-zonkTcId :: TcIdOcc s -> NF_TcM s (TcIdOcc s)
-zonkTcId tc_id@(RealId id) = returnNF_Tc tc_id
-zonkTcId (TcId id)
- = zonkId id `thenNF_Tc` \id ->
- returnNF_Tc (TcId id)
-
-zonkId :: TcIdBndr s -> NF_TcM s (TcIdBndr s)
-zonkId id
- = zonkTcType (idType id) `thenNF_Tc` \ ty' ->
- returnNF_Tc (setIdType id ty')
-\end{code}
-
-
This zonking pass runs over the bindings
a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
b) convert unbound TcTyVar to Void
- c) convert each TcIdBndr to an Id by zonking its type
-
-We pass an environment around so that
+ c) convert each TcId to an Id by zonking its type
- a) we know which TyVars are unbound
- b) we maintain sharing; eg an Id is zonked at its binding site and they
- all occurrences of that Id point to the common zonked copy
+The type variables are converted by binding mutable tyvars to immutable ones
+and then zonking as normal.
-Actually, since this is all in the Tc monad, it's convenient to keep the
-mapping from TcIds to Ids in the GVE of the Tc monad. (Those TcIds
-were previously in the LVE of the Tc monad.) The type variables, though,
-we carry round in a separate environment.
+The Ids are converted by binding them in the normal Tc envt; that
+way we maintain sharing; eg an Id is zonked at its binding site and they
+all occurrences of that Id point to the common zonked copy
It's all pretty boring stuff, because HsSyn is such a large type, and
the environment manipulation is tiresome.
\begin{code}
-extend_te te tyvars = extendVarEnvList te [(tyvar, mkTyVarTy tyvar) | tyvar <- tyvars]
-
-zonkIdBndr :: TyVarEnv Type -> TcIdOcc s -> NF_TcM s Id
-zonkIdBndr te (RealId id) = returnNF_Tc id
-zonkIdBndr te (TcId id)
- = zonkTcTypeToType te (idType id) `thenNF_Tc` \ ty' ->
+-- zonkId is used *during* typechecking just to zonk the Id's type
+zonkId :: TcId -> NF_TcM s TcId
+zonkId id
+ = zonkTcType (idType id) `thenNF_Tc` \ ty' ->
returnNF_Tc (setIdType id ty')
+-- zonkIdBndr is used *after* typechecking to get the Id's type
+-- to its final form. The TyVarEnv give
+zonkIdBndr :: TcId -> NF_TcM s Id
+zonkIdBndr id
+ = zonkTcTypeToType (idType id) `thenNF_Tc` \ ty' ->
+ returnNF_Tc (setIdType id ty')
-zonkIdOcc :: TcIdOcc s -> NF_TcM s Id
-zonkIdOcc (RealId id) = returnNF_Tc id
-zonkIdOcc (TcId id)
- = tcLookupGlobalValueMaybe (getName id) `thenNF_Tc` \ maybe_id' ->
+zonkIdOcc :: TcId -> NF_TcM s Id
+zonkIdOcc id
+ | not (isLocallyDefined id) || omitIfaceSigForId id
+ -- The omitIfaceSigForId thing may look wierd but it's quite
+ -- sensible really. We're avoiding looking up superclass selectors
+ -- and constructors; zonking them is a no-op anyway, and the
+ -- superclass selectors aren't in the environment anyway.
+ = returnNF_Tc id
+ | otherwise
+ = tcLookupValueMaybe (idName id) `thenNF_Tc` \ maybe_id' ->
let
new_id = case maybe_id' of
Just id' -> id'
- Nothing -> pprTrace "zonkIdOcc: " (ppr id) $
- setIdType id voidTy
+ Nothing -> pprTrace "zonkIdOcc: " (ppr id) id
in
returnNF_Tc new_id
\end{code}
\begin{code}
-zonkTopBinds :: TcMonoBinds s -> NF_TcM s (TypecheckedMonoBinds, GlobalValueEnv)
+zonkTopBinds :: TcMonoBinds -> NF_TcM s (TypecheckedMonoBinds, ValueEnv)
zonkTopBinds binds -- Top level is implicitly recursive
= fixNF_Tc (\ ~(_, new_ids) ->
tcExtendGlobalValEnv (bagToList new_ids) $
- zonkMonoBinds emptyVarEnv binds `thenNF_Tc` \ (binds', _, new_ids) ->
- -- No top-level existential type variables
- tcGetGlobalValEnv `thenNF_Tc` \ env ->
+ zonkMonoBinds binds `thenNF_Tc` \ (binds', new_ids) ->
+ tcGetValueEnv `thenNF_Tc` \ env ->
returnNF_Tc ((binds', env), new_ids)
) `thenNF_Tc` \ (stuff, _) ->
returnNF_Tc stuff
+zonkBinds :: TcHsBinds -> NF_TcM s (TypecheckedHsBinds, TcEnv)
-zonkBinds :: TyVarEnv Type
- -> TcHsBinds s
- -> NF_TcM s (TypecheckedHsBinds, TyVarEnv Type, TcEnv s)
-
-zonkBinds te binds
- = go binds te (\ binds' te' -> tcGetEnv `thenNF_Tc` \ env ->
- returnNF_Tc (binds', te', env))
+zonkBinds binds
+ = go binds (\ binds' -> tcGetEnv `thenNF_Tc` \ env ->
+ returnNF_Tc (binds', env))
where
- -- go :: TcHsBinds s
+ -- go :: TcHsBinds
-- -> (TypecheckedHsBinds
- -- -> TyVarEnv Type
- -- -> NF_TcM s (TypecheckedHsBinds, TyVarEnv Type, TcEnv s)
+ -- -> NF_TcM s (TypecheckedHsBinds, TcEnv)
-- )
- -- -> NF_TcM s (TypecheckedHsBinds, TyVarEnv Type, TcEnv s)
- go (ThenBinds b1 b2) te thing_inside = go b1 te $ \ b1' te1 ->
- go b2 te1 $ \ b2' te2 ->
- thing_inside (b1' `ThenBinds` b2') te2
+ -- -> NF_TcM s (TypecheckedHsBinds, TcEnv)
- go EmptyBinds te thing_inside = thing_inside EmptyBinds te
+ go (ThenBinds b1 b2) thing_inside = go b1 $ \ b1' ->
+ go b2 $ \ b2' ->
+ thing_inside (b1' `ThenBinds` b2')
- go (MonoBind bind sigs is_rec) te thing_inside
+ go EmptyBinds thing_inside = thing_inside EmptyBinds
+
+ go (MonoBind bind sigs is_rec) thing_inside
= ASSERT( null sigs )
- fixNF_Tc (\ ~(_, new_tvs, new_ids) ->
- let
- new_te = extend_te te (bagToList new_tvs)
- in
- tcExtendGlobalValEnv (bagToList new_ids) $
- zonkMonoBinds new_te bind `thenNF_Tc` \ (new_bind, new_tvs, new_ids) ->
- thing_inside (MonoBind new_bind [] is_rec) new_te `thenNF_Tc` \ stuff ->
- returnNF_Tc (stuff, new_tvs, new_ids)
- ) `thenNF_Tc` \ (stuff, _, _) ->
+ fixNF_Tc (\ ~(_, new_ids) ->
+ tcExtendGlobalValEnv (bagToList new_ids) $
+ zonkMonoBinds bind `thenNF_Tc` \ (new_bind, new_ids) ->
+ thing_inside (MonoBind new_bind [] is_rec) `thenNF_Tc` \ stuff ->
+ returnNF_Tc (stuff, new_ids)
+ ) `thenNF_Tc` \ (stuff, _) ->
returnNF_Tc stuff
\end{code}
\begin{code}
-------------------------------------------------------------------------
-zonkMonoBinds :: TyVarEnv Type
- -> TcMonoBinds s
- -> NF_TcM s (TypecheckedMonoBinds, Bag TyVar, Bag Id)
+zonkMonoBinds :: TcMonoBinds
+ -> NF_TcM s (TypecheckedMonoBinds, Bag Id)
-zonkMonoBinds te EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, emptyBag, emptyBag)
+zonkMonoBinds EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, emptyBag)
-zonkMonoBinds te (AndMonoBinds mbinds1 mbinds2)
- = zonkMonoBinds te mbinds1 `thenNF_Tc` \ (b1', tvs1, ids1) ->
- zonkMonoBinds te mbinds2 `thenNF_Tc` \ (b2', tvs2, ids2) ->
+zonkMonoBinds (AndMonoBinds mbinds1 mbinds2)
+ = zonkMonoBinds mbinds1 `thenNF_Tc` \ (b1', ids1) ->
+ zonkMonoBinds mbinds2 `thenNF_Tc` \ (b2', ids2) ->
returnNF_Tc (b1' `AndMonoBinds` b2',
- tvs1 `unionBags` tvs2,
ids1 `unionBags` ids2)
-zonkMonoBinds te (PatMonoBind pat grhss_w_binds locn)
- = zonkPat te pat `thenNF_Tc` \ (new_pat, tvs, ids) ->
- zonkGRHSsAndBinds te grhss_w_binds `thenNF_Tc` \ new_grhss_w_binds ->
- returnNF_Tc (PatMonoBind new_pat new_grhss_w_binds locn, tvs, ids)
+zonkMonoBinds (PatMonoBind pat grhss locn)
+ = zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
+ zonkGRHSs grhss `thenNF_Tc` \ new_grhss ->
+ returnNF_Tc (PatMonoBind new_pat new_grhss locn, ids)
-zonkMonoBinds te (VarMonoBind var expr)
- = zonkIdBndr te var `thenNF_Tc` \ new_var ->
- zonkExpr te expr `thenNF_Tc` \ new_expr ->
- returnNF_Tc (VarMonoBind new_var new_expr, emptyBag, unitBag new_var)
+zonkMonoBinds (VarMonoBind var expr)
+ = zonkIdBndr var `thenNF_Tc` \ new_var ->
+ zonkExpr expr `thenNF_Tc` \ new_expr ->
+ returnNF_Tc (VarMonoBind new_var new_expr, unitBag new_var)
-zonkMonoBinds te (CoreMonoBind var core_expr)
- = zonkIdBndr te var `thenNF_Tc` \ new_var ->
- returnNF_Tc (CoreMonoBind new_var core_expr, emptyBag, unitBag new_var)
+zonkMonoBinds (CoreMonoBind var core_expr)
+ = zonkIdBndr var `thenNF_Tc` \ new_var ->
+ returnNF_Tc (CoreMonoBind new_var core_expr, unitBag new_var)
-zonkMonoBinds te (FunMonoBind var inf ms locn)
- = zonkIdBndr te var `thenNF_Tc` \ new_var ->
- mapNF_Tc (zonkMatch te) ms `thenNF_Tc` \ new_ms ->
- returnNF_Tc (FunMonoBind new_var inf new_ms locn, emptyBag, unitBag new_var)
+zonkMonoBinds (FunMonoBind var inf ms locn)
+ = zonkIdBndr var `thenNF_Tc` \ new_var ->
+ mapNF_Tc zonkMatch ms `thenNF_Tc` \ new_ms ->
+ returnNF_Tc (FunMonoBind new_var inf new_ms locn, unitBag new_var)
-zonkMonoBinds te (AbsBinds tyvars dicts exports val_bind)
+zonkMonoBinds (AbsBinds tyvars dicts exports val_bind)
= mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
- let
- new_te = extend_te te new_tyvars
- in
- mapNF_Tc (zonkIdBndr new_te) dicts `thenNF_Tc` \ new_dicts ->
+ -- No need to extend tyvar env: the effects are
+ -- propagated through binding the tyvars themselves
+ mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
tcExtendGlobalValEnv new_dicts $
- fixNF_Tc (\ ~(_, _, val_bind_tvs, val_bind_ids) ->
- let
- new_te2 = extend_te new_te (bagToList val_bind_tvs)
- in
- tcExtendGlobalValEnv (bagToList val_bind_ids) $
- zonkMonoBinds new_te2 val_bind `thenNF_Tc` \ (new_val_bind, val_bind_tvs, val_bind_ids) ->
- mapNF_Tc (zonkExport new_te2) exports `thenNF_Tc` \ new_exports ->
- returnNF_Tc (new_val_bind, new_exports, val_bind_tvs, val_bind_ids)
- ) `thenNF_Tc ` \ (new_val_bind, new_exports, _, _) ->
+
+ fixNF_Tc (\ ~(_, _, val_bind_ids) ->
+ tcExtendGlobalValEnv (bagToList val_bind_ids) $
+ zonkMonoBinds val_bind `thenNF_Tc` \ (new_val_bind, val_bind_ids) ->
+ mapNF_Tc zonkExport exports `thenNF_Tc` \ new_exports ->
+ returnNF_Tc (new_val_bind, new_exports, val_bind_ids)
+ ) `thenNF_Tc ` \ (new_val_bind, new_exports, _) ->
let
new_globals = listToBag [global | (_, global, local) <- new_exports]
in
returnNF_Tc (AbsBinds new_tyvars new_dicts new_exports new_val_bind,
- emptyBag, -- For now.
new_globals)
where
- zonkExport te (tyvars, global, local)
- = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
- zonkIdBndr te global `thenNF_Tc` \ new_global ->
+ zonkExport (tyvars, global, local)
+ = mapNF_Tc zonkTcTyVarBndr tyvars `thenNF_Tc` \ new_tyvars ->
+ zonkIdBndr global `thenNF_Tc` \ new_global ->
zonkIdOcc local `thenNF_Tc` \ new_local ->
returnNF_Tc (new_tyvars, new_global, new_local)
\end{code}
%************************************************************************
%* *
-\subsection[BackSubst-Match-GRHSs]{Match and GRHSsAndBinds}
+\subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
%* *
%************************************************************************
\begin{code}
-zonkMatch :: TyVarEnv Type
- -> TcMatch s -> NF_TcM s TypecheckedMatch
+zonkMatch :: TcMatch -> NF_TcM s TypecheckedMatch
-zonkMatch te (PatMatch pat match)
- = zonkPat te pat `thenNF_Tc` \ (new_pat, new_tvs, new_ids) ->
- let
- new_te = extend_te te (bagToList new_tvs)
- in
+zonkMatch (Match _ pats _ grhss)
+ = zonkPats pats `thenNF_Tc` \ (new_pats, new_ids) ->
tcExtendGlobalValEnv (bagToList new_ids) $
- zonkMatch new_te match `thenNF_Tc` \ new_match ->
- returnNF_Tc (PatMatch new_pat new_match)
-
-zonkMatch te (GRHSMatch grhss_w_binds)
- = zonkGRHSsAndBinds te grhss_w_binds `thenNF_Tc` \ new_grhss_w_binds ->
- returnNF_Tc (GRHSMatch new_grhss_w_binds)
-
-zonkMatch te (SimpleMatch expr)
- = zonkExpr te expr `thenNF_Tc` \ new_expr ->
- returnNF_Tc (SimpleMatch new_expr)
+ zonkGRHSs grhss `thenNF_Tc` \ new_grhss ->
+ returnNF_Tc (Match [] new_pats Nothing new_grhss)
-------------------------------------------------------------------------
-zonkGRHSsAndBinds :: TyVarEnv Type
- -> TcGRHSsAndBinds s
- -> NF_TcM s TypecheckedGRHSsAndBinds
+zonkGRHSs :: TcGRHSs
+ -> NF_TcM s TypecheckedGRHSs
-zonkGRHSsAndBinds te (GRHSsAndBindsOut grhss binds ty)
- = zonkBinds te binds `thenNF_Tc` \ (new_binds, new_te, new_env) ->
+zonkGRHSs (GRHSs grhss binds (Just ty))
+ = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
tcSetEnv new_env $
let
zonk_grhs (GRHS guarded locn)
- = zonkStmts new_te guarded `thenNF_Tc` \ new_guarded ->
+ = zonkStmts guarded `thenNF_Tc` \ new_guarded ->
returnNF_Tc (GRHS new_guarded locn)
in
mapNF_Tc zonk_grhs grhss `thenNF_Tc` \ new_grhss ->
- zonkTcTypeToType new_te ty `thenNF_Tc` \ new_ty ->
- returnNF_Tc (GRHSsAndBindsOut new_grhss new_binds new_ty)
+ zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
+ returnNF_Tc (GRHSs new_grhss new_binds (Just new_ty))
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-zonkExpr :: TyVarEnv Type
- -> TcExpr s -> NF_TcM s TypecheckedHsExpr
+zonkExpr :: TcExpr -> NF_TcM s TypecheckedHsExpr
-zonkExpr te (HsVar id)
+zonkExpr (HsVar id)
= zonkIdOcc id `thenNF_Tc` \ id' ->
returnNF_Tc (HsVar id')
-zonkExpr te (HsLit _) = panic "zonkExpr te:HsLit"
+zonkExpr (HsLit _) = panic "zonkExpr:HsLit"
-zonkExpr te (HsLitOut lit ty)
- = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
+zonkExpr (HsLitOut lit ty)
+ = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
returnNF_Tc (HsLitOut lit new_ty)
-zonkExpr te (HsLam match)
- = zonkMatch te match `thenNF_Tc` \ new_match ->
+zonkExpr (HsLam match)
+ = zonkMatch match `thenNF_Tc` \ new_match ->
returnNF_Tc (HsLam new_match)
-zonkExpr te (HsApp e1 e2)
- = zonkExpr te e1 `thenNF_Tc` \ new_e1 ->
- zonkExpr te e2 `thenNF_Tc` \ new_e2 ->
+zonkExpr (HsApp e1 e2)
+ = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
+ zonkExpr e2 `thenNF_Tc` \ new_e2 ->
returnNF_Tc (HsApp new_e1 new_e2)
-zonkExpr te (OpApp e1 op fixity e2)
- = zonkExpr te e1 `thenNF_Tc` \ new_e1 ->
- zonkExpr te op `thenNF_Tc` \ new_op ->
- zonkExpr te e2 `thenNF_Tc` \ new_e2 ->
+zonkExpr (OpApp e1 op fixity e2)
+ = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
+ zonkExpr op `thenNF_Tc` \ new_op ->
+ zonkExpr e2 `thenNF_Tc` \ new_e2 ->
returnNF_Tc (OpApp new_e1 new_op fixity new_e2)
-zonkExpr te (NegApp _ _) = panic "zonkExpr te:NegApp"
-zonkExpr te (HsPar _) = panic "zonkExpr te:HsPar"
+zonkExpr (NegApp _ _) = panic "zonkExpr: NegApp"
+zonkExpr (HsPar _) = panic "zonkExpr: HsPar"
-zonkExpr te (SectionL expr op)
- = zonkExpr te expr `thenNF_Tc` \ new_expr ->
- zonkExpr te op `thenNF_Tc` \ new_op ->
+zonkExpr (SectionL expr op)
+ = zonkExpr expr `thenNF_Tc` \ new_expr ->
+ zonkExpr op `thenNF_Tc` \ new_op ->
returnNF_Tc (SectionL new_expr new_op)
-zonkExpr te (SectionR op expr)
- = zonkExpr te op `thenNF_Tc` \ new_op ->
- zonkExpr te expr `thenNF_Tc` \ new_expr ->
+zonkExpr (SectionR op expr)
+ = zonkExpr op `thenNF_Tc` \ new_op ->
+ zonkExpr expr `thenNF_Tc` \ new_expr ->
returnNF_Tc (SectionR new_op new_expr)
-zonkExpr te (HsCase expr ms src_loc)
- = zonkExpr te expr `thenNF_Tc` \ new_expr ->
- mapNF_Tc (zonkMatch te) ms `thenNF_Tc` \ new_ms ->
+zonkExpr (HsCase expr ms src_loc)
+ = zonkExpr expr `thenNF_Tc` \ new_expr ->
+ mapNF_Tc zonkMatch ms `thenNF_Tc` \ new_ms ->
returnNF_Tc (HsCase new_expr new_ms src_loc)
-zonkExpr te (HsIf e1 e2 e3 src_loc)
- = zonkExpr te e1 `thenNF_Tc` \ new_e1 ->
- zonkExpr te e2 `thenNF_Tc` \ new_e2 ->
- zonkExpr te e3 `thenNF_Tc` \ new_e3 ->
+zonkExpr (HsIf e1 e2 e3 src_loc)
+ = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
+ zonkExpr e2 `thenNF_Tc` \ new_e2 ->
+ zonkExpr e3 `thenNF_Tc` \ new_e3 ->
returnNF_Tc (HsIf new_e1 new_e2 new_e3 src_loc)
-zonkExpr te (HsLet binds expr)
- = zonkBinds te binds `thenNF_Tc` \ (new_binds, new_te, new_env) ->
+zonkExpr (HsLet binds expr)
+ = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
tcSetEnv new_env $
- zonkExpr new_te expr `thenNF_Tc` \ new_expr ->
+ zonkExpr expr `thenNF_Tc` \ new_expr ->
returnNF_Tc (HsLet new_binds new_expr)
-zonkExpr te (HsDo _ _ _) = panic "zonkExpr te:HsDo"
+zonkExpr (HsDo _ _ _) = panic "zonkExpr:HsDo"
-zonkExpr te (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc)
- = zonkStmts te stmts `thenNF_Tc` \ new_stmts ->
- zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
+zonkExpr (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc)
+ = zonkStmts stmts `thenNF_Tc` \ new_stmts ->
+ zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
zonkIdOcc return_id `thenNF_Tc` \ new_return_id ->
zonkIdOcc then_id `thenNF_Tc` \ new_then_id ->
zonkIdOcc zero_id `thenNF_Tc` \ new_zero_id ->
returnNF_Tc (HsDoOut do_or_lc new_stmts new_return_id new_then_id new_zero_id
new_ty src_loc)
-zonkExpr te (ExplicitList _) = panic "zonkExpr te:ExplicitList"
+zonkExpr (ExplicitList _) = panic "zonkExpr:ExplicitList"
-zonkExpr te (ExplicitListOut ty exprs)
- = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
- mapNF_Tc (zonkExpr te) exprs `thenNF_Tc` \ new_exprs ->
+zonkExpr (ExplicitListOut ty exprs)
+ = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
+ mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs ->
returnNF_Tc (ExplicitListOut new_ty new_exprs)
-zonkExpr te (ExplicitTuple exprs boxed)
- = mapNF_Tc (zonkExpr te) exprs `thenNF_Tc` \ new_exprs ->
+zonkExpr (ExplicitTuple exprs boxed)
+ = mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs ->
returnNF_Tc (ExplicitTuple new_exprs boxed)
-zonkExpr te (HsCon data_con tys exprs)
- = mapNF_Tc (zonkTcTypeToType te) tys `thenNF_Tc` \ new_tys ->
- mapNF_Tc (zonkExpr te) exprs `thenNF_Tc` \ new_exprs ->
+zonkExpr (HsCon data_con tys exprs)
+ = mapNF_Tc zonkTcTypeToType tys `thenNF_Tc` \ new_tys ->
+ mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs ->
returnNF_Tc (HsCon data_con new_tys new_exprs)
-zonkExpr te (RecordConOut data_con con_expr rbinds)
- = zonkExpr te con_expr `thenNF_Tc` \ new_con_expr ->
- zonkRbinds te rbinds `thenNF_Tc` \ new_rbinds ->
+zonkExpr (RecordConOut data_con con_expr rbinds)
+ = zonkExpr con_expr `thenNF_Tc` \ new_con_expr ->
+ zonkRbinds rbinds `thenNF_Tc` \ new_rbinds ->
returnNF_Tc (RecordConOut data_con new_con_expr new_rbinds)
-zonkExpr te (RecordUpd _ _) = panic "zonkExpr te:RecordUpd"
+zonkExpr (RecordUpd _ _) = panic "zonkExpr:RecordUpd"
-zonkExpr te (RecordUpdOut expr ty dicts rbinds)
- = zonkExpr te expr `thenNF_Tc` \ new_expr ->
- zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
+zonkExpr (RecordUpdOut expr ty dicts rbinds)
+ = zonkExpr expr `thenNF_Tc` \ new_expr ->
+ zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts ->
- zonkRbinds te rbinds `thenNF_Tc` \ new_rbinds ->
+ zonkRbinds rbinds `thenNF_Tc` \ new_rbinds ->
returnNF_Tc (RecordUpdOut new_expr new_ty new_dicts new_rbinds)
-zonkExpr te (ExprWithTySig _ _) = panic "zonkExpr te:ExprWithTySig"
-zonkExpr te (ArithSeqIn _) = panic "zonkExpr te:ArithSeqIn"
+zonkExpr (ExprWithTySig _ _) = panic "zonkExpr:ExprWithTySig"
+zonkExpr (ArithSeqIn _) = panic "zonkExpr:ArithSeqIn"
-zonkExpr te (ArithSeqOut expr info)
- = zonkExpr te expr `thenNF_Tc` \ new_expr ->
- zonkArithSeq te info `thenNF_Tc` \ new_info ->
+zonkExpr (ArithSeqOut expr info)
+ = zonkExpr expr `thenNF_Tc` \ new_expr ->
+ zonkArithSeq info `thenNF_Tc` \ new_info ->
returnNF_Tc (ArithSeqOut new_expr new_info)
-zonkExpr te (CCall fun args may_gc is_casm result_ty)
- = mapNF_Tc (zonkExpr te) args `thenNF_Tc` \ new_args ->
- zonkTcTypeToType te result_ty `thenNF_Tc` \ new_result_ty ->
+zonkExpr (CCall fun args may_gc is_casm result_ty)
+ = mapNF_Tc zonkExpr args `thenNF_Tc` \ new_args ->
+ zonkTcTypeToType result_ty `thenNF_Tc` \ new_result_ty ->
returnNF_Tc (CCall fun new_args may_gc is_casm new_result_ty)
-zonkExpr te (HsSCC label expr)
- = zonkExpr te expr `thenNF_Tc` \ new_expr ->
+zonkExpr (HsSCC label expr)
+ = zonkExpr expr `thenNF_Tc` \ new_expr ->
returnNF_Tc (HsSCC label new_expr)
-zonkExpr te (TyLam tyvars expr)
+zonkExpr (TyLam tyvars expr)
= mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
- let
- new_te = extend_te te new_tyvars
- in
- zonkExpr new_te expr `thenNF_Tc` \ new_expr ->
+ -- No need to extend tyvar env; see AbsBinds
+
+ zonkExpr expr `thenNF_Tc` \ new_expr ->
returnNF_Tc (TyLam new_tyvars new_expr)
-zonkExpr te (TyApp expr tys)
- = zonkExpr te expr `thenNF_Tc` \ new_expr ->
- mapNF_Tc (zonkTcTypeToType te) tys `thenNF_Tc` \ new_tys ->
+zonkExpr (TyApp expr tys)
+ = zonkExpr expr `thenNF_Tc` \ new_expr ->
+ mapNF_Tc zonkTcTypeToType tys `thenNF_Tc` \ new_tys ->
returnNF_Tc (TyApp new_expr new_tys)
-zonkExpr te (DictLam dicts expr)
- = mapNF_Tc (zonkIdBndr te) dicts `thenNF_Tc` \ new_dicts ->
+zonkExpr (DictLam dicts expr)
+ = mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
tcExtendGlobalValEnv new_dicts $
- zonkExpr te expr `thenNF_Tc` \ new_expr ->
+ zonkExpr expr `thenNF_Tc` \ new_expr ->
returnNF_Tc (DictLam new_dicts new_expr)
-zonkExpr te (DictApp expr dicts)
- = zonkExpr te expr `thenNF_Tc` \ new_expr ->
+zonkExpr (DictApp expr dicts)
+ = zonkExpr expr `thenNF_Tc` \ new_expr ->
mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts ->
returnNF_Tc (DictApp new_expr new_dicts)
-------------------------------------------------------------------------
-zonkArithSeq :: TyVarEnv Type
- -> TcArithSeqInfo s -> NF_TcM s TypecheckedArithSeqInfo
+zonkArithSeq :: TcArithSeqInfo -> NF_TcM s TypecheckedArithSeqInfo
-zonkArithSeq te (From e)
- = zonkExpr te e `thenNF_Tc` \ new_e ->
+zonkArithSeq (From e)
+ = zonkExpr e `thenNF_Tc` \ new_e ->
returnNF_Tc (From new_e)
-zonkArithSeq te (FromThen e1 e2)
- = zonkExpr te e1 `thenNF_Tc` \ new_e1 ->
- zonkExpr te e2 `thenNF_Tc` \ new_e2 ->
+zonkArithSeq (FromThen e1 e2)
+ = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
+ zonkExpr e2 `thenNF_Tc` \ new_e2 ->
returnNF_Tc (FromThen new_e1 new_e2)
-zonkArithSeq te (FromTo e1 e2)
- = zonkExpr te e1 `thenNF_Tc` \ new_e1 ->
- zonkExpr te e2 `thenNF_Tc` \ new_e2 ->
+zonkArithSeq (FromTo e1 e2)
+ = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
+ zonkExpr e2 `thenNF_Tc` \ new_e2 ->
returnNF_Tc (FromTo new_e1 new_e2)
-zonkArithSeq te (FromThenTo e1 e2 e3)
- = zonkExpr te e1 `thenNF_Tc` \ new_e1 ->
- zonkExpr te e2 `thenNF_Tc` \ new_e2 ->
- zonkExpr te e3 `thenNF_Tc` \ new_e3 ->
+zonkArithSeq (FromThenTo e1 e2 e3)
+ = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
+ zonkExpr e2 `thenNF_Tc` \ new_e2 ->
+ zonkExpr e3 `thenNF_Tc` \ new_e3 ->
returnNF_Tc (FromThenTo new_e1 new_e2 new_e3)
-------------------------------------------------------------------------
-zonkStmts :: TyVarEnv Type
- -> [TcStmt s]
+zonkStmts :: [TcStmt]
-> NF_TcM s [TypecheckedStmt]
-zonkStmts te [] = returnNF_Tc []
+zonkStmts [] = returnNF_Tc []
-zonkStmts te [ReturnStmt expr]
- = zonkExpr te expr `thenNF_Tc` \ new_expr ->
+zonkStmts [ReturnStmt expr]
+ = zonkExpr expr `thenNF_Tc` \ new_expr ->
returnNF_Tc [ReturnStmt new_expr]
-zonkStmts te (ExprStmt expr locn : stmts)
- = zonkExpr te expr `thenNF_Tc` \ new_expr ->
- zonkStmts te stmts `thenNF_Tc` \ new_stmts ->
+zonkStmts (ExprStmt expr locn : stmts)
+ = zonkExpr expr `thenNF_Tc` \ new_expr ->
+ zonkStmts stmts `thenNF_Tc` \ new_stmts ->
returnNF_Tc (ExprStmt new_expr locn : new_stmts)
-zonkStmts te (GuardStmt expr locn : stmts)
- = zonkExpr te expr `thenNF_Tc` \ new_expr ->
- zonkStmts te stmts `thenNF_Tc` \ new_stmts ->
+zonkStmts (GuardStmt expr locn : stmts)
+ = zonkExpr expr `thenNF_Tc` \ new_expr ->
+ zonkStmts stmts `thenNF_Tc` \ new_stmts ->
returnNF_Tc (GuardStmt new_expr locn : new_stmts)
-zonkStmts te (LetStmt binds : stmts)
- = zonkBinds te binds `thenNF_Tc` \ (new_binds, new_te, new_env) ->
+zonkStmts (LetStmt binds : stmts)
+ = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
tcSetEnv new_env $
- zonkStmts new_te stmts `thenNF_Tc` \ new_stmts ->
+ zonkStmts stmts `thenNF_Tc` \ new_stmts ->
returnNF_Tc (LetStmt new_binds : new_stmts)
-zonkStmts te (BindStmt pat expr locn : stmts)
- = zonkExpr te expr `thenNF_Tc` \ new_expr ->
- zonkPat te pat `thenNF_Tc` \ (new_pat, new_tvs, new_ids) ->
- let
- new_te = extend_te te (bagToList new_tvs)
- in
+zonkStmts (BindStmt pat expr locn : stmts)
+ = zonkExpr expr `thenNF_Tc` \ new_expr ->
+ zonkPat pat `thenNF_Tc` \ (new_pat, new_ids) ->
tcExtendGlobalValEnv (bagToList new_ids) $
- zonkStmts new_te stmts `thenNF_Tc` \ new_stmts ->
+ zonkStmts stmts `thenNF_Tc` \ new_stmts ->
returnNF_Tc (BindStmt new_pat new_expr locn : new_stmts)
-------------------------------------------------------------------------
-zonkRbinds :: TyVarEnv Type
- -> TcRecordBinds s -> NF_TcM s TypecheckedRecordBinds
+zonkRbinds :: TcRecordBinds -> NF_TcM s TypecheckedRecordBinds
-zonkRbinds te rbinds
+zonkRbinds rbinds
= mapNF_Tc zonk_rbind rbinds
where
zonk_rbind (field, expr, pun)
- = zonkExpr te expr `thenNF_Tc` \ new_expr ->
+ = zonkExpr expr `thenNF_Tc` \ new_expr ->
zonkIdOcc field `thenNF_Tc` \ new_field ->
returnNF_Tc (new_field, new_expr, pun)
\end{code}
%************************************************************************
\begin{code}
-zonkPat :: TyVarEnv Type
- -> TcPat s -> NF_TcM s (TypecheckedPat, Bag TyVar, Bag Id)
+zonkPat :: TcPat -> NF_TcM s (TypecheckedPat, Bag Id)
-zonkPat te (WildPat ty)
- = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
- returnNF_Tc (WildPat new_ty, emptyBag, emptyBag)
+zonkPat (WildPat ty)
+ = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
+ returnNF_Tc (WildPat new_ty, emptyBag)
-zonkPat te (VarPat v)
- = zonkIdBndr te v `thenNF_Tc` \ new_v ->
- returnNF_Tc (VarPat new_v, emptyBag, unitBag new_v)
+zonkPat (VarPat v)
+ = zonkIdBndr v `thenNF_Tc` \ new_v ->
+ returnNF_Tc (VarPat new_v, unitBag new_v)
-zonkPat te (LazyPat pat)
- = zonkPat te pat `thenNF_Tc` \ (new_pat, tvs, ids) ->
- returnNF_Tc (LazyPat new_pat, tvs, ids)
+zonkPat (LazyPat pat)
+ = zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
+ returnNF_Tc (LazyPat new_pat, ids)
-zonkPat te (AsPat n pat)
- = zonkIdBndr te n `thenNF_Tc` \ new_n ->
- zonkPat te pat `thenNF_Tc` \ (new_pat, tvs, ids) ->
- returnNF_Tc (AsPat new_n new_pat, tvs, new_n `consBag` ids)
+zonkPat (AsPat n pat)
+ = zonkIdBndr n `thenNF_Tc` \ new_n ->
+ zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
+ returnNF_Tc (AsPat new_n new_pat, new_n `consBag` ids)
-zonkPat te (ListPat ty pats)
- = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
- zonkPats te pats `thenNF_Tc` \ (new_pats, tvs, ids) ->
- returnNF_Tc (ListPat new_ty new_pats, tvs, ids)
+zonkPat (ListPat ty pats)
+ = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
+ zonkPats pats `thenNF_Tc` \ (new_pats, ids) ->
+ returnNF_Tc (ListPat new_ty new_pats, ids)
-zonkPat te (TuplePat pats boxed)
- = zonkPats te pats `thenNF_Tc` \ (new_pats, tvs, ids) ->
- returnNF_Tc (TuplePat new_pats boxed, tvs, ids)
+zonkPat (TuplePat pats boxed)
+ = zonkPats pats `thenNF_Tc` \ (new_pats, ids) ->
+ returnNF_Tc (TuplePat new_pats boxed, ids)
-zonkPat te (ConPat n ty tvs dicts pats)
- = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
+zonkPat (ConPat n ty tvs dicts pats)
+ = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
mapNF_Tc zonkTcTyVarToTyVar tvs `thenNF_Tc` \ new_tvs ->
- let
- new_te = extend_te te new_tvs
- in
- mapNF_Tc (zonkIdBndr new_te) dicts `thenNF_Tc` \ new_dicts ->
+ mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
tcExtendGlobalValEnv new_dicts $
-
- zonkPats new_te pats `thenNF_Tc` \ (new_pats, tvs, ids) ->
-
+ zonkPats pats `thenNF_Tc` \ (new_pats, ids) ->
returnNF_Tc (ConPat n new_ty new_tvs new_dicts new_pats,
- listToBag new_tvs `unionBags` tvs,
listToBag new_dicts `unionBags` ids)
-zonkPat te (RecPat n ty tvs dicts rpats)
- = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
+zonkPat (RecPat n ty tvs dicts rpats)
+ = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
mapNF_Tc zonkTcTyVarToTyVar tvs `thenNF_Tc` \ new_tvs ->
- let
- new_te = extend_te te new_tvs
- in
- mapNF_Tc (zonkIdBndr new_te) dicts `thenNF_Tc` \ new_dicts ->
- tcExtendGlobalValEnv new_dicts $
- mapNF_Tc (zonk_rpat new_te) rpats `thenNF_Tc` \ stuff ->
- let
- (new_rpats, tvs_s, ids_s) = unzip3 stuff
- in
+ mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
+ tcExtendGlobalValEnv new_dicts $
+ mapAndUnzipNF_Tc zonk_rpat rpats `thenNF_Tc` \ (new_rpats, ids_s) ->
returnNF_Tc (RecPat n new_ty new_tvs new_dicts new_rpats,
- listToBag new_tvs `unionBags` unionManyBags tvs_s,
listToBag new_dicts `unionBags` unionManyBags ids_s)
where
- zonk_rpat te (f, pat, pun)
- = zonkPat te pat `thenNF_Tc` \ (new_pat, tvs, ids) ->
- returnNF_Tc ((f, new_pat, pun), tvs, ids)
-
-zonkPat te (LitPat lit ty)
- = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
- returnNF_Tc (LitPat lit new_ty, emptyBag, emptyBag)
-
-zonkPat te (NPat lit ty expr)
- = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
- zonkExpr te expr `thenNF_Tc` \ new_expr ->
- returnNF_Tc (NPat lit new_ty new_expr, emptyBag, emptyBag)
-
-zonkPat te (NPlusKPat n k ty e1 e2)
- = zonkIdBndr te n `thenNF_Tc` \ new_n ->
- zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
- zonkExpr te e1 `thenNF_Tc` \ new_e1 ->
- zonkExpr te e2 `thenNF_Tc` \ new_e2 ->
- returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2, emptyBag, unitBag new_n)
-
-zonkPat te (DictPat ds ms)
- = mapNF_Tc (zonkIdBndr te) ds `thenNF_Tc` \ new_ds ->
- mapNF_Tc (zonkIdBndr te) ms `thenNF_Tc` \ new_ms ->
- returnNF_Tc (DictPat new_ds new_ms, emptyBag,
+ zonk_rpat (f, pat, pun)
+ = zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
+ returnNF_Tc ((f, new_pat, pun), ids)
+
+zonkPat (LitPat lit ty)
+ = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
+ returnNF_Tc (LitPat lit new_ty, emptyBag)
+
+zonkPat (NPat lit ty expr)
+ = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
+ zonkExpr expr `thenNF_Tc` \ new_expr ->
+ returnNF_Tc (NPat lit new_ty new_expr, emptyBag)
+
+zonkPat (NPlusKPat n k ty e1 e2)
+ = zonkIdBndr n `thenNF_Tc` \ new_n ->
+ zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
+ zonkExpr e1 `thenNF_Tc` \ new_e1 ->
+ zonkExpr e2 `thenNF_Tc` \ new_e2 ->
+ returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2, unitBag new_n)
+
+zonkPat (DictPat ds ms)
+ = mapNF_Tc zonkIdBndr ds `thenNF_Tc` \ new_ds ->
+ mapNF_Tc zonkIdBndr ms `thenNF_Tc` \ new_ms ->
+ returnNF_Tc (DictPat new_ds new_ms,
listToBag new_ds `unionBags` listToBag new_ms)
-zonkPats te []
- = returnNF_Tc ([], emptyBag, emptyBag)
+zonkPats []
+ = returnNF_Tc ([], emptyBag)
-zonkPats te (pat:pats)
- = zonkPat te pat `thenNF_Tc` \ (pat', tvs1, ids1) ->
- zonkPats te pats `thenNF_Tc` \ (pats', tvs2, ids2) ->
- returnNF_Tc (pat':pats', tvs1 `unionBags` tvs2, ids1 `unionBags` ids2)
+zonkPats (pat:pats)
+ = zonkPat pat `thenNF_Tc` \ (pat', ids1) ->
+ zonkPats pats `thenNF_Tc` \ (pats', ids2) ->
+ returnNF_Tc (pat':pats', ids1 `unionBags` ids2)
\end{code}
%************************************************************************
\begin{code}
-zonkForeignExports :: [TcForeignExportDecl s] -> NF_TcM s [TypecheckedForeignDecl]
+zonkForeignExports :: [TcForeignExportDecl] -> NF_TcM s [TypecheckedForeignDecl]
zonkForeignExports ls = mapNF_Tc zonkForeignExport ls
-zonkForeignExport :: TcForeignExportDecl s -> NF_TcM s (TypecheckedForeignDecl)
+zonkForeignExport :: TcForeignExportDecl -> NF_TcM s (TypecheckedForeignDecl)
zonkForeignExport (ForeignDecl i imp_exp hs_ty ext_nm cconv src_loc) =
zonkIdOcc i `thenNF_Tc` \ i' ->
returnNF_Tc (ForeignDecl i' imp_exp undefined ext_nm cconv src_loc)
-
\end{code}
import HsSyn ( HsDecl(..), IfaceSig(..) )
import TcMonad
-import TcMonoType ( tcHsType, tcHsTypeKind, tcTyVarScope )
-import TcEnv ( tcExtendTyVarEnv, tcExtendGlobalValEnv, tcSetGlobalValEnv,
- tcLookupTyConByKey, tcLookupGlobalValueMaybe,
- tcExplicitLookupGlobal, badCon, badPrimOp,
- GlobalValueEnv
+import TcMonoType ( tcHsType, tcHsTypeKind,
+ -- NB: all the tyars in interface files are kinded,
+ -- so tcHsType will do the Right Thing without
+ -- having to mess about with zonking
+ tcExtendTyVarScope
+ )
+import TcEnv ( ValueEnv, tcExtendTyVarEnv,
+ tcExtendGlobalValEnv, tcSetValueEnv,
+ tcLookupTyConByKey, tcLookupValueMaybe,
+ explicitLookupValue, badCon, badPrimOp
)
import TcType ( TcKind, kindToTcKind )
signatures.
\begin{code}
-tcInterfaceSigs :: GlobalValueEnv -- Envt to use when checking unfoldings
+tcInterfaceSigs :: ValueEnv -- Envt to use when checking unfoldings
-> [RenamedHsDecl] -- Ignore non-sig-decls in these decls
-> TcM s [Id]
= tcStrictness unf_env ty info strict
tcPrag info (HsSpecialise tyvars tys rhs)
- = tcTyVarScope tyvars $ \ tyvars' ->
+ = tcExtendTyVarScope tyvars $ \ tyvars' ->
mapAndUnzipTc tcHsTypeKind tys `thenTc` \ (kinds, tys') ->
-- Assume that the kinds match the kinds of the
-- type variables of the function; this is, after all, an
\end{code}
\begin{code}
-tcStrictness unf_env ty info (HsStrictnessInfo demands maybe_worker)
+tcStrictness unf_env ty info (HsStrictnessInfo (demands, bot_result) maybe_worker)
= tcWorker unf_env maybe_worker `thenNF_Tc` \ maybe_worker_id ->
uniqSMToTcM (mkWrapper ty demands) `thenNF_Tc` \ wrap_fn ->
let
has_worker = maybeToBool maybe_worker_id
in
- returnTc (StrictnessInfo demands has_worker `setStrictnessInfo` info')
-
--- Boring to write these out, but the result type differs from the arg type...
-tcStrictness unf_env ty info HsBottom
- = returnTc (BottomGuaranteed `setStrictnessInfo` info)
+ returnTc (StrictnessInfo demands bot_result has_worker `setStrictnessInfo` info')
\end{code}
\begin{code}
tcWorker unf_env (Just (worker_name,_))
= returnNF_Tc (trace_maybe maybe_worker_id)
where
- maybe_worker_id = tcExplicitLookupGlobal unf_env worker_name
+ maybe_worker_id = explicitLookupValue unf_env worker_name
-- The trace is so we can see what's getting dropped
trace_maybe Nothing = pprTrace "tcWorker failed:" (ppr worker_name) Nothing
an unfolding that isn't going to be looked at.
\begin{code}
-tcPragExpr :: GlobalValueEnv -> Name -> UfExpr Name -> NF_TcM s (Maybe CoreExpr)
+tcPragExpr :: ValueEnv -> Name -> UfExpr Name -> NF_TcM s (Maybe CoreExpr)
tcPragExpr unf_env name core_expr
= forkNF_Tc (
recoverNF_Tc no_unfolding (
- tcSetGlobalValEnv unf_env $
+ tcSetValueEnv unf_env $
tcCoreExpr core_expr `thenTc` \ core_expr' ->
returnTc (Just core_expr')
))
\begin{code}
tcVar :: Name -> TcM s Id
tcVar name
- = tcLookupGlobalValueMaybe name `thenNF_Tc` \ maybe_id ->
+ = tcLookupValueMaybe name `thenNF_Tc` \ maybe_id ->
case maybe_id of {
Just id -> returnTc id;
Nothing -> failWithTc (noDecl name)
tcCoreExpr (UfNote note expr)
= tcCoreExpr expr `thenTc` \ expr' ->
case note of
- UfCoerce to_ty -> tcHsTypeKind to_ty `thenTc` \ (_,to_ty') ->
+ UfCoerce to_ty -> tcHsType to_ty `thenTc` \ to_ty' ->
returnTc (Note (Coerce to_ty' (coreExprType expr')) expr')
UfInlineCall -> returnTc (Note InlineCall expr')
UfSCC cc -> returnTc (Note (SCC cc) expr')
= let
tyvar = mkTyVar name kind
in
- tcExtendTyVarEnv [name] [(kindToTcKind kind, tyvar)] $
- thing_inside tyvar
+ tcExtendTyVarEnv [tyvar] (thing_inside tyvar)
tcCoreValBndr (UfValBinder name ty) thing_inside
= tcHsType ty `thenTc` \ ty' ->
= zipWithEqual "tcCoreAlts" mkUserId id_names arg_tys
in
ASSERT( con `elem` cons && length inst_tys == length main_tyvars )
- tcExtendTyVarEnv (map getName ex_tyvars')
- [ (kindToTcKind (tyVarKind tv), tv)
- | tv <- ex_tyvars'] $
- tcExtendGlobalValEnv arg_ids $
+ tcExtendTyVarEnv ex_tyvars' $
+ tcExtendGlobalValEnv arg_ids $
tcCoreExpr rhs `thenTc` \ rhs' ->
returnTc (DataCon con, ex_tyvars' ++ arg_ids, rhs')
\end{code}
#include "HsVersions.h"
import HsSyn ( HsDecl(..), InstDecl(..),
- HsBinds(..), MonoBinds(..), GRHSsAndBinds(..),
+ HsBinds(..), MonoBinds(..),
HsExpr(..), InPat(..), HsLit(..), Sig(..),
collectMonoBinders, andMonoBindList
)
import RnHsSyn ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl )
-import TcHsSyn ( TcMonoBinds, TcIdOcc(..),
- maybeBoxedPrimType, tcIdType
+import TcHsSyn ( TcMonoBinds,
+ maybeBoxedPrimType
)
import TcBinds ( tcPragmaSigs )
import Inst ( Inst, InstOrigin(..),
newDicts, LIE, emptyLIE, plusLIE, plusLIEs )
import TcDeriv ( tcDeriving )
-import TcEnv ( GlobalValueEnv, tcExtendGlobalValEnv, tcAddImportedIdInfo, tcInstId )
+import TcEnv ( ValueEnv, tcExtendGlobalValEnv, tcExtendTyVarEnvForMeths,
+ tcAddImportedIdInfo, tcInstId
+ )
import TcInstUtil ( InstInfo(..), classDataCon )
-import TcMonoType ( tcHsType )
+import TcMonoType ( tcHsTopType )
import TcSimplify ( tcSimplifyAndCheck )
import TcType ( TcTyVar, zonkTcTyVarBndr )
)
import CmdLineOpts ( opt_GlasgowExts, opt_AllowUndecidableInstances )
import Class ( classBigSig, Class )
-import Var ( setIdInfo, idName, Id, TyVar )
+import Var ( setIdInfo, idName, idType, Id, TyVar )
import DataCon ( isNullaryDataCon, dataConArgTys, dataConId )
import Maybes ( maybeToBool, catMaybes, expectJust )
import MkId ( mkDictFunId )
splitSigmaTy, isTyVarTy,
splitTyConApp_maybe, splitDictTy_maybe,
splitAlgTyConApp_maybe,
- tyVarsOfTypes, substFlexiTheta
+ tyVarsOfTypes, substTopTheta
)
import VarEnv ( zipVarEnv )
import VarSet ( mkVarSet, varSetElems )
\end{enumerate}
\begin{code}
-tcInstDecls1 :: GlobalValueEnv -- Contains IdInfo for dfun ids
+tcInstDecls1 :: ValueEnv -- Contains IdInfo for dfun ids
-> [RenamedHsDecl]
-> Module -- module name for deriving
-> RnNameSupply -- for renaming derivings
-> TcM s (Bag InstInfo,
- RenamedHsBinds,
- SDoc)
+ RenamedHsBinds)
tcInstDecls1 unf_env decls mod_name rn_name_supply
= -- Do the ordinary instance declarations
-- for things in this module; we ignore deriving decls from
-- interfaces!
tcDeriving mod_name rn_name_supply decl_inst_info
- `thenTc` \ (deriv_inst_info, deriv_binds, ddump_deriv) ->
+ `thenTc` \ (deriv_inst_info, deriv_binds) ->
let
full_inst_info = deriv_inst_info `unionBags` decl_inst_info
in
- returnTc (full_inst_info, deriv_binds, ddump_deriv)
+ returnTc (full_inst_info, deriv_binds)
-tcInstDecl1 :: GlobalValueEnv -> Module -> RenamedInstDecl -> NF_TcM s (Bag InstInfo)
+tcInstDecl1 :: ValueEnv -> Module -> RenamedInstDecl -> NF_TcM s (Bag InstInfo)
tcInstDecl1 unf_env mod_name (InstDecl poly_ty binds uprags (Just dfun_name) src_loc)
= -- Prime error recovery, set source location
tcAddSrcLoc src_loc $
-- Type-check all the stuff before the "where"
- tcHsType poly_ty `thenTc` \ poly_ty' ->
+ tcHsTopType poly_ty `thenTc` \ poly_ty' ->
let
(tyvars, theta, dict_ty) = splitSigmaTy poly_ty'
(clas, inst_tys) = case splitDictTy_maybe dict_ty of
\begin{code}
tcInstDecls2 :: Bag InstInfo
- -> NF_TcM s (LIE s, TcMonoBinds s)
+ -> NF_TcM s (LIE, TcMonoBinds)
tcInstDecls2 inst_decls
= foldBag combine tcInstDecl2 (returnNF_Tc (emptyLIE, EmptyMonoBinds)) inst_decls
First comes the easy case of a non-local instance decl.
\begin{code}
-tcInstDecl2 :: InstInfo -> NF_TcM s (LIE s, TcMonoBinds s)
+tcInstDecl2 :: InstInfo -> NF_TcM s (LIE, TcMonoBinds)
tcInstDecl2 (InstInfo clas inst_tyvars inst_tys
inst_decl_theta
op_sel_ids, defm_ids) = classBigSig clas
-- Instantiate the theta found in the original instance decl
- inst_decl_theta' = substFlexiTheta (zipVarEnv inst_tyvars (mkTyVarTys inst_tyvars'))
- inst_decl_theta
+ inst_decl_theta' = substTopTheta (zipVarEnv inst_tyvars (mkTyVarTys inst_tyvars'))
+ inst_decl_theta
-- Instantiate the super-class context with inst_tys
- sc_theta' = substFlexiTheta (zipVarEnv class_tyvars inst_tys') sc_theta
+ sc_theta' = substTopTheta (zipVarEnv class_tyvars inst_tys') sc_theta
in
-- Create dictionary Ids from the specified instance contexts.
newDicts origin sc_theta' `thenNF_Tc` \ (sc_dicts, sc_dict_ids) ->
in
mapNF_Tc check_from_this_class bndrs `thenNF_Tc_`
- tcExtendGlobalValEnv (catMaybes defm_ids) (
-
+ tcExtendTyVarEnvForMeths inst_tyvars inst_tyvars' (
+ tcExtendGlobalValEnv (catMaybes defm_ids) (
-- Default-method Ids may be mentioned in synthesised RHSs
- mapAndUnzip3Tc (tcMethodBind clas origin inst_tys' inst_tyvars' monobinds uprags True)
+
+ mapAndUnzip3Tc (tcMethodBind clas origin inst_tyvars' inst_tys' inst_decl_theta'
+ monobinds uprags True)
(op_sel_ids `zip` defm_ids)
- ) `thenTc` \ (method_binds_s, insts_needed_s, meth_lies_w_ids) ->
+ )) `thenTc` \ (method_binds_s, insts_needed_s, meth_lies_w_ids) ->
-- Deal with SPECIALISE instance pragmas
let
-- emit an error message. This in turn means that we don't
-- mention the constructor, which doesn't exist for CCallable, CReturnable
-- Hardly beautiful, but only three extra lines.
- HsApp (TyApp (HsVar (RealId eRROR_ID)) [tcIdType this_dict_id])
+ HsApp (TyApp (HsVar eRROR_ID) [idType this_dict_id])
(HsLitOut (HsString msg) stringTy)
| otherwise -- The common case
- = foldl HsApp (TyApp (HsVar (RealId (dataConId dict_constr))) inst_tys')
+ = foldl HsApp (TyApp (HsVar (dataConId dict_constr)) inst_tys')
(map HsVar (sc_dict_ids ++ meth_ids))
-- We don't produce a binding for the dict_constr; instead we
-- rely on the simplifier to unfold this saturated application
= AbsBinds
zonked_inst_tyvars
dfun_arg_dicts_ids
- [(inst_tyvars', RealId final_dfun_id, this_dict_id)]
+ [(inst_tyvars', final_dfun_id, this_dict_id)]
(lie_binds1 `AndMonoBinds`
lie_binds2 `AndMonoBinds`
method_binds `AndMonoBinds`
import Class ( classTyCon )
import DataCon ( DataCon )
import TyCon ( tyConDataCons )
-import Util ( equivClasses, assertPanic )
+import Unique ( Unique, getUnique )
+import Util ( equivClassesByUniq )
import Outputable
\end{code}
buildInstanceEnvs info
= let
- icmp :: InstInfo -> InstInfo -> Ordering
- (InstInfo c1 _ _ _ _ _ _ _) `icmp` (InstInfo c2 _ _ _ _ _ _ _)
- = c1 `compare` c2
+ i_uniq :: InstInfo -> Unique
+ i_uniq (InstInfo c _ _ _ _ _ _ _) = getUnique c
- info_by_class = equivClasses icmp (bagToList info)
+ info_by_class = equivClassesByUniq i_uniq (bagToList info)
in
mapNF_Tc buildInstanceEnv info_by_class `thenNF_Tc` \ inst_env_entries ->
let
--- /dev/null
+_interface_ TcMatches 2
+_exports_
+TcMatches tcGRHSs tcMatchesFun;
+_declarations_
+2 tcGRHSs _:_ _forall_ [s] =>
+ RnHsSyn.RenamedGRHSs
+ -> TcMonad.TcType
+ -> HsExpr.StmtCtxt
+ -> TcMonad.TcM s (TcHsSyn.TcGRHSs, Inst.LIE) ;;
+3 tcMatchesFun _:_ _forall_ [s] =>
+ [(Name.Name,Var.Id)]
+ -> Name.Name
+ -> TcMonad.TcType
+ -> [RnHsSyn.RenamedMatch]
+ -> TcMonad.TcM s ([TcHsSyn.TcMatch], Inst.LIE) ;;
+
-%
+\%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[TcMatches]{Typecheck some @Matches@}
\begin{code}
-module TcMatches ( tcMatchesFun, tcMatchesCase, tcMatchExpected ) where
+module TcMatches ( tcMatchesFun, tcMatchesCase, tcMatchLambda, tcStmts, tcGRHSs ) where
#include "HsVersions.h"
-import {-# SOURCE #-} TcGRHSs ( tcGRHSsAndBinds )
+import {-# SOURCE #-} TcExpr( tcExpr )
-import HsSyn ( HsBinds(..), Match(..), GRHSsAndBinds(..),
- MonoBinds(..), StmtCtxt(..),
+import HsSyn ( HsBinds(..), Match(..), GRHSs(..), GRHS(..),
+ MonoBinds(..), StmtCtxt(..), Stmt(..),
pprMatch, getMatchLoc
)
-import RnHsSyn ( RenamedMatch )
-import TcHsSyn ( TcMatch )
+import RnHsSyn ( RenamedMatch, RenamedGRHSs, RenamedStmt )
+import TcHsSyn ( TcMatch, TcGRHSs, TcStmt )
import TcMonad
-import TcMonoType ( checkSigTyVars, noSigs, existentialPatCtxt )
-import Inst ( Inst, LIE, plusLIE, emptyLIE )
-import TcEnv ( tcExtendEnvWithPat, tcExtendGlobalTyVars )
-import TcPat ( tcPat )
-import TcType ( TcType, newTyVarTy )
+import TcMonoType ( checkSigTyVars, tcHsTyVar, tcHsType, noSigs, sigPatCtxt )
+import Inst ( Inst, LIE, plusLIE, emptyLIE, plusLIEs )
+import TcEnv ( tcExtendLocalValEnv, tcExtendGlobalTyVars, tcExtendTyVarEnv )
+import TcPat ( tcPat, polyPatSig )
+import TcType ( TcType, newTyVarTy, newTyVarTy_OpenKind )
+import TcBinds ( tcBindsAndThen )
import TcSimplify ( tcSimplifyAndCheck, bindInstsOfLocalFuns )
-import TcUnify ( unifyFunTy )
+import TcUnify ( unifyFunTy, unifyTauTy )
import Name ( Name )
+import TysWiredIn ( boolTy )
import BasicTypes ( RecFlag(..) )
-import Type ( Kind, tyVarsOfType, isTauTy, mkFunTy, openTypeKind )
+import Type ( Kind, tyVarsOfType, isTauTy, mkFunTy, boxedTypeKind )
import VarSet
+import Var ( Id )
import Util
import Bag
import Outputable
-import SrcLoc (SrcLoc)
+import List ( nub )
\end{code}
+%************************************************************************
+%* *
+\subsection{tcMatchesFun, tcMatchesCase}
+%* *
+%************************************************************************
+
@tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
@FunMonoBind@. The second argument is the name of the function, which
is used in error messages. It checks that all the equations have the
same number of arguments before using @tcMatches@ to do the work.
\begin{code}
-tcMatchesFun :: Name
- -> TcType s -- Expected type
+tcMatchesFun :: [(Name,Id)] -- Bindings for the variables bound in this group
+ -> Name
+ -> TcType -- Expected type
-> [RenamedMatch]
- -> TcM s ([TcMatch s], LIE s)
+ -> TcM s ([TcMatch], LIE)
-tcMatchesFun fun_name expected_ty matches@(first_match:_)
- = -- Set the location to that of the first equation, so that
+tcMatchesFun xve fun_name expected_ty matches@(first_match:_)
+ = -- Check that they all have the same no of arguments
+ -- Set the location to that of the first equation, so that
-- any inter-equation error messages get some vaguely
-- sensible location. Note: we have to do this odd
-- ann-grabbing, because we don't always have annotations in
-- hand when we call tcMatchesFun...
-
tcAddSrcLoc (getMatchLoc first_match) (
-
- -- Check that they all have the same no of arguments
- checkTc (all_same (noOfArgs matches))
- (varyingArgsErr fun_name matches) `thenTc_`
+ checkTc (sameNoOfArgs matches)
+ (varyingArgsErr fun_name matches)
+ ) `thenTc_`
-- ToDo: Don't use "expected" stuff if there ain't a type signature
-- because inconsistency between branches
-- may show up as something wrong with the (non-existent) type signature
-- No need to zonk expected_ty, because unifyFunTy does that on the fly
- tcMatchesExpected matches expected_ty (FunRhs fun_name)
-
- )
- where
- all_same :: [Int] -> Bool
- all_same [] = True -- Should never happen (ToDo: panic?)
- all_same [x] = True
- all_same (x:xs) = all ((==) x) xs
+ tcMatches xve matches expected_ty (FunRhs fun_name)
\end{code}
@tcMatchesCase@ doesn't do the argument-count check because the
parser guarantees that each equation has exactly one argument.
\begin{code}
-tcMatchesCase :: TcType s -- Type of whole case expressions
- -> [RenamedMatch] -- The case alternatives
- -> TcM s (TcType s, -- Inferred type of the scrutinee
- [TcMatch s], -- Translated alternatives
- LIE s)
-
-tcMatchesCase expr_ty matches
- = newTyVarTy openTypeKind `thenNF_Tc` \ scrut_ty ->
- tcMatchesExpected matches (mkFunTy scrut_ty expr_ty) CaseAlt `thenTc` \ (matches', lie) ->
+tcMatchesCase :: [RenamedMatch] -- The case alternatives
+ -> TcType -- Type of whole case expressions
+ -> TcM s (TcType, -- Inferred type of the scrutinee
+ [TcMatch], -- Translated alternatives
+ LIE)
+
+tcMatchesCase matches expr_ty
+ = newTyVarTy_OpenKind `thenNF_Tc` \ scrut_ty ->
+ tcMatches [] matches (mkFunTy scrut_ty expr_ty) CaseAlt `thenTc` \ (matches', lie) ->
returnTc (scrut_ty, matches', lie)
+
+tcMatchLambda :: RenamedMatch -> TcType -> TcM s (TcMatch, LIE)
+tcMatchLambda match res_ty = tcMatch [] match res_ty LambdaBody
\end{code}
\begin{code}
-tcMatchesExpected :: [RenamedMatch]
- -> TcType s
- -> StmtCtxt
- -> TcM s ([TcMatch s], LIE s)
-
-tcMatchesExpected [match] expected_ty fun_or_case
- = tcAddSrcLoc (getMatchLoc match) $
- tcAddErrCtxt (matchCtxt fun_or_case match) $
- tcMatchExpected match expected_ty fun_or_case `thenTc` \ (match', lie) ->
- returnTc ([match'], lie)
-
-tcMatchesExpected (match1 : matches) expected_ty fun_or_case
- = tcAddSrcLoc (getMatchLoc match1) (
- tcAddErrCtxt (matchCtxt fun_or_case match1) $
- tcMatchExpected match1 expected_ty fun_or_case
- ) `thenTc` \ (match1', lie1) ->
- tcMatchesExpected matches expected_ty fun_or_case `thenTc` \ (matches', lie2) ->
- returnTc (match1' : matches', plusLIE lie1 lie2)
+tcMatches :: [(Name,Id)]
+ -> [RenamedMatch]
+ -> TcType
+ -> StmtCtxt
+ -> TcM s ([TcMatch], LIE)
+
+tcMatches xve matches expected_ty fun_or_case
+ = mapAndUnzipTc tc_match matches `thenTc` \ (matches, lies) ->
+ returnTc (matches, plusLIEs lies)
+ where
+ tc_match match = tcMatch xve match expected_ty fun_or_case
\end{code}
+
+%************************************************************************
+%* *
+\subsection{tcMatch}
+%* *
+%************************************************************************
+
\begin{code}
-tcMatchExpected
- :: RenamedMatch
- -> TcType s -- Expected result-type of the Match.
+tcMatch :: [(Name,Id)]
+ -> RenamedMatch
+ -> TcType -- Expected result-type of the Match.
-- Early unification with this guy gives better error messages
-> StmtCtxt
- -> TcM s (TcMatch s,LIE s)
+ -> TcM s (TcMatch, LIE)
-tcMatchExpected match expected_ty ctxt
- = tcMatchExpected_help emptyBag emptyBag emptyLIE match expected_ty ctxt
+tcMatch xve1 match@(Match sig_tvs pats maybe_rhs_sig grhss) expected_ty ctxt
+ = tcAddSrcLoc (getMatchLoc match) $
+ tcAddErrCtxt (matchCtxt ctxt match) $
+ if null sig_tvs then -- The common case
+ tc_match expected_ty `thenTc` \ (_, match_and_lie) ->
+ returnTc match_and_lie
-tcMatchExpected_help bound_tvs bound_ids bound_lie
- the_match@(PatMatch pat match) expected_ty ctxt
- = unifyFunTy expected_ty `thenTc` \ (arg_ty, rest_ty) ->
+ else
+ -- If there are sig tve we must be careful *not* to use
+ -- expected_ty right away, else we'll unify with tyvars free
+ -- in the envt. So invent a fresh tyvar and use that instead
+ newTyVarTy_OpenKind `thenNF_Tc` \ tyvar_ty ->
- tcPat noSigs pat arg_ty `thenTc` \ (pat', pat_lie, pat_tvs, pat_ids, avail_lie) ->
+ -- Extend the tyvar env and check the match itself
+ mapNF_Tc tcHsTyVar sig_tvs `thenNF_Tc` \ sig_tyvars ->
+ tcExtendTyVarEnv sig_tyvars (
+ tc_match tyvar_ty
+ ) `thenTc` \ (pat_ids, match_and_lie) ->
- tcMatchExpected_help
- (bound_tvs `unionBags` pat_tvs)
- (bound_ids `unionBags` pat_ids)
- (bound_lie `plusLIE` avail_lie)
- match rest_ty ctxt `thenTc` \ (match', lie_match) ->
+ -- Check that the scoped type variables from the patterns
+ -- have not been constrained
+ tcAddErrCtxtM (sigPatCtxt sig_tyvars pat_ids) (
+ checkSigTyVars sig_tyvars
+ ) `thenTc_`
- returnTc (PatMatch pat' match', pat_lie `plusLIE` lie_match)
+ -- *Now* we're free to unify with expected_ty
+ unifyTauTy expected_ty tyvar_ty `thenTc_`
+ returnTc match_and_lie
-tcMatchExpected_help bound_tvs bound_ids bound_lie
- (GRHSMatch grhss_and_binds) expected_ty ctxt
- = -- Check that the remaining "expected type" is not a rank-2 type
+ where
+ tc_match expexted_ty -- Any sig tyvars are in scope by now
+ = -- STEP 1: Typecheck the patterns
+ tcMatchPats pats expected_ty `thenTc` \ (rhs_ty, pats', lie_req1, ex_tvs, pat_bndrs, lie_avail) ->
+ let
+ xve2 = bagToList pat_bndrs
+ pat_ids = map snd xve2
+ ex_tv_list = bagToList ex_tvs
+ in
+
+ -- STEP 2: Check that the remaining "expected type" is not a rank-2 type
-- If it is it'll mess up the unifier when checking the RHS
- checkTc (isTauTy expected_ty)
- lurkingRank2SigErr `thenTc_`
+ checkTc (isTauTy rhs_ty) lurkingRank2SigErr `thenTc_`
+
+ -- STEP 3: Unify with the rhs type signature if any
+ (case maybe_rhs_sig of
+ Nothing -> returnTc ()
+ Just sig -> tcHsType sig `thenTc` \ sig_ty ->
+
+ -- Check that the signature isn't a polymorphic one, which
+ -- we don't permit (at present, anyway)
+ checkTc (isTauTy sig_ty) (polyPatSig sig_ty) `thenTc_`
+ unifyTauTy rhs_ty sig_ty
+ ) `thenTc_`
+
+ -- STEP 4: Typecheck the guarded RHSs and the associated where clause
+ tcExtendLocalValEnv xve1 (tcExtendLocalValEnv xve2 (
+ tcGRHSs grhss rhs_ty ctxt
+ )) `thenTc` \ (grhss', lie_req2) ->
+
+ -- STEP 5: Check for existentially bound type variables
+ tcExtendGlobalTyVars (tyVarsOfType rhs_ty) (
+ tcAddErrCtxtM (sigPatCtxt ex_tv_list pat_ids) $
+ checkSigTyVars ex_tv_list `thenTc` \ zonked_ex_tvs ->
+ tcSimplifyAndCheck
+ (text ("the existential context of a data constructor"))
+ (mkVarSet zonked_ex_tvs)
+ lie_avail (lie_req1 `plusLIE` lie_req2)
+ ) `thenTc` \ (lie_req', ex_binds) ->
+
+ -- STEP 6 In case there are any polymorpic, overloaded binders in the pattern
+ -- (which can happen in the case of rank-2 type signatures, or data constructors
+ -- with polymorphic arguments), we must do a bindInstsOfLocalFns here
+ bindInstsOfLocalFuns lie_req' pat_ids `thenTc` \ (lie_req'', inst_binds) ->
- tcExtendEnvWithPat bound_ids (
- tcGRHSsAndBinds grhss_and_binds expected_ty ctxt
- ) `thenTc` \ (GRHSsAndBindsOut grhss binds ty, lie) ->
+ -- Phew! All done.
+ let
+ grhss'' = glue_on Recursive ex_binds $
+ glue_on Recursive inst_binds grhss'
+ in
+ returnTc (pat_ids, (Match [] pats' Nothing grhss', lie_req''))
+ -- glue_on just avoids stupid dross
+glue_on _ EmptyMonoBinds grhss = grhss -- The common case
+glue_on is_rec mbinds (GRHSs grhss binds ty)
+ = GRHSs grhss (MonoBind mbinds [] is_rec `ThenBinds` binds) ty
- -- Check for existentially bound type variables
- tcExtendGlobalTyVars (tyVarsOfType expected_ty) (
- tcAddErrCtxtM (existentialPatCtxt bound_tvs bound_ids) $
- checkSigTyVars (bagToList bound_tvs) `thenTc` \ zonked_pat_tvs ->
- tcSimplifyAndCheck
- (text ("the existential context of a data constructor"))
- (mkVarSet zonked_pat_tvs)
- bound_lie lie
- ) `thenTc` \ (ex_lie, ex_binds) ->
+tcGRHSs :: RenamedGRHSs
+ -> TcType -> StmtCtxt
+ -> TcM s (TcGRHSs, LIE)
- -- In case there are any polymorpic, overloaded binders in the pattern
- -- (which can happen in the case of rank-2 type signatures, or data constructors
- -- with polymorphic arguments), we must do a bindInstsOfLocalFns here
- bindInstsOfLocalFuns ex_lie bound_id_list `thenTc` \ (inst_lie, inst_binds) ->
+tcGRHSs (GRHSs grhss binds _) expected_ty ctxt
+ = tcBindsAndThen glue_on binds (tc_grhss grhss)
+ where
+ tc_grhss grhss
+ = mapAndUnzipTc tc_grhs grhss `thenTc` \ (grhss', lies) ->
+ returnTc (GRHSs grhss' EmptyBinds (Just expected_ty), plusLIEs lies)
+
+ tc_grhs (GRHS guarded locn)
+ = tcAddSrcLoc locn $
+ tcStmts ctxt (\ty -> ty) guarded expected_ty `thenTc` \ (guarded', lie) ->
+ returnTc (GRHS guarded' locn, lie)
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{tcMatchPats}
+%* *
+%************************************************************************
+
+\begin{code}
+tcMatchPats [] expected_ty
+ = returnTc (expected_ty, [], emptyLIE, emptyBag, emptyBag, emptyLIE)
+
+tcMatchPats (pat:pats) expected_ty
+ = unifyFunTy expected_ty `thenTc` \ (arg_ty, rest_ty) ->
+ tcPat noSigs pat arg_ty `thenTc` \ (pat', lie_req, pat_tvs, pat_ids, lie_avail) ->
+ tcMatchPats pats rest_ty `thenTc` \ (rhs_ty, pats', lie_reqs, pats_tvs, pats_ids, lie_avails) ->
+ returnTc ( rhs_ty,
+ pat':pats',
+ lie_req `plusLIE` lie_reqs,
+ pat_tvs `unionBags` pats_tvs,
+ pat_ids `unionBags` pats_ids,
+ lie_avail `plusLIE` lie_avails
+ )
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{tcStmts}
+%* *
+%************************************************************************
+
+\begin{code}
+tcStmts :: StmtCtxt
+ -> (TcType -> TcType) -- m, the relationship type of pat and rhs in pat <- rhs
+ -> [RenamedStmt]
+ -> TcType -- elt_ty, where type of the comprehension is (m elt_ty)
+ -> TcM s ([TcStmt], LIE)
+
+tcStmts do_or_lc m (stmt@(ReturnStmt exp) : stmts) elt_ty
+ = ASSERT( null stmts )
+ tcSetErrCtxt (stmtCtxt do_or_lc stmt) $
+ tcExpr exp elt_ty `thenTc` \ (exp', exp_lie) ->
+ returnTc ([ReturnStmt exp'], exp_lie)
+
+ -- ExprStmt at the end
+tcStmts do_or_lc m [stmt@(ExprStmt exp src_loc)] elt_ty
+ = tcSetErrCtxt (stmtCtxt do_or_lc stmt) $
+ tcExpr exp (m elt_ty) `thenTc` \ (exp', exp_lie) ->
+ returnTc ([ExprStmt exp' src_loc], exp_lie)
+
+ -- ExprStmt not at the end
+tcStmts do_or_lc m (stmt@(ExprStmt exp src_loc) : stmts) elt_ty
+ = ASSERT( isDoStmt do_or_lc )
+ tcAddSrcLoc src_loc (
+ tcSetErrCtxt (stmtCtxt do_or_lc stmt) $
+ -- exp has type (m tau) for some tau (doesn't matter what)
+ newTyVarTy_OpenKind `thenNF_Tc` \ any_ty ->
+ tcExpr exp (m any_ty)
+ ) `thenTc` \ (exp', exp_lie) ->
+ tcStmts do_or_lc m stmts elt_ty `thenTc` \ (stmts', stmts_lie) ->
+ returnTc (ExprStmt exp' src_loc : stmts',
+ exp_lie `plusLIE` stmts_lie)
+
+tcStmts do_or_lc m (stmt@(GuardStmt exp src_loc) : stmts) elt_ty
+ = ASSERT( not (isDoStmt do_or_lc) )
+ tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
+ tcAddSrcLoc src_loc $
+ tcExpr exp boolTy
+ ) `thenTc` \ (exp', exp_lie) ->
+ tcStmts do_or_lc m stmts elt_ty `thenTc` \ (stmts', stmts_lie) ->
+ returnTc (GuardStmt exp' src_loc : stmts',
+ exp_lie `plusLIE` stmts_lie)
+
+tcStmts do_or_lc m (stmt@(BindStmt pat exp src_loc) : stmts) elt_ty
+ = tcAddSrcLoc src_loc (
+ tcSetErrCtxt (stmtCtxt do_or_lc stmt) $
+ newTyVarTy boxedTypeKind `thenNF_Tc` \ pat_ty ->
+ tcPat noSigs pat pat_ty `thenTc` \ (pat', pat_lie, pat_tvs, pat_ids, avail) ->
+ tcExpr exp (m pat_ty) `thenTc` \ (exp', exp_lie) ->
+ returnTc (pat', exp',
+ pat_lie `plusLIE` exp_lie,
+ pat_tvs, pat_ids, avail)
+ ) `thenTc` \ (pat', exp', lie_req, pat_tvs, pat_bndrs, lie_avail) ->
let
- binds' = ex_binds `glue_on` (inst_binds `glue_on` binds)
+ new_val_env = bagToList pat_bndrs
+ pat_ids = map snd new_val_env
+ pat_tv_list = bagToList pat_tvs
in
- returnTc (GRHSMatch (GRHSsAndBindsOut grhss binds' ty), inst_lie)
- where
- bound_id_list = map snd (bagToList bound_ids)
- -- glue_on just avoids stupid dross
- glue_on EmptyMonoBinds binds = binds -- The common case
- glue_on mbinds binds = MonoBind mbinds [] Recursive `ThenBinds` binds
+ -- Do the rest; we don't need to add the pat_tvs to the envt
+ -- because they all appear in the pat_ids's types
+ tcExtendLocalValEnv new_val_env (
+ tcStmts do_or_lc m stmts elt_ty
+ ) `thenTc` \ (stmts', stmts_lie) ->
+
+
+ -- Reinstate context for existential checks
+ tcSetErrCtxt (stmtCtxt do_or_lc stmt) $
+ tcExtendGlobalTyVars (tyVarsOfType (m elt_ty)) $
+ tcAddErrCtxtM (sigPatCtxt pat_tv_list pat_ids) $
+
+ checkSigTyVars pat_tv_list `thenTc` \ zonked_pat_tvs ->
+
+ tcSimplifyAndCheck
+ (text ("the existential context of a data constructor"))
+ (mkVarSet zonked_pat_tvs)
+ lie_avail stmts_lie `thenTc` \ (final_lie, dict_binds) ->
+
+ returnTc (BindStmt pat' exp' src_loc :
+ LetStmt (MonoBind dict_binds [] Recursive) :
+ stmts',
+ lie_req `plusLIE` final_lie)
+
+tcStmts do_or_lc m (LetStmt binds : stmts) elt_ty
+ = tcBindsAndThen -- No error context, but a binding group is
+ combine -- rather a large thing for an error context anyway
+ binds
+ (tcStmts do_or_lc m stmts elt_ty)
+ where
+ combine is_rec binds' stmts' = LetStmt (MonoBind binds' [] is_rec) : stmts'
+
+
+isDoStmt DoStmt = True
+isDoStmt other = False
\end{code}
-@noOfArgs@ takes a @[RenamedMatch]@ and returns a list telling how
-many arguments were used in each of the equations. This is used to
-report a sensible error message when different equations have
-different numbers of arguments.
+%************************************************************************
+%* *
+\subsection{Errors and contexts}
+%* *
+%************************************************************************
-\begin{code}
-noOfArgs :: [RenamedMatch] -> [Int]
+@sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
+number of args are used in each equation.
-noOfArgs ms = map args_in_match ms
+\begin{code}
+sameNoOfArgs :: [RenamedMatch] -> Bool
+sameNoOfArgs matches = length (nub (map args_in_match matches)) == 1
where
args_in_match :: RenamedMatch -> Int
- args_in_match (GRHSMatch _) = 0
- args_in_match (PatMatch _ match) = 1 + args_in_match match
+ args_in_match (Match _ pats _ _) = length pats
\end{code}
-Errors and contexts
-~~~~~~~~~~~~~~~~~~~
\begin{code}
matchCtxt CaseAlt match
= hang (ptext SLIT("In a \"case\" branch:"))
- 4 (pprMatch True{-is_case-} match)
+ 4 (pprMatch (True,empty) {-is_case-} match)
matchCtxt (FunRhs fun) match
- = hang (hcat [ptext SLIT("In an equation for function "), quotes (ppr fun), char ':'])
- 4 (hcat [ppr fun, space, pprMatch False{-not case-} match])
-\end{code}
+ = hang (hcat [ptext SLIT("In an equation for function "), quotes (ppr_fun), char ':'])
+ 4 (pprMatch (False, ppr_fun) {-not case-} match)
+ where
+ ppr_fun = ppr fun
+matchCtxt LambdaBody match
+ = hang (ptext SLIT("In the lambda expression"))
+ 4 (pprMatch (True, empty) match)
-\begin{code}
varyingArgsErr name matches
= sep [ptext SLIT("Varying number of arguments for function"), quotes (ppr name)]
lurkingRank2SigErr
= ptext SLIT("Too few explicit arguments when defining a function with a rank-2 type")
+
+stmtCtxt do_or_lc stmt
+ = hang (ptext SLIT("In") <+> what <> colon)
+ 4 (ppr stmt)
+ where
+ what = case do_or_lc of
+ ListComp -> ptext SLIT("a list-comprehension qualifier")
+ DoStmt -> ptext SLIT("a do statement:")
+ PatBindRhs -> thing <+> ptext SLIT("a pattern binding")
+ FunRhs f -> thing <+> ptext SLIT("an equation for") <+> quotes (ppr f)
+ CaseAlt -> thing <+> ptext SLIT("a case alternative")
+ LambdaBody -> thing <+> ptext SLIT("a lambda abstraction")
+ thing = case stmt of
+ BindStmt _ _ _ -> ptext SLIT("a pattern guard for")
+ GuardStmt _ _ -> ptext SLIT("a guard for")
+ ExprStmt _ _ -> ptext SLIT("the right-hand side of")
\end{code}
\begin{code}
module TcModule (
typecheckModule,
- TcResults,
- TcDDumpDeriv
+ TcResults
) where
#include "HsVersions.h"
-import CmdLineOpts ( opt_D_dump_tc, opt_D_dump_deriv )
+import CmdLineOpts ( opt_D_dump_tc )
import HsSyn ( HsModule(..), HsBinds(..), MonoBinds(..), HsDecl(..) )
import RnHsSyn ( RenamedHsModule )
import TcHsSyn ( TcMonoBinds, TypecheckedMonoBinds, zonkTopBinds,
import TcBinds ( tcTopBindsAndThen )
import TcClassDcl ( tcClassDecls2 )
import TcDefaults ( tcDefaults )
-import TcEnv ( TcIdOcc(..), tcExtendGlobalValEnv, tcExtendTyConEnv,
- getEnv_TyCons, getEnv_Classes, tcLookupLocalValue,
- lookupGlobalByKey, tcSetGlobalValEnv,
- tcLookupTyCon, initEnv, GlobalValueEnv
+import TcEnv ( tcExtendGlobalValEnv, tcExtendTypeEnv,
+ getEnvTyCons, getEnvClasses, tcLookupValueMaybe,
+ explicitLookupValueByKey, tcSetValueEnv,
+ tcLookupTyCon, initEnv,
+ ValueEnv, TcTyThing(..)
)
import TcExpr ( tcId )
import TcForeign ( tcForeignImports, tcForeignExports )
import TcInstDcls ( tcInstDecls1, tcInstDecls2 )
import TcInstUtil ( buildInstanceEnvs, classDataCon, InstInfo )
import TcSimplify ( tcSimplifyTop )
-import TcTyClsDecls ( tcTyAndClassDecls1 )
+import TcTyClsDecls ( tcTyAndClassDecls )
import TcTyDecls ( mkDataBinds )
import TcType ( TcType, typeToTcType,
TcKind, kindToTcKind
[TyCon], [Class],
Bag InstInfo, -- Instance declaration information
[TypecheckedForeignDecl], -- foreign import & exports.
- TcDDumpDeriv,
- GlobalValueEnv,
+ ValueEnv,
[Id] -- The thin-air Ids
)
-type TcDDumpDeriv = SDoc
-
---------------
typecheckModule
:: UniqSupply
-> IO (Maybe TcResults)
typecheckModule us rn_name_supply mod
- = let
- (maybe_result, warns, errs) =
- initTc us initEnv (tcModule rn_name_supply mod)
- in
+ = initTc us initEnv (tcModule rn_name_supply mod) >>= \ (maybe_result, warns, errs) ->
+
print_errs warns >>
print_errs errs >>
- dumpIfSet opt_D_dump_tc "Typechecked"
- (case maybe_result of
- Just (binds, _, _, _, _, _, _, _) -> ppr binds
- Nothing -> text "Typecheck failed") >>
-
- dumpIfSet opt_D_dump_deriv "Derived instances"
- (case maybe_result of
- Just (_, _, _, _, _, dump_deriv, _, _) -> dump_deriv
- Nothing -> empty) >>
-
-- write the thin-air Id map
(case maybe_result of
- Just (_, _, _, _, _, _, _, thin_air_ids) -> setThinAirIds thin_air_ids
- Nothing -> return ()
+ Just (_, _, _, _, _, _, thin_air_ids) -> setThinAirIds thin_air_ids
+ Nothing -> return ()
) >>
+ dumpIfSet opt_D_dump_tc "Typechecked"
+ (case maybe_result of
+ Just (binds, _, _, _, _, _, _) -> ppr binds
+ Nothing -> text "Typecheck failed") >>
+
return (if isEmptyBag errs then
maybe_result
else
-> TcM s TcResults -- output
tcModule rn_name_supply
- (HsModule mod_name verion exports imports fixities decls src_loc)
+ (HsModule mod_name verion exports imports decls src_loc)
= tcAddSrcLoc src_loc $ -- record where we're starting
fixTc (\ ~(unf_env ,_) ->
-- The knot for instance information. This isn't used at all
-- till we type-check value declarations
- fixTc ( \ ~(rec_inst_mapper, _, _, _, _) ->
+ fixTc ( \ ~(rec_inst_mapper, _, _, _) ->
-- Type-check the type and class decls
- -- trace "tcTyAndClassDecls:" $
- tcTyAndClassDecls1 unf_env rec_inst_mapper decls `thenTc` \ env ->
+ tcTyAndClassDecls unf_env rec_inst_mapper decls `thenTc` \ env ->
- -- trace "tc3" $
-- Typecheck the instance decls, includes deriving
tcSetEnv env (
- -- trace "tcInstDecls:" $
tcInstDecls1 unf_env decls mod_name rn_name_supply
- ) `thenTc` \ (inst_info, deriv_binds, ddump_deriv) ->
+ ) `thenTc` \ (inst_info, deriv_binds) ->
- -- trace "tc4" $
buildInstanceEnvs inst_info `thenNF_Tc` \ inst_mapper ->
- returnTc (inst_mapper, env, inst_info, deriv_binds, ddump_deriv)
+ returnTc (inst_mapper, env, inst_info, deriv_binds)
-- End of inner fix loop
- ) `thenTc` \ (_, env, inst_info, deriv_binds, ddump_deriv) ->
+ ) `thenTc` \ (_, env, inst_info, deriv_binds) ->
- -- trace "tc5" $
- tcSetEnv env $
+ tcSetEnv env (
-- Default declarations
tcDefaults decls `thenTc` \ defaulting_tys ->
-- they are always fully applied, and the bindings are just there
-- to support partial applications
let
- tycons = getEnv_TyCons env
- classes = getEnv_Classes env
+ tycons = getEnvTyCons env
+ classes = getEnvClasses env
local_tycons = filter isLocallyDefined tycons
local_classes = filter isLocallyDefined classes
in
-- (a) constructors
-- (b) record selectors
-- (c) class op selectors
- -- (d) default-method ids
+ -- (d) default-method ids... where? I can't see where these are
+ -- put into the envt, and I'm worried that the zonking phase
+ -- will find they aren't there and complain.
tcExtendGlobalValEnv data_ids $
tcExtendGlobalValEnv (concat (map classSelIds classes)) $
-- corresponding data cons.
-- They are mentioned in types in interface files.
tcExtendGlobalValEnv (map (dataConId . classDataCon) classes) $
- tcExtendTyConEnv [ (getName tycon, (kindToTcKind (tyConKind tycon), Nothing, tycon))
- | clas <- classes,
- let tycon = classTyCon clas
- ] $
+ 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
-- Value declarations next.
-- We also typecheck any extra binds that came out of the "deriving" process
--- trace "tc6" $
tcTopBindsAndThen
(\ is_rec binds1 (binds2, thing) -> (binds1 `AndMonoBinds` binds2, thing))
(get_val_decls decls `ThenBinds` deriv_binds)
- ( tcGetEnv `thenNF_Tc` \ env ->
--- tcGetUnique `thenNF_Tc` \ uniq ->
--- pprTrace "tc7" (ppr uniq) $
+ ( tcGetEnv `thenNF_Tc` \ env ->
+ tcGetUnique `thenNF_Tc` \ uniq ->
returnTc ((EmptyMonoBinds, env), emptyLIE)
) `thenTc` \ ((val_binds, final_env), lie_valdecls) ->
tcSetEnv final_env $
-- Second pass over class and instance declarations,
-- to compile the bindings themselves.
--- pprTrace "tc8" emtpy $
tcInstDecls2 inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
tcClassDecls2 decls `thenNF_Tc` \ (lie_clasdecls, cls_binds) ->
foe_binds
in
zonkTopBinds all_binds `thenNF_Tc` \ (all_binds', really_final_env) ->
- tcSetGlobalValEnv really_final_env $
+ tcSetValueEnv really_final_env $
zonkForeignExports foe_decls `thenNF_Tc` \ foe_decls' ->
let
- thin_air_ids = map (lookupGlobalByKey really_final_env . nameUnique) thinAirIdNames
+ 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
returnTc (really_final_env,
(all_binds', local_tycons, local_classes, inst_info,
foi_decls ++ foe_decls',
- ddump_deriv, really_final_env, thin_air_ids))
+ really_final_env,
+ thin_air_ids))
+ )
-- End of outer fix loop
) `thenTc` \ (final_env, stuff) ->
| otherwise
= -- Check that main is defined
- tcLookupTyCon ioTyCon_NAME `thenTc` \ (_,_,ioTyCon) ->
- tcLookupLocalValue main_NAME `thenNF_Tc` \ maybe_main_id ->
+ tcLookupTyCon ioTyCon_NAME `thenTc` \ ioTyCon ->
+ tcLookupValueMaybe main_NAME `thenNF_Tc` \ maybe_main_id ->
case maybe_main_id of {
Nothing -> failWithTc noMainErr ;
Just main_id ->
= hsep [ptext SLIT("Module"), quotes (pprModule mAIN),
ptext SLIT("must include a definition for"), quotes (ppr main_NAME)]
-mainTyMisMatch :: TcType s -> TcType s -> ErrMsg
+mainTyMisMatch :: TcType -> TcType -> ErrMsg
mainTyMisMatch expected actual
= hang (hsep [ppr main_NAME, ptext SLIT("has the wrong type")])
4 (vcat [
\begin{code}
module TcMonad(
- TcType, TcMaybe(..), TcBox,
+ TcType,
TcTauType, TcThetaType, TcRhoType,
TcTyVar, TcTyVarSet,
TcKind,
TcM, NF_TcM, TcDown, TcEnv,
- SST_R, FSST_R,
initTc,
returnTc, thenTc, thenTc_, mapTc, listTc,
foldrTc, foldlTc, mapAndUnzipTc, mapAndUnzip3Tc,
- mapBagTc, fixTc, tryTc, getErrsTc,
+ mapBagTc, fixTc, tryTc, tryTc_, getErrsTc,
+ traceTc, ioToTc,
uniqSMToTcM,
tcAddErrCtxt, tcSetErrCtxt,
tcNewMutVar, tcReadMutVar, tcWriteMutVar, TcRef,
+ tcNewMutTyVar, tcReadMutTyVar, tcWriteMutTyVar,
- TcError, TcWarning, TidyTypeEnv, emptyTidyEnv,
+ TcError, TcWarning, TidyEnv, emptyTidyEnv,
arityErr
) where
import {-# SOURCE #-} TcEnv ( TcEnv )
-import Type ( Type, GenType )
+import Type ( Type, Kind, ThetaType, RhoType, TauType,
+ )
import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, ErrMsg, Message, WarnMsg )
import CmdLineOpts ( opt_PprStyle_Debug )
-import SST
import Bag ( Bag, emptyBag, isEmptyBag,
foldBag, unitBag, unionBags, snocBag )
import Class ( Class )
-import Var ( GenTyVar )
-import VarEnv ( TyVarEnv, emptyVarEnv )
-import VarSet ( GenTyVarSet )
+import Name ( Name )
+import Var ( TyVar, newMutTyVar, readMutTyVar, writeMutTyVar )
+import VarEnv ( TyVarEnv, emptyVarEnv, TidyEnv, emptyTidyEnv )
+import VarSet ( TyVarSet )
import UniqSupply ( UniqSupply, uniqFromSupply, uniqsFromSupply, splitUniqSupply,
UniqSM, initUs )
import SrcLoc ( SrcLoc, noSrcLoc )
import FiniteMap ( FiniteMap, emptyFM )
import UniqFM ( UniqFM, emptyUFM )
import Unique ( Unique )
+import BasicTypes ( Unused )
import Util
import Outputable
+import FastString ( FastString )
-import GlaExts ( State#, RealWorld )
+import IOExts ( IORef, newIORef, readIORef, writeIORef,
+ unsafeInterleaveIO, fixIO
+ )
infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenNF_Tc_`
Types
~~~~~
\begin{code}
-type TcType s = GenType (TcBox s) -- Used during typechecker
+type TcTyVar = TyVar -- Might be a mutable tyvar
+type TcTyVarSet = TyVarSet
+
+type TcType = Type -- A TcType can have mutable type variables
-- Invariant on ForAllTy in TcTypes:
-- forall a. T
-- a cannot occur inside a MutTyVar in T; that is,
-- T is "flattened" before quantifying over a
-type TcKind s = TcType s
-
-type TcThetaType s = [(Class, [TcType s])]
-type TcRhoType s = TcType s -- No ForAllTys
-type TcTauType s = TcType s -- No DictTys or ForAllTys
-
-type TcBox s = TcRef s (TcMaybe s)
-
-data TcMaybe s = UnBound
- | BoundTo (TcType s)
-
--- Interestingly, you can't use (Maybe (TcType s)) instead of (TcMaybe s),
--- because you get a synonym loop if you do!
-
-type TcTyVar s = GenTyVar (TcBox s)
-type TcTyVarSet s = GenTyVarSet (TcBox s)
+type TcThetaType = ThetaType
+type TcRhoType = RhoType
+type TcTauType = TauType
+type TcKind = TcType
\end{code}
%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
-type NF_TcM s r = TcDown s -> TcEnv s -> SST s r
-type TcM s r = TcDown s -> TcEnv s -> FSST s r ()
+type NF_TcM s r = TcDown -> TcEnv -> IO r -- Can't raise UserError
+type TcM s r = TcDown -> TcEnv -> IO r -- Can raise UserError
+ -- ToDo: nuke the 's' part
+ -- The difference between the two is
+ -- now for documentation purposes only
+
+type Either_TcM s r = TcDown -> TcEnv -> IO r -- Either NF_TcM or TcM
+ -- Used only in this file for type signatures which
+ -- have a part that's polymorphic in whether it's NF_TcM or TcM
+ -- E.g. thenNF_Tc
+
+type TcRef a = IORef a
\end{code}
\begin{code}
--- With a builtin polymorphic type for runSST the type for
--- initTc should use TcM s r instead of TcM RealWorld r
-
-- initEnv is passed in to avoid module recursion between TcEnv & TcMonad.
initTc :: UniqSupply
- -> (TcRef RealWorld (UniqFM a) -> TcEnv RealWorld)
- -> TcM RealWorld r
- -> (Maybe r, Bag WarnMsg, Bag ErrMsg)
+ -> (TcRef (UniqFM a) -> TcEnv)
+ -> TcM s r
+ -> IO (Maybe r, Bag WarnMsg, Bag ErrMsg)
initTc us initenv do_this
- = runSST (
- newMutVarSST us `thenSST` \ us_var ->
- newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var ->
- newMutVarSST emptyUFM `thenSST` \ tvs_var ->
+ = do {
+ us_var <- newIORef us ;
+ errs_var <- newIORef (emptyBag,emptyBag) ;
+ tvs_var <- newIORef emptyUFM ;
+
let
init_down = TcDown [] us_var
noSrcLoc
[] errs_var
init_env = initenv tvs_var
- in
- recoverSST
- (\_ -> returnSST Nothing)
- (do_this init_down init_env `thenFSST` \ res ->
- returnFSST (Just res))
- `thenSST` \ maybe_res ->
- readMutVarSST errs_var `thenSST` \ (warns,errs) ->
- returnSST (maybe_res, warns, errs)
- )
-
-thenNF_Tc :: NF_TcM s a
- -> (a -> TcDown s -> TcEnv s -> State# s -> b)
- -> TcDown s -> TcEnv s -> State# s -> b
--- thenNF_Tc :: NF_TcM s a -> (a -> NF_TcM s b) -> NF_TcM s b
--- thenNF_Tc :: NF_TcM s a -> (a -> TcM s b) -> TcM s b
-
-thenNF_Tc m k down env
- = m down env `thenSST` \ r ->
- k r down env
-
-thenNF_Tc_ :: NF_TcM s a
- -> (TcDown s -> TcEnv s -> State# s -> b)
- -> TcDown s -> TcEnv s -> State# s -> b
--- thenNF_Tc :: NF_TcM s a -> NF_TcM s b -> NF_TcM s b
--- thenNF_Tc :: NF_TcM s a -> TcM s b -> TcM s b
-
-thenNF_Tc_ m k down env
- = m down env `thenSST_` k down env
-
-returnNF_Tc :: a -> NF_TcM s a
-returnNF_Tc v down env = returnSST v
+ ;
-fixNF_Tc :: (a -> NF_TcM s a) -> NF_TcM s a
-fixNF_Tc m env down = fixSST (\ loop -> m loop env down)
+ maybe_res <- catch (do { res <- do_this init_down init_env ;
+ return (Just res)})
+ (\_ -> return Nothing) ;
+
+ (warns,errs) <- readIORef errs_var ;
+ return (maybe_res, warns, errs)
+ }
-mapNF_Tc :: (a -> NF_TcM s b) -> [a] -> NF_TcM s [b]
-mapNF_Tc f [] = returnNF_Tc []
-mapNF_Tc f (x:xs) = f x `thenNF_Tc` \ r ->
- mapNF_Tc f xs `thenNF_Tc` \ rs ->
- returnNF_Tc (r:rs)
+-- Monadic operations
-foldrNF_Tc :: (a -> b -> NF_TcM s b) -> b -> [a] -> NF_TcM s b
-foldrNF_Tc k z [] = returnNF_Tc z
-foldrNF_Tc k z (x:xs) = foldrNF_Tc k z xs `thenNF_Tc` \r ->
- k x r
-
-foldlNF_Tc :: (a -> b -> NF_TcM s a) -> a -> [b] -> NF_TcM s a
-foldlNF_Tc k z [] = returnNF_Tc z
-foldlNF_Tc k z (x:xs) = k z x `thenNF_Tc` \r ->
- foldlNF_Tc k r xs
-
-listNF_Tc :: [NF_TcM s a] -> NF_TcM s [a]
-listNF_Tc [] = returnNF_Tc []
-listNF_Tc (x:xs) = x `thenNF_Tc` \ r ->
- listNF_Tc xs `thenNF_Tc` \ rs ->
- returnNF_Tc (r:rs)
-
-mapBagNF_Tc :: (a -> NF_TcM s b) -> Bag a -> NF_TcM s (Bag b)
-mapBagNF_Tc f bag
- = foldBag (\ b1 b2 -> b1 `thenNF_Tc` \ r1 ->
- b2 `thenNF_Tc` \ r2 ->
- returnNF_Tc (unionBags r1 r2))
- (\ a -> f a `thenNF_Tc` \ r -> returnNF_Tc (unitBag r))
- (returnNF_Tc emptyBag)
- bag
-
-mapAndUnzipNF_Tc :: (a -> NF_TcM s (b,c)) -> [a] -> NF_TcM s ([b],[c])
-mapAndUnzipNF_Tc f [] = returnNF_Tc ([],[])
-mapAndUnzipNF_Tc f (x:xs) = f x `thenNF_Tc` \ (r1,r2) ->
- mapAndUnzipNF_Tc f xs `thenNF_Tc` \ (rs1,rs2) ->
- returnNF_Tc (r1:rs1, r2:rs2)
+returnNF_Tc :: a -> NF_TcM s a
+returnTc :: a -> TcM s a
+returnTc v down env = return v
-thenTc :: TcM s a -> (a -> TcM s b) -> TcM s b
-thenTc m k down env
- = m down env `thenFSST` \ r ->
- k r down env
+thenTc :: TcM s a -> (a -> TcM s b) -> TcM s b
+thenNF_Tc :: NF_TcM s a -> (a -> Either_TcM s b) -> Either_TcM s b
+thenTc m k down env = do { r <- m down env; k r down env }
-thenTc_ :: TcM s a -> TcM s b -> TcM s b
-thenTc_ m k down env
- = m down env `thenFSST_` k down env
+thenTc_ :: TcM s a -> TcM s b -> TcM s b
+thenNF_Tc_ :: NF_TcM s a -> Either_TcM s b -> Either_TcM s b
+thenTc_ m k down env = do { m down env; k down env }
-returnTc :: a -> TcM s a
-returnTc val down env = returnFSST val
+listTc :: [TcM s a] -> TcM s [a]
+listNF_Tc :: [NF_TcM s a] -> NF_TcM s [a]
+listTc [] = returnTc []
+listTc (x:xs) = x `thenTc` \ r ->
+ listTc xs `thenTc` \ rs ->
+ returnTc (r:rs)
-mapTc :: (a -> TcM s b) -> [a] -> TcM s [b]
+mapTc :: (a -> TcM s b) -> [a] -> TcM s [b]
+mapNF_Tc :: (a -> NF_TcM s b) -> [a] -> NF_TcM s [b]
mapTc f [] = returnTc []
mapTc f (x:xs) = f x `thenTc` \ r ->
mapTc f xs `thenTc` \ rs ->
returnTc (r:rs)
-listTc :: [TcM s a] -> TcM s [a]
-listTc [] = returnTc []
-listTc (x:xs) = x `thenTc` \ r ->
- listTc xs `thenTc` \ rs ->
- returnTc (r:rs)
-
-foldrTc :: (a -> b -> TcM s b) -> b -> [a] -> TcM s b
+foldrTc :: (a -> b -> TcM s b) -> b -> [a] -> TcM s b
+foldrNF_Tc :: (a -> b -> NF_TcM s b) -> b -> [a] -> NF_TcM s b
foldrTc k z [] = returnTc z
foldrTc k z (x:xs) = foldrTc k z xs `thenTc` \r ->
k x r
-foldlTc :: (a -> b -> TcM s a) -> a -> [b] -> TcM s a
+foldlTc :: (a -> b -> TcM s a) -> a -> [b] -> TcM s a
+foldlNF_Tc :: (a -> b -> NF_TcM s a) -> a -> [b] -> NF_TcM s a
foldlTc k z [] = returnTc z
foldlTc k z (x:xs) = k z x `thenTc` \r ->
foldlTc k r xs
-mapAndUnzipTc :: (a -> TcM s (b,c)) -> [a] -> TcM s ([b],[c])
+mapAndUnzipTc :: (a -> TcM s (b,c)) -> [a] -> TcM s ([b],[c])
+mapAndUnzipNF_Tc :: (a -> NF_TcM s (b,c)) -> [a] -> NF_TcM s ([b],[c])
mapAndUnzipTc f [] = returnTc ([],[])
mapAndUnzipTc f (x:xs) = f x `thenTc` \ (r1,r2) ->
mapAndUnzipTc f xs `thenTc` \ (rs1,rs2) ->
mapAndUnzip3Tc f xs `thenTc` \ (rs1,rs2,rs3) ->
returnTc (r1:rs1, r2:rs2, r3:rs3)
-mapBagTc :: (a -> TcM s b) -> Bag a -> TcM s (Bag b)
+mapBagTc :: (a -> TcM s b) -> Bag a -> TcM s (Bag b)
+mapBagNF_Tc :: (a -> NF_TcM s b) -> Bag a -> NF_TcM s (Bag b)
mapBagTc f bag
= foldBag (\ b1 b2 -> b1 `thenTc` \ r1 ->
b2 `thenTc` \ r2 ->
(returnTc emptyBag)
bag
-fixTc :: (a -> TcM s a) -> TcM s a
-fixTc m env down = fixFSST (\ loop -> m loop env down)
+fixTc :: (a -> TcM s a) -> TcM s a
+fixNF_Tc :: (a -> NF_TcM s a) -> NF_TcM s a
+fixTc m env down = fixIO (\ loop -> m loop env down)
+
+recoverTc :: TcM s r -> TcM s r -> TcM s r
+recoverNF_Tc :: NF_TcM s r -> TcM s r -> NF_TcM s r
+recoverTc recover m down env
+ = catch (m down env) (\ _ -> recover down env)
+
+returnNF_Tc = returnTc
+thenNF_Tc = thenTc
+thenNF_Tc_ = thenTc_
+fixNF_Tc = fixTc
+recoverNF_Tc = recoverTc
+mapNF_Tc = mapTc
+foldrNF_Tc = foldrTc
+foldlNF_Tc = foldlTc
+listNF_Tc = listTc
+mapAndUnzipNF_Tc = mapAndUnzipTc
+mapBagNF_Tc = mapBagTc
\end{code}
@forkNF_Tc@ runs a sub-typecheck action *lazily* in a separate state
thread. Ideally, this elegantly ensures that it can't zap any type
variables that belong to the main thread. But alas, the environment
-contains TyCon and Class environments that include (TcKind s) stuff,
+contains TyCon and Class environments that include TcKind stuff,
which is a Royal Pain. By the time this fork stuff is used they'll
have been unified down so there won't be any kind variables, but we
can't express that in the current typechecker framework.
\begin{code}
forkNF_Tc :: NF_TcM s r -> NF_TcM s r
forkNF_Tc m (TcDown deflts u_var src_loc err_cxt err_var) env
- = -- Get a fresh unique supply
- readMutVarSST u_var `thenSST` \ us ->
- let
- (us1, us2) = splitUniqSupply us
- in
- writeMutVarSST u_var us1 `thenSST_`
+ = do
+ -- Get a fresh unique supply
+ us <- readIORef u_var
+ let (us1, us2) = splitUniqSupply us
+ writeIORef u_var us1
- unsafeInterleaveSST (
- newMutVarSST us2 `thenSST` \ us_var' ->
- newMutVarSST (emptyBag,emptyBag) `thenSST` \ err_var' ->
- newMutVarSST emptyUFM `thenSST` \ tv_var' ->
- let
- down' = TcDown deflts us_var' src_loc err_cxt err_var'
- in
- m down' env
- -- ToDo: optionally dump any error messages
- )
+ unsafeInterleaveIO (do {
+ us_var' <- newIORef us2 ;
+ err_var' <- newIORef (emptyBag,emptyBag) ;
+ tv_var' <- newIORef emptyUFM ;
+ let { down' = TcDown deflts us_var' src_loc err_cxt err_var' } ;
+ m down' env
+ -- ToDo: optionally dump any error messages
+ })
+\end{code}
+
+\begin{code}
+traceTc :: SDoc -> NF_TcM s ()
+traceTc doc down env = printErrs doc
+
+ioToTc :: IO a -> NF_TcM s a
+ioToTc io down env = io
\end{code}
-Error handling
-~~~~~~~~~~~~~~
+%************************************************************************
+%* *
+\subsection{Error handling}
+%* *
+%************************************************************************
+
\begin{code}
-getErrsTc :: NF_TcM s (Bag ErrMsg, Bag WarnMsg)
+getErrsTc :: NF_TcM s (Bag WarnMsg, Bag ErrMsg)
getErrsTc down env
- = readMutVarSST errs_var
- where
- errs_var = getTcErrs down
-
+ = readIORef (getTcErrs down)
failTc :: TcM s a
-failTc down env
- = failFSST ()
+failTc down env = give_up
+
+give_up :: IO a
+give_up = fail (userError "Typecheck failed")
failWithTc :: Message -> TcM s a -- Add an error message and fail
failWithTc err_msg = failWithTcM (emptyTidyEnv, err_msg)
addErrTc :: Message -> NF_TcM s ()
addErrTc err_msg = addErrTcM (emptyTidyEnv, err_msg)
--- The 'M' variants do the TidyTypeEnv bit
-failWithTcM :: (TidyTypeEnv s, Message) -> TcM s a -- Add an error message and fail
+-- The 'M' variants do the TidyEnv bit
+failWithTcM :: (TidyEnv, Message) -> TcM s a -- Add an error message and fail
failWithTcM env_and_msg
= addErrTcM env_and_msg `thenNF_Tc_`
failTc
-addErrTcM :: (TidyTypeEnv s, Message) -> NF_TcM s () -- Add an error message but don't fail
+checkTc :: Bool -> Message -> TcM s () -- Check that the boolean is true
+checkTc True err = returnTc ()
+checkTc False err = failWithTc err
+
+checkTcM :: Bool -> TcM s () -> TcM s () -- Check that the boolean is true
+checkTcM True err = returnTc ()
+checkTcM False err = err
+
+checkMaybeTc :: Maybe val -> Message -> TcM s val
+checkMaybeTc (Just val) err = returnTc val
+checkMaybeTc Nothing err = failWithTc err
+
+checkMaybeTcM :: Maybe val -> TcM s val -> TcM s val
+checkMaybeTcM (Just val) err = returnTc val
+checkMaybeTcM Nothing err = err
+
+addErrTcM :: (TidyEnv, Message) -> NF_TcM s () -- Add an error message but don't fail
addErrTcM (tidy_env, err_msg) down env
- = readMutVarSST errs_var `thenSST` \ (warns,errs) ->
- do_ctxt tidy_env ctxt down env `thenSST` \ ctxt_msgs ->
- let
- err = addShortErrLocLine loc $
- vcat (err_msg : ctxt_to_use ctxt_msgs)
- in
- writeMutVarSST errs_var (warns, errs `snocBag` err) `thenSST_`
- returnSST ()
+ = do
+ (warns, errs) <- readIORef errs_var
+ ctxt_msgs <- do_ctxt tidy_env ctxt down env
+ let err = addShortErrLocLine loc $
+ vcat (err_msg : ctxt_to_use ctxt_msgs)
+ writeIORef errs_var (warns, errs `snocBag` err)
where
errs_var = getTcErrs down
ctxt = getErrCtxt down
loc = getLoc down
do_ctxt tidy_env [] down env
- = returnSST []
+ = return []
do_ctxt tidy_env (c:cs) down env
- = c tidy_env down env `thenSST` \ (tidy_env', m) ->
- do_ctxt tidy_env' cs down env `thenSST` \ ms ->
- returnSST (m:ms)
+ = do
+ (tidy_env', m) <- c tidy_env down env
+ ms <- do_ctxt tidy_env' cs down env
+ return (m:ms)
-- warnings don't have an 'M' variant
warnTc :: Bool -> Message -> NF_TcM s ()
warnTc warn_if_true warn_msg down env
- = if warn_if_true then
- readMutVarSST errs_var `thenSST` \ (warns,errs) ->
- do_ctxt emptyTidyEnv ctxt down env `thenSST` \ ctxt_msgs ->
- let
- warn = addShortWarnLocLine loc $
+ | warn_if_true
+ = do
+ (warns,errs) <- readIORef errs_var
+ ctxt_msgs <- do_ctxt emptyTidyEnv ctxt down env
+ let warn = addShortWarnLocLine loc $
vcat (warn_msg : ctxt_to_use ctxt_msgs)
- in
- writeMutVarSST errs_var (warns `snocBag` warn, errs) `thenSST_`
- returnSST ()
- else
- returnSST ()
+ writeIORef errs_var (warns `snocBag` warn, errs)
+ | otherwise
+ = return ()
where
errs_var = getTcErrs down
ctxt = getErrCtxt down
loc = getLoc down
-recoverTc :: TcM s r -> TcM s r -> TcM s r
-recoverTc recover m down env
- = recoverFSST (\ _ -> recover down env) (m down env)
+-- (tryTc r m) succeeds if m succeeds and generates no errors
+-- If m fails then r is invoked, passing the warnings and errors from m
+-- If m succeeds, (tryTc r m) checks whether m generated any errors messages
+-- (it might have recovered internally)
+-- If so, then r is invoked, passing the warnings and errors from m
+
+tryTc :: ((Bag WarnMsg, Bag ErrMsg) -> TcM s r) -- Recovery action
+ -> TcM s r -- Thing to try
+ -> TcM s r
+tryTc recover main down env
+ = do
+ m_errs_var <- newIORef (emptyBag,emptyBag)
+ catch (my_main m_errs_var) (\ _ -> my_recover m_errs_var)
+ where
+ my_recover m_errs_var
+ = do warns_and_errs <- readIORef m_errs_var
+ recover warns_and_errs down env
+
+ my_main m_errs_var
+ = do result <- main (setTcErrs down m_errs_var) env
+
+ -- Check that m has no errors; if it has internal recovery
+ -- mechanisms it might "succeed" but having found a bunch of
+ -- errors along the way.
+ (m_warns, m_errs) <- readIORef m_errs_var
+ if isEmptyBag m_errs then
+ return result
+ else
+ give_up -- This triggers the catch
-recoverNF_Tc :: NF_TcM s r -> TcM s r -> NF_TcM s r
-recoverNF_Tc recover m down env
- = recoverSST (\ _ -> recover down env) (m down env)
-- (checkNoErrsTc m) succeeds iff m succeeds and generates no errors
-- If m fails then (checkNoErrsTc m) fails.
-- If m succeeds, it checks whether m generated any errors messages
-- (it might have recovered internally)
-- If so, it fails too.
--- Regardless, any errors generated by m are propagated to the enclosing
--- context.
-
+-- Regardless, any errors generated by m are propagated to the enclosing context.
checkNoErrsTc :: TcM s r -> TcM s r
-checkNoErrsTc m down env
- = newMutVarSST (emptyBag,emptyBag) `thenSST` \ m_errs_var ->
- let
- errs_var = getTcErrs down
- propagate_errs _
- = readMutVarSST m_errs_var `thenSST` \ (m_warns, m_errs) ->
- readMutVarSST errs_var `thenSST` \ (warns, errs) ->
- writeMutVarSST errs_var (warns `unionBags` m_warns,
- errs `unionBags` m_errs) `thenSST_`
- failFSST()
- in
-
- recoverFSST propagate_errs $
-
- m (setTcErrs down m_errs_var) env `thenFSST` \ result ->
-
- -- Check that m has no errors; if it has internal recovery
- -- mechanisms it might "succeed" but having found a bunch of
- -- errors along the way.
- readMutVarSST m_errs_var `thenSST` \ (m_warns, m_errs) ->
- if isEmptyBag m_errs then
- returnFSST result
- else
- failFSST () -- This triggers the recoverFSST
-
--- (tryTc r m) tries m; if it succeeds it returns it,
--- otherwise it returns r. Any error messages added by m are discarded,
--- whether or not m succeeds.
-tryTc :: TcM s r -> TcM s r -> TcM s r
-tryTc recover m down env
- = recoverFSST (\ _ -> recover down env) $
-
- newMutVarSST (emptyBag,emptyBag) `thenSST` \ new_errs_var ->
- m (setTcErrs down new_errs_var) env `thenFSST` \ result ->
-
- -- Check that m has no errors; if it has internal recovery
- -- mechanisms it might "succeed" but having found a bunch of
- -- errors along the way. If so we want tryTc to use
- -- "recover" instead
- readMutVarSST new_errs_var `thenSST` \ (_,errs) ->
- if isEmptyBag errs then
- returnFSST result
- else
- recover down env
-
--- Run the thing inside, but throw away all its error messages.
--- discardErrsTc :: TcM s r -> TcM s r
--- discardErrsTc :: NF_TcM s r -> NF_TcM s r
-discardErrsTc :: (TcDown s -> TcEnv s -> State# s -> a)
- -> (TcDown s -> TcEnv s -> State# s -> a)
-discardErrsTc m down env
- = newMutVarSST (emptyBag,emptyBag) `thenSST` \ new_errs_var ->
- m (setTcErrs down new_errs_var) env
-
-checkTc :: Bool -> Message -> TcM s () -- Check that the boolean is true
-checkTc True err = returnTc ()
-checkTc False err = failWithTc err
+checkNoErrsTc main
+ = tryTc my_recover main
+ where
+ my_recover (m_warns, m_errs) down env
+ = do (warns, errs) <- readIORef errs_var
+ writeIORef errs_var (warns `unionBags` m_warns,
+ errs `unionBags` m_errs)
+ give_up
+ where
+ errs_var = getTcErrs down
-checkTcM :: Bool -> TcM s () -> TcM s () -- Check that the boolean is true
-checkTcM True err = returnTc ()
-checkTcM False err = err
-checkMaybeTc :: Maybe val -> Message -> TcM s val
-checkMaybeTc (Just val) err = returnTc val
-checkMaybeTc Nothing err = failWithTc err
+-- (tryTc_ r m) tries m; if it succeeds it returns it,
+-- otherwise it returns r. Any error messages added by m are discarded,
+-- whether or not m succeeds.
+tryTc_ :: TcM s r -> TcM s r -> TcM s r
+tryTc_ recover main
+ = tryTc my_recover main
+ where
+ my_recover warns_and_errs = recover
-checkMaybeTcM :: Maybe val -> TcM s val -> TcM s val
-checkMaybeTcM (Just val) err = returnTc val
-checkMaybeTcM Nothing err = err
+-- (discardErrsTc m) runs m, but throw away all its error messages.
+discardErrsTc :: Either_TcM s r -> Either_TcM s r
+discardErrsTc main down env
+ = do new_errs_var <- newIORef (emptyBag,emptyBag)
+ main (setTcErrs down new_errs_var) env
\end{code}
Mutable variables
~~~~~~~~~~~~~~~~~
\begin{code}
-type TcRef s a = SSTRef s a
+tcNewMutVar :: a -> NF_TcM s (TcRef a)
+tcNewMutVar val down env = newIORef val
-tcNewMutVar :: a -> NF_TcM s (TcRef s a)
-tcNewMutVar val down env = newMutVarSST val
+tcWriteMutVar :: TcRef a -> a -> NF_TcM s ()
+tcWriteMutVar var val down env = writeIORef var val
-tcWriteMutVar :: TcRef s a -> a -> NF_TcM s ()
-tcWriteMutVar var val down env = writeMutVarSST var val
+tcReadMutVar :: TcRef a -> NF_TcM s a
+tcReadMutVar var down env = readIORef var
-tcReadMutVar :: TcRef s a -> NF_TcM s a
-tcReadMutVar var down env = readMutVarSST var
+tcNewMutTyVar :: Name -> Kind -> NF_TcM s TyVar
+tcNewMutTyVar name kind down env = newMutTyVar name kind
+
+tcReadMutTyVar :: TyVar -> NF_TcM s (Maybe Type)
+tcReadMutTyVar tyvar down env = readMutTyVar tyvar
+
+tcWriteMutTyVar :: TyVar -> Maybe Type -> NF_TcM s ()
+tcWriteMutTyVar tyvar val down env = writeMutTyVar tyvar val
\end{code}
Environment
~~~~~~~~~~~
\begin{code}
-tcGetEnv :: NF_TcM s (TcEnv s)
-tcGetEnv down env = returnSST env
-
-tcSetEnv :: TcEnv s
- -> (TcDown s -> TcEnv s -> State# s -> b)
- -> TcDown s -> TcEnv s -> State# s -> b
--- tcSetEnv :: TcEnv s -> TcM s a -> TcM s a
--- tcSetEnv :: TcEnv s -> NF_TcM s a -> NF_TcM s a
+tcGetEnv :: NF_TcM s TcEnv
+tcGetEnv down env = return env
+tcSetEnv :: TcEnv -> Either_TcM s a -> Either_TcM s a
tcSetEnv new_env m down old_env = m down new_env
\end{code}
~~~~~~~~~~~~~~~
\begin{code}
tcGetDefaultTys :: NF_TcM s [Type]
-tcGetDefaultTys down env = returnSST (getDefaultTys down)
+tcGetDefaultTys down env = return (getDefaultTys down)
tcSetDefaultTys :: [Type] -> TcM s r -> TcM s r
tcSetDefaultTys tys m down env = m (setDefaultTys down tys) env
--- tcAddSrcLoc :: SrcLoc -> TcM s a -> TcM s a
--- tcAddSrcLoc :: SrcLoc -> NF_TcM s a -> NF_TcM s a
-tcAddSrcLoc :: SrcLoc -> (TcDown s -> env -> result)
- -> (TcDown s -> env -> result)
+tcAddSrcLoc :: SrcLoc -> Either_TcM s a -> Either_TcM s a
tcAddSrcLoc loc m down env = m (setLoc down loc) env
tcGetSrcLoc :: NF_TcM s SrcLoc
-tcGetSrcLoc down env = returnSST (getLoc down)
+tcGetSrcLoc down env = return (getLoc down)
-tcSetErrCtxtM, tcAddErrCtxtM :: (TidyTypeEnv s -> NF_TcM s (TidyTypeEnv s, Message))
+tcSetErrCtxtM, tcAddErrCtxtM :: (TidyEnv -> NF_TcM s (TidyEnv, Message))
-> TcM s a -> TcM s a
tcSetErrCtxtM msg m down env = m (setErrCtxt down msg) env
tcAddErrCtxtM msg m down env = m (addErrCtxt down msg) env
-tcSetErrCtxt, tcAddErrCtxt
- :: Message
- -> (TcDown s -> TcEnv s -> State# s -> b)
- -> TcDown s -> TcEnv s -> State# s -> b
+tcSetErrCtxt, tcAddErrCtxt :: Message -> Either_TcM s r -> Either_TcM s r
-- Usual thing
tcSetErrCtxt msg m down env = m (setErrCtxt down (\env -> returnNF_Tc (env, msg))) env
tcAddErrCtxt msg m down env = m (addErrCtxt down (\env -> returnNF_Tc (env, msg))) env
\begin{code}
tcGetUnique :: NF_TcM s Unique
tcGetUnique down env
- = readMutVarSST u_var `thenSST` \ uniq_supply ->
- let
- (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
- uniq = uniqFromSupply uniq_s
- in
- writeMutVarSST u_var new_uniq_supply `thenSST_`
- returnSST uniq
+ = do uniq_supply <- readIORef u_var
+ let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
+ uniq = uniqFromSupply uniq_s
+ writeIORef u_var new_uniq_supply
+ return uniq
where
u_var = getUniqSupplyVar down
tcGetUniques :: Int -> NF_TcM s [Unique]
tcGetUniques n down env
- = readMutVarSST u_var `thenSST` \ uniq_supply ->
- let
- (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
- uniqs = uniqsFromSupply n uniq_s
- in
- writeMutVarSST u_var new_uniq_supply `thenSST_`
- returnSST uniqs
+ = do uniq_supply <- readIORef u_var
+ let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
+ uniqs = uniqsFromSupply n uniq_s
+ writeIORef u_var new_uniq_supply
+ return uniqs
where
u_var = getUniqSupplyVar down
uniqSMToTcM :: UniqSM a -> NF_TcM s a
uniqSMToTcM m down env
- = readMutVarSST u_var `thenSST` \ uniq_supply ->
- let
- (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
- in
- writeMutVarSST u_var new_uniq_supply `thenSST_`
- returnSST (initUs uniq_s m)
+ = do uniq_supply <- readIORef u_var
+ let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
+ writeIORef u_var new_uniq_supply
+ return (initUs uniq_s m)
where
u_var = getUniqSupplyVar down
\end{code}
%~~~~~~~~~~~~~~~
\begin{code}
-data TcDown s
+data TcDown
= TcDown
- [Type] -- Types used for defaulting
+ [Type] -- Types used for defaulting
- (TcRef s UniqSupply) -- Unique supply
+ (TcRef UniqSupply) -- Unique supply
- SrcLoc -- Source location
- (ErrCtxt s) -- Error context
- (TcRef s (Bag WarnMsg,
+ SrcLoc -- Source location
+ ErrCtxt -- Error context
+ (TcRef (Bag WarnMsg,
Bag ErrMsg))
--- The TidyTypeEnv gives us a chance to tidy up the type,
--- so it prints nicely in error messages
-type TidyTypeEnv s = (FiniteMap FastString Int, -- Says what the 'next' unique to use
- -- for this occname is
- TyVarEnv (TcType s)) -- Current mapping
-
-emptyTidyEnv :: TidyTypeEnv s
-emptyTidyEnv = (emptyFM, emptyVarEnv)
-
-type ErrCtxt s = [TidyTypeEnv s -> NF_TcM s (TidyTypeEnv s, Message)]
+type ErrCtxt = [TidyEnv -> NF_TcM Unused (TidyEnv, Message)]
-- Innermost first. Monadic so that we have a chance
-- to deal with bound type variables just before error
-- message construction
\section[TcMonoType]{Typechecking user-specified @MonoTypes@}
\begin{code}
-module TcMonoType ( tcHsType, tcHsTcType, tcHsTypeKind, tcContext,
- tcTyVarScope,
+module TcMonoType ( tcHsType, tcHsTypeKind, tcHsTopType, tcHsTopBoxedType,
+ tcContext, tcHsTyVar, kcHsTyVar,
+ tcExtendTyVarScope, tcExtendTopTyVarScope,
TcSigInfo(..), tcTySig, mkTcSig, noSigs, maybeSig,
- checkSigTyVars, sigCtxt, existentialPatCtxt
+ checkSigTyVars, sigCtxt, sigPatCtxt
) where
#include "HsVersions.h"
-import HsSyn ( HsType(..), HsTyVar(..), Sig(..), pprContext )
+import HsSyn ( HsType(..), HsTyVar(..), Sig(..), pprClassAssertion, pprParendHsType )
import RnHsSyn ( RenamedHsType, RenamedContext, RenamedSig )
-import TcHsSyn ( TcIdBndr, TcIdOcc(..) )
+import TcHsSyn ( TcId )
import TcMonad
-import TcEnv ( tcLookupTyVar, tcLookupClass, tcLookupTyCon, tcExtendTyVarEnv,
- tcGetGlobalTyVars, tidyTypes, tidyTyVar
+import TcEnv ( tcExtendTyVarEnv, tcLookupTy, tcGetValueEnv, tcGetInScopeTyVars,
+ tcGetGlobalTyVars, TcTyThing(..)
)
import TcType ( TcType, TcKind, TcTyVar, TcThetaType, TcTauType,
typeToTcType, tcInstTcType, kindToTcKind,
- newKindVar,
- zonkTcKindToKind, zonkTcTyVars, zonkTcType
+ newKindVar,
+ zonkTcKindToKind, zonkTcTypeToType, zonkTcTyVars, zonkTcType
)
import Inst ( Inst, InstOrigin(..), newMethodWithGivenTy, instToIdBndr )
-import TcUnify ( unifyKind, unifyKinds )
+import TcUnify ( unifyKind, unifyKinds, unifyTypeKind )
import Type ( Type, ThetaType,
- mkTyVarTy, mkTyVarTys, mkFunTy, mkSynTy,
+ mkTyVarTy, mkTyVarTys, mkFunTy, mkSynTy, zipFunTys,
mkSigmaTy, mkDictTy, mkTyConApp, mkAppTys, splitRhoTy,
- boxedTypeKind, unboxedTypeKind, openTypeKind,
- mkArrowKind, getTyVar_maybe, getTyVar
+ boxedTypeKind, unboxedTypeKind, tyVarsOfType,
+ mkArrowKinds, getTyVar_maybe, getTyVar,
+ tidyOpenType, tidyOpenTypes, tidyTyVar
)
import Id ( mkUserId, idName, idType, idFreeTyVars )
import Var ( TyVar, mkTyVar )
import VarEnv
import VarSet
import Bag ( bagToList )
+import ErrUtils ( Message )
import PrelInfo ( cCallishClassKeys )
import TyCon ( TyCon )
-import Name ( Name, OccName, isTvOcc, getOccName )
+import Name ( Name, OccName, isTvOcc, getOccName, isLocallyDefined )
import TysWiredIn ( mkListTy, mkTupleTy, mkUnboxedTupleTy )
import SrcLoc ( SrcLoc )
import Unique ( Unique, Uniquable(..) )
+import UniqFM ( eltsUFM )
import Util ( zipWithEqual, zipLazy, mapAccumL )
import Outputable
\end{code}
tcHsType checks that the type really is of kind Type!
\begin{code}
-tcHsType :: RenamedHsType -> TcM s Type
+tcHsType :: RenamedHsType -> TcM s TcType
tcHsType ty
- = tcAddErrCtxt (typeCtxt ty) $
- tc_hs_type ty
-
--- Version for when we need a TcType returned
-tcHsTcType :: RenamedHsType -> TcM s (TcType s)
-tcHsTcType ty
- = tcHsType ty `thenTc` \ ty' ->
- returnTc (typeToTcType ty')
-
-tc_hs_type ty
- = tc_hs_type_kind ty `thenTc` \ (kind,ty) ->
- -- Check that it really is a type
- unifyKind openTypeKind kind `thenTc_`
- returnTc ty
+ = -- tcAddErrCtxt (typeCtxt ty) $
+ tc_type ty
+
+tcHsTypeKind :: RenamedHsType -> TcM s (TcKind, TcType)
+tcHsTypeKind ty
+ = -- tcAddErrCtxt (typeCtxt ty) $
+ tc_type_kind ty
+
+-- Type-check a type, *and* then lazily zonk it. The important
+-- point is that this zonks all the uncommitted *kind* variables
+-- in kinds of any any nested for-all tyvars.
+-- There won't be any mutable *type* variables at all.
+--
+-- NOTE the forkNF_Tc. This makes the zonking lazy, which is
+-- absolutely necessary. During the type-checking of a recursive
+-- group of tycons/classes (TcTyClsDecls.tcGroup) we use an
+-- environment in which we aren't allowed to look at the actual
+-- tycons/classes returned from a lookup. Because tc_app does
+-- look at the tycon to build the type, we can't look at the type
+-- either, until we get out of the loop. The fork delays the
+-- zonking till we've completed the loop. Sigh.
+
+tcHsTopType :: RenamedHsType -> TcM s Type
+tcHsTopType ty
+ = -- tcAddErrCtxt (typeCtxt ty) $
+ tc_type ty `thenTc` \ ty' ->
+ forkNF_Tc (zonkTcTypeToType ty')
+
+tcHsTopBoxedType :: RenamedHsType -> TcM s Type
+tcHsTopBoxedType ty
+ = -- tcAddErrCtxt (typeCtxt ty) $
+ tc_boxed_type ty `thenTc` \ ty' ->
+ forkNF_Tc (zonkTcTypeToType ty')
\end{code}
-tcHsTypeKind does the real work. It returns a kind and a type.
-
-\begin{code}
-tcHsTypeKind :: RenamedHsType -> TcM s (TcKind s, Type)
-
-tcHsTypeKind ty
- = tcAddErrCtxt (typeCtxt ty) $
- tc_hs_type_kind ty
+The main work horse
+~~~~~~~~~~~~~~~~~~~
- -- This equation isn't needed (the next one would handle it fine)
- -- but it's rather a common case, so we handle it directly
-tc_hs_type_kind (MonoTyVar name)
- | isTvOcc (getOccName name)
- = tcLookupTyVar name `thenNF_Tc` \ (kind,tyvar) ->
- returnTc (kind, mkTyVarTy tyvar)
-
-tc_hs_type_kind ty@(MonoTyVar name)
- = tcFunType ty []
+\begin{code}
+tc_boxed_type :: RenamedHsType -> TcM s Type
+tc_boxed_type ty
+ = tc_type_kind ty `thenTc` \ (actual_kind, tc_ty) ->
+ tcAddErrCtxt (typeKindCtxt ty)
+ (unifyKind boxedTypeKind actual_kind) `thenTc_`
+ returnTc tc_ty
+
+tc_type :: RenamedHsType -> TcM s Type
+tc_type ty
+ -- The type ty must be a *type*, but it can be boxed
+ -- or unboxed. So we check that is is of form (Type bv)
+ -- using unifyTypeKind
+ = tc_type_kind ty `thenTc` \ (actual_kind, tc_ty) ->
+ tcAddErrCtxt (typeKindCtxt ty)
+ (unifyTypeKind actual_kind) `thenTc_`
+ returnTc tc_ty
+
+tc_type_kind :: RenamedHsType -> TcM s (TcKind, Type)
+tc_type_kind ty@(MonoTyVar name)
+ = tc_app ty []
-tc_hs_type_kind (MonoListTy ty)
- = tc_hs_type ty `thenTc` \ tau_ty ->
+tc_type_kind (MonoListTy ty)
+ = tc_boxed_type ty `thenTc` \ tau_ty ->
returnTc (boxedTypeKind, mkListTy tau_ty)
-tc_hs_type_kind (MonoTupleTy tys True{-boxed-})
- = mapTc tc_hs_type tys `thenTc` \ tau_tys ->
+tc_type_kind (MonoTupleTy tys True {-boxed-})
+ = mapTc tc_boxed_type tys `thenTc` \ tau_tys ->
returnTc (boxedTypeKind, mkTupleTy (length tys) tau_tys)
-tc_hs_type_kind (MonoTupleTy tys False{-unboxed-})
- = mapTc tc_hs_type tys `thenTc` \ tau_tys ->
+tc_type_kind (MonoTupleTy tys False {-unboxed-})
+ = mapTc tc_type tys `thenTc` \ tau_tys ->
returnTc (unboxedTypeKind, mkUnboxedTupleTy (length tys) tau_tys)
-tc_hs_type_kind (MonoFunTy ty1 ty2)
- = tc_hs_type ty1 `thenTc` \ tau_ty1 ->
- tc_hs_type ty2 `thenTc` \ tau_ty2 ->
+tc_type_kind (MonoFunTy ty1 ty2)
+ = tc_type ty1 `thenTc` \ tau_ty1 ->
+ tc_type ty2 `thenTc` \ tau_ty2 ->
returnTc (boxedTypeKind, mkFunTy tau_ty1 tau_ty2)
-tc_hs_type_kind (MonoTyApp ty1 ty2)
- = tcTyApp ty1 [ty2]
+tc_type_kind (MonoTyApp ty1 ty2)
+ = tc_app ty1 [ty2]
-tc_hs_type_kind (HsForAllTy tv_names context ty)
- = tcTyVarScope tv_names $ \ tyvars ->
- tcContext context `thenTc` \ theta ->
- tc_hs_type ty `thenTc` \ tau ->
- -- For-all's are of kind type!
- returnTc (boxedTypeKind, mkSigmaTy tyvars theta tau)
-
--- for unfoldings, and instance decls, only:
-tc_hs_type_kind (MonoDictTy class_name tys)
+tc_type_kind (MonoDictTy class_name tys)
= tcClassAssertion (class_name, tys) `thenTc` \ (clas, arg_tys) ->
returnTc (boxedTypeKind, mkDictTy clas arg_tys)
+
+tc_type_kind (HsForAllTy tv_names context ty)
+ = tcExtendTyVarScope tv_names $ \ tyvars ->
+ tcContext context `thenTc` \ theta ->
+ tc_boxed_type ty `thenTc` \ tau ->
+ -- Body of a for-all is a boxed type!
+ returnTc (boxedTypeKind, mkSigmaTy tyvars theta tau)
\end{code}
Help functions for type applications
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
\begin{code}
-tcTyApp (MonoTyApp ty1 ty2) tys
- = tcTyApp ty1 (ty2:tys)
+tc_app (MonoTyApp ty1 ty2) tys
+ = tc_app ty1 (ty2:tys)
-tcTyApp ty tys
+tc_app ty tys
| null tys
- = tcFunType ty []
+ = tc_fun_type ty []
| otherwise
- = mapAndUnzipTc tc_hs_type_kind tys `thenTc` \ (arg_kinds, arg_tys) ->
- tcFunType ty arg_tys `thenTc` \ (fun_kind, result_ty) ->
+ = tcAddErrCtxt (appKindCtxt pp_app) $
+ mapAndUnzipTc tc_type_kind tys `thenTc` \ (arg_kinds, arg_tys) ->
+ tc_fun_type ty arg_tys `thenTc` \ (fun_kind, result_ty) ->
-- Check argument compatibility
- newKindVar `thenNF_Tc` \ result_kind ->
- unifyKind fun_kind (foldr mkArrowKind result_kind arg_kinds)
+ newKindVar `thenNF_Tc` \ result_kind ->
+ unifyKind fun_kind (mkArrowKinds arg_kinds result_kind)
`thenTc_`
returnTc (result_kind, result_ty)
+ where
+ pp_app = ppr ty <+> sep (map pprParendHsType tys)
--- (tcFunType ty arg_tys) returns (kind-of ty, mkAppTys ty arg_tys)
+-- (tc_fun_type ty arg_tys) returns (kind-of ty, mkAppTys ty arg_tys)
-- But not quite; for synonyms it checks the correct arity, and builds a SynTy
-- hence the rather strange functionality.
-tcFunType (MonoTyVar name) arg_tys
- | isTvOcc (getOccName name) -- Must be a type variable
- = tcLookupTyVar name `thenNF_Tc` \ (kind,tyvar) ->
- returnTc (kind, mkAppTys (mkTyVarTy tyvar) arg_tys)
-
- | otherwise -- Must be a type constructor
- = tcLookupTyCon name `thenTc` \ (tycon_kind,maybe_arity, tycon) ->
- case maybe_arity of
- Nothing -> -- Data type or newtype
- returnTc (tycon_kind, mkTyConApp tycon arg_tys)
-
- Just arity -> -- Type synonym
- checkTc (arity <= n_args) err_msg `thenTc_`
- returnTc (tycon_kind, result_ty)
- where
- -- It's OK to have an *over-applied* type synonym
- -- data Tree a b = ...
- -- type Foo a = Tree [a]
- -- f :: Foo a b -> ...
- result_ty = mkAppTys (mkSynTy tycon (take arity arg_tys))
- (drop arity arg_tys)
- err_msg = arityErr "Type synonym constructor" name arity n_args
- n_args = length arg_tys
-
-tcFunType ty arg_tys
- = tc_hs_type_kind ty `thenTc` \ (fun_kind, fun_ty) ->
+tc_fun_type (MonoTyVar name) arg_tys
+ = tcLookupTy name `thenTc` \ (tycon_kind, maybe_arity, 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)
+
+ Just arity -> -- Type synonym
+ checkTc (arity <= n_args) err_msg `thenTc_`
+ returnTc (tycon_kind, result_ty)
+ where
+ -- It's OK to have an *over-applied* type synonym
+ -- data Tree a b = ...
+ -- type Foo a = Tree [a]
+ -- f :: Foo a b -> ...
+ result_ty = mkAppTys (mkSynTy tc (take arity arg_tys))
+ (drop arity arg_tys)
+ err_msg = arityErr "type synonym" name arity n_args
+ n_args = length arg_tys
+
+tc_fun_type ty arg_tys
+ = tc_type_kind ty `thenTc` \ (fun_kind, fun_ty) ->
returnTc (fun_kind, mkAppTys fun_ty arg_tys)
\end{code}
tcContext :: RenamedContext -> TcM s ThetaType
tcContext context
- = tcAddErrCtxt (thetaCtxt context) $
-
- --Someone discovered that @CCallable@ and @CReturnable@
+ = --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
= checkTc (not (getUnique class_name `elem` cCallishClassKeys))
(naughtyCCallContextErr class_name)
-tcClassAssertion (class_name, tys)
- = tcLookupClass class_name `thenTc` \ (class_kinds, clas) ->
- mapAndUnzipTc tc_hs_type_kind tys `thenTc` \ (ty_kinds, tc_tys) ->
-
- -- Check with kind mis-match
- let
- arity = length class_kinds
- n_tys = length ty_kinds
- err = arityErr "Class" class_name arity n_tys
- in
- checkTc (arity == n_tys) err `thenTc_`
- unifyKinds class_kinds ty_kinds `thenTc_`
-
- returnTc (clas, tc_tys)
+tcClassAssertion assn@(class_name, tys)
+ = tcAddErrCtxt (appKindCtxt (pprClassAssertion assn)) $
+ mapAndUnzipTc tc_type_kind tys `thenTc` \ (arg_kinds, arg_tys) ->
+ tcLookupTy class_name `thenTc` \ (kind, ~(Just arity), thing) ->
+ case thing of
+ ATyVar _ -> failWithTc (tyVarAsClassErr class_name)
+ ATyCon _ -> failWithTc (tyConAsClassErr class_name)
+ AClass clas ->
+ -- Check with kind mis-match
+ checkTc (arity == n_tys) err `thenTc_`
+ unifyKind kind (mkArrowKinds arg_kinds boxedTypeKind) `thenTc_`
+ returnTc (clas, arg_tys)
+ where
+ n_tys = length tys
+ err = arityErr "Class" class_name arity n_tys
\end{code}
%************************************************************************
\begin{code}
-tcTyVarScope
- :: [HsTyVar Name] -- Names of some type variables
- -> ([TyVar] -> TcM s a) -- Thing to type check in their scope
- -> TcM s a -- Result
-
-tcTyVarScope tyvar_names thing_inside
- = mapAndUnzipNF_Tc tcHsTyVar tyvar_names `thenNF_Tc` \ (names, kinds) ->
-
- fixTc (\ ~(rec_tyvars, _) ->
- -- Ok to look at names, kinds, but not tyvars!
+tcExtendTopTyVarScope :: TcKind -> [HsTyVar Name]
+ -> ([TcTyVar] -> TcKind -> TcM s a)
+ -> TcM s a
+tcExtendTopTyVarScope kind tyvar_names thing_inside
+ = let
+ (tyvars_w_kinds, result_kind) = zipFunTys tyvar_names kind
+ tyvars = map mk_tv tyvars_w_kinds
+ in
+ tcExtendTyVarEnv tyvars (thing_inside tyvars result_kind)
+ where
+ mk_tv (UserTyVar name, kind) = mkTyVar name kind
+ mk_tv (IfaceTyVar name _, kind) = mkTyVar name kind
+ -- NB: immutable tyvars, but perhaps with mutable kinds
+
+tcExtendTyVarScope :: [HsTyVar 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 (UserTyVar name) = newKindVar `thenNF_Tc` \ kind ->
+ tcNewMutTyVar name kind
+ -- NB: mutable kind => mutable tyvar, so that zonking can bind
+ -- the tyvar to its immutable form
- tcExtendTyVarEnv names (kinds `zipLazy` rec_tyvars)
- (thing_inside rec_tyvars) `thenTc` \ result ->
-
- -- Get the tyvar's Kinds from their TcKinds
- mapNF_Tc zonkTcKindToKind kinds `thenNF_Tc` \ kinds' ->
+tcHsTyVar (IfaceTyVar name kind) = returnNF_Tc (mkTyVar name (kindToTcKind kind))
- -- Construct the real TyVars
- let
- tyvars = zipWithEqual "tcTyVarScope" mkTyVar names kinds'
- in
- returnTc (tyvars, result)
- ) `thenTc` \ (_,result) ->
- returnTc result
-
-tcHsTyVar (UserTyVar name)
- = newKindVar `thenNF_Tc` \ tc_kind ->
- returnNF_Tc (name, tc_kind)
-tcHsTyVar (IfaceTyVar name kind)
- = returnNF_Tc (name, kindToTcKind kind)
+kcHsTyVar :: HsTyVar name -> NF_TcM s TcKind
+kcHsTyVar (UserTyVar name) = newKindVar
+kcHsTyVar (IfaceTyVar name kind) = returnNF_Tc (kindToTcKind kind)
\end{code}
been instantiated.
\begin{code}
-data TcSigInfo s
+data TcSigInfo
= TySigInfo
Name -- N, the Name in corresponding binding
- (TcIdBndr s) -- *Polymorphic* binder for this value...
+ TcId -- *Polymorphic* binder for this value...
-- Has name = N
- [TcTyVar s] -- tyvars
- (TcThetaType s) -- theta
- (TcTauType s) -- tau
+ [TcTyVar] -- tyvars
+ TcThetaType -- theta
+ TcTauType -- tau
- (TcIdBndr s) -- *Monomorphic* binder for this value
+ TcId -- *Monomorphic* binder for this value
-- Does *not* have name = N
-- Has type tau
- (Inst s) -- Empty if theta is null, or
+ Inst -- Empty if theta is null, or
-- (method mono_id) otherwise
SrcLoc -- Of the signature
-maybeSig :: [TcSigInfo s] -> Name -> Maybe (TcSigInfo s)
+maybeSig :: [TcSigInfo] -> Name -> Maybe (TcSigInfo)
-- Search for a particular signature
maybeSig [] name = Nothing
maybeSig (sig@(TySigInfo sig_name _ _ _ _ _ _ _) : sigs) name
| otherwise = maybeSig sigs name
-- This little helper is useful to pass to tcPat
-noSigs :: Name -> Maybe (TcIdBndr s)
+noSigs :: Name -> Maybe TcId
noSigs name = Nothing
\end{code}
\begin{code}
-tcTySig :: RenamedSig
- -> TcM s (TcSigInfo s)
+tcTySig :: RenamedSig -> TcM s TcSigInfo
tcTySig (Sig v ty src_loc)
= tcAddSrcLoc src_loc $
- tcHsTcType ty `thenTc` \ sigma_tc_ty ->
+ tcHsType ty `thenTc` \ sigma_tc_ty ->
mkTcSig (mkUserId v sigma_tc_ty) src_loc `thenNF_Tc` \ sig ->
returnTc sig
-mkTcSig :: TcIdBndr s -> SrcLoc -> NF_TcM s (TcSigInfo s)
+mkTcSig :: TcId -> SrcLoc -> NF_TcM s TcSigInfo
mkTcSig poly_id src_loc
= -- Instantiate this type
-- It's important to do this even though in the error-free case
-- wherever possible, which can improve interface files.
in
newMethodWithGivenTy SignatureOrigin
- (TcId poly_id)
+ poly_id
(mkTyVarTys tyvars)
theta tau `thenNF_Tc` \ inst ->
-- We make a Method even if it's not overloaded; no harm
@checkSigTyVars@ is used after the type in a type signature has been unified with
the actual type found. It then checks that the type variables of the type signature
are
- (a) still all type variables
+ (a) Still all type variables
eg matching signature [a] against inferred type [(p,q)]
[then a will be unified to a non-type variable]
- (b) still all distinct
+ (b) Still all distinct
eg matching signature [(a,b)] against inferred type [(p,p)]
[then a and b will be unified together]
- (c) not mentioned in the environment
+ (c) Not mentioned in the environment
eg the signature for f in this:
g x = ... where
Here, f is forced to be monorphic by the free occurence of x.
+ (d) Not (unified with another type variable that is) in scope.
+ eg f x :: (r->r) = (\y->y) :: forall a. a->r
+ when checking the expression type signature, we find that
+ even though there is nothing in scope whose type mentions r,
+ nevertheless the type signature for the expression isn't right.
+
+ Another example is in a class or instance declaration:
+ class C a where
+ op :: forall b. a -> b
+ op x = x
+ Here, b gets unified with a
+
Before doing this, the substitution is applied to the signature type variable.
We used to have the notion of a "DontBind" type variable, which would
give a helpful message in checkSigTyVars.
\begin{code}
-checkSigTyVars :: [TcTyVar s] -- The original signature type variables
- -> TcM s [TcTyVar s] -- Zonked signature type variables
+checkSigTyVars :: [TcTyVar] -- The original signature type variables
+ -> TcM s [TcTyVar] -- Zonked signature type variables
checkSigTyVars [] = returnTc []
checkSigTyVars sig_tyvars
= zonkTcTyVars sig_tyvars `thenNF_Tc` \ sig_tys ->
tcGetGlobalTyVars `thenNF_Tc` \ globals ->
+
checkTcM (all_ok sig_tys globals)
(complain sig_tys globals) `thenTc_`
complain sig_tys globals
- = failWithTcM (env2, main_msg)
- where
- (env1, tidy_tys) = tidyTypes emptyTidyEnv sig_tys
- (env2, tidy_tvs) = mapAccumL tidyTyVar env1 sig_tyvars
+ = -- For the in-scope ones, zonk them and construct a map
+ -- from the zonked tyvar to the in-scope one
+ -- If any of the in-scope tyvars zonk to a type, then ignore them;
+ -- that'll be caught later when we back up to their type sig
+ tcGetInScopeTyVars `thenNF_Tc` \ in_scope_tvs ->
+ zonkTcTyVars in_scope_tvs `thenNF_Tc` \ in_scope_tys ->
+ let
+ in_scope_assoc = [ (zonked_tv, in_scope_tv)
+ | (z_ty, in_scope_tv) <- in_scope_tys `zip` in_scope_tvs,
+ Just zonked_tv <- [getTyVar_maybe z_ty]
+ ]
+ in_scope_env = mkVarEnv in_scope_assoc
+ in
- msgs = check (tidy_tvs `zip` tidy_tys) emptyVarEnv
+ -- "check" checks each sig tyvar in turn
+ foldlNF_Tc check
+ (env2, in_scope_env, [])
+ (tidy_tvs `zip` tidy_tys) `thenNF_Tc` \ (env3, _, msgs) ->
- main_msg = ptext SLIT("Inferred type is less polymorphic than expected")
- $$
- nest 4 (vcat msgs)
+ failWithTcM (env3, main_msg $$ nest 4 (vcat msgs))
+ where
+ (env1, tidy_tvs) = mapAccumL tidyTyVar emptyTidyEnv sig_tyvars
+ (env2, tidy_tys) = tidyOpenTypes env1 sig_tys
- check [] acc = []
- check ((sig_tyvar,ty):prs) acc
- = case getTyVar_maybe ty of
- Nothing -- Error (a)!
- -> unify_msg sig_tyvar (ppr ty) : check prs acc
+ main_msg = ptext SLIT("Inferred type is less polymorphic than expected")
- Just tv
- | tv `elemVarSet` globals -- Error (c)! Type variable escapes
- -> escape_msg tv : check prs acc
+ check (env, acc, msgs) (sig_tyvar,ty)
+ -- sig_tyvar is from the signature;
+ -- ty is what you get if you zonk sig_tyvar and then tidy it
+ --
+ -- acc maps a zonked type variable back to a signature type variable
+ = case getTyVar_maybe ty of {
+ Nothing -> -- Error (a)!
+ returnNF_Tc (env, acc, unify_msg sig_tyvar (ppr ty) : msgs) ;
+
+ Just tv ->
+
+ case lookupVarEnv acc tv of {
+ Just sig_tyvar' -> -- Error (b) or (d)!
+ returnNF_Tc (env, acc, unify_msg sig_tyvar (ppr sig_tyvar') : msgs) ;
+
+ Nothing ->
+
+ if tv `elemVarSet` globals -- Error (c)! Type variable escapes
+ -- The least comprehensible, so put it last
+ then tcGetValueEnv `thenNF_Tc` \ ve ->
+ find_globals tv env (eltsUFM ve) `thenNF_Tc` \ (env1, globs) ->
+ returnNF_Tc (env1, acc, escape_msg sig_tyvar tv globs : msgs)
+
+ else -- All OK
+ returnNF_Tc (env, extendVarEnv acc tv sig_tyvar, msgs)
+ }}
+
+-- find_globals looks at the value environment and finds values
+-- whose types mention the offending type variable. It has to be
+-- careful to zonk the Id's type first, so it has to be in the monad.
+-- We must be careful to pass it a zonked type variable, too.
+find_globals tv tidy_env ids
+ | null ids
+ = returnNF_Tc (tidy_env, [])
+
+find_globals tv tidy_env (id:ids)
+ | not (isLocallyDefined id) ||
+ isEmptyVarSet (idFreeTyVars id)
+ = find_globals tv tidy_env ids
- | otherwise
- -> case lookupVarEnv acc tv of
- Nothing -- All OK
- -> check prs (extendVarEnv acc tv sig_tyvar) -- All OK
- Just sig_tyvar' -- Error (b)!
- -> unify_msg sig_tyvar (ppr sig_tyvar') : check prs acc
+ | otherwise
+ = zonkTcType (idType id) `thenNF_Tc` \ id_ty ->
+ if tv `elemVarSet` tyVarsOfType id_ty then
+ let
+ (tidy_env', id_ty') = tidyOpenType tidy_env id_ty
+ in
+ find_globals tv tidy_env' ids `thenNF_Tc` \ (tidy_env'', globs) ->
+ returnNF_Tc (tidy_env'', (idName id, id_ty') : globs)
+ else
+ find_globals tv tidy_env ids
+
+escape_msg sig_tv tv globs
+ = vcat [mk_msg sig_tv <+> ptext SLIT("escapes"),
+ pp_escape,
+ ptext SLIT("The following variables in the environment mention") <+> quotes (ppr tv),
+ nest 4 (vcat_first 10 [ppr name <+> dcolon <+> ppr ty | (name,ty) <- globs])
+ ]
+ where
+ pp_escape | sig_tv /= tv = ptext SLIT("It unifies with") <+>
+ quotes (ppr tv) <> comma <+>
+ ptext SLIT("which is mentioned in the environment")
+ | otherwise = ptext SLIT("It is mentioned in the environment")
+ vcat_first n [] = empty
+ vcat_first 0 (x:xs) = text "...others omitted..."
+ vcat_first n (x:xs) = x $$ vcat_first (n-1) xs
-escape_msg tv = mk_msg tv <+> ptext SLIT("escapes; i.e. unifies with something more global")
unify_msg tv thing = mk_msg tv <+> ptext SLIT("is unified with") <+> quotes thing
mk_msg tv = ptext SLIT("Quantified type variable") <+> quotes (ppr tv)
\end{code}
These two context are used with checkSigTyVars
\begin{code}
-sigCtxt thing sig_tau tidy_env
- = zonkTcType sig_tau `thenNF_Tc` \ zonked_sig_tau ->
- let
- (env1, [tidy_tau, tidy_zonked_tau]) = tidyTypes tidy_env [sig_tau, zonked_sig_tau]
-
- msg = vcat [ptext SLIT("When checking the type signature for") <+> thing,
- nest 4 (ptext SLIT("Signature:") <+> ppr tidy_tau),
- nest 4 (ptext SLIT("Inferred: ") <+> ppr tidy_zonked_tau)]
+sigCtxt :: (Type -> Message) -> Type
+ -> TidyEnv -> NF_TcM s (TidyEnv, Message)
+sigCtxt mk_msg sig_ty tidy_env
+ = let
+ (env1, tidy_sig_ty) = tidyOpenType tidy_env sig_ty
in
- returnNF_Tc (env1, msg)
+ returnNF_Tc (env1, mk_msg tidy_sig_ty)
-existentialPatCtxt bound_tvs bound_ids tidy_env
+sigPatCtxt bound_tvs bound_ids tidy_env
= returnNF_Tc (env1,
- sep [ptext SLIT("When checking an existential pattern that binds"),
+ sep [ptext SLIT("When checking a pattern that binds"),
nest 4 (vcat (zipWith ppr_id show_ids tidy_tys))])
where
- tv_list = bagToList bound_tvs
- show_ids = filter is_interesting (map snd (bagToList bound_ids))
- is_interesting id = any (`elemVarSet` idFreeTyVars id) tv_list
+ show_ids = filter is_interesting bound_ids
+ is_interesting id = any (`elemVarSet` idFreeTyVars id) bound_tvs
- (env1, tidy_tys) = tidyTypes tidy_env (map idType show_ids)
- ppr_id id ty = ppr id <+> ptext SLIT("::") <+> ppr ty
+ (env1, tidy_tys) = tidyOpenTypes tidy_env (map idType show_ids)
+ ppr_id id ty = ppr id <+> dcolon <+> ppr ty
-- Don't zonk the types so we get the separate, un-unified versions
\end{code}
\begin{code}
naughtyCCallContextErr clas_name
- = sep [ptext SLIT("Can't use class"), quotes (ppr clas_name), ptext SLIT("in a context")]
+ = 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)
-thetaCtxt theta = ptext SLIT("In the context") <+> quotes (pprContext theta)
+typeKindCtxt :: RenamedHsType -> Message
+typeKindCtxt ty = sep [ptext SLIT("When checking that"),
+ nest 2 (quotes (ppr ty)),
+ ptext SLIT("is a type")]
+
+appKindCtxt :: SDoc -> Message
+appKindCtxt pp = ptext SLIT("When checking kinds in") <+> quotes pp
+
+classAsTyConErr name
+ = ptext SLIT("Class used as a type constructor:") <+> ppr name
+
+tyConAsClassErr name
+ = ptext SLIT("Type constructor used as a class:") <+> ppr name
+
+tyVarAsClassErr name
+ = ptext SLIT("Type variable used as a class:") <+> ppr name
\end{code}
\section[TcPat]{Typechecking patterns}
\begin{code}
-module TcPat ( tcPat, tcVarPat, badFieldCon ) where
+module TcPat ( tcPat, tcVarPat, badFieldCon, polyPatSig ) where
#include "HsVersions.h"
+import {-# SOURCE #-} TcExpr( tcExpr )
+
import HsSyn ( InPat(..), OutPat(..), HsLit(..), HsExpr(..), Sig(..) )
import RnHsSyn ( RenamedPat )
-import TcHsSyn ( TcPat, TcIdBndr )
+import TcHsSyn ( TcPat, TcId )
import TcMonad
import Inst ( Inst, OverloadedLit(..), InstOrigin(..),
)
import Name ( Name, getOccName, getSrcLoc )
import FieldLabel ( fieldLabelName )
-import TcEnv ( TcIdOcc(..), tcLookupGlobalValue,
- tcLookupGlobalValueByKey, newLocalId, badCon
+import TcEnv ( tcLookupValue,
+ tcLookupValueByKey, newLocalId, badCon
)
import TcType ( TcType, TcTyVar, tcInstTyVars )
+import TcMonoType ( tcHsType )
import TcUnify ( unifyTauTy, unifyListTy,
unifyTupleTy, unifyUnboxedTupleTy
)
import Bag ( Bag )
import CmdLineOpts ( opt_IrrefutableTuples )
import DataCon ( DataCon, dataConSig, dataConFieldLabels, dataConSourceArity )
-import Id ( Id, idType, isDataConId_maybe )
-import Type ( Type, substFlexiTy, substFlexiTheta, mkTyConApp )
+import Id ( Id, mkUserId, idType, isDataConId_maybe )
+import Type ( Type, isTauTy, substTopTy, substTopTheta, mkTyConApp )
import TysPrim ( charPrimTy, intPrimTy, floatPrimTy,
doublePrimTy, addrPrimTy
)
%************************************************************************
\begin{code}
-tcVarPat :: (Name -> Maybe (TcIdBndr s)) -- Info about signatures
+tcVarPat :: (Name -> Maybe TcId) -- Info about signatures; gives the *monomorphic*
+ -- Id for variables with a type signature
-> Name
- -> TcType s -- Expected type
- -> TcM s (TcIdBndr s) -- The monomorphic Id; this is put in the pattern itself
+
+ -> TcType -- Expected type, derived from the context
+ -- In the case of a function with a rank-2 signature,
+ -- this type might be a forall type.
+ -- INVARIANT: if it is, the foralls will always be visible,
+ -- not hidden inside a mutable type variable
+
+ -> TcM s TcId -- The monomorphic Id; this is put in the pattern itself
tcVarPat sig_fn binder_name pat_ty
= case sig_fn binder_name of
returnTc bndr_id
Just bndr_id -> tcAddSrcLoc (getSrcLoc binder_name) $
- unifyTauTy pat_ty (idType bndr_id) `thenTc_`
+ unifyTauTy (idType bndr_id) pat_ty `thenTc_`
returnTc bndr_id
\end{code}
%************************************************************************
\begin{code}
-tcPat :: (Name -> Maybe (TcIdBndr s)) -- Info about signatures
+tcPat :: (Name -> Maybe TcId) -- Info about signatures; gives the *monomorphic*
+ -- Id for variables with a type signature
-> RenamedPat
- -> TcType s -- Expected type
- -> TcM s (TcPat s,
- LIE s, -- Required by n+k and literal pats
- Bag (TcTyVar s), -- TyVars bound by the pattern
- Bag (Name, TcIdBndr s), -- Ids bound by the pattern, along with the Name under
+ -> TcType -- Expected type; see invariant in tcVarPat
+ -> TcM s (TcPat,
+ LIE, -- Required by n+k and literal pats
+ Bag TcTyVar, -- TyVars bound by the pattern
+ -- These are just the existentially-bound ones.
+ -- Any tyvars bound by *type signatures* in the
+ -- patterns are brought into scope before we begin.
+ Bag (Name, TcId), -- Ids bound by the pattern, along with the Name under
-- which it occurs in the pattern
-- The two aren't the same because we conjure up a new
-- local name for each variable.
- LIE s) -- Dicts or methods [see below] bound by the pattern
+ LIE) -- Dicts or methods [see below] bound by the pattern
+ -- from existential constructor patterns
\end{code}
\begin{code}
tcPat sig_fn (VarPatIn name) pat_ty
= tcVarPat sig_fn name pat_ty `thenTc` \ bndr_id ->
- returnTc (VarPat (TcId bndr_id), emptyLIE, emptyBag, unitBag (name, bndr_id), emptyLIE)
+ returnTc (VarPat bndr_id, emptyLIE, emptyBag, unitBag (name, bndr_id), emptyLIE)
tcPat sig_fn (LazyPatIn pat) pat_ty
= tcPat sig_fn pat pat_ty `thenTc` \ (pat', lie_req, tvs, ids, lie_avail) ->
= tcVarPat sig_fn name pat_ty `thenTc` \ bndr_id ->
tcPat sig_fn pat pat_ty `thenTc` \ (pat', lie_req, tvs, ids, lie_avail) ->
tcAddErrCtxt (patCtxt pat_in) $
- returnTc (AsPat (TcId bndr_id) pat', lie_req,
- tvs, (name, bndr_id) `consBag` ids,
- lie_avail)
+ returnTc (AsPat bndr_id pat', lie_req,
+ tvs, (name, bndr_id) `consBag` ids, lie_avail)
tcPat sig_fn WildPatIn pat_ty
= returnTc (WildPat pat_ty, emptyLIE, emptyBag, emptyBag, emptyLIE)
tcPat sig_fn (ParPatIn parend_pat) pat_ty
= tcPat sig_fn parend_pat pat_ty
+
+tcPat sig_fn (SigPatIn pat sig) pat_ty
+ = tcHsType sig `thenTc` \ sig_ty ->
+
+ -- Check that the signature isn't a polymorphic one, which
+ -- we don't permit (at present, anyway)
+ checkTc (isTauTy sig_ty) (polyPatSig sig_ty) `thenTc_`
+
+ unifyTauTy pat_ty sig_ty `thenTc_`
+ tcPat sig_fn pat sig_ty
\end{code}
%************************************************************************
= ASSERT( null extras )
tc_fields field_tys rpats `thenTc` \ (rpats', lie_req1, tvs1, ids1, lie_avail1) ->
- tcLookupGlobalValue field_label `thenNF_Tc` \ sel_id ->
+ tcLookupValue field_label `thenNF_Tc` \ sel_id ->
tcPat sig_fn rhs_pat rhs_ty `thenTc` \ (rhs_pat', lie_req2, tvs2, ids2, lie_avail2) ->
returnTc ((sel_id, rhs_pat', pun_flag) : rpats',
\begin{code}
tcPat sig_fn pat@(LitPatIn lit@(HsString str)) pat_ty
= unifyTauTy pat_ty stringTy `thenTc_`
- tcLookupGlobalValueByKey eqClassOpKey `thenNF_Tc` \ sel_id ->
- newMethod (PatOrigin pat)
- (RealId sel_id) [stringTy] `thenNF_Tc` \ (lie, eq_id) ->
+ tcLookupValueByKey eqClassOpKey `thenNF_Tc` \ sel_id ->
+ newMethod (PatOrigin pat) sel_id [stringTy] `thenNF_Tc` \ (lie, eq_id) ->
let
comp_op = HsApp (HsVar eq_id) (HsLitOut lit stringTy)
in
tcPat sig_fn pat@(NPlusKPatIn name lit@(HsInt i)) pat_ty
= tcVarPat sig_fn name pat_ty `thenTc` \ bndr_id ->
- tcLookupGlobalValueByKey geClassOpKey `thenNF_Tc` \ ge_sel_id ->
- tcLookupGlobalValueByKey minusClassOpKey `thenNF_Tc` \ minus_sel_id ->
+ tcLookupValueByKey geClassOpKey `thenNF_Tc` \ ge_sel_id ->
+ tcLookupValueByKey minusClassOpKey `thenNF_Tc` \ minus_sel_id ->
newOverloadedLit origin
(OverloadedIntegral i) pat_ty `thenNF_Tc` \ (over_lit_expr, lie1) ->
- newMethod origin (RealId ge_sel_id) [pat_ty] `thenNF_Tc` \ (lie2, ge_id) ->
- newMethod origin (RealId minus_sel_id) [pat_ty] `thenNF_Tc` \ (lie3, minus_id) ->
+ newMethod origin ge_sel_id [pat_ty] `thenNF_Tc` \ (lie2, ge_id) ->
+ newMethod origin minus_sel_id [pat_ty] `thenNF_Tc` \ (lie3, minus_id) ->
- returnTc (NPlusKPat (TcId bndr_id) lit pat_ty
+ returnTc (NPlusKPat bndr_id lit pat_ty
(SectionR (HsVar ge_id) over_lit_expr)
(SectionR (HsVar minus_id) over_lit_expr),
lie1 `plusLIE` lie2 `plusLIE` lie3,
Helper functions
\begin{code}
-tcPats :: (Name -> Maybe (TcIdBndr s)) -- Info about signatures
- -> [RenamedPat] -> [TcType s] -- Excess 'expected types' discarded
- -> TcM s ([TcPat s],
- LIE s, -- Required by n+k and literal pats
- Bag (TcTyVar s),
- Bag (Name, TcIdBndr s), -- Ids bound by the pattern
- LIE s) -- Dicts bound by the pattern
+tcPats :: (Name -> Maybe TcId) -- Info about signatures
+ -> [RenamedPat] -> [TcType] -- Excess 'expected types' discarded
+ -> TcM s ([TcPat],
+ LIE, -- Required by n+k and literal pats
+ Bag TcTyVar,
+ Bag (Name, TcId), -- Ids bound by the pattern
+ LIE) -- Dicts bound by the pattern
tcPats sig_fn [] tys = returnTc ([], emptyLIE, emptyBag, emptyBag, emptyLIE)
tcOverloadedLitPat pat lit over_lit pat_ty
= newOverloadedLit (PatOrigin pat) over_lit pat_ty `thenNF_Tc` \ (over_lit_expr, lie1) ->
- tcLookupGlobalValueByKey eqClassOpKey `thenNF_Tc` \ eq_sel_id ->
- newMethod origin (RealId eq_sel_id) [pat_ty] `thenNF_Tc` \ (lie2, eq_id) ->
+ tcLookupValueByKey eqClassOpKey `thenNF_Tc` \ eq_sel_id ->
+ newMethod origin eq_sel_id [pat_ty] `thenNF_Tc` \ (lie2, eq_id) ->
returnTc (NPat lit pat_ty (HsApp (HsVar eq_id)
over_lit_expr),
\begin{code}
tcConstructor pat con_name pat_ty
= -- Check that it's a constructor
- tcLookupGlobalValue con_name `thenNF_Tc` \ con_id ->
+ tcLookupValue con_name `thenNF_Tc` \ con_id ->
case isDataConId_maybe con_id of {
Nothing -> failWithTc (badCon con_id);
Just data_con ->
in
tcInstTyVars (ex_tvs ++ tvs) `thenNF_Tc` \ (all_tvs', ty_args', tenv) ->
let
- ex_theta' = substFlexiTheta tenv ex_theta
- arg_tys' = map (substFlexiTy tenv) arg_tys
+ ex_theta' = substTopTheta tenv ex_theta
+ arg_tys' = map (substTopTy tenv) arg_tys
n_ex_tvs = length ex_tvs
ex_tvs' = take n_ex_tvs all_tvs'
badFieldCon con field
= hsep [ptext SLIT("Constructor") <+> quotes (ppr con),
ptext SLIT("does not have field"), quotes (ppr field)]
+
+polyPatSig :: TcType -> SDoc
+polyPatSig sig_ty
+ = hang (ptext SLIT("Polymorphic type signature in pattern"))
+ 4 (ppr sig_ty)
\end{code}
#include "HsVersions.h"
-import CmdLineOpts ( opt_MaxContextReductionDepth )
+import CmdLineOpts ( opt_MaxContextReductionDepth, opt_GlasgowExts )
import HsSyn ( MonoBinds(..), HsExpr(..), andMonoBinds, andMonoBindList )
-import TcHsSyn ( TcExpr, TcIdOcc(..), TcIdBndr,
+import TcHsSyn ( TcExpr, TcId,
TcMonoBinds, TcDictBinds
)
Inst, LIE, pprInsts, pprInstsInFull, mkLIE, emptyLIE,
plusLIE, pprOrigin
)
-import TcEnv ( TcIdOcc(..), tcGetGlobalTyVars )
+import TcEnv ( tcGetGlobalTyVars )
import TcType ( TcType, TcTyVarSet, typeToTcType )
import TcUnify ( unifyTauTy )
import Id ( idType )
import PrelInfo ( isNumericClass, isCreturnableClass )
import Type ( Type, ThetaType, TauType, mkTyVarTy, getTyVar,
- isTyVarTy, substFlexiTheta, splitSigmaTy,
- tyVarsOfTypes
+ isTyVarTy, substTopTheta, splitSigmaTy, tyVarsOfTypes
)
import PprType ( pprConstraint )
import TysWiredIn ( unitTy )
tcSimplify
:: SDoc
-> TopLevelFlag
- -> TcTyVarSet s -- ``Local'' type variables
+ -> TcTyVarSet -- ``Local'' type variables
-- ASSERT: this tyvar set is already zonked
- -> LIE s -- Wanted
- -> TcM s (LIE s, -- Free
- TcDictBinds s, -- Bindings
- LIE s) -- Remaining wanteds; no dups
+ -> LIE -- Wanted
+ -> TcM s (LIE, -- Free
+ TcDictBinds, -- Bindings
+ LIE) -- Remaining wanteds; no dups
tcSimplify str top_lvl local_tvs wanted_lie
| isEmptyVarSet local_tvs
\begin{code}
tcSimplifyAndCheck
:: SDoc
- -> TcTyVarSet s -- ``Local'' type variables
- -- ASSERT: this tyvar set is already zonked
- -> LIE s -- Given; constrain only local tyvars
- -> LIE s -- Wanted
- -> TcM s (LIE s, -- Free
- TcDictBinds s) -- Bindings
+ -> TcTyVarSet -- ``Local'' type variables
+ -- ASSERT: this tyvar set is already zonked
+ -> LIE -- Given; constrain only local tyvars
+ -> LIE -- Wanted
+ -> TcM s (LIE, -- Free
+ TcDictBinds) -- Bindings
tcSimplifyAndCheck str local_tvs given_lie wanted_lie
| isEmptyVarSet local_tvs
where
givens = bagToList given_lie
wanteds = bagToList wanted_lie
+ given_dicts = filter isDict givens
try_me inst
-- Does not constrain a local tyvar
= ReduceMe AddToIrreds
complain dict = mapNF_Tc zonkInst givens `thenNF_Tc` \ givens ->
- addNoInstanceErr str givens dict
+ addNoInstanceErr str given_dicts dict
\end{code}
| FreeIfTautological -- Return as free iff it's tautological;
-- if not, return as irreducible
+ -- The FreeIfTautological case is to allow the possibility
+ -- of generating functions with types like
+ -- f :: C Int => Int -> Int
+ -- Here, the C Int isn't a tautology presumably because Int
+ -- isn't an instance of C in this module; but perhaps it will
+ -- be at f's call site(s). Haskell doesn't allow this at
+ -- present.
data NoInstanceAction
= Stop -- Fail; no error message
\begin{code}
type RedState s
= (Avails s, -- What's available
- [Inst s], -- Insts for which try_me returned Free
- [Inst s] -- Insts for which try_me returned DontReduce
+ [Inst], -- Insts for which try_me returned Free
+ [Inst] -- Insts for which try_me returned DontReduce
)
-type Avails s = FiniteMap (Inst s) (Avail s)
+type Avails s = FiniteMap Inst Avail
-data Avail s
+data Avail
= Avail
- (TcIdOcc s) -- The "main Id"; that is, the Id for the Inst that
+ TcId -- The "main Id"; that is, the Id for the Inst that
-- caused this avail to be put into the finite map in the first place
-- It is this Id that is bound to the RHS.
- (RHS s) -- The RHS: an expression whose value is that Inst.
+ RHS -- The RHS: an expression whose value is that Inst.
-- The main Id should be bound to this RHS
- [TcIdOcc s] -- Extra Ids that must all be bound to the main Id.
+ [TcId] -- Extra Ids that must all be bound to the main Id.
-- At the end we generate a list of bindings
-- { i1 = main_id; i2 = main_id; i3 = main_id; ... }
-data RHS s
+data RHS
= NoRhs -- Used for irreducible dictionaries,
-- which are going to be lambda bound, or for those that are
-- suppplied as "given" when checking againgst a signature.
-- where no witness is required.
| Rhs -- Used when there is a RHS
- (TcExpr s)
+ TcExpr
Bool -- True => the RHS simply selects a superclass dictionary
-- from a subclass dictionary.
-- False => not so.
-- an (Ord t) dictionary; then we put an (Eq t) entry in
-- the finite map, with an PassiveScSel. Then if the
-- the (Eq t) binding is ever *needed* we make it an Rhs
- (TcExpr s)
- [Inst s] -- List of Insts that are free in the RHS.
+ TcExpr
+ [Inst] -- List of Insts that are free in the RHS.
-- If the main Id is subsequently needed, we toss this list into
-- the needed-inst pool so that we make sure their bindings
-- will actually be produced.
The main entry point for context reduction is @reduceContext@:
\begin{code}
-reduceContext :: SDoc -> (Inst s -> WhatToDo)
- -> [Inst s] -- Given
- -> [Inst s] -- Wanted
- -> TcM s (TcDictBinds s,
- [Inst s], -- Free
- [Inst s]) -- Irreducible
+reduceContext :: SDoc -> (Inst -> WhatToDo)
+ -> [Inst] -- Given
+ -> [Inst] -- Wanted
+ -> TcM s (TcDictBinds,
+ [Inst], -- Free
+ [Inst]) -- Irreducible
reduceContext str try_me givens wanteds
= -- Zonking first
The main context-reduction function is @reduce@. Here's its game plan.
\begin{code}
-reduceList :: (Int,[Inst s])
- -> (Inst s -> WhatToDo)
- -> [Inst s]
+reduceList :: (Int,[Inst]) -- Stack (for err msgs)
+ -- along with its depth
+ -> (Inst -> WhatToDo)
+ -> [Inst]
-> RedState s
-> TcM s (RedState s)
\end{code}
It returns a RedState.
+The (n,stack) pair is just used for error reporting.
+n is always the depth of the stack.
+The stack is the stack of Insts being reduced: to produce X
+I had to produce Y, to produce Y I had to produce Z, and so on.
\begin{code}
reduceList (n,stack) try_me wanteds state
| otherwise
=
#ifdef DEBUG
- (if n > 4 then
+ (if n > 8 then
pprTrace "Jeepers! ReduceContext:" (reduceDepthMsg n stack)
else (\x->x))
#endif
-- Base case: we're done!
reduce stack try_me wanted state@(avails, frees, irreds)
-
-- It's the same as an existing inst, or a superclass thereof
| wanted `elemFM` avails
= returnTc (activate avails wanted, frees, irreds)
- -- It should be reduced
- | case try_me_result of { ReduceMe _ -> True; _ -> False }
- = lookupInst wanted `thenNF_Tc` \ lookup_result ->
-
- case lookup_result of
- GenInst wanteds' rhs -> use_instance wanteds' rhs
- SimpleInst rhs -> use_instance [] rhs
-
- NoInstance -> -- No such instance!
- -- Decide what to do based on the no_instance_action requested
- case no_instance_action of
- Stop -> failTc -- Fail
- AddToIrreds -> add_to_irreds -- Add the offending insts to the irreds
-
- -- It's free and this isn't a top-level binding, so just chuck it upstairs
- | case try_me_result of { Free -> True; _ -> False }
- = -- First, see if the inst can be reduced to a constant in one step
- lookupInst wanted `thenNF_Tc` \ lookup_result ->
- case lookup_result of
- SimpleInst rhs -> use_instance [] rhs
- other -> add_to_frees
-
- -- It's free and this is a top level binding, so
- -- check whether it's a tautology or not
- | case try_me_result of { FreeIfTautological -> True; _ -> False }
- = -- Try for tautology
- tryTc
- -- If tautology trial fails, add to irreds
- (addGiven avails wanted `thenNF_Tc` \ avails' ->
- returnTc (avails', frees, wanted:irreds))
+ | otherwise
+ = case try_me wanted of {
+
+ ReduceMe no_instance_action -> -- It should be reduced
+ lookupInst wanted `thenNF_Tc` \ lookup_result ->
+ case lookup_result of
+ GenInst wanteds' rhs -> use_instance wanteds' rhs
+ SimpleInst rhs -> use_instance [] rhs
+
+ NoInstance -> -- No such instance!
+ case no_instance_action of
+ Stop -> failTc
+ AddToIrreds -> add_to_irreds
+ ;
+ Free -> -- It's free and this isn't a top-level binding, so just chuck it upstairs
+ -- First, see if the inst can be reduced to a constant in one step
+ lookupInst wanted `thenNF_Tc` \ lookup_result ->
+ case lookup_result of
+ SimpleInst rhs -> use_instance [] rhs
+ other -> add_to_frees
+
+
+
+ ;
+ FreeIfTautological -> -- It's free and this is a top level binding, so
+ -- check whether it's a tautology or not
+ tryTc_
+ add_to_irreds -- If tautology trial fails, add to irreds
-- If tautology succeeds, just add to frees
- (reduce stack try_me_taut wanted (avails, [], []) `thenTc_`
+ (reduce stack try_me_taut wanted (avails, [], []) `thenTc_`
returnTc (avails, wanted:frees, irreds))
- -- It's irreducible (or at least should not be reduced)
- | otherwise
- = ASSERT( case try_me_result of { DontReduce -> True; other -> False } )
+ ;
+ DontReduce -> -- It's irreducible (or at least should not be reduced)
-- See if the inst can be reduced to a constant in one step
- lookupInst wanted `thenNF_Tc` \ lookup_result ->
- case lookup_result of
- SimpleInst rhs -> use_instance [] rhs
- other -> add_to_irreds
-
+ lookupInst wanted `thenNF_Tc` \ lookup_result ->
+ case lookup_result of
+ SimpleInst rhs -> use_instance [] rhs
+ other -> add_to_irreds
+ }
where
-- The three main actions
add_to_frees = let
use_instance wanteds' rhs = addWanted avails wanted rhs `thenNF_Tc` \ avails' ->
reduceList stack try_me wanteds' (avails', frees, irreds)
- try_me_result = try_me wanted
- ReduceMe no_instance_action = try_me_result
-- The try-me to use when trying to identify tautologies
-- It blunders on reducing as much as possible
\begin{code}
-activate :: Avails s -> Inst s -> Avails s
+activate :: Avails s -> Inst -> Avails s
-- Activate the binding for Inst, ensuring that a binding for the
-- wanted Inst will be generated.
-- (Activate its parent if necessary, recursively).
rhs | instBindingRequired wanted = Rhs rhs_expr False -- Not superclass selection
| otherwise = NoRhs
-addFree :: Avails s -> Inst s -> (Avails s)
+addFree :: Avails s -> Inst -> (Avails s)
-- When an Inst is tossed upstairs as 'free' we nevertheless add it
-- to avails, so that any other equal Insts will be commoned up right
- -- here rather than also being tossed upstairs.
+ -- here rather than also being tossed upstairs. This is really just
+ -- an optimisation, and perhaps it is more trouble that it is worth,
+ -- as the following comments show!
+ --
+ -- NB1: do *not* add superclasses. If we have
+ -- df::Floating a
+ -- dn::Num a
+ -- but a is not bound here, then we *don't* want to derive
+ -- dn from df here lest we lose sharing.
+ --
+ -- NB2: do *not* add the Inst to avails at all if it's a method.
+ -- The following situation shows why this is bad:
+ -- truncate :: forall a. RealFrac a => forall b. Integral b => a -> b
+ -- From an application (truncate f i) we get
+ -- t1 = truncate at f
+ -- t2 = t1 at i
+ -- If we have also have a secon occurrence of truncate, we get
+ -- t3 = truncate at f
+ -- t4 = t3 at i
+ -- When simplifying with i,f free, we might still notice that
+ -- t1=t3; but alas, the binding for t2 (which mentions t1)
+ -- will continue to float out!
+ -- Solution: never put methods in avail till they are captured
+ -- in which case addFree isn't used
addFree avails free
| isDict free = addToFM avails free (Avail (instToId free) NoRhs [])
| otherwise = avails
-addGiven :: Avails s -> Inst s -> NF_TcM s (Avails s)
+addGiven :: Avails s -> Inst -> NF_TcM s (Avails s)
addGiven avails given
= -- ASSERT( not (given `elemFM` avails) )
-- This assertion isn't necessarily true. It's permitted
addAvail avails wanted avail
= addSuperClasses (addToFM avails wanted avail) wanted
-addSuperClasses :: Avails s -> Inst s -> NF_TcM s (Avails s)
+addSuperClasses :: Avails s -> Inst -> NF_TcM s (Avails s)
-- Add all the superclasses of the Inst to Avails
-- Invariant: the Inst is already in Avails.
(clas, tys) = getDictClassTys dict
(tyvars, sc_theta, sc_sels, _, _) = classBigSig clas
- sc_theta' = substFlexiTheta (zipVarEnv tyvars tys) sc_theta
+ sc_theta' = substTopTheta (zipVarEnv tyvars tys) sc_theta
add_sc avails ((super_clas, super_tys), sc_sel)
= newDictFromOld dict super_clas super_tys `thenNF_Tc` \ super_dict ->
let
- sc_sel_rhs = DictApp (TyApp (HsVar (RealId sc_sel))
- tys)
+ sc_sel_rhs = DictApp (TyApp (HsVar sc_sel) tys)
[instToId dict]
in
case lookupFM avails super_dict of
\begin{code}
tcSimplifyThetas :: (Class -> ClassInstEnv) -- How to find the ClassInstEnv
-> ThetaType -- Wanted
- -> TcM s ThetaType -- Needed; of the form C a b c
- -- where a,b,c are type variables
+ -> TcM s ThetaType -- Needed
tcSimplifyThetas inst_mapper wanteds
= reduceSimple inst_mapper [] wanteds `thenNF_Tc` \ irreds ->
let
- -- Check that the returned dictionaries are of the form (C a b c)
+ -- For multi-param Haskell, check that the returned dictionaries
+ -- don't have any of the form (C Int Bool) for which
+ -- we expect an instance here
+ -- For Haskell 98, check that all the constraints are of the form C a,
+ -- where a is a type variable
bad_guys | opt_GlasgowExts = [ct | ct@(clas,tys) <- irreds,
isEmptyVarSet (tyVarsOfTypes tys)]
| otherwise = [ct | ct@(clas,tys) <- irreds,
not (all isTyVarTy tys)]
-
in
if null bad_guys then
returnTc irreds
= foldl add givens sc_theta
where
(tyvars, sc_theta_tmpl, _, _, _) = classBigSig clas
- sc_theta = substFlexiTheta (zipVarEnv tyvars tys) sc_theta_tmpl
+ sc_theta = substTopTheta (zipVarEnv tyvars tys) sc_theta_tmpl
add givens ct = case lookupFM givens ct of
Nothing -> -- Add it and its superclasses
@LIE@), as well as the @HsBinds@ generated.
\begin{code}
-bindInstsOfLocalFuns :: LIE s -> [TcIdBndr s] -> TcM s (LIE s, TcMonoBinds s)
+bindInstsOfLocalFuns :: LIE -> [TcId] -> TcM s (LIE, TcMonoBinds)
bindInstsOfLocalFuns init_lie local_ids
| null overloaded_ids || null lie_for_here
all the constant and ambiguous Insts.
\begin{code}
-tcSimplifyTop :: LIE s -> TcM s (TcDictBinds s)
+tcSimplifyTop :: LIE -> TcM s TcDictBinds
tcSimplifyTop wanted_lie
= reduceContext (text "tcSimplTop") try_me [] wanteds `thenTc` \ (binds1, frees, irreds) ->
ASSERT( null frees )
@void@.
\begin{code}
-disambigGroup :: [Inst s] -- All standard classes of form (C a)
- -> TcM s (TcDictBinds s)
+disambigGroup :: [Inst] -- All standard classes of form (C a)
+ -> TcM s TcDictBinds
disambigGroup dicts
| any isNumericClass classes -- Guaranteed all standard classes
= failTc
try_default (default_ty : default_tys)
- = tryTc (try_default default_tys) $ -- If default_ty fails, we try
+ = tryTc_ (try_default default_tys) $ -- If default_ty fails, we try
-- default_tys instead
tcSimplifyCheckThetas [] thetas `thenTc` \ _ ->
returnTc default_ty
addErrTcM (tidy_env,
sep [sep [ptext SLIT("Could not deduce") <+> quotes (pprInst tidy_dict),
nest 4 $ parens $ pprOrigin dict],
- nest 4 $ ptext SLIT("from the context") <+> pprInsts tidy_givens]
+ nest 4 $ ptext SLIT("from the context:") <+> pprInsts tidy_givens]
$$
ptext SLIT("Probable cause:") <+>
- vcat [ptext SLIT("missing") <+> quotes (pprInst tidy_dict) <+> ptext SLIT("in") <+> str,
+ vcat [sep [ptext SLIT("missing") <+> quotes (pprInst tidy_dict),
+ ptext SLIT("in") <+> str],
if all_tyvars then empty else
ptext SLIT("or missing instance declaration for") <+> quotes (pprInst tidy_dict)]
)
\begin{code}
module TcTyClsDecls (
- tcTyAndClassDecls1
+ tcTyAndClassDecls
) where
#include "HsVersions.h"
-import HsSyn ( HsDecl(..), TyDecl(..), ClassDecl(..),
+import HsSyn ( HsDecl(..), TyClDecl(..),
HsType(..), HsTyVar,
ConDecl(..), ConDetails(..), BangType(..),
Sig(..),
- hsDeclName
+ tyClDeclName, isClassDecl, isSynDecl
)
-import RnHsSyn ( RenamedHsDecl )
-import RnEnv ( listTyCon_name, tupleTyCon_name ) -- ToDo: move these
-import BasicTypes ( RecFlag(..), Arity )
+import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, listTyCon_name, tupleTyCon_name )
+import BasicTypes ( RecFlag(..), NewOrData(..), Arity )
import TcMonad
import Inst ( InstanceMapper )
-import TcClassDcl ( tcClassDecl1 )
-import TcEnv ( TcIdOcc(..), GlobalValueEnv, tcExtendTyConEnv, tcExtendClassEnv )
-import TcType ( TcKind, newKindVar, newKindVars, kindToTcKind )
-import TcTyDecls ( tcTyDecl )
-import TcMonoType ( tcTyVarScope )
+import TcClassDcl ( kcClassDecl, tcClassDecl1 )
+import TcEnv ( ValueEnv, TcTyThing(..),
+ tcExtendTypeEnv
+ )
+import TcTyDecls ( tcTyDecl, kcTyDecl )
+import TcMonoType ( kcHsTyVar )
+import TcType ( TcKind, newKindVar, newKindVars, kindToTcKind, zonkTcKindToKind )
-import TyCon ( tyConKind, tyConArity, isSynTyCon )
+import Type ( mkArrowKind, boxedTypeKind )
import Class ( Class, classBigSig )
import Var ( tyVarKind )
import Bag
import UniqSet ( UniqSet, emptyUniqSet,
unitUniqSet, unionUniqSets,
unionManyUniqSets, uniqSetToList )
+import ErrUtils ( ErrMsg )
import SrcLoc ( SrcLoc )
import TyCon ( TyCon )
import Unique ( Unique, Uniquable(..) )
-import Util ( panic{-, pprTrace-} )
-
+import UniqFM ( listToUFM, lookupUFM )
\end{code}
The main function
~~~~~~~~~~~~~~~~~
\begin{code}
-tcTyAndClassDecls1 :: GlobalValueEnv -> InstanceMapper -- Knot tying stuff
- -> [RenamedHsDecl]
- -> TcM s (TcEnv s)
+tcTyAndClassDecls :: ValueEnv -> InstanceMapper -- Knot tying stuff
+ -> [RenamedHsDecl]
+ -> TcM s TcEnv
-tcTyAndClassDecls1 unf_env inst_mapper decls
+tcTyAndClassDecls unf_env inst_mapper decls
= sortByDependency decls `thenTc` \ groups ->
tcGroups unf_env inst_mapper groups
returnTc env
tcGroups unf_env inst_mapper (group:groups)
- = tcGroup unf_env inst_mapper group `thenTc` \ (group_tycons, group_classes) ->
-
- -- Extend the environment using the new tycons and classes
- tcExtendTyConEnv [(getName tycon, (kindToTcKind (tyConKind tycon),
- if isSynTyCon tycon then Just (tyConArity tycon) else Nothing,
- tycon))
- | tycon <- group_tycons] $
-
- tcExtendClassEnv [(getName clas, (classKind clas, clas))
- | clas <- group_classes] $
-
-
- -- Do the remaining groups
+ = tcGroup unf_env inst_mapper group `thenTc` \ env ->
+ tcSetEnv env $
tcGroups unf_env inst_mapper groups
- where
- classKind clas = map (kindToTcKind . tyVarKind) tyvars
- where
- (tyvars, _, _, _, _) = classBigSig clas
\end{code}
Dealing with a group
~~~~~~~~~~~~~~~~~~~~
-Notice the uses of @zipLazy@, which makes sure
-that the knot-tied TyVars, TyCons and Classes aren't looked at too early.
-
-
\begin{code}
-tcGroup :: GlobalValueEnv -> InstanceMapper -> SCC RenamedHsDecl -> TcM s ([TyCon], [Class])
+tcGroup :: ValueEnv -> InstanceMapper -> SCC RenamedTyClDecl -> TcM s TcEnv
tcGroup unf_env inst_mapper scc
- = -- TIE THE KNOT
- fixTc ( \ ~(rec_tycons, rec_classes) ->
-
- -- EXTEND TYPE AND CLASS ENVIRONMENTS
- let
- mk_tycon_bind (name, arity) = newKindVar `thenNF_Tc` \ kind ->
- returnNF_Tc (name, (kind, arity, find name rec_tycons))
-
- mk_class_bind (name, arity) = newKindVars arity `thenNF_Tc` \ kinds ->
- returnNF_Tc (name, (kinds, find name rec_classes))
-
- find name [] = pprPanic "tcGroup" (ppr name)
- find name (thing:things) | name == getName thing = thing
- | otherwise = find name things
-
- in
- mapNF_Tc mk_tycon_bind tycon_names_w_arities `thenNF_Tc` \ tycon_binds ->
- mapNF_Tc mk_class_bind class_names_w_arities `thenNF_Tc` \ class_binds ->
- tcExtendTyConEnv tycon_binds $
- tcExtendClassEnv class_binds $
-
- -- DEAL WITH TYPE VARIABLES
- tcTyVarScope tyvar_names ( \ tyvars ->
-
- -- DEAL WITH THE DEFINITIONS THEMSELVES
- foldlTc (tcDecl is_rec_group unf_env inst_mapper) ([], []) decls
- ) `thenTc` \ (tycons, classes) ->
-
- returnTc (tycons, classes)
- )
+ = -- Do kind checking
+ mapNF_Tc getTyBinding1 decls `thenNF_Tc` \ ty_env_stuff1 ->
+ tcExtendTypeEnv ty_env_stuff1 (mapTc kcDecl decls) `thenTc_`
+
+ -- Tie the knot
+-- traceTc (ppr (map fst ty_env_stuff1)) `thenTc_`
+ fixTc ( \ ~(rec_tyclss, _) ->
+ let
+ rec_env = listToUFM rec_tyclss
+ in
+
+ -- Do type checking
+ mapNF_Tc (getTyBinding2 rec_env) ty_env_stuff1 `thenNF_Tc` \ ty_env_stuff2 ->
+ tcExtendTypeEnv ty_env_stuff2 $
+ mapTc (tcDecl is_rec_group unf_env inst_mapper) decls `thenTc` \ tyclss ->
+
+ tcGetEnv `thenTc` \ env ->
+ returnTc (tyclss, env)
+ ) `thenTc` \ (_, env) ->
+-- traceTc (text "done" <+> ppr (map fst ty_env_stuff1)) `thenTc_`
+ returnTc env
where
is_rec_group = case scc of
AcyclicSCC _ -> NonRecursive
decls = case scc of
AcyclicSCC decl -> [decl]
CyclicSCC decls -> decls
-
- (tyvar_names, tycon_names_w_arities, class_names_w_arities) = get_binders decls
\end{code}
Dealing with one decl
~~~~~~~~~~~~~~~~~~~~~
\begin{code}
+kcDecl decl
+ = tcAddDeclCtxt decl $
+ if isClassDecl decl then
+ kcClassDecl decl
+ else
+ kcTyDecl decl
+
tcDecl :: RecFlag -- True => recursive group
- -> GlobalValueEnv -> InstanceMapper
- -> ([TyCon], [Class]) -- Accumulating parameter
- -> RenamedHsDecl
- -> TcM s ([TyCon], [Class])
-
-tcDecl is_rec_group unf_env inst_mapper (tycons, classes) (TyD decl)
- = tcTyDecl is_rec_group decl `thenTc` \ tycon ->
- returnTc (tycon:tycons, classes)
-
-tcDecl is_rec_group unf_env inst_mapper (tycons, classes) (ClD decl)
- = tcClassDecl1 unf_env inst_mapper decl `thenTc` \ clas ->
- returnTc (tycons, clas:classes)
+ -> ValueEnv -> InstanceMapper
+ -> RenamedTyClDecl -> TcM s (Name, TcTyThing)
+
+tcDecl is_rec_group unf_env inst_mapper decl
+ = tcAddDeclCtxt decl $
+-- traceTc (text "Starting" <+> ppr name) `thenTc_`
+ if isClassDecl decl then
+ tcClassDecl1 unf_env inst_mapper decl `thenTc` \ clas ->
+-- traceTc (text "Finished" <+> ppr name) `thenTc_`
+ returnTc (getName clas, AClass clas)
+ else
+ tcTyDecl is_rec_group decl `thenTc` \ tycon ->
+-- traceTc (text "Finished" <+> ppr name) `thenTc_`
+ returnTc (getName tycon, ATyCon tycon)
+
+ where
+ name = tyClDeclName decl
+
+
+tcAddDeclCtxt decl thing_inside
+ = tcAddSrcLoc loc $
+ tcAddErrCtxt ctxt $
+ thing_inside
+ where
+ (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")
+
+ ctxt = hsep [ptext SLIT("In the"), text thing,
+ ptext SLIT("declaration for"), quotes (ppr name)]
+\end{code}
+
+
+getTyBinders
+~~~~~~~~~~~
+Extract *binding* names from type and class decls. Type variables are
+bound in type, data, newtype and class declarations,
+ *and* the polytypes in the class op sigs.
+ *and* the existentially quantified contexts in datacon decls
+
+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.]
+
+Because we can only commit to the final kind of a type variable when
+we've completed the mutually recursive group. For example:
+
+class C a where
+ op :: D b => a -> b -> b
+
+class D c where
+ bop :: (Monad c) => ...
+
+Here, the kind of the locally-polymorphic type variable "b"
+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.
+
+
+\begin{code}
+getTyBinding1 :: RenamedTyClDecl -> NF_TcM s (Name, (TcKind, Maybe Arity, 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))))
+
+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")))
+
+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")))
+
+-- Zonk the kind to its final form, and lookup the
+-- recursive tycon/class
+getTyBinding2 rec_env (name, (tc_kind, maybe_arity, thing))
+ = zonkTcKindToKind tc_kind `thenNF_Tc` \ kind ->
+ returnNF_Tc (name, (kind, maybe_arity, mk_thing thing (lookupUFM rec_env name)))
+ where
+ mk_thing (ATyCon _) ~(Just (ATyCon tc)) = ATyCon tc
+ mk_thing (AClass _) ~(Just (AClass cls)) = AClass cls
\end{code}
+
+%************************************************************************
+%* *
+\subsection{Dependency analysis}
+%* *
+%************************************************************************
+
Dependency analysis
~~~~~~~~~~~~~~~~~~~
\begin{code}
-sortByDependency :: [RenamedHsDecl] -> TcM s [SCC RenamedHsDecl]
+sortByDependency :: [RenamedHsDecl] -> TcM s [SCC RenamedTyClDecl]
sortByDependency decls
= let -- CHECK FOR CLASS CYCLES
- cls_sccs = stronglyConnComp (mapMaybe mk_cls_edges decls)
+ cls_sccs = stronglyConnComp (mapMaybe mk_cls_edges tycl_decls)
cls_cycles = [ decls | CyclicSCC decls <- cls_sccs]
in
checkTc (null cls_cycles) (classCycleErr cls_cycles) `thenTc_`
in
returnTc decl_sccs
where
- edges = mapMaybe mk_edges decls
+ tycl_decls = [d | TyClD d <- decls]
+ edges = map mk_edges tycl_decls
-is_syn_decl (TyD (TySynonym _ _ _ _), _, _) = True
-is_syn_decl _ = False
-
-is_cls_decl (ClD _, _, _) = True
-is_cls_decl other = False
+ is_syn_decl (d, _, _) = isSynDecl d
+ is_cls_decl (d, _, _) = isClassDecl d
\end{code}
Edges in Type/Class decls
~~~~~~~~~~~~~~~~~~~~~~~~~
+
\begin{code}
+----------------------------------------------------
-- mk_cls_edges looks only at the context of class decls
-- Its used when we are figuring out if there's a cycle in the
-- superclass hierarchy
-mk_cls_edges :: RenamedHsDecl -> Maybe (RenamedHsDecl, Unique, [Unique])
+mk_cls_edges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Unique, [Unique])
-mk_cls_edges decl@(ClD (ClassDecl ctxt name _ _ _ _ _ _ _))
+mk_cls_edges decl@(ClassDecl ctxt name _ _ _ _ _ _ _)
= Just (decl, getUnique name, map (getUnique . fst) ctxt)
mk_cls_edges other_decl
= Nothing
+----------------------------------------------------
+mk_edges :: RenamedTyClDecl -> (RenamedTyClDecl, Unique, [Unique])
-mk_edges :: RenamedHsDecl -> Maybe (RenamedHsDecl, Unique, [Unique])
-
-mk_edges decl@(TyD (TyData _ ctxt name _ condecls derivs _ _))
- = Just (decl, getUnique name, uniqSetToList (get_ctxt ctxt `unionUniqSets`
+mk_edges decl@(TyData _ ctxt name _ condecls derivs _ _)
+ = (decl, getUnique name, uniqSetToList (get_ctxt ctxt `unionUniqSets`
get_cons condecls `unionUniqSets`
get_deriv derivs))
-mk_edges decl@(TyD (TySynonym name _ rhs _))
- = Just (decl, getUnique name, uniqSetToList (get_ty rhs))
+mk_edges decl@(TySynonym name _ rhs _)
+ = (decl, getUnique name, uniqSetToList (get_ty rhs))
-mk_edges decl@(ClD (ClassDecl ctxt name _ sigs _ _ _ _ _))
- = Just (decl, getUnique name, uniqSetToList (get_ctxt ctxt `unionUniqSets`
+mk_edges decl@(ClassDecl ctxt name _ sigs _ _ _ _ _)
+ = (decl, getUnique name, uniqSetToList (get_ctxt ctxt `unionUniqSets`
get_sigs sigs))
-mk_edges other_decl = Nothing
+----------------------------------------------------
get_ctxt ctxt = unionManyUniqSets (map (set_name.fst) ctxt)
+----------------------------------------------------
get_deriv Nothing = emptyUniqSet
get_deriv (Just clss) = unionManyUniqSets (map set_name clss)
+----------------------------------------------------
get_cons cons = unionManyUniqSets (map get_con cons)
+----------------------------------------------------
get_con (ConDecl _ _ ctxt details _)
= get_ctxt ctxt `unionUniqSets` get_con_details details
+----------------------------------------------------
get_con_details (VanillaCon btys) = unionManyUniqSets (map get_bty btys)
get_con_details (InfixCon bty1 bty2) = unionUniqSets (get_bty bty1) (get_bty bty2)
-get_con_details (NewCon ty) = get_ty ty
+get_con_details (NewCon ty) = get_ty ty
get_con_details (RecCon nbtys) = unionManyUniqSets (map (get_bty.snd) nbtys)
+----------------------------------------------------
get_bty (Banged ty) = get_ty ty
get_bty (Unbanged ty) = get_ty ty
+----------------------------------------------------
get_ty (MonoTyVar name)
= if isTvOcc (nameOccName name) then emptyUniqSet else set_name name
get_ty (MonoTyApp ty1 ty2)
= get_ctxt ctxt `unionUniqSets` get_ty mty
get_ty other = panic "TcTyClsDecls:get_ty"
+----------------------------------------------------
get_tys tys
= unionManyUniqSets (map get_ty tys)
+----------------------------------------------------
get_sigs sigs
= unionManyUniqSets (map get_sig sigs)
where
get_sig (ClassOpSig _ _ ty _) = get_ty ty
get_sig other = panic "TcTyClsDecls:get_sig"
+----------------------------------------------------
set_name name = unitUniqSet (getUnique name)
-
set_to_bag set = listToBag (uniqSetToList set)
\end{code}
-get_binders
-~~~~~~~~~~~
-Extract *binding* names from type and class decls. Type variables are
-bound in type, data, newtype and class declarations,
- *and* the polytypes in the class op sigs.
- *and* the existentially quantified contexts in datacon decls
-
-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.]
-
-Because we can only commit to the final kind of a type variable when
-we've completed the mutually recursive group. For example:
-
-class C a where
- op :: D b => a -> b -> b
-
-class D c where
- bop :: (Monad c) => ...
-
-Here, the kind of the locally-polymorphic type variable "b"
-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.
-
-
\begin{code}
-get_binders :: [RenamedHsDecl]
- -> ([HsTyVar Name], -- TyVars; no dups
- [(Name, Maybe Arity)], -- Tycons; no dups; arities for synonyms
- [(Name, Arity)]) -- Classes; no dups; with their arities
-
-get_binders decls = (bagToList tyvars, bagToList tycons, bagToList classes)
- where
- (tyvars, tycons, classes) = foldr (union3 . get_binders1)
- (emptyBag,emptyBag,emptyBag)
- decls
-
- union3 (a1,a2,a3) (b1,b2,b3)
- = (a1 `unionBags` b1, a2 `unionBags` b2, a3 `unionBags` b3)
-
-get_binders1 (TyD (TySynonym name tyvars _ _))
- = (listToBag tyvars, unitBag (name, Just (length tyvars)), emptyBag)
-get_binders1 (TyD (TyData _ _ name tyvars condecls _ _ _))
- = (listToBag tyvars `unionBags` cons_tvs condecls,
- unitBag (name,Nothing), emptyBag)
-get_binders1 (ClD (ClassDecl _ name tyvars sigs _ _ _ _ _))
- = (listToBag tyvars `unionBags` sigs_tvs sigs,
- emptyBag, unitBag (name, length tyvars))
-
-cons_tvs condecls = unionManyBags (map con_tvs condecls)
- where
- con_tvs (ConDecl _ tvs _ _ _) = listToBag tvs
+typeCycleErr, classCycleErr :: [[RenamedTyClDecl]] -> ErrMsg
-sigs_tvs sigs = unionManyBags (map sig_tvs sigs)
- where
- sig_tvs (ClassOpSig _ _ ty _) = pty_tvs ty
- pty_tvs (HsForAllTy tvs _ _) = listToBag tvs -- tvs doesn't include the class tyvar
- pty_tvs other = emptyBag
-\end{code}
-
-
-\begin{code}
typeCycleErr syn_cycles
= vcat (map (pp_cycle "Cycle in type declarations:") syn_cycles)
pp_decl decl
= hsep [quotes (ppr name), ptext SLIT("at"), ppr (getSrcLoc name)]
where
- name = hsDeclName decl
+ name = tyClDeclName decl
\end{code}
\begin{code}
module TcTyDecls (
- tcTyDecl,
+ tcTyDecl, kcTyDecl,
tcConDecl,
mkDataBinds
) where
#include "HsVersions.h"
import HsSyn ( MonoBinds(..),
- TyDecl(..), ConDecl(..), ConDetails(..), BangType(..),
+ TyClDecl(..), ConDecl(..), ConDetails(..), BangType(..),
andMonoBindList
)
-import RnHsSyn ( RenamedTyDecl, RenamedConDecl )
+import RnHsSyn ( RenamedTyClDecl, RenamedConDecl )
import TcHsSyn ( TcMonoBinds )
import BasicTypes ( RecFlag(..), NewOrData(..), StrictnessMark(..) )
-import Inst ( InstOrigin(..) )
-import TcMonoType ( tcHsTypeKind, tcHsType, tcContext )
-import TcEnv ( TcIdOcc(..),
- tcLookupTyCon, tcLookupClass,
- tcLookupTyVarBndrs
+import TcMonoType ( tcExtendTopTyVarScope, tcExtendTyVarScope,
+ tcHsTypeKind, tcHsType, tcHsTopType, tcHsTopBoxedType,
+ tcContext
)
+import TcEnv ( tcLookupTy, TcTyThing(..) )
import TcMonad
import TcUnify ( unifyKind )
import CoreUnfold ( getUnfoldingTemplate )
import FieldLabel
import Var ( Id, TyVar )
-import Name ( isLocallyDefined, OccName(..), NamedThing(..) )
+import Name ( isLocallyDefined, OccName, NamedThing(..) )
import Outputable
import TyCon ( TyCon, mkSynTyCon, mkAlgTyCon, isAlgTyCon,
isSynTyCon, tyConDataCons
)
-import Type ( typeKind, getTyVar, tyVarsOfTypes,
+import Type ( getTyVar, tyVarsOfTypes,
mkTyConApp, mkTyVarTys, mkForAllTys, mkFunTy,
mkTyVarTy,
mkArrowKind, mkArrowKinds, boxedTypeKind,
)
import Var ( tyVarKind )
import VarSet ( intersectVarSet, isEmptyVarSet )
-import Util ( equivClasses, panic, assertPanic )
+import Util ( equivClasses )
\end{code}
+%************************************************************************
+%* *
+\subsection{Kind checking}
+%* *
+%************************************************************************
+
\begin{code}
-tcTyDecl :: RecFlag -> RenamedTyDecl -> TcM s TyCon
-\end{code}
+kcTyDecl :: RenamedTyClDecl -> TcM s ()
+
+kcTyDecl (TySynonym name tyvar_names rhs src_loc)
+ = 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, _, _) ->
+ tcExtendTopTyVarScope kind tyvar_names $ \ result_kind _ ->
+ tcContext context `thenTc_`
+ mapTc kcConDecl con_decls `thenTc_`
+ returnTc ()
+
+kcConDecl (ConDecl _ ex_tvs ex_ctxt details loc)
+ = tcAddSrcLoc loc (
+ tcExtendTyVarScope ex_tvs ( \ tyvars ->
+ tcContext ex_ctxt `thenTc_`
+ kc_con details `thenTc_`
+ returnTc ()
+ ))
+ where
+ kc_con (VanillaCon btys) = mapTc kc_bty btys `thenTc_` returnTc ()
+ kc_con (InfixCon bty1 bty2) = mapTc kc_bty [bty1,bty2] `thenTc_` returnTc ()
+ kc_con (NewCon ty) = tcHsType ty `thenTc_` returnTc ()
+ kc_con (RecCon flds) = mapTc kc_field flds `thenTc_` returnTc ()
-Type synonym decls
-~~~~~~~~~~~~~~~~~~
+ kc_bty (Banged ty) = tcHsType ty
+ kc_bty (Unbanged ty) = tcHsType ty
-\begin{code}
-tcTyDecl is_rec (TySynonym tycon_name tyvar_names rhs src_loc)
- = tcAddSrcLoc src_loc $
- tcAddErrCtxt (tySynCtxt tycon_name) $
+ kc_field (_, bty) = kc_bty bty
+\end{code}
- -- Look up the pieces
- tcLookupTyCon tycon_name `thenTc` \ (tycon_kind, _, rec_tycon) ->
- tcLookupTyVarBndrs tyvar_names `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
- -- Look at the rhs
- tcHsTypeKind rhs `thenTc` \ (rhs_kind, rhs_ty) ->
+%************************************************************************
+%* *
+\subsection{Type checking}
+%* *
+%************************************************************************
- -- Unify tycon kind with (k1->...->kn->rhs)
- unifyKind tycon_kind (mkArrowKinds tyvar_kinds rhs_kind) `thenTc_`
+\begin{code}
+tcTyDecl :: RecFlag -> RenamedTyClDecl -> TcM s TyCon
+
+tcTyDecl is_rec (TySynonym tycon_name tyvar_names rhs src_loc)
+ = tcLookupTy tycon_name `thenNF_Tc` \ (tycon_kind, Just arity, _) ->
+ tcExtendTopTyVarScope tycon_kind tyvar_names $ \ tyvars _ ->
+ tcHsTopType rhs `thenTc` \ rhs_ty ->
let
-- Construct the tycon
- kind = mkArrowKinds (map tyVarKind rec_tyvars) (typeKind rhs_ty)
- tycon = mkSynTyCon (getName tycon_name)
- kind
- (length tyvar_names)
- rec_tyvars
- rhs_ty
+ tycon = mkSynTyCon tycon_name tycon_kind arity tyvars rhs_ty
in
returnTc tycon
-\end{code}
-Algebraic data and newtype decls
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-\begin{code}
tcTyDecl is_rec (TyData data_or_new context tycon_name tyvar_names con_decls derivings pragmas src_loc)
- = tcAddSrcLoc src_loc $
- let ctxt = case data_or_new of
- NewType -> tyNewCtxt tycon_name
- DataType -> tyDataCtxt tycon_name
- in
- tcAddErrCtxt ctxt $
+ = -- Lookup the pieces
+ tcLookupTy tycon_name `thenNF_Tc` \ (tycon_kind, _, ATyCon rec_tycon) ->
+ tcExtendTopTyVarScope tycon_kind tyvar_names $ \ tyvars _ ->
- -- Lookup the pieces
- tcLookupTyCon tycon_name `thenTc` \ (tycon_kind, _, rec_tycon) ->
- tcLookupTyVarBndrs tyvar_names `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
- tc_derivs derivings `thenTc` \ derived_classes ->
+ -- Typecheck the pieces
+ tcContext context `thenTc` \ ctxt ->
+ mapTc (tcConDecl rec_tycon tyvars ctxt) con_decls `thenTc` \ data_cons ->
+ tc_derivs derivings `thenTc` \ derived_classes ->
- -- Typecheck the context
- tcContext context `thenTc` \ ctxt ->
-
- -- Unify tycon kind with (k1->...->kn->Type)
- unifyKind tycon_kind (mkArrowKinds tyvar_kinds boxedTypeKind) `thenTc_`
-
- -- Walk the condecls
- mapTc (tcConDecl rec_tycon rec_tyvars ctxt) con_decls
- `thenTc` \ data_cons ->
let
-- Construct the tycon
real_data_or_new = case data_or_new of
NewType -> NewType
- DataType -> if all isNullaryDataCon data_cons then
- EnumType
- else
- DataType
-
- kind = foldr (mkArrowKind . tyVarKind) boxedTypeKind rec_tyvars
- tycon = mkAlgTyCon (getName tycon_name)
- kind
- rec_tyvars
- ctxt
+ DataType | all isNullaryDataCon data_cons -> EnumType
+ | otherwise -> DataType
+
+ tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt
data_cons
derived_classes
Nothing -- Not a dictionary
- real_data_or_new
- is_rec
+ real_data_or_new is_rec
in
returnTc tycon
+ where
+ tc_derivs Nothing = returnTc []
+ tc_derivs (Just ds) = mapTc tc_deriv ds
+
+ tc_deriv name = tcLookupTy name `thenTc` \ (_, _, AClass clas) ->
+ returnTc clas
+\end{code}
-tc_derivs Nothing = returnTc []
-tc_derivs (Just ds) = mapTc tc_deriv ds
-tc_deriv name
- = tcLookupClass name `thenTc` \ (_, clas) ->
- returnTc clas
+%************************************************************************
+%* *
+\subsection{Type check constructors}
+%* *
+%************************************************************************
+
+\begin{code}
+tcConDecl :: TyCon -> [TyVar] -> ThetaType -> RenamedConDecl -> TcM s DataCon
+
+tcConDecl tycon tyvars ctxt (ConDecl name ex_tvs ex_ctxt details src_loc)
+ = tcAddSrcLoc src_loc $
+ tcExtendTyVarScope ex_tvs $ \ ex_tyvars ->
+ tcContext ex_ctxt `thenTc` \ ex_theta ->
+ tc_con_decl_help tycon tyvars ctxt name ex_tyvars ex_theta details
+
+tc_con_decl_help tycon tyvars ctxt name ex_tyvars ex_theta details
+ = case details of
+ VanillaCon btys -> tc_datacon btys
+ InfixCon bty1 bty2 -> tc_datacon [bty1,bty2]
+ NewCon ty -> tc_newcon ty
+ RecCon fields -> tc_rec_con fields
+ where
+ tc_datacon btys
+ = let
+ arg_stricts = map get_strictness btys
+ tys = map get_pty btys
+ in
+ mapTc tcHsTopType tys `thenTc` \ arg_tys ->
+ returnTc (mk_data_con arg_stricts arg_tys [])
+
+ tc_newcon ty
+ = tcHsTopBoxedType ty `thenTc` \ arg_ty ->
+ -- can't allow an unboxed type here, because we're effectively
+ -- going to remove the constructor while coercing it to a boxed type.
+ returnTc (mk_data_con [NotMarkedStrict] [arg_ty] [])
+
+ tc_rec_con fields
+ = checkTc (null ex_tyvars) (exRecConErr name) `thenTc_`
+ mapTc tc_field fields `thenTc` \ field_label_infos_s ->
+ let
+ field_label_infos = concat field_label_infos_s
+ arg_stricts = [strict | (_, _, strict) <- field_label_infos]
+ arg_tys = [ty | (_, ty, _) <- field_label_infos]
+
+ field_labels = [ mkFieldLabel (getName name) ty tag
+ | ((name, ty, _), tag) <- field_label_infos `zip` allFieldLabelTags ]
+ in
+ returnTc (mk_data_con arg_stricts arg_tys field_labels)
+
+ tc_field (field_label_names, bty)
+ = tcHsTopType (get_pty bty) `thenTc` \ field_ty ->
+ returnTc [(name, field_ty, get_strictness bty) | name <- field_label_names]
+
+ mk_data_con arg_stricts arg_tys fields = data_con
+ where
+ data_con = mkDataCon name arg_stricts fields
+ tyvars (thinContext arg_tys ctxt)
+ ex_tyvars ex_theta
+ arg_tys
+ tycon data_con_id
+ data_con_id = mkDataConId data_con
+
+
+-- The context for a data constructor should be limited to
+-- the type variables mentioned in the arg_tys
+thinContext arg_tys ctxt
+ = filter in_arg_tys ctxt
+ where
+ arg_tyvars = tyVarsOfTypes arg_tys
+ in_arg_tys (clas,tys) = not $ isEmptyVarSet $
+ tyVarsOfTypes tys `intersectVarSet` arg_tyvars
+
+get_strictness (Banged _) = MarkedStrict
+get_strictness (Unbanged _) = NotMarkedStrict
+
+get_pty (Banged ty) = ty
+get_pty (Unbanged ty) = ty
\end{code}
-Generating constructor/selector bindings for data declarations
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+%************************************************************************
+%* *
+\subsection{Generating constructor/selector bindings for data declarations}
+%* *
+%************************************************************************
\begin{code}
-mkDataBinds :: [TyCon] -> TcM s ([Id], TcMonoBinds s)
+mkDataBinds :: [TyCon] -> TcM s ([Id], TcMonoBinds)
mkDataBinds [] = returnTc ([], EmptyMonoBinds)
mkDataBinds (tycon : tycons)
| isSynTyCon tycon = mkDataBinds tycons
-- For the locally-defined things
-- we need to turn the unfoldings inside the Ids into bindings,
- binds = [ CoreMonoBind (RealId data_id) (getUnfoldingTemplate (getIdUnfolding data_id))
+ binds = [ CoreMonoBind data_id (getUnfoldingTemplate (getIdUnfolding data_id))
| data_id <- data_ids, isLocallyDefined data_id
]
in
selector_id = mkRecordSelId first_field_label selector_ty
\end{code}
-Constructors
-~~~~~~~~~~~~
-\begin{code}
-tcConDecl :: TyCon -> [TyVar] -> ThetaType -> RenamedConDecl -> TcM s DataCon
-
-tcConDecl tycon tyvars ctxt (ConDecl name ex_tvs ex_ctxt details src_loc)
- = tcAddSrcLoc src_loc $
- tcLookupTyVarBndrs ex_tvs `thenNF_Tc` \ (kinds, ex_tyvars) ->
- tcContext ex_ctxt `thenTc` \ ex_theta ->
- tc_con_help tycon tyvars ctxt name ex_tyvars ex_theta details
-
-tc_con_help tycon tyvars ctxt name ex_tyvars ex_theta (VanillaCon btys)
- = tc_datacon_help tycon tyvars ctxt name ex_tyvars ex_theta btys
-
-tc_con_help tycon tyvars ctxt name ex_tyvars ex_theta (InfixCon bty1 bty2)
- = tc_datacon_help tycon tyvars ctxt name ex_tyvars ex_theta [bty1,bty2]
-
-tc_con_help tycon tyvars ctxt name ex_tyvars ex_theta (NewCon ty)
- = tcHsType ty `thenTc` \ arg_ty ->
- -- can't allow an unboxed type here, because we're effectively
- -- going to remove the constructor while coercing it to a boxed type.
- checkTc (not (isUnboxedType arg_ty)) (newTypeUnboxedField ty) `thenTc_`
- let
- data_con = mkDataCon (getName name)
- [NotMarkedStrict]
- [{- No labelled fields -}]
- tyvars
- ctxt
- ex_tyvars ex_theta
- [arg_ty]
- tycon data_con_id
- data_con_id = mkDataConId data_con
- in
- returnTc data_con
-
-tc_con_help tycon tyvars ctxt name ex_tyvars ex_theta (RecCon fields)
- = checkTc (null ex_tyvars) (exRecConErr name) `thenTc_`
- mapTc tcField fields `thenTc` \ field_label_infos_s ->
- let
- field_label_infos = concat field_label_infos_s
- arg_stricts = [strict | (_, _, strict) <- field_label_infos]
- arg_tys = [ty | (_, ty, _) <- field_label_infos]
-
- field_labels = [ mkFieldLabel (getName name) ty tag
- | ((name, ty, _), tag) <- field_label_infos `zip` allFieldLabelTags ]
-
- data_con = mkDataCon (getName name)
- arg_stricts
- field_labels
- tyvars
- (thinContext arg_tys ctxt)
- ex_tyvars ex_theta
- arg_tys
- tycon data_con_id
- data_con_id = mkDataConId data_con
- in
- returnTc data_con
-
-tcField (field_label_names, bty)
- = tcHsType (get_pty bty) `thenTc` \ field_ty ->
- returnTc [(name, field_ty, get_strictness bty) | name <- field_label_names]
-
-tc_datacon_help tycon tyvars ctxt name ex_tyvars ex_theta btys
- = let
- arg_stricts = map get_strictness btys
- tys = map get_pty btys
- in
- mapTc tcHsType tys `thenTc` \ arg_tys ->
- let
- data_con = mkDataCon (getName name)
- arg_stricts
- [{- No field labels -}]
- tyvars
- (thinContext arg_tys ctxt)
- ex_tyvars ex_theta
- arg_tys
- tycon data_con_id
- data_con_id = mkDataConId data_con
- in
- returnTc data_con
-
--- The context for a data constructor should be limited to
--- the type variables mentioned in the arg_tys
-thinContext arg_tys ctxt
- = filter in_arg_tys ctxt
- where
- arg_tyvars = tyVarsOfTypes arg_tys
- in_arg_tys (clas,tys) = not $ isEmptyVarSet $
- tyVarsOfTypes tys `intersectVarSet` arg_tyvars
-
-get_strictness (Banged _) = MarkedStrict
-get_strictness (Unbanged _) = NotMarkedStrict
-
-get_pty (Banged ty) = ty
-get_pty (Unbanged ty) = ty
-\end{code}
-
-
Errors and contexts
~~~~~~~~~~~~~~~~~~~
\begin{code}
-tySynCtxt tycon_name
- = hsep [ptext SLIT("In the type declaration for"), quotes (ppr tycon_name)]
-
-tyDataCtxt tycon_name
- = hsep [ptext SLIT("In the data declaration for"), quotes (ppr tycon_name)]
-
-tyNewCtxt tycon_name
- = hsep [ptext SLIT("In the newtype declaration for"), quotes (ppr tycon_name)]
-
fieldTypeMisMatch field_name
= sep [ptext SLIT("Declared types differ for field"), quotes (ppr field_name)]
-newTypeUnboxedField ty
- = sep [ptext SLIT("Newtype constructor field has an unboxed type:"),
- quotes (ppr ty)]
-
exRecConErr name
= ptext SLIT("Can't combine named fields with locally-quantified type variables")
$$
\begin{code}
module TcType (
- TcTyVar, TcBox,
+ TcTyVar,
TcTyVarSet,
- newTcTyVar,
- newTyVarTy, -- Kind -> NF_TcM s (TcType s)
- newTyVarTys, -- Int -> Kind -> NF_TcM s [TcType s]
+ newTyVar,
+ newTyVarTy, -- Kind -> NF_TcM s TcType
+ newTyVarTys, -- Int -> Kind -> NF_TcM s [TcType]
+
+ newTyVarTy_OpenKind, -- NF_TcM s TcType
+ newOpenTypeKind, -- NF_TcM s TcKind
-----------------------------------------
- TcType, TcMaybe(..),
- TcTauType, TcThetaType, TcRhoType,
+ TcType, TcTauType, TcThetaType, TcRhoType,
-- Find the type to which a type variable is bound
- tcWriteTyVar, -- :: TcTyVar s -> TcType s -> NF_TcM (TcType s)
- tcReadTyVar, -- :: TcTyVar s -> NF_TcM (TcMaybe s)
+ tcPutTyVar, -- :: TcTyVar -> TcType -> NF_TcM TcType
+ tcGetTyVar, -- :: TcTyVar -> NF_TcM (Maybe TcType) does shorting out
tcSplitRhoTy,
typeToTcType,
+ tcTypeKind, -- :: TcType -> NF_TcM s TcKind
--------------------------------
TcKind,
newKindVar, newKindVars,
-- friends:
-import PprType ()
-import Type ( Type, Kind, ThetaType, GenType(..), TyNote(..),
- mkAppTy,
+import PprType ( pprType )
+import Type ( Type(..), Kind, ThetaType, TyNote(..),
+ mkAppTy, mkTyConApp,
splitDictTy_maybe, splitForAllTys,
- isTyVarTy, mkTyVarTys,
- fullSubstTy, substFlexiTy,
- boxedTypeKind, superKind
+ isTyVarTy, mkTyVarTy, mkTyVarTys,
+ fullSubstTy, substTopTy,
+ typeCon, openTypeKind, boxedTypeKind, boxedKind, superKind, superBoxity
)
+import TyCon ( tyConKind )
import VarEnv
import VarSet ( emptyVarSet )
-import Var ( TyVar, GenTyVar, tyVarKind, tyVarFlexi, tyVarName,
- mkFlexiTyVar, removeTyVarFlexi, isFlexiTyVar, isTyVar
- )
+import Var ( TyVar, tyVarKind, tyVarName, isTyVar, isMutTyVar, mkTyVar )
-- others:
import TcMonad
-import Name ( changeUnique )
-
import TysWiredIn ( voidTy )
-import Name ( NamedThing(..), changeUnique, mkSysLocalName )
+import Name ( NamedThing(..), setNameUnique, mkSysLocalName )
import Unique ( Unique )
import Util ( nOfThem )
import Outputable
-Data types
+Coercions
~~~~~~~~~~
-See TcMonad.lhs
+Type definitions are in TcMonad.lhs
\begin{code}
-tcTyVarToTyVar :: TcTyVar s -> TyVar
-tcTyVarToTyVar = removeTyVarFlexi
+typeToTcType :: Type -> TcType
+typeToTcType ty = ty
+
+kindToTcKind :: Kind -> TcKind
+kindToTcKind kind = kind
\end{code}
Utility functions
to a for-all type.
\begin{code}
-tcSplitRhoTy :: TcType s -> NF_TcM s (TcThetaType s, TcType s)
+tcSplitRhoTy :: TcType -> NF_TcM s (TcThetaType, TcType)
tcSplitRhoTy t
= go t t []
where
Just pair -> go res res (pair:ts)
Nothing -> returnNF_Tc (reverse ts, syn_t)
go syn_t (NoteTy _ t) ts = go syn_t t ts
- go syn_t (TyVarTy tv) ts = tcReadTyVar tv `thenNF_Tc` \ maybe_ty ->
+ go syn_t (TyVarTy tv) ts = tcGetTyVar tv `thenNF_Tc` \ maybe_ty ->
case maybe_ty of
- BoundTo ty | not (isTyVarTy ty) -> go syn_t ty ts
- other -> returnNF_Tc (reverse ts, syn_t)
+ Just ty | not (isTyVarTy ty) -> go syn_t ty ts
+ other -> returnNF_Tc (reverse ts, syn_t)
go syn_t t ts = returnNF_Tc (reverse ts, syn_t)
\end{code}
-New type variables
-~~~~~~~~~~~~~~~~~~
+%************************************************************************
+%* *
+\subsection{New type variables}
+%* *
+%************************************************************************
\begin{code}
-newTcTyVar :: Kind -> NF_TcM s (TcTyVar s)
-newTcTyVar kind
+newTyVar :: Kind -> NF_TcM s TcTyVar
+newTyVar kind
= tcGetUnique `thenNF_Tc` \ uniq ->
- tcNewMutVar UnBound `thenNF_Tc` \ box ->
- let
- name = mkSysLocalName uniq
- in
- returnNF_Tc (mkFlexiTyVar name kind box)
+ tcNewMutTyVar (mkSysLocalName uniq SLIT("t")) kind
-newTyVarTy :: Kind -> NF_TcM s (TcType s)
+newTyVarTy :: Kind -> NF_TcM s TcType
newTyVarTy kind
- = newTcTyVar kind `thenNF_Tc` \ tc_tyvar ->
+ = newTyVar kind `thenNF_Tc` \ tc_tyvar ->
returnNF_Tc (TyVarTy tc_tyvar)
-newTyVarTys :: Int -> Kind -> NF_TcM s [TcType s]
+newTyVarTys :: Int -> Kind -> NF_TcM s [TcType]
newTyVarTys n kind = mapNF_Tc newTyVarTy (nOfThem n kind)
-newKindVar :: NF_TcM s (TcKind s)
-newKindVar = newTyVarTy superKind
+newKindVar :: NF_TcM s TcKind
+newKindVar
+ = tcGetUnique `thenNF_Tc` \ uniq ->
+ tcNewMutTyVar (mkSysLocalName uniq SLIT("k")) superKind `thenNF_Tc` \ kv ->
+ returnNF_Tc (TyVarTy kv)
-newKindVars :: Int -> NF_TcM s [TcKind s]
+newKindVars :: Int -> NF_TcM s [TcKind]
newKindVars n = mapNF_Tc (\ _ -> newKindVar) (nOfThem n ())
+
+-- Returns a type variable of kind (Type bv) where bv is a new boxity var
+-- Used when you need a type variable that's definitely a , but you don't know
+-- what kind of type (boxed or unboxed).
+newTyVarTy_OpenKind :: NF_TcM s TcType
+newTyVarTy_OpenKind = newOpenTypeKind `thenNF_Tc` \ kind ->
+ newTyVarTy kind
+
+newOpenTypeKind :: NF_TcM s TcKind
+newOpenTypeKind = newTyVarTy superBoxity `thenNF_Tc` \ bv ->
+ returnNF_Tc (mkTyConApp typeCon [bv])
\end{code}
-Type instantiation
-~~~~~~~~~~~~~~~~~~
+
+%************************************************************************
+%* *
+\subsection{Type instantiation}
+%* *
+%************************************************************************
Instantiating a bunch of type variables
\begin{code}
-tcInstTyVars :: [GenTyVar flexi]
- -> NF_TcM s ([TcTyVar s], [TcType s], TyVarEnv (TcType s))
+tcInstTyVars :: [TyVar]
+ -> NF_TcM s ([TcTyVar], [TcType], TyVarEnv TcType)
tcInstTyVars tyvars
= mapNF_Tc inst_tyvar tyvars `thenNF_Tc` \ tc_tyvars ->
inst_tyvar tyvar -- Could use the name from the tyvar?
= tcGetUnique `thenNF_Tc` \ uniq ->
- tcNewMutVar UnBound `thenNF_Tc` \ box ->
let
- name = changeUnique (tyVarName tyvar) uniq
+ kind = tyVarKind tyvar
+ name = setNameUnique (tyVarName tyvar) uniq
-- Note that we don't change the print-name
-- This won't confuse the type checker but there's a chance
-- that two different tyvars will print the same way
-- Better watch out for this. If worst comes to worst, just
-- use mkSysLocalName.
in
- returnNF_Tc (mkFlexiTyVar name (tyVarKind tyvar) box)
+ tcNewMutTyVar name kind
\end{code}
@tcInstTcType@ instantiates the outer-level for-alls of a TcType with
fresh type variables, returning them and the instantiated body of the for-all.
-
\begin{code}
-tcInstTcType :: TcType s -> NF_TcM s ([TcTyVar s], TcType s)
+tcInstTcType :: TcType -> NF_TcM s ([TcTyVar], TcType)
tcInstTcType ty
- = let
- (tyvars, rho) = splitForAllTys ty
- in
- case tyvars of
- [] -> returnNF_Tc ([], ty) -- Nothing to do
- other -> tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', _, tenv) ->
- returnNF_Tc (tyvars', fullSubstTy tenv emptyVarSet rho)
+ = case splitForAllTys ty of
+ ([], _) -> returnNF_Tc ([], ty) -- Nothing to do
+ (tyvars, rho) -> tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', _, tenv) ->
+ returnNF_Tc (tyvars', fullSubstTy tenv emptyVarSet rho)
-- Since the tyvars are freshly made,
-- they cannot possibly be captured by
-- any existing for-alls. Hence emptyVarSet
\end{code}
-Sometimes we have to convert a Type to a TcType. I wonder whether we could
-do this less than we do?
-\begin{code}
-typeToTcType :: Type -> TcType s
-typeToTcType t = substFlexiTy emptyVarEnv t
-
-kindToTcKind :: Kind -> TcKind s
-kindToTcKind = typeToTcType
-\end{code}
+%************************************************************************
+%* *
+\subsection{Putting and getting mutable type variables}
+%* *
+%************************************************************************
-Reading and writing TcTyVars
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
-tcWriteTyVar :: TcTyVar s -> TcType s -> NF_TcM s ()
-tcReadTyVar :: TcTyVar s -> NF_TcM s (TcMaybe s)
+tcPutTyVar :: TcTyVar -> TcType -> NF_TcM s TcType
+tcGetTyVar :: TcTyVar -> NF_TcM s (Maybe TcType)
\end{code}
-Writing is easy:
+Putting is easy:
\begin{code}
-tcWriteTyVar tyvar ty = tcWriteMutVar (tyVarFlexi tyvar) (BoundTo ty)
+tcPutTyVar tyvar ty = tcWriteMutTyVar tyvar (Just ty) `thenNF_Tc_`
+ returnNF_Tc ty
\end{code}
-Reading is more interesting. The easy thing to do is just to read, thus:
+Getting is more interesting. The easy thing to do is just to read, thus:
+
\begin{verbatim}
-tcReadTyVar tyvar = tcReadMutVar (tyVarFlexi tyvar)
+tcGetTyVar tyvar = tcReadMutTyVar tyvar
\end{verbatim}
But it's more fun to short out indirections on the way: If this
We return Nothing iff the original box was unbound.
\begin{code}
-tcReadTyVar tyvar
- = tcReadMutVar box `thenNF_Tc` \ maybe_ty ->
+tcGetTyVar tyvar
+ = ASSERT2( isMutTyVar tyvar, ppr tyvar )
+ tcReadMutTyVar tyvar `thenNF_Tc` \ maybe_ty ->
case maybe_ty of
- BoundTo ty -> short_out ty `thenNF_Tc` \ ty' ->
- tcWriteMutVar box (BoundTo ty') `thenNF_Tc_`
- returnNF_Tc (BoundTo ty')
+ Just ty -> short_out ty `thenNF_Tc` \ ty' ->
+ tcWriteMutTyVar tyvar (Just ty') `thenNF_Tc_`
+ returnNF_Tc (Just ty')
- other -> returnNF_Tc other
- where
- box = tyVarFlexi tyvar
+ Nothing -> returnNF_Tc Nothing
-short_out :: TcType s -> NF_TcM s (TcType s)
+short_out :: TcType -> NF_TcM s TcType
short_out ty@(TyVarTy tyvar)
- = tcReadMutVar box `thenNF_Tc` \ maybe_ty ->
+ | not (isMutTyVar tyvar)
+ = returnNF_Tc ty
+
+ | otherwise
+ = tcReadMutTyVar tyvar `thenNF_Tc` \ maybe_ty ->
case maybe_ty of
- BoundTo ty' -> short_out ty' `thenNF_Tc` \ ty' ->
- tcWriteMutVar box (BoundTo ty') `thenNF_Tc_`
- returnNF_Tc ty'
+ Just ty' -> short_out ty' `thenNF_Tc` \ ty' ->
+ tcWriteMutTyVar tyvar (Just ty') `thenNF_Tc_`
+ returnNF_Tc ty'
- other -> returnNF_Tc ty
- where
- box = tyVarFlexi tyvar
+ other -> returnNF_Tc ty
short_out other_ty = returnNF_Tc other_ty
\end{code}
-Zonking Tc types to Tc types
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-\begin{code}
-zonkTcTyVars :: [TcTyVar s] -> NF_TcM s [TcType s]
-zonkTcTyVars tyvars = mapNF_Tc zonkTcTyVar tyvars
+%************************************************************************
+%* *
+\subsection{Zonking -- the exernal interfaces}
+%* *
+%************************************************************************
-zonkTcTyVar :: TcTyVar s -> NF_TcM s (TcType s)
-zonkTcTyVar tyvar
- | not (isFlexiTyVar tyvar) -- Not a flexi tyvar. This can happen when
- -- zonking a forall type, when the bound type variable
- -- needn't be a flexi.
- = ASSERT( isTyVar tyvar )
- returnNF_Tc (TyVarTy tyvar)
+----------------- Type variables
- | otherwise -- Is a flexi tyvar
- = tcReadTyVar tyvar `thenNF_Tc` \ maybe_ty ->
- case maybe_ty of
- BoundTo ty@(TyVarTy tyvar') -> returnNF_Tc ty -- tcReadTyVar never returns a bound tyvar
- BoundTo other -> zonkTcType other
- other -> returnNF_Tc (TyVarTy tyvar)
+\begin{code}
+zonkTcTyVars :: [TcTyVar] -> NF_TcM s [TcType]
+zonkTcTyVars tyvars = mapNF_Tc zonkTcTyVar tyvars
-zonkTcTyVarBndr :: TcTyVar s -> NF_TcM s (TcTyVar s)
+zonkTcTyVarBndr :: TcTyVar -> NF_TcM s TcTyVar
zonkTcTyVarBndr tyvar
= zonkTcTyVar tyvar `thenNF_Tc` \ (TyVarTy tyvar') ->
returnNF_Tc tyvar'
-zonkTcTypes :: [TcType s] -> NF_TcM s [TcType s]
+zonkTcTyVar :: TcTyVar -> NF_TcM s TcType
+zonkTcTyVar tyvar = zonkTyVar (\ tv -> returnNF_Tc (TyVarTy tv)) tyvar
+\end{code}
+
+----------------- Types
+
+\begin{code}
+zonkTcType :: TcType -> NF_TcM s TcType
+zonkTcType ty = zonkType (\ tv -> returnNF_Tc (TyVarTy tv)) ty
+
+zonkTcTypes :: [TcType] -> NF_TcM s [TcType]
zonkTcTypes tys = mapNF_Tc zonkTcType tys
-zonkTcThetaType :: TcThetaType s -> NF_TcM s (TcThetaType s)
+zonkTcThetaType :: TcThetaType -> NF_TcM s TcThetaType
zonkTcThetaType theta = mapNF_Tc zonk theta
where
- zonk (c,ts) = zonkTcTypes ts `thenNF_Tc` \ new_ts ->
- returnNF_Tc (c, new_ts)
+ zonk (c,ts) = zonkTcTypes ts `thenNF_Tc` \ new_ts ->
+ returnNF_Tc (c, new_ts)
-zonkTcKind :: TcKind s -> NF_TcM s (TcKind s)
+zonkTcKind :: TcKind -> NF_TcM s TcKind
zonkTcKind = zonkTcType
+\end{code}
-zonkTcType :: TcType s -> NF_TcM s (TcType s)
-
-zonkTcType (TyVarTy tyvar) = zonkTcTyVar tyvar
-
-zonkTcType (AppTy ty1 ty2)
- = zonkTcType ty1 `thenNF_Tc` \ ty1' ->
- zonkTcType ty2 `thenNF_Tc` \ ty2' ->
- returnNF_Tc (mkAppTy ty1' ty2')
-
-zonkTcType (TyConApp tc tys)
- = mapNF_Tc zonkTcType tys `thenNF_Tc` \ tys' ->
- returnNF_Tc (TyConApp tc tys')
-
-zonkTcType (NoteTy (SynNote ty1) ty2)
- = zonkTcType ty1 `thenNF_Tc` \ ty1' ->
- zonkTcType ty2 `thenNF_Tc` \ ty2' ->
- returnNF_Tc (NoteTy (SynNote ty1') ty2')
+------------------- These ...ToType, ...ToKind versions
+ are used at the end of type checking
-zonkTcType (NoteTy (FTVNote _) ty2) = zonkTcType ty2
+\begin{code}
+zonkTcKindToKind :: TcKind -> NF_TcM s Kind
+zonkTcKindToKind kind = zonkType zonk_unbound_kind_var kind
+ where
+ -- Zonk a mutable but unbound kind variable to
+ -- (Type Boxed) if it has kind superKind
+ -- Boxed if it has kind superBoxity
+ zonk_unbound_kind_var kv
+ | super_kind == superKind = tcPutTyVar kv boxedTypeKind
+ | otherwise = ASSERT( super_kind == superBoxity )
+ tcPutTyVar kv boxedKind
+ where
+ super_kind = tyVarKind kv
+
+
+zonkTcTypeToType :: TcType -> NF_TcM s Type
+zonkTcTypeToType ty = zonkType zonk_unbound_tyvar ty
+ where
+ -- Zonk a mutable but unbound type variable to
+ -- Void if it has kind (Type Boxed)
+ -- Voidxxx otherwise
+ zonk_unbound_tyvar tv
+ = zonkTcKindToKind (tyVarKind tv) `thenNF_Tc` \ kind ->
+ if kind == boxedTypeKind then
+ tcPutTyVar tv voidTy -- Just to creating a new tycon in
+ -- this vastly common case
+ else
+ tcPutTyVar tv (TyConApp (mk_void_tycon tv) [])
+
+ mk_void_tycon tv -- Make a new TyCon with the same kind as the
+ -- type variable tv. Same name too, apart from
+ -- making it start with a capital letter (sigh)
+ -- I can't quite bring myself to write the Name-fiddling
+ -- code yet. ToDo. SLPJ Nov 98
+ = pprPanic "zonkTcTypeToType: free type variable with non-* type:" (ppr tv)
+
+
+-- zonkTcTyVarToTyVar is applied to the *binding* occurrence
+-- of a type variable, at the *end* of type checking.
+-- It zonks the type variable, to get a mutable, but unbound, tyvar, tv;
+-- zonks its kind, and then makes an immutable version of tv and binds tv to it.
+-- Now any bound occurences of the original type variable will get
+-- zonked to the immutable version.
+
+zonkTcTyVarToTyVar :: TcTyVar -> NF_TcM s TyVar
+zonkTcTyVarToTyVar tv
+ = zonkTcKindToKind (tyVarKind tv) `thenNF_Tc` \ kind ->
+ let
+ -- Make an immutable version
+ immut_tv = mkTyVar (tyVarName tv) kind
+ immut_tv_ty = mkTyVarTy immut_tv
+
+ zap tv = tcPutTyVar tv immut_tv_ty
+ -- Bind the mutable version to the immutable one
+ in
+ -- If the type variable is mutable, then bind it to immut_tv_ty
+ -- so that all other occurrences of the tyvar will get zapped too
+ zonkTyVar zap tv `thenNF_Tc` \ ty2 ->
+ ASSERT2( immut_tv_ty == ty2, ppr tv $$ ppr immut_tv $$ ppr ty2 )
+
+ returnNF_Tc immut_tv
+\end{code}
-zonkTcType (ForAllTy tv ty)
- = zonkTcTyVar tv `thenNF_Tc` \ tv_ty ->
- zonkTcType ty `thenNF_Tc` \ ty' ->
- case tv_ty of -- Should be a tyvar!
- TyVarTy tv' -> returnNF_Tc (ForAllTy tv' ty')
- _ -> panic "zonkTcType"
- -- pprTrace "zonkTcType:ForAllTy:" (hsep [ppr tv, ppr tv_ty]) $
- -- returnNF_Tc (ForAllTy tv{-(tcTyVarToTyVar tv)-} ty')
-zonkTcType (FunTy ty1 ty2)
- = zonkTcType ty1 `thenNF_Tc` \ ty1' ->
- zonkTcType ty2 `thenNF_Tc` \ ty2' ->
- returnNF_Tc (FunTy ty1' ty2')
-\end{code}
+%************************************************************************
+%* *
+\subsection{Zonking -- the main work-horses: zonkType, zonkTyVar}
+%* *
+%* For internal use only! *
+%* *
+%************************************************************************
-Zonking Tc types to Type/Kind
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
-zonkTcKindToKind :: TcKind s -> NF_TcM s Kind
-zonkTcKindToKind kind = zonkTcToType boxedTypeKind emptyVarEnv kind
+-- zonkType is used for Kinds as well
-zonkTcTypeToType :: TyVarEnv Type -> TcType s -> NF_TcM s Type
-zonkTcTypeToType env ty = zonkTcToType voidTy env ty
-
-zonkTcTyVarToTyVar :: TcTyVar s -> NF_TcM s TyVar
-zonkTcTyVarToTyVar tv
- = zonkTcTyVarBndr tv `thenNF_Tc` \ tv' ->
- returnNF_Tc (tcTyVarToTyVar tv')
+-- For unbound, mutable tyvars, zonkType uses the function given to it
+-- For tyvars bound at a for-all, zonkType zonks them to an immutable
+-- type variable and zonks the kind too
--- zonkTcToType is used for Kinds as well
-zonkTcToType :: Type -> TyVarEnv Type -> TcType s -> NF_TcM s Type
-zonkTcToType unbound_var_ty env ty
+zonkType :: (TcTyVar -> NF_TcM s Type) -- What to do with unbound mutable type variables
+ -- see zonkTcType, and zonkTcTypeToType
+ -> TcType
+ -> NF_TcM s Type
+zonkType unbound_var_fn ty
= go ty
where
go (TyConApp tycon tys) = mapNF_Tc go tys `thenNF_Tc` \ tys' ->
returnNF_Tc (mkAppTy fun' arg')
-- The two interesting cases!
- -- c.f. zonkTcTyVar
- go (TyVarTy tyvar)
- | not (isFlexiTyVar tyvar) = lookup env tyvar
-
- | otherwise = tcReadTyVar tyvar `thenNF_Tc` \ maybe_ty ->
- case maybe_ty of
- BoundTo (TyVarTy tyvar') -> lookup env tyvar'
- BoundTo other_ty -> go other_ty
- other -> lookup env tyvar
+ go (TyVarTy tyvar) = zonkTyVar unbound_var_fn tyvar
go (ForAllTy tyvar ty)
= zonkTcTyVarToTyVar tyvar `thenNF_Tc` \ tyvar' ->
- let
- new_env = extendVarEnv env tyvar (TyVarTy tyvar')
- in
- zonkTcToType unbound_var_ty new_env ty `thenNF_Tc` \ ty' ->
+ go ty `thenNF_Tc` \ ty' ->
returnNF_Tc (ForAllTy tyvar' ty')
- lookup env tyvar = returnNF_Tc (case lookupVarEnv env tyvar of
- Just ty -> ty
- Nothing -> unbound_var_ty)
+zonkTyVar :: (TcTyVar -> NF_TcM s Type) -- What to do for an unbound mutable variable
+ -> TcTyVar -> NF_TcM s TcType
+zonkTyVar unbound_var_fn tyvar
+ | not (isMutTyVar tyvar) -- Not a mutable tyvar. This can happen when
+ -- zonking a forall type, when the bound type variable
+ -- needn't be mutable
+ = ASSERT( isTyVar tyvar ) -- Should not be any immutable kind vars
+ returnNF_Tc (TyVarTy tyvar)
+
+ | otherwise
+ = tcGetTyVar tyvar `thenNF_Tc` \ maybe_ty ->
+ case maybe_ty of
+ Nothing -> unbound_var_fn tyvar -- Mutable and unbound
+ Just other_ty -> zonkType unbound_var_fn other_ty -- Bound
\end{code}
+%************************************************************************
+%* *
+\subsection{tcTypeKind}
+%* *
+%************************************************************************
+
+Sadly, we need a Tc version of typeKind, that looks though mutable
+kind variables. See the notes with Type.typeKind for the typeKindF nonsense
+
+This is pretty gruesome.
+\begin{code}
+tcTypeKind :: TcType -> NF_TcM s TcKind
+
+tcTypeKind (TyVarTy tyvar) = returnNF_Tc (tyVarKind tyvar)
+tcTypeKind (TyConApp tycon tys) = foldlTc (\k _ -> tcFunResultTy k) (tyConKind tycon) tys
+tcTypeKind (NoteTy _ ty) = tcTypeKind ty
+tcTypeKind (AppTy fun arg) = tcTypeKind fun `thenNF_Tc` \ fun_kind ->
+ tcFunResultTy fun_kind
+tcTypeKind (FunTy fun arg) = tcTypeKindF arg
+tcTypeKind (ForAllTy _ ty) = tcTypeKindF ty
+
+tcTypeKindF :: TcType -> NF_TcM s TcKind
+tcTypeKindF (NoteTy _ ty) = tcTypeKindF ty
+tcTypeKindF (FunTy _ ty) = tcTypeKindF ty
+tcTypeKindF (ForAllTy _ ty) = tcTypeKindF ty
+tcTypeKindF other = tcTypeKind other `thenNF_Tc` \ kind ->
+ fix_up kind
+ where
+ fix_up (TyConApp kc _) | kc == typeCon = returnNF_Tc boxedTypeKind
+ -- Functions at the type level are always boxed
+ fix_up (NoteTy _ kind) = fix_up kind
+ fix_up kind@(TyVarTy tv) = tcGetTyVar tv `thenNF_Tc` \ maybe_ty ->
+ case maybe_ty of
+ Just kind' -> fix_up kind'
+ Nothing -> returnNF_Tc kind
+ fix_up kind = returnNF_Tc kind
+
+tcFunResultTy (NoteTy _ ty) = tcFunResultTy ty
+tcFunResultTy (FunTy arg res) = returnNF_Tc res
+tcFunResultTy (TyVarTy tv) = tcGetTyVar tv `thenNF_Tc` \ maybe_ty ->
+ case maybe_ty of
+ Just ty' -> tcFunResultTy ty'
+ -- The Nothing case, and the other cases for tcFunResultTy
+ -- should never happen... pattern match failure
+\end{code}
\begin{code}
module TcUnify ( unifyTauTy, unifyTauTyList, unifyTauTyLists,
unifyFunTy, unifyListTy, unifyTupleTy, unifyUnboxedTupleTy,
- unifyKind, unifyKinds
+ unifyKind, unifyKinds, unifyTypeKind
) where
#include "HsVersions.h"
-- friends:
import TcMonad
-import TcEnv ( tidyType, tidyTypes, tidyTyVar )
-import Type ( GenType(..), Type, tyVarsOfType, funTyCon,
- typeKind, mkFunTy, splitFunTy_maybe, splitTyConApp_maybe,
- Kind, hasMoreBoxityInfo, openTypeKind, boxedTypeKind, superKind,
- splitAppTy_maybe
+import Type ( Type(..), tyVarsOfType, funTyCon,
+ mkFunTy, splitFunTy_maybe, splitTyConApp_maybe,
+ Kind, boxedTypeKind, typeCon, anyBoxCon, anyBoxKind,
+ splitAppTy_maybe,
+ tidyOpenType, tidyOpenTypes, tidyTyVar
)
import TyCon ( TyCon, isTupleTyCon, isUnboxedTupleTyCon,
- tyConArity, matchesTyCon )
+ tyConArity )
import Name ( isSysLocalName )
import Var ( TyVar, tyVarKind, varName )
import VarEnv
import VarSet ( varSetElems )
-import TcType ( TcType, TcMaybe(..), TcTauType, TcTyVar,
- TcKind,
- newTyVarTy, tcReadTyVar, tcWriteTyVar, zonkTcType
+import TcType ( TcType, TcTauType, TcTyVar, TcKind,
+ newTyVarTy, newOpenTypeKind, newTyVarTy_OpenKind,
+ tcGetTyVar, tcPutTyVar, zonkTcType, tcTypeKind
)
-- others:
import BasicTypes ( Arity )
%************************************************************************
\begin{code}
-unifyKind :: TcKind s -- Expected
- -> TcKind s -- Actual
+unifyKind :: TcKind -- Expected
+ -> TcKind -- Actual
-> TcM s ()
unifyKind k1 k2
= tcAddErrCtxtM (unifyCtxt "kind" k1 k2) $
uTys k1 k1 k2 k2
-unifyKinds :: [TcKind s] -> [TcKind s] -> TcM s ()
+unifyKinds :: [TcKind] -> [TcKind] -> TcM s ()
unifyKinds [] [] = returnTc ()
unifyKinds (k1:ks1) (k2:ks2) = unifyKind k1 k2 `thenTc_`
unifyKinds ks1 ks2
Unify two @TauType@s. Dead straightforward.
\begin{code}
-unifyTauTy :: TcTauType s -> TcTauType s -> TcM s ()
+unifyTauTy :: TcTauType -> TcTauType -> TcM s ()
unifyTauTy ty1 ty2 -- ty1 expected, ty2 inferred
= tcAddErrCtxtM (unifyCtxt "type" ty1 ty2) $
uTys ty1 ty1 ty2 ty2
complain if their lengths differ.
\begin{code}
-unifyTauTyLists :: [TcTauType s] -> [TcTauType s] -> TcM s ()
+unifyTauTyLists :: [TcTauType] -> [TcTauType] -> TcM s ()
unifyTauTyLists [] [] = returnTc ()
unifyTauTyLists (ty1:tys1) (ty2:tys2) = uTys ty1 ty1 ty2 ty2 `thenTc_`
unifyTauTyLists tys1 tys2
lists, when all the elts should be of the same type.
\begin{code}
-unifyTauTyList :: [TcTauType s] -> TcM s ()
+unifyTauTyList :: [TcTauType] -> TcM s ()
unifyTauTyList [] = returnTc ()
unifyTauTyList [ty] = returnTc ()
unifyTauTyList (ty1:tys@(ty2:_)) = unifyTauTy ty1 ty2 `thenTc_`
We call the first one \tr{ps_ty1}, \tr{ps_ty2} for ``possible synomym''.
\begin{code}
-uTys :: TcTauType s -> TcTauType s -- Error reporting ty1 and real ty1
- -> TcTauType s -> TcTauType s -- Error reporting ty2 and real ty2
+uTys :: TcTauType -> TcTauType -- Error reporting ty1 and real ty1
+ -> TcTauType -> TcTauType -- Error reporting ty2 and real ty2
-> TcM s ()
-- Always expand synonyms (see notes at end)
-- Type constructors must match
uTys ps_ty1 (TyConApp con1 tys1) ps_ty2 (TyConApp con2 tys2)
- = checkTcM (con1 `matchesTyCon` con2 && length tys1 == length tys2)
+ = checkTcM (cons_match && length tys1 == length tys2)
(failWithTcM (unifyMisMatch ps_ty1 ps_ty2)) `thenTc_`
unifyTauTyLists tys1 tys2
+ where
+ -- The AnyBox wild card matches anything
+ cons_match = con1 == con2
+ || con1 == anyBoxCon
+ || con2 == anyBoxCon
-- Applications need a bit of care!
-- They can match FunTy and TyConApp, so use splitAppTy_maybe
Nothing -> failWithTcM (unifyMisMatch ps_ty1 ps_ty2)
-- Now the same, but the other way round
- -- ** DON'T ** swap the types, because when unifying kinds
- -- we need to check that the expected type has less boxity info
- -- than the inferred one; so we need to keep them the right way round
+ -- Don't swap the types, because the error messages get worse
uTys ps_ty1 ty1 ps_ty2 (AppTy s2 t2)
= case splitAppTy_maybe ty1 of
Just (s1,t1) -> uTys s1 s1 s2 s2 `thenTc_` uTys t1 t1 t2 t2
\begin{code}
uVar :: Bool -- False => tyvar is the "expected"
-- True => ty is the "expected" thing
- -> TcTyVar s
- -> TcTauType s -> TcTauType s -- printing and real versions
+ -> TcTyVar
+ -> TcTauType -> TcTauType -- printing and real versions
-> TcM s ()
uVar swapped tv1 ps_ty2 ty2
- = tcReadTyVar tv1 `thenNF_Tc` \ maybe_ty1 ->
+ = tcGetTyVar tv1 `thenNF_Tc` \ maybe_ty1 ->
case maybe_ty1 of
- BoundTo ty1 | swapped -> uTys ps_ty2 ty2 ty1 ty1 -- Swap back
- | otherwise -> uTys ty1 ty1 ps_ty2 ty2 -- Same order
- other -> uUnboundVar tv1 maybe_ty1 ps_ty2 ty2
+ Just ty1 | swapped -> uTys ps_ty2 ty2 ty1 ty1 -- Swap back
+ | otherwise -> uTys ty1 ty1 ps_ty2 ty2 -- Same order
+ other -> uUnboundVar swapped tv1 maybe_ty1 ps_ty2 ty2
-- Expand synonyms
-uUnboundVar tv1 maybe_ty1 ps_ty2 (NoteTy _ ty2)
- = uUnboundVar tv1 maybe_ty1 ps_ty2 ty2
+uUnboundVar swapped tv1 maybe_ty1 ps_ty2 (NoteTy _ ty2)
+ = uUnboundVar swapped tv1 maybe_ty1 ps_ty2 ty2
-- The both-type-variable case
-uUnboundVar tv1 maybe_ty1 ps_ty2 ty2@(TyVarTy tv2)
+uUnboundVar swapped tv1 maybe_ty1 ps_ty2 ty2@(TyVarTy tv2)
-- Same type variable => no-op
| tv1 == tv2
= returnTc ()
-- Distinct type variables
- -- ASSERT maybe_ty1 /= BoundTo
+ -- ASSERT maybe_ty1 /= Just
| otherwise
- = tcReadTyVar tv2 `thenNF_Tc` \ maybe_ty2 ->
+ = tcGetTyVar tv2 `thenNF_Tc` \ maybe_ty2 ->
case maybe_ty2 of
- BoundTo ty2' -> uUnboundVar tv1 maybe_ty1 ty2' ty2'
-
- -- Try to update sys-y type variables in preference to sig-y ones
- -- (the latter respond False to isSysLocalName)
- UnBound | can_update_tv2
- && (tv2_is_sys_y || not can_update_tv1)
- -> tcWriteTyVar tv2 (TyVarTy tv1) `thenNF_Tc_` returnTc ()
-
- | can_update_tv1
- -> tcWriteTyVar tv1 ps_ty2 `thenNF_Tc_` returnTc ()
-
- other -> failWithTc (unifyKindErr tv1 ps_ty2)
- where
- kind1 = tyVarKind tv1
- kind2 = tyVarKind tv2
-
- can_update_tv1 = kind2 `hasMoreBoxityInfo` kind1
- can_update_tv2 = kind1 `hasMoreBoxityInfo` kind2
+ Just ty2' -> uUnboundVar swapped tv1 maybe_ty1 ty2' ty2'
- -- Try to overwrite sys-y things with sig-y things
- tv2_is_sys_y = isSysLocalName (varName tv2)
+ Nothing -> checkKinds swapped tv1 ty2 `thenTc_`
+ -- Try to update sys-y type variables in preference to sig-y ones
+ -- (the latter respond False to isSysLocalName)
+ if isSysLocalName (varName tv2) then
+ tcPutTyVar tv2 (TyVarTy tv1) `thenNF_Tc_`
+ returnTc ()
+ else
+ tcPutTyVar tv1 ps_ty2 `thenNF_Tc_`
+ returnTc ()
-- Second one isn't a type variable
-uUnboundVar tv1 maybe_ty1 ps_ty2 non_var_ty2
- | non_var_ty2 == openTypeKind
- = -- We never bind a kind variable to openTypeKind;
- -- instead we refine it to boxedTypeKind
- -- This is a rather dark corner, I have to admit. SLPJ May 98
- tcWriteTyVar tv1 boxedTypeKind `thenNF_Tc_`
- returnTc ()
-
- | tyvar_kind == superKind
- || typeKind non_var_ty2 `hasMoreBoxityInfo` tyvar_kind
- -- OK to bind if we're at the kind level, or
- -- (at the type level) the variable has less boxity info than the type
- = occur_check non_var_ty2 `thenTc_`
- tcWriteTyVar tv1 ps_ty2 `thenNF_Tc_`
- returnTc ()
-
- | otherwise
- = failWithTc (unifyKindErr tv1 ps_ty2)
+uUnboundVar swapped tv1 maybe_ty1 ps_ty2 non_var_ty2
+ | non_var_ty2 == anyBoxKind
+ -- If the
+ = returnTc ()
+ | otherwise
+ = checkKinds swapped tv1 non_var_ty2 `thenTc_`
+ occur_check non_var_ty2 `thenTc_`
+ tcPutTyVar tv1 ps_ty2 `thenNF_Tc_`
+ returnTc ()
where
- tyvar_kind = tyVarKind tv1
-
occur_check ty = mapTc occur_check_tv (varSetElems (tyVarsOfType ty)) `thenTc_`
returnTc ()
failWithTcM (unifyOccurCheck tv1 zonked_ty2)
| otherwise -- A different tyvar
- = tcReadTyVar tv2 `thenNF_Tc` \ maybe_ty2 ->
+ = tcGetTyVar tv2 `thenNF_Tc` \ maybe_ty2 ->
case maybe_ty2 of
- BoundTo ty2' -> occur_check ty2'
- other -> returnTc ()
+ Just ty2' -> occur_check ty2'
+ other -> returnTc ()
+
+checkKinds swapped tv1 ty2
+ = tcAddErrCtxtM (unifyKindCtxt swapped tv1 ty2) $
+
+ -- We have to use tcTypeKind not just typeKind to get the
+ -- kind of ty2, because there might be mutable kind variables
+ -- in the way. For example, suppose that ty2 :: (a b), and
+ -- the kind of 'a' is a kind variable 'k' that has (presumably)
+ -- been unified with 'k1 -> k2'.
+ tcTypeKind ty2 `thenNF_Tc` \ k2 ->
+
+ if swapped then
+ unifyKind k2 (tyVarKind tv1)
+ else
+ unifyKind (tyVarKind tv1) k2
\end{code}
%************************************************************************
@unifyFunTy@ is used to avoid the fruitless creation of type variables.
\begin{code}
-unifyFunTy :: TcType s -- Fail if ty isn't a function type
- -> TcM s (TcType s, TcType s) -- otherwise return arg and result types
+unifyFunTy :: TcType -- Fail if ty isn't a function type
+ -> TcM s (TcType, TcType) -- otherwise return arg and result types
unifyFunTy ty@(TyVarTy tyvar)
- = tcReadTyVar tyvar `thenNF_Tc` \ maybe_ty ->
+ = tcGetTyVar tyvar `thenNF_Tc` \ maybe_ty ->
case maybe_ty of
- BoundTo ty' -> unifyFunTy ty'
+ Just ty' -> unifyFunTy ty'
other -> unify_fun_ty_help ty
unifyFunTy ty
Nothing -> unify_fun_ty_help ty
unify_fun_ty_help ty -- Special cases failed, so revert to ordinary unification
- = newTyVarTy openTypeKind `thenNF_Tc` \ arg ->
- newTyVarTy openTypeKind `thenNF_Tc` \ res ->
+ = newTyVarTy_OpenKind `thenNF_Tc` \ arg ->
+ newTyVarTy_OpenKind `thenNF_Tc` \ res ->
unifyTauTy ty (mkFunTy arg res) `thenTc_`
returnTc (arg,res)
\end{code}
\begin{code}
-unifyListTy :: TcType s -- expected list type
- -> TcM s (TcType s) -- list element type
+unifyListTy :: TcType -- expected list type
+ -> TcM s TcType -- list element type
unifyListTy ty@(TyVarTy tyvar)
- = tcReadTyVar tyvar `thenNF_Tc` \ maybe_ty ->
+ = tcGetTyVar tyvar `thenNF_Tc` \ maybe_ty ->
case maybe_ty of
- BoundTo ty' -> unifyListTy ty'
+ Just ty' -> unifyListTy ty'
other -> unify_list_ty_help ty
unifyListTy ty
\end{code}
\begin{code}
-unifyTupleTy :: Arity -> TcType s -> TcM s [TcType s]
+unifyTupleTy :: Arity -> TcType -> TcM s [TcType]
unifyTupleTy arity ty@(TyVarTy tyvar)
- = tcReadTyVar tyvar `thenNF_Tc` \ maybe_ty ->
+ = tcGetTyVar tyvar `thenNF_Tc` \ maybe_ty ->
case maybe_ty of
- BoundTo ty' -> unifyTupleTy arity ty'
+ Just ty' -> unifyTupleTy arity ty'
other -> unify_tuple_ty_help arity ty
unifyTupleTy arity ty
\end{code}
\begin{code}
-unifyUnboxedTupleTy :: Arity -> TcType s -> TcM s [TcType s]
+unifyUnboxedTupleTy :: Arity -> TcType -> TcM s [TcType]
unifyUnboxedTupleTy arity ty@(TyVarTy tyvar)
- = tcReadTyVar tyvar `thenNF_Tc` \ maybe_ty ->
+ = tcGetTyVar tyvar `thenNF_Tc` \ maybe_ty ->
case maybe_ty of
- BoundTo ty' -> unifyUnboxedTupleTy arity ty'
- other -> unify_unboxed_tuple_ty_help arity ty
+ Just ty' -> unifyUnboxedTupleTy arity ty'
+ other -> unify_unboxed_tuple_ty_help arity ty
unifyUnboxedTupleTy arity ty
= case splitTyConApp_maybe ty of
other -> unify_tuple_ty_help arity ty
unify_unboxed_tuple_ty_help arity ty
- = mapNF_Tc (\ _ -> newTyVarTy openTypeKind) [1..arity]`thenNF_Tc` \ arg_tys ->
+ = mapNF_Tc (\ _ -> newTyVarTy_OpenKind) [1..arity] `thenNF_Tc` \ arg_tys ->
unifyTauTy ty (mkUnboxedTupleTy arity arg_tys) `thenTc_`
returnTc arg_tys
\end{code}
+Make sure a kind is of the form (Type b) for some boxity b.
+
+\begin{code}
+unifyTypeKind :: TcKind -> TcM s ()
+unifyTypeKind kind@(TyVarTy kv)
+ = tcGetTyVar kv `thenNF_Tc` \ maybe_kind ->
+ case maybe_kind of
+ Just kind' -> unifyTypeKind kind'
+ Nothing -> unify_type_kind_help kind
+
+unifyTypeKind kind
+ = case splitTyConApp_maybe kind of
+ Just (tycon, [_]) | tycon == typeCon -> returnTc ()
+ other -> unify_type_kind_help kind
+
+unify_type_kind_help kind
+ = newOpenTypeKind `thenNF_Tc` \ expected_kind ->
+ unifyKind expected_kind kind
+\end{code}
+
+
%************************************************************************
%* *
\subsection[Unify-context]{Errors and contexts}
text "Inferred" <+> text s <> colon <+> ppr tidy_ty2
]))
where
- (env1, [tidy_ty1,tidy_ty2]) = tidyTypes tidy_env [ty1,ty2]
+ (env1, [tidy_ty1,tidy_ty2]) = tidyOpenTypes tidy_env [ty1,ty2]
+
+unifyKindCtxt swapped tv1 ty2 tidy_env -- not swapped => tv1 expected, ty2 inferred
+ = returnNF_Tc (env2, ptext SLIT("When matching types") <+>
+ sep [quotes pp_expected, ptext SLIT("and"), quotes pp_actual])
+ where
+ (pp_expected, pp_actual) | swapped = (pp2, pp1)
+ | otherwise = (pp1, pp2)
+ (env1, tv1') = tidyTyVar tidy_env tv1
+ (env2, ty2') = tidyOpenType env1 ty2
+ pp1 = ppr tv1'
+ pp2 = ppr ty2'
unifyMisMatch ty1 ty2
= (env2, hang (ptext SLIT("Couldn't match"))
4 (sep [quotes (ppr tidy_ty1), ptext SLIT("against"), quotes (ppr tidy_ty2)]))
where
- (env1, tidy_ty1) = tidyType emptyTidyEnv ty1
- (env2, tidy_ty2) = tidyType env1 ty2
-
-unifyKindErr tyvar ty
- = hang (ptext SLIT("Kind mis-match between"))
- 4 (sep [quotes (hsep [ppr tyvar, ptext SLIT("::"), ppr (tyVarKind tyvar)]),
- ptext SLIT("and"),
- quotes (hsep [ppr ty, ptext SLIT("::"), ppr (typeKind ty)])])
+ (env1, tidy_ty1) = tidyOpenType emptyTidyEnv ty1
+ (env2, tidy_ty2) = tidyOpenType env1 ty2
unifyOccurCheck tyvar ty
= (env2, hang (ptext SLIT("Occurs check: cannot construct the infinite type:"))
4 (sep [ppr tidy_tyvar, char '=', ppr tidy_ty]))
where
(env1, tidy_tyvar) = tidyTyVar emptyTidyEnv tyvar
- (env2, tidy_ty) = tidyType env1 ty
+ (env2, tidy_ty) = tidyOpenType env1 ty
\end{code}
pprConstraint, pprTheta,
pprTyVarBndr, pprTyVarBndrs,
- getTyDescription,
-
- nmbrType, nmbrGlobalType
+ -- Junk
+ getTyDescription, showTypeCategory
) where
#include "HsVersions.h"
-- friends:
-- (PprType can see all the representations it's trying to print)
-import Type ( GenType(..), TyNote(..), Kind, Type, ThetaType,
+import Type ( Type(..), TyNote(..), Kind, ThetaType,
splitFunTys, splitDictTy_maybe,
splitForAllTys, splitSigmaTy, splitRhoTy,
+ isDictTy, splitTyConApp_maybe, splitFunTy_maybe,
boxedTypeKind
)
-import Var ( GenTyVar, TyVar, tyVarKind,
+import Var ( TyVar, tyVarKind,
tyVarName, setTyVarName
)
import VarEnv
-import TyCon ( TyCon, isTupleTyCon, isUnboxedTupleTyCon, tyConArity )
+import TyCon ( TyCon, isPrimTyCon, isTupleTyCon, isUnboxedTupleTyCon,
+ maybeTyConSingleCon, isEnumerationTyCon,
+ tyConArity, tyConUnique
+ )
import Class ( Class )
-- others:
import Maybes ( maybeToBool )
-import Name ( getOccString, setNameVisibility, NamedThing(..) )
+import Name ( getOccString, NamedThing(..) )
import Outputable
import PprEnv
-import Unique ( Unique, Uniquable(..),
- incrUnique, listTyConKey, initTyVarUnique
- )
+import Unique ( Uniquable(..) )
+import Unique -- quite a few *Keys
import Util
\end{code}
works just by setting the initial context precedence very high.
\begin{code}
-pprType, pprParendType :: GenType flexi -> SDoc
+pprType, pprParendType :: Type -> SDoc
pprType ty = ppr_ty pprTyEnv tOP_PREC ty
pprParendType ty = ppr_ty pprTyEnv tYCON_PREC ty
pprKind = pprType
pprParendKind = pprParendType
-pprConstraint :: Class -> [GenType flexi] -> SDoc
+pprConstraint :: Class -> [Type] -> SDoc
pprConstraint clas tys = ppr clas <+> hsep (map (pprParendType) tys)
pprTheta :: ThetaType -> SDoc
where
ppr_dict (c,tys) = pprConstraint c tys
-instance Outputable (GenType flexi) where
+instance Outputable Type where
ppr ty = pprType ty
\end{code}
\end{code}
\begin{code}
-ppr_ty :: PprEnv (GenTyVar flexi) flexi -> Int
- -> GenType flexi
- -> SDoc
-
+ppr_ty :: PprEnv TyVar -> Int -> Type -> SDoc
ppr_ty env ctxt_prec (TyVarTy tyvar)
= pTyVarO env tyvar
+ppr_ty env ctxt_prec ty@(TyConApp tycon tys)
+ -- KIND CASE; it's of the form (Type x)
+ | tycon_uniq == 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)
+ case ty1 of
+ TyConApp bx [] -> ppr bx
+ other -> maybeParen ctxt_prec tYCON_PREC
+ (ppr tycon <+> tys_w_spaces)
+
+
-- TUPLE CASE (boxed and unboxed)
-ppr_ty env ctxt_prec (TyConApp tycon tys)
| isTupleTyCon tycon
&& length tys == tyConArity tycon -- no magic if partially applied
= parens tys_w_commas
| isUnboxedTupleTyCon tycon
&& length tys == tyConArity tycon -- no magic if partially applied
= parens (char '#' <+> tys_w_commas <+> char '#')
- where
- tys_w_commas = sep (punctuate comma (map (ppr_ty env tOP_PREC) tys))
-- LIST CASE
-ppr_ty env ctxt_prec (TyConApp tycon [ty])
- | getUnique tycon == listTyConKey
- = brackets (ppr_ty env tOP_PREC ty)
+ | tycon_uniq == listTyConKey && n_tys == 1
+ = brackets (ppr_ty env tOP_PREC ty1)
-- DICTIONARY CASE, prints {C a}
-- This means that instance decls come out looking right in interfaces
-- and that in turn means they get "gated" correctly when being slurped in
-ppr_ty env ctxt_prec ty@(TyConApp tycon tys)
| maybeToBool maybe_dict
= braces (ppr_dict env tYCON_PREC ctys)
- where
- Just ctys = maybe_dict
- maybe_dict = splitDictTy_maybe ty
-
+
-- NO-ARGUMENT CASE (=> no parens)
-ppr_ty env ctxt_prec (TyConApp tycon [])
+ | null tys
= ppr tycon
-- GENERAL CASE
-ppr_ty env ctxt_prec (TyConApp tycon tys)
+ | otherwise
= maybeParen ctxt_prec tYCON_PREC (hsep [ppr tycon, tys_w_spaces])
+
where
+ tycon_uniq = tyConUnique tycon
+ n_tys = length tys
+ (ty1:_) = tys
+ Just ctys = maybe_dict
+ maybe_dict = splitDictTy_maybe ty -- Checks class and arity
+ tys_w_commas = sep (punctuate comma (map (ppr_ty env tOP_PREC) tys))
tys_w_spaces = hsep (map (ppr_ty env tYCON_PREC) tys)
+
ppr_ty env ctxt_prec ty@(ForAllTy _ _)
= getPprStyle $ \ sty ->
maybeParen ctxt_prec fUN_PREC $
- if userStyle sty then
- sep [ ptext SLIT("forall"), pp_tyvars, ptext SLIT("."), pp_maybe_ctxt, pp_body ]
- else
+ if ifaceStyle sty then
sep [ ptext SLIT("__forall"), brackets pp_tyvars, pp_ctxt, pp_body ]
+ else
+ sep [ ptext SLIT("forall"), pp_tyvars <> ptext SLIT("."), pp_maybe_ctxt, pp_body ]
where
(tyvars, rho_ty) = splitForAllTys ty
(theta, body_ty) = splitRhoTy rho_ty
pprTyVarBndr tyvar
= getPprStyle $ \ sty ->
if (ifaceStyle sty || debugStyle sty) && kind /= boxedTypeKind then
- hcat [ppr tyvar, text " :: ", pprParendKind kind]
+ hsep [ppr tyvar, dcolon, pprParendKind kind]
-- See comments with ppDcolon in PprCore.lhs
else
ppr tyvar
\end{code}
-%************************************************************************
-%* *
-\subsection{Renumbering types}
-%* *
-%************************************************************************
-
-We tend to {\em renumber} everything before printing, so that we get
-consistent Uniques on everything from run to run.
-
-
-\begin{code}
-nmbrGlobalType :: Type -> Type -- Renumber a top-level type
-nmbrGlobalType ty = nmbrType emptyVarEnv initTyVarUnique ty
-
-nmbrType :: TyVarEnv Type -- Substitution
- -> Unique -- This unique and its successors are not
- -- free in the range of the substitution
- -> Type
- -> Type
-
-nmbrType tyvar_env uniq ty
- = initNmbr tyvar_env uniq (nmbrTy ty)
-
-nmbrTy :: Type -> NmbrM Type
-
-nmbrTy (TyVarTy tv)
- = lookupTyVar tv
-
-nmbrTy (AppTy t1 t2)
- = nmbrTy t1 `thenNmbr` \ new_t1 ->
- nmbrTy t2 `thenNmbr` \ new_t2 ->
- returnNmbr (AppTy new_t1 new_t2)
-
-nmbrTy (TyConApp tc tys)
- = mapNmbr nmbrTy tys `thenNmbr` \ new_tys ->
- returnNmbr (TyConApp tc new_tys)
-
-nmbrTy (NoteTy (SynNote ty1) ty2)
- = nmbrTy ty1 `thenNmbr` \ new_ty1 ->
- nmbrTy ty2 `thenNmbr` \ new_ty2 ->
- returnNmbr (NoteTy (SynNote new_ty1) new_ty2)
-
-nmbrTy (NoteTy (FTVNote _) ty2) = nmbrTy ty2
-
-nmbrTy (ForAllTy tv ty)
- = addTyVar tv $ \ new_tv ->
- nmbrTy ty `thenNmbr` \ new_ty ->
- returnNmbr (ForAllTy new_tv new_ty)
-
-nmbrTy (FunTy t1 t2)
- = nmbrTy t1 `thenNmbr` \ new_t1 ->
- nmbrTy t2 `thenNmbr` \ new_t2 ->
- returnNmbr (FunTy new_t1 new_t2)
-
-
-lookupTyVar tyvar env uniq
- = (uniq, ty)
- where
- ty = case lookupVarEnv env tyvar of
- Just ty -> ty
- Nothing -> TyVarTy tyvar
-
-addTyVar tv m env u
- = m tv' env' u'
- where
- env' = extendVarEnv env tv (TyVarTy tv')
- tv' = setTyVarName tv (setNameVisibility Nothing u (tyVarName tv))
- u' = incrUnique u
-\end{code}
-
-Monad stuff
-
\begin{code}
-type NmbrM a = TyVarEnv Type -> Unique -> (Unique, a) -- Unique is name supply
-
-initNmbr :: TyVarEnv Type -> Unique -> NmbrM a -> a
-initNmbr env uniq m
- = snd (m env uniq)
-
-returnNmbr x nenv u = (u, x)
-
-thenNmbr m k nenv u
- = let
- (u', res) = m nenv u
- in
- k res nenv u'
-
-
-mapNmbr f [] = returnNmbr []
-mapNmbr f (x:xs)
- = f x `thenNmbr` \ r ->
- mapNmbr f xs `thenNmbr` \ rs ->
- returnNmbr (r:rs)
+showTypeCategory :: Type -> Char
+ {-
+ {C,I,F,D} char, int, float, double
+ T tuple
+ S other single-constructor type
+ {c,i,f,d} unboxed ditto
+ t *unpacked* tuple
+ s *unpacked" single-cons...
+
+ v void#
+ a primitive array
+
+ E enumeration type
+ + dictionary, unless it's a ...
+ L List
+ > function
+ M other (multi-constructor) data-con type
+ . other type
+ - reserved for others to mark as "uninteresting"
+ -}
+showTypeCategory ty
+ = if isDictTy ty
+ then '+'
+ else
+ case splitTyConApp_maybe ty of
+ Nothing -> if maybeToBool (splitFunTy_maybe ty)
+ then '>'
+ else '.'
+
+ Just (tycon, _) ->
+ let utc = getUnique tycon in
+ if utc == charDataConKey then 'C'
+ else if utc == intDataConKey then 'I'
+ else if utc == floatDataConKey then 'F'
+ else if utc == doubleDataConKey then 'D'
+ else if utc == integerDataConKey then 'J'
+ else if utc == charPrimTyConKey then 'c'
+ else if (utc == intPrimTyConKey || utc == wordPrimTyConKey
+ || utc == addrPrimTyConKey) then 'i'
+ else if utc == floatPrimTyConKey then 'f'
+ else if utc == doublePrimTyConKey then 'd'
+ else if isPrimTyCon tycon {- array, we hope -} then 'A'
+ else if isEnumerationTyCon tycon then 'E'
+ else if isTupleTyCon tycon then 'T'
+ else if maybeToBool (maybeTyConSingleCon tycon) then 'S'
+ else if utc == listTyConKey then 'L'
+ else 'M' -- oh, well...
\end{code}
\begin{code}
module TyCon(
- TyCon, KindCon, Boxity(..),
+ TyCon, KindCon, SuperKindCon,
isFunTyCon, isUnLiftedTyCon, isBoxedTyCon, isProductTyCon,
isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isPrimTyCon,
mkTupleTyCon,
mkSynTyCon,
mkKindCon,
- superKindCon,
+ mkSuperKindCon,
tyConKind,
tyConUnique,
#include "HsVersions.h"
-import {-# SOURCE #-} Type ( Type, Kind )
+import {-# SOURCE #-} Type ( Type, Kind, SuperKind )
import {-# SOURCE #-} DataCon ( DataCon )
import Class ( Class )
import BasicTypes ( Arity, NewOrData(..), RecFlag(..) )
import Maybes
import Name ( Name, nameUnique, NamedThing(getName) )
-import Unique ( Unique, Uniquable(..), superKindConKey )
+import Unique ( Unique, Uniquable(..), anyBoxConKey )
import PrimRep ( PrimRep(..), isFollowableRep )
import Outputable
\end{code}
%************************************************************************
\begin{code}
-type KindCon = TyCon
+type KindCon = TyCon
+type SuperKindCon = TyCon
data TyCon
= FunTyCon {
tyConName :: Name,
tyConKind :: Kind,
tyConArity :: Arity,
- tyConBoxed :: Bool,
+ tyConBoxed :: Bool, -- True for boxed; False for unboxed
tyConTyVars :: [TyVar],
dataCon :: DataCon
}
| KindCon { -- Type constructor at the kind level
tyConUnique :: Unique,
tyConName :: Name,
- tyConKind :: Kind,
- tyConArity :: Arity,
-
- kindConBoxity :: Boxity
+ tyConKind :: SuperKind,
+ tyConArity :: Arity
}
- | SuperKindCon { -- The type of kind variables,
- tyConUnique :: Unique -- sometimes written as a box
+ | SuperKindCon { -- The type of kind variables or boxity variables,
+ tyConUnique :: Unique,
+ tyConName :: Name
}
-
-data Boxity = Boxed | Unboxed | Open
\end{code}
%************************************************************************
So we compromise, and move their Kind calculation to the call site.
\begin{code}
-superKindCon = SuperKindCon superKindConKey
-
-mkKindCon name kind boxity
+mkSuperKindCon :: Name -> SuperKindCon
+mkSuperKindCon name = SuperKindCon {
+ tyConUnique = nameUnique name,
+ tyConName = name
+ }
+
+mkKindCon :: Name -> SuperKind -> KindCon
+mkKindCon name kind
= KindCon {
tyConUnique = nameUnique name,
tyConName = name,
tyConArity = 0,
- tyConKind = kind,
- kindConBoxity = boxity
+ tyConKind = kind
}
+mkFunTyCon :: Name -> Kind -> TyCon
mkFunTyCon name kind
= FunTyCon {
tyConUnique = nameUnique name,
@matchesTyCon tc1 tc2@ checks whether an appliation
(tc1 t1..tn) matches (tc2 t1..tn). By "matches" we basically mean "equals",
-except that at the kind level tc2 might have more boxity info that tc1.
-
-E.g. It's ok to bind a type variable
- tv :: k2
-to a type
- t :: k1
+except that at the kind level tc2 might have more boxity info than tc1.
\begin{code}
matchesTyCon :: TyCon -- Expected (e.g. arg type of function)
-> TyCon -- Inferred (e.g. type of actual arg to function)
-> Bool
-matchesTyCon (KindCon {kindConBoxity = k1}) (KindCon {kindConBoxity = k2})
- = k2 `has_more` k1
- where
- -- "has_more" means has more boxity info
- Boxed `has_more` Open = True
- Boxed `has_more` Boxed = True
- Unboxed `has_more` Open = True
- Unboxed `has_more` Unboxed = True
- Open `has_more` Open = True
- k1 `has_more` k2 = False
-
-matchesTyCon tc1 tc2 = tyConUnique tc1 == tyConUnique tc2
+matchesTyCon tc1 tc2 = uniq1 == uniq2 || uniq1 == anyBoxConKey
+ where
+ uniq1 = tyConUnique tc1
+ uniq2 = tyConUnique tc2
\end{code}
_interface_ Type 1
_exports_
-Type Type GenType Kind ;
+Type Type Kind SuperKind ;
_declarations_
-1 type Type = GenType BasicTypes.Unused ;
+1 data Type ;
1 type Kind = Type ;
-1 data GenType a ;
+1 type SuperKind = Type ;
\begin{code}
module Type (
- GenType(..), TyNote(..), -- Representation visible to friends
- Type, GenKind, Kind,
- TyVarSubst, GenTyVarSubst,
+ Type(..), TyNote(..), -- Representation visible to friends
+ Kind, TyVarSubst,
- funTyCon, boxedKindCon, unboxedKindCon, openKindCon,
+ superKind, superBoxity, -- :: SuperKind
- boxedTypeKind, unboxedTypeKind, openTypeKind, mkArrowKind, mkArrowKinds,
- hasMoreBoxityInfo, superKind,
+ boxedKind, -- :: Kind :: BX
+ anyBoxKind, -- :: Kind :: BX
+ typeCon, -- :: KindCon :: BX -> KX
+ anyBoxCon, -- :: KindCon :: BX
+
+ boxedTypeKind, unboxedTypeKind, openTypeKind, -- Kind :: superKind
+
+ mkArrowKind, mkArrowKinds, hasMoreBoxityInfo,
+
+ funTyCon,
mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, isTyVarTy,
mkAppTy, mkAppTys, splitAppTy, splitAppTys, splitAppTy_maybe,
mkFunTy, mkFunTys, splitFunTy_maybe, splitFunTys, funResultTy,
+ zipFunTys,
mkTyConApp, mkTyConTy, splitTyConApp_maybe,
splitAlgTyConApp_maybe, splitAlgTyConApp,
mkRhoTy, splitRhoTy,
mkSigmaTy, splitSigmaTy,
+ -- Lifting and boxity
isUnLiftedType, isUnboxedType, isUnboxedTupleType, isAlgType,
typePrimRep,
+ -- Free variables
tyVarsOfType, tyVarsOfTypes, namesOfType, typeKind,
addFreeTyVars,
- substTy, fullSubstTy, substTyVar,
- substFlexiTy, substFlexiTheta,
+ -- Substitution
+ substTy, substTheta, fullSubstTy, substTyVar,
+ substTopTy, substTopTheta,
- showTypeCategory
+ -- Tidying up for printing
+ tidyType, tidyTypes,
+ tidyOpenType, tidyOpenTypes,
+ tidyTyVar, tidyTyVars,
+ tidyTopType
) where
#include "HsVersions.h"
import {-# SOURCE #-} DataCon( DataCon )
+import {-# SOURCE #-} PprType( pprType ) -- Only called in debug messages
-- friends:
-import Var ( Id, TyVar, GenTyVar, IdOrTyVar,
- removeTyVarFlexi,
- tyVarKind, isId, idType
+import Var ( Id, TyVar, IdOrTyVar,
+ tyVarKind, isId, idType, setVarOcc
)
import VarEnv
import VarSet
import Name ( NamedThing(..), Provenance(..), ExportFlag(..),
- mkWiredInTyConName, mkGlobalName, varOcc
+ mkWiredInTyConName, mkGlobalName, tcOcc,
+ tidyOccName, TidyOccEnv
)
import NameSet
import Class ( classTyCon, Class )
-import TyCon ( TyCon, Boxity(..),
- mkFunTyCon, mkKindCon, superKindCon,
+import TyCon ( TyCon, KindCon,
+ mkFunTyCon, mkKindCon, mkSuperKindCon,
matchesTyCon, isUnboxedTupleTyCon, isUnLiftedTyCon,
- isFunTyCon, isEnumerationTyCon,
- isTupleTyCon, maybeTyConSingleCon,
- isPrimTyCon, isAlgTyCon, isSynTyCon, tyConArity,
+ isFunTyCon,
+ isAlgTyCon, isSynTyCon, tyConArity,
tyConKind, tyConDataCons, getSynTyConDefn,
tyConPrimRep, tyConClass_maybe
)
import Maybes ( maybeToBool )
import PrimRep ( PrimRep(..), isFollowableRep )
import Unique -- quite a few *Keys
-import Util ( thenCmp )
+import Util ( thenCmp, mapAccumL )
import Outputable
\end{code}
\begin{code}
-type Type = GenType Unused -- Used after typechecker
-
-type GenKind flexi = GenType flexi
-type Kind = Type
+type SuperKind = Type
+type Kind = Type
type TyVarSubst = TyVarEnv Type
-type GenTyVarSubst flexi = TyVarEnv (GenType flexi)
-data GenType flexi -- Parameterised over the "flexi" part of a type variable
- = TyVarTy (GenTyVar flexi)
+data Type
+ = TyVarTy TyVar
| AppTy
- (GenType flexi) -- Function is *not* a TyConApp
- (GenType flexi)
+ Type -- Function is *not* a TyConApp
+ Type
| TyConApp -- Application of a TyCon
TyCon -- *Invariant* saturated appliations of FunTyCon and
-- synonyms have their own constructors, below.
- [GenType flexi] -- Might not be saturated.
+ [Type] -- Might not be saturated.
| FunTy -- Special case of TyConApp: TyConApp FunTyCon [t1,t2]
- (GenType flexi)
- (GenType flexi)
+ Type
+ Type
| NoteTy -- Saturated application of a type synonym
- (TyNote flexi)
- (GenType flexi) -- The expanded version
+ TyNote
+ Type -- The expanded version
| ForAllTy
- (GenTyVar flexi)
- (GenType flexi) -- TypeKind
+ TyVar
+ Type -- TypeKind
-data TyNote flexi
- = SynNote (GenType flexi) -- The unexpanded version of the type synonym; always a TyConApp
- | FTVNote (GenTyVarSet flexi) -- The free type variables of the noted expression
+data TyNote
+ = SynNote Type -- The unexpanded version of the type synonym; always a TyConApp
+ | FTVNote TyVarSet -- The free type variables of the noted expression
\end{code}
%************************************************************************
%* *
-\subsection{Wired-in type constructors
+\subsection{Kinds}
%* *
%************************************************************************
-We define a few wired-in type constructors here to avoid module knots
+Kinds
+~~~~~
+k::K = Type bx
+ | k -> k
+ | kv
-\begin{code}
-funTyConName = mkWiredInTyConName funTyConKey pREL_GHC SLIT("->") funTyCon
-funTyCon = mkFunTyCon funTyConName (mkArrowKinds [boxedTypeKind, boxedTypeKind] boxedTypeKind)
-\end{code}
+kv :: KX is a kind variable
+
+Type :: BX -> KX
+
+bx::BX = Boxed
+ | Unboxed
+ | AnyBox -- Used *only* for special built-in things
+ -- like error :: forall (a::*?). String -> a
+ -- Here, the 'a' can be instantiated to a boxed or
+ -- unboxed type.
+ | bv
+
+bxv :: BX is a boxity variable
+
+sk = KX -- A kind
+ | BX -- A boxity
+ | sk -> sk -- In ptic (BX -> KX)
\begin{code}
-mk_kind_name key str = mkGlobalName key pREL_GHC (varOcc str)
- (LocalDef mkBuiltinSrcLoc NotExported)
+mk_kind_name key str = mkGlobalName key pREL_GHC (tcOcc str)
+ (LocalDef mkBuiltinSrcLoc NotExported)
-- mk_kind_name is a bit of a hack
-- The LocalDef means that we print the name without
-- a qualifier, which is what we want for these kinds.
+ -- It's used for both Kinds and Boxities
+\end{code}
-boxedKindConName = mk_kind_name boxedKindConKey SLIT("*")
-boxedKindCon = mkKindCon boxedKindConName superKind Boxed
+Define KX, BX.
-unboxedKindConName = mk_kind_name unboxedKindConKey SLIT("*#")
-unboxedKindCon = mkKindCon unboxedKindConName superKind Unboxed
+\begin{code}
+superKind :: SuperKind -- KX, the type of all kinds
+superKindName = mk_kind_name kindConKey SLIT("KX")
+superKind = TyConApp (mkSuperKindCon superKindName) []
-openKindConName = mk_kind_name openKindConKey SLIT("*?")
-openKindCon = mkKindCon openKindConName superKind Open
+superBoxity :: SuperKind -- BX, the type of all boxities
+superBoxityName = mk_kind_name boxityConKey SLIT("BX")
+superBoxity = TyConApp (mkSuperKindCon superBoxityName) []
\end{code}
+Define Boxed, Unboxed, AnyBox
-%************************************************************************
-%* *
-\subsection{Kinds}
-%* *
-%************************************************************************
+\begin{code}
+boxedKind, unboxedKind, anyBoxKind :: Kind -- Of superkind superBoxity
+
+boxedConName = mk_kind_name boxedConKey SLIT("*")
+boxedKind = TyConApp (mkKindCon boxedConName superBoxity) []
+
+unboxedConName = mk_kind_name unboxedConKey SLIT("#")
+unboxedKind = TyConApp (mkKindCon unboxedConName superBoxity) []
+
+anyBoxConName = mk_kind_name anyBoxConKey SLIT("?")
+anyBoxCon = mkKindCon anyBoxConName superBoxity -- A kind of wild card
+anyBoxKind = TyConApp anyBoxCon []
+\end{code}
+
+Define Type
\begin{code}
-superKind :: GenKind flexi -- Box, the type of all kinds
-superKind = TyConApp superKindCon []
+typeCon :: KindCon
+typeConName = mk_kind_name typeConKey SLIT("Type")
+typeCon = mkKindCon typeConName (superBoxity `FunTy` superKind)
+\end{code}
+
+Define (Type Boxed), (Type Unboxed), (Type AnyBox)
-boxedTypeKind, unboxedTypeKind, openTypeKind :: GenKind flexi
-boxedTypeKind = TyConApp boxedKindCon []
-unboxedTypeKind = TyConApp unboxedKindCon []
-openTypeKind = TyConApp openKindCon []
+\begin{code}
+boxedTypeKind, unboxedTypeKind, openTypeKind :: Kind
+boxedTypeKind = TyConApp typeCon [boxedKind]
+unboxedTypeKind = TyConApp typeCon [unboxedKind]
+openTypeKind = TyConApp typeCon [anyBoxKind]
-mkArrowKind :: GenKind flexi -> GenKind flexi -> GenKind flexi
-mkArrowKind = FunTy
+mkArrowKind :: Kind -> Kind -> Kind
+mkArrowKind k1 k2 = k1 `FunTy` k2
-mkArrowKinds :: [GenKind flexi] -> GenKind flexi -> GenKind flexi
-mkArrowKinds arg_kinds result_kind = foldr FunTy result_kind arg_kinds
+mkArrowKinds :: [Kind] -> Kind -> Kind
+mkArrowKinds arg_kinds result_kind = foldr mkArrowKind result_kind arg_kinds
\end{code}
\begin{code}
-hasMoreBoxityInfo :: GenKind flexi -> GenKind flexi -> Bool
+hasMoreBoxityInfo :: Kind -> Kind -> Bool
+hasMoreBoxityInfo k1 k2
+ | k2 == openTypeKind = ASSERT( is_type_kind k1) True
+ | otherwise = k1 == k2
+ where
+ -- Returns true for things of form (Type x)
+ is_type_kind k = case splitTyConApp_maybe k of
+ Just (tc,[_]) -> tc == typeCon
+ Nothing -> False
+\end{code}
-(NoteTy _ k1) `hasMoreBoxityInfo` k2 = k1 `hasMoreBoxityInfo` k2
-k1 `hasMoreBoxityInfo` (NoteTy _ k2) = k1 `hasMoreBoxityInfo` k2
-(TyConApp kc1 ts1) `hasMoreBoxityInfo` (TyConApp kc2 ts2)
- = ASSERT( null ts1 && null ts2 )
- kc2 `matchesTyCon` kc1 -- NB the reversal of arguments
+%************************************************************************
+%* *
+\subsection{Wired-in type constructors
+%* *
+%************************************************************************
-kind1@(FunTy _ _) `hasMoreBoxityInfo` kind2@(FunTy _ _)
- = ASSERT( kind1 == kind2 )
- True
- -- The two kinds can be arrow kinds; for example when unifying
- -- (m1 Int) and (m2 Int) we end up unifying m1 and m2, which should
- -- have the same kind.
+We define a few wired-in type constructors here to avoid module knots
--- Other cases are impossible
+\begin{code}
+funTyConName = mkWiredInTyConName funTyConKey pREL_GHC SLIT("->") funTyCon
+funTyCon = mkFunTyCon funTyConName (mkArrowKinds [boxedTypeKind, boxedTypeKind] boxedTypeKind)
\end{code}
+
%************************************************************************
%* *
\subsection{Constructor-specific functions}
TyVarTy
~~~~~~~
\begin{code}
-mkTyVarTy :: GenTyVar flexi -> GenType flexi
+mkTyVarTy :: TyVar -> Type
mkTyVarTy = TyVarTy
-mkTyVarTys :: [GenTyVar flexi] -> [GenType flexi]
+mkTyVarTys :: [TyVar] -> [Type]
mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy
-getTyVar :: String -> GenType flexi -> GenTyVar flexi
+getTyVar :: String -> Type -> TyVar
getTyVar msg (TyVarTy tv) = tv
getTyVar msg (NoteTy _ t) = getTyVar msg t
getTyVar msg other = panic ("getTyVar: " ++ msg)
-getTyVar_maybe :: GenType flexi -> Maybe (GenTyVar flexi)
+getTyVar_maybe :: Type -> Maybe TyVar
getTyVar_maybe (TyVarTy tv) = Just tv
getTyVar_maybe (NoteTy _ t) = getTyVar_maybe t
getTyVar_maybe other = Nothing
-isTyVarTy :: GenType flexi -> Bool
+isTyVarTy :: Type -> Bool
isTyVarTy (TyVarTy tv) = True
isTyVarTy (NoteTy _ ty) = isTyVarTy ty
isTyVarTy other = False
mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ [orig_ty2])
mk_app ty1 = AppTy orig_ty1 orig_ty2
-mkAppTys :: GenType flexi -> [GenType flexi] -> GenType flexi
+mkAppTys :: Type -> [Type] -> Type
mkAppTys orig_ty1 [] = orig_ty1
-- This check for an empty list of type arguments
-- avoids the needless of a type synonym constructor.
mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ orig_tys2)
mk_app ty1 = foldl AppTy orig_ty1 orig_tys2
-splitAppTy_maybe :: GenType flexi -> Maybe (GenType flexi, GenType flexi)
+splitAppTy_maybe :: Type -> Maybe (Type, Type)
splitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2)
splitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2)
splitAppTy_maybe (NoteTy _ ty) = splitAppTy_maybe ty
splitAppTy_maybe other = Nothing
-splitAppTy :: GenType flexi -> (GenType flexi, GenType flexi)
+splitAppTy :: Type -> (Type, Type)
splitAppTy ty = case splitAppTy_maybe ty of
Just pr -> pr
Nothing -> panic "splitAppTy"
-splitAppTys :: GenType flexi -> (GenType flexi, [GenType flexi])
+splitAppTys :: Type -> (Type, [Type])
splitAppTys ty = split ty ty []
where
split orig_ty (AppTy ty arg) args = split ty ty (arg:args)
~~~~~
\begin{code}
-mkFunTy :: GenType flexi -> GenType flexi -> GenType flexi
+mkFunTy :: Type -> Type -> Type
mkFunTy arg res = FunTy arg res
-mkFunTys :: [GenType flexi] -> GenType flexi -> GenType flexi
+mkFunTys :: [Type] -> Type -> Type
mkFunTys tys ty = foldr FunTy ty tys
-splitFunTy_maybe :: GenType flexi -> Maybe (GenType flexi, GenType flexi)
+splitFunTy_maybe :: Type -> Maybe (Type, Type)
splitFunTy_maybe (FunTy arg res) = Just (arg, res)
splitFunTy_maybe (NoteTy _ ty) = splitFunTy_maybe ty
splitFunTy_maybe other = Nothing
-splitFunTys :: GenType flexi -> ([GenType flexi], GenType flexi)
+splitFunTys :: Type -> ([Type], Type)
splitFunTys ty = split [] ty ty
where
split args orig_ty (FunTy arg res) = split (arg:args) res res
split args orig_ty (NoteTy _ ty) = split args orig_ty ty
split args orig_ty ty = (reverse args, orig_ty)
-funResultTy :: GenType flexi -> GenType flexi
+zipFunTys :: Outputable a => [a] -> Type -> ([(a,Type)], Type)
+zipFunTys orig_xs orig_ty = split [] orig_xs orig_ty orig_ty
+ where
+ split acc [] nty ty = (reverse acc, nty)
+ split acc (x:xs) nty (FunTy arg res) = split ((x,arg):acc) xs res res
+ split acc xs nty (NoteTy _ ty) = split acc xs nty ty
+ split acc (x:xs) nty ty = pprPanic "zipFunTys" (ppr orig_xs <+> pprType orig_ty)
+
+funResultTy :: Type -> Type
funResultTy (FunTy arg res) = res
funResultTy (NoteTy _ ty) = funResultTy ty
-funResultTy ty = ty
+funResultTy ty = pprPanic "funResultTy" (pprType ty)
\end{code}
~~~~~~~~
\begin{code}
-mkTyConApp :: TyCon -> [GenType flexi] -> GenType flexi
+mkTyConApp :: TyCon -> [Type] -> Type
mkTyConApp tycon tys
| isFunTyCon tycon && length tys == 2
= case tys of
= ASSERT(not (isSynTyCon tycon))
TyConApp tycon tys
-mkTyConTy :: TyCon -> GenType flexi
+mkTyConTy :: TyCon -> Type
mkTyConTy tycon = ASSERT( not (isSynTyCon tycon) )
TyConApp tycon []
-- mean a distinct type, but all other type-constructor applications
-- including functions are returned as Just ..
-splitTyConApp_maybe :: GenType flexi -> Maybe (TyCon, [GenType flexi])
+splitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
splitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res])
splitTyConApp_maybe (NoteTy _ ty) = splitTyConApp_maybe ty
-- "Algebraic" => newtype, data type, or dictionary (not function types)
-- We return the constructors too.
-splitAlgTyConApp_maybe :: GenType flexi -> Maybe (TyCon, [GenType flexi], [DataCon])
+splitAlgTyConApp_maybe :: Type -> Maybe (TyCon, [Type], [DataCon])
splitAlgTyConApp_maybe (TyConApp tc tys)
| isAlgTyCon tc &&
tyConArity tc == length tys = Just (tc, tys, tyConDataCons tc)
splitAlgTyConApp_maybe (NoteTy _ ty) = splitAlgTyConApp_maybe ty
splitAlgTyConApp_maybe other = Nothing
-splitAlgTyConApp :: GenType flexi -> (TyCon, [GenType flexi], [DataCon])
+splitAlgTyConApp :: Type -> (TyCon, [Type], [DataCon])
-- Here the "algebraic" property is an *assertion*
splitAlgTyConApp (TyConApp tc tys) = ASSERT( isAlgTyCon tc && tyConArity tc == length tys )
(tc, tys, tyConDataCons tc)
tell from the type constructor whether it's a dictionary or not.
\begin{code}
-mkDictTy :: Class -> [GenType flexi] -> GenType flexi
+mkDictTy :: Class -> [Type] -> Type
mkDictTy clas tys = TyConApp (classTyCon clas) tys
-splitDictTy_maybe :: GenType flexi -> Maybe (Class, [GenType flexi])
+splitDictTy_maybe :: Type -> Maybe (Class, [Type])
splitDictTy_maybe (TyConApp tc tys)
| maybeToBool maybe_class
&& tyConArity tc == length tys = Just (clas, tys)
splitDictTy_maybe (NoteTy _ ty) = splitDictTy_maybe ty
splitDictTy_maybe other = Nothing
-isDictTy :: GenType flexi -> Bool
+isDictTy :: Type -> Bool
-- This version is slightly more efficient than (maybeToBool . splitDictTy)
isDictTy (TyConApp tc tys)
| maybeToBool (tyConClass_maybe tc)
mkSynTy syn_tycon tys
= ASSERT(isSynTyCon syn_tycon)
NoteTy (SynNote (TyConApp syn_tycon tys))
- (substFlexiTy (zipVarEnv tyvars tys) body)
- -- The "flexi" is needed so we can get a TcType from a synonym
+ (substTopTy (zipVarEnv tyvars tys) body)
where
(tyvars, body) = getSynTyConDefn syn_tycon
\begin{code}
mkForAllTy = ForAllTy
-mkForAllTys :: [GenTyVar flexi] -> GenType flexi -> GenType flexi
+mkForAllTys :: [TyVar] -> Type -> Type
mkForAllTys tyvars ty = foldr ForAllTy ty tyvars
-splitForAllTy_maybe :: GenType flexi -> Maybe (GenTyVar flexi, GenType flexi)
+splitForAllTy_maybe :: Type -> Maybe (TyVar, Type)
splitForAllTy_maybe (NoteTy _ ty) = splitForAllTy_maybe ty
splitForAllTy_maybe (ForAllTy tyvar ty) = Just(tyvar, ty)
splitForAllTy_maybe _ = Nothing
-isForAllTy :: GenType flexi -> Bool
+isForAllTy :: Type -> Bool
isForAllTy (NoteTy _ ty) = isForAllTy ty
isForAllTy (ForAllTy tyvar ty) = True
isForAllTy _ = False
-splitForAllTys :: GenType flexi -> ([GenTyVar flexi], GenType flexi)
+splitForAllTys :: Type -> ([TyVar], Type)
splitForAllTys ty = split ty ty []
where
split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs)
\end{code}
\begin{code}
-applyTy :: GenType flexi -> GenType flexi -> GenType flexi
+applyTy :: Type -> Type -> Type
applyTy (NoteTy _ fun) arg = applyTy fun arg
applyTy (ForAllTy tv ty) arg = substTy (mkVarEnv [(tv,arg)]) ty
applyTy other arg = panic "applyTy"
-applyTys :: GenType flexi -> [GenType flexi] -> GenType flexi
+applyTys :: Type -> [Type] -> Type
applyTys fun_ty arg_tys
= go [] fun_ty arg_tys
where
@isTauTy@ tests for nested for-alls.
\begin{code}
-isTauTy :: GenType flexi -> Bool
+isTauTy :: Type -> Bool
isTauTy (TyVarTy v) = True
isTauTy (TyConApp _ tys) = all isTauTy tys
isTauTy (AppTy a b) = isTauTy a && isTauTy b
\end{code}
\begin{code}
-mkRhoTy :: [(Class, [GenType flexi])] -> GenType flexi -> GenType flexi
+mkRhoTy :: [(Class, [Type])] -> Type -> Type
mkRhoTy theta ty = foldr (\(c,t) r -> FunTy (mkDictTy c t) r) ty theta
-splitRhoTy :: GenType flexi -> ([(Class, [GenType flexi])], GenType flexi)
+splitRhoTy :: Type -> ([(Class, [Type])], Type)
splitRhoTy ty = split ty ty []
where
split orig_ty (FunTy arg res) ts = case splitDictTy_maybe arg of
\begin{code}
mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau)
-splitSigmaTy :: GenType flexi -> ([GenTyVar flexi], [(Class, [GenType flexi])], GenType flexi)
+splitSigmaTy :: Type -> ([TyVar], [(Class, [Type])], Type)
splitSigmaTy ty =
(tyvars, theta, tau)
where
Finding the kind of a type
~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
--- typeKind is only ever used on Types, never Kinds
--- If it were used on Kinds, the typeKind of FunTy would not be boxedTypeKind;
--- yet at the type level functions are boxed even if neither argument nor
--- result are boxed. This seems pretty fishy to me.
+typeKind :: Type -> Kind
-typeKind :: GenType flexi -> Kind
-
-typeKind (TyVarTy tyvar) = tyVarKind tyvar
+typeKind (TyVarTy tyvar) = tyVarKind tyvar
typeKind (TyConApp tycon tys) = foldr (\_ k -> funResultTy k) (tyConKind tycon) tys
typeKind (NoteTy _ ty) = typeKind ty
-typeKind (FunTy fun arg) = boxedTypeKind
typeKind (AppTy fun arg) = funResultTy (typeKind fun)
-typeKind (ForAllTy _ _) = boxedTypeKind
+typeKind (FunTy fun arg) = typeKindF arg
+typeKind (ForAllTy _ ty) = typeKindF ty -- We could make this a new kind polyTypeKind
+ -- to prevent a forall type unifying with a
+ -- boxed type variable, but I didn't think it
+ -- was worth it yet.
+
+-- The complication is that a *function* is boxed even if
+-- its *result* type is unboxed. Seems wierd.
+
+typeKindF :: Type -> Kind
+typeKindF (NoteTy _ ty) = typeKindF ty
+typeKindF (FunTy _ ty) = typeKindF ty
+typeKindF (ForAllTy _ ty) = typeKindF ty
+typeKindF other = fix_up (typeKind other)
+ where
+ fix_up (TyConApp kc _) | kc == typeCon = boxedTypeKind
+ -- Functions at the type level are always boxed
+ fix_up (NoteTy _ kind) = fix_up kind
+ fix_up kind = kind
\end{code}
Free variables of a type
~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
-tyVarsOfType :: GenType flexi -> GenTyVarSet flexi
+tyVarsOfType :: Type -> TyVarSet
tyVarsOfType (TyVarTy tv) = unitVarSet tv
tyVarsOfType (TyConApp tycon tys) = tyVarsOfTypes tys
tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionVarSet` tyVarsOfType arg
tyVarsOfType (ForAllTy tyvar ty) = tyVarsOfType ty `minusVarSet` unitVarSet tyvar
-tyVarsOfTypes :: [GenType flexi] -> GenTyVarSet flexi
+tyVarsOfTypes :: [Type] -> TyVarSet
tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys
-- Add a Note with the free tyvars to the top of the type
-addFreeTyVars :: GenType flexi -> GenType flexi
+addFreeTyVars :: Type -> Type
addFreeTyVars ty@(NoteTy (FTVNote _) _) = ty
addFreeTyVars ty = NoteTy (FTVNote (tyVarsOfType ty)) ty
-- Find the free names of a type, including the type constructors and classes it mentions
-namesOfType :: GenType flexi -> NameSet
+namesOfType :: Type -> NameSet
namesOfType (TyVarTy tv) = unitNameSet (getName tv)
namesOfType (TyConApp tycon tys) = unitNameSet (getName tycon) `unionNameSets`
namesOfTypes tys
@substTy@ applies a substitution to a type. It deals correctly with name capture.
\begin{code}
-substTy :: GenTyVarSubst flexi -> GenType flexi -> GenType flexi
-substTy tenv ty = subst_ty tenv tset ty
- where
- tset = foldVarEnv (unionVarSet . tyVarsOfType) emptyVarSet tenv
- -- If ty doesn't have any for-alls, then this thunk
- -- will never be evaluated
+substTy :: TyVarSubst -> Type -> Type
+substTy tenv ty
+ | isEmptyVarEnv tenv = ty
+ | otherwise = subst_ty tenv tset ty
+ where
+ tset = foldVarEnv (unionVarSet . tyVarsOfType) emptyVarSet tenv
+ -- If ty doesn't have any for-alls, then this thunk
+ -- will never be evaluated
+
+substTheta :: TyVarSubst -> ThetaType -> ThetaType
+substTheta tenv theta
+ | isEmptyVarEnv tenv = theta
+ | otherwise = [(clas, map (subst_ty tenv tset) tys) | (clas, tys) <- theta]
+ where
+ tset = foldVarEnv (unionVarSet . tyVarsOfType) emptyVarSet tenv
+ -- If ty doesn't have any for-alls, then this thunk
+ -- will never be evaluated
+
+substTopTy :: TyVarSubst -> Type -> Type
+substTopTy = substTy -- Called when doing top-level substitutions.
+ -- Here we expect that the free vars of the range of the
+ -- substitution will be empty; but during typechecking I'm
+ -- a bit dubious about that (mutable tyvars bouund to Int, say)
+ -- So I've left it as substTy for the moment. SLPJ Nov 98
+substTopTheta = substTheta
\end{code}
@fullSubstTy@ is like @substTy@ except that it needs to be given a set
if you happen to have that set lying around.
\begin{code}
-fullSubstTy :: GenTyVarSubst flexi -- Substitution to apply
- -> GenTyVarSet flexi -- Superset of the free tyvars of
- -- the range of the tyvar env
- -> GenType flexi -> GenType flexi
+fullSubstTy :: TyVarSubst -- Substitution to apply
+ -> TyVarSet -- Superset of the free tyvars of
+ -- the range of the tyvar env
+ -> Type -> Type
-- ASSUMPTION: The substitution is idempotent.
-- Equivalently: No tyvar is both in scope, and in the domain of the substitution.
fullSubstTy tenv tset ty | isEmptyVarEnv tenv = ty
go (ForAllTy tv ty) = case substTyVar tenv tset tv of
(tenv', tset', tv') -> ForAllTy tv' (subst_ty tenv' tset' ty)
-substTyVar :: GenTyVarSubst flexi -> GenTyVarSet flexi -> GenTyVar flexi
- -> (GenTyVarSubst flexi, GenTyVarSet flexi, GenTyVar flexi)
+substTyVar :: TyVarSubst -> TyVarSet -> TyVar
+ -> (TyVarSubst, TyVarSet, TyVar)
substTyVar tenv tset tv
| not (tv `elemVarSet` tset) -- No need to clone
\end{code}
-@substFlexiTy@ applies a substitution to a (GenType flexi1) returning
-a (GenType flexi2). Note that we convert from one flexi status to another.
+%************************************************************************
+%* *
+\subsection{TidyType}
+%* *
+%************************************************************************
-Two assumptions, for (substFlexiTy env ty)
- (a) the substitution, env, must cover all free tyvars of the type, ty
- (b) the free vars of the range of the substitution must be
- different than any of the forall'd variables in the type, ty
+tidyTy tidies up a type for printing in an error message, or in
+an interface file.
-The latter assumption is reasonable because, after all, ty has a different
-type to the range of the substitution.
+It doesn't change the uniques at all, just the print names.
\begin{code}
-substFlexiTy :: GenTyVarSubst flexi2 -> GenType flexi1 -> GenType flexi2
-substFlexiTy env ty = go ty
+tidyTyVar :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
+tidyTyVar env@(tidy_env, subst) tyvar
+ = case lookupVarEnv subst tyvar of
+
+ Just tyvar' -> -- Already substituted
+ (env, tyvar')
+
+ Nothing -> -- Make a new nice name for it
+
+ case tidyOccName tidy_env (getOccName tyvar) of
+ (tidy', occ') -> -- New occname reqd
+ ((tidy', subst'), tyvar')
+ where
+ subst' = extendVarEnv subst tyvar tyvar'
+ tyvar' = setVarOcc tyvar occ'
+
+tidyTyVars env tyvars = mapAccumL tidyTyVar env tyvars
+
+tidyType :: TidyEnv -> Type -> Type
+tidyType env@(tidy_env, subst) ty
+ = go ty
where
- go (TyVarTy tv) = case lookupVarEnv env tv of
- Just ty -> ty
- Nothing -> pprPanic "substFlexiTy" (ppr tv)
- go (TyConApp tc tys) = TyConApp tc (map go tys)
- go (NoteTy (SynNote ty1) ty2) = NoteTy (SynNote (go ty1)) (go ty2)
- go (NoteTy (FTVNote _) ty2) = go ty2 -- Discard free tyvar note
- go (FunTy arg res) = FunTy (go arg) (go res)
- go (AppTy fun arg) = mkAppTy (go fun) (go arg)
- go (ForAllTy tv ty) = ForAllTy tv' (substFlexiTy env' ty)
- where
- tv' = removeTyVarFlexi tv
- env' = extendVarEnv env tv (TyVarTy tv')
-
-substFlexiTheta :: GenTyVarSubst flexi2 -> [(Class, [GenType flexi1])]
- -> [(Class, [GenType flexi2])]
-substFlexiTheta env theta = [(clas, map (substFlexiTy env) tys) | (clas,tys) <- theta]
+ go (TyVarTy tv) = case lookupVarEnv subst tv of
+ Nothing -> TyVarTy tv
+ Just tv' -> TyVarTy tv'
+ go (TyConApp tycon tys) = TyConApp tycon (map go tys)
+ go (NoteTy note ty) = NoteTy (go_note note) (go ty)
+ go (AppTy fun arg) = AppTy (go fun) (go arg)
+ go (FunTy fun arg) = FunTy (go fun) (go arg)
+ go (ForAllTy tv ty) = ForAllTy tv' (tidyType env' ty)
+ where
+ (env', tv') = tidyTyVar env tv
+
+ go_note (SynNote ty) = SynNote (go ty)
+ go_note note@(FTVNote ftvs) = note -- No need to tidy the free tyvars
+
+tidyTypes env tys = map (tidyType env) tys
+\end{code}
+
+
+@tidyOpenType@ grabs the free type varibles, tidies them
+and then uses @tidyType@ to work over the type itself
+
+\begin{code}
+tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type)
+tidyOpenType env ty
+ = (env', tidyType env' ty)
+ where
+ env' = foldl go env (varSetElems (tyVarsOfType ty))
+ go env tyvar = fst (tidyTyVar env tyvar)
+
+tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type])
+tidyOpenTypes env tys = mapAccumL tidyOpenType env tys
+
+tidyTopType :: Type -> Type
+tidyTopType ty = tidyType emptyTidyEnv ty
\end{code}
%************************************************************************
\begin{code}
-isUnboxedType :: GenType flexi -> Bool
+isUnboxedType :: Type -> Bool
isUnboxedType ty = not (isFollowableRep (typePrimRep ty))
-isUnLiftedType :: GenType flexi -> Bool
+isUnLiftedType :: Type -> Bool
isUnLiftedType ty = case splitTyConApp_maybe ty of
Just (tc, ty_args) -> isUnLiftedTyCon tc
other -> False
-isUnboxedTupleType :: GenType flexi -> Bool
+isUnboxedTupleType :: Type -> Bool
isUnboxedTupleType ty = case splitTyConApp_maybe ty of
Just (tc, ty_args) -> isUnboxedTupleTyCon tc
other -> False
-isAlgType :: GenType flexi -> Bool
+isAlgType :: Type -> Bool
isAlgType ty = case splitTyConApp_maybe ty of
Just (tc, ty_args) -> isAlgTyCon tc
other -> False
-typePrimRep :: GenType flexi -> PrimRep
+typePrimRep :: Type -> PrimRep
typePrimRep ty = case splitTyConApp_maybe ty of
Just (tc, ty_args) -> tyConPrimRep tc
other -> PtrRep
there are embedded for-alls.
\begin{code}
-instance Eq (GenType flexi) where
+instance Eq Type where
ty1 == ty2 = case ty1 `cmpTy` ty2 of { EQ -> True; other -> False }
-instance Ord (GenType flexi) where
+instance Ord Type where
compare ty1 ty2 = cmpTy ty1 ty2
-cmpTy :: GenType flexi -> GenType flexi -> Ordering
+cmpTy :: Type -> Type -> Ordering
cmpTy ty1 ty2
= cmp emptyVarEnv ty1 ty2
where
\end{code}
-
-%************************************************************************
-%* *
-\subsection{Grime}
-%* *
-%************************************************************************
-
-
-
-\begin{code}
-showTypeCategory :: Type -> Char
- {-
- {C,I,F,D} char, int, float, double
- T tuple
- S other single-constructor type
- {c,i,f,d} unboxed ditto
- t *unpacked* tuple
- s *unpacked" single-cons...
-
- v void#
- a primitive array
-
- E enumeration type
- + dictionary, unless it's a ...
- L List
- > function
- M other (multi-constructor) data-con type
- . other type
- - reserved for others to mark as "uninteresting"
- -}
-showTypeCategory ty
- = if isDictTy ty
- then '+'
- else
- case splitTyConApp_maybe ty of
- Nothing -> if maybeToBool (splitFunTy_maybe ty)
- then '>'
- else '.'
-
- Just (tycon, _) ->
- let utc = getUnique tycon in
- if utc == charDataConKey then 'C'
- else if utc == intDataConKey then 'I'
- else if utc == floatDataConKey then 'F'
- else if utc == doubleDataConKey then 'D'
- else if utc == integerDataConKey then 'J'
- else if utc == charPrimTyConKey then 'c'
- else if (utc == intPrimTyConKey || utc == wordPrimTyConKey
- || utc == addrPrimTyConKey) then 'i'
- else if utc == floatPrimTyConKey then 'f'
- else if utc == doublePrimTyConKey then 'd'
- else if isPrimTyCon tycon {- array, we hope -} then 'A'
- else if isEnumerationTyCon tycon then 'E'
- else if isTupleTyCon tycon then 'T'
- else if maybeToBool (maybeTyConSingleCon tycon) then 'S'
- else if utc == listTyConKey then 'L'
- else 'M' -- oh, well...
-\end{code}
matchTy, matchTys
) where
-import Var ( GenTyVar, TyVar, tyVarKind )
+import Var ( TyVar, tyVarKind )
import VarEnv
import VarSet ( varSetElems )
-import Type ( GenType(..), funTyCon, typeKind, tyVarsOfType, hasMoreBoxityInfo,
+import Type ( Type(..), funTyCon, typeKind, tyVarsOfType,
splitAppTy_maybe
)
import Unique ( Uniquable(..) )
Unify types with an explicit substitution and no monad.
\begin{code}
-type Subst flexi_tmpl flexi_result
- = ([GenTyVar flexi_tmpl], -- Set of template tyvars
- TyVarEnv (GenType flexi_result)) -- Not necessarily idempotent
-
-unifyTysX :: [GenTyVar flexi] -- Template tyvars
- -> GenType flexi
- -> GenType flexi
- -> Maybe (TyVarEnv (GenType flexi))
+type Subst
+ = ([TyVar], -- Set of template tyvars
+ TyVarEnv Type) -- Not necessarily idempotent
+
+unifyTysX :: [TyVar] -- Template tyvars
+ -> Type
+ -> Type
+ -> Maybe (TyVarEnv Type)
unifyTysX tmpl_tyvars ty1 ty2
= uTysX ty1 ty2 (\(_,s) -> Just s) (tmpl_tyvars, emptyVarEnv)
-unifyTyListsX :: [GenTyVar flexi] -> [GenType flexi] -> [GenType flexi]
- -> Maybe (TyVarEnv (GenType flexi))
+unifyTyListsX :: [TyVar] -> [Type] -> [Type]
+ -> Maybe (TyVarEnv Type)
unifyTyListsX tmpl_tyvars tys1 tys2
= uTyListsX tys1 tys2 (\(_,s) -> Just s) (tmpl_tyvars, emptyVarEnv)
-uTysX :: GenType flexi
- -> GenType flexi
- -> (Subst flexi flexi -> Maybe result)
- -> Subst flexi flexi
+uTysX :: Type
+ -> Type
+ -> (Subst -> Maybe result)
+ -> Subst
-> Maybe result
uTysX (NoteTy _ ty1) ty2 k subst = uTysX ty1 ty2 k subst
uTysX ty1 ty2 k subst
Nothing -- Not already bound
- | typeKind ty2 `hasMoreBoxityInfo` tyVarKind tv1
+ | typeKind ty2 == tyVarKind tv1
&& occur_check_ok ty2
-> -- No kind mismatch nor occur check
k (tmpls, extendVarEnv env tv1 ty2)
types.
\begin{code}
-matchTy :: [GenTyVar flexi_tmpl] -- Template tyvars
- -> GenType flexi_tmpl -- Template
- -> GenType flexi_result -- Proposed instance of template
- -> Maybe (TyVarEnv (GenType flexi_result)) -- Matching substitution
+matchTy :: [TyVar] -- Template tyvars
+ -> Type -- Template
+ -> Type -- Proposed instance of template
+ -> Maybe (TyVarEnv Type) -- Matching substitution
-matchTys :: [GenTyVar flexi_tmpl] -- Template tyvars
- -> [GenType flexi_tmpl] -- Templates
- -> [GenType flexi_result] -- Proposed instance of template
- -> Maybe (TyVarEnv (GenType flexi_result), -- Matching substitution
- [GenType flexi_result]) -- Left over instance types
+matchTys :: [TyVar] -- Template tyvars
+ -> [Type] -- Templates
+ -> [Type] -- Proposed instance of template
+ -> Maybe (TyVarEnv Type, -- Matching substitution
+ [Type]) -- Left over instance types
matchTy tmpls ty1 ty2 = match ty1 ty2 (\(_,env) -> Just env)
(tmpls, emptyVarEnv)
@match@ is the main function.
\begin{code}
-match :: GenType flexi_tmpl -> GenType flexi_result -- Current match pair
- -> (Subst flexi_tmpl flexi_result -> Maybe result) -- Continuation
- -> Subst flexi_tmpl flexi_result -- Current substitution
+match :: Type -> Type -- Current match pair
+ -> (Subst -> Maybe result) -- Continuation
+ -> Subst -- Current substitution
-> Maybe result
-- When matching against a type variable, see if the variable
, bagToFM
, FiniteSet, emptySet, mkSet, isEmptySet
- , elementOf, setToList, union, minusSet
+ , elementOf, setToList, union, insert, minusSet
) where
addListToFM :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> [(key,elt)] -> FiniteMap key elt
-- Combines with previous binding
+ -- The combining fn goes (old -> new -> new)
addToFM_C :: (Ord key OUTPUTABLE_key) => (elt -> elt -> elt)
-> FiniteMap key elt -> key -> elt
-> FiniteMap key elt
minusSet :: (Ord key OUTPUTABLE_key) => FiniteSet key -> FiniteSet key -> FiniteSet key
setToList :: FiniteSet key -> [key]
union :: (Ord key OUTPUTABLE_key) => FiniteSet key -> FiniteSet key -> FiniteSet key
+insert :: (Ord key OUTPUTABLE_key) => FiniteSet key -> key -> FiniteSet key
emptySet = emptyFM
mkSet xs = listToFM [ (x, ()) | x <- xs]
minusSet = minusFM
setToList = keysFM
union = plusFM
-
+insert s v = addToFM s v ()
\end{code}
%************************************************************************
text, char, ptext,
int, integer, float, double, rational,
parens, brackets, braces, quotes, doubleQuotes,
- semi, comma, colon, space, equals,
- lparen, rparen, lbrack, rbrack, lbrace, rbrace,
+ semi, comma, colon, dcolon, space, equals, dot,
+ lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore,
(<>), (<+>), hcat, hsep,
($$), ($+$), vcat,
sep, cat,
-- error handling
pprPanic, pprPanic#, pprError, pprTrace, assertPprPanic,
- panic, panic#, assertPanic
+ trace, panic, panic#, assertPanic
) where
#include "HsVersions.h"
import FastString
import qualified Pretty
import Pretty ( Doc, Mode(..), TextDetails(..), fullRender )
-import Util ( panic, assertPanic, panic#, trace )
+import Panic
import ST ( runST )
import Foreign
\end{code}
rbrack sty = Pretty.rbrack
lbrace sty = Pretty.lbrace
rbrace sty = Pretty.rbrace
+dcolon sty = Pretty.ptext SLIT("::")
+underscore = char '_'
+dot = char '.'
nest n d sty = Pretty.nest n (d sty)
(<>) d1 d2 sty = (Pretty.<>) (d1 sty) (d2 sty)
instance (Outputable a, Outputable b) => Outputable (a, b) where
ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
+instance Outputable a => Outputable (Maybe a) where
+ ppr Nothing = text "Nothing"
+ ppr (Just x) = text "Just" <+> ppr x
+
-- ToDo: may not be used
instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
ppr (x,y,z) =
| otherwise = int t <+> ptext SLIT("times")
\end{code}
+
%************************************************************************
%* *
-\subsection[Utils-errors]{Error handling}
+\subsection{Error handling}
%* *
%************************************************************************
\begin{code}
+pprPanic :: String -> SDoc -> a
pprPanic heading pretty_msg = panic (show (doc PprDebug))
where
doc = text heading <+> pretty_msg
+pprError :: String -> SDoc -> a
pprError heading pretty_msg = error (heading++ " " ++ (showSDoc pretty_msg))
+pprTrace :: String -> SDoc -> a -> a
pprTrace heading pretty_msg = trace (show (doc PprDebug))
where
doc = text heading <+> pretty_msg
lookupUFM, lookupUFM_Directly,
lookupWithDefaultUFM, lookupWithDefaultUFM_Directly,
eltsUFM, keysUFM,
- ufmToList,
- FastString
+ ufmToList
) where
#include "HsVersions.h"
import {-# SOURCE #-} Name ( Name )
import Unique ( Uniquable(..), Unique, u2i, mkUniqueGrimily )
-import Util
+import Panic
import GlaExts -- Lots of Int# operations
#if ! OMIT_NATIVE_CODEGEN
zipLazy, stretchZipEqual,
mapAndUnzip, mapAndUnzip3,
nOfThem, lengthExceeds, isSingleton,
- startsWith, endsWith, snocView,
+ snocView,
isIn, isn'tIn,
-- association lists
assoc, assocUsing, assocDefault, assocDefaultUsing,
-- duplicate handling
- hasNoDups, equivClasses, runs, removeDups,
+ hasNoDups, equivClasses, runs, removeDups, equivClassesByUniq,
-- sorting
IF_NOT_GHC(quicksort COMMA stableSortLt COMMA mergesort COMMA)
-- comparisons
thenCmp, cmpList,
- FastString,
-- pairs
IF_NOT_GHC(cfst COMMA applyToPair COMMA applyToFst COMMA)
IF_NOT_GHC(applyToSnd COMMA foldPair COMMA)
- unzipWith,
-
- -- tracing (abstract away from lib home)
- trace,
-
- -- error handling
- panic, panic#, assertPanic
-
+ unzipWith
) where
#include "HsVersions.h"
-import FastString ( FastString )
import List ( zipWith4 )
-import GlaExts ( trace )
+import Panic ( panic )
+import Unique ( Unique )
+import UniqFM ( eltsUFM, emptyUFM, addToUFM_C )
infixr 9 `thenCmp`
\end{code}
isSingleton [x] = True
isSingleton _ = False
-
-startsWith, endsWith :: String -> String -> Maybe String
-
-startsWith [] str = Just str
-startsWith (c:cs) (s:ss)
- = if c /= s then Nothing else startsWith cs ss
-startsWith _ [] = Nothing
-
-endsWith cs ss
- = case (startsWith (reverse cs) (reverse ss)) of
- Nothing -> Nothing
- Just rs -> Just (reverse rs)
\end{code}
\begin{code}
\end{code}
+\begin{code}
+equivClassesByUniq :: (a -> Unique) -> [a] -> [[a]]
+ -- NB: it's *very* important that if we have the input list [a,b,c],
+ -- where a,b,c all have the same unique, then we get back the list
+ -- [a,b,c]
+ -- not
+ -- [c,b,a]
+ -- Hence the use of foldr, plus the reversed-args tack_on below
+equivClassesByUniq get_uniq xs
+ = eltsUFM (foldr add emptyUFM xs)
+ where
+ add a ufm = addToUFM_C tack_on ufm (get_uniq a) [a]
+ tack_on old new = new++old
+\end{code}
+
%************************************************************************
%* *
\subsection[Utils-sorting]{Sorting}
\end{code}
-%************************************************************************
-%* *
-\subsection[Utils-errors]{Error handling}
-%* *
-%************************************************************************
-
-\begin{code}
-panic x = error ("panic! (the `impossible' happened):\n\t"
- ++ x ++ "\n\n"
- ++ "Please report it as a compiler bug "
- ++ "to glasgow-haskell-bugs@dcs.gla.ac.uk.\n\n" )
-
--- #-versions because panic can't return an unboxed int, and that's
--- what TAG_ is with GHC at the moment. Ugh. (Simon)
--- No, man -- Too Beautiful! (Will)
-
-panic# :: String -> FAST_INT
-panic# s = case (panic s) of () -> ILIT(0)
-
-assertPanic :: String -> Int -> a
-assertPanic file line = panic ("ASSERT failed! file " ++ file ++ ", line " ++ show line)
-\end{code}
projects / ghc-hetmet.git / commitdiff