# -----------------------------------------------------------------------------
-# $Id: Makefile,v 1.221 2002/09/06 14:35:43 simonmar Exp $
+# $Id: Makefile,v 1.222 2002/09/13 15:02:25 simonpj Exp $
TOP = ..
ALL_DIRS = \
utils basicTypes types hsSyn prelude rename typecheck deSugar coreSyn \
specialise simplCore stranal stgSyn simplStg codeGen absCSyn main \
- profiling parser usageSP cprAnalysis compMan ndpFlatten
+ profiling parser usageSP cprAnalysis compMan ndpFlatten
# Make sure we include Config.hs even if it doesn't exist yet...
ALL_SRCS += $(CONFIG_HS)
+# HsGeneric.hs is not used just now
+EXCLUDED_SRCS += hsSyn/HsGeneric.hs
+
ifeq ($(GhcWithNativeCodeGen),YES)
ALL_DIRS += nativeGen
else
endif
# Only include GHCi if we're bootstrapping with at least version 411
-ifeq "$(GhcWithInterpreter)" "YES"
-ifeq "$(bootstrapped)" "YES"
-SRC_HC_OPTS += -DGHCI -package readline
+ifeq "$(GhcWithInterpreter) $(bootstrapped)" "YES YES"
+# Yes, include the interepreter, readline, and Template Haskell extensions
+SRC_HC_OPTS += -DGHCI -package readline -package haskell-src
ifneq "$(TARGETPLATFORM)" "i386-unknown-mingw32"
SRC_HC_OPTS += -package unix
endif
ALL_DIRS += ghci
-endif
-endif
+else
+# No interpreter, so exclude Template Haskell modules
+EXCLUDED_SRCS += deSugar/DsMeta.hs typecheck/TcSplice.lhs hsSyn/Convert.lhs
+endif
# There are some C files to include in HS_PROG, so add these to HS_OBJS
HS_OBJS += $(C_OBJS)
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: AbsCSyn.lhs,v 1.49 2002/08/02 13:08:33 simonmar Exp $
+% $Id: AbsCSyn.lhs,v 1.50 2002/09/13 15:02:25 simonpj Exp $
%
\section[AbstractC]{Abstract C: the last stop before machine code}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CLabel.lhs,v 1.54 2002/07/18 09:16:12 simonmar Exp $
+% $Id: CLabel.lhs,v 1.55 2002/09/13 15:02:26 simonpj Exp $
%
\section[CLabel]{@CLabel@: Information to make C Labels}
import Unique ( pprUnique, Unique )
import PrimOp ( PrimOp )
import CostCentre ( CostCentre, CostCentreStack )
-import BasicTypes ( Version )
import Outputable
import FastString
\end{code}
Unused, unused,
- Fixity(..), FixityDirection(..),
+ FixitySig(..), Fixity(..), FixityDirection(..),
defaultFixity, maxPrecedence,
arrowFixity, negateFixity, negatePrecedence,
compareFixity,
StrictnessMark(..), isMarkedUnboxed, isMarkedStrict,
CompilerPhase,
- Activation(..), isActive, isNeverActive, isAlwaysActive
+ Activation(..), isActive, isNeverActive, isAlwaysActive,
+
+ SuccessFlag(..), succeeded, failed, successIf
) where
#include "HsVersions.h"
import Outputable
+import SrcLoc
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
+------------------------
+data FixitySig name = FixitySig name Fixity SrcLoc
+
+instance Eq name => Eq (FixitySig name) where
+ (FixitySig n1 f1 _) == (FixitySig n2 f2 _) = n1==n2 && f1==f2
+
+instance Outputable name => Outputable (FixitySig name) where
+ ppr (FixitySig name fixity loc) = sep [ppr fixity, ppr name]
+
+------------------------
data Fixity = Fixity Int FixityDirection
-data FixityDirection = InfixL | InfixR | InfixN
- deriving(Eq)
instance Outputable Fixity where
ppr (Fixity prec dir) = hcat [ppr dir, space, int prec]
+instance Eq Fixity where -- Used to determine if two fixities conflict
+ (Fixity p1 dir1) == (Fixity p2 dir2) = p1==p2 && dir1 == dir2
+
+------------------------
+data FixityDirection = InfixL | InfixR | InfixN
+ deriving(Eq)
+
instance Outputable FixityDirection where
ppr InfixL = ptext SLIT("infixl")
ppr InfixR = ptext SLIT("infixr")
ppr InfixN = ptext SLIT("infix")
-instance Eq Fixity where -- Used to determine if two fixities conflict
- (Fixity p1 dir1) == (Fixity p2 dir2) = p1==p2 && dir1 == dir2
-
+------------------------
maxPrecedence = (9::Int)
defaultFixity = Fixity maxPrecedence InfixL
%************************************************************************
%* *
+\subsection{Success flag}
+%* *
+%************************************************************************
+
+\begin{code}
+data SuccessFlag = Succeeded | Failed
+
+successIf :: Bool -> SuccessFlag
+successIf True = Succeeded
+successIf False = Failed
+
+succeeded, failed :: SuccessFlag -> Bool
+succeeded Succeeded = True
+succeeded Failed = False
+
+failed Succeeded = False
+failed Failed = True
+\end{code}
+
+
+%************************************************************************
+%* *
\subsection{Activation}
%* *
%************************************************************************
isAlwaysActive AlwaysActive = True
isAlwaysActive other = False
\end{code}
+
-- New demand and strictness info
newStrictnessInfo, setNewStrictnessInfo,
- newDemandInfo, setNewDemandInfo,
+ newDemandInfo, setNewDemandInfo, pprNewStrictness,
-- Strictness; imported from Demand
StrictnessInfo(..),
import DataCon ( DataCon )
import ForeignCall ( ForeignCall )
import FieldLabel ( FieldLabel )
-import Type ( usOnce, usMany )
+import Type ( usOnce )
import Demand hiding( Demand, seqDemand )
import qualified Demand
import NewDemand
import Outputable
-import Util ( seqList, listLengthCmp )
+import Util ( listLengthCmp )
import Maybe ( isJust )
import List ( replicate )
seqNewStrictnessInfo Nothing = ()
seqNewStrictnessInfo (Just ty) = seqStrictSig ty
+pprNewStrictness Nothing = empty
+pprNewStrictness (Just sig) = ftext FSLIT("Str:") <+> ppr sig
+
#ifdef OLD_STRICTNESS
oldStrictnessFromNew :: StrictSig -> Demand.StrictnessInfo
oldStrictnessFromNew sig = mkStrictnessInfo (map oldDemand dmds, isBotRes res_info)
import Ratio ( numerator )
import FastString ( uniqueOfFS, lengthFS )
-import Int ( Int8, Int16, Int32 )
-import Word ( Word8, Word16, Word32 )
+import DATA_INT ( Int8, Int16, Int32 )
+import DATA_WORD ( Word8, Word16, Word32 )
import Char ( ord, chr )
\end{code}
isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType,
tcSplitFunTys, tcSplitForAllTys, mkPredTy
)
-import Module ( Module )
import CoreUtils ( exprType )
import CoreUnfold ( mkTopUnfolding, mkCompulsoryUnfolding, mkOtherCon )
import Literal ( Literal(..), nullAddrLit )
import Class ( Class, classTyCon, classTyVars, classSelIds )
import Var ( Id, TyVar, Var )
import VarSet ( isEmptyVarSet )
-import Name ( mkWiredInName, mkFCallName, Name )
-import OccName ( mkVarOcc )
+import Name ( mkFCallName, Name )
import PrimOp ( PrimOp(DataToTagOp), primOpSig, mkPrimOpIdName )
import ForeignCall ( ForeignCall )
import DataCon ( DataCon,
import ListSetOps ( assoc, assocMaybe )
import UnicodeUtil ( stringToUtf8 )
import List ( nubBy )
-import Char ( ord )
\end{code}
%************************************************************************
\begin{code}
-- unsafeCoerce# :: forall a b. a -> b
unsafeCoerceId
- = pcMiscPrelId unsafeCoerceIdKey gHC_PRIM FSLIT("unsafeCoerce#") ty info
+ = pcMiscPrelId unsafeCoerceName ty info
where
info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
-- The reason is is here is because we don't provide
-- a way to write this literal in Haskell.
nullAddrId
- = pcMiscPrelId nullAddrIdKey gHC_PRIM FSLIT("nullAddr#") addrPrimTy info
+ = pcMiscPrelId nullAddrName addrPrimTy info
where
info = noCafIdInfo `setUnfoldingInfo`
mkCompulsoryUnfolding (Lit nullAddrLit)
seqId
- = pcMiscPrelId seqIdKey gHC_PRIM FSLIT("seq") ty info
+ = pcMiscPrelId seqName ty info
where
info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
-- the info in PrelBase.hi. This is important, because the strictness
-- analyser will spot it as strict!
lazyId
- = pcMiscPrelId lazyIdKey pREL_BASE FSLIT("lazy") ty info
+ = pcMiscPrelId lazyIdName ty info
where
info = noCafIdInfo
ty = mkForAllTys [alphaTyVar] (mkFunTy alphaTy alphaTy)
\begin{code}
getTagId
- = pcMiscPrelId getTagIdKey gHC_PRIM FSLIT("getTag#") ty info
+ = pcMiscPrelId getTagName ty info
where
info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
-- We don't provide a defn for this; you must inline it
\begin{code}
realWorldPrimId -- :: State# RealWorld
- = pcMiscPrelId realWorldPrimIdKey gHC_PRIM FSLIT("realWorld#")
- realWorldStatePrimTy
+ = pcMiscPrelId realWorldName realWorldStatePrimTy
(noCafIdInfo `setUnfoldingInfo` mkOtherCon [])
-- The mkOtherCon makes it look that realWorld# is evaluated
-- which in turn makes Simplify.interestingArg return True,
where
err_string = Lit (MachStr (mkFastString (stringToUtf8 err_msg)))
-rEC_SEL_ERROR_ID = mkRuntimeErrorId recSelErrIdKey FSLIT("recSelError")
-rUNTIME_ERROR_ID = mkRuntimeErrorId runtimeErrorIdKey FSLIT("runtimeError")
-
-iRREFUT_PAT_ERROR_ID = mkRuntimeErrorId irrefutPatErrorIdKey FSLIT("irrefutPatError")
-rEC_CON_ERROR_ID = mkRuntimeErrorId recConErrorIdKey FSLIT("recConError")
-nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId nonExhaustiveGuardsErrorIdKey FSLIT("nonExhaustiveGuardsError")
-pAT_ERROR_ID = mkRuntimeErrorId patErrorIdKey FSLIT("patError")
-nO_METHOD_BINDING_ERROR_ID = mkRuntimeErrorId noMethodBindingErrorIdKey FSLIT("noMethodBindingError")
+rEC_SEL_ERROR_ID = mkRuntimeErrorId recSelErrorName
+rUNTIME_ERROR_ID = mkRuntimeErrorId runtimeErrorName
+iRREFUT_PAT_ERROR_ID = mkRuntimeErrorId irrefutPatErrorName
+rEC_CON_ERROR_ID = mkRuntimeErrorId recConErrorName
+nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId nonExhaustiveGuardsErrorName
+pAT_ERROR_ID = mkRuntimeErrorId patErrorName
+nO_METHOD_BINDING_ERROR_ID = mkRuntimeErrorId noMethodBindingErrorName
-- The runtime error Ids take a UTF8-encoded string as argument
-mkRuntimeErrorId key name = pc_bottoming_Id key pREL_ERR name runtimeErrorTy
-runtimeErrorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy)
+mkRuntimeErrorId name = pc_bottoming_Id name runtimeErrorTy
+runtimeErrorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy)
\end{code}
\begin{code}
-eRROR_ID = pc_bottoming_Id errorIdKey pREL_ERR FSLIT("error") errorTy
+eRROR_ID = pc_bottoming_Id errorName errorTy
errorTy :: Type
errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy)
%************************************************************************
\begin{code}
-pcMiscPrelId :: Unique{-IdKey-} -> Module -> FastString -> Type -> IdInfo -> Id
-pcMiscPrelId key mod str ty info
- = let
- name = mkWiredInName mod (mkVarOcc str) key
- imp = mkVanillaGlobal name ty info -- the usual case...
- in
- imp
+pcMiscPrelId :: Name -> Type -> IdInfo -> Id
+pcMiscPrelId name ty info
+ = mkVanillaGlobal name ty info
-- We lie and say the thing is imported; otherwise, we get into
-- a mess with dependency analysis; e.g., core2stg may heave in
-- random calls to GHCbase.unpackPS__. If GHCbase is the module
-- being compiled, then it's just a matter of luck if the definition
-- will be in "the right place" to be in scope.
-pc_bottoming_Id key mod name ty
- = pcMiscPrelId key mod name ty bottoming_info
+pc_bottoming_Id name ty
+ = pcMiscPrelId name ty bottoming_info
where
bottoming_info = hasCafIdInfo `setAllStrictnessInfo` Just strict_sig
-- Do *not* mark them as NoCafRefs, because they can indeed have
(
Module, -- Abstract, instance of Eq, Ord, Outputable
- , PackageName -- = FastString; instance of Outputable, Uniquable
- , preludePackage -- :: PackageName
+ , ModLocation(..),
+ , showModMsg
, ModuleName
, pprModuleName -- :: ModuleName -> SDoc
, mkVanillaModule -- :: ModuleName -> Module
, isVanillaModule -- :: Module -> Bool
, mkPrelModule -- :: UserString -> Module
- , mkModule -- :: ModuleName -> PackageName -> Module
, mkHomeModule -- :: ModuleName -> Module
, isHomeModule -- :: Module -> Bool
, mkPackageModule -- :: ModuleName -> Module
, pprModule,
- -- Where to find a .hi file
- , WhereFrom(..)
-
, ModuleEnv,
, elemModuleEnv, extendModuleEnv, extendModuleEnvList, plusModuleEnv_C
, delModuleEnvList, delModuleEnv, plusModuleEnv, lookupModuleEnv
, lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv
, moduleEnvElts, unitModuleEnv, isEmptyModuleEnv, foldModuleEnv
- , lookupModuleEnvByName, extendModuleEnv_C
+ , extendModuleEnv_C
+ , lookupModuleEnvByName, extendModuleEnvByName, unitModuleEnvByName
, ModuleSet, emptyModuleSet, mkModuleSet, moduleSetElts, extendModuleSet, elemModuleSet
#include "HsVersions.h"
import OccName
import Outputable
+import Packages ( PackageName, preludePackage )
import CmdLineOpts ( opt_InPackage )
import FastString ( FastString )
import Unique ( Uniquable(..) )
+import Maybes ( expectJust )
import UniqFM
import UniqSet
import Binary
-- Later on (in RnEnv.newTopBinder) we'll update the cache
-- to have the right PackageName
-type PackageName = FastString -- No encoding at all
-
-preludePackage :: PackageName
-preludePackage = FSLIT("base")
-
packageInfoPackage :: PackageInfo -> PackageName
packageInfoPackage ThisPackage = opt_InPackage
packageInfoPackage DunnoYet = FSLIT("<?>")
%************************************************************************
%* *
-\subsection{Where from}
+\subsection{Module locations}
%* *
%************************************************************************
-The @WhereFrom@ type controls where the renamer looks for an interface file
-
\begin{code}
-data WhereFrom = ImportByUser -- Ordinary user import: look for M.hi
- | ImportByUserSource -- User {- SOURCE -}: look for M.hi-boot
- | ImportBySystem -- Non user import. Look for M.hi if M is in
- -- the module this module depends on, or is a system-ish module;
- -- M.hi-boot otherwise
- | ImportByCmdLine -- The user typed a qualified name at
- -- the GHCi prompt, try to demand-load
- -- the interface.
-
-instance Outputable WhereFrom where
- ppr ImportByUser = empty
- ppr ImportByUserSource = ptext SLIT("{- SOURCE -}")
- ppr ImportBySystem = ptext SLIT("{- SYSTEM IMPORT -}")
+data ModLocation
+ = ModLocation {
+ ml_hs_file :: Maybe FilePath,
+ ml_hspp_file :: Maybe FilePath, -- path of preprocessed source
+ ml_hi_file :: FilePath,
+ ml_obj_file :: Maybe FilePath
+ }
+ deriving Show
+
+instance Outputable ModLocation where
+ ppr = text . show
+
+-- Rather a gruesome function to have in Module
+
+showModMsg :: Bool -> Module -> ModLocation -> String
+showModMsg use_object mod location =
+ mod_str ++ replicate (max 0 (16 - length mod_str)) ' '
+ ++" ( " ++ expectJust "showModMsg" (ml_hs_file location) ++ ", "
+ ++ (if use_object
+ then expectJust "showModMsg" (ml_obj_file location)
+ else "interpreted")
+ ++ " )"
+ where mod_str = moduleUserString mod
\end{code}
+For a module in another package, the hs_file and obj_file
+components of ModLocation are undefined.
+
+The locations specified by a ModLocation may or may not
+correspond to actual files yet: for example, even if the object
+file doesn't exist, the ModLocation still contains the path to
+where the object file will reside if/when it is created.
+
%************************************************************************
%* *
pprModule (Module mod p) = getPprStyle $ \ sty ->
if debugStyle sty then
-- Print the package too
- ppr p <> dot <> pprModuleName mod
+ -- Don't use '.' because it gets confused
+ -- with module names
+ brackets (ppr p) <> pprModuleName mod
else
pprModuleName mod
\end{code}
\begin{code}
-mkModule :: ModuleName -- Name of the module
- -> PackageName
- -> Module
-mkModule mod_nm pack_name
+mkPrelModule :: ModuleName -> Module
+mkPrelModule mod_nm
= Module mod_nm pack_info
where
- pack_info | pack_name == opt_InPackage = ThisPackage
- | otherwise = AnotherPackage
+ pack_info
+ | opt_InPackage == preludePackage = ThisPackage
+ | otherwise = AnotherPackage
mkHomeModule :: ModuleName -> Module
mkHomeModule mod_nm = Module mod_nm ThisPackage
isVanillaModule (Module nm DunnoYet) = True
isVanillaModule _ = False
-mkPrelModule :: ModuleName -> Module
-mkPrelModule name = mkModule name preludePackage
-
moduleString :: Module -> EncodedString
moduleString (Module (ModuleName fs) _) = unpackFS fs
\begin{code}
type ModuleEnv elt = UniqFM elt
+-- A ModuleName and Module have the same Unique,
+-- so both will work as keys.
+-- The 'ByName' variants work on ModuleNames
emptyModuleEnv :: ModuleEnv a
mkModuleEnv :: [(Module, a)] -> ModuleEnv a
isEmptyModuleEnv :: ModuleEnv a -> Bool
lookupModuleEnv :: ModuleEnv a -> Module -> Maybe a
-lookupModuleEnvByName:: ModuleEnv a -> ModuleName -> Maybe a
lookupWithDefaultModuleEnv :: ModuleEnv a -> a -> Module -> a
elemModuleEnv :: Module -> ModuleEnv a -> Bool
foldModuleEnv :: (a -> b -> b) -> b -> ModuleEnv a -> b
+-- The ByName variants
+lookupModuleEnvByName :: ModuleEnv a -> ModuleName -> Maybe a
+unitModuleEnvByName :: ModuleName -> a -> ModuleEnv a
+extendModuleEnvByName :: ModuleEnv a -> ModuleName -> a -> ModuleEnv a
+
elemModuleEnv = elemUFM
extendModuleEnv = addToUFM
+extendModuleEnvByName = addToUFM
extendModuleEnv_C = addToUFM_C
extendModuleEnvList = addListToUFM
plusModuleEnv_C = plusUFM_C
emptyModuleEnv = emptyUFM
moduleEnvElts = eltsUFM
unitModuleEnv = unitUFM
+unitModuleEnvByName = unitUFM
isEmptyModuleEnv = isNullUFM
foldModuleEnv = foldUFM
\end{code}
nameUnique, setNameUnique,
nameOccName, nameModule, nameModule_maybe,
- setNameOcc, nameRdrName, setNameModuleAndLoc,
- toRdrName, hashName,
- externaliseName, localiseName,
+ setNameOcc, setNameModuleAndLoc,
+ hashName, externaliseName, localiseName,
- nameSrcLoc,
+ nameSrcLoc, eqNameByOcc,
isSystemName, isInternalName, isExternalName,
- isTyVarName, isDllName,
+ isTyVarName, isDllName, isWiredInName,
nameIsLocalOrFrom, isHomePackageName,
-- Class NamedThing and overloaded friends
NamedThing(..),
- getSrcLoc, getOccString, toRdrName
+ getSrcLoc, getOccString
) where
#include "HsVersions.h"
import OccName -- All of it
-import Module ( Module, moduleName, mkVanillaModule, isHomeModule )
-import RdrName ( RdrName, mkRdrOrig, mkRdrUnqual, rdrNameOcc, rdrNameModule )
+import Module ( Module, ModuleName, moduleName, mkVanillaModule, isHomeModule )
import CmdLineOpts ( opt_Static )
-import SrcLoc ( builtinSrcLoc, noSrcLoc, SrcLoc )
+import SrcLoc ( noSrcLoc, isWiredInLoc, wiredInSrcLoc, SrcLoc )
import Unique ( Unique, Uniquable(..), getKey, pprUnique )
import FastTypes
-import Binary
import Outputable
\end{code}
nameUnique name = n_uniq name
nameOccName name = n_occ name
nameSrcLoc name = n_loc name
-
-nameModule (Name { n_sort = External mod }) = mod
-nameModule name = pprPanic "nameModule" (ppr name)
-
-nameModule_maybe (Name { n_sort = External mod }) = Just mod
-nameModule_maybe name = Nothing
\end{code}
\begin{code}
isExternalName :: Name -> Bool
isSystemName :: Name -> Bool
isHomePackageName :: Name -> Bool
+isWiredInName :: Name -> Bool
+
+isWiredInName name = isWiredInLoc (n_loc name)
isExternalName (Name {n_sort = External _}) = True
-isExternalName other = False
+isExternalName other = False
+
+nameModule (Name { n_sort = External mod }) = mod
+nameModule name = pprPanic "nameModule" (ppr name)
+
+nameModule_maybe (Name { n_sort = External mod }) = Just mod
+nameModule_maybe name = Nothing
isInternalName name = not (isExternalName name)
isSystemName (Name {n_sort = System}) = True
isSystemName other = False
+
+eqNameByOcc :: Name -> Name -> Bool
+-- Compare using the strings, not the unique
+-- See notes with HsCore.eq_ufVar
+eqNameByOcc (Name {n_sort = sort1, n_occ = occ1})
+ (Name {n_sort = sort2, n_occ = occ2})
+ = sort1 `eq_sort` sort2 && occ1 == occ2
+ where
+ eq_sort (External m1) (External m2) = moduleName m1 == moduleName m2
+ eq_sort (External _) _ = False
+ eq_sort _ (External _) = False
+ eq_sort _ _ = True
\end{code}
mkExternalName uniq mod occ loc = Name { n_uniq = uniq, n_sort = External mod,
n_occ = occ, n_loc = loc }
-mkKnownKeyExternalName :: RdrName -> Unique -> Name
-mkKnownKeyExternalName rdr_name uniq
- = mkExternalName uniq (mkVanillaModule (rdrNameModule rdr_name))
- (rdrNameOcc rdr_name)
- builtinSrcLoc
+mkKnownKeyExternalName :: ModuleName -> OccName -> Unique -> Name
+mkKnownKeyExternalName mod occ uniq
+ = mkExternalName uniq (mkVanillaModule mod) occ noSrcLoc
mkWiredInName :: Module -> OccName -> Unique -> Name
-mkWiredInName mod occ uniq = mkExternalName uniq mod occ builtinSrcLoc
+mkWiredInName mod occ uniq = mkExternalName uniq mod occ wiredInSrcLoc
mkSystemName :: Unique -> UserFS -> Name
mkSystemName uniq fs = Name { n_uniq = uniq, n_sort = System,
\begin{code}
hashName :: Name -> Int
hashName name = iBox (getKey (nameUnique name))
-
-
-nameRdrName :: Name -> RdrName
--- Makes a qualified name for top-level (External) names,
--- whether locally defined or not and an unqualified name just for Internals
-nameRdrName (Name { n_occ = occ, n_sort = External mod }) = mkRdrOrig (moduleName mod) occ
-nameRdrName (Name { n_occ = occ }) = mkRdrUnqual occ
\end{code}
getName n = n
\end{code}
-%************************************************************************
-%* *
-\subsection{Binary output}
-%* *
-%************************************************************************
-
-\begin{code}
-instance Binary Name where
- -- we must print these as RdrNames, because that's how they will be read in
- put_ bh Name {n_sort = sort, n_uniq = uniq, n_occ = occ} =
- case sort of
- External mod
- | this_mod == mod -> put_ bh (mkRdrUnqual occ)
- | otherwise -> put_ bh (mkRdrOrig (moduleName mod) occ)
- where (this_mod,_,_,_) = getUserData bh
- _ -> do
- put_ bh (mkRdrUnqual occ)
-
- get bh = error "can't Binary.get a Name"
-\end{code}
%************************************************************************
%* *
-- When printing interfaces, all Internals have been given nice print-names
ppr name = pprName name
+instance OutputableBndr Name where
+ pprBndr _ name = pprName name
+
pprName name@(Name {n_sort = sort, n_uniq = uniq, n_occ = occ})
= getPprStyle $ \ sty ->
case sort of
\begin{code}
getSrcLoc :: NamedThing a => a -> SrcLoc
getOccString :: NamedThing a => a -> String
-toRdrName :: NamedThing a => a -> RdrName
getSrcLoc = nameSrcLoc . getName
getOccString = occNameString . getOccName
-toRdrName = nameRdrName . getName
\end{code}
module NameEnv (
NameEnv, mkNameEnv,
emptyNameEnv, unitNameEnv, nameEnvElts,
- extendNameEnv_C, extendNameEnv, foldNameEnv, filterNameEnv,
- plusNameEnv, plusNameEnv_C, extendNameEnv, extendNameEnvList,
+ extendNameEnv_C, extendNameEnv, extendNameEnvList,
+ foldNameEnv, filterNameEnv,
+ plusNameEnv, plusNameEnv_C,
lookupNameEnv, lookupNameEnv_NF, delFromNameEnv, delListFromNameEnv,
elemNameEnv
) where
-------------
isLexConId cs -- Prefix type or data constructors
- | nullFastString cs = False -- e.g. "Foo", "[]", "(,)"
+ | nullFastString cs = False -- e.g. "Foo", "[]", "(,)"
| cs == FSLIT("[]") = True
| otherwise = startsConId (headFS cs)
isLexVarId cs -- Ordinary prefix identifiers
- | nullFastString cs = False -- e.g. "x", "_x"
- | otherwise = startsVarId (headFS cs)
+ | nullFastString cs = False -- e.g. "x", "_x"
+ | otherwise = startsVarId (headFS cs)
isLexConSym cs -- Infix type or data constructors
- | nullFastString cs = False -- e.g. ":-:", ":", "->"
+ | nullFastString cs = False -- e.g. ":-:", ":", "->"
| cs == FSLIT("->") = True
- | otherwise = startsConSym (headFS cs)
+ | otherwise = startsConSym (headFS cs)
isLexVarSym cs -- Infix identifiers
- | nullFastString cs = False -- e.g. "+"
- | otherwise = startsVarSym (headFS cs)
+ | nullFastString cs = False -- e.g. "+"
+ | otherwise = startsVarSym (headFS cs)
-------------
startsVarSym, startsVarId, startsConSym, startsConId :: Char -> Bool
+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1996-1998
-%
-\section[PprEnv]{The @PprEnv@ type}
-
-\begin{code}
-module PprEnv (
- PprEnv, --
- BindingSite(..),
-
- initPprEnv,
-
- pBndr, pOcc, pSCC,
- pTy, pTyVarO
- ) where
-
-#include "HsVersions.h"
-
-import Var ( Id, TyVar )
-import CostCentre ( CostCentre )
-import Type ( Type )
-import Outputable
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Public interfaces for Core printing (excluding instances)}
-%* *
-%************************************************************************
-
-\begin{code}
-data PprEnv bndr
- = PE {
- pSCC :: CostCentre -> SDoc,
-
- pTyVarO :: TyVar -> SDoc, -- to print tyvar occurrences
- pTy :: Type -> SDoc, -- to print types
-
- pBndr :: BindingSite -> bndr -> SDoc, -- to print value binders
- pOcc :: Id -> SDoc -- to print value occurrences
- }
-\end{code}
-
-@BindingSite@ is used to tell the thing that prints binder what
-language construct is binding the identifier.
-
-\begin{code}
-data BindingSite = LambdaBind | CaseBind | LetBind
-\end{code}
-
-\begin{code}
-initPprEnv
- :: Maybe (CostCentre -> SDoc)
- -> Maybe (TyVar -> SDoc)
- -> Maybe (Type -> SDoc)
- -> Maybe (BindingSite -> bndr -> SDoc)
- -> Maybe (Id -> SDoc)
- -> PprEnv bndr
-
--- you can specify all the printers individually; if
--- you don't specify one, you get bottom
-
-initPprEnv c tvo ty bndr occ
- = PE (demaybe c)
- (demaybe tvo)
- (demaybe ty)
- (demaybe bndr)
- (demaybe occ)
- where
- demaybe Nothing = bottom
- demaybe (Just x) = x
-
- bottom = panic "PprEnv.initPprEnv: unspecified printing function"
-\end{code}
-
RdrName,
-- Construction
- mkRdrUnqual, mkRdrQual, mkRdrOrig, mkRdrUnqual,
- mkUnqual, mkQual, mkIfaceOrig, mkOrig,
+ mkRdrUnqual, mkRdrQual,
+ mkUnqual, mkQual, mkOrig, mkIfaceOrig,
+ nameRdrName, getRdrName,
qualifyRdrName, unqualifyRdrName, mkRdrNameWkr,
dummyRdrVarName, dummyRdrTcName,
-- Destruction
- rdrNameModule, rdrNameOcc, setRdrNameOcc,
- isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isUnqual, isOrig,
+ rdrNameModule, rdrNameOcc, setRdrNameSpace,
+ isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isUnqual,
+ isOrig, isExact, isExact_maybe,
-- Environment
RdrNameEnv,
import OccName ( NameSpace, tcName,
OccName, UserFS, EncodedFS,
- mkSysOccFS,
- mkOccFS, mkVarOcc,
+ mkSysOccFS, setOccNameSpace,
+ mkOccFS, mkVarOcc, occNameFlavour,
isDataOcc, isTvOcc, isTcOcc, mkWorkerOcc
)
import Module ( ModuleName,
mkSysModuleNameFS, mkModuleNameFS
)
+import Name ( Name, NamedThing(getName), nameModule, nameOccName )
+import Module ( moduleName )
import FiniteMap
import Outputable
import Binary
%************************************************************************
\begin{code}
-data RdrName = RdrName Qual OccName
- {-! derive: Binary !-}
-
-data Qual
- = Unqual
-
- | Qual ModuleName -- A qualified name written by the user in source code
- -- The module isn't necessarily the module where
- -- the thing is defined; just the one from which it
- -- is imported
-
- | Orig ModuleName -- This is an *original* name; the module is the place
- -- where the thing was defined
- {-! derive: Binary !-}
-
+data RdrName
+ = Unqual OccName
+ -- Used for ordinary, unqualified occurrences
+
+ | Qual ModuleName OccName
+ -- A qualified name written by the user in
+ -- *source* code. The module isn't necessarily
+ -- the module where the thing is defined;
+ -- just the one from which it is imported
+
+ | Orig ModuleName OccName
+ -- An original name; the module is the *defining* module.
+ -- This is used when GHC generates code that will be fed
+ -- into the renamer (e.g. from deriving clauses), but where
+ -- we want to say "Use Prelude.map dammit".
+
+ | Exact Name
+ -- We know exactly the Name. This is used
+ -- (a) when the parser parses built-in syntax like "[]"
+ -- and "(,)", but wants a RdrName from it
+ -- (b) possibly, by the meta-programming stuff
\end{code}
\begin{code}
rdrNameModule :: RdrName -> ModuleName
-rdrNameModule (RdrName (Qual m) _) = m
-rdrNameModule (RdrName (Orig m) _) = m
-rdrNameModule n = pprPanic "rdrNameModule" (ppr n)
+rdrNameModule (Qual m _) = m
+rdrNameModule (Orig m _) = m
+rdrNameModule (Exact n) = moduleName (nameModule n)
+rdrNameModule (Unqual n) = pprPanic "rdrNameModule" (ppr n)
rdrNameOcc :: RdrName -> OccName
-rdrNameOcc (RdrName _ occ) = occ
-
-setRdrNameOcc :: RdrName -> OccName -> RdrName
-setRdrNameOcc (RdrName q _) occ = RdrName q occ
+rdrNameOcc (Qual _ occ) = occ
+rdrNameOcc (Unqual occ) = occ
+rdrNameOcc (Orig _ occ) = occ
+rdrNameOcc (Exact name) = nameOccName name
+
+setRdrNameSpace :: RdrName -> NameSpace -> RdrName
+-- This rather gruesome function is used mainly by the parser
+-- When parsing data T a = T | T1 Int
+-- we parse the data constructors as *types* because of parser ambiguities,
+-- so then we need to change the *type constr* to a *data constr*
+--
+-- The original-name case *can* occur when parsing
+-- data [] a = [] | a : [a]
+-- For the orig-name case we return an unqualified name.
+setRdrNameSpace (Unqual occ) ns = Unqual (setOccNameSpace occ ns)
+setRdrNameSpace (Qual m occ) ns = Qual m (setOccNameSpace occ ns)
+setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace occ ns)
+setRdrNameSpace (Exact n) ns = Unqual (setOccNameSpace (nameOccName n) ns)
\end{code}
\begin{code}
-- These two are the basic constructors
mkRdrUnqual :: OccName -> RdrName
-mkRdrUnqual occ = RdrName Unqual occ
+mkRdrUnqual occ = Unqual occ
mkRdrQual :: ModuleName -> OccName -> RdrName
-mkRdrQual mod occ = RdrName (Qual mod) occ
+mkRdrQual mod occ = Qual mod occ
-mkRdrOrig :: ModuleName -> OccName -> RdrName
-mkRdrOrig mod occ = RdrName (Orig mod) occ
+mkOrig :: ModuleName -> OccName -> RdrName
+mkOrig mod occ = Orig mod occ
mkIfaceOrig :: NameSpace -> (EncodedFS, EncodedFS) -> RdrName
-mkIfaceOrig ns (m,n) = RdrName (Orig (mkSysModuleNameFS m)) (mkSysOccFS ns n)
+mkIfaceOrig ns (m,n) = Qual (mkSysModuleNameFS m) (mkSysOccFS ns n)
-- These two are used when parsing source files
-- They do encode the module and occurrence names
mkUnqual :: NameSpace -> UserFS -> RdrName
-mkUnqual sp n = RdrName Unqual (mkOccFS sp n)
+mkUnqual sp n = Unqual (mkOccFS sp n)
mkQual :: NameSpace -> (UserFS, UserFS) -> RdrName
-mkQual sp (m, n) = RdrName (Qual (mkModuleNameFS m)) (mkOccFS sp n)
+mkQual sp (m, n) = Qual (mkModuleNameFS m) (mkOccFS sp n)
+
+getRdrName :: NamedThing thing => thing -> RdrName
+getRdrName name = Exact (getName name)
-mkOrig :: NameSpace -> ModuleName -> UserFS -> RdrName
-mkOrig sp mod n = RdrName (Orig mod) (mkOccFS sp n)
+nameRdrName :: Name -> RdrName
+nameRdrName name = Exact name
qualifyRdrName :: ModuleName -> RdrName -> RdrName
-- Sets the module name of a RdrName, even if it has one already
-qualifyRdrName mod (RdrName _ occ) = RdrName (Qual mod) occ
+qualifyRdrName mod rn = Qual mod (rdrNameOcc rn)
unqualifyRdrName :: RdrName -> RdrName
-unqualifyRdrName (RdrName _ occ) = RdrName Unqual occ
+unqualifyRdrName rdr_name = Unqual (rdrNameOcc rdr_name)
mkRdrNameWkr :: RdrName -> RdrName -- Worker-ify it
-mkRdrNameWkr (RdrName qual occ) = RdrName qual (mkWorkerOcc occ)
+mkRdrNameWkr rdr_name = Qual (rdrNameModule rdr_name)
+ (mkWorkerOcc (rdrNameOcc rdr_name))
\end{code}
\begin{code}
-- the renamer. We can't just put "error..." because
-- we sometimes want to print out stuff after reading but
-- before renaming
-dummyRdrVarName = RdrName Unqual (mkVarOcc FSLIT("V-DUMMY"))
-dummyRdrTcName = RdrName Unqual (mkOccFS tcName FSLIT("TC-DUMMY"))
+dummyRdrVarName = Unqual (mkVarOcc FSLIT("V-DUMMY"))
+dummyRdrTcName = Unqual (mkOccFS tcName FSLIT("TC-DUMMY"))
\end{code}
\begin{code}
-isRdrDataCon (RdrName _ occ) = isDataOcc occ
-isRdrTyVar (RdrName _ occ) = isTvOcc occ
-isRdrTc (RdrName _ occ) = isTcOcc occ
+isRdrDataCon rn = isDataOcc (rdrNameOcc rn)
+isRdrTyVar rn = isTvOcc (rdrNameOcc rn)
+isRdrTc rn = isTcOcc (rdrNameOcc rn)
-isUnqual (RdrName Unqual _) = True
-isUnqual other = False
+isUnqual (Unqual _) = True
+isUnqual other = False
-isQual (RdrName (Qual _) _) = True
-isQual _ = False
+isQual (Qual _ _) = True
+isQual _ = False
-isOrig (RdrName (Orig _) _) = True
-isOrig other = False
+isOrig (Orig _ _) = True
+isOrig _ = False
+
+isExact (Exact _) = True
+isExact other = False
+
+isExact_maybe (Exact n) = Just n
+isExact_maybe other = Nothing
\end{code}
\begin{code}
instance Outputable RdrName where
- ppr (RdrName qual occ) = pp_qual qual <> ppr occ
- where
- pp_qual Unqual = empty
- pp_qual (Qual mod) = ppr mod <> dot
- pp_qual (Orig mod) = ppr mod <> dot
+ ppr (Exact name) = ppr name
+ ppr (Unqual occ) = ppr occ <+> ppr_name_space occ
+ ppr (Qual mod occ) = ppr mod <> dot <> ppr occ <+> ppr_name_space occ
+ ppr (Orig mod occ) = ppr mod <> dot <> ppr occ <+> ppr_name_space occ
+
+ppr_name_space occ = ifPprDebug (parens (text (occNameFlavour occ)))
-pprUnqualRdrName (RdrName qual occ) = ppr occ
+instance OutputableBndr RdrName where
+ pprBndr _ n
+ | isTvOcc (rdrNameOcc n) = char '@' <+> ppr n
+ | otherwise = ppr n
+
+pprUnqualRdrName rdr_name = ppr (rdrNameOcc rdr_name)
instance Eq RdrName where
a == b = case (a `compare` b) of { EQ -> True; _ -> 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 (RdrName q1 o1) (RdrName q2 o2)
- = (o1 `compare` o2) `thenCmp`
- (q1 `cmpQual` q2)
-
-cmpQual Unqual Unqual = EQ
-cmpQual (Qual m1) (Qual m2) = m1 `compare` m2
-cmpQual (Orig m1) (Orig m2) = m1 `compare` m2
-cmpQual Unqual _ = LT
-cmpQual (Qual _) (Orig _) = LT
-cmpQual _ _ = GT
+ -- Unqual < Qual < Orig < Exact
+ compare (Qual m1 o1) (Qual m2 o2) = (o1 `compare` o2) `thenCmp` (m1 `compare` m2)
+ compare (Orig m1 o1) (Orig m2 o2) = (o1 `compare` o2) `thenCmp` (m1 `compare` m2)
+ compare (Unqual o1) (Unqual o2) = o1 `compare` o2
+ compare (Exact n1) (Exact n2) = n1 `compare` n2
+
+ compare (Unqual _) _ = LT
+
+ compare (Qual _ _) (Orig _ _) = LT
+ compare (Qual _ _) (Exact _) = LT
+
+ compare (Orig _ _) (Exact _) = LT
+
+ compare _ _ = GT
\end{code}
elemRdrEnv = elemFM
foldRdrEnv = foldFM
\end{code}
+
\begin{code}
-{-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-}
instance Binary RdrName where
- put_ bh (RdrName aa ab) = do
+ put_ bh (Unqual aa) = do
+ putByte bh 0
put_ bh aa
- put_ bh ab
- get bh = do
- aa <- get bh
- ab <- get bh
- return (RdrName aa ab)
-instance Binary Qual where
- put_ bh Unqual = do
- putByte bh 0
- put_ bh (Qual aa) = do
+ put_ bh (Qual aa ab) = do
putByte bh 1
put_ bh aa
- put_ bh (Orig ab) = do
+ put_ bh ab
+
+ put_ bh (Orig aa ab) = do
putByte bh 2
+ put_ bh aa
put_ bh ab
- get bh = do
- h <- getByte bh
- case h of
- 0 -> do return Unqual
- 1 -> do aa <- get bh
- return (Qual aa)
- _ -> do ab <- get bh
- return (Orig ab)
--- Imported from other files :-
+ put_ bh (Exact n) = pprPanic "No Binary instance for RdrName.Exact" (ppr n)
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do aa <- get bh
+ return (Unqual aa)
+ 1 -> do aa <- get bh
+ ab <- get bh
+ return (Qual aa ab)
+ _ -> do aa <- get bh
+ ab <- get bh
+ return (Orig aa ab)
\end{code}
module SrcLoc (
SrcLoc, -- Abstract
- mkSrcLoc, isGoodSrcLoc,
+ mkSrcLoc, isGoodSrcLoc, isWiredInLoc,
noSrcLoc, -- "I'm sorry, I haven't a clue"
importedSrcLoc, -- Unknown place in an interface
- builtinSrcLoc, -- Something wired into the compiler
+ wiredInSrcLoc, -- Something wired into the compiler
generatedSrcLoc, -- Code generated within the compiler
incSrcLine, replaceSrcLine,
this is the obvious stuff:
\begin{code}
data SrcLoc
- = SrcLoc FastString -- A precise location (file name)
+ = WiredInLoc -- Used exclusively for Ids and TyCons
+ -- that are totally wired in to the
+ -- compiler. That supports the
+ -- occasionally-useful predicate
+ -- isWiredInName
+
+ | SrcLoc FastString -- A precise location (file name)
FastInt
| UnhelpfulSrcLoc FastString -- Just a general indication
-
- | NoSrcLoc
\end{code}
Note that an entity might be imported via more than one route, and
Things to make 'em:
\begin{code}
mkSrcLoc x y = SrcLoc x (iUnbox y)
-noSrcLoc = NoSrcLoc
+wiredInSrcLoc = WiredInLoc
+noSrcLoc = UnhelpfulSrcLoc FSLIT("<No locn>")
importedSrcLoc = UnhelpfulSrcLoc FSLIT("<imported>")
-builtinSrcLoc = UnhelpfulSrcLoc FSLIT("<built-into-the-compiler>")
generatedSrcLoc = UnhelpfulSrcLoc FSLIT("<compiler-generated-code>")
isGoodSrcLoc (SrcLoc _ _) = True
isGoodSrcLoc other = False
+isWiredInLoc WiredInLoc = True
+isWiredInLoc other = False
+
srcLocFile :: SrcLoc -> FastString
srcLocFile (SrcLoc fname _) = fname
instance Ord SrcLoc where
compare = cmpSrcLoc
-cmpSrcLoc NoSrcLoc NoSrcLoc = EQ
-cmpSrcLoc NoSrcLoc other = LT
+cmpSrcLoc WiredInLoc WiredInLoc = EQ
+cmpSrcLoc WiredInLoc other = LT
cmpSrcLoc (UnhelpfulSrcLoc s1) (UnhelpfulSrcLoc s2) = s1 `compare` s2
cmpSrcLoc (UnhelpfulSrcLoc s1) other = GT
-cmpSrcLoc (SrcLoc s1 l1) NoSrcLoc = GT
+cmpSrcLoc (SrcLoc s1 l1) WiredInLoc = GT
cmpSrcLoc (SrcLoc s1 l1) (UnhelpfulSrcLoc _) = LT
cmpSrcLoc (SrcLoc s1 l1) (SrcLoc s2 l2) = (s1 `compare` s2) `thenCmp` (l1 `cmpline` l2)
where
-- so emacs can find the file
ppr (UnhelpfulSrcLoc s) = ftext s
- ppr NoSrcLoc = ptext SLIT("<No locn>")
+ ppr WiredInLoc = ptext SLIT("<Wired in>")
\end{code}
tyVarName, tyVarKind,
setTyVarName, setTyVarUnique,
mkTyVar, mkSysTyVar,
- newMutTyVar, readMutTyVar, writeMutTyVar, makeTyVarImmutable,
+ mkMutTyVar, mutTyVarRef, makeTyVarImmutable,
-- Ids
Id, DictId,
import FastTypes
import Outputable
-import DATA_IOREF ( IORef, newIORef, readIORef, writeIORef )
+import DATA_IOREF ( IORef )
\end{code}
where
name = mkSystemTvNameEncoded uniq FSLIT("t")
-newMutTyVar :: Name -> Kind -> TyVarDetails -> IO TyVar
-newMutTyVar name kind details
- = do loc <- newIORef Nothing
- return (Var { varName = name
- , realUnique = getKey (nameUnique name)
- , varType = kind
- , varDetails = MutTyVar loc details
- , varInfo = pprPanic "newMutTyVar" (ppr name)
- })
-
-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
+mkMutTyVar :: Name -> Kind -> TyVarDetails -> IORef (Maybe Type) -> TyVar
+mkMutTyVar name kind details ref
+ = Var { varName = name
+ , realUnique = getKey (nameUnique name)
+ , varType = kind
+ , varDetails = MutTyVar ref details
+ , varInfo = pprPanic "newMutTyVar" (ppr name)
+ }
+
+mutTyVarRef :: TyVar -> IORef (Maybe Type)
+mutTyVarRef (Var {varDetails = MutTyVar loc _}) = loc
makeTyVarImmutable :: TyVar -> TyVar
makeTyVarImmutable tyvar = tyvar { varDetails = TyVar}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgCase.lhs,v 1.59 2002/09/04 10:00:45 simonmar Exp $
+% $Id: CgCase.lhs,v 1.60 2002/09/13 15:02:27 simonpj Exp $
%
%********************************************************
%* *
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgClosure.lhs,v 1.57 2002/04/29 14:03:41 simonmar Exp $
+% $Id: CgClosure.lhs,v 1.58 2002/09/13 15:02:27 simonpj Exp $
%
\section[CgClosure]{Code generation for closures}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgExpr.lhs,v 1.50 2002/08/02 13:08:34 simonmar Exp $
+% $Id: CgExpr.lhs,v 1.51 2002/09/13 15:02:28 simonpj Exp $
%
%********************************************************
%* *
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgHeapery.lhs,v 1.33 2002/09/04 10:00:46 simonmar Exp $
+% $Id: CgHeapery.lhs,v 1.34 2002/09/13 15:02:28 simonpj Exp $
%
\section[CgHeapery]{Heap management functions}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
-% $Id: CgLetNoEscape.lhs,v 1.17 2002/09/04 10:00:46 simonmar Exp $
+% $Id: CgLetNoEscape.lhs,v 1.18 2002/09/13 15:02:28 simonpj Exp $
%
%********************************************************
%* *
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgMonad.lhs,v 1.34 2002/04/29 14:03:42 simonmar Exp $
+% $Id: CgMonad.lhs,v 1.35 2002/09/13 15:02:28 simonpj Exp $
%
\section[CgMonad]{The code generation monad}
%
% (c) The GRASP Project, Glasgow University, 1992-1998
%
-% $Id: CgRetConv.lhs,v 1.32 2002/08/02 13:08:34 simonmar Exp $
+% $Id: CgRetConv.lhs,v 1.33 2002/09/13 15:02:28 simonpj Exp $
%
\section[CgRetConv]{Return conventions for the code generator}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgStackery.lhs,v 1.21 2002/08/29 15:44:13 simonmar Exp $
+% $Id: CgStackery.lhs,v 1.22 2002/09/13 15:02:29 simonpj Exp $
%
\section[CgStackery]{Stack management functions}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: ClosureInfo.lhs,v 1.52 2002/04/29 14:03:43 simonmar Exp $
+% $Id: ClosureInfo.lhs,v 1.53 2002/09/13 15:02:29 simonpj Exp $
%
\section[ClosureInfo]{Data structures which describe closures}
import PrelNames ( gHC_PRIM )
import CLabel ( CLabel, mkSRTLabel, mkClosureLabel,
mkPlainModuleInitLabel, mkModuleInitLabel )
-
import PprAbsC ( dumpRealC )
import AbsCUtils ( mkAbstractCs, flattenAbsC )
import CgBindery ( CgIdInfo, addBindC, addBindsC, getCAddrModeAndInfo )
import ClosureInfo ( mkClosureLFInfo )
import CmdLineOpts ( DynFlags, DynFlag(..),
opt_SccProfilingOn, opt_EnsureSplittableC )
+import HscTypes ( ModGuts(..), ModGuts, ForeignStubs(..),
+ typeEnvTyCons )
import CostCentre ( CollectedCCs )
import Id ( Id, idName, setIdName )
import Name ( nameSrcLoc, nameOccName, nameUnique, isInternalName, mkExternalName )
import OccName ( mkLocalOcc )
-import Module ( Module )
import PrimRep ( PrimRep(..) )
-import TyCon ( TyCon, isDataTyCon )
-import BasicTypes ( TopLevelFlag(..), Version )
+import TyCon ( isDataTyCon )
+import BasicTypes ( TopLevelFlag(..) )
import UniqSupply ( mkSplitUniqSupply )
import ErrUtils ( dumpIfSet_dyn, showPass )
import Panic ( assertPanic )
\begin{code}
codeGen :: DynFlags
- -> Module -- Module name
- -> [Module] -- Import names
+ -> ModGuts
-> CollectedCCs -- (Local/global) cost-centres needing declaring/registering.
- -> [Id] -- foreign-exported binders
- -> [TyCon] -- Local tycons, including ones from classes
-> [(StgBinding,[Id])] -- Bindings to convert, with SRTs
-> IO AbstractC -- Output
-codeGen dflags mod_name imported_modules cost_centre_info fe_binders
- tycons stg_binds
+codeGen dflags
+ mod_impl@(ModGuts { mg_module = mod_name, mg_types = type_env })
+ cost_centre_info stg_binds
= do
showPass dflags "CodeGen"
fl_uniqs <- mkSplitUniqSupply 'f'
way <- readIORef v_Build_tag
let
+ tycons = typeEnvTyCons type_env
data_tycons = filter isDataTyCon tycons
cinfo = MkCompInfo mod_name
datatype_stuff = genStaticConBits cinfo data_tycons
code_stuff = initC cinfo (mapCs cgTopBinding stg_binds)
- init_stuff = mkModuleInit fe_binders mod_name way
- imported_modules cost_centre_info
+ init_stuff = mkModuleInit way cost_centre_info mod_impl
abstractC = mkAbstractCs [ maybeSplitCode,
init_stuff,
\begin{code}
mkModuleInit
- :: [Id] -- foreign exported functions
- -> Module -- module name
- -> String -- the "way"
- -> [Module] -- import names
+ :: String -- the "way"
-> CollectedCCs -- cost centre info
+ -> ModGuts
-> AbstractC
-mkModuleInit fe_binders mod way imps cost_centre_info
+mkModuleInit way cost_centre_info
+ (ModGuts { mg_module = mod,
+ mg_foreign = ForeignStubs _ _ _ fe_binders,
+ mg_dir_imps = imported_modules })
= let
register_fes =
map (\f -> CMacroStmt REGISTER_FOREIGN_EXPORT [f]) fe_labels
(cc_decls, cc_regs) = mkCostCentreStuff cost_centre_info
-- we don't want/need to init GHC.Prim, so filter it out
- mk_import_register imp
- | imp == gHC_PRIM = AbsCNop
- | otherwise = CMacroStmt REGISTER_IMPORT [
- CLbl (mkModuleInitLabel imp way) AddrRep
- ]
+ mk_import_register mod
+ | mod == gHC_PRIM = AbsCNop
+ | otherwise = CMacroStmt REGISTER_IMPORT [
+ CLbl (mkModuleInitLabel mod way) AddrRep
+ ]
- register_imports = map mk_import_register imps
+ register_imports = map mk_import_register imported_modules
in
mkAbstractCs [
cc_decls,
+++ /dev/null
-%
-% (c) The University of Glasgow, 2001
-%
-\section[CmLink]{The compilation manager's linker}
-
-\begin{code}
-module CmLink (
- LinkResult(..), link, unload,
-
- filterModuleLinkables,
- findModuleLinkable_maybe,
-
- PersistentLinkerState{-abstractly!-}, emptyPLS,
-
-#ifdef GHCI
- delListFromClosureEnv,
- addListToClosureEnv,
- linkExpr
-#endif
- ) where
-
-
-#include "HsVersions.h"
-
-#ifdef GHCI
-import ByteCodeLink ( linkIModules, linkIExpr )
-import Interpreter
-import Name ( Name )
-import FiniteMap
-import ErrUtils ( showPass )
-import DATA_IOREF ( readIORef, writeIORef )
-#endif
-
-import DriverPipeline
-import CmTypes
-import HscTypes ( GhciMode(..) )
-import Module ( ModuleName )
-import Outputable
-import CmdLineOpts ( DynFlags(..) )
-import Util
-
-#ifdef GHCI
-import Control.Exception ( block )
-#endif
-
-import DATA_IOREF ( IORef )
-
-import List
-import Monad
-import IO
-
--- ---------------------------------------------------------------------------
--- The Linker's state
-
--- The PersistentLinkerState maps Names to actual closures (for
--- interpreted code only), for use during linking.
-
-data PersistentLinkerState
- = PersistentLinkerState {
-
-#ifdef GHCI
- -- Current global mapping from RdrNames to closure addresses
- closure_env :: ClosureEnv,
-
- -- the current global mapping from RdrNames of DataCons to
- -- info table addresses.
- -- When a new Unlinked is linked into the running image, or an existing
- -- module in the image is replaced, the itbl_env must be updated
- -- appropriately.
- itbl_env :: ItblEnv,
-
- -- the currently loaded interpreted modules
- bcos_loaded :: [Linkable]
-
-#else
- dummy :: () -- sigh, can't have an empty record
-#endif
-
- }
-
-emptyPLS :: IO PersistentLinkerState
-#ifdef GHCI
-emptyPLS = return (PersistentLinkerState { closure_env = emptyFM,
- itbl_env = emptyFM,
- bcos_loaded = [] })
-#else
-emptyPLS = return (PersistentLinkerState {dummy=()})
-#endif
-
--- We also keep track of which object modules are currently loaded
--- into the dynamic linker, so that we can unload them again later.
---
--- This state *must* match the actual state of the dyanmic linker at
--- all times, which is why we keep it private here and don't
--- put it in the PersistentLinkerState.
---
-GLOBAL_VAR(v_ObjectsLoaded, [], [Linkable])
-
-
--- ---------------------------------------------------------------------------
--- Utils
-
-findModuleLinkable_maybe :: [Linkable] -> ModuleName -> Maybe Linkable
-findModuleLinkable_maybe lis mod
- = case [LM time nm us | LM time nm us <- lis, nm == mod] of
- [] -> Nothing
- [li] -> Just li
- many -> pprPanic "findModuleLinkable" (ppr mod)
-
-filterModuleLinkables :: (ModuleName -> Bool) -> [Linkable] -> [Linkable]
-filterModuleLinkables p [] = []
-filterModuleLinkables p (li:lis)
- = case li of
- LM _ modnm _ -> if p modnm then retain else dump
- where
- dump = filterModuleLinkables p lis
- retain = li : dump
-
-#ifdef GHCI
-linkableInSet :: Linkable -> [Linkable] -> Bool
-linkableInSet l objs_loaded =
- case findModuleLinkable_maybe objs_loaded (linkableModName l) of
- Nothing -> False
- Just m -> linkableTime l == linkableTime m
-
--- These two are used to add/remove entries from the closure env for
--- new bindings made at the prompt.
-delListFromClosureEnv :: PersistentLinkerState -> [Name]
- -> IO PersistentLinkerState
-delListFromClosureEnv pls names
- = return pls{ closure_env = delListFromFM (closure_env pls) names }
-
-addListToClosureEnv :: PersistentLinkerState -> [(Name,HValue)]
- -> IO PersistentLinkerState
-addListToClosureEnv pls new_bindings
- = return pls{ closure_env = addListToFM (closure_env pls) new_bindings }
-#endif
-
--- ---------------------------------------------------------------------------
--- Unloading old objects ready for a new compilation sweep.
---
--- The compilation manager provides us with a list of linkables that it
--- considers "stable", i.e. won't be recompiled this time around. For
--- each of the modules current linked in memory,
---
--- * if the linkable is stable (and it's the same one - the
--- user may have recompiled the module on the side), we keep it,
---
--- * otherwise, we unload it.
---
--- * we also implicitly unload all temporary bindings at this point.
-
-unload :: GhciMode
- -> DynFlags
- -> [Linkable] -- stable linkables
- -> PersistentLinkerState
- -> IO PersistentLinkerState
-
-unload Batch dflags linkables pls = return pls
-
-#ifdef GHCI
-unload Interactive dflags linkables pls
- = block $ do -- block, so we're safe from Ctrl-C in here
- objs_loaded <- readIORef v_ObjectsLoaded
- objs_loaded' <- filterM (maybeUnload objs_to_keep) objs_loaded
- writeIORef v_ObjectsLoaded objs_loaded'
-
- bcos_loaded' <- filterM (maybeUnload bcos_to_keep) (bcos_loaded pls)
-
- let objs_retained = map linkableModName objs_loaded'
- bcos_retained = map linkableModName bcos_loaded'
- itbl_env' = filterNameMap bcos_retained (itbl_env pls)
- closure_env' = filterNameMap bcos_retained (closure_env pls)
-
- let verb = verbosity dflags
- when (verb >= 3) $ do
- hPutStrLn stderr (showSDoc
- (text "CmLink.unload: retaining objs" <+> ppr objs_retained))
- hPutStrLn stderr (showSDoc
- (text "CmLink.unload: retaining bcos" <+> ppr bcos_retained))
-
- return pls{ itbl_env = itbl_env',
- closure_env = closure_env',
- bcos_loaded = bcos_loaded' }
- where
- (objs_to_keep, bcos_to_keep) = partition isObjectLinkable linkables
-
- maybeUnload :: [Linkable] -> Linkable -> IO Bool
- maybeUnload keep_linkables l@(LM time mod objs)
- | linkableInSet l linkables
- = return True
- | otherwise
- = do mapM_ unloadObj [ f | DotO f <- objs ]
- return False
-#else
-unload Interactive dflags linkables pls = panic "CmLink.unload: no interpreter"
-#endif
-
------------------------------------------------------------------------------
--- Linking
-
-data LinkResult
- = LinkOK PersistentLinkerState
- | LinkFailed PersistentLinkerState
-
-link :: GhciMode -- interactive or batch
- -> DynFlags -- dynamic flags
- -> Bool -- attempt linking in batch mode?
- -> [Linkable]
- -> PersistentLinkerState
- -> IO LinkResult
-
--- For the moment, in the batch linker, we don't bother to tell doLink
--- which packages to link -- it just tries all that are available.
--- batch_attempt_linking should only be *looked at* in batch mode. It
--- should only be True if the upsweep was successful and someone
--- exports main, i.e., we have good reason to believe that linking
--- will succeed.
-
--- There will be (ToDo: are) two lists passed to link. These
--- correspond to
---
--- 1. The list of all linkables in the current home package. This is
--- used by the batch linker to link the program, and by the interactive
--- linker to decide which modules from the previous link it can
--- throw away.
--- 2. The list of modules on which we just called "compile". This list
--- is used by the interactive linker to decide which modules need
--- to be actually linked this time around (or unlinked and re-linked
--- if the module was recompiled).
-
-link mode dflags batch_attempt_linking linkables pls1
- = do let verb = verbosity dflags
- when (verb >= 3) $ do
- hPutStrLn stderr "CmLink.link: linkables are ..."
- hPutStrLn stderr (showSDoc (vcat (map ppr linkables)))
- res <- link' mode dflags batch_attempt_linking linkables pls1
- when (verb >= 3) $
- hPutStrLn stderr "CmLink.link: done"
- return res
-
-link' Batch dflags batch_attempt_linking linkables pls1
- | batch_attempt_linking
- = do let o_files = concatMap getOfiles linkables
- when (verb >= 1) $
- hPutStrLn stderr "ghc: linking ..."
- -- don't showPass in Batch mode; doLink will do that for us.
- doLink o_files
- -- doLink only returns if it succeeds
- return (LinkOK pls1)
- | otherwise
- = do when (verb >= 3) $ do
- hPutStrLn stderr "CmLink.link(batch): upsweep (partially) failed OR"
- hPutStrLn stderr " Main.main not exported; not linking."
- return (LinkOK pls1)
- where
- verb = verbosity dflags
- getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)
-
-#ifdef GHCI
-link' Interactive dflags batch_attempt_linking linkables pls
- = do showPass dflags "Linking"
- block $ do -- don't want to be interrupted by ^C in here
-
- -- Always load objects first. Objects aren't allowed to
- -- depend on BCOs.
- let (objs, bcos) = partition isObjectLinkable
- (concatMap partitionLinkable linkables)
-
- objs_loaded <- readIORef v_ObjectsLoaded
- objs_loaded' <- linkObjs objs objs_loaded
- writeIORef v_ObjectsLoaded objs_loaded'
-
- -- resolve symbols within the object files
- ok <- resolveObjs
- -- if resolving failed, unload all our object modules and
- -- carry on.
- if (not ok)
- then do pls <- unload Interactive dflags [] pls
- return (LinkFailed pls)
- else do
-
- -- finally link the interpreted linkables
- linkBCOs bcos [] pls
-#endif
-
------------------------------------------------------------------------------
--- Linker for interactive mode
-
-#ifdef GHCI
-linkObjs [] objs_loaded = return objs_loaded
-linkObjs (l@(LM _ m uls) : ls) objs_loaded
- | linkableInSet l objs_loaded = linkObjs ls objs_loaded -- already loaded
- | otherwise = do mapM_ loadObj [ file | DotO file <- uls ]
- linkObjs ls (l:objs_loaded)
-
-linkBCOs [] ul_trees pls = linkFinish pls ul_trees
-linkBCOs (l@(LM _ m uls) : ls) ul_trees pls
- | linkableInSet l (bcos_loaded pls)
- = linkBCOs ls ul_trees pls
- | otherwise
- = linkBCOs ls (uls++ul_trees) pls{bcos_loaded = l : bcos_loaded pls}
-
--- link all the interpreted code in one go.
-linkFinish pls ul_bcos = do
-
- let stuff = [ (bcos,itbls) | BCOs bcos itbls <- ul_bcos ]
-
- (ibinds, new_itbl_env, new_closure_env) <-
- linkIModules (itbl_env pls) (closure_env pls) stuff
-
- let new_pls = pls { closure_env = new_closure_env,
- itbl_env = new_itbl_env
- }
- return (LinkOK new_pls)
-#endif
-
--- ---------------------------------------------------------------------------
--- Link a single expression
-
-#ifdef GHCI
-linkExpr :: PersistentLinkerState -> UnlinkedBCOExpr -> IO HValue
-linkExpr PersistentLinkerState{ itbl_env = ie, closure_env = ce } bcos
- = linkIExpr ie ce bcos
-#endif
-\end{code}
+++ /dev/null
-%
-% (c) The University of Glasgow, 2000
-%
-\section[CmTypes]{Types for the compilation manager}
-
-\begin{code}
-module CmTypes (
- Unlinked(..), isObject, nameOfObject, isInterpretable,
- Linkable(..), isObjectLinkable, partitionLinkable,
- ModSummary(..), ms_allimps, pprSummaryTime, modSummaryName,
- ) where
-
-import Interpreter
-import HscTypes
-import Module
-import Outputable
-
-import Time ( ClockTime )
-
-
-data Unlinked
- = DotO FilePath
- | DotA FilePath
- | DotDLL FilePath
- | BCOs [UnlinkedBCO] ItblEnv -- bunch of interpretable bindings, +
- -- a mapping from DataCons to their itbls
-
-instance Outputable Unlinked where
- ppr (DotO path) = text "DotO" <+> text path
- ppr (DotA path) = text "DotA" <+> text path
- ppr (DotDLL path) = text "DotDLL" <+> text path
- ppr (BCOs bcos _) = text "BCOs" <+> ppr bcos
-
-isObject (DotO _) = True
-isObject (DotA _) = True
-isObject (DotDLL _) = True
-isObject _ = False
-
-nameOfObject (DotO fn) = fn
-nameOfObject (DotA fn) = fn
-nameOfObject (DotDLL fn) = fn
-
-isInterpretable = not . isObject
-
-data Linkable = LM {
- linkableTime :: ClockTime,
- linkableModName :: ModuleName, -- should be Module, but see below
- linkableUnlinked :: [Unlinked]
- }
-
-isObjectLinkable :: Linkable -> Bool
-isObjectLinkable l = all isObject (linkableUnlinked l)
-
--- HACK to support f-x-dynamic in the interpreter; no other purpose
-partitionLinkable :: Linkable -> [Linkable]
-partitionLinkable li
- = let li_uls = linkableUnlinked li
- li_uls_obj = filter isObject li_uls
- li_uls_bco = filter isInterpretable li_uls
- in
- case (li_uls_obj, li_uls_bco) of
- (objs@(_:_), bcos@(_:_))
- -> [li{linkableUnlinked=li_uls_obj}, li{linkableUnlinked=li_uls_bco}]
- other
- -> [li]
-
-instance Outputable Linkable where
- ppr (LM when_made mod unlinkeds)
- = (text "LinkableM" <+> parens (text (show when_made)) <+> ppr mod)
- $$ nest 3 (ppr unlinkeds)
-
--- The ModuleLocation contains both the original source filename and the
--- filename of the cleaned-up source file after all preprocessing has been
--- done. The point is that the summariser will have to cpp/unlit/whatever
--- all files anyway, and there's no point in doing this twice -- just
--- park the result in a temp file, put the name of it in the location,
--- and let @compile@ read from that file on the way back up.
-data ModSummary
- = ModSummary {
- ms_mod :: Module, -- name, package
- ms_location :: ModuleLocation, -- location
- ms_srcimps :: [ModuleName], -- source imports
- ms_imps :: [ModuleName], -- non-source imports
- ms_hs_date :: ClockTime -- timestamp of summarised file
- }
-
-instance Outputable ModSummary where
- ppr ms
- = sep [text "ModSummary {",
- nest 3 (sep [text "ms_hs_date = " <> text (show (ms_hs_date ms)),
- text "ms_mod =" <+> ppr (ms_mod ms) <> comma,
- text "ms_imps =" <+> ppr (ms_imps ms),
- text "ms_srcimps =" <+> ppr (ms_srcimps ms)]),
- char '}'
- ]
-
-pprSummaryTime ms
- = text "ms_hs_date = " <> parens (text (show (ms_hs_date ms)))
-
-ms_allimps ms
- = ms_srcimps ms ++ ms_imps ms
-
-modSummaryName :: ModSummary -> ModuleName
-modSummaryName = moduleName . ms_mod
-\end{code}
\begin{code}
{-# OPTIONS -fvia-C #-}
module CompManager (
- ModuleGraph,
+ ModuleGraph, ModSummary(..),
CmState, emptyCmState, -- abstract
cmCompileExpr, -- :: CmState -> DynFlags -> String
-- -> IO (CmState, Maybe HValue)
- cmGetModuleGraph, -- :: CmState -> ModuleGraph
- cmGetLinkables, -- :: CmState -> [Linkable]
+ cmGetModInfo, -- :: CmState -> (ModuleGraph, HomePackageTable)
+ findModuleLinkable_maybe, -- Exported to InteractiveUI
cmGetBindings, -- :: CmState -> [TyThing]
cmGetPrintUnqual, -- :: CmState -> PrintUnqualified
-#endif
- -- utils
- showModMsg, --
+ sandboxIO -- Should be somewhere else
+#endif
)
where
#include "HsVersions.h"
-import CmLink
-import CmTypes
-import DriverPipeline
+import DriverPipeline ( CompResult(..), preprocess, compile, link )
import DriverState ( v_Output_file )
import DriverPhases
import DriverUtil
import Finder
-#ifdef GHCI
-import HscMain ( initPersistentCompilerState, hscThing,
- hscModuleContents )
-#else
import HscMain ( initPersistentCompilerState )
-#endif
-import HscTypes hiding ( moduleNameToModule )
-import Name ( Name, NamedThing(..), nameRdrName, nameModule,
- isHomePackageName, isExternalName )
+import HscTypes hiding ( moduleNameToModule )
import NameEnv
import PrelNames ( gHC_PRIM_Name )
-import Rename ( mkGlobalContext )
-import RdrName ( emptyRdrEnv )
-import Module
+import Module ( Module, ModuleName, moduleName, mkModuleName, isHomeModule,
+ ModuleEnv, lookupModuleEnvByName, mkModuleEnv, moduleEnvElts,
+ extendModuleEnvList, extendModuleEnv,
+ moduleNameUserString,
+ ModLocation(..) )
import GetImports
import UniqFM
-import Unique ( Uniquable )
import Digraph ( SCC(..), stronglyConnComp, flattenSCC, flattenSCCs )
import ErrUtils ( showPass )
import SysTools ( cleanTempFilesExcept )
+import BasicTypes ( SuccessFlag(..), succeeded, failed )
import Util
import Outputable
import Panic
import CmdLineOpts ( DynFlags(..), getDynFlags )
-import Maybes ( expectJust )
+import Maybes ( expectJust, orElse )
import DATA_IOREF ( readIORef )
#ifdef GHCI
-import RdrName ( lookupRdrEnv )
-import Id ( idType, idName )
+import HscMain ( hscThing, hscStmt, hscTcExpr )
+import Module ( moduleUserString )
+import TcRnDriver ( mkGlobalContext, getModuleContents )
+import Name ( Name, NamedThing(..), isExternalName )
+import Id ( idType )
import Type ( tidyType )
import VarEnv ( emptyTidyEnv )
-import BasicTypes ( Fixity, defaultFixity )
-import Interpreter ( HValue )
-import HscMain ( hscStmt )
+import BasicTypes ( Fixity, FixitySig(..), defaultFixity )
+import Linker ( HValue, unload, extendLinkEnv )
import GHC.Exts ( unsafeCoerce# )
import Foreign
import Control.Exception as Exception ( Exception, try )
import Monad
import List ( nub )
import Maybe
+import Time ( ClockTime )
\end{code}
-- Persistent state for the entire system
data CmState
= CmState {
- hst :: HomeSymbolTable, -- home symbol table
- hit :: HomeIfaceTable, -- home interface table
- ui :: UnlinkedImage, -- the unlinked images
- mg :: ModuleGraph, -- the module graph
gmode :: GhciMode, -- NEVER CHANGES
- ic :: InteractiveContext, -- command-line binding info
- pcs :: PersistentCompilerState, -- compile's persistent state
- pls :: PersistentLinkerState -- link's persistent state
+ hpt :: HomePackageTable, -- Info about home package module
+ mg :: ModuleGraph, -- the module graph
+ ic :: InteractiveContext, -- command-line binding info
+
+ pcs :: PersistentCompilerState -- compile's persistent state
}
+cmGetModInfo cmstate = (mg cmstate, hpt cmstate)
+cmGetBindings cmstate = nameEnvElts (ic_type_env (ic cmstate))
+cmGetPrintUnqual cmstate = icPrintUnqual (ic cmstate)
+
emptyCmState :: GhciMode -> IO CmState
emptyCmState gmode
= do pcs <- initPersistentCompilerState
- pls <- emptyPLS
- return (CmState { hst = emptySymbolTable,
- hit = emptyIfaceTable,
- ui = emptyUI,
+ return (CmState { hpt = emptyHomePackageTable,
mg = emptyMG,
gmode = gmode,
ic = emptyInteractiveContext,
- pcs = pcs,
- pls = pls })
-
-emptyInteractiveContext
- = InteractiveContext { ic_toplev_scope = [],
- ic_exports = [],
- ic_rn_gbl_env = emptyRdrEnv,
- ic_print_unqual = alwaysQualify,
- ic_rn_local_env = emptyRdrEnv,
- ic_type_env = emptyTypeEnv }
-
--- CM internal types
-type UnlinkedImage = [Linkable] -- the unlinked images (should be a set, really)
-emptyUI :: UnlinkedImage
-emptyUI = []
-
-type ModuleGraph = [ModSummary] -- the module graph, topologically sorted
-emptyMG :: ModuleGraph
-emptyMG = []
-
------------------------------------------------------------------------------
--- Produce an initial CmState.
+ pcs = pcs })
cmInit :: GhciMode -> IO CmState
cmInit mode = emptyCmState mode
------------------------------------------------------------------------------
--- Grab information from the CmState
-cmGetModuleGraph = mg
-cmGetLinkables = ui
+-------------------------------------------------------------------
+-- The unlinked image
+--
+-- The compilation manager keeps a list of compiled, but as-yet unlinked
+-- binaries (byte code or object code). Even when it links bytecode
+-- it keeps the unlinked version so it can re-link it later without
+-- recompiling.
-cmGetBindings cmstate = nameEnvElts (ic_type_env (ic cmstate))
-cmGetPrintUnqual cmstate = ic_print_unqual (ic cmstate)
+type UnlinkedImage = [Linkable] -- the unlinked images (should be a set, really)
+emptyUI :: UnlinkedImage
+emptyUI = []
+findModuleLinkable_maybe :: [Linkable] -> ModuleName -> Maybe Linkable
+findModuleLinkable_maybe lis mod
+ = case [LM time nm us | LM time nm us <- lis, nm == mod] of
+ [] -> Nothing
+ [li] -> Just li
+ many -> pprPanic "findModuleLinkable" (ppr mod)
+
+filterModuleLinkables :: (ModuleName -> Bool) -> [Linkable] -> [Linkable]
+filterModuleLinkables p [] = []
+filterModuleLinkables p (li:lis)
+ = case li of
+ LM _ modnm _ -> if p modnm then retain else dump
+ where
+ dump = filterModuleLinkables p lis
+ retain = li : dump
+
+linkableInSet :: Linkable -> [Linkable] -> Bool
+linkableInSet l objs_loaded =
+ case findModuleLinkable_maybe objs_loaded (linkableModName l) of
+ Nothing -> False
+ Just m -> linkableTime l == linkableTime m
+\end{code}
+
+
+%************************************************************************
+%* *
+ GHCI stuff
+%* *
+%************************************************************************
+
+\begin{code}
+#ifdef GHCI
-----------------------------------------------------------------------------
-- Setting the context doesn't throw away any bindings; the bindings
-- we've built up in the InteractiveContext simply move to the new
-> [String] -- and the just the exports from these
-> IO CmState
cmSetContext cmstate dflags toplevs exports = do
- let CmState{ hit=hit, hst=hst, pcs=pcs, ic=old_ic } = cmstate
+ let CmState{ hpt=hpt, pcs=pcs, ic=old_ic } = cmstate
+ hsc_env = HscEnv { hsc_mode = Interactive, hsc_dflags = dflags,
+ hsc_HPT = hpt }
- toplev_mods <- mapM (getTopLevModule hit) (map mkModuleName toplevs)
- export_mods <- mapM (moduleNameToModule hit) (map mkModuleName exports)
+ toplev_mods <- mapM (getTopLevModule hpt) (map mkModuleName toplevs)
+ export_mods <- mapM (moduleNameToModule hpt) (map mkModuleName exports)
- (new_pcs, print_unqual, maybe_env)
- <- mkGlobalContext dflags hit hst pcs toplev_mods export_mods
+ (new_pcs, maybe_env)
+ <- mkGlobalContext hsc_env pcs toplev_mods export_mods
case maybe_env of
- Nothing -> return cmstate
+ Nothing -> return cmstate
Just env -> return cmstate{ pcs = new_pcs,
ic = old_ic{ ic_toplev_scope = toplev_mods,
ic_exports = export_mods,
- ic_rn_gbl_env = env,
- ic_print_unqual = print_unqual } }
+ ic_rn_gbl_env = env } }
+
+getTopLevModule hpt mn =
+ case lookupModuleEnvByName hpt mn of
+
+ Just mod_info
+ | isJust (mi_globals iface) -> return (mi_module iface)
+ where
+ iface = hm_iface mod_info
-getTopLevModule hit mn =
- case lookupModuleEnvByName hit mn of
- Just iface
- | Just _ <- mi_globals iface -> return (mi_module iface)
_other -> throwDyn (CmdLineError (
"cannot enter the top-level scope of a compiled module (module `" ++
moduleNameUserString mn ++ "')"))
-moduleNameToModule :: HomeIfaceTable -> ModuleName -> IO Module
-moduleNameToModule hit mn = do
- case lookupModuleEnvByName hit mn of
- Just iface -> return (mi_module iface)
+moduleNameToModule :: HomePackageTable -> ModuleName -> IO Module
+moduleNameToModule hpt mn = do
+ case lookupModuleEnvByName hpt mn of
+ Just mod_info -> return (mi_module (hm_iface mod_info))
_not_a_home_module -> do
maybe_stuff <- findModule mn
case maybe_stuff of
cmModuleIsInterpreted :: CmState -> String -> IO Bool
cmModuleIsInterpreted cmstate str
- = case lookupModuleEnvByName (hit cmstate) (mkModuleName str) of
- Just iface -> return (not (isNothing (mi_globals iface)))
+ = case lookupModuleEnvByName (hpt cmstate) (mkModuleName str) of
+ Just details -> return (isJust (mi_globals (hm_iface details)))
_not_a_home_module -> return False
-----------------------------------------------------------------------------
-- A string may refer to more than one TyThing (eg. a constructor,
-- and type constructor), so we return a list of all the possible TyThings.
-#ifdef GHCI
cmInfoThing :: CmState -> DynFlags -> String -> IO (CmState, [(TyThing,Fixity)])
cmInfoThing cmstate dflags id
- = do (new_pcs, things) <- hscThing dflags hst hit pcs icontext id
+ = do (new_pcs, things) <- hscThing hsc_env pcs icontext id
let pairs = map (\x -> (x, getFixity new_pcs (getName x))) things
return (cmstate{ pcs=new_pcs }, pairs)
where
- CmState{ hst=hst, hit=hit, pcs=pcs, pls=pls, ic=icontext } = cmstate
-
+ CmState{ hpt=hpt, pcs=pcs, ic=icontext } = cmstate
+ hsc_env = HscEnv { hsc_mode = Interactive,
+ hsc_dflags = dflags,
+ hsc_HPT = hpt }
+ pit = eps_PIT (pcs_EPS pcs)
getFixity :: PersistentCompilerState -> Name -> Fixity
getFixity pcs name
| isExternalName name,
- Just iface <- lookupModuleEnv iface_table (nameModule name),
- Just fixity <- lookupNameEnv (mi_fixities iface) name
- = fixity
+ Just iface <- lookupIface hpt pit name,
+ Just (FixitySig _ fixity _) <- lookupNameEnv (mi_fixities iface) name
+ = fixity
| otherwise
- = defaultFixity
- where iface_table | isHomePackageName name = hit
- | otherwise = pcs_PIT pcs
-#endif
+ = defaultFixity
-- ---------------------------------------------------------------------------
-- cmBrowseModule: get all the TyThings defined in a module
-#ifdef GHCI
cmBrowseModule :: CmState -> DynFlags -> String -> Bool
-> IO (CmState, [TyThing])
cmBrowseModule cmstate dflags str exports_only = do
let mn = mkModuleName str
- mod <- moduleNameToModule hit mn
+ mod <- moduleNameToModule hpt mn
(pcs1, maybe_ty_things)
- <- hscModuleContents dflags hst hit pcs mod exports_only
+ <- getModuleContents hsc_env pcs mod exports_only
case maybe_ty_things of
Nothing -> return (cmstate{pcs=pcs1}, [])
Just ty_things -> return (cmstate{pcs=pcs1}, ty_things)
where
- CmState{ hst=hst, hit=hit, pcs=pcs, pls=pls, ic=icontext } = cmstate
-#endif
+ hsc_env = HscEnv { hsc_mode = Interactive, hsc_dflags = dflags,
+ hsc_HPT = hpt }
+ CmState{ hpt=hpt, pcs=pcs, ic=icontext } = cmstate
-----------------------------------------------------------------------------
-- cmRunStmt: Run a statement/expr.
-#ifdef GHCI
data CmRunResult
= CmRunOk [Name] -- names bound by this evaluation
| CmRunFailed
| CmRunException Exception -- statement raised an exception
cmRunStmt :: CmState -> DynFlags -> String -> IO (CmState, CmRunResult)
-cmRunStmt cmstate@CmState{ hst=hst, hit=hit, pcs=pcs, pls=pls, ic=icontext }
+cmRunStmt cmstate@CmState{ hpt=hpt, pcs=pcs, ic=icontext }
dflags expr
= do
- let InteractiveContext {
- ic_rn_local_env = rn_env,
- ic_type_env = type_env } = icontext
-
+ let hsc_env = HscEnv { hsc_mode = Interactive,
+ hsc_dflags = dflags,
+ hsc_HPT = hpt }
+
(new_pcs, maybe_stuff)
- <- hscStmt dflags hst hit pcs icontext expr False{-stmt-}
+ <- hscStmt hsc_env pcs icontext expr
case maybe_stuff of
Nothing -> return (cmstate{ pcs=new_pcs }, CmRunFailed)
- Just (ids, _, bcos) -> do
-
- -- update the interactive context
- let
- names = map idName ids
-
- -- these names have just been shadowed
- shadowed = [ n | r <- map nameRdrName names,
- Just n <- [lookupRdrEnv rn_env r] ]
-
- new_rn_env = extendLocalRdrEnv rn_env names
-
- -- remove any shadowed bindings from the type_env
- filtered_type_env = delListFromNameEnv type_env shadowed
-
- new_type_env = extendNameEnvList filtered_type_env
- [ (getName id, AnId id) | id <- ids]
+ Just (new_ic, names, hval) -> do
- new_ic = icontext { ic_rn_local_env = new_rn_env,
- ic_type_env = new_type_env }
-
- -- link it
- hval <- linkExpr pls bcos
-
- -- run it!
let thing_to_run = unsafeCoerce# hval :: IO [HValue]
either_hvals <- sandboxIO thing_to_run
+
case either_hvals of
- Left err
- -> do hPutStrLn stderr ("unknown failure, code " ++ show err)
- return ( cmstate{ pcs=new_pcs, ic=new_ic }, CmRunFailed )
-
- Right maybe_hvals ->
- case maybe_hvals of
- Left e ->
- return ( cmstate{ pcs=new_pcs, ic=new_ic },
- CmRunException e )
- Right hvals -> do
- -- Get the newly bound things, and bind them.
- -- Don't forget to delete any shadowed bindings from the
- -- closure_env, lest we end up with a space leak.
- pls <- delListFromClosureEnv pls shadowed
- new_pls <- addListToClosureEnv pls (zip names hvals)
-
- return (cmstate{ pcs=new_pcs, pls=new_pls, ic=new_ic },
- CmRunOk names)
+ Left e -> do
+ return ( cmstate{ pcs=new_pcs, ic=new_ic },
+ CmRunException e )
+ Right hvals -> do
+ -- Get the newly bound things, and bind them.
+ -- Don't need to delete any shadowed bindings;
+ -- the new ones override the old ones.
+ extendLinkEnv (zip names hvals)
+
+ return (cmstate{ pcs=new_pcs, ic=new_ic },
+ CmRunOk names)
-- We run the statement in a "sandbox" to protect the rest of the
-- consists of just wrapping it in an exception handler, but see below
-- for another version.
-sandboxIO :: IO a -> IO (Either Int (Either Exception a))
-sandboxIO thing = do
- r <- Exception.try thing
- return (Right r)
+sandboxIO :: IO a -> IO (Either Exception a)
+sandboxIO thing = Exception.try thing
{-
-- This version of sandboxIO runs the expression in a completely new
-- won't be delivered to the new thread, instead they'll be delivered
-- to the (blocked) GHCi main thread.
+-- SLPJ: when re-enabling this, reflect a wrong-stat error as an exception
+
sandboxIO :: IO a -> IO (Either Int (Either Exception a))
sandboxIO thing = do
st_thing <- newStablePtr (Exception.try thing)
rts_evalStableIO :: StablePtr (IO a) -> Ptr (StablePtr a) -> IO CInt
-- more informative than the C type!
-}
-#endif
-----------------------------------------------------------------------------
-- cmTypeOfExpr: returns a string representing the type of an expression
-#ifdef GHCI
cmTypeOfExpr :: CmState -> DynFlags -> String -> IO (CmState, Maybe String)
cmTypeOfExpr cmstate dflags expr
- = do (new_pcs, maybe_stuff)
- <- hscStmt dflags hst hit pcs ic expr True{-just an expr-}
+ = do (new_pcs, maybe_stuff) <- hscTcExpr hsc_env pcs ic expr
let new_cmstate = cmstate{pcs = new_pcs}
case maybe_stuff of
Nothing -> return (new_cmstate, Nothing)
- Just (_, ty, _) -> return (new_cmstate, Just str)
+ Just ty -> return (new_cmstate, Just str)
where
- str = showSDocForUser unqual (ppr tidy_ty)
- unqual = ic_print_unqual ic
+ str = showSDocForUser unqual (text expr <+> dcolon <+> ppr tidy_ty)
+ unqual = icPrintUnqual ic
tidy_ty = tidyType emptyTidyEnv ty
where
- CmState{ hst=hst, hit=hit, pcs=pcs, ic=ic } = cmstate
-#endif
+ CmState{ hpt=hpt, pcs=pcs, ic=ic } = cmstate
+ hsc_env = HscEnv { hsc_mode = Interactive,
+ hsc_dflags = dflags,
+ hsc_HPT = hpt }
+
+
-----------------------------------------------------------------------------
-- cmTypeOfName: returns a string representing the type of a name.
-#ifdef GHCI
cmTypeOfName :: CmState -> Name -> IO (Maybe String)
-cmTypeOfName CmState{ hit=hit, pcs=pcs, ic=ic } name
- = case lookupNameEnv (ic_type_env ic) name of
+cmTypeOfName CmState{ pcs=pcs, ic=ic } name
+ = do
+ hPutStrLn stderr ("cmTypeOfName: " ++ showSDoc (ppr name))
+ case lookupNameEnv (ic_type_env ic) name of
Nothing -> return Nothing
Just (AnId id) -> return (Just str)
where
- unqual = ic_print_unqual ic
+ unqual = icPrintUnqual ic
ty = tidyType emptyTidyEnv (idType id)
str = showSDocForUser unqual (ppr ty)
_ -> panic "cmTypeOfName"
-#endif
-----------------------------------------------------------------------------
-- cmCompileExpr: compile an expression and deliver an HValue
-#ifdef GHCI
cmCompileExpr :: CmState -> DynFlags -> String -> IO (CmState, Maybe HValue)
cmCompileExpr cmstate dflags expr
= do
- let InteractiveContext {
- ic_rn_local_env = rn_env,
- ic_type_env = type_env } = icontext
-
+ let hsc_env = HscEnv { hsc_mode = Interactive,
+ hsc_dflags = dflags,
+ hsc_HPT = hpt }
+
(new_pcs, maybe_stuff)
- <- hscStmt dflags hst hit pcs icontext
- ("let __cmCompileExpr = "++expr) False{-stmt-}
+ <- hscStmt hsc_env pcs icontext
+ ("let __cmCompileExpr = "++expr)
case maybe_stuff of
Nothing -> return (cmstate{ pcs=new_pcs }, Nothing)
- Just (ids, _, bcos) -> do
+ Just (new_ic, names, hval) -> do
- -- link it
- hval <- linkExpr pls bcos
+ -- Run it!
+ hvals <- (unsafeCoerce# hval) :: IO [HValue]
- -- run it!
- let thing_to_run = unsafeCoerce# hval :: IO [HValue]
- hvals <- thing_to_run
-
- case (ids,hvals) of
- ([id],[hv]) -> return (cmstate{ pcs=new_pcs }, Just hv)
- _ -> panic "cmCompileExpr"
+ case (names,hvals) of
+ ([n],[hv]) -> return (cmstate{ pcs=new_pcs }, Just hv)
+ _ -> panic "cmCompileExpr"
where
- CmState{ hst=hst, hit=hit, pcs=pcs, pls=pls, ic=icontext } = cmstate
-#endif
+ CmState{ hpt=hpt, pcs=pcs, ic=icontext } = cmstate
+#endif /* GHCI */
+\end{code}
+
+
+%************************************************************************
+%* *
+ Loading and unloading
+%* *
+%************************************************************************
+\begin{code}
-----------------------------------------------------------------------------
-- Unload the compilation manager's state: everything it knows about the
-- current collection of modules in the Home package.
cmUnload :: CmState -> DynFlags -> IO CmState
-cmUnload state@CmState{ gmode=mode, pls=pls, pcs=pcs } dflags
+cmUnload state@CmState{ gmode=mode, pcs=pcs } dflags
= do -- Throw away the old home dir cache
emptyHomeDirCache
-- Unload everything the linker knows about
- new_pls <- CmLink.unload mode dflags [] pls
+ cm_unload mode dflags []
-- Start with a fresh CmState, but keep the PersistentCompilerState
new_state <- cmInit mode
- return new_state{ pcs=pcs, pls=new_pls }
+ return new_state{ pcs=pcs }
+
+cm_unload Batch dflags linkables = return ()
+
+#ifdef GHCI
+cm_unload Interactive dflags linkables = Linker.unload dflags linkables
+#else
+cm_unload Interactive dflags linkables = panic "unload: no interpreter"
+#endif
-----------------------------------------------------------------------------
-- Trace dependency graph
-- This is a seperate pass so that the caller can back off and keep
--- the current state if the downsweep fails.
+-- the current state if the downsweep fails. Typically the caller
+-- might go cmDepAnal
+-- cmUnload
+-- cmLoadModules
+-- He wants to do the dependency analysis before the unload, so that
+-- if the former fails he can use the later
cmDepAnal :: CmState -> DynFlags -> [FilePath] -> IO ModuleGraph
cmDepAnal cmstate dflags rootnames
-- a module name, try and bring the module up to date, probably changing
-- the system state at the same time.
-cmLoadModules :: CmState
- -> DynFlags
- -> ModuleGraph
- -> IO (CmState, -- new state
- Bool, -- was successful
- [String]) -- list of modules loaded
+cmLoadModules :: CmState -- The HPT may not be as up to date
+ -> DynFlags -- as the ModuleGraph
+ -> ModuleGraph -- Bang up to date
+ -> IO (CmState, -- new state
+ SuccessFlag, -- was successful
+ [String]) -- list of modules loaded
cmLoadModules cmstate1 dflags mg2unsorted
= do -- version 1's are the original, before downsweep
- let pls1 = pls cmstate1
let pcs1 = pcs cmstate1
- let hst1 = hst cmstate1
- let hit1 = hit cmstate1
- -- similarly, ui1 is the (complete) set of linkables from
- -- the previous pass, if any.
- let ui1 = ui cmstate1
+ let hpt1 = hpt cmstate1
let ghci_mode = gmode cmstate1 -- this never changes
let mg2 = topological_sort False mg2unsorted
-- ... whereas this takes them into account. Used for
-- backing out partially complete cycles following a failed
- -- upsweep, and for removing from hst/hit all the modules
+ -- upsweep, and for removing from hpt all the modules
-- not in strict downwards closure, during calls to compile.
let mg2_with_srcimps = topological_sort True mg2unsorted
-- Sort out which linkables we wish to keep in the unlinked image.
-- See getValidLinkables below for details.
(valid_old_linkables, new_linkables)
- <- getValidLinkables ghci_mode ui1
+ <- getValidLinkables ghci_mode (hptLinkables hpt1)
mg2unsorted_names mg2_with_srcimps
-- putStrLn (showSDoc (vcat [ppr valid_old_linkables, ppr new_linkables]))
- -- uniq of ModuleName is the same as Module, fortunately...
- let hit2 = delListFromUFM hit1 (map linkableModName new_linkables)
+ -- Uniq of ModuleName is the same as Module, fortunately...
+ let hpt2 = delListFromUFM hpt1 (map linkableModName new_linkables)
-- When (verb >= 2) $
-- putStrLn (showSDoc (text "Valid linkables:"
putStrLn (showSDoc (text "Stable modules:"
<+> sep (map (text.moduleNameUserString) stable_mods)))
- -- unload any modules which are going to be re-linked this
+ -- Unload any modules which are going to be re-linked this
-- time around.
- pls2 <- CmLink.unload ghci_mode dflags stable_linkables pls1
+ cm_unload ghci_mode dflags stable_linkables
-- we can now glom together our linkable sets
let valid_linkables = valid_old_linkables ++ new_linkables
-- Now do the upsweep, calling compile for each module in
-- turn. Final result is version 3 of everything.
- let threaded2 = CmThreaded pcs1 hst1 hit2
+ let threaded2 = CmThreaded pcs1 hpt2
-- clean up between compilations
let cleanup = cleanTempFilesExcept verb
(ppFilesFromSummaries (flattenSCCs mg2))
- (upsweep_complete_success, threaded3, modsUpswept, newLis)
+ (upsweep_ok, threaded3, modsUpswept)
<- upsweep_mods ghci_mode dflags valid_linkables reachable_from
threaded2 cleanup upsweep_these
- let ui3 = add_to_ui valid_linkables newLis
- let (CmThreaded pcs3 hst3 hit3) = threaded3
+ let (CmThreaded pcs3 hpt3) = threaded3
-- At this point, modsUpswept and newLis should have the same
-- length, so there is one new (or old) linkable for each
-- mod which was processed (passed to compile).
-- Make modsDone be the summaries for each home module now
- -- available; this should equal the domains of hst3 and hit3.
+ -- available; this should equal the domain of hpt3.
-- (NOT STRICTLY TRUE if an interactive session was started
-- with some object on disk ???)
-- Get in in a roughly top .. bottom order (hence reverse).
-- Try and do linking in some form, depending on whether the
-- upsweep was completely or only partially successful.
- if upsweep_complete_success
+ if succeeded upsweep_ok
then
-- Easy; just relink it all.
hPutStrLn stderr "Warning: output was redirected with -o, but no output will be generated\nbecause there is no Main module."
-- link everything together
- linkresult <- link ghci_mode dflags a_root_is_Main ui3 pls2
+ linkresult <- link ghci_mode dflags a_root_is_Main (hptLinkables hpt3)
- cmLoadFinish True linkresult
- hst3 hit3 ui3 modsDone ghci_mode pcs3
+ cmLoadFinish Succeeded linkresult
+ hpt3 modsDone ghci_mode pcs3
else
-- Tricky. We need to back out the effects of compiling any
= filter ((`notElem` mods_to_zap_names).modSummaryName)
modsDone
- let (hst4, hit4, ui4)
- = retainInTopLevelEnvs (map modSummaryName mods_to_keep)
- (hst3,hit3,ui3)
+ let hpt4 = retainInTopLevelEnvs (map modSummaryName mods_to_keep) hpt3
- -- clean up after ourselves
+ -- Clean up after ourselves
cleanTempFilesExcept verb (ppFilesFromSummaries mods_to_keep)
- -- link everything together
- linkresult <- link ghci_mode dflags False ui4 pls2
+ -- Link everything together
+ linkresult <- link ghci_mode dflags False (hptLinkables hpt4)
- cmLoadFinish False linkresult
- hst4 hit4 ui4 mods_to_keep ghci_mode pcs3
+ cmLoadFinish Failed linkresult
+ hpt4 mods_to_keep ghci_mode pcs3
-- Finish up after a cmLoad.
-- If the link failed, unload everything and return.
-cmLoadFinish ok (LinkFailed pls) hst hit ui mods ghci_mode pcs = do
- dflags <- getDynFlags
- new_pls <- CmLink.unload ghci_mode dflags [] pls
+cmLoadFinish ok Failed hpt mods ghci_mode pcs = do
+ dflags <- getDynFlags
+ cm_unload ghci_mode dflags []
new_state <- cmInit ghci_mode
- return (new_state{ pcs=pcs, pls=new_pls }, False, [])
+ return (new_state{ pcs=pcs }, Failed, [])
-- Empty the interactive context and set the module context to the topmost
-- newly loaded module, or the Prelude if none were loaded.
-cmLoadFinish ok (LinkOK pls) hst hit ui mods ghci_mode pcs
- = do let new_cmstate = CmState{ hst=hst, hit=hit, ui=ui, mg=mods,
- gmode=ghci_mode, pcs=pcs, pls=pls,
+cmLoadFinish ok Succeeded hpt mods ghci_mode pcs
+ = do let new_cmstate = CmState{ hpt=hpt, mg=mods,
+ gmode=ghci_mode, pcs=pcs,
ic = emptyInteractiveContext }
mods_loaded = map (moduleNameUserString.modSummaryName) mods
getValidLinkable :: [Linkable] -> Bool -> [(Linkable,Bool)] -> ModSummary
-> IO [(Linkable,Bool)]
- -- True <=> linkable is new
+ -- True <=> linkable is new; i.e. freshly discovered on the disk
+ -- presumably generated 'on the side'
+ -- by a separate GHC run
getValidLinkable old_linkables objects_allowed new_linkables summary
+ -- 'objects_allowed' says whether we permit this module to
+ -- have a .o-file linkable. We only permit it if all the
+ -- modules it depends on also have .o files; a .o file can't
+ -- link to a bytecode module
= do let mod_name = modSummaryName summary
maybe_disk_linkable
then return (Just (LM obj_time mod [DotO obj_fn, DotO stub_fn]))
else return (Just (LM obj_time mod [DotO obj_fn]))
+hptLinkables :: HomePackageTable -> [Linkable]
+-- Get all the linkables from the home package table, one for each module
+-- Once the HPT is up to date, these are the ones we should link
+hptLinkables hpt = map hm_linkable (moduleEnvElts hpt)
+
-----------------------------------------------------------------------------
-- Do a pre-upsweep without use of "compile", to establish a
-- a stable module:
-- * has a valid linkable (see getValidLinkables above)
-- * depends only on stable modules
--- * has an interface in the HIT (interactive mode only)
+-- * has an interface in the HPT (interactive mode only)
preUpsweep :: [Linkable] -- new valid linkables
-> [ModuleName] -- names of all mods encountered in downsweep
else chewed_rest
--- Add the given (LM-form) Linkables to the UI, overwriting previous
--- versions if they exist.
-add_to_ui :: UnlinkedImage -> [Linkable] -> UnlinkedImage
-add_to_ui ui lis
- = filter (not_in lis) ui ++ lis
- where
- not_in :: [Linkable] -> Linkable -> Bool
- not_in lis li
- = all (\l -> linkableModName l /= mod) lis
- where mod = linkableModName li
-
-
data CmThreaded -- stuff threaded through individual module compilations
- = CmThreaded PersistentCompilerState HomeSymbolTable HomeIfaceTable
+ = CmThreaded PersistentCompilerState HomePackageTable
-- Compile multiple modules, stopping as soon as an error appears.
-- There better had not be any cyclic groups here -- we check for them.
upsweep_mods :: GhciMode
-> DynFlags
- -> UnlinkedImage -- valid linkables
+ -> [Linkable] -- Valid linkables
-> (ModuleName -> [ModuleName]) -- to construct downward closures
- -> CmThreaded -- PCS & HST & HIT
+ -> CmThreaded -- PCS & HPT
-> IO () -- how to clean up unwanted tmp files
-> [SCC ModSummary] -- mods to do (the worklist)
-- ...... RETURNING ......
- -> IO (Bool{-complete success?-},
- CmThreaded,
- [ModSummary], -- mods which succeeded
- [Linkable]) -- new linkables
+ -> IO (SuccessFlag,
+ CmThreaded, -- Includes linkables
+ [ModSummary]) -- Mods which succeeded
upsweep_mods ghci_mode dflags oldUI reachable_from threaded cleanup
[]
- = return (True, threaded, [], [])
+ = return (Succeeded, threaded, [])
upsweep_mods ghci_mode dflags oldUI reachable_from threaded cleanup
((CyclicSCC ms):_)
= do hPutStrLn stderr ("Module imports form a cycle for modules:\n\t" ++
unwords (map (moduleNameUserString.modSummaryName) ms))
- return (False, threaded, [], [])
+ return (Failed, threaded, [])
upsweep_mods ghci_mode dflags oldUI reachable_from threaded cleanup
((AcyclicSCC mod):mods)
= do --case threaded of
- -- CmThreaded pcsz hstz hitz
- -- -> putStrLn ("UPSWEEP_MOD: hit = " ++ show (map (moduleNameUserString.moduleName.mi_module) (eltsUFM hitz)))
+ -- CmThreaded pcsz hptz
+ -- -> putStrLn ("UPSWEEP_MOD: hpt = " ++
+ -- show (map (moduleNameUserString.moduleName.mi_module.hm_iface) (eltsUFM hptz)))
- (threaded1, maybe_linkable)
- <- upsweep_mod ghci_mode dflags oldUI threaded mod
- (reachable_from (modSummaryName mod))
+ (ok_flag, threaded1) <- upsweep_mod ghci_mode dflags oldUI threaded mod
+ (reachable_from (modSummaryName mod))
- -- remove unwanted tmp files between compilations
- cleanup
+ cleanup -- Remove unwanted tmp files between compilations
- case maybe_linkable of
- Just linkable
- -> -- No errors; do the rest
- do (restOK, threaded2, modOKs, linkables)
+ if failed ok_flag then
+ return (Failed, threaded1, [])
+ else do
+ (restOK, threaded2, modOKs)
<- upsweep_mods ghci_mode dflags oldUI reachable_from
threaded1 cleanup mods
- return (restOK, threaded2, mod:modOKs, linkable:linkables)
- Nothing -- we got a compilation error; give up now
- -> return (False, threaded1, [], [])
+ return (restOK, threaded2, mod:modOKs)
-- Compile a single module. Always produce a Linkable for it if
-> CmThreaded
-> ModSummary
-> [ModuleName]
- -> IO (CmThreaded, Maybe Linkable)
+ -> IO (SuccessFlag, CmThreaded)
upsweep_mod ghci_mode dflags oldUI threaded1 summary1 reachable_inc_me
= do
- let mod_name = modSummaryName summary1
+ let this_mod = ms_mod summary1
+ location = ms_location summary1
+ mod_name = moduleName this_mod
- let (CmThreaded pcs1 hst1 hit1) = threaded1
- let old_iface = lookupUFM hit1 mod_name
+ let (CmThreaded pcs1 hpt1) = threaded1
+ let mb_old_iface = case lookupModuleEnvByName hpt1 mod_name of
+ Just mod_info -> Just (hm_iface mod_info)
+ Nothing -> Nothing
let maybe_old_linkable = findModuleLinkable_maybe oldUI mod_name
+ source_unchanged = isJust maybe_old_linkable
- source_unchanged = isJust maybe_old_linkable
-
- reachable_only = filter (/= (modSummaryName summary1))
- reachable_inc_me
+ reachable_only = filter (/= mod_name) reachable_inc_me
- -- in interactive mode, all home modules below us *must* have an
- -- interface in the HIT. We never demand-load home interfaces in
+ -- In interactive mode, all home modules below us *must* have an
+ -- interface in the HPT. We never demand-load home interfaces in
-- interactive mode.
- (hst1_strictDC, hit1_strictDC, [])
- = ASSERT(ghci_mode == Batch ||
- all (`elemUFM` hit1) reachable_only)
- retainInTopLevelEnvs reachable_only (hst1,hit1,[])
+ hpt1_strictDC
+ = ASSERT(ghci_mode == Batch || all (`elemUFM` hpt1) reachable_only)
+ retainInTopLevelEnvs reachable_only hpt1
- old_linkable
- = expectJust "upsweep_mod:old_linkable" maybe_old_linkable
+ old_linkable = expectJust "upsweep_mod:old_linkable" maybe_old_linkable
have_object
| Just l <- maybe_old_linkable, isObjectLinkable l = True
| otherwise = False
- compresult <- compile ghci_mode summary1 source_unchanged
- have_object old_iface hst1_strictDC hit1_strictDC pcs1
+ compresult <- compile ghci_mode this_mod location source_unchanged
+ have_object mb_old_iface hpt1_strictDC pcs1
case compresult of
-- linkable (depending on whether compilation was actually performed
-- or not).
CompOK pcs2 new_details new_iface maybe_new_linkable
- -> do let hst2 = addToUFM hst1 mod_name new_details
- hit2 = addToUFM hit1 mod_name new_iface
- threaded2 = CmThreaded pcs2 hst2 hit2
-
- return (threaded2, if isJust maybe_new_linkable
- then maybe_new_linkable
- else Just old_linkable)
-
- -- Compilation failed. compile may still have updated
- -- the PCS, tho.
- CompErrs pcs2
- -> do let threaded2 = CmThreaded pcs2 hst1 hit1
- return (threaded2, Nothing)
-
--- Filter modules in the top level envs (HST, HIT, UI).
-retainInTopLevelEnvs :: [ModuleName]
- -> (HomeSymbolTable, HomeIfaceTable, UnlinkedImage)
- -> (HomeSymbolTable, HomeIfaceTable, UnlinkedImage)
-retainInTopLevelEnvs keep_these (hst, hit, ui)
- = (retainInUFM hst keep_these,
- retainInUFM hit keep_these,
- filterModuleLinkables (`elem` keep_these) ui
- )
- where
- retainInUFM :: Uniquable key => UniqFM elt -> [key] -> UniqFM elt
- retainInUFM ufm keys_to_keep
- = listToUFM (concatMap (maybeLookupUFM ufm) keys_to_keep)
- maybeLookupUFM ufm u
- = case lookupUFM ufm u of Nothing -> []; Just val -> [(u, val)]
+ -> do let
+ new_linkable = maybe_new_linkable `orElse` old_linkable
+ new_info = HomeModInfo { hm_iface = new_iface,
+ hm_details = new_details,
+ hm_linkable = new_linkable }
+ hpt2 = extendModuleEnv hpt1 this_mod new_info
+
+ return (Succeeded, CmThreaded pcs2 hpt2)
+
+ -- Compilation failed. Compile may still have updated the PCS, tho.
+ CompErrs pcs2 -> return (Failed, CmThreaded pcs2 hpt1)
+
+-- Filter modules in the HPT
+retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable
+retainInTopLevelEnvs keep_these hpt
+ = listToUFM (concatMap (maybeLookupUFM hpt) keep_these)
+ where
+ maybeLookupUFM ufm u = case lookupUFM ufm u of
+ Nothing -> []
+ Just val -> [(u, val)]
--- Needed to clean up HIT and HST so that we don't get duplicates in inst env
+-- Needed to clean up HPT so that we don't get duplicates in inst env
downwards_closure_of_module :: [ModSummary] -> ModuleName -> [ModuleName]
downwards_closure_of_module summaries root
= let toEdge :: ModSummary -> (ModuleName,[ModuleName])
srcimps the_imps src_timestamp)
-- Summarise a module, and pick up source and timestamp.
-summarise :: Module -> ModuleLocation -> Maybe ModSummary
+summarise :: Module -> ModLocation -> Maybe ModSummary
-> IO (Maybe ModSummary)
summarise mod location old_summary
| not (isHomeModule mod) = return Nothing
text "is defined in multiple files:" <+>
sep (map text files))))
\end{code}
+
+
+%************************************************************************
+%* *
+ The ModSummary Type
+%* *
+%************************************************************************
+
+\begin{code}
+-- The ModLocation contains both the original source filename and the
+-- filename of the cleaned-up source file after all preprocessing has been
+-- done. The point is that the summariser will have to cpp/unlit/whatever
+-- all files anyway, and there's no point in doing this twice -- just
+-- park the result in a temp file, put the name of it in the location,
+-- and let @compile@ read from that file on the way back up.
+
+
+type ModuleGraph = [ModSummary] -- the module graph, topologically sorted
+
+emptyMG :: ModuleGraph
+emptyMG = []
+
+data ModSummary
+ = ModSummary {
+ ms_mod :: Module, -- name, package
+ ms_location :: ModLocation, -- location
+ ms_srcimps :: [ModuleName], -- source imports
+ ms_imps :: [ModuleName], -- non-source imports
+ ms_hs_date :: ClockTime -- timestamp of summarised file
+ }
+
+instance Outputable ModSummary where
+ ppr ms
+ = sep [text "ModSummary {",
+ nest 3 (sep [text "ms_hs_date = " <> text (show (ms_hs_date ms)),
+ text "ms_mod =" <+> ppr (ms_mod ms) <> comma,
+ text "ms_imps =" <+> ppr (ms_imps ms),
+ text "ms_srcimps =" <+> ppr (ms_srcimps ms)]),
+ char '}'
+ ]
+
+ms_allimps ms = ms_srcimps ms ++ ms_imps ms
+
+modSummaryName :: ModSummary -> ModuleName
+modSummaryName = moduleName . ms_mod
+\end{code}
import VarSet
import Var ( Var, isId, isLocalVar, varName )
import Type ( tyVarsOfType )
-import TcType ( namesOfType )
+import TcType ( tyClsNamesOfType )
import Util ( mapAndUnzip )
import Outputable
\end{code}
= addOneToNameSet (exprsFreeNames tpl_args `del_binders` tpl_vars) (varName fn)
exprFreeNames :: CoreExpr -> NameSet
-exprFreeNames (Var v) = unitNameSet (varName v)
-exprFreeNames (Lit _) = emptyNameSet
-exprFreeNames (Type ty) = namesOfType ty
+exprFreeNames (Var v) = unitNameSet (varName v)
+exprFreeNames (Lit _) = emptyNameSet
+exprFreeNames (Type ty) = tyClsNamesOfType ty -- Don't need free tyvars
exprFreeNames (App e1 e2) = exprFreeNames e1 `unionNameSets` exprFreeNames e2
exprFreeNames (Lam v e) = exprFreeNames e `delFromNameSet` varName v
exprFreeNames (Note n e) = exprFreeNames e
import Name ( getSrcLoc )
import PprCore
import ErrUtils ( doIfSet, dumpIfSet_core, ghcExit, Message, showPass,
- ErrMsg, addErrLocHdrLine, pprBagOfErrors,
- WarnMsg, pprBagOfWarnings)
+ addErrLocHdrLine )
import SrcLoc ( SrcLoc, noSrcLoc )
import Type ( Type, tyVarsOfType, eqType,
splitFunTy_maybe, mkTyVarTy,
\begin{code}
type LintM a = [LintLocInfo] -- Locations
-> IdSet -- Local vars in scope
- -> Bag ErrMsg -- Error messages so far
- -> Bag WarnMsg -- Warning messages so far
- -> (Maybe a, Bag ErrMsg, Bag WarnMsg) -- Result and error/warning messages (if any)
+ -> Bag Message -- Error messages so far
+ -> Bag Message -- Warning messages so far
+ -> (Maybe a, Bag Message, Bag Message) -- Result and error/warning messages (if any)
data LintLocInfo
= RhsOf Id -- The variable bound
initL :: LintM a -> (Maybe Message {- errors -}, Maybe Message {- warnings -})
initL m
= case m [] emptyVarSet emptyBag emptyBag of
- (_, errs, warns) -> (ifNonEmptyBag errs pprBagOfErrors,
- ifNonEmptyBag warns pprBagOfWarnings)
+ (_, errs, warns) -> (ifNonEmptyBag errs,
+ ifNonEmptyBag warns)
where
- ifNonEmptyBag bag f | isEmptyBag bag = Nothing
- | otherwise = Just (f bag)
+ ifNonEmptyBag bag
+ | isEmptyBag bag = Nothing
+ | otherwise = Just (vcat (punctuate (text "") (bagToList bag)))
returnL :: a -> LintM a
returnL r loc scope errs warns = (Just r, errs, warns)
addErrL :: Message -> LintM a
addErrL msg loc scope errs warns = (Nothing, addErr errs msg loc, warns)
-addErr :: Bag ErrMsg -> Message -> [LintLocInfo] -> Bag ErrMsg
+addErr :: Bag Message -> Message -> [LintLocInfo] -> Bag Message
-- errors or warnings, actually... they're the same type.
addErr errs_so_far msg locs
= ASSERT( notNull locs )
isLocalId, hasNoBinding, idNewStrictness,
isDataConId_maybe, idUnfolding
)
-import HscTypes ( ModDetails(..), implicitTyThingIds, typeEnvElts )
+import HscTypes ( ModGuts(..), ModGuts, implicitTyThingIds, typeEnvElts )
import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel,
RecFlag(..), isNonRec
)
-- -----------------------------------------------------------------------------
\begin{code}
-corePrepPgm :: DynFlags -> ModDetails -> IO ModDetails
-corePrepPgm dflags mod_details
+corePrepPgm :: DynFlags -> ModGuts -> IO ModGuts
+corePrepPgm dflags mod_impl
= do showPass dflags "CorePrep"
us <- mkSplitUniqSupply 's'
- let implicit_binds = mkImplicitBinds (md_types mod_details)
+ let implicit_binds = mkImplicitBinds (mg_types mod_impl)
-- NB: we must feed mkImplicitBinds through corePrep too
-- so that they are suitably cloned and eta-expanded
binds_out = initUs_ us (
- corePrepTopBinds (md_binds mod_details) `thenUs` \ floats1 ->
- corePrepTopBinds implicit_binds `thenUs` \ floats2 ->
+ corePrepTopBinds (mg_binds mod_impl) `thenUs` \ floats1 ->
+ corePrepTopBinds implicit_binds `thenUs` \ floats2 ->
returnUs (deFloatTop (floats1 `appOL` floats2))
)
endPass dflags "CorePrep" Opt_D_dump_prep binds_out
- return (mod_details { md_binds = binds_out })
+ return (mod_impl { mg_binds = binds_out })
corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
corePrepExpr dflags expr
module CoreSyn (
Expr(..), Alt, Bind(..), AltCon(..), Arg, Note(..),
CoreExpr, CoreAlt, CoreBind, CoreArg, CoreBndr,
- TaggedExpr, TaggedAlt, TaggedBind, TaggedArg,
+ TaggedExpr, TaggedAlt, TaggedBind, TaggedArg, TaggedBndr(..),
mkLets, mkLams,
mkApps, mkTyApps, mkValApps, mkVarApps,
Binders are ``tagged'' with a \tr{t}:
\begin{code}
-type Tagged t = (CoreBndr, t)
+data TaggedBndr t = TB CoreBndr t -- TB for "tagged binder"
-type TaggedBind t = Bind (Tagged t)
-type TaggedExpr t = Expr (Tagged t)
-type TaggedArg t = Arg (Tagged t)
-type TaggedAlt t = Alt (Tagged t)
+type TaggedBind t = Bind (TaggedBndr t)
+type TaggedExpr t = Expr (TaggedBndr t)
+type TaggedArg t = Arg (TaggedBndr t)
+type TaggedAlt t = Alt (TaggedBndr t)
+
+instance Outputable b => Outputable (TaggedBndr b) where
+ ppr (TB b l) = char '<' <> ppr b <> comma <> ppr l <> char '>'
+
+instance Outputable b => OutputableBndr (TaggedBndr b) where
+ pprBndr _ b = ppr b -- Simple
\end{code}
import IO
import FastString
-emitExternalCore :: DynFlags -> ModIface -> ModDetails -> IO ()
-emitExternalCore dflags iface details
+emitExternalCore :: DynFlags -> ModGuts -> IO ()
+emitExternalCore dflags mod_impl
| opt_EmitExternalCore
= (do handle <- openFile corename WriteMode
- hPutStr handle (show (mkExternalCore iface details))
+ hPutStr handle (show (mkExternalCore mod_impl))
hClose handle)
`catch` (\err -> pprPanic "Failed to open or write external core output file"
(text corename))
where corename = extCoreName dflags
-emitExternalCore _ _ _
+emitExternalCore _ _
| otherwise
= return ()
-mkExternalCore :: ModIface -> ModDetails -> C.Module
-mkExternalCore (ModIface {mi_module=mi_module,mi_exports=mi_exports})
- (ModDetails {md_types=md_types,md_binds=md_binds}) =
- C.Module mname tdefs vdefs
+mkExternalCore :: ModGuts -> C.Module
+mkExternalCore (ModGuts {mg_module=this_mod, mg_types = type_env, mg_binds = binds})
+ = C.Module mname tdefs vdefs
where
- mname = make_mid mi_module
- tdefs = foldr collect_tdefs [] (typeEnvTyCons md_types)
- vdefs = map make_vdef md_binds
+ mname = make_mid this_mod
+ tdefs = foldr collect_tdefs [] (typeEnvTyCons type_env)
+ vdefs = map make_vdef binds
collect_tdefs :: TyCon -> [C.Tdef] -> [C.Tdef]
collect_tdefs tcon tdefs
\begin{code}
module PprCore (
- pprCoreExpr, pprParendExpr,
- pprCoreBinding, pprCoreBindings, pprIdBndr,
+ pprCoreExpr, pprParendExpr, pprIdBndr,
pprCoreBinding, pprCoreBindings, pprCoreAlt,
pprIdRules, pprCoreRule
) where
import CoreSyn
import CostCentre ( pprCostCentreCore )
+import Var ( Var )
import Id ( Id, idType, isDataConId_maybe, idLBVarInfo, idArity,
idInfo, idInlinePragma, idOccInfo,
#ifdef OLD_STRICTNESS
import Var ( isTyVar )
import IdInfo ( IdInfo, megaSeqIdInfo,
arityInfo, ppArityInfo,
- specInfo, ppStrictnessInfo,
+ specInfo, pprNewStrictness,
workerInfo, ppWorkerInfo,
newStrictnessInfo,
#ifdef OLD_STRICTNESS
cprInfo, ppCprInfo,
- strictnessInfo,
+ strictnessInfo, ppStrictnessInfo,
#endif
)
import DataCon ( dataConTyCon )
import TyCon ( tupleTyConBoxity, isTupleTyCon )
-import PprType ( pprParendType, pprTyVarBndr )
+import PprType ( pprParendType, pprType, pprTyVarBndr )
import BasicTypes ( tupleParens )
-import PprEnv
import Util ( lengthIs )
import Outputable
\end{code}
%* *
%************************************************************************
-@pprCoreBinding@ and @pprCoreExpr@ let you give special printing
-function for ``major'' val_bdrs (those next to equal signs :-),
-``minor'' ones (lambda-bound, case-bound), and bindees. They would
-usually be called through some intermediary.
-
-The binder/occ printers take the default ``homogenized'' (see
-@PprEnv@...) @Doc@ and the binder/occ. They can either use the
-homogenized one, or they can ignore it completely. In other words,
-the things passed in act as ``hooks'', getting the last word on how to
-print something.
-
@pprParendCoreExpr@ puts parens around non-atomic Core expressions.
-Un-annotated core dumps
-~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
-pprCoreBindings :: [CoreBind] -> SDoc
-pprCoreBinding :: CoreBind -> SDoc
-pprCoreExpr :: CoreExpr -> SDoc
-pprParendExpr :: CoreExpr -> SDoc
-
-pprCoreBindings = pprTopBinds pprCoreEnv
-pprCoreBinding = pprTopBind pprCoreEnv
-pprCoreExpr = ppr_noparend_expr pprCoreEnv
-pprParendExpr = ppr_parend_expr pprCoreEnv
-pprArg = ppr_arg pprCoreEnv
-pprCoreAlt = ppr_alt pprCoreEnv
-
-pprCoreEnv = initCoreEnv pprCoreBinder
-\end{code}
+pprCoreBindings :: OutputableBndr b => [Bind b] -> SDoc
+pprCoreBinding :: OutputableBndr b => Bind b -> SDoc
+pprCoreExpr :: OutputableBndr b => Expr b -> SDoc
+pprParendExpr :: OutputableBndr b => Expr b -> SDoc
-Printer for unfoldings in interfaces
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-\begin{code}
-instance Outputable b => Outputable (Bind b) where
- ppr bind = ppr_bind pprGenericEnv bind
+pprCoreBindings = pprTopBinds
+pprCoreBinding = pprTopBind
-instance Outputable b => Outputable (Expr b) where
- ppr expr = ppr_noparend_expr pprGenericEnv expr
+instance OutputableBndr b => Outputable (Bind b) where
+ ppr bind = ppr_bind bind
-pprGenericEnv :: Outputable b => PprEnv b
-pprGenericEnv = initCoreEnv (\site -> ppr)
+instance OutputableBndr b => Outputable (Expr b) where
+ ppr expr = pprCoreExpr expr
\end{code}
-%************************************************************************
-%* *
-\subsection{Instance declarations for Core printing}
-%* *
-%************************************************************************
-
-
-\begin{code}
-initCoreEnv pbdr
- = initPprEnv
- (Just pprCostCentreCore) -- Cost centres
-
- (Just ppr) -- tyvar occs
- (Just pprParendType) -- types
-
- (Just pbdr) (Just ppr) -- value vars
- -- Use pprIdBndr for this last one as a debugging device.
-\end{code}
%************************************************************************
%* *
%************************************************************************
\begin{code}
-pprTopBinds pe binds = vcat (map (pprTopBind pe) binds)
+pprTopBinds binds = vcat (map pprTopBind binds)
-pprTopBind pe (NonRec binder expr)
- = ppr_binding_pe pe (binder,expr) $$ text ""
+pprTopBind (NonRec binder expr)
+ = ppr_binding (binder,expr) $$ text ""
-pprTopBind pe (Rec binds)
+pprTopBind (Rec binds)
= vcat [ptext SLIT("Rec {"),
- vcat (map (ppr_binding_pe pe) binds),
+ vcat (map ppr_binding binds),
ptext SLIT("end Rec }"),
text ""]
\end{code}
\begin{code}
-ppr_bind :: PprEnv b -> Bind b -> SDoc
+ppr_bind :: OutputableBndr 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_bind (NonRec val_bdr expr) = ppr_binding (val_bdr, expr)
+ppr_bind (Rec binds) = vcat (map pp binds)
+ where
+ pp bind = ppr_binding bind <> semi
-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_noparend_expr pe expr)]
+ppr_binding :: OutputableBndr b => (b, Expr b) -> SDoc
+ppr_binding (val_bdr, expr)
+ = pprBndr LetBind val_bdr $$
+ (ppr val_bdr <+> equals <+> pprCoreExpr expr)
\end{code}
\begin{code}
-ppr_parend_expr pe expr = ppr_expr parens pe expr
-ppr_noparend_expr pe expr = ppr_expr noParens pe expr
+pprParendExpr expr = ppr_expr parens expr
+pprCoreExpr expr = ppr_expr noParens expr
noParens :: SDoc -> SDoc
noParens pp = pp
\end{code}
\begin{code}
-ppr_expr :: (SDoc -> SDoc) -> PprEnv b -> Expr b -> SDoc
+ppr_expr :: OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc
-- The function adds parens in context that need
-- an atomic value (e.g. function args)
-ppr_expr add_par pe (Type ty) = add_par (ptext SLIT("TYPE") <+> ppr ty) -- Wierd
+ppr_expr add_par (Type ty) = add_par (ptext SLIT("TYPE") <+> ppr ty) -- Wierd
-ppr_expr add_par pe (Var name) = pOcc pe name
-ppr_expr add_par pe (Lit lit) = ppr lit
+ppr_expr add_par (Var name) = ppr name
+ppr_expr add_par (Lit lit) = ppr lit
-ppr_expr add_par pe expr@(Lam _ _)
+ppr_expr add_par expr@(Lam _ _)
= let
(bndrs, body) = collectBinders expr
in
add_par $
- hang (ptext SLIT("\\") <+> sep (map (pBndr pe LambdaBind) bndrs) <+> arrow)
- 2 (ppr_noparend_expr pe body)
+ hang (ptext SLIT("\\") <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow)
+ 2 (pprCoreExpr body)
-ppr_expr add_par pe expr@(App fun arg)
+ppr_expr add_par expr@(App fun arg)
= case collectArgs expr of { (fun, args) ->
let
- pp_args = sep (map (ppr_arg pe) args)
+ pp_args = sep (map pprArg args)
val_args = dropWhile isTypeArg args -- Drop the type arguments for tuples
- pp_tup_args = sep (punctuate comma (map (ppr_arg pe) val_args))
+ pp_tup_args = sep (punctuate comma (map pprArg val_args))
in
case fun of
Var f -> case isDataConId_maybe f of
tc = dataConTyCon dc
saturated = val_args `lengthIs` idArity f
- other -> add_par (hang (pOcc pe f) 2 pp_args)
+ other -> add_par (hang (ppr f) 2 pp_args)
- other -> add_par (hang (ppr_parend_expr pe fun) 2 pp_args)
+ other -> add_par (hang (pprParendExpr fun) 2 pp_args)
}
-ppr_expr add_par pe (Case expr var [(con,args,rhs)])
+ppr_expr add_par (Case expr var [(con,args,rhs)])
= add_par $
- sep [sep [ptext SLIT("case") <+> ppr_noparend_expr pe expr,
+ sep [sep [ptext SLIT("case") <+> pprCoreExpr expr,
hsep [ptext SLIT("of"),
ppr_bndr var,
char '{',
- ppr_case_pat pe con args
+ ppr_case_pat con args
]],
- ppr_noparend_expr pe rhs,
+ pprCoreExpr rhs,
char '}'
]
where
- ppr_bndr = pBndr pe CaseBind
+ ppr_bndr = pprBndr CaseBind
-ppr_expr add_par pe (Case expr var alts)
+ppr_expr add_par (Case expr var alts)
= add_par $
- sep [sep [ptext SLIT("case") <+> ppr_noparend_expr pe expr,
+ sep [sep [ptext SLIT("case") <+> pprCoreExpr expr,
ptext SLIT("of") <+> ppr_bndr var <+> char '{'],
- nest 2 (sep (punctuate semi (map (ppr_alt pe) alts))),
+ nest 2 (sep (punctuate semi (map pprCoreAlt alts))),
char '}'
]
where
- ppr_bndr = pBndr pe CaseBind
+ ppr_bndr = pprBndr CaseBind
-- special cases: let ... in let ...
-- ("disgusting" SLPJ)
-ppr_expr add_par pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
+{-
+ppr_expr add_par (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
= add_par $
vcat [
- hsep [ptext SLIT("let {"), pBndr pe LetBind val_bdr, equals],
- nest 2 (ppr_noparend_expr pe rhs),
+ hsep [ptext SLIT("let {"), (pprBndr LetBind val_bdr $$ ppr val_bndr), equals],
+ nest 2 (pprCoreExpr rhs),
ptext SLIT("} in"),
- ppr_noparend_expr pe body ]
+ pprCoreExpr body ]
+-}
-ppr_expr add_par pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
+ppr_expr add_par (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
= add_par
(hang (ptext SLIT("let {"))
- 2 (hsep [hang (hsep [pBndr pe LetBind val_bdr, equals])
- 2 (ppr_noparend_expr pe rhs),
- ptext SLIT("} in")])
+ 2 (hsep [ppr_binding (val_bdr,rhs),
+ ptext SLIT("} in")])
$$
- ppr_noparend_expr pe expr)
+ pprCoreExpr expr)
-- general case (recursive case, too)
-ppr_expr add_par pe (Let bind expr)
+ppr_expr add_par (Let bind expr)
= add_par $
- sep [hang (ptext keyword) 2 (ppr_bind pe bind),
- hang (ptext SLIT("} in ")) 2 (ppr_noparend_expr pe expr)]
+ sep [hang (ptext keyword) 2 (ppr_bind bind),
+ hang (ptext SLIT("} in ")) 2 (pprCoreExpr expr)]
where
keyword = case bind of
Rec _ -> SLIT("__letrec {")
NonRec _ _ -> SLIT("let {")
-ppr_expr add_par pe (Note (SCC cc) expr)
- = add_par (sep [pSCC pe cc, ppr_noparend_expr pe expr])
+ppr_expr add_par (Note (SCC cc) expr)
+ = add_par (sep [pprCostCentreCore cc, pprCoreExpr expr])
#ifdef DEBUG
-ppr_expr add_par pe (Note (Coerce to_ty from_ty) expr)
+ppr_expr add_par (Note (Coerce to_ty from_ty) expr)
= add_par $
getPprStyle $ \ sty ->
if debugStyle sty then
- sep [ptext SLIT("__coerce") <+> sep [pTy pe to_ty, pTy pe from_ty],
- ppr_parend_expr pe expr]
+ sep [ptext SLIT("__coerce") <+>
+ sep [pprParendType to_ty, pprParendType from_ty],
+ pprParendExpr expr]
else
- sep [hsep [ptext SLIT("__coerce"), pTy pe to_ty],
- ppr_parend_expr pe expr]
+ sep [hsep [ptext SLIT("__coerce"), pprParendType to_ty],
+ pprParendExpr expr]
#else
-ppr_expr add_par pe (Note (Coerce to_ty from_ty) expr)
+ppr_expr add_par (Note (Coerce to_ty from_ty) expr)
= add_par $
- sep [sep [ptext SLIT("__coerce"), nest 2 (pTy pe to_ty)],
- ppr_parend_expr pe expr]
+ sep [sep [ptext SLIT("__coerce"), nest 2 (pprParendType to_ty)],
+ pprParendExpr expr]
#endif
-ppr_expr add_par pe (Note InlineCall expr)
- = add_par (ptext SLIT("__inline_call") <+> ppr_parend_expr pe expr)
+ppr_expr add_par (Note InlineCall expr)
+ = add_par (ptext SLIT("__inline_call") <+> pprParendExpr expr)
-ppr_expr add_par pe (Note InlineMe expr)
- = add_par $ ptext SLIT("__inline_me") <+> ppr_parend_expr pe expr
+ppr_expr add_par (Note InlineMe expr)
+ = add_par $ ptext SLIT("__inline_me") <+> pprParendExpr expr
-ppr_alt pe (con, args, rhs)
- = hang (ppr_case_pat pe con args) 2 (ppr_noparend_expr pe rhs)
+pprCoreAlt (con, args, rhs)
+ = hang (ppr_case_pat con args) 2 (pprCoreExpr rhs)
-ppr_case_pat pe con@(DataAlt dc) args
+ppr_case_pat con@(DataAlt dc) args
| isTupleTyCon tc
= tupleParens (tupleTyConBoxity tc) (hsep (punctuate comma (map ppr_bndr args))) <+> arrow
where
- ppr_bndr = pBndr pe CaseBind
+ ppr_bndr = pprBndr CaseBind
tc = dataConTyCon dc
-ppr_case_pat pe con args
+ppr_case_pat con args
= ppr con <+> hsep (map ppr_bndr args) <+> arrow
where
- ppr_bndr = pBndr pe CaseBind
+ ppr_bndr = pprBndr CaseBind
-ppr_arg pe (Type ty) = ptext SLIT("@") <+> pTy pe ty
-ppr_arg pe expr = ppr_parend_expr pe expr
+pprArg (Type ty) = ptext SLIT("@") <+> pprParendType ty
+pprArg expr = pprParendExpr expr
arrow = ptext SLIT("->")
\end{code}
and @pprCoreExpr@ functions.
\begin{code}
--- Used for printing dump info
+instance OutputableBndr Var where
+ pprBndr = pprCoreBinder
+
+pprCoreBinder :: BindingSite -> Var -> SDoc
pprCoreBinder LetBind binder
- = vcat [sig, pprIdDetails binder, pragmas, ppr binder]
+ = vcat [sig, pprIdDetails binder, pragmas]
where
sig = pprTypedBinder binder
pragmas = ppIdInfo binder (idInfo binder)
pprTypedBinder binder
| isTyVar binder = ptext SLIT("@") <+> pprTyVarBndr binder
- | otherwise = pprIdBndr binder <+> dcolon <+> pprParendType (idType binder)
+ | otherwise = pprIdBndr binder <+> dcolon <+> pprType (idType binder)
-- The space before the :: is important; it helps the lexer
-- when reading inferfaces. Otherwise it would lex "a::b" as one thing.
--
-- It's important that the type is parenthesised too, at least when
-- printing interfaces, because we get \ x::(a->b) y::(c->d) -> ...
+ -- [Jun 2002: interfaces are now binary, so this doesn't matter]
-- pprIdBndr does *not* print the type
-- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness
ppStrictnessInfo s,
ppCprInfo m,
#endif
- ppr (newStrictnessInfo info),
+ pprNewStrictness (newStrictnessInfo info),
vcat (map (pprCoreRule (ppr b)) (rulesRules p))
-- Inline pragma, occ, demand, lbvar info
-- printed out with all binders (when debug is on);
$tot = 0;
$totcmts = 0;
+printf "\n Code Comments\n"
foreach $m (sort (keys %ModCount)) {
printf "%-20s %6d %6d\n", $m, $ModCount{$m}, $ModComments{$m};
$tot += $ModCount{$m};
import HsSyn
-import TcHsSyn ( TypecheckedPat, outPatType )
-import TcType ( tcTyConAppTyCon, tcTyConAppArgs )
+import TcHsSyn ( TypecheckedPat, hsPatType )
+import TcType ( tcTyConAppTyCon )
import DsUtils ( EquationInfo(..), MatchResult(..), EqnSet,
CanItFail(..), tidyLitPat, tidyNPat,
)
import Id ( idType )
-import DataCon ( DataCon, dataConTyCon, dataConArgTys,
- dataConSourceArity, dataConFieldLabels )
+import DataCon ( DataCon, dataConTyCon, dataConOrigArgTys, dataConFieldLabels )
import Name ( Name, mkInternalName, getOccName, isDataSymOcc, getName, mkVarOcc )
-import TcType ( mkTyVarTys )
-import TysPrim ( charPrimTy )
import TysWiredIn
import PrelNames ( unboundKey )
import TyCon ( tyConDataCons, tupleTyConBoxity, isTupleTyCon )
untidy_pars p = untidy True p
untidy :: NeedPars -> WarningPat -> WarningPat
-untidy _ p@WildPatIn = p
-untidy _ p@(VarPatIn name) = p
-untidy _ (LitPatIn lit) = LitPatIn (untidy_lit lit)
-untidy _ p@(ConPatIn name []) = p
-untidy b (ConPatIn name pats) =
- pars b (ConPatIn name (map untidy_pars pats))
-untidy b (ConOpPatIn pat1 name fixity pat2) =
- pars b (ConOpPatIn (untidy_pars pat1) name fixity (untidy_pars pat2))
-untidy _ (ListPatIn pats) = ListPatIn (map untidy_no_pars pats)
-untidy _ (PArrPatIn pats) =
- panic "Check.untidy: Shouldn't get a parallel array here!"
-untidy _ (TuplePatIn pats boxed) = TuplePatIn (map untidy_no_pars pats) boxed
-
-untidy _ pat = pprPanic "Check.untidy: SigPatIn" (ppr pat)
+untidy _ p@(WildPat _) = p
+untidy _ p@(VarPat name) = p
+untidy _ (LitPat lit) = LitPat (untidy_lit lit)
+untidy _ p@(ConPatIn name (PrefixCon [])) = p
+untidy b (ConPatIn name ps) = pars b (ConPatIn name (untidy_con ps))
+untidy _ (ListPat pats ty) = ListPat (map untidy_no_pars pats) ty
+untidy _ (TuplePat pats boxed) = TuplePat (map untidy_no_pars pats) boxed
+untidy _ (PArrPat _ _) = panic "Check.untidy: Shouldn't get a parallel array here!"
+untidy _ (SigPatIn _ _) = panic "Check.untidy: SigPat"
+
+untidy_con (PrefixCon pats) = PrefixCon (map untidy_pars pats)
+untidy_con (InfixCon p1 p2) = InfixCon (untidy_pars p1) (untidy_pars p2)
+untidy_con (RecCon bs) = RecCon [(f,untidy_pars p) | (f,p) <- bs]
pars :: NeedPars -> WarningPat -> WarningPat
-pars True p = ParPatIn p
+pars True p = ParPat p
pars _ p = p
untidy_lit :: HsLit -> HsLit
untidy_lit (HsCharPrim c) = HsChar c
---untidy_lit (HsStringPrim s) = HsString s
-untidy_lit lit = lit
+untidy_lit lit = lit
\end{code}
This equation is the same that check, the only difference is that the
| literals = split_by_literals qs
| constructors = split_by_constructor qs
| only_vars = first_column_only_vars qs
- | otherwise = panic "Check.check': Not implemented :-("
+ | otherwise = pprPanic "Check.check': Not implemented :-(" (ppr first_pats)
where
-- Note: RecPats will have been simplified to ConPats
-- at this stage.
- constructors = or (map is_con qs)
- literals = or (map is_lit qs)
- only_vars = and (map is_var qs)
+ first_pats = ASSERT2( okGroup qs, pprGroup qs ) map firstPat qs
+ constructors = any is_con first_pats
+ literals = any is_lit first_pats
+ only_vars = all is_var first_pats
-- npat = or (map is_npat qs)
-- nplusk = or (map is_nplusk qs)
\end{code}
| otherwise = (pats_default,indexs_default)
where
(pats,indexs) = process_explicit_literals used_lits qs
- default_eqns = (map remove_var (filter is_var qs))
+ default_eqns = ASSERT2( okGroup qs, pprGroup qs )
+ map remove_var (filter (is_var . firstPat) qs)
(pats',indexs') = check' default_eqns
pats_default = [(new_wild_pat:ps,constraints) | (ps,constraints) <- (pats')] ++ pats
indexs_default = unionUniqSets indexs' indexs
(map (\ (xs,ys) -> (new_lit:xs,ys)) pats,indexs)
where
(pats,indexs) = (check' (remove_first_column_lit lit qs))
- new_lit = LitPatIn lit
+ new_lit = LitPat lit
remove_first_column_lit :: HsLit
-> [EquationInfo]
-> [EquationInfo]
-remove_first_column_lit lit qs =
- map shift_pat (filter (is_var_lit lit) qs)
+remove_first_column_lit lit qs
+ = ASSERT2( okGroup qs, pprGroup qs )
+ map shift_pat (filter (is_var_lit lit . firstPat) qs)
where
shift_pat (EqnInfo n ctx [] result) = panic "Check.shift_var: no patterns"
shift_pat (EqnInfo n ctx (_:ps) result) = EqnInfo n ctx ps result
| otherwise = (pats_default,indexs_default)
where
(pats,indexs) = no_need_default_case used_cons qs
- default_eqns = (map remove_var (filter is_var qs))
+ default_eqns = ASSERT2( okGroup qs, pprGroup qs ) map remove_var (filter (is_var . firstPat) qs)
(pats',indexs') = check' default_eqns
pats_default = [(make_whole_con c:ps,constraints) |
c <- unused_cons, (ps,constraints) <- pats'] ++ pats
remove_first_column :: TypecheckedPat -- Constructor
-> [EquationInfo]
-> [EquationInfo]
-remove_first_column (ConPat con _ _ _ con_pats) qs =
- map shift_var (filter (is_var_con con) qs)
+remove_first_column (ConPatOut con (PrefixCon con_pats) _ _ _) qs
+ = ASSERT2( okGroup qs, pprGroup qs )
+ map shift_var (filter (is_var_con con . firstPat) qs)
where
- new_wilds = [WildPat (outPatType arg_pat) | arg_pat <- con_pats]
- shift_var (EqnInfo n ctx (ConPat _ _ _ _ ps':ps) result) =
+ new_wilds = [WildPat (hsPatType arg_pat) | arg_pat <- con_pats]
+ shift_var (EqnInfo n ctx (ConPatOut _ (PrefixCon ps') _ _ _:ps) result) =
EqnInfo n ctx (ps'++ps) result
shift_var (EqnInfo n ctx (WildPat _ :ps) result) =
EqnInfo n ctx (new_wilds ++ ps) result
make_row_vars :: [HsLit] -> EquationInfo -> ExhaustivePat
make_row_vars used_lits (EqnInfo _ _ pats _ ) =
- (VarPatIn new_var:takeList (tail pats) (repeat new_wild_pat),[(new_var,used_lits)])
+ (VarPat new_var:takeList (tail pats) (repeat new_wild_pat),[(new_var,used_lits)])
where new_var = hash_x
hash_x = mkInternalName unboundKey {- doesn't matter much -}
make_row_vars_for_constructor (EqnInfo _ _ pats _ ) = takeList (tail pats) (repeat new_wild_pat)
compare_cons :: TypecheckedPat -> TypecheckedPat -> Bool
-compare_cons (ConPat id1 _ _ _ _) (ConPat id2 _ _ _ _) = id1 == id2
+compare_cons (ConPatOut id1 _ _ _ _) (ConPatOut id2 _ _ _ _) = id1 == id2
remove_dups :: [TypecheckedPat] -> [TypecheckedPat]
remove_dups [] = []
| otherwise = x : remove_dups xs
get_used_cons :: [EquationInfo] -> [TypecheckedPat]
-get_used_cons qs = remove_dups [con | (EqnInfo _ _ (con@(ConPat _ _ _ _ _):_) _) <- qs ]
+get_used_cons qs = remove_dups [con | (EqnInfo _ _ (con@(ConPatOut _ _ _ _ _):_) _) <- qs ]
remove_dups' :: [HsLit] -> [HsLit]
remove_dups' [] = []
get_used_lits' :: [EquationInfo] -> [HsLit]
get_used_lits' [] = []
-get_used_lits' ((EqnInfo _ _ ((LitPat lit _):_) _):qs) =
+get_used_lits' ((EqnInfo _ _ ((LitPat lit):_) _):qs) =
lit : get_used_lits qs
-get_used_lits' ((EqnInfo _ _ ((NPat lit _ _):_) _):qs) =
+get_used_lits' ((EqnInfo _ _ ((NPatOut lit _ _):_) _):qs) =
lit : get_used_lits qs
get_used_lits' (q:qs) =
get_used_lits qs
get_unused_cons :: [TypecheckedPat] -> [DataCon]
get_unused_cons used_cons = unused_cons
where
- (ConPat _ ty _ _ _) = head used_cons
- ty_con = tcTyConAppTyCon ty -- Newtype observable
- all_cons = tyConDataCons ty_con
- used_cons_as_id = map (\ (ConPat d _ _ _ _) -> d) used_cons
- unused_cons = uniqSetToList
+ (ConPatOut _ _ ty _ _) = head used_cons
+ ty_con = tcTyConAppTyCon ty -- Newtype observable
+ all_cons = tyConDataCons ty_con
+ used_cons_as_id = map (\ (ConPatOut d _ _ _ _) -> d) used_cons
+ unused_cons = uniqSetToList
(mkUniqSet all_cons `minusUniqSet` mkUniqSet used_cons_as_id)
all_vars :: [TypecheckedPat] -> Bool
remove_var _ =
panic "Check.remove_var: equation does not begin with a variable"
-is_con :: EquationInfo -> Bool
-is_con (EqnInfo _ _ ((ConPat _ _ _ _ _):_) _) = True
-is_con _ = False
-
-is_lit :: EquationInfo -> Bool
-is_lit (EqnInfo _ _ ((LitPat _ _):_) _) = True
-is_lit (EqnInfo _ _ ((NPat _ _ _):_) _) = True
-is_lit _ = False
-
-is_npat :: EquationInfo -> Bool
-is_npat (EqnInfo _ _ ((NPat _ _ _):_) _) = True
-is_npat _ = False
-
-is_nplusk :: EquationInfo -> Bool
-is_nplusk (EqnInfo _ _ ((NPlusKPat _ _ _ _ _):_) _) = True
-is_nplusk _ = False
-
-is_var :: EquationInfo -> Bool
-is_var (EqnInfo _ _ ((WildPat _):_) _) = True
-is_var _ = False
-
-is_var_con :: DataCon -> EquationInfo -> Bool
-is_var_con con (EqnInfo _ _ ((WildPat _):_) _) = True
-is_var_con con (EqnInfo _ _ ((ConPat id _ _ _ _):_) _) | id == con = True
-is_var_con con _ = False
-
-is_var_lit :: HsLit -> EquationInfo -> Bool
-is_var_lit lit (EqnInfo _ _ ((WildPat _):_) _) = True
-is_var_lit lit (EqnInfo _ _ ((LitPat lit' _):_) _) | lit == lit' = True
-is_var_lit lit (EqnInfo _ _ ((NPat lit' _ _):_) _) | lit == lit' = True
-is_var_lit lit _ = False
+-----------------------
+eqnPats :: EquationInfo -> [TypecheckedPat]
+eqnPats (EqnInfo _ _ ps _) = ps
+
+firstPat :: EquationInfo -> TypecheckedPat
+firstPat eqn_info = head (eqnPats eqn_info)
+
+okGroup :: [EquationInfo] -> Bool
+-- True if all equations have at least one pattern, and
+-- all have the same number of patterns
+okGroup [] = True
+okGroup (e:es) = n_pats > 0 && and [length (eqnPats e) == n_pats | e <- es]
+ where
+ n_pats = length (eqnPats e)
+
+-- Half-baked print
+pprGroup es = vcat (map pprEqnInfo es)
+pprEqnInfo e = ppr (eqnPats e)
+
+is_con :: TypecheckedPat -> Bool
+is_con (ConPatOut _ _ _ _ _) = True
+is_con _ = False
+
+is_lit :: TypecheckedPat -> Bool
+is_lit (LitPat _) = True
+is_lit (NPatOut _ _ _) = True
+is_lit _ = False
+
+is_npat :: TypecheckedPat -> Bool
+is_npat (NPatOut _ _ _) = True
+is_npat _ = False
+
+is_nplusk :: TypecheckedPat -> Bool
+is_nplusk (NPlusKPatOut _ _ _ _) = True
+is_nplusk _ = False
+
+is_var :: TypecheckedPat -> Bool
+is_var (WildPat _) = True
+is_var _ = False
+
+is_var_con :: DataCon -> TypecheckedPat -> Bool
+is_var_con con (WildPat _) = True
+is_var_con con (ConPatOut id _ _ _ _) | id == con = True
+is_var_con con _ = False
+
+is_var_lit :: HsLit -> TypecheckedPat -> Bool
+is_var_lit lit (WildPat _) = True
+is_var_lit lit (LitPat lit') | lit == lit' = True
+is_var_lit lit (NPatOut lit' _ _) | lit == lit' = True
+is_var_lit lit _ = False
\end{code}
The difference beteewn @make_con@ and @make_whole_con@ is that
\begin{code}
isInfixCon con = isDataSymOcc (getOccName con)
-is_nil (ConPatIn con []) = con == getName nilDataCon
-is_nil _ = False
+is_nil (ConPatIn con (PrefixCon [])) = con == getName nilDataCon
+is_nil _ = False
-is_list (ListPatIn _) = True
+is_list (ListPat _ _) = True
is_list _ = False
return_list id q = id == consDataCon && (is_nil q || is_list q)
-make_list p q | is_nil q = ListPatIn [p]
-make_list p (ListPatIn ps) = ListPatIn (p:ps)
-make_list _ _ = panic "Check.make_list: Invalid argument"
+make_list p q | is_nil q = ListPat [p] placeHolderType
+make_list p (ListPat ps ty) = ListPat (p:ps) ty
+make_list _ _ = panic "Check.make_list: Invalid argument"
make_con :: TypecheckedPat -> ExhaustivePat -> ExhaustivePat
-make_con (ConPat id _ _ _ _) (p:q:ps, constraints)
+make_con (ConPatOut 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 = getName id
- fixity = panic "Check.make_con: Guessing fixity"
+ | isInfixCon id = (ConPatIn (getName id) (InfixCon p q) : ps, constraints)
-make_con (ConPat id _ _ _ pats) (ps, constraints)
- | isTupleTyCon tc = (TuplePatIn pats_con (tupleTyConBoxity tc) : rest_pats, constraints)
- | otherwise = (ConPatIn name pats_con : rest_pats, constraints)
- where name = getName id
- (pats_con, rest_pats) = splitAtList pats ps
- tc = dataConTyCon id
+make_con (ConPatOut id (PrefixCon pats) _ _ _) (ps, constraints)
+ | isTupleTyCon tc = (TuplePat pats_con (tupleTyConBoxity tc) : rest_pats, constraints)
+ | isPArrFakeCon id = (PArrPat pats_con placeHolderType : rest_pats, constraints)
+ | otherwise = (ConPatIn name (PrefixCon pats_con) : rest_pats, constraints)
+ where
+ name = getName id
+ (pats_con, rest_pats) = splitAtList pats ps
+ tc = dataConTyCon id
-- reconstruct parallel array pattern
--
-- * don't check for the type only; we need to make sure that we are really
-- dealing with one of the fake constructors and not with the real
-- representation
---
-make_con (ConPat id _ _ _ pats) (ps, constraints)
- | isPArrFakeCon id = (PArrPatIn patsCon : restPats, constraints)
- | otherwise = (ConPatIn name patsCon : restPats, constraints)
- where
- name = getName id
- (patsCon, restPats) = splitAtList pats ps
- tc = dataConTyCon id
-
make_whole_con :: DataCon -> WarningPat
-make_whole_con con | isInfixCon con = ConOpPatIn new_wild_pat name fixity new_wild_pat
- | otherwise = ConPatIn name pats
+make_whole_con con | isInfixCon con = ConPatIn name (InfixCon new_wild_pat new_wild_pat)
+ | otherwise = ConPatIn name (PrefixCon pats)
where
- fixity = panic "Check.make_whole_con: Guessing fixity"
name = getName con
- arity = dataConSourceArity con
- pats = replicate arity new_wild_pat
-
+ pats = [new_wild_pat | t <- dataConOrigArgTys con]
new_wild_pat :: WarningPat
-new_wild_pat = WildPatIn
+new_wild_pat = WildPat placeHolderType
\end{code}
This equation makes the same thing as @tidy@ in @Match.lhs@, the
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 (SigPat p ty fn) = simplify_pat p -- I'm not sure this is right
+simplify_pat (ParPat p) = simplify_pat p
+simplify_pat (LazyPat p) = simplify_pat p
+simplify_pat (AsPat id p) = simplify_pat p
+simplify_pat (SigPatOut p ty fn) = simplify_pat p -- I'm not sure this is right
-simplify_pat (ConPat id ty tvs dicts ps) = ConPat id ty tvs dicts (map simplify_pat ps)
+simplify_pat (ConPatOut id ps ty tvs dicts) = ConPatOut id (simplify_con id ps) ty tvs dicts
-simplify_pat (ListPat ty ps) = foldr (\ x -> \y -> ConPat consDataCon list_ty [] [] [x, y])
- (ConPat nilDataCon list_ty [] [] [])
+simplify_pat (ListPat ps ty) = foldr (\ x y -> mkPrefixConPat consDataCon [x,y] list_ty)
+ (mkNilPat list_ty)
(map simplify_pat ps)
where list_ty = mkListTy ty
-- introduce fake parallel array constructors to be able to handle parallel
-- arrays with the existing machinery for constructor pattern
--
-simplify_pat (PArrPat ty ps)
- = ConPat (parrFakeCon arity) (mkPArrTy ty) [] [] (map simplify_pat ps)
+simplify_pat (PArrPat ps ty)
+ = ConPatOut (parrFakeCon arity)
+ (PrefixCon (map simplify_pat ps))
+ (mkPArrTy ty) [] []
where
arity = length ps
simplify_pat (TuplePat ps boxity)
- = ConPat (tupleCon boxity arity)
- (mkTupleTy boxity arity (map outPatType ps)) [] []
- (map simplify_pat ps)
+ = ConPatOut (tupleCon boxity arity)
+ (PrefixCon (map simplify_pat ps))
+ (mkTupleTy boxity arity (map hsPatType ps)) [] []
where
arity = length ps
-simplify_pat (RecPat dc ty ex_tvs dicts [])
- = ConPat dc ty ex_tvs dicts all_wild_pats
- where
- all_wild_pats = map WildPat con_arg_tys
-
- -- Identical to machinations in Match.tidy1:
- inst_tys = tcTyConAppArgs ty -- Newtype is observable
- con_arg_tys = dataConArgTys dc (inst_tys ++ mkTyVarTys ex_tvs)
-
-simplify_pat (RecPat dc ty ex_tvs dicts idps)
- = ConPat dc ty ex_tvs dicts pats
- where
- pats = map (simplify_pat.snd) all_pats
-
- -- pad out all the missing fields with WildPats.
- field_pats = map (\ f -> (getName f, WildPat (panic "simplify_pat(RecPat-2)")))
- (dataConFieldLabels dc)
- all_pats =
- foldr
- ( \ (id,p,_) acc -> insertNm (getName id) p acc)
- field_pats
- idps
-
- insertNm nm p [] = [(nm,p)]
- insertNm nm p (x@(n,_):xs)
- | nm == n = (nm,p):xs
- | otherwise = x : insertNm nm p xs
-
-simplify_pat pat@(LitPat lit lit_ty) = tidyLitPat lit pat
+simplify_pat pat@(LitPat lit) = tidyLitPat lit pat
-- unpack string patterns fully, so we can see when they overlap with
-- each other, or even explicit lists of Chars.
-simplify_pat pat@(NPat (HsString s) _ _) =
- foldr (\c pat -> ConPat consDataCon stringTy [] [] [mk_char_lit c,pat])
- (ConPat nilDataCon stringTy [] [] []) (unpackIntFS s)
+simplify_pat pat@(NPatOut (HsString s) _ _) =
+ foldr (\c pat -> ConPatOut consDataCon (PrefixCon [mk_char_lit c,pat]) stringTy [] [])
+ (ConPatOut nilDataCon (PrefixCon []) stringTy [] []) (unpackIntFS s)
where
- mk_char_lit c = ConPat charDataCon charTy [] []
- [LitPat (HsCharPrim c) charPrimTy]
+ mk_char_lit c = ConPatOut charDataCon (PrefixCon [LitPat (HsCharPrim c)])
+ charTy [] []
-simplify_pat pat@(NPat lit lit_ty hsexpr) = tidyNPat lit lit_ty pat
+simplify_pat pat@(NPatOut lit lit_ty hsexpr) = tidyNPat lit lit_ty pat
-simplify_pat (NPlusKPat id hslit ty hsexpr1 hsexpr2) =
- WildPat ty
- where ty = panic "Check.simplify_pat: Gessing ty"
+simplify_pat (NPlusKPatOut id hslit hsexpr1 hsexpr2)
+ = WildPat (idType id)
-simplify_pat (DictPat dicts methods) =
- case num_of_d_and_ms of
+simplify_pat (DictPat dicts methods)
+ = case num_of_d_and_ms of
0 -> simplify_pat (TuplePat [] Boxed)
1 -> simplify_pat (head dict_and_method_pats)
_ -> simplify_pat (TuplePat dict_and_method_pats Boxed)
where
num_of_d_and_ms = length dicts + length methods
dict_and_method_pats = map VarPat (dicts ++ methods)
+
+-----------------
+simplify_con con (PrefixCon ps) = PrefixCon (map simplify_pat ps)
+simplify_con con (InfixCon p1 p2) = PrefixCon [simplify_pat p1, simplify_pat p2]
+simplify_con con (RecCon fs)
+ | null fs = PrefixCon [wild_pat | t <- dataConOrigArgTys con]
+ -- Special case for null patterns; maybe not a record at all
+ | otherwise = PrefixCon (map (simplify_pat.snd) all_pats)
+ where
+ -- pad out all the missing fields with WildPats.
+ field_pats = map (\ f -> (getName f, wild_pat))
+ (dataConFieldLabels con)
+ all_pats = foldr (\ (id,p) acc -> insertNm (getName id) p acc)
+ field_pats fs
+
+ insertNm nm p [] = [(nm,p)]
+ insertNm nm p (x@(n,_):xs)
+ | nm == n = (nm,p):xs
+ | otherwise = x : insertNm nm p xs
+
+ wild_pat = WildPat (panic "Check.simplify_con")
\end{code}
\section[Desugar]{@deSugar@: the main function}
\begin{code}
-module Desugar ( deSugar, deSugarExpr,
- deSugarCore ) where
+module Desugar ( deSugar, deSugarExpr ) where
#include "HsVersions.h"
-import CmdLineOpts ( DynFlags, DynFlag(..), dopt, opt_SccProfilingOn )
-import HscTypes ( ModDetails(..), TypeEnv )
+import CmdLineOpts ( DynFlag(..), dopt, opt_SccProfilingOn )
+import HscTypes ( ModGuts(..), ModGuts, HscEnv(..), ExternalPackageState(..),
+ PersistentCompilerState(..),
+ lookupType )
import HsSyn ( MonoBinds, RuleDecl(..), RuleBndr(..),
HsExpr(..), HsBinds(..), MonoBinds(..) )
-import TcHsSyn ( TypecheckedRuleDecl, TypecheckedHsExpr,
- TypecheckedCoreBind )
-import TcModule ( TcResults(..) )
+import TcHsSyn ( TypecheckedRuleDecl, TypecheckedHsExpr )
+import TcRnTypes ( TcGblEnv(..), ImportAvails(imp_mods) )
+import MkIface ( mkUsageInfo )
import Id ( Id )
import CoreSyn
import PprCore ( pprIdRules, pprCoreExpr )
import DsForeign ( dsForeigns )
import DsExpr () -- Forces DsExpr to be compiled; DsBinds only
-- depends on DsExpr.hi-boot.
-import Module ( Module )
+import Module ( Module, moduleEnvElts )
import Id ( Id )
import NameEnv ( lookupNameEnv )
import VarEnv
import VarSet
import Bag ( isEmptyBag )
import CoreLint ( showPass, endPass )
-import ErrUtils ( doIfSet, dumpIfSet_dyn, pprBagOfWarnings )
+import ErrUtils ( doIfSet, dumpIfSet_dyn, pprBagOfWarnings, addShortWarnLocLine )
import Outputable
import UniqSupply ( mkSplitUniqSupply )
-import HscTypes ( HomeSymbolTable, PersistentCompilerState(..), TyThing(..), lookupType, )
import FastString
+import DATA_IOREF ( readIORef )
\end{code}
%************************************************************************
%* *
%************************************************************************
-The only trick here is to get the @DsMonad@ stuff off to a good
-start.
-
\begin{code}
-deSugar :: DynFlags
- -> PersistentCompilerState -> HomeSymbolTable
- -> Module -> PrintUnqualified
- -> TcResults
- -> IO (ModDetails, (SDoc, SDoc, [FastString], [CoreBndr]))
-
-deSugar dflags pcs hst mod_name unqual
- (TcResults {tc_env = type_env,
- tc_binds = all_binds,
- tc_insts = insts,
- tc_rules = rules,
- tc_fords = fo_decls})
+deSugar :: HscEnv -> PersistentCompilerState
+ -> TcGblEnv -> IO ModGuts
+
+deSugar hsc_env pcs
+ (TcGblEnv { tcg_mod = mod,
+ tcg_type_env = type_env,
+ tcg_usages = usage_var,
+ tcg_imports = imports,
+ tcg_exports = exports,
+ tcg_rdr_env = rdr_env,
+ tcg_fix_env = fix_env,
+ tcg_deprecs = deprecs,
+ tcg_insts = insts,
+ tcg_binds = binds,
+ tcg_fords = fords,
+ tcg_rules = rules })
= do { showPass dflags "Desugar"
; us <- mkSplitUniqSupply 'd'
+ ; usages <- readIORef usage_var
-- Do desugaring
- ; let (ds_result, ds_warns) = initDs dflags us lookup mod_name
- (dsProgram mod_name all_binds rules fo_decls)
-
- (ds_binds, ds_rules, foreign_stuff) = ds_result
-
- mod_details = ModDetails { md_types = type_env,
- md_insts = insts,
- md_rules = ds_rules,
- md_binds = ds_binds }
+ ; let ((ds_binds, ds_rules, ds_fords), ds_warns)
+ = initDs dflags us lookup mod
+ (dsProgram binds rules fords)
+
+ warn_doc = pprBagOfWarnings (mapBag mk_warn ds_warns))
-- Display any warnings
; doIfSet (not (isEmptyBag ds_warns))
- (printErrs unqual (pprBagOfWarnings ds_warns))
+ (printErrs warn_doc)
-- Lint result if necessary
; endPass dflags "Desugar" Opt_D_dump_ds ds_binds
-- Dump output
; doIfSet (dopt Opt_D_dump_ds dflags)
- (printDump (ppr_ds_rules ds_rules))
-
- ; return (mod_details, foreign_stuff)
+ (printDump (ppr_ds_rules ds_rules))
+
+ ; let
+ mod_guts = ModGuts {
+ mg_module = mod,
+ mg_exports = exports,
+ mg_usages = mkUsageInfo hsc_env eps imports usages,
+ mg_dir_imps = [m | (m,_) <- moduleEnvElts (imp_mods imports)],
+ mg_rdr_env = rdr_env,
+ mg_fix_env = fix_env,
+ mg_deprecs = deprecs,
+ mg_types = type_env,
+ mg_insts = insts,
+ mg_rules = ds_rules,
+ mg_binds = ds_binds,
+ mg_foreign = ds_fords }
+
+ ; return mod_guts
}
where
+ dflags = hsc_dflags hsc_env
+ print_unqual = unQualInScope rdr_env
+
+ -- Desugarer warnings are SDocs; here we
+ -- add the info about whether or not to print unqualified
+ mk_warn (loc,sdoc) = (loc, addShortWarnLocLine loc print_unqual sdoc)
+
-- The lookup function passed to initDs is used for well-known Ids,
-- such as fold, build, cons etc, so the chances are
-- it'll be found in the package symbol table. That's
-- why we don't merge all these tables
- pte = pcs_PTE pcs
- lookup n = case lookupType hst pte n of {
- Just (AnId v) -> v ;
+ eps = pcs_EPS pcs
+ pte = eps_PTE eps
+ hpt = hsc_HPT hsc_env
+ lookup n = case lookupType hpt pte n of {
+ Just v -> v ;
other ->
case lookupNameEnv type_env n of
- Just (AnId v) -> v ;
+ Just v -> v ;
other -> pprPanic "Desugar: lookup:" (ppr n)
}
-deSugarExpr :: DynFlags
- -> PersistentCompilerState -> HomeSymbolTable
+deSugarExpr :: HscEnv
+ -> PersistentCompilerState
-> Module -> PrintUnqualified
-> TypecheckedHsExpr
-> IO CoreExpr
-deSugarExpr dflags pcs hst mod_name unqual tc_expr
+deSugarExpr hsc_env pcs mod_name unqual tc_expr
= do { showPass dflags "Desugar"
; us <- mkSplitUniqSupply 'd'
-- Display any warnings
; doIfSet (not (isEmptyBag ds_warns))
- (printErrs unqual (pprBagOfWarnings ds_warns))
+ (printErrs (pprBagOfWarnings ds_warns))
-- Dump output
; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr core_expr)
; return core_expr
}
where
- pte = pcs_PTE pcs
- lookup n = case lookupType hst pte n of
- Just (AnId v) -> v
- other -> pprPanic "Desugar: lookup:" (ppr n)
-
-dsProgram mod_name all_binds rules fo_decls
+ dflags = hsc_dflags hsc_env
+ hpt = hsc_HPT hsc_env
+ pte = eps_PTE (pcs_EPS pcs)
+ lookup n = case lookupType hpt pte n of
+ Just v -> v
+ other -> pprPanic "Desugar: lookup:" (ppr n)
+
+dsProgram all_binds rules fo_decls
= dsMonoBinds auto_scc all_binds [] `thenDs` \ core_prs ->
- dsForeigns mod_name fo_decls `thenDs` \ (fe_binders, foreign_binds, h_code, c_code, headers) ->
+ dsForeigns fo_decls `thenDs` \ (ds_fords, foreign_binds) ->
let
ds_binds = [Rec (foreign_binds ++ core_prs)]
-- Notice that we put the whole lot in a big Rec, even the foreign binds
local_binders = mkVarSet (bindersOfBinds ds_binds)
in
- mapDs (dsRule local_binders) rules `thenDs` \ rules' ->
- returnDs (ds_binds, rules', (h_code, c_code, headers, fe_binders))
+ mapDs (dsRule local_binders) rules `thenDs` \ ds_rules ->
+ returnDs (ds_binds, ds_rules, ds_fords)
where
auto_scc | opt_SccProfilingOn = TopLevel
| otherwise = NoSccs
pprIdRules rules
\end{code}
-Simplest thing in the world, desugaring External Core:
-
-\begin{code}
-deSugarCore :: (TypeEnv, [TypecheckedCoreBind], [TypecheckedRuleDecl])
- -> IO (ModDetails, (SDoc, SDoc, [FastString], [CoreBndr]))
-deSugarCore (type_env, pairs, rules)
- = return (mod_details, no_foreign_stuff)
- where
- mod_details = ModDetails { md_types = type_env
- , md_insts = []
- , md_rules = ds_rules
- , md_binds = ds_binds }
- ds_binds = [Rec pairs]
- ds_rules = [(fun,rule) | IfaceRuleOut fun rule <- rules]
-
- no_foreign_stuff = (empty,empty,[],[])
-\end{code}
%************************************************************************
import {-# SOURCE #-} DsExpr( dsExpr )
+import DsMonad
+import DsGRHSs ( dsGuarded )
+import DsUtils
import HsSyn -- lots of things
import CoreSyn -- lots of things
import CoreUtils ( exprType, mkInlineMe, mkSCC )
import TcHsSyn ( TypecheckedMonoBinds )
-import DsMonad
-import DsGRHSs ( dsGuarded )
-import DsUtils
import Match ( matchWrapper )
import CmdLineOpts ( opt_AutoSccsOnAllToplevs, opt_AutoSccsOnExportedToplevs )
\section[DsExpr]{Matching expressions (Exprs)}
\begin{code}
-module DsExpr ( dsExpr, dsLet ) where
+module DsExpr ( dsExpr, dsLet, dsLit ) where
#include "HsVersions.h"
+import Match ( matchWrapper, matchSimply )
+import MatchLit ( dsLit )
+import DsBinds ( dsMonoBinds, AutoScc(..) )
+import DsGRHSs ( dsGuarded )
+import DsCCall ( dsCCall )
+import DsListComp ( dsListComp, dsPArrComp )
+import DsUtils ( mkErrorAppDs, mkStringLit, mkConsExpr, mkNilExpr)
+import DsMonad
+
+#ifdef GHCI
+ -- Template Haskell stuff iff bootstrapped
+import DsMeta ( dsBracket )
+#endif
+
import HsSyn ( failureFreePat,
- HsExpr(..), OutPat(..), HsLit(..), ArithSeqInfo(..),
+ HsExpr(..), Pat(..), HsLit(..), ArithSeqInfo(..),
Stmt(..), HsMatchContext(..), HsDoContext(..),
- Match(..), HsBinds(..), MonoBinds(..),
+ Match(..), HsBinds(..), MonoBinds(..), HsConDetails(..),
mkSimpleMatch
)
-import TcHsSyn ( TypecheckedHsExpr, TypecheckedHsBinds, TypecheckedStmt, outPatType )
+import TcHsSyn ( TypecheckedHsExpr, TypecheckedHsBinds, TypecheckedStmt, hsPatType )
-- NB: The desugarer, which straddles the source and Core worlds, sometimes
-- needs to see source types (newtypes etc), and sometimes not
-- Sigh. This is a pain.
import TcType ( tcSplitAppTy, tcSplitFunTys, tcTyConAppArgs,
- isIntegerTy, tcSplitTyConApp, isUnLiftedType, Type )
+ tcSplitTyConApp, isUnLiftedType, Type )
import Type ( splitFunTys )
import CoreSyn
import CoreUtils ( exprType, mkIfThenElse, bindNonRec )
-import DsMonad
-import DsBinds ( dsMonoBinds, AutoScc(..) )
-import DsGRHSs ( dsGuarded )
-import DsCCall ( dsCCall, resultWrapper )
-import DsListComp ( dsListComp, dsPArrComp )
-import DsUtils ( mkErrorAppDs, mkStringLit, mkStringLitFS,
- mkConsExpr, mkNilExpr, mkIntegerLit
- )
-import Match ( matchWrapper, matchSimply )
-
import FieldLabel ( FieldLabel, fieldLabelTyCon )
import CostCentre ( mkUserCC )
import Id ( Id, idType, recordSelectorFieldLabel )
import PrelInfo ( rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID )
import DataCon ( DataCon, dataConWrapId, dataConFieldLabels, dataConInstOrigArgTys )
import DataCon ( isExistentialDataCon )
-import Literal ( Literal(..) )
import TyCon ( tyConDataCons )
-import TysWiredIn ( tupleCon, charDataCon, intDataCon )
+import TysWiredIn ( tupleCon )
import BasicTypes ( RecFlag(..), Boxity(..), ipNameName )
-import Maybes ( maybeToBool )
-import PrelNames ( hasKey, ratioTyConKey, toPName )
+import PrelNames ( toPName )
import Util ( zipEqual, zipWithEqual )
import Outputable
import FastString
-
-import Ratio ( numerator, denominator )
\end{code}
\begin{code}
dsExpr :: TypecheckedHsExpr -> DsM CoreExpr
+dsExpr (HsPar x) = dsExpr x
dsExpr (HsVar var) = returnDs (Var var)
dsExpr (HsIPVar ip) = returnDs (Var (ipNameName ip))
dsExpr (HsLit lit) = dsLit lit
-- here at compile time
--
dsExpr (ExplicitPArr ty xs)
- = dsLookupGlobalValue toPName `thenDs` \toP ->
+ = dsLookupGlobalId toPName `thenDs` \toP ->
dsExpr (ExplicitList ty xs) `thenDs` \coreList ->
returnDs (mkApps (Var toP) [Type ty, coreList])
-- hence TcType.tcSplitFunTys
mk_arg (arg_ty, lbl)
- = case [rhs | (sel_id,rhs,_) <- rbinds,
+ = case [rhs | (sel_id,rhs) <- rbinds,
lbl == recordSelectorFieldLabel sel_id] of
(rhs:rhss) -> ASSERT( null rhss )
dsExpr rhs
out_inst_tys = tcTyConAppArgs record_out_ty -- Newtype opaque
mk_val_arg field old_arg_id
- = case [rhs | (sel_id, rhs, _) <- rbinds,
+ = case [rhs | (sel_id, rhs) <- rbinds,
field == recordSelectorFieldLabel sel_id] of
(rhs:rest) -> ASSERT(null rest) rhs
[] -> HsVar old_arg_id
rhs = foldl HsApp (TyApp (HsVar (dataConWrapId con)) out_inst_tys)
val_args
in
- returnDs (mkSimpleMatch [ConPat con record_in_ty [] [] (map VarPat arg_ids)]
+ returnDs (mkSimpleMatch [ConPatOut con (PrefixCon (map VarPat arg_ids)) record_in_ty [] []]
rhs
record_out_ty
src_loc)
where
updated_fields :: [FieldLabel]
- updated_fields = [recordSelectorFieldLabel sel_id | (sel_id,_,_) <- rbinds]
+ updated_fields = [recordSelectorFieldLabel sel_id | (sel_id,_) <- rbinds]
-- Get the type constructor from the first field label,
-- so that we are sure it'll have all its DataCons
returnDs (foldl (\f d -> f `App` (Var d)) core_expr dicts)
\end{code}
+Here is where we desugar the Template Haskell brackets and escapes
+
+\begin{code}
+-- Template Haskell stuff
+
+#ifdef GHCI /* Only if bootstrapping */
+dsExpr (HsBracketOut x ps) = dsBracket x ps
+dsExpr (HsSplice n e) = pprPanic "dsExpr:splice" (ppr e)
+#endif
+
+\end{code}
+
+
\begin{code}
#ifdef DEBUG
= putSrcLocDs locn $
dsExpr expr `thenDs` \ expr2 ->
let
- a_ty = outPatType pat
+ a_ty = hsPatType pat
fail_expr = HsApp (TyApp (HsVar fail_id) [b_ty])
(HsLit (HsString (mkFastString msg)))
msg = "Pattern match failure in do expression, " ++ showSDoc (ppr locn)
where
do_expr expr locn = putSrcLocDs locn (dsExpr expr)
\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[DsExpr-literals]{Literals}
-%* *
-%************************************************************************
-
-We give int/float literals type @Integer@ and @Rational@, respectively.
-The typechecker will (presumably) have put \tr{from{Integer,Rational}s}
-around them.
-
-ToDo: put in range checks for when converting ``@i@''
-(or should that be in the typechecker?)
-
-For numeric literals, we try to detect there use at a standard type
-(@Int@, @Float@, etc.) are directly put in the right constructor.
-[NB: down with the @App@ conversion.]
-
-See also below where we look for @DictApps@ for \tr{plusInt}, etc.
-
-\begin{code}
-dsLit :: HsLit -> DsM CoreExpr
-dsLit (HsChar c) = returnDs (mkConApp charDataCon [mkLit (MachChar c)])
-dsLit (HsCharPrim c) = returnDs (mkLit (MachChar c))
-dsLit (HsString str) = mkStringLitFS str
-dsLit (HsStringPrim s) = returnDs (mkLit (MachStr s))
-dsLit (HsInteger i) = mkIntegerLit i
-dsLit (HsInt i) = returnDs (mkConApp intDataCon [mkIntLit i])
-dsLit (HsIntPrim i) = returnDs (mkIntLit i)
-dsLit (HsFloatPrim f) = returnDs (mkLit (MachFloat f))
-dsLit (HsDoublePrim d) = returnDs (mkLit (MachDouble d))
-dsLit (HsLitLit str ty)
- = ASSERT( maybeToBool maybe_ty )
- returnDs (wrap_fn (mkLit (MachLitLit str rep_ty)))
- where
- (maybe_ty, wrap_fn) = resultWrapper ty
- Just rep_ty = maybe_ty
-
-dsLit (HsRat r ty)
- = mkIntegerLit (numerator r) `thenDs` \ num ->
- mkIntegerLit (denominator r) `thenDs` \ denom ->
- returnDs (mkConApp ratio_data_con [Type integer_ty, num, denom])
- where
- (ratio_data_con, integer_ty)
- = case tcSplitTyConApp ty of
- (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
- (head (tyConDataCons tycon), i_ty)
-\end{code}
import CoreUtils ( exprType, mkInlineMe )
import Id ( Id, idType, idName, mkSysLocal, setInlinePragma )
import Literal ( Literal(..) )
-import Module ( Module, moduleString )
+import Module ( moduleString )
import Name ( getOccString, NamedThing(..) )
import OccName ( encodeFS )
import Type ( repType, eqType )
tcSplitForAllTys, tcSplitFunTys, tcTyConAppArgs,
)
+import HscTypes ( ForeignStubs(..) )
import ForeignCall ( ForeignCall(..), CCallSpec(..),
Safety(..), playSafe,
CExportSpec(..),
import TysPrim ( addrPrimTy )
import PrelNames ( hasKey, ioTyConKey, newStablePtrName, bindIOName )
import BasicTypes ( Activation( NeverActive ) )
-import ErrUtils ( addShortWarnLocLine )
import Outputable
import Maybe ( fromJust )
import FastString
type Binding = (Id, CoreExpr) -- No rec/nonrec structure;
-- the occurrence analyser will sort it all out
-dsForeigns :: Module
- -> [TypecheckedForeignDecl]
- -> DsM ( [Id] -- Foreign-exported binders;
- -- we have to generate code to register these
- , [Binding]
- , SDoc -- Header file prototypes for
- -- "foreign exported" functions.
- , SDoc -- C stubs to use when calling
- -- "foreign exported" functions.
- , [FastString] -- headers that need to be included
- -- into C code generated for this module
- )
-dsForeigns mod_name fos
- = foldlDs combine ([], [], empty, empty, []) fos
+dsForeigns :: [TypecheckedForeignDecl]
+ -> DsM (ForeignStubs, [Binding])
+dsForeigns fos
+ = foldlDs combine (ForeignStubs empty empty [] [], []) fos
where
- combine (acc_feb, acc_f, acc_h, acc_c, acc_header)
+ combine (ForeignStubs acc_h acc_c acc_hdrs acc_feb, acc_f)
(ForeignImport id _ spec depr loc)
- = dsFImport mod_name id spec `thenDs` \(bs, h, c, hd) ->
+ = dsFImport id spec `thenDs` \(bs, h, c, hd) ->
warnDepr depr loc `thenDs` \_ ->
- returnDs (acc_feb, bs ++ acc_f, h $$ acc_h, c $$ acc_c, hd ++ acc_header)
+ returnDs (ForeignStubs (h $$ acc_h) (c $$ acc_c) (hd ++ acc_hdrs) acc_feb,
+ bs ++ acc_f)
- combine (acc_feb, acc_f, acc_h, acc_c, acc_header)
+ combine (ForeignStubs acc_h acc_c acc_hdrs acc_feb, acc_f)
(ForeignExport id _ (CExport (CExportStatic ext_nm cconv)) depr loc)
- = dsFExport mod_name id (idType id)
+ = dsFExport id (idType id)
ext_nm cconv False `thenDs` \(h, c) ->
warnDepr depr loc `thenDs` \_ ->
- returnDs (id:acc_feb, acc_f, h $$ acc_h, c $$ acc_c, acc_header)
+ returnDs (ForeignStubs (h $$ acc_h) (c $$ acc_c) acc_hdrs (id:acc_feb),
+ acc_f)
warnDepr False _ = returnDs ()
- warnDepr True loc = dsWarn (addShortWarnLocLine loc msg)
+ warnDepr True loc = dsWarn (loc, msg)
where
msg = ptext SLIT("foreign declaration uses deprecated non-standard syntax")
\end{code}
because it exposes the boxing to the call site.
\begin{code}
-dsFImport :: Module
- -> Id
+dsFImport :: Id
-> ForeignImport
-> DsM ([Binding], SDoc, SDoc, [FastString])
-dsFImport modName id (CImport cconv safety header lib spec)
- = dsCImport modName id spec cconv safety `thenDs` \(ids, h, c) ->
+dsFImport id (CImport cconv safety header lib spec)
+ = dsCImport id spec cconv safety `thenDs` \(ids, h, c) ->
returnDs (ids, h, c, if nullFastString header then [] else [header])
-- FIXME: the `lib' field is needed for .NET ILX generation when invoking
-- routines that are external to the .NET runtime, but GHC doesn't
-- support such calls yet; if `nullFastString lib', the value was not given
-dsFImport modName id (DNImport spec)
- = dsFCall modName id (DNCall spec) `thenDs` \(ids, h, c) ->
+dsFImport id (DNImport spec)
+ = dsFCall id (DNCall spec) `thenDs` \(ids, h, c) ->
returnDs (ids, h, c, [])
-dsCImport :: Module
- -> Id
+dsCImport :: Id
-> CImportSpec
-> CCallConv
-> Safety
-> DsM ([Binding], SDoc, SDoc)
-dsCImport modName id (CLabel cid) _ _
+dsCImport id (CLabel cid) _ _
= ASSERT(fromJust resTy `eqType` addrPrimTy) -- typechecker ensures this
returnDs ([(id, rhs)], empty, empty)
where
(resTy, foRhs) = resultWrapper (idType id)
rhs = foRhs (mkLit (MachLabel cid))
-dsCImport modName id (CFunction target) cconv safety
- = dsFCall modName id (CCall (CCallSpec target cconv safety))
-dsCImport modName id CWrapper cconv _
- = dsFExportDynamic modName id cconv
+dsCImport id (CFunction target) cconv safety
+ = dsFCall id (CCall (CCallSpec target cconv safety))
+dsCImport id CWrapper cconv _
+ = dsFExportDynamic id cconv
\end{code}
%************************************************************************
\begin{code}
-dsFCall mod_Name fn_id fcall
+dsFCall fn_id fcall
= let
ty = idType fn_id
(tvs, fun_ty) = tcSplitForAllTys ty
the user-written Haskell function `@M.foo@'.
\begin{code}
-dsFExport :: Module
- -> Id -- Either the exported Id,
+dsFExport :: Id -- Either the exported Id,
-- or the foreign-export-dynamic constructor
-> Type -- The type of the thing callable from C
-> CLabelString -- The name to export to C land
, SDoc -- contents of Module_stub.c
)
-dsFExport mod_name fn_id ty ext_name cconv isDyn
+dsFExport fn_id ty ext_name cconv isDyn
=
let
(tvs,sans_foralls) = tcSplitForAllTys ty
)
`thenDs` \ (res_ty, -- t
is_IO_res_ty) -> -- Bool
- getModuleDs
- `thenDs` \ mod ->
let
(h_stub, c_stub)
= mkFExportCBits ext_name
\end{verbatim}
\begin{code}
-dsFExportDynamic :: Module
- -> Id
+dsFExportDynamic :: Id
-> CCallConv
-> DsM ([Binding], SDoc, SDoc)
-dsFExportDynamic mod_name id cconv
- = newSysLocalDs ty `thenDs` \ fe_id ->
+dsFExportDynamic id cconv
+ = newSysLocalDs ty `thenDs` \ fe_id ->
+ getModuleDs `thenDs` \ mod_name ->
let
-- hack: need to get at the name of the C stub we're about to generate.
fe_nm = mkFastString (moduleString mod_name ++ "_" ++ toCName fe_id)
in
- dsFExport mod_name id export_ty fe_nm cconv True `thenDs` \ (h_code, c_code) ->
- newSysLocalDs arg_ty `thenDs` \ cback ->
- dsLookupGlobalValue newStablePtrName `thenDs` \ newStablePtrId ->
+ dsFExport id export_ty fe_nm cconv True `thenDs` \ (h_code, c_code) ->
+ newSysLocalDs arg_ty `thenDs` \ cback ->
+ dsLookupGlobalId newStablePtrName `thenDs` \ newStablePtrId ->
let
mk_stbl_ptr_app = mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ]
in
- dsLookupGlobalValue bindIOName `thenDs` \ bindIOId ->
+ dsLookupGlobalId bindIOName `thenDs` \ bindIOId ->
newSysLocalDs (mkTyConApp stablePtrTyCon [arg_ty]) `thenDs` \ stbl_value ->
let
stbl_app cont ret_ty
import BasicTypes ( Boxity(..) )
import TyCon ( tyConName )
-import HsSyn ( OutPat(..), HsExpr(..), Stmt(..),
+import HsSyn ( Pat(..), HsExpr(..), Stmt(..),
HsMatchContext(..), HsDoContext(..),
- collectHsOutBinders )
+ collectHsBinders )
import TcHsSyn ( TypecheckedStmt, TypecheckedPat, TypecheckedHsExpr,
- outPatType )
+ hsPatType )
import CoreSyn
import DsMonad -- the monadery used in the desugarer
splitTyConApp_maybe )
import TysPrim ( alphaTyVar )
import TysWiredIn ( nilDataCon, consDataCon, unitDataConId, unitTy,
- mkListTy, mkTupleTy, intDataCon )
+ mkListTy, mkTupleTy )
import Match ( matchSimply )
import PrelNames ( trueDataConName, falseDataConName, foldrName,
buildName, replicatePName, mapPName, filterPName,
in
newSysLocalsDs [c_ty,n_ty] `thenDs` \ [c, n] ->
dfListComp c n quals `thenDs` \ result ->
- dsLookupGlobalValue buildName `thenDs` \ build_id ->
+ dsLookupGlobalId buildName `thenDs` \ build_id ->
returnDs (Var build_id `App` Type elt_ty
`App` mkLams [n_tyvar, c, n] result)
u3_ty@u1_ty = exprType core_list1 -- two names, same thing
-- u1_ty is a [alpha] type, and u2_ty = alpha
- u2_ty = outPatType pat
+ u2_ty = hsPatType pat
res_ty = exprType core_list2
h_ty = u1_ty `mkFunTy` res_ty
= dsExpr list1 `thenDs` \ core_list1 ->
-- find the required type
- let x_ty = outPatType pat
+ let x_ty = hsPatType pat
b_ty = idType n_id
in
pat core_rest (Var b) `thenDs` \ core_expr ->
-- now build the outermost foldr, and return
- dsLookupGlobalValue foldrName `thenDs` \ foldr_id ->
+ dsLookupGlobalId foldrName `thenDs` \ foldr_id ->
returnDs (
Var foldr_id `App` Type x_ty
`App` Type b_ty
-> Type -- Don't use; called with `undefined' below
-> DsM CoreExpr
dsPArrComp qs _ =
- dsLookupGlobalValue replicatePName `thenDs` \repP ->
+ dsLookupGlobalId replicatePName `thenDs` \repP ->
let unitArray = mkApps (Var repP) [Type unitTy,
- mkConApp intDataCon [mkIntLit 1],
+ mkIntExpr 1,
mkTupleExpr []]
in
dePArrComp qs (TuplePat [] Boxed) unitArray
-- <<[:e' | :]>> pa ea = mapP (\pa -> e') ea
--
dePArrComp [ResultStmt e' _] pa cea =
- dsLookupGlobalValue mapPName `thenDs` \mapP ->
+ dsLookupGlobalId mapPName `thenDs` \mapP ->
let ty = parrElemType cea
in
deLambda ty pa e' `thenDs` \(clam,
-- <<[:e' | b, qs:]>> pa ea = <<[:e' | qs:]>> pa (filterP (\pa -> b) ea)
--
dePArrComp (ExprStmt b _ _ : qs) pa cea =
- dsLookupGlobalValue filterPName `thenDs` \filterP ->
+ dsLookupGlobalId filterPName `thenDs` \filterP ->
let ty = parrElemType cea
in
deLambda ty pa b `thenDs` \(clam,_) ->
-- <<[:e' | qs:]>> (pa, p) (crossP ea ef)
--
dePArrComp (BindStmt p e _ : qs) pa cea =
- dsLookupGlobalValue falseDataConName `thenDs` \falseId ->
- dsLookupGlobalValue trueDataConName `thenDs` \trueId ->
- dsLookupGlobalValue filterPName `thenDs` \filterP ->
- dsLookupGlobalValue crossPName `thenDs` \crossP ->
+ dsLookupGlobalId falseDataConName `thenDs` \falseId ->
+ dsLookupGlobalId trueDataConName `thenDs` \trueId ->
+ dsLookupGlobalId filterPName `thenDs` \filterP ->
+ dsLookupGlobalId crossPName `thenDs` \crossP ->
dsExpr e `thenDs` \ce ->
let ty'cea = parrElemType cea
ty'ce = parrElemType ce
-- {x_1, ..., x_n} = DV (ds) -- Defined Variables
--
dePArrComp (LetStmt ds : qs) pa cea =
- dsLookupGlobalValue mapPName `thenDs` \mapP ->
- let xs = collectHsOutBinders ds
+ dsLookupGlobalId mapPName `thenDs` \mapP ->
+ let xs = collectHsBinders ds
ty'cea = parrElemType cea
in
newSysLocalDs ty'cea `thenDs` \v ->
--
dePArrComp (ParStmtOut [] : qss2) pa cea = dePArrComp qss2 pa cea
dePArrComp (ParStmtOut ((xs, qs):qss) : qss2) pa cea =
- dsLookupGlobalValue zipPName `thenDs` \zipP ->
+ dsLookupGlobalId zipPName `thenDs` \zipP ->
let pa' = TuplePat [pa, TuplePat (map VarPat xs) Boxed] Boxed
ty'cea = parrElemType cea
resStmt = ResultStmt (ExplicitTuple (map HsVar xs) Boxed) noSrcLoc
--- /dev/null
+-----------------------------------------------------------------------------
+-- The purpose of this module is to transform an HsExpr into a CoreExpr which
+-- when evaluated, returns a (Meta.Q Meta.Exp) computation analogous to the
+-- input HsExpr. We do this in the DsM monad, which supplies access to
+-- CoreExpr's of the "smart constructors" of the Meta.Exp datatype.
+-----------------------------------------------------------------------------
+
+
+module DsMeta( dsBracket ) where
+
+#include "HsVersions.h"
+
+import {-# SOURCE #-} DsExpr ( dsExpr )
+
+import DsUtils ( mkListExpr, mkStringLit, mkCoreTup,
+ mkIntExpr, mkCharExpr )
+import DsMonad
+
+import qualified Language.Haskell.THSyntax as M
+
+import HsSyn ( Pat(..), HsExpr(..), Stmt(..), HsLit(..), HsOverLit(..),
+ Match(..), GRHSs(..), GRHS(..), HsBracket(..),
+ HsDoContext(ListComp,DoExpr), ArithSeqInfo(..),
+ HsBinds(..), MonoBinds(..), HsConDetails(..),
+ HsDecl(..), TyClDecl(..), ForeignDecl(..),
+ PendingSplice,
+ placeHolderType, tyClDeclNames,
+ collectHsBinders, collectMonoBinders,
+ collectPatBinders, collectPatsBinders
+ )
+
+import Name ( Name, nameOccName, nameModule )
+import OccName ( isDataOcc, occNameUserString )
+import Module ( moduleUserString )
+import PrelNames ( intLName,charLName,
+ plitName, pvarName, ptupName, pconName,
+ ptildeName, paspatName, pwildName,
+ varName, conName, litName, appName, lamName,
+ tupName, doEName, compName,
+ listExpName, condName, letEName, caseEName,
+ infixAppName, guardedName, normalName,
+ bindStName, letStName, noBindStName,
+ fromName, fromThenName, fromToName, fromThenToName,
+ funName, valName, matchName, clauseName,
+ liftName, gensymName, bindQName,
+ matTyConName, expTyConName, clsTyConName,
+ pattTyConName, exprTyConName, declTyConName
+ )
+
+import Id ( Id )
+import NameEnv
+import Type ( Type, mkGenTyConApp )
+import TysWiredIn ( stringTy )
+import CoreSyn
+import CoreUtils ( exprType )
+import Panic ( panic )
+
+import Outputable
+import FastString ( mkFastString )
+
+-----------------------------------------------------------------------------
+dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr
+-- Returns a CoreExpr of type M.Expr
+-- The quoted thing is parameterised over Name, even though it has
+-- been type checked. We don't want all those type decorations!
+
+dsBracket (ExpBr e) splices
+ = dsExtendMetaEnv new_bit (repE e) `thenDs` \ (MkC new_e) ->
+ returnDs new_e
+ where
+ new_bit = mkNameEnv [(n, Splice e) | (n,e) <- splices]
+
+
+{- -------------- Examples --------------------
+
+ [| \x -> x |]
+====>
+ gensym (unpackString "x"#) `bindQ` \ x1::String ->
+ lam (pvar x1) (var x1)
+
+
+ [| \x -> $(f [| x |]) |]
+====>
+ gensym (unpackString "x"#) `bindQ` \ x1::String ->
+ lam (pvar x1) (f (var x1))
+-}
+
+
+-----------------------------------------------------------------------------
+-- repD
+
+{-
+repDs :: [HsDecl Name] -> DsM (Core [M.Decl])
+repDs decls
+ = do { ds' <- mapM repD ds ;
+ coreList declTyConName ds' }
+
+repD :: HsDecl Name -> DsM (Core M.Decl)
+repD (TyClD (TyData { tcdND = DataType, tcdCtxt = [],
+ tcdName = tc, tcdTyVars = tvs,
+ tcdCons = cons, tcdDerivs = mb_derivs }))
+ = do { tc1 <- localVar tc ;
+ cons1 <- mapM repCon cons ;
+ tvs1 <- repTvs tvs ;
+ cons2 <- coreList consTyConName cons1 ;
+ derivs1 <- repDerivs mb_derivs ;
+ derivs2 <- coreList stringTyConName derivs1 ;
+ repData tc1 tvs1 cons2 derivs2 }
+
+repD (TyClD (ClassD { tcdCtxt = cxt, tcdName = cls,
+ tcdTyVars = tvs, tcdFDs = [],
+ tcdSigs = sigs, tcdMeths = Just decls
+ }))
+ = do { cls1 <- localVar cls ;
+ tvs1 <- repTvs tvs ;
+ cxt1 <- repCtxt cxt ;
+ sigs1 <- repSigs sigs ;
+ repClass cxt1 cls1 tvs1 sigs1 }
+
+repD (InstD (InstDecl ty binds _ _ loc))
+ -- Ignore user pragmas for now
+ = do { cls1 <- localVar cls ;
+ cxt1 <- repCtxt cxt ;
+ tys1 <- repTys tys ;
+ binds1 <- repMonoBind binds ;
+ binds2 <- coreList declTyConName binds1 ;
+ repInst ... binds2 }
+ where
+ (tvs, cxt, cls, tys) = splitHsInstDeclTy ty
+
+-- Un-handled cases
+repD d = do { dsWarn (hang (ptext SLIT("Cannot desugar this Template Haskell declaration:"))
+ 4 (ppr d)) ;
+ return (ValD EmptyBinds) -- A sort of empty decl
+ }
+
+repTvs :: [HsTyVarBndr Name] -> DsM (Core [String])
+repTvs tvs = do { tvs1 <- mapM (localVar . hsTyVarName) tvs ;
+ coreList stringTyConName tvs1 }
+
+repCtxt :: HsContext Name -> DsM (Core M.Ctxt)
+repCtxt ctxt
+ = do {
+
+repTy :: HsType Name -> DsM (Core M.Type)
+repTy ty@(HsForAllTy _ cxt ty)
+ = pprPanic "repTy" (ppr ty)
+
+repTy (HsTyVar tv)
+ = do { tv1 <- localVar tv ; repTvar tv1 }
+
+repTy (HsAppTy f a) = do { f1 <- repTy f ; a1 <- repTy a ; repTapp f1 a2 }
+repTy (HsFunTy f a) = do { f1 <- repTy f ; a1 <- repTy a ; tcon <- repArrowTyCon ; repTapps tcon [f1,a1] }
+repTy (HsListTy t) = do { t1 <- repTy t ; list <- repListTyCon ; repTapp tcon t1 }
+
+repTy (HsTupleTy tc tys)
+ = do
+repTy (HsOpTy ty1 HsArrow ty2) = repTy (HsFunTy ty1 ty2)
+repTy (HsOpTy ty1 (HsTyOp n) = repTy ((HsTyVar n `HsAppTy` ty1) `HsAppTy` ty2)
+repTy (HsParTy t) = repTy t
+repTy (HsPredTy (HsClassP c tys)) = repTy (foldl HsApp (HsTyVar c) tys)
+
+ | HsTupleTy HsTupCon
+ [HsType name] -- Element types (length gives arity)
+
+ | HsKindSig (HsType name) -- (ty :: kind)
+ Kind -- A type with a kind signature
+-}
+
+-----------------------------------------------------------------------------
+-- Using the phantom type constructors "repConstructor" we define repE
+-- This ensures we keep the types of the CoreExpr objects we build are
+-- consistent with their real types.
+
+repEs :: [HsExpr Name] -> DsM (Core [M.Expr])
+repEs es = do { es' <- mapM repE es ;
+ coreList exprTyConName es' }
+
+repE :: HsExpr Name -> DsM (Core M.Expr)
+repE (HsVar x)
+ = do { mb_val <- dsLookupMetaEnv x
+ ; case mb_val of
+ Nothing -> do { str <- globalVar x
+ ; if constructor x then
+ repCon str
+ else
+ repVar str }
+ Just (Bound y) -> repVar (coreVar y)
+ Just (Splice e) -> do { e' <- dsExpr e
+ ; return (MkC e') } }
+
+repE (HsIPVar x) = panic "Can't represent implicit parameters"
+repE (HsLit l) = do { a <- repLiteral l; repLit a }
+repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
+
+repE (HsSplice n e)
+ = do { mb_val <- dsLookupMetaEnv n
+ ; case mb_val of
+ Just (Splice e) -> do { e' <- dsExpr e
+ ; return (MkC e') }
+ other -> pprPanic "HsSplice" (ppr n) }
+
+
+repE (HsLam m) = repLambda m
+repE (HsApp x y) = do {a <- repE x; b <- repE y; repApp a b}
+repE (NegApp x nm) = panic "No negate yet"
+repE (SectionL x y) = do { a <- repE x; b <- repE y; repSectionL a b }
+repE (SectionR x y) = do { a <- repE x; b <- repE y; repSectionR a b }
+
+repE (OpApp e1 (HsVar op) fix e2) =
+ do { arg1 <- repE e1;
+ arg2 <- repE e2;
+ mb_val <- dsLookupMetaEnv op;
+ the_op <- case mb_val of {
+ Nothing -> globalVar op ;
+ Just (Bound x) -> return (coreVar x) ;
+ other -> pprPanic "repE:OpApp" (ppr op) } ;
+ repInfixApp arg1 the_op arg2 }
+
+repE (HsCase e ms loc)
+ = do { arg <- repE e
+ ; ms2 <- mapM repMatchTup ms
+ ; repCaseE arg (nonEmptyCoreList ms2) }
+
+-- I havn't got the types here right yet
+repE (HsDo DoExpr sts _ ty loc) = do { (ss,zs) <- repSts sts;
+ e <- repDoE (nonEmptyCoreList zs);
+ combine expTyConName ss e }
+repE (HsDo ListComp sts _ ty loc) = do { (ss,zs) <- repSts sts;
+ e <- repComp (nonEmptyCoreList zs);
+ combine expTyConName ss e }
+
+repE (ArithSeqIn (From e)) = do { ds1 <- repE e; repFrom ds1 }
+repE (ArithSeqIn (FromThen e1 e2)) = do { ds1 <- repE e1; ds2 <- repE e2;
+ repFromThen ds1 ds2 }
+repE (ArithSeqIn (FromTo e1 e2)) = do { ds1 <- repE e1; ds2 <- repE e2;
+ repFromTo ds1 ds2 }
+repE (ArithSeqIn (FromThenTo e1 e2 e3)) = do { ds1 <- repE e1; ds2 <- repE e2;
+ ds3 <- repE e3; repFromThenTo ds1 ds2 ds3 }
+
+repE (HsIf x y z loc)
+ = do { a <- repE x; b <- repE y; c <- repE z; repCond a b c }
+
+repE (HsLet bs e) =
+ do { (ss,ds) <- repDecs bs
+ ; e2 <- addBinds ss (repE e)
+ ; z <- repLetE ds e2
+ ; combine expTyConName ss z }
+repE (HsWith _ _ _) = panic "No with for implicit parameters yet"
+repE (ExplicitList ty es) =
+ do { xs <- repEs es; repListExp xs }
+repE (ExplicitTuple es boxed) =
+ do { xs <- repEs es; repTup xs }
+repE (ExplicitPArr ty es) = panic "No parallel arrays yet"
+repE (RecordConOut _ _ _) = panic "No record construction yet"
+repE (RecordUpdOut _ _ _ _) = panic "No record update yet"
+repE (ExprWithTySig e ty) = panic "No expressions with type signatures yet"
+
+
+-----------------------------------------------------------------------------
+-- Building representations of auxillary structures like Match, Clause, Stmt,
+
+repMatchTup :: Match Name -> DsM (Core M.Mtch)
+repMatchTup (Match [p] ty (GRHSs guards wheres ty2)) =
+ do { ss1 <- mkGenSyms (collectPatBinders p)
+ ; addBinds ss1 $ do {
+ ; p1 <- repP p
+ ; (ss2,ds) <- repDecs wheres
+ ; addBinds ss2 $ do {
+ ; gs <- repGuards guards
+ ; match <- repMatch p1 gs ds
+ ; combine matTyConName (ss1++ss2) match }}}
+
+repClauseTup :: Match Name -> DsM (Core M.Clse)
+repClauseTup (Match ps ty (GRHSs guards wheres ty2)) =
+ do { ss1 <- mkGenSyms (collectPatsBinders ps)
+ ; addBinds ss1 $ do {
+ ps1 <- repPs ps
+ ; (ss2,ds) <- repDecs wheres
+ ; addBinds ss2 $ do {
+ gs <- repGuards guards
+ ; clause <- repClause ps1 gs ds
+ ; combine clsTyConName (ss1++ss2) clause }}}
+
+repGuards :: [GRHS Name] -> DsM (Core M.Rihs)
+repGuards [GRHS[ResultStmt e loc] loc2]
+ = do {a <- repE e; repNormal a }
+repGuards other
+ = do { zs <- mapM process other;
+ repGuarded (nonEmptyCoreList (map corePair zs)) }
+ where
+ process (GRHS [ExprStmt e1 ty loc,ResultStmt e2 _] _)
+ = do { x <- repE e1; y <- repE e2; return (x, y) }
+ process other = panic "Non Haskell 98 guarded body"
+
+
+-----------------------------------------------------------------------------
+-- Representing Stmt's is tricky, especially if bound variables
+-- shaddow each other. Consider: [| do { x <- f 1; x <- f x; g x } |]
+-- First gensym new names for every variable in any of the patterns.
+-- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))
+-- if variables didn't shaddow, the static gensym wouldn't be necessary
+-- and we could reuse the original names (x and x).
+--
+-- do { x'1 <- gensym "x"
+-- ; x'2 <- gensym "x"
+-- ; doE [ BindSt (pvar x'1) [| f 1 |]
+-- , BindSt (pvar x'2) [| f x |]
+-- , NoBindSt [| g x |]
+-- ]
+-- }
+
+-- The strategy is to translate a whole list of do-bindings by building a
+-- bigger environment, and a bigger set of meta bindings
+-- (like: x'1 <- gensym "x" ) and then combining these with the translations
+-- of the expressions within the Do
+
+-----------------------------------------------------------------------------
+-- The helper function repSts computes the translation of each sub expression
+-- and a bunch of prefix bindings denoting the dynamic renaming.
+
+repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core M.Stmt])
+repSts [ResultStmt e loc] =
+ do { a <- repE e
+ ; e1 <- repNoBindSt a
+ ; return ([], [e1]) }
+repSts (BindStmt p e loc : ss) =
+ do { e2 <- repE e
+ ; ss1 <- mkGenSyms (collectPatBinders p)
+ ; addBinds ss1 $ do {
+ ; p1 <- repP p;
+ ; (ss2,zs) <- repSts ss
+ ; z <- repBindSt p1 e2
+ ; return (ss1++ss2, z : zs) }}
+repSts (LetStmt bs : ss) =
+ do { (ss1,ds) <- repDecs bs
+ ; z <- repLetSt ds
+ ; (ss2,zs) <- addBinds ss1 (repSts ss)
+ ; return (ss1++ss2, z : zs) }
+repSts (ExprStmt e ty loc : ss) =
+ do { e2 <- repE e
+ ; z <- repNoBindSt e2
+ ; (ss2,zs) <- repSts ss
+ ; return (ss2, z : zs) }
+repSts other = panic "Exotic Stmt in meta brackets"
+
+
+
+repDecs :: HsBinds Name -> DsM ([GenSymBind], Core [M.Decl])
+repDecs decs
+ = do { let { bndrs = collectHsBinders decs } ;
+ ss <- mkGenSyms bndrs ;
+ core <- addBinds ss (rep_decs decs) ;
+ core_list <- coreList declTyConName core ;
+ return (ss, core_list) }
+
+rep_decs :: HsBinds Name -> DsM [Core M.Decl]
+rep_decs EmptyBinds = return []
+rep_decs (ThenBinds x y)
+ = do { core1 <- rep_decs x
+ ; core2 <- rep_decs y
+ ; return (core1 ++ core2) }
+rep_decs (MonoBind bs sigs _)
+ = do { core1 <- repMonoBind bs
+ ; core2 <- rep_sigs sigs
+ ; return (core1 ++ core2) }
+
+rep_sigs sigs = return [] -- Incomplete!
+
+repMonoBind :: MonoBinds Name -> DsM [Core M.Decl]
+repMonoBind EmptyMonoBinds = return []
+repMonoBind (AndMonoBinds x y) = do { x1 <- repMonoBind x;
+ y1 <- repMonoBind y;
+ return (x1 ++ y1) }
+
+-- Note GHC treats declarations of a variable (not a pattern)
+-- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match
+-- with an empty list of patterns
+repMonoBind (FunMonoBind fn infx [Match [] ty (GRHSs guards wheres ty2)] loc)
+ = do { (ss,wherecore) <- repDecs wheres
+ ; guardcore <- addBinds ss (repGuards guards)
+ ; fn' <- lookupBinder fn
+ ; p <- repPvar fn'
+ ; ans <- repVal p guardcore wherecore
+ ; return [ans] }
+
+repMonoBind (FunMonoBind fn infx ms loc)
+ = do { ms1 <- mapM repClauseTup ms
+ ; fn' <- lookupBinder fn
+ ; ans <- repFun fn' (nonEmptyCoreList ms1)
+ ; return [ans] }
+
+repMonoBind (PatMonoBind pat (GRHSs guards wheres ty2) loc)
+ = do { patcore <- repP pat
+ ; (ss,wherecore) <- repDecs wheres
+ ; guardcore <- addBinds ss (repGuards guards)
+ ; ans <- repVal patcore guardcore wherecore
+ ; return [ans] }
+
+repMonoBind (VarMonoBind v e)
+ = do { v' <- lookupBinder v
+ ; e2 <- repE e
+ ; x <- repNormal e2
+ ; patcore <- repPvar v'
+ ; empty_decls <- coreList declTyConName []
+ ; ans <- repVal patcore x empty_decls
+ ; return [ans] }
+
+-----------------------------------------------------------------------------
+-- Since everything in a MonoBind is mutually recursive we need rename all
+-- all the variables simultaneously. For example:
+-- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to
+-- do { f'1 <- gensym "f"
+-- ; g'2 <- gensym "g"
+-- ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},
+-- do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}
+-- ]}
+-- This requires collecting the bindings (f'1 <- gensym "f"), and the
+-- environment ( f |-> f'1 ) from each binding, and then unioning them
+-- together. As we do this we collect GenSymBinds's which represent the renamed
+-- variables bound by the Bindings. In order not to lose track of these
+-- representations we build a shadow datatype MB with the same structure as
+-- MonoBinds, but which has slots for the representations
+
+-----------------------------------------------------------------------------
+-- Gathering binders
+
+hsDeclsBinders :: [HsDecl Name] -> [Name]
+hsDeclsBinders ds = concat (map hsDeclBinders ds)
+
+hsDeclBinders (ValD b) = collectHsBinders b
+hsDeclBinders (TyClD d) = map fst (tyClDeclNames d)
+hsDeclBinders (ForD d) = forDeclBinders d
+hsDeclBinders other = []
+
+forDeclBinders (ForeignImport n _ _ _ _) = [n]
+forDeclBinders other = []
+
+
+-----------------------------------------------------------------------------
+-- GHC seems to allow a more general form of lambda abstraction than specified
+-- by Haskell 98. In particular it allows guarded lambda's like :
+-- (\ x | even x -> 0 | odd x -> 1) at the moment we can't represent this in
+-- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
+-- (\ p1 .. pn -> exp) by causing an error.
+
+repLambda :: Match Name -> DsM (Core M.Expr)
+repLambda (Match ps _ (GRHSs [GRHS [ResultStmt e _ ] _ ]
+ EmptyBinds _))
+ = do { let bndrs = collectPatsBinders ps ;
+ ; ss <- mkGenSyms bndrs
+ ; lam <- addBinds ss (
+ do { xs <- repPs ps; body <- repE e; repLam xs body })
+ ; combine expTyConName ss lam }
+
+repLambda z = panic "Can't represent a guarded lambda in Template Haskell"
+
+
+-----------------------------------------------------------------------------
+-- repP
+-- repP deals with patterns. It assumes that we have already
+-- walked over the pattern(s) once to collect the binders, and
+-- have extended the environment. So every pattern-bound
+-- variable should already appear in the environment.
+
+-- Process a list of patterns
+repPs :: [Pat Name] -> DsM (Core [M.Patt])
+repPs ps = do { ps' <- mapM repP ps ;
+ coreList pattTyConName ps' }
+
+repP :: Pat Name -> DsM (Core M.Patt)
+repP (WildPat _) = repPwild
+repP (LitPat l) = do { l2 <- repLiteral l; repPlit l2 }
+repP (VarPat x) = do { x' <- lookupBinder x; repPvar x' }
+repP (LazyPat p) = do { p1 <- repP p; repPtilde p1 }
+repP (AsPat x p) = do { x' <- lookupBinder x; p1 <- repP p; repPaspat x' p1 }
+repP (ParPat p) = repP p
+repP (ListPat ps _) = repListPat ps
+repP (TuplePat ps _) = do { qs <- repPs ps; repPtup qs }
+repP (ConPatIn dc details)
+ = do { con_str <- globalVar dc
+ ; case details of
+ PrefixCon ps -> do { qs <- repPs ps; repPcon con_str qs }
+ RecCon pairs -> error "No records in template haskell yet"
+ InfixCon p1 p2 -> do { qs <- repPs [p1,p2]; repPcon con_str qs }
+ }
+repP other = panic "Exotic pattern inside meta brackets"
+
+repListPat :: [Pat Name] -> DsM (Core M.Patt)
+repListPat [] = do { nil_con <- coreStringLit "[]"
+ ; nil_args <- coreList pattTyConName []
+ ; repPcon nil_con nil_args }
+repListPat (p:ps) = do { p2 <- repP p
+ ; ps2 <- repListPat ps
+ ; cons_con <- coreStringLit ":"
+ ; repPcon cons_con (nonEmptyCoreList [p2,ps2]) }
+
+
+----------------------------------------------------------
+-- Literals
+
+repLiteral :: HsLit -> DsM (Core M.Lit)
+repLiteral (HsInt i) = rep2 intLName [mkIntExpr i]
+repLiteral (HsChar c) = rep2 charLName [mkCharExpr c]
+repLiteral x = panic "trying to represent exotic literal"
+
+repOverloadedLiteral :: HsOverLit -> DsM(Core M.Lit)
+repOverloadedLiteral (HsIntegral i _) = rep2 intLName [mkIntExpr i]
+repOverloadedLiteral (HsFractional f _) = panic "Cant do fractional literals yet"
+
+
+----------------------------------------------------------
+-- The meta-environment
+
+type GenSymBind = (Name, Id) -- Gensym the string and bind it to the Id
+ -- I.e. (x, x_id) means
+ -- let x_id = gensym "x" in ...
+
+addBinds :: [GenSymBind] -> DsM a -> DsM a
+addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m
+
+lookupBinder :: Name -> DsM (Core String)
+lookupBinder n
+ = do { mb_val <- dsLookupMetaEnv n;
+ case mb_val of
+ Just (Bound id) -> return (MkC (Var id))
+ other -> pprPanic "Failed binder lookup:" (ppr n) }
+
+mkGenSym :: Name -> DsM GenSymBind
+mkGenSym nm = do { id <- newUniqueId nm stringTy; return (nm,id) }
+
+mkGenSyms :: [Name] -> DsM [GenSymBind]
+mkGenSyms ns = mapM mkGenSym ns
+
+lookupType :: Name -- Name of type constructor (e.g. M.Expr)
+ -> DsM Type -- The type
+lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
+ return (mkGenTyConApp tc []) }
+
+-- combine[ x1 <- e1, x2 <- e2 ] y
+-- --> bindQ e1 (\ x1 -> bindQ e2 (\ x2 -> y))
+
+combine :: Name -- Name of the type (consructor) for 'a'
+ -> [GenSymBind]
+ -> Core (M.Q a) -> DsM (Core (M.Q a))
+combine tc_name binds body@(MkC b)
+ = do { elt_ty <- lookupType tc_name
+ ; go elt_ty binds }
+ where
+ go elt_ty [] = return body
+ go elt_ty ((name,id) : binds)
+ = do { MkC body' <- go elt_ty binds
+ ; lit_str <- localVar name
+ ; gensym_app <- repGensym lit_str
+ ; repBindQ stringTy elt_ty
+ gensym_app (MkC (Lam id body')) }
+
+constructor :: Name -> Bool
+constructor x = isDataOcc (nameOccName x)
+
+void = placeHolderType
+
+string :: String -> HsExpr Id
+string s = HsLit (HsString (mkFastString s))
+
+
+-- %*********************************************************************
+-- %* *
+-- Constructing code
+-- %* *
+-- %*********************************************************************
+
+-----------------------------------------------------------------------------
+-- PHANTOM TYPES for consistency. In order to make sure we do this correct
+-- we invent a new datatype which uses phantom types.
+
+newtype Core a = MkC CoreExpr
+unC (MkC x) = x
+
+rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)
+rep2 n xs = do { id <- dsLookupGlobalId n
+ ; return (MkC (foldl App (Var id) xs)) }
+
+-- Then we make "repConstructors" which use the phantom types for each of the
+-- smart constructors of the Meta.Meta datatypes.
+
+
+-- %*********************************************************************
+-- %* *
+-- The 'smart constructors'
+-- %* *
+-- %*********************************************************************
+
+--------------- Patterns -----------------
+repPlit :: Core M.Lit -> DsM (Core M.Patt)
+repPlit (MkC l) = rep2 plitName [l]
+
+repPvar :: Core String -> DsM (Core M.Patt)
+repPvar (MkC s) = rep2 pvarName [s]
+
+repPtup :: Core [M.Patt] -> DsM (Core M.Patt)
+repPtup (MkC ps) = rep2 ptupName [ps]
+
+repPcon :: Core String -> Core [M.Patt] -> DsM (Core M.Patt)
+repPcon (MkC s) (MkC ps) = rep2 pconName [s, ps]
+
+repPtilde :: Core M.Patt -> DsM (Core M.Patt)
+repPtilde (MkC p) = rep2 ptildeName [p]
+
+repPaspat :: Core String -> Core M.Patt -> DsM (Core M.Patt)
+repPaspat (MkC s) (MkC p) = rep2 paspatName [s, p]
+
+repPwild :: DsM (Core M.Patt)
+repPwild = rep2 pwildName []
+
+--------------- Expressions -----------------
+repVar :: Core String -> DsM (Core M.Expr)
+repVar (MkC s) = rep2 varName [s]
+
+repCon :: Core String -> DsM (Core M.Expr)
+repCon (MkC s) = rep2 conName [s]
+
+repLit :: Core M.Lit -> DsM (Core M.Expr)
+repLit (MkC c) = rep2 litName [c]
+
+repApp :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
+repApp (MkC x) (MkC y) = rep2 appName [x,y]
+
+repLam :: Core [M.Patt] -> Core M.Expr -> DsM (Core M.Expr)
+repLam (MkC ps) (MkC e) = rep2 lamName [ps, e]
+
+repTup :: Core [M.Expr] -> DsM (Core M.Expr)
+repTup (MkC es) = rep2 tupName [es]
+
+repCond :: Core M.Expr -> Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
+repCond (MkC x) (MkC y) (MkC z) = rep2 condName [x,y,z]
+
+repLetE :: Core [M.Decl] -> Core M.Expr -> DsM (Core M.Expr)
+repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
+
+repCaseE :: Core M.Expr -> Core [M.Mtch] -> DsM( Core M.Expr)
+repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
+
+repDoE :: Core [M.Stmt] -> DsM (Core M.Expr)
+repDoE (MkC ss) = rep2 doEName [ss]
+
+repComp :: Core [M.Stmt] -> DsM (Core M.Expr)
+repComp (MkC ss) = rep2 compName [ss]
+
+repListExp :: Core [M.Expr] -> DsM (Core M.Expr)
+repListExp (MkC es) = rep2 listExpName [es]
+
+repInfixApp :: Core M.Expr -> Core String -> Core M.Expr -> DsM (Core M.Expr)
+repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
+
+repSectionL :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
+repSectionL (MkC x) (MkC y) = rep2 infixAppName [x,y]
+
+repSectionR :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
+repSectionR (MkC x) (MkC y) = rep2 infixAppName [x,y]
+
+------------ Right hand sides (guarded expressions) ----
+repGuarded :: Core [(M.Expr, M.Expr)] -> DsM (Core M.Rihs)
+repGuarded (MkC pairs) = rep2 guardedName [pairs]
+
+repNormal :: Core M.Expr -> DsM (Core M.Rihs)
+repNormal (MkC e) = rep2 normalName [e]
+
+------------- Statements -------------------
+repBindSt :: Core M.Patt -> Core M.Expr -> DsM (Core M.Stmt)
+repBindSt (MkC p) (MkC e) = rep2 bindStName [p,e]
+
+repLetSt :: Core [M.Decl] -> DsM (Core M.Stmt)
+repLetSt (MkC ds) = rep2 letStName [ds]
+
+repNoBindSt :: Core M.Expr -> DsM (Core M.Stmt)
+repNoBindSt (MkC e) = rep2 noBindStName [e]
+
+-------------- DotDot (Arithmetic sequences) -----------
+repFrom :: Core M.Expr -> DsM (Core M.Expr)
+repFrom (MkC x) = rep2 fromName [x]
+
+repFromThen :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
+repFromThen (MkC x) (MkC y) = rep2 fromThenName [x,y]
+
+repFromTo :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
+repFromTo (MkC x) (MkC y) = rep2 fromToName [x,y]
+
+repFromThenTo :: Core M.Expr -> Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
+repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToName [x,y,z]
+
+------------ Match and Clause Tuples -----------
+repMatch :: Core M.Patt -> Core M.Rihs -> Core [M.Decl] -> DsM (Core M.Mtch)
+repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]
+
+repClause :: Core [M.Patt] -> Core M.Rihs -> Core [M.Decl] -> DsM (Core M.Clse)
+repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]
+
+-------------- Dec -----------------------------
+repVal :: Core M.Patt -> Core M.Rihs -> Core [M.Decl] -> DsM (Core M.Decl)
+repVal (MkC p) (MkC b) (MkC ds) = rep2 valName [p, b, ds]
+
+repFun :: Core String -> Core [M.Clse] -> DsM (Core M.Decl)
+repFun (MkC nm) (MkC b) = rep2 funName [nm, b]
+
+repData :: Core String -> Core [String] -> Core [M.Cons] -> Core [String] -> DsM (Core M.Decl)
+repData (MkC nm) (MkC tvs) (MkC cons) (MkC derivs) = rep2 dataDName [nm, tvs, cons, derivs]
+
+repInst :: Core M.Ctxt -> Core M.Type -> Core [M.Decl]
+repInst (MkC cxt) (MkC ty) (Core ds) = rep2 instanceDName [cxt, ty, ds]
+
+repClass :: Core M.Ctxt -> Core String -> Core [String] -> Core [M.Decl] -> DsM (Core M.Decl)
+repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC ds) = rep2 classDName [cxt, cls, tvs, ds]
+
+repProto :: Core String -> Core M.Type -> DsM (Core M.Decl)
+repProto (MkC s) (MkC ty) = rep2 protoName [s, ty]
+
+------------ Types -------------------
+
+repTvar :: Core String -> DsM (Core M.Type)
+repTvar (MkC s) = rep2 tvarName [s]
+
+repTapp :: Core M.Type -> Core M.Type -> DsM (Core M.Type)
+repTapp (MkC t1) (MkC t2) = rep2 tappName [t1,t2]
+
+repTapps :: Core M.Type -> [Core M.Type] -> DsM (Core M.Type)
+repTapps f [] = return f
+repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
+
+
+repNamedTyCon :: Core String -> DsM (Core M.Type)
+repNamedTyCon (MkC s) = rep2 namedTyConName [s]
+
+repTupleTyCon :: Core Int -> DsM (Core M.Tag)
+repTupleTyCon (MkC i) = rep2 tupleTyConName [i]
+
+repArrowTyCon :: DsM (Core M.Type)
+repArrowTyCon = rep2 arrowTyConName []
+
+repListTyCon :: DsM (Core M.Tag)
+repListTyCon = rep2 listTyConName []
+
+
+--------------- Miscellaneous -------------------
+
+repLift :: Core e -> DsM (Core M.Expr)
+repLift (MkC x) = rep2 liftName [x]
+
+repGensym :: Core String -> DsM (Core (M.Q String))
+repGensym (MkC lit_str) = rep2 gensymName [lit_str]
+
+repBindQ :: Type -> Type -- a and b
+ -> Core (M.Q a) -> Core (a -> M.Q b) -> DsM (Core (M.Q b))
+repBindQ ty_a ty_b (MkC x) (MkC y)
+ = rep2 bindQName [Type ty_a, Type ty_b, x, y]
+
+------------ Lists and Tuples -------------------
+-- turn a list of patterns into a single pattern matching a list
+
+coreList :: Name -- Of the TyCon of the element type
+ -> [Core a] -> DsM (Core [a])
+coreList tc_name es
+ = do { elt_ty <- lookupType tc_name
+ ; let es' = map unC es
+ ; return (MkC (mkListExpr elt_ty es')) }
+
+nonEmptyCoreList :: [Core a] -> Core [a]
+ -- The list must be non-empty so we can get the element type
+ -- Otherwise use coreList
+nonEmptyCoreList [] = panic "coreList: empty argument"
+nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
+
+corePair :: (Core a, Core b) -> Core (a,b)
+corePair (MkC x, MkC y) = MkC (mkCoreTup [x,y])
+
+globalVar :: Name -> DsM (Core String)
+globalVar n = coreStringLit (name_mod ++ ":" ++ name_occ)
+ where
+ name_mod = moduleUserString (nameModule n)
+ name_occ = occNameUserString (nameOccName n)
+
+localVar :: Name -> DsM (Core String)
+localVar n = coreStringLit (occNameUserString (nameOccName n))
+
+coreStringLit :: String -> DsM (Core String)
+coreStringLit s = do { z <- mkStringLit s; return(MkC z) }
+
+coreVar :: Id -> Core String -- The Id has type String
+coreVar id = MkC (Var id)
\begin{code}
module DsMonad (
DsM,
- initDs, returnDs, thenDs, andDs, mapDs, listDs,
+ initDs, returnDs, thenDs, mapDs, listDs,
mapAndUnzipDs, zipWithDs, foldlDs,
uniqSMtoDsM,
newTyVarsDs, cloneTyVarsDs,
- duplicateLocalDs, newSysLocalDs, newSysLocalsDs,
+ duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId,
newFailLocalDs,
getSrcLocDs, putSrcLocDs,
getModuleDs,
getUniqueDs, getUniquesDs,
getDOptsDs,
- dsLookupGlobalValue,
+ dsLookupGlobalId, dsLookupTyCon,
+
+ DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
dsWarn,
DsWarnings,
#include "HsVersions.h"
-import TcHsSyn ( TypecheckedPat, TypecheckedMatchContext )
+import TcHsSyn ( TypecheckedPat, TypecheckedMatchContext, TypecheckedHsExpr )
+import HscTypes ( TyThing(..) )
import Bag ( emptyBag, snocBag, Bag )
+import TyCon ( TyCon )
import ErrUtils ( WarnMsg )
import Id ( mkSysLocal, setIdUnique, Id )
import Module ( Module )
import Outputable
import SrcLoc ( noSrcLoc, SrcLoc )
import Type ( Type )
-import UniqSupply ( initUs_, splitUniqSupply, uniqFromSupply, uniqsFromSupply,
+import UniqSupply ( initUs_, getUniqueUs, getUniquesUs, thenUs, returnUs,
UniqSM, UniqSupply )
-import Unique ( Unique )
-import Name ( Name )
+import Unique ( Unique )
+import Name ( Name, nameOccName )
+import NameEnv
+import OccName ( occNameFS )
import CmdLineOpts ( DynFlags )
infixr 9 `thenDs`
a @UniqueSupply@ and some annotations, which
presumably include source-file location information:
\begin{code}
-type DsM result =
- DynFlags
- -> UniqSupply
- -> (Name -> Id) -- Lookup well-known Ids
- -> SrcLoc -- to put in pattern-matching error msgs
- -> Module -- module: for SCC profiling
- -> DsWarnings
- -> (result, DsWarnings)
+newtype DsM result
+ = DsM (DsEnv -> DsWarnings -> UniqSM (result, DsWarnings))
+
+unDsM (DsM x) = x
+
+data DsEnv = DsEnv {
+ ds_dflags :: DynFlags,
+ ds_globals :: Name -> TyThing, -- Lookup well-known Ids
+ ds_meta :: DsMetaEnv, -- Template Haskell bindings
+ ds_loc :: SrcLoc, -- to put in pattern-matching error msgs
+ ds_mod :: Module -- module: for SCC profiling
+ }
+
+-- Inside [| |] brackets, the desugarer looks
+-- up variables in the DsMetaEnv
+type DsMetaEnv = NameEnv DsMetaVal
-type DsWarnings = Bag WarnMsg -- The desugarer reports matches which are
+data DsMetaVal
+ = Bound Id -- Bound by a pattern inside the [| |].
+ -- Will be dynamically alpha renamed.
+ -- The Id has type String
+
+ | Splice TypecheckedHsExpr -- These bindings are introduced by
+ -- the PendingSplices on a HsBracketOut
+
+instance Monad DsM where
+ return = returnDs
+ (>>=) = thenDs
+
+type DsWarnings = Bag DsWarning -- The desugarer reports matches which are
-- completely shadowed or incomplete patterns
+type DsWarning = (Loc, SDoc)
-{-# INLINE andDs #-}
{-# INLINE thenDs #-}
{-# INLINE returnDs #-}
initDs :: DynFlags
-> UniqSupply
- -> (Name -> Id)
+ -> (Name -> TyThing)
-> Module -- module name: for profiling
-> DsM a
-> (a, DsWarnings)
-initDs dflags init_us lookup mod action
- = action dflags init_us lookup noSrcLoc mod emptyBag
+initDs dflags init_us lookup mod (DsM action)
+ = initUs_ init_us (action ds_env emptyBag)
+ where
+ ds_env = DsEnv { ds_dflags = dflags, ds_globals = lookup,
+ ds_loc = noSrcLoc, ds_mod = mod,
+ ds_meta = emptyNameEnv }
thenDs :: DsM a -> (a -> DsM b) -> DsM b
-andDs :: (a -> a -> a) -> DsM a -> DsM a -> DsM a
-
-thenDs m1 m2 dflags us genv loc mod warns
- = case splitUniqSupply us of { (s1, s2) ->
- case (m1 dflags s1 genv loc mod warns) of { (result, warns1) ->
- m2 result dflags s2 genv loc mod warns1}}
-andDs combiner m1 m2 dflags us genv loc mod warns
- = case splitUniqSupply us of { (s1, s2) ->
- case (m1 dflags s1 genv loc mod warns) of { (result1, warns1) ->
- case (m2 dflags s2 genv loc mod warns1) of { (result2, warns2) ->
- (combiner result1 result2, warns2) }}}
+thenDs (DsM m1) m2 = DsM( \ env warns ->
+ m1 env warns `thenUs` \ (result, warns1) ->
+ unDsM (m2 result) env warns1)
returnDs :: a -> DsM a
-returnDs result dflags us genv loc mod warns = (result, warns)
+returnDs result = DsM (\ env warns -> returnUs (result, warns))
listDs :: [DsM a] -> DsM [a]
listDs [] = returnDs []
it easier to read debugging output.
\begin{code}
-newSysLocalDs, newFailLocalDs :: Type -> DsM Id
-newSysLocalDs ty dflags us genv loc mod warns
- = case uniqFromSupply us of { assigned_uniq ->
- (mkSysLocal FSLIT("ds") assigned_uniq ty, warns) }
-
-newSysLocalsDs tys = mapDs newSysLocalDs tys
-
-newFailLocalDs ty dflags us genv loc mod warns
- = case uniqFromSupply us of { assigned_uniq ->
- (mkSysLocal FSLIT("fail") assigned_uniq ty, warns) }
- -- The UserLocal bit just helps make the code a little clearer
+uniqSMtoDsM :: UniqSM a -> DsM a
+uniqSMtoDsM u_action = DsM(\ env warns ->
+ u_action `thenUs` \ res ->
+ returnUs (res, warns))
+
getUniqueDs :: DsM Unique
-getUniqueDs dflags us genv loc mod warns
- = (uniqFromSupply us, warns)
+getUniqueDs = DsM (\ env warns ->
+ getUniqueUs `thenUs` \ uniq ->
+ returnUs (uniq, warns))
getUniquesDs :: DsM [Unique]
-getUniquesDs dflags us genv loc mod warns
- = (uniqsFromSupply us, warns)
+getUniquesDs = DsM(\ env warns ->
+ getUniquesUs `thenUs` \ uniqs ->
+ returnUs (uniqs, warns))
-getDOptsDs :: DsM DynFlags
-getDOptsDs dflags us genv loc mod warns
- = (dflags, warns)
+-- Make a new Id with the same print name, but different type, and new unique
+newUniqueId :: Name -> Type -> DsM Id
+newUniqueId id ty
+ = getUniqueDs `thenDs` \ uniq ->
+ returnDs (mkSysLocal (occNameFS (nameOccName id)) uniq ty)
duplicateLocalDs :: Id -> DsM Id
-duplicateLocalDs old_local dflags us genv loc mod warns
- = case uniqFromSupply us of { assigned_uniq ->
- (setIdUnique old_local assigned_uniq, warns) }
+duplicateLocalDs old_local
+ = getUniqueDs `thenDs` \ uniq ->
+ returnDs (setIdUnique old_local uniq)
-cloneTyVarsDs :: [TyVar] -> DsM [TyVar]
-cloneTyVarsDs tyvars dflags us genv loc mod warns
- = (zipWith setTyVarUnique tyvars (uniqsFromSupply us), warns)
+newSysLocalDs, newFailLocalDs :: Type -> DsM Id
+newSysLocalDs ty
+ = getUniqueDs `thenDs` \ uniq ->
+ returnDs (mkSysLocal FSLIT("ds") uniq ty)
+
+newSysLocalsDs tys = mapDs newSysLocalDs tys
+
+newFailLocalDs ty
+ = getUniqueDs `thenDs` \ uniq ->
+ returnDs (mkSysLocal FSLIT("fail") uniq ty)
+ -- The UserLocal bit just helps make the code a little clearer
\end{code}
\begin{code}
+cloneTyVarsDs :: [TyVar] -> DsM [TyVar]
+cloneTyVarsDs tyvars
+ = getUniquesDs `thenDs` \ uniqs ->
+ returnDs (zipWith setTyVarUnique tyvars uniqs)
+
newTyVarsDs :: [TyVar] -> DsM [TyVar]
-newTyVarsDs tyvar_tmpls dflags us genv loc mod warns
- = (zipWith setTyVarUnique tyvar_tmpls (uniqsFromSupply us), warns)
+newTyVarsDs tyvar_tmpls
+ = getUniquesDs `thenDs` \ uniqs ->
+ returnDs (zipWith setTyVarUnique tyvar_tmpls uniqs)
\end{code}
We can also reach out and either set/grab location information from
the @SrcLoc@ being carried around.
+
\begin{code}
-uniqSMtoDsM :: UniqSM a -> DsM a
+getDOptsDs :: DsM DynFlags
+getDOptsDs = DsM(\ env warns -> returnUs (ds_dflags env, warns))
-uniqSMtoDsM u_action dflags us genv loc mod warns
- = (initUs_ us u_action, warns)
+getModuleDs :: DsM Module
+getModuleDs = DsM(\ env warns -> returnUs (ds_mod env, warns))
getSrcLocDs :: DsM SrcLoc
-getSrcLocDs dflags us genv loc mod warns
- = (loc, warns)
+getSrcLocDs = DsM(\ env warns -> returnUs (ds_loc env, warns))
putSrcLocDs :: SrcLoc -> DsM a -> DsM a
-putSrcLocDs new_loc expr dflags us genv old_loc mod warns
- = expr dflags us genv new_loc mod warns
-
-dsWarn :: WarnMsg -> DsM ()
-dsWarn warn dflags us genv loc mod warns = ((), warns `snocBag` warn)
+putSrcLocDs new_loc (DsM expr) = DsM(\ env warns ->
+ expr (env { ds_loc = new_loc }) warns)
+dsWarn :: DsWarning -> DsM ()
+dsWarn warn = DsM(\ env warns -> returnUs ((), warns `snocBag` warn))
\end{code}
\begin{code}
-getModuleDs :: DsM Module
-getModuleDs dflags us genv loc mod warns = (mod, warns)
+dsLookupGlobalId :: Name -> DsM Id
+dsLookupGlobalId name = DsM(\ env warns ->
+ returnUs (get_id name (ds_globals env name), warns))
+
+dsLookupTyCon :: Name -> DsM TyCon
+dsLookupTyCon name = DsM(\ env warns ->
+ returnUs (get_tycon name (ds_globals env name), warns))
+
+get_id name (AnId id) = id
+get_id name other = pprPanic "dsLookupGlobalId" (ppr name)
+
+get_tycon name (ATyCon tc) = tc
+get_tycon name other = pprPanic "dsLookupTyCon" (ppr name)
\end{code}
\begin{code}
-dsLookupGlobalValue :: Name -> DsM Id
-dsLookupGlobalValue name dflags us genv loc mod warns
- = (genv name, warns)
+dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
+dsLookupMetaEnv name = DsM(\ env warns -> returnUs (lookupNameEnv (ds_meta env) name, warns))
+
+dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
+dsExtendMetaEnv menv (DsM m)
+ = DsM (\ env warns -> m (env { ds_meta = ds_meta env `plusNameEnv` menv }) warns)
\end{code}
mkCoLetsMatchResult, mkGuardedMatchResult,
mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult,
- mkErrorAppDs, mkNilExpr, mkConsExpr,
- mkStringLit, mkStringLitFS, mkIntegerLit,
+ mkErrorAppDs, mkNilExpr, mkConsExpr, mkListExpr,
+ mkIntExpr, mkCharExpr,
+ mkStringLit, mkStringLitFS, mkIntegerExpr,
- mkSelectorBinds, mkTupleExpr, mkTupleSelector,
+ mkSelectorBinds, mkTupleExpr, mkTupleSelector, mkCoreTup,
selectMatchVar
) where
import {-# SOURCE #-} Match ( matchSimply )
import HsSyn
-import TcHsSyn ( TypecheckedPat, outPatType, collectTypedPatBinders )
+import TcHsSyn ( TypecheckedPat, hsPatType )
import CoreSyn
import DsMonad
import MkId ( mkReboxingAlt, mkNewTypeBody )
import Id ( idType, Id, mkWildId )
import Literal ( Literal(..), inIntRange, tARGET_MAX_INT )
-import TyCon ( isNewTyCon, tyConDataCons, isRecursiveTyCon )
+import TyCon ( isNewTyCon, tyConDataCons )
import DataCon ( DataCon, dataConSourceArity )
import Type ( mkFunTy, isUnLiftedType, Type, splitTyConApp )
import TcType ( tcTyConAppTyCon, isIntTy, isFloatTy, isDoubleTy )
-import TysPrim ( intPrimTy, charPrimTy, floatPrimTy, doublePrimTy )
+import TysPrim ( intPrimTy )
import TysWiredIn ( nilDataCon, consDataCon,
tupleCon,
unitDataConId, unitTy,
\begin{code}
tidyLitPat :: HsLit -> TypecheckedPat -> TypecheckedPat
-tidyLitPat (HsChar c) pat = ConPat charDataCon charTy [] [] [LitPat (HsCharPrim c) charPrimTy]
+tidyLitPat (HsChar c) pat = mkCharLitPat c
tidyLitPat lit pat = pat
tidyNPat :: HsLit -> Type -> TypecheckedPat -> TypecheckedPat
tidyNPat (HsString s) _ pat
| lengthFS s <= 1 -- Short string literals only
- = foldr (\c pat -> ConPat consDataCon stringTy [] [] [mk_char_lit c,pat])
- (ConPat nilDataCon stringTy [] [] []) (unpackIntFS s)
+ = foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c,pat] stringTy)
+ (mkNilPat stringTy) (unpackIntFS s)
-- The stringTy is the type of the whole pattern, not
-- the type to instantiate (:) or [] with!
where
- mk_char_lit c = ConPat charDataCon charTy [] [] [LitPat (HsCharPrim c) charPrimTy]
tidyNPat lit lit_ty default_pat
- | isIntTy lit_ty = ConPat intDataCon lit_ty [] [] [LitPat (mk_int lit) intPrimTy]
- | isFloatTy lit_ty = ConPat floatDataCon lit_ty [] [] [LitPat (mk_float lit) floatPrimTy]
- | isDoubleTy lit_ty = ConPat doubleDataCon lit_ty [] [] [LitPat (mk_double lit) doublePrimTy]
+ | isIntTy lit_ty = mkPrefixConPat intDataCon [LitPat (mk_int lit)] lit_ty
+ | isFloatTy lit_ty = mkPrefixConPat floatDataCon [LitPat (mk_float lit)] lit_ty
+ | isDoubleTy lit_ty = mkPrefixConPat doubleDataCon [LitPat (mk_double lit)] lit_ty
| otherwise = default_pat
where
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 other_pat = newSysLocalDs (hsPatType other_pat) -- OK, better make up one...
\end{code}
panic "DsUtils: You may not mix `[:...:]' with `PArr' patterns"
--
mk_parrCase fail =
- dsLookupGlobalValue lengthPName `thenDs` \lengthP ->
+ dsLookupGlobalId lengthPName `thenDs` \lengthP ->
unboxAlt `thenDs` \alt ->
returnDs (Case (len lengthP) (mkWildId intTy) [alt])
where
--
unboxAlt =
newSysLocalDs intPrimTy `thenDs` \l ->
- dsLookupGlobalValue indexPName `thenDs` \indexP ->
+ dsLookupGlobalId indexPName `thenDs` \indexP ->
mapDs (mkAlt indexP) match_alts `thenDs` \alts ->
returnDs (DataAlt intDataCon, [l], (Case (Var l) wild (dft : alts)))
where
lit = MachInt $ toInteger (dataConSourceArity con)
binds = [NonRec arg (indexExpr i) | (i, arg) <- zip [1..] args]
--
- indexExpr i = mkApps (Var indexP) [Type elemTy, Var var, toInt i]
- toInt i = mkConApp intDataCon [Lit $ MachInt i]
+ indexExpr i = mkApps (Var indexP) [Type elemTy, Var var, mkIntExpr i]
\end{code}
%************************************************************************
\begin{code}
-mkIntegerLit :: Integer -> DsM CoreExpr
-mkIntegerLit i
+mkCharExpr :: Int -> CoreExpr -- Returns C# c :: Int
+mkIntExpr :: Integer -> CoreExpr -- Returns I# i :: Int
+mkIntegerExpr :: Integer -> DsM CoreExpr -- Result :: Integer
+
+mkIntExpr i = mkConApp intDataCon [mkIntLit i]
+mkCharExpr c = mkConApp charDataCon [mkLit (MachChar c)]
+
+mkIntegerExpr i
| inIntRange i -- Small enough, so start from an Int
= returnDs (mkSmallIntegerLit i)
-- integral literals. This improves constant folding.
| otherwise -- Big, so start from a string
- = dsLookupGlobalValue plusIntegerName `thenDs` \ plus_id ->
- dsLookupGlobalValue timesIntegerName `thenDs` \ times_id ->
+ = dsLookupGlobalId plusIntegerName `thenDs` \ plus_id ->
+ dsLookupGlobalId timesIntegerName `thenDs` \ times_id ->
let
plus a b = Var plus_id `App` a `App` b
times a b = Var times_id `App` a `App` b
| lengthFS str == 1
= let
- the_char = mkConApp charDataCon [mkLit (MachChar (headIntFS str))]
+ the_char = mkCharExpr (headIntFS str)
in
returnDs (mkConsExpr charTy the_char (mkNilExpr charTy))
| all safeChar int_chars
- = dsLookupGlobalValue unpackCStringName `thenDs` \ unpack_id ->
+ = dsLookupGlobalId unpackCStringName `thenDs` \ unpack_id ->
returnDs (App (Var unpack_id) (Lit (MachStr str)))
| otherwise
- = dsLookupGlobalValue unpackCStringUtf8Name `thenDs` \ unpack_id ->
+ = dsLookupGlobalId unpackCStringUtf8Name `thenDs` \ unpack_id ->
returnDs (App (Var unpack_id) (Lit (MachStr (mkFastString (intsToUtf8 int_chars)))))
where
in
returnDs ( (tuple_var, tuple_expr) : map mk_tup_bind binders )
where
- binders = collectTypedPatBinders pat
+ binders = collectPatBinders pat
local_tuple = mkTupleExpr binders
tuple_ty = exprType local_tuple
where
error_expr = mkCoerce (idType bndr_var) (Var err_var)
- is_simple_pat (TuplePat ps Boxed) = all is_triv_pat ps
- is_simple_pat (ConPat _ _ _ _ ps) = all is_triv_pat ps
- is_simple_pat (VarPat _) = True
- is_simple_pat (RecPat _ _ _ _ ps) = and [is_triv_pat p | (_,p,_) <- ps]
- is_simple_pat other = False
+ is_simple_pat (TuplePat ps Boxed) = all is_triv_pat ps
+ is_simple_pat (ConPatOut _ ps _ _ _) = all is_triv_pat (hsConArgs ps)
+ is_simple_pat (VarPat _) = True
+ is_simple_pat (ParPat p) = is_simple_pat p
+ is_simple_pat other = False
is_triv_pat (VarPat v) = True
is_triv_pat (WildPat _) = True
+ is_triv_pat (ParPat p) = is_triv_pat p
is_triv_pat other = False
\end{code}
\begin{code}
mkTupleExpr :: [Id] -> CoreExpr
+{- This code has been replaced by mkCoreTup below
mkTupleExpr [] = Var unitDataConId
mkTupleExpr [id] = Var id
mkTupleExpr ids = mkConApp (tupleCon Boxed (length ids))
- (map (Type . idType) ids ++ [ Var i | i <- ids ])
+ (map (Type . idType) ids ++ [ Var i | i <-ids])
+-}
+
+mkTupleExpr ids = mkCoreTup(map Var ids)
+
+mkCoreTup :: [CoreExpr] -> CoreExpr
+mkCoreTup [] = Var unitDataConId
+mkCoreTup [c] = c
+mkCoreTup cs = mkConApp (tupleCon Boxed (length cs))
+ (map (Type . exprType) cs ++ cs)
+
\end{code}
mkConsExpr :: Type -> CoreExpr -> CoreExpr -> CoreExpr
mkConsExpr ty hd tl = mkConApp consDataCon [Type ty, hd, tl]
+
+mkListExpr :: Type -> [CoreExpr] -> CoreExpr
+mkListExpr ty xs = foldr (mkConsExpr ty) (mkNilExpr ty) xs
+
\end{code}
import {-# SOURCE #-} DsExpr( dsExpr )
import CmdLineOpts ( DynFlag(..), dopt )
import HsSyn
-import TcHsSyn ( TypecheckedPat, TypecheckedMatch, TypecheckedMatchContext, outPatType )
+import TcHsSyn ( TypecheckedPat, TypecheckedMatch, TypecheckedMatchContext, hsPatType )
import Check ( check, ExhaustivePat )
import CoreSyn
import CoreUtils ( bindNonRec )
import MatchLit ( matchLiterals )
import PrelInfo ( pAT_ERROR_ID )
import TcType ( mkTyVarTys, Type, tcTyConAppArgs, tcEqType )
-import TysWiredIn ( nilDataCon, consDataCon, mkTupleTy, mkListTy,
+import TysWiredIn ( consDataCon, mkTupleTy, mkListTy,
tupleCon, parrFakeCon, mkPArrTy )
import BasicTypes ( Boxity(..) )
import UniqSet
-import ErrUtils ( addWarnLocHdrLine, dontAddErrLoc )
+import SrcLoc ( noSrcLoc )x
import Util ( lengthExceeds, isSingleton, notNull )
import Outputable
\end{code}
| otherwise = empty
pp_context NoMatchContext msg rest_of_msg_fun
- = dontAddErrLoc (ptext SLIT("Some match(es)") <+> hang msg 8 (rest_of_msg_fun id))
+ = (noSrcLoc, ptext SLIT("Some match(es)") <+> hang msg 8 (rest_of_msg_fun id))
pp_context (DsMatchContext kind pats loc) msg rest_of_msg_fun
- = addWarnLocHdrLine loc
- (ptext SLIT("Pattern match(es)") <+> msg)
- (sep [ppr_match <> char ':', nest 4 (rest_of_msg_fun pref)])
+ = (loc, vcat [ptext SLIT("Pattern match(es)") <+> msg,
+ sep [ppr_match <> char ':', nest 4 (rest_of_msg_fun pref)]])
where
(ppr_match, pref)
= case kind of
- FunRhs fun -> (pprMatchContext kind, \ pp -> ppr fun <+> pp)
- other -> (pprMatchContext kind <+> ppr_pats pats, \ pp -> pp)
+ FunRhs fun -> (pprMatchContext kind, \ pp -> ppr fun <+> pp)
+ other -> (pprMatchContext kind, \ pp -> pp)
ppr_pats pats = sep (map ppr pats)
Float, Double, at least) are converted to unboxed form; e.g.,
\tr{(NPat (HsInt i) _ _)} is converted to:
\begin{verbatim}
-(ConPat I# _ _ [LitPat (HsIntPrim i) _])
+(ConPat I# _ _ [LitPat (HsIntPrim i)])
\end{verbatim}
\end{description}
= tidy1 v pat match_result `thenDs` \ (pat', match_result') ->
returnDs (EqnInfo n ctx (pat' : pats) match_result')
+
+tidy1 :: Id -- The Id being scrutinised
+ -> TypecheckedPat -- The pattern against which it is to be matched
+ -> MatchResult -- Current thing do do after matching
+ -> DsM (TypecheckedPat, -- Equivalent pattern
+ MatchResult) -- Augmented thing to do afterwards
+ -- The augmentation usually takes the form
+ -- of new bindings to be added to the front
+
-------------------------------------------------------
-- (pat', mr') = tidy1 v pat mr
-- tidies the *outer level only* of pat, giving pat'
-- NPlusKPat
--
-
-tidy1 :: Id -- The Id being scrutinised
- -> TypecheckedPat -- The pattern against which it is to be matched
- -> MatchResult -- Current thing do do after matching
- -> DsM (TypecheckedPat, -- Equivalent pattern
- MatchResult) -- Augmented thing to do afterwards
- -- The augmentation usually takes the form
- -- of new bindings to be added to the front
+tidy1 v (ParPat pat) match_result
+ = tidy1 v pat match_result
-- case v of { x -> mr[] }
-- = case v of { _ -> let x=v in mr[] }
-- re-express <con-something> as (ConPat ...) [directly]
-tidy1 v (RecPat data_con pat_ty ex_tvs dicts rpats) match_result
- | null rpats
- = -- Special case for C {}, which can be used for
- -- a constructor that isn't declared to have
- -- fields at all
- returnDs (ConPat data_con pat_ty ex_tvs dicts (map WildPat con_arg_tys'), match_result)
-
- | otherwise
- = returnDs (ConPat data_con pat_ty ex_tvs dicts pats, match_result)
+tidy1 v (ConPatOut con ps pat_ty ex_tvs dicts) match_result
+ = returnDs (ConPatOut con tidy_ps pat_ty ex_tvs dicts, match_result)
where
- pats = map mk_pat tagged_arg_tys
+ tidy_ps = PrefixCon (tidy_con con pat_ty ex_tvs ps)
- -- Boring stuff to find the arg-tys of the constructor
- inst_tys = tcTyConAppArgs pat_ty -- Newtypes must be opaque
- con_arg_tys' = dataConInstOrigArgTys data_con (inst_tys ++ mkTyVarTys ex_tvs)
- tagged_arg_tys = con_arg_tys' `zip` (dataConFieldLabels data_con)
-
- -- mk_pat picks a WildPat of the appropriate type for absent fields,
- -- and the specified pattern for present fields
- mk_pat (arg_ty, lbl) = case [pat | (sel_id,pat,_) <- rpats,
- recordSelectorFieldLabel sel_id == lbl
- ] of
- (pat:pats) -> ASSERT( null pats )
- pat
- [] -> WildPat arg_ty
-
-tidy1 v (ListPat ty pats) match_result
+tidy1 v (ListPat pats ty) match_result
= returnDs (list_ConPat, match_result)
where
- list_ty = mkListTy ty
- list_ConPat
- = foldr (\ x -> \y -> ConPat consDataCon list_ty [] [] [x, y])
- (ConPat nilDataCon list_ty [] [] [])
- pats
+ list_ty = mkListTy ty
+ list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] list_ty)
+ (mkNilPat list_ty)
+ pats
-- introduce fake parallel array constructors to be able to handle parallel
-- arrays with the existing machinery for constructor pattern
--
-tidy1 v (PArrPat ty pats) match_result
+tidy1 v (PArrPat pats ty) match_result
= returnDs (parrConPat, match_result)
where
arity = length pats
- parrConPat = ConPat (parrFakeCon arity) (mkPArrTy ty) [] [] pats
+ parrConPat = mkPrefixConPat (parrFakeCon arity) pats (mkPArrTy ty)
tidy1 v (TuplePat pats boxity) match_result
= returnDs (tuple_ConPat, match_result)
where
arity = length pats
- tuple_ConPat
- = ConPat (tupleCon boxity arity)
- (mkTupleTy boxity arity (map outPatType pats)) [] []
- pats
+ tuple_ConPat = mkPrefixConPat (tupleCon boxity arity) pats
+ (mkTupleTy boxity arity (map hsPatType pats))
tidy1 v (DictPat dicts methods) match_result
= case num_of_d_and_ms of
dict_and_method_pats = map VarPat (dicts ++ methods)
-- LitPats: we *might* be able to replace these w/ a simpler form
-tidy1 v pat@(LitPat lit lit_ty) match_result
+tidy1 v pat@(LitPat lit) match_result
= returnDs (tidyLitPat lit pat, match_result)
-- NPats: we *might* be able to replace these w/ a simpler form
-tidy1 v pat@(NPat lit lit_ty _) match_result
+tidy1 v pat@(NPatOut lit lit_ty _) match_result
= returnDs (tidyNPat lit lit_ty pat, match_result)
-- and everything else goes through unchanged...
tidy1 v non_interesting_pat match_result
= returnDs (non_interesting_pat, match_result)
+
+
+tidy_con data_con pat_ty ex_tvs (PrefixCon ps) = ps
+tidy_con data_con pat_ty ex_tvs (InfixCon p1 p2) = [p1,p2]
+tidy_con data_con pat_ty ex_tvs (RecCon rpats)
+ | null rpats
+ = -- Special case for C {}, which can be used for
+ -- a constructor that isn't declared to have
+ -- fields at all
+ map WildPat con_arg_tys'
+
+ | otherwise
+ = map mk_pat tagged_arg_tys
+ where
+ -- Boring stuff to find the arg-tys of the constructor
+ inst_tys = tcTyConAppArgs pat_ty -- Newtypes must be opaque
+ con_arg_tys' = dataConInstOrigArgTys data_con (inst_tys ++ mkTyVarTys ex_tvs)
+ tagged_arg_tys = con_arg_tys' `zip` (dataConFieldLabels data_con)
+
+ -- mk_pat picks a WildPat of the appropriate type for absent fields,
+ -- and the specified pattern for present fields
+ mk_pat (arg_ty, lbl) = case [pat | (sel_id,pat) <- rpats,
+ recordSelectorFieldLabel sel_id == lbl
+ ] of
+ (pat:pats) -> ASSERT( null pats )
+ pat
+ [] -> WildPat arg_ty
\end{code}
\noindent
\begin{code}
matchSigPat :: [Id] -> EquationInfo -> DsM MatchResult
-matchSigPat (var:vars) (EqnInfo n ctx (SigPat pat ty co_fn : pats) result)
+matchSigPat (var:vars) (EqnInfo n ctx (SigPatOut pat ty co_fn : pats) result)
= selectMatchVar pat `thenDs` \ new_var ->
dsExpr (HsApp co_fn (HsVar var)) `thenDs` \ rhs ->
match (new_var:vars) [EqnInfo n ctx (pat:pats) result] `thenDs` \ result' ->
import {-# SOURCE #-} Match ( match )
-import HsSyn ( OutPat(..) )
+import HsSyn ( Pat(..), HsConDetails(..) )
import DsMonad
import DsUtils
-- Sort into equivalence classes by the unique on the constructor
-- All the EqnInfos should start with a ConPat
eqn_groups = equivClassesByUniq get_uniq eqns_info
- get_uniq (EqnInfo _ _ (ConPat data_con _ _ _ _ : _) _) = getUnique data_con
+ get_uniq (EqnInfo _ _ (ConPatOut data_con _ _ _ _ : _) _) = getUnique data_con
in
-- Now make a case alternative out of each group
mapDs (match_con vars) eqn_groups `thenDs` \ alts ->
Wadler's chapter in SLPJ.
\begin{code}
-match_con vars (eqn1@(EqnInfo _ _ (ConPat data_con _ ex_tvs ex_dicts arg_pats : _) _)
+match_con vars (eqn1@(EqnInfo _ _ (ConPatOut data_con (PrefixCon arg_pats) _ ex_tvs ex_dicts : _) _)
: other_eqns)
= -- Make new vars for the con arguments; avoid new locals where possible
mapDs selectMatchVar arg_pats `thenDs` \ arg_vars ->
returnDs (data_con, ex_tvs ++ ex_dicts ++ arg_vars, match_result')
where
shift_con_pat :: EquationInfo -> EquationInfo
- shift_con_pat (EqnInfo n ctx (ConPat _ _ _ _ arg_pats : pats) match_result)
+ shift_con_pat (EqnInfo n ctx (ConPatOut _ (PrefixCon arg_pats) _ _ _ : pats) match_result)
= EqnInfo n ctx (arg_pats ++ pats) match_result
other_pats = [p | EqnInfo _ _ (p:_) _ <- other_eqns]
var_prs = concat [ (ex_tvs' `zip` ex_tvs) ++
(ex_dicts' `zip` ex_dicts)
- | ConPat _ _ ex_tvs' ex_dicts' _ <- other_pats ]
+ | ConPatOut _ _ _ ex_tvs' ex_dicts' <- other_pats ]
do_subst e = substExpr subst e
where
\section[MatchLit]{Pattern-matching literal patterns}
\begin{code}
-module MatchLit ( matchLiterals ) where
+module MatchLit ( dsLit, matchLiterals ) where
#include "HsVersions.h"
import {-# SOURCE #-} Match ( match )
import {-# SOURCE #-} DsExpr ( dsExpr )
-import HsSyn ( HsLit(..), OutPat(..), HsExpr(..) )
-import TcHsSyn ( TypecheckedPat )
-import CoreSyn ( Expr(..), Bind(..) )
-import Id ( Id )
-
import DsMonad
+import DsCCall ( resultWrapper )
import DsUtils
+import HsSyn ( HsLit(..), Pat(..), HsExpr(..) )
+import TcHsSyn ( TypecheckedPat )
+import Id ( Id )
+import CoreSyn
+import TyCon ( tyConDataCons )
+import TcType ( tcSplitTyConApp, isIntegerTy )
+
+import PrelNames ( ratioTyConKey )
+import Unique ( hasKey )
import Literal ( mkMachInt, Literal(..) )
import Maybes ( catMaybes )
import Type ( isUnLiftedType )
import Panic ( panic, assertPanic )
+import Maybe ( isJust )
+import Ratio ( numerator, denominator )
\end{code}
+%************************************************************************
+%* *
+ Desugaring literals
+ [used to be in DsExpr, but DsMeta needs it,
+ and it's nice to avoid a loop]
+%* *
+%************************************************************************
+
+We give int/float literals type @Integer@ and @Rational@, respectively.
+The typechecker will (presumably) have put \tr{from{Integer,Rational}s}
+around them.
+
+ToDo: put in range checks for when converting ``@i@''
+(or should that be in the typechecker?)
+
+For numeric literals, we try to detect there use at a standard type
+(@Int@, @Float@, etc.) are directly put in the right constructor.
+[NB: down with the @App@ conversion.]
+
+See also below where we look for @DictApps@ for \tr{plusInt}, etc.
+
+\begin{code}
+dsLit :: HsLit -> DsM CoreExpr
+dsLit (HsChar c) = returnDs (mkCharExpr c)
+dsLit (HsCharPrim c) = returnDs (mkLit (MachChar c))
+dsLit (HsString str) = mkStringLitFS str
+dsLit (HsStringPrim s) = returnDs (mkLit (MachStr s))
+dsLit (HsInteger i) = mkIntegerExpr i
+dsLit (HsInt i) = returnDs (mkIntExpr i)
+dsLit (HsIntPrim i) = returnDs (mkIntLit i)
+dsLit (HsFloatPrim f) = returnDs (mkLit (MachFloat f))
+dsLit (HsDoublePrim d) = returnDs (mkLit (MachDouble d))
+dsLit (HsLitLit str ty)
+ = ASSERT( isJust maybe_ty )
+ returnDs (wrap_fn (mkLit (MachLitLit str rep_ty)))
+ where
+ (maybe_ty, wrap_fn) = resultWrapper ty
+ Just rep_ty = maybe_ty
+
+dsLit (HsRat r ty)
+ = mkIntegerExpr (numerator r) `thenDs` \ num ->
+ mkIntegerExpr (denominator r) `thenDs` \ denom ->
+ returnDs (mkConApp ratio_data_con [Type integer_ty, num, denom])
+ where
+ (ratio_data_con, integer_ty)
+ = case tcSplitTyConApp ty of
+ (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
+ (head (tyConDataCons tycon), i_ty)
+\end{code}
+
+%************************************************************************
+%* *
+ Pattern matching on literals
+%* *
+%************************************************************************
+
\begin{code}
matchLiterals :: [Id]
-> [EquationInfo]
the alts---here we use @match_prims_used@.
\begin{code}
-matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo n ctx (LitPat literal lit_ty : ps1) _ : eqns)
+matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo n ctx (LitPat literal : ps1) _ : eqns)
= -- GENERATE THE ALTS
match_prims_used vars eqns_info `thenDs` \ prim_alts ->
where
match_prims_used _ [{-no more eqns-}] = returnDs []
- match_prims_used vars eqns_info@(EqnInfo n ctx (pat@(LitPat literal lit_ty):ps1) _ : eqns)
+ match_prims_used vars eqns_info@(EqnInfo n ctx (pat@(LitPat literal):ps1) _ : eqns)
= let
(shifted_eqns_for_this_lit, eqns_not_for_this_lit)
= partitionEqnsByLit pat eqns_info
\begin{code}
matchLiterals all_vars@(var:vars)
- eqns_info@(EqnInfo n ctx (pat@(NPat literal lit_ty eq_chk):ps1) _ : eqns)
+ eqns_info@(EqnInfo n ctx (pat@(NPatOut literal lit_ty eq_chk):ps1) _ : eqns)
= let
(shifted_eqns_for_this_lit, eqns_not_for_this_lit)
= partitionEqnsByLit pat eqns_info
\begin{code}
-matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo n ctx (pat@(NPlusKPat master_n k ty ge sub):ps1) _ : eqns)
+matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo n ctx (pat@(NPlusKPatOut master_n k ge sub):ps1) _ : eqns)
= let
(shifted_eqns_for_this_lit, eqns_not_for_this_lit)
= partitionEqnsByLit pat eqns_info
where
partition_eqn :: TypecheckedPat -> EquationInfo -> (Maybe EquationInfo, Maybe EquationInfo)
- partition_eqn (LitPat k1 _) (EqnInfo n ctx (LitPat k2 _ : remaining_pats) match_result)
+ partition_eqn (LitPat k1) (EqnInfo n ctx (LitPat k2 : remaining_pats) match_result)
| k1 == k2 = (Just (EqnInfo n ctx remaining_pats match_result), Nothing)
-- NB the pattern is stripped off the EquationInfo
- partition_eqn (NPat k1 _ _) (EqnInfo n ctx (NPat k2 _ _ : remaining_pats) match_result)
+ partition_eqn (NPatOut k1 _ _) (EqnInfo n ctx (NPatOut k2 _ _ : remaining_pats) match_result)
| k1 == k2 = (Just (EqnInfo n ctx remaining_pats match_result), Nothing)
-- NB the pattern is stripped off the EquationInfo
- partition_eqn (NPlusKPat master_n k1 _ _ _)
- (EqnInfo n ctx (NPlusKPat n' k2 _ _ _ : remaining_pats) match_result)
+ partition_eqn (NPlusKPatOut master_n k1 _ _)
+ (EqnInfo n ctx (NPlusKPatOut n' k2 _ _ : remaining_pats) match_result)
| k1 == k2 = (Just (EqnInfo n ctx remaining_pats new_match_result), Nothing)
-- NB the pattern is stripped off the EquationInfo
where
-- Default case; not for this pattern
partition_eqn master_pat eqn = (Nothing, Just eqn)
\end{code}
+
--- /dev/null
+%
+% (c) The University of Glasgow 2000
+%
+\section[ByteCodeLink]{Bytecode assembler and linker}
+
+\begin{code}
+
+{-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
+
+module ByteCodeAsm (
+ assembleBCOs, assembleBCO,
+
+ CompiledByteCode(..),
+ UnlinkedBCO(..), UnlinkedBCOExpr, nameOfUnlinkedBCO, bcosFreeNames,
+ SizedSeq, sizeSS, ssElts,
+ iNTERP_STACK_CHECK_THRESH
+ ) where
+
+#include "HsVersions.h"
+
+import ByteCodeInstr ( BCInstr(..), ProtoBCO(..) )
+import ByteCodeItbls ( ItblEnv, mkITbls )
+
+import Name ( Name, getName )
+import NameSet
+import FiniteMap ( addToFM, lookupFM, emptyFM )
+import CoreSyn
+import Literal ( Literal(..) )
+import TyCon ( TyCon )
+import PrimOp ( PrimOp )
+import PrimRep ( PrimRep(..), isFollowableRep )
+import Constants ( wORD_SIZE )
+import FastString ( FastString(..), unpackFS )
+import FiniteMap
+import Outputable
+
+import Control.Monad ( foldM )
+import Control.Monad.ST ( runST )
+
+import GHC.Word ( Word(..) )
+import Data.Array.MArray ( MArray, newArray_, readArray, writeArray )
+import Data.Array.ST ( castSTUArray )
+import Foreign.Ptr ( nullPtr )
+import Foreign ( Word16, free )
+import Data.Int ( Int64 )
+
+#if __GLASGOW_HASKELL__ >= 503
+import GHC.IOBase ( IO(..) )
+import GHC.Ptr ( Ptr(..) )
+#else
+import PrelIOBase ( IO(..) )
+import Ptr ( Ptr(..) )
+#endif
+\end{code}
+
+
+
+%************************************************************************
+%* *
+ Unlinked BCOs
+%* *
+%************************************************************************
+
+\begin{code}
+-- CompiledByteCode represents the result of byte-code
+-- compiling a bunch of functions and data types
+
+data CompiledByteCode
+ = ByteCode [UnlinkedBCO] -- Bunch of interpretable bindings
+ ItblEnv -- A mapping from DataCons to their itbls
+
+instance Outputable CompiledByteCode where
+ ppr (ByteCode bcos _) = ppr bcos
+
+
+data UnlinkedBCO
+ = UnlinkedBCO Name
+ (SizedSeq Word16) -- insns
+ (SizedSeq (Either Word FastString)) -- literals
+ -- Either literal words or a pointer to a asciiz
+ -- string, denoting a label whose *address* should
+ -- be determined at link time
+ (SizedSeq (Either Name PrimOp)) -- ptrs
+ (SizedSeq Name) -- itbl refs
+
+nameOfUnlinkedBCO (UnlinkedBCO nm _ _ _ _) = nm
+
+bcosFreeNames :: [UnlinkedBCO] -> NameSet
+-- Finds external references. Remember to remove the names
+-- defined by this group of BCOs themselves
+bcosFreeNames bcos
+ = free_names `minusNameSet` defined_names
+ where
+ defined_names = mkNameSet (map nameOfUnlinkedBCO bcos)
+ free_names = foldr (unionNameSets . bco_refs) emptyNameSet bcos
+
+ bco_refs (UnlinkedBCO _ _ _ ptrs itbls)
+ = mkNameSet [n | Left n <- ssElts ptrs] `unionNameSets`
+ mkNameSet (ssElts itbls)
+
+-- When translating expressions, we need to distinguish the root
+-- BCO for the expression
+type UnlinkedBCOExpr = (UnlinkedBCO, [UnlinkedBCO])
+
+instance Outputable UnlinkedBCO where
+ ppr (UnlinkedBCO nm insns lits ptrs itbls)
+ = sep [text "BCO", ppr nm, text "with",
+ int (sizeSS insns), text "insns",
+ int (sizeSS lits), text "lits",
+ int (sizeSS ptrs), text "ptrs",
+ int (sizeSS itbls), text "itbls"]
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{The bytecode assembler}
+%* *
+%************************************************************************
+
+The object format for bytecodes is: 16 bits for the opcode, and 16 for
+each field -- so the code can be considered a sequence of 16-bit ints.
+Each field denotes either a stack offset or number of items on the
+stack (eg SLIDE), and index into the pointer table (eg PUSH_G), an
+index into the literal table (eg PUSH_I/D/L), or a bytecode address in
+this BCO.
+
+\begin{code}
+-- Top level assembler fn.
+assembleBCOs :: [ProtoBCO Name] -> [TyCon] -> IO CompiledByteCode
+assembleBCOs proto_bcos tycons
+ = do itblenv <- mkITbls tycons
+ bcos <- mapM assembleBCO proto_bcos
+ return (ByteCode bcos itblenv)
+
+assembleBCO :: ProtoBCO Name -> IO UnlinkedBCO
+
+assembleBCO (ProtoBCO nm instrs origin malloced)
+ = let
+ -- pass 1: collect up the offsets of the local labels.
+ -- Remember that the first insn starts at offset 1 since offset 0
+ -- (eventually) will hold the total # of insns.
+ label_env = mkLabelEnv emptyFM 1 instrs
+
+ mkLabelEnv env i_offset [] = env
+ mkLabelEnv env i_offset (i:is)
+ = let new_env
+ = case i of LABEL n -> addToFM env n i_offset ; _ -> env
+ in mkLabelEnv new_env (i_offset + instrSize16s i) is
+
+ findLabel lab
+ = case lookupFM label_env lab of
+ Just bco_offset -> bco_offset
+ Nothing -> pprPanic "assembleBCO.findLabel" (int lab)
+ in
+ do -- pass 2: generate the instruction, ptr and nonptr bits
+ insns <- return emptySS :: IO (SizedSeq Word16)
+ lits <- return emptySS :: IO (SizedSeq (Either Word FastString))
+ ptrs <- return emptySS :: IO (SizedSeq (Either Name PrimOp))
+ itbls <- return emptySS :: IO (SizedSeq Name)
+ let init_asm_state = (insns,lits,ptrs,itbls)
+ (final_insns, final_lits, final_ptrs, final_itbls)
+ <- mkBits findLabel init_asm_state instrs
+
+ let ul_bco = UnlinkedBCO nm final_insns final_lits final_ptrs final_itbls
+
+ -- 8 Aug 01: Finalisers aren't safe when attached to non-primitive
+ -- objects, since they might get run too early. Disable this until
+ -- we figure out what to do.
+ -- when (notNull malloced) (addFinalizer ul_bco (mapM_ zonk malloced))
+
+ return ul_bco
+ where
+ zonk ptr = do -- putStrLn ("freeing malloc'd block at " ++ show (A# a#))
+ free ptr
+
+-- instrs nonptrs ptrs itbls
+type AsmState = (SizedSeq Word16,
+ SizedSeq (Either Word FastString),
+ SizedSeq (Either Name PrimOp),
+ SizedSeq Name)
+
+data SizedSeq a = SizedSeq !Int [a]
+emptySS = SizedSeq 0 []
+
+-- Why are these two monadic???
+addToSS (SizedSeq n r_xs) x = return (SizedSeq (n+1) (x:r_xs))
+addListToSS (SizedSeq n r_xs) xs
+ = return (SizedSeq (n + length xs) (reverse xs ++ r_xs))
+
+ssElts :: SizedSeq a -> [a]
+ssElts (SizedSeq n r_xs) = reverse r_xs
+
+sizeSS :: SizedSeq a -> Int
+sizeSS (SizedSeq n r_xs) = n
+
+-- This is where all the action is (pass 2 of the assembler)
+mkBits :: (Int -> Int) -- label finder
+ -> AsmState
+ -> [BCInstr] -- instructions (in)
+ -> IO AsmState
+
+mkBits findLabel st proto_insns
+ = foldM doInstr st proto_insns
+ where
+ doInstr :: AsmState -> BCInstr -> IO AsmState
+ doInstr st i
+ = case i of
+ SWIZZLE stkoff n -> instr3 st i_SWIZZLE stkoff n
+ ARGCHECK n -> instr2 st i_ARGCHECK n
+ STKCHECK n -> instr2 st i_STKCHECK n
+ PUSH_L o1 -> instr2 st i_PUSH_L o1
+ PUSH_LL o1 o2 -> instr3 st i_PUSH_LL o1 o2
+ PUSH_LLL o1 o2 o3 -> instr4 st i_PUSH_LLL o1 o2 o3
+ PUSH_G nm -> do (p, st2) <- ptr st nm
+ instr2 st2 i_PUSH_G p
+ PUSH_AS nm pk -> do (p, st2) <- ptr st (Left nm)
+ (np, st3) <- ctoi_itbl st2 pk
+ instr3 st3 i_PUSH_AS p np
+ PUSH_UBX (Left lit) nws
+ -> do (np, st2) <- literal st lit
+ instr3 st2 i_PUSH_UBX np nws
+ PUSH_UBX (Right aa) nws
+ -> do (np, st2) <- addr st aa
+ instr3 st2 i_PUSH_UBX np nws
+
+ PUSH_TAG tag -> instr2 st i_PUSH_TAG tag
+ SLIDE n by -> instr3 st i_SLIDE n by
+ ALLOC n -> instr2 st i_ALLOC n
+ MKAP off sz -> instr3 st i_MKAP off sz
+ UNPACK n -> instr2 st i_UNPACK n
+ UPK_TAG n m k -> instr4 st i_UPK_TAG n m k
+ PACK dcon sz -> do (itbl_no,st2) <- itbl st dcon
+ instr3 st2 i_PACK itbl_no sz
+ LABEL lab -> return st
+ TESTLT_I i l -> do (np, st2) <- int st i
+ instr3 st2 i_TESTLT_I np (findLabel l)
+ TESTEQ_I i l -> do (np, st2) <- int st i
+ instr3 st2 i_TESTEQ_I np (findLabel l)
+ TESTLT_F f l -> do (np, st2) <- float st f
+ instr3 st2 i_TESTLT_F np (findLabel l)
+ TESTEQ_F f l -> do (np, st2) <- float st f
+ instr3 st2 i_TESTEQ_F np (findLabel l)
+ TESTLT_D d l -> do (np, st2) <- double st d
+ instr3 st2 i_TESTLT_D np (findLabel l)
+ TESTEQ_D d l -> do (np, st2) <- double st d
+ instr3 st2 i_TESTEQ_D np (findLabel l)
+ TESTLT_P i l -> instr3 st i_TESTLT_P i (findLabel l)
+ TESTEQ_P i l -> instr3 st i_TESTEQ_P i (findLabel l)
+ CASEFAIL -> instr1 st i_CASEFAIL
+ JMP l -> instr2 st i_JMP (findLabel l)
+ ENTER -> instr1 st i_ENTER
+ RETURN rep -> do (itbl_no,st2) <- itoc_itbl st rep
+ instr2 st2 i_RETURN itbl_no
+ CCALL m_addr -> do (np, st2) <- addr st m_addr
+ instr2 st2 i_CCALL np
+
+ i2s :: Int -> Word16
+ i2s = fromIntegral
+
+ instr1 (st_i0,st_l0,st_p0,st_I0) i1
+ = do st_i1 <- addToSS st_i0 (i2s i1)
+ return (st_i1,st_l0,st_p0,st_I0)
+
+ instr2 (st_i0,st_l0,st_p0,st_I0) i1 i2
+ = do st_i1 <- addToSS st_i0 (i2s i1)
+ st_i2 <- addToSS st_i1 (i2s i2)
+ return (st_i2,st_l0,st_p0,st_I0)
+
+ instr3 (st_i0,st_l0,st_p0,st_I0) i1 i2 i3
+ = do st_i1 <- addToSS st_i0 (i2s i1)
+ st_i2 <- addToSS st_i1 (i2s i2)
+ st_i3 <- addToSS st_i2 (i2s i3)
+ return (st_i3,st_l0,st_p0,st_I0)
+
+ instr4 (st_i0,st_l0,st_p0,st_I0) i1 i2 i3 i4
+ = do st_i1 <- addToSS st_i0 (i2s i1)
+ st_i2 <- addToSS st_i1 (i2s i2)
+ st_i3 <- addToSS st_i2 (i2s i3)
+ st_i4 <- addToSS st_i3 (i2s i4)
+ return (st_i4,st_l0,st_p0,st_I0)
+
+ float (st_i0,st_l0,st_p0,st_I0) f
+ = do let ws = mkLitF f
+ st_l1 <- addListToSS st_l0 (map Left ws)
+ return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
+
+ double (st_i0,st_l0,st_p0,st_I0) d
+ = do let ws = mkLitD d
+ st_l1 <- addListToSS st_l0 (map Left ws)
+ return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
+
+ int (st_i0,st_l0,st_p0,st_I0) i
+ = do let ws = mkLitI i
+ st_l1 <- addListToSS st_l0 (map Left ws)
+ return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
+
+ int64 (st_i0,st_l0,st_p0,st_I0) i
+ = do let ws = mkLitI64 i
+ st_l1 <- addListToSS st_l0 (map Left ws)
+ return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
+
+ addr (st_i0,st_l0,st_p0,st_I0) a
+ = do let ws = mkLitPtr a
+ st_l1 <- addListToSS st_l0 (map Left ws)
+ return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
+
+ litlabel (st_i0,st_l0,st_p0,st_I0) fs
+ = do st_l1 <- addListToSS st_l0 [Right fs]
+ return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
+
+ ptr (st_i0,st_l0,st_p0,st_I0) p
+ = do st_p1 <- addToSS st_p0 p
+ return (sizeSS st_p0, (st_i0,st_l0,st_p1,st_I0))
+
+ itbl (st_i0,st_l0,st_p0,st_I0) dcon
+ = do st_I1 <- addToSS st_I0 (getName dcon)
+ return (sizeSS st_I0, (st_i0,st_l0,st_p0,st_I1))
+
+ literal st (MachLabel fs) = litlabel st fs
+ literal st (MachWord w) = int st (fromIntegral w)
+ literal st (MachInt j) = int st (fromIntegral j)
+ literal st (MachFloat r) = float st (fromRational r)
+ literal st (MachDouble r) = double st (fromRational r)
+ literal st (MachChar c) = int st c
+ literal st (MachInt64 ii) = int64 st (fromIntegral ii)
+ literal st (MachWord64 ii) = int64 st (fromIntegral ii)
+ literal st other = pprPanic "ByteCodeLink.literal" (ppr other)
+
+ ctoi_itbl st pk
+ = addr st ret_itbl_addr
+ where
+ ret_itbl_addr
+ = case pk of
+ WordRep -> stg_ctoi_ret_R1n_info
+ IntRep -> stg_ctoi_ret_R1n_info
+ AddrRep -> stg_ctoi_ret_R1n_info
+ CharRep -> stg_ctoi_ret_R1n_info
+ FloatRep -> stg_ctoi_ret_F1_info
+ DoubleRep -> stg_ctoi_ret_D1_info
+ VoidRep -> stg_ctoi_ret_V_info
+ other | isFollowableRep pk -> stg_ctoi_ret_R1p_info
+ -- Includes ArrayRep, ByteArrayRep, as well as
+ -- the obvious PtrRep
+ | otherwise
+ -> pprPanic "ByteCodeLink.ctoi_itbl" (ppr pk)
+
+ itoc_itbl st pk
+ = addr st ret_itbl_addr
+ where
+ ret_itbl_addr
+ = case pk of
+ CharRep -> stg_gc_unbx_r1_info
+ IntRep -> stg_gc_unbx_r1_info
+ WordRep -> stg_gc_unbx_r1_info
+ AddrRep -> stg_gc_unbx_r1_info
+ FloatRep -> stg_gc_f1_info
+ DoubleRep -> stg_gc_d1_info
+ VoidRep -> nullPtr -- Interpreter.c spots this special case
+ other | isFollowableRep pk -> stg_gc_unpt_r1_info
+ | otherwise
+ -> pprPanic "ByteCodeLink.itoc_itbl" (ppr pk)
+
+foreign label "stg_ctoi_ret_R1p_info" stg_ctoi_ret_R1p_info :: Ptr ()
+foreign label "stg_ctoi_ret_R1n_info" stg_ctoi_ret_R1n_info :: Ptr ()
+foreign label "stg_ctoi_ret_F1_info" stg_ctoi_ret_F1_info :: Ptr ()
+foreign label "stg_ctoi_ret_D1_info" stg_ctoi_ret_D1_info :: Ptr ()
+foreign label "stg_ctoi_ret_V_info" stg_ctoi_ret_V_info :: Ptr ()
+
+foreign label "stg_gc_unbx_r1_info" stg_gc_unbx_r1_info :: Ptr ()
+foreign label "stg_gc_unpt_r1_info" stg_gc_unpt_r1_info :: Ptr ()
+foreign label "stg_gc_f1_info" stg_gc_f1_info :: Ptr ()
+foreign label "stg_gc_d1_info" stg_gc_d1_info :: Ptr ()
+
+-- The size in 16-bit entities of an instruction.
+instrSize16s :: BCInstr -> Int
+instrSize16s instr
+ = case instr of
+ STKCHECK _ -> 2
+ ARGCHECK _ -> 2
+ PUSH_L _ -> 2
+ PUSH_LL _ _ -> 3
+ PUSH_LLL _ _ _ -> 4
+ PUSH_G _ -> 2
+ PUSH_AS _ _ -> 3
+ PUSH_UBX _ _ -> 3
+ PUSH_TAG _ -> 2
+ SLIDE _ _ -> 3
+ ALLOC _ -> 2
+ MKAP _ _ -> 3
+ UNPACK _ -> 2
+ UPK_TAG _ _ _ -> 4
+ PACK _ _ -> 3
+ LABEL _ -> 0 -- !!
+ TESTLT_I _ _ -> 3
+ TESTEQ_I _ _ -> 3
+ TESTLT_F _ _ -> 3
+ TESTEQ_F _ _ -> 3
+ TESTLT_D _ _ -> 3
+ TESTEQ_D _ _ -> 3
+ TESTLT_P _ _ -> 3
+ TESTEQ_P _ _ -> 3
+ JMP _ -> 2
+ CASEFAIL -> 1
+ ENTER -> 1
+ RETURN _ -> 2
+
+
+-- Make lists of host-sized words for literals, so that when the
+-- words are placed in memory at increasing addresses, the
+-- bit pattern is correct for the host's word size and endianness.
+mkLitI :: Int -> [Word]
+mkLitF :: Float -> [Word]
+mkLitD :: Double -> [Word]
+mkLitPtr :: Ptr () -> [Word]
+mkLitI64 :: Int64 -> [Word]
+
+mkLitF f
+ = runST (do
+ arr <- newArray_ ((0::Int),0)
+ writeArray arr 0 f
+ f_arr <- castSTUArray arr
+ w0 <- readArray f_arr 0
+ return [w0 :: Word]
+ )
+
+mkLitD d
+ | wORD_SIZE == 4
+ = runST (do
+ arr <- newArray_ ((0::Int),1)
+ writeArray arr 0 d
+ d_arr <- castSTUArray arr
+ w0 <- readArray d_arr 0
+ w1 <- readArray d_arr 1
+ return [w0 :: Word, w1]
+ )
+ | wORD_SIZE == 8
+ = runST (do
+ arr <- newArray_ ((0::Int),0)
+ writeArray arr 0 d
+ d_arr <- castSTUArray arr
+ w0 <- readArray d_arr 0
+ return [w0 :: Word]
+ )
+
+mkLitI64 ii
+ | wORD_SIZE == 4
+ = runST (do
+ arr <- newArray_ ((0::Int),1)
+ writeArray arr 0 ii
+ d_arr <- castSTUArray arr
+ w0 <- readArray d_arr 0
+ w1 <- readArray d_arr 1
+ return [w0 :: Word,w1]
+ )
+ | wORD_SIZE == 8
+ = runST (do
+ arr <- newArray_ ((0::Int),0)
+ writeArray arr 0 ii
+ d_arr <- castSTUArray arr
+ w0 <- readArray d_arr 0
+ return [w0 :: Word]
+ )
+
+mkLitI i
+ = runST (do
+ arr <- newArray_ ((0::Int),0)
+ writeArray arr 0 i
+ i_arr <- castSTUArray arr
+ w0 <- readArray i_arr 0
+ return [w0 :: Word]
+ )
+
+mkLitPtr a
+ = runST (do
+ arr <- newArray_ ((0::Int),0)
+ writeArray arr 0 a
+ a_arr <- castSTUArray arr
+ w0 <- readArray a_arr 0
+ return [w0 :: Word]
+ )
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Connect to actual values for bytecode opcodes}
+%* *
+%************************************************************************
+
+\begin{code}
+
+#include "Bytecodes.h"
+
+i_ARGCHECK = (bci_ARGCHECK :: Int)
+i_PUSH_L = (bci_PUSH_L :: Int)
+i_PUSH_LL = (bci_PUSH_LL :: Int)
+i_PUSH_LLL = (bci_PUSH_LLL :: Int)
+i_PUSH_G = (bci_PUSH_G :: Int)
+i_PUSH_AS = (bci_PUSH_AS :: Int)
+i_PUSH_UBX = (bci_PUSH_UBX :: Int)
+i_PUSH_TAG = (bci_PUSH_TAG :: Int)
+i_SLIDE = (bci_SLIDE :: Int)
+i_ALLOC = (bci_ALLOC :: Int)
+i_MKAP = (bci_MKAP :: Int)
+i_UNPACK = (bci_UNPACK :: Int)
+i_UPK_TAG = (bci_UPK_TAG :: Int)
+i_PACK = (bci_PACK :: Int)
+i_TESTLT_I = (bci_TESTLT_I :: Int)
+i_TESTEQ_I = (bci_TESTEQ_I :: Int)
+i_TESTLT_F = (bci_TESTLT_F :: Int)
+i_TESTEQ_F = (bci_TESTEQ_F :: Int)
+i_TESTLT_D = (bci_TESTLT_D :: Int)
+i_TESTEQ_D = (bci_TESTEQ_D :: Int)
+i_TESTLT_P = (bci_TESTLT_P :: Int)
+i_TESTEQ_P = (bci_TESTEQ_P :: Int)
+i_CASEFAIL = (bci_CASEFAIL :: Int)
+i_ENTER = (bci_ENTER :: Int)
+i_RETURN = (bci_RETURN :: Int)
+i_STKCHECK = (bci_STKCHECK :: Int)
+i_JMP = (bci_JMP :: Int)
+#ifdef bci_CCALL
+i_CCALL = (bci_CCALL :: Int)
+i_SWIZZLE = (bci_SWIZZLE :: Int)
+#else
+i_CCALL = error "Sorry pal, you need to bootstrap to use i_CCALL."
+i_SWIZZLE = error "Sorry pal, you need to bootstrap to use i_SWIZZLE."
+#endif
+
+iNTERP_STACK_CHECK_THRESH = (INTERP_STACK_CHECK_THRESH :: Int)
+\end{code}
+
import PrimRep ( PrimRep(..), getPrimRepSize, isFollowableRep )
import ForeignCall ( CCallConv(..) )
--- DON'T remove apparently unused imports here .. there is ifdeffery
--- below
-import Bits ( Bits(..), shiftR, shiftL )
+-- DON'T remove apparently unused imports here ..
+-- there is ifdeffery below
+import DATA_BITS ( Bits(..), shiftR, shiftL )
import Foreign ( newArray )
-import Data.Word ( Word8, Word32 )
-import Foreign ( Ptr, mallocBytes )
-import Debug.Trace ( trace )
+import DATA_WORD ( Word8, Word32 )
+import Foreign ( Ptr )
import System.IO.Unsafe ( unsafePerformIO )
import IO ( hPutStrLn, stderr )
+-- import Debug.Trace ( trace )
\end{code}
%************************************************************************
\section[ByteCodeGen]{Generate bytecode from Core}
\begin{code}
-module ByteCodeGen ( UnlinkedBCO, UnlinkedBCOExpr, ItblEnv, ClosureEnv, HValue,
- filterNameMap,
- byteCodeGen, coreExprToBCOs
+module ByteCodeGen ( UnlinkedBCO, UnlinkedBCOExpr,
+ byteCodeGen, coreExprToBCOs
) where
#include "HsVersions.h"
+import ByteCodeInstr ( BCInstr(..), ProtoBCO(..), nameOfProtoBCO, bciStackUse )
+import ByteCodeFFI ( taggedSizeW, untaggedSizeW, mkMarshalCode, moan64 )
+import ByteCodeAsm ( CompiledByteCode(..), UnlinkedBCO, UnlinkedBCOExpr,
+ assembleBCO, assembleBCOs, iNTERP_STACK_CHECK_THRESH )
+import ByteCodeLink ( lookupStaticPtr )
+
import Outputable
-import Name ( Name, getName )
+import Name ( Name, getName, mkSystemName )
import Id ( Id, idType, isDataConId_maybe, isPrimOpId_maybe, isFCallId,
- idPrimRep, mkSysLocal, idName, isFCallId_maybe, isPrimOpId )
+ idPrimRep, mkLocalId, isFCallId_maybe, isPrimOpId )
import ForeignCall ( ForeignCall(..), CCallTarget(..), CCallSpec(..) )
import OrdList ( OrdList, consOL, snocOL, appOL, unitOL,
nilOL, toOL, concatOL, fromOL )
import FiniteMap ( FiniteMap, addListToFM, listToFM, elemFM,
addToFM, lookupFM, fmToList )
+import HscTypes ( ModGuts(..), ModGuts, typeEnvTyCons, typeEnvClasses )
import CoreUtils ( exprType )
import CoreSyn
import PprCore ( pprCoreExpr )
import Type ( typePrimRep, isUnLiftedType, splitTyConApp_maybe, isTyVarTy )
import DataCon ( dataConTag, fIRST_TAG, dataConTyCon,
dataConWrapId, isUnboxedTupleCon )
-import TyCon ( TyCon(..), tyConFamilySize, isDataTyCon, tyConDataCons,
+import TyCon ( tyConFamilySize, isDataTyCon, tyConDataCons,
isFunTyCon, isUnboxedTupleTyCon )
import Class ( Class, classTyCon )
import Type ( Type, repType, splitFunTys, dropForAlls )
import PprType ( pprType )
import SMRep ( arrWordsHdrSize, arrPtrsHdrSize )
import Constants ( wORD_SIZE )
-import ByteCodeInstr ( BCInstr(..), ProtoBCO(..), nameOfProtoBCO, bciStackUse )
-import ByteCodeItbls ( ItblEnv, mkITbls )
-import ByteCodeLink ( UnlinkedBCO, UnlinkedBCOExpr, assembleBCO,
- ClosureEnv, HValue, filterNameMap, linkFail,
- iNTERP_STACK_CHECK_THRESH )
-import ByteCodeFFI ( taggedSizeW, untaggedSizeW, mkMarshalCode, moan64 )
-import Linker ( lookupSymbol )
import List ( intersperse, sortBy, zip4 )
import Foreign ( Ptr, castPtr, mallocBytes, pokeByteOff, Word8 )
-import CTypes ( CInt )
+import Foreign.C ( CInt )
import Control.Exception ( throwDyn )
import GHC.Exts ( Int(..), ByteArray# )
\begin{code}
byteCodeGen :: DynFlags
- -> [CoreBind]
- -> [TyCon] -> [Class]
- -> IO ([UnlinkedBCO], ItblEnv)
-byteCodeGen dflags binds local_tycons local_classes
+ -> ModGuts
+ -> IO CompiledByteCode
+byteCodeGen dflags (ModGuts { mg_binds = binds, mg_types = type_env })
= do showPass dflags "ByteCodeGen"
- let tycs = local_tycons ++ map classTyCon local_classes
- itblenv <- mkITbls tycs
+ let local_tycons = typeEnvTyCons type_env
+ local_classes = typeEnvClasses type_env
+ tycs = local_tycons ++ map classTyCon local_classes
let flatBinds = concatMap getBind binds
getBind (NonRec bndr rhs) = [(bndr, freeVars rhs)]
dumpIfSet_dyn dflags Opt_D_dump_BCOs
"Proto-bcos" (vcat (intersperse (char ' ') (map ppr proto_bcos)))
- bcos <- mapM assembleBCO proto_bcos
-
- return (bcos, itblenv)
+ assembleBCOs proto_bcos tycs
-- Returns: (the root BCO for this expression,
-- create a totally bogus name for the top-level BCO; this
-- should be harmless, since it's never used for anything
- let invented_id = mkSysLocal FSLIT("ExprTopLevel")
- (mkPseudoUnique3 0)
- (panic "invented_id's type")
- let invented_name = idName invented_id
-
- annexpr = freeVars expr
- fvs = filter (not.isTyVar) (varSetElems (fst annexpr))
+ let invented_name = mkSystemName (mkPseudoUnique3 0) FSLIT("ExprTopLevel")
+ invented_id = mkLocalId invented_name (panic "invented_id's type")
+ annexpr = freeVars expr
+ fvs = filter (not.isTyVar) (varSetElems (fst annexpr))
(BcM_State all_proto_bcos final_ctr mallocd, ())
<- runBc (BcM_State [] 0 [])
DynamicTarget
-> returnBc (False, panic "ByteCodeGen.generateCCall(dyn)")
StaticTarget target
- -> let sym_to_find = unpackFS target in
- ioToBc (lookupSymbol sym_to_find) `thenBc` \res ->
- case res of
- Just aa -> returnBc (True, aa)
- Nothing -> ioToBc (linkFail "ByteCodeGen.generateCCall"
- sym_to_find)
+ -> ioToBc (lookupStaticPtr target) `thenBc` \res ->
+ returnBc (True, res)
CasmTarget _
-> pprPanic "ByteCodeGen.generateCCall: casm" (ppr ccall_spec)
in
import DataCon ( DataCon )
import VarSet ( VarSet )
import PrimOp ( PrimOp )
-import Ptr
+import GHC.Ptr
\end{code}
%************************************************************************
#include "HsVersions.h"
import Name ( Name, getName )
-import FiniteMap ( FiniteMap, listToFM, emptyFM, plusFM )
+import NameEnv
import Type ( typePrimRep )
import DataCon ( DataCon, dataConRepArgTys )
import TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons )
import Foreign ( Storable(..), Word8, Word16, Word32, Word64,
malloc, castPtr, plusPtr )
-import Bits ( Bits(..), shiftR )
-
-import Monad ( liftM )
+import DATA_BITS ( Bits(..), shiftR )
import GHC.Exts ( Int(I#), addr2Int# )
+#if __GLASGOW_HASKELL__ < 503
+import Ptr ( Ptr(..) )
+#else
import GHC.Ptr ( Ptr(..) )
+#endif
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-
type ItblPtr = Ptr StgInfoTable
-type ItblEnv = FiniteMap Name ItblPtr
+type ItblEnv = NameEnv (Name, ItblPtr)
+ -- We need the Name in the range so we know which
+ -- elements to filter out when unloading a module
+
+mkItblEnv :: [(Name,ItblPtr)] -> ItblEnv
+mkItblEnv pairs = mkNameEnv [(n, (n,p)) | (n,p) <- pairs]
-- Make info tables for the data decls in this module
mkITbls :: [TyCon] -> IO ItblEnv
-mkITbls [] = return emptyFM
+mkITbls [] = return emptyNameEnv
mkITbls (tc:tcs) = do itbls <- mkITbl tc
itbls2 <- mkITbls tcs
- return (itbls `plusFM` itbls2)
+ return (itbls `plusNameEnv` itbls2)
mkITbl :: TyCon -> IO ItblEnv
mkITbl tc
| not (isDataTyCon tc)
- = return emptyFM
+ = return emptyNameEnv
| dcs `lengthIs` n -- paranoia; this is an assertion.
= make_constr_itbls dcs
where
make_constr_itbls cons
| listLengthCmp cons 8 /= GT -- <= 8 elements in the list
= do is <- mapM mk_vecret_itbl (zip cons [0..])
- return (listToFM is)
+ return (mkItblEnv is)
| otherwise
= do is <- mapM mk_dirret_itbl (zip cons [0..])
- return (listToFM is)
+ return (mkItblEnv is)
where
mk_vecret_itbl (dcon, conNo)
= mk_itbl dcon conNo (vecret_entry conNo)
{-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
-module ByteCodeLink ( UnlinkedBCO, UnlinkedBCOExpr, assembleBCO,
- ClosureEnv, HValue, filterNameMap,
- linkIModules, linkIExpr, linkFail,
- iNTERP_STACK_CHECK_THRESH
- ) where
+module ByteCodeLink (
+ HValue,
+ ClosureEnv, emptyClosureEnv, extendClosureEnv,
+ linkBCO, lookupStaticPtr
+ ) where
#include "HsVersions.h"
-import Outputable
-import Name ( Name, getName, nameModule, toRdrName, isExternalName )
-import RdrName ( rdrNameOcc, rdrNameModule )
+import ByteCodeItbls ( ItblEnv, ItblPtr )
+import ByteCodeAsm ( UnlinkedBCO(..), sizeSS, ssElts )
+import ObjLink ( lookupSymbol )
+
+import Name ( Name, nameModule, nameOccName, isExternalName )
+import NameEnv
import OccName ( occNameString )
-import FiniteMap ( FiniteMap, addListToFM, filterFM,
- addToFM, lookupFM, emptyFM )
-import CoreSyn
-import Literal ( Literal(..) )
import PrimOp ( PrimOp, primOpOcc )
-import PrimRep ( PrimRep(..), isFollowableRep )
-import Constants ( wORD_SIZE )
-import Module ( ModuleName, moduleName, moduleNameFS )
-import Linker ( lookupSymbol )
+import Module ( moduleString )
import FastString ( FastString(..), unpackFS )
-import ByteCodeInstr ( BCInstr(..), ProtoBCO(..) )
-import ByteCodeItbls ( ItblEnv, ItblPtr )
-import FiniteMap
+import Outputable
import Panic ( GhcException(..) )
-import Util ( notNull )
-
-import Control.Monad ( when, foldM )
-import Control.Monad.ST ( runST )
-import Data.Array.IArray ( array )
+-- Standard libraries
import GHC.Word ( Word(..) )
-import Data.Array.MArray ( MArray, newArray_, readArray, writeArray )
-import Data.Array.ST ( castSTUArray )
+
+import Data.Array.IArray ( array )
import Data.Array.Base ( UArray(..) )
-import Foreign.Ptr ( nullPtr )
-import Foreign ( Word16, free )
-import System.Mem.Weak ( addFinalizer )
-import Data.Int ( Int64 )
+import Foreign ( Word16 )
-import System.IO ( fixIO )
import Control.Exception ( throwDyn )
import GHC.Exts ( BCO#, newBCO#, unsafeCoerce#,
import GHC.Ptr ( Ptr(..) )
\end{code}
+
%************************************************************************
%* *
-\subsection{Top-level stuff}
+\subsection{Linking interpretables into something we can run}
%* *
%************************************************************************
\begin{code}
--- Linking stuff
-linkIModules :: ItblEnv -- incoming global itbl env; returned updated
- -> ClosureEnv -- incoming global closure env; returned updated
- -> [([UnlinkedBCO], ItblEnv)]
- -> IO ([HValue], ItblEnv, ClosureEnv)
-linkIModules gie gce mods
- = do let (bcoss, ies) = unzip mods
- bcos = concat bcoss
- final_gie = foldr plusFM gie ies
- (final_gce, linked_bcos) <- linkSomeBCOs True final_gie gce bcos
- return (linked_bcos, final_gie, final_gce)
-
-
-linkIExpr :: ItblEnv -> ClosureEnv -> UnlinkedBCOExpr
- -> IO HValue -- IO BCO# really
-linkIExpr ie ce (root_ul_bco, aux_ul_bcos)
- = do (aux_ce, _) <- linkSomeBCOs False ie ce aux_ul_bcos
- (_, [root_bco]) <- linkSomeBCOs False ie aux_ce [root_ul_bco]
- return root_bco
-
--- Link a bunch of BCOs and return them + updated closure env.
-linkSomeBCOs :: Bool -- False <=> add _all_ BCOs to returned closure env
- -- True <=> add only toplevel BCOs to closure env
- -> ItblEnv
- -> ClosureEnv
- -> [UnlinkedBCO]
- -> IO (ClosureEnv, [HValue])
-linkSomeBCOs toplevs_only ie ce_in ul_bcos
- = do let nms = map nameOfUnlinkedBCO ul_bcos
- hvals <- fixIO
- ( \ hvs -> let ce_out = addListToFM ce_in (zipLazily nms hvs)
- in mapM (linkBCO ie ce_out) ul_bcos )
-
- let ce_all_additions = zip nms hvals
- ce_top_additions = filter (isExternalName.fst) ce_all_additions
- ce_additions = if toplevs_only then ce_top_additions
- else ce_all_additions
- ce_out = -- make sure we're not inserting duplicate names into the
- -- closure environment, which leads to trouble.
- ASSERT (all (not . (`elemFM` ce_in)) (map fst ce_additions))
- addListToFM ce_in ce_additions
- return (ce_out, hvals)
- where
- -- A lazier zip, in which no demand is propagated to the second
- -- list unless some demand is propagated to the snd of one of the
- -- result list elems.
- zipLazily [] ys = []
- zipLazily (x:xs) ys = (x, head ys) : zipLazily xs (tail ys)
-
-
-data UnlinkedBCO
- = UnlinkedBCO Name
- (SizedSeq Word16) -- insns
- (SizedSeq (Either Word FastString)) -- literals
- -- Either literal words or a pointer to a asciiz
- -- string, denoting a label whose *address* should
- -- be determined at link time
- (SizedSeq (Either Name PrimOp)) -- ptrs
- (SizedSeq Name) -- itbl refs
-
-nameOfUnlinkedBCO (UnlinkedBCO nm _ _ _ _) = nm
-
--- When translating expressions, we need to distinguish the root
--- BCO for the expression
-type UnlinkedBCOExpr = (UnlinkedBCO, [UnlinkedBCO])
-
-instance Outputable UnlinkedBCO where
- ppr (UnlinkedBCO nm insns lits ptrs itbls)
- = sep [text "BCO", ppr nm, text "with",
- int (sizeSS insns), text "insns",
- int (sizeSS lits), text "lits",
- int (sizeSS ptrs), text "ptrs",
- int (sizeSS itbls), text "itbls"]
-
-
--- these need a proper home
-type ClosureEnv = FiniteMap Name HValue
+type ClosureEnv = NameEnv (Name, HValue)
data HValue = HValue -- dummy type, actually a pointer to some Real Code.
--- remove all entries for a given set of modules from the environment;
--- note that this removes all local names too (ie. temporary bindings from
--- the command line).
-filterNameMap :: [ModuleName] -> FiniteMap Name a -> FiniteMap Name a
-filterNameMap mods env
- = filterFM (\n _ -> isExternalName n
- && moduleName (nameModule n) `elem` mods) env
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{The bytecode assembler}
-%* *
-%************************************************************************
-
-The object format for bytecodes is: 16 bits for the opcode, and 16 for
-each field -- so the code can be considered a sequence of 16-bit ints.
-Each field denotes either a stack offset or number of items on the
-stack (eg SLIDE), and index into the pointer table (eg PUSH_G), an
-index into the literal table (eg PUSH_I/D/L), or a bytecode address in
-this BCO.
+emptyClosureEnv = emptyNameEnv
-\begin{code}
--- Top level assembler fn.
-assembleBCO :: ProtoBCO Name -> IO UnlinkedBCO
-
-assembleBCO (ProtoBCO nm instrs origin malloced)
- = let
- -- pass 1: collect up the offsets of the local labels.
- -- Remember that the first insn starts at offset 1 since offset 0
- -- (eventually) will hold the total # of insns.
- label_env = mkLabelEnv emptyFM 1 instrs
-
- mkLabelEnv env i_offset [] = env
- mkLabelEnv env i_offset (i:is)
- = let new_env
- = case i of LABEL n -> addToFM env n i_offset ; _ -> env
- in mkLabelEnv new_env (i_offset + instrSize16s i) is
-
- findLabel lab
- = case lookupFM label_env lab of
- Just bco_offset -> bco_offset
- Nothing -> pprPanic "assembleBCO.findLabel" (int lab)
- in
- do -- pass 2: generate the instruction, ptr and nonptr bits
- insns <- return emptySS :: IO (SizedSeq Word16)
- lits <- return emptySS :: IO (SizedSeq (Either Word FastString))
- ptrs <- return emptySS :: IO (SizedSeq (Either Name PrimOp))
- itbls <- return emptySS :: IO (SizedSeq Name)
- let init_asm_state = (insns,lits,ptrs,itbls)
- (final_insns, final_lits, final_ptrs, final_itbls)
- <- mkBits findLabel init_asm_state instrs
-
- let ul_bco = UnlinkedBCO nm final_insns final_lits final_ptrs final_itbls
-
- -- 8 Aug 01: Finalisers aren't safe when attached to non-primitive
- -- objects, since they might get run too early. Disable this until
- -- we figure out what to do.
- -- when (notNull malloced) (addFinalizer ul_bco (mapM_ zonk malloced))
-
- return ul_bco
- where
- zonk ptr = do -- putStrLn ("freeing malloc'd block at " ++ show (A# a#))
- free ptr
-
--- instrs nonptrs ptrs itbls
-type AsmState = (SizedSeq Word16,
- SizedSeq (Either Word FastString),
- SizedSeq (Either Name PrimOp),
- SizedSeq Name)
-
-data SizedSeq a = SizedSeq !Int [a]
-emptySS = SizedSeq 0 []
-addToSS (SizedSeq n r_xs) x = return (SizedSeq (n+1) (x:r_xs))
-addListToSS (SizedSeq n r_xs) xs
- = return (SizedSeq (n + length xs) (reverse xs ++ r_xs))
-sizeSS (SizedSeq n r_xs) = n
-listFromSS (SizedSeq n r_xs) = return (reverse r_xs)
-
-
--- This is where all the action is (pass 2 of the assembler)
-mkBits :: (Int -> Int) -- label finder
- -> AsmState
- -> [BCInstr] -- instructions (in)
- -> IO AsmState
-
-mkBits findLabel st proto_insns
- = foldM doInstr st proto_insns
- where
- doInstr :: AsmState -> BCInstr -> IO AsmState
- doInstr st i
- = case i of
- SWIZZLE stkoff n -> instr3 st i_SWIZZLE stkoff n
- ARGCHECK n -> instr2 st i_ARGCHECK n
- STKCHECK n -> instr2 st i_STKCHECK n
- PUSH_L o1 -> instr2 st i_PUSH_L o1
- PUSH_LL o1 o2 -> instr3 st i_PUSH_LL o1 o2
- PUSH_LLL o1 o2 o3 -> instr4 st i_PUSH_LLL o1 o2 o3
- PUSH_G nm -> do (p, st2) <- ptr st nm
- instr2 st2 i_PUSH_G p
- PUSH_AS nm pk -> do (p, st2) <- ptr st (Left nm)
- (np, st3) <- ctoi_itbl st2 pk
- instr3 st3 i_PUSH_AS p np
- PUSH_UBX (Left lit) nws
- -> do (np, st2) <- literal st lit
- instr3 st2 i_PUSH_UBX np nws
- PUSH_UBX (Right aa) nws
- -> do (np, st2) <- addr st aa
- instr3 st2 i_PUSH_UBX np nws
-
- PUSH_TAG tag -> instr2 st i_PUSH_TAG tag
- SLIDE n by -> instr3 st i_SLIDE n by
- ALLOC n -> instr2 st i_ALLOC n
- MKAP off sz -> instr3 st i_MKAP off sz
- UNPACK n -> instr2 st i_UNPACK n
- UPK_TAG n m k -> instr4 st i_UPK_TAG n m k
- PACK dcon sz -> do (itbl_no,st2) <- itbl st dcon
- instr3 st2 i_PACK itbl_no sz
- LABEL lab -> return st
- TESTLT_I i l -> do (np, st2) <- int st i
- instr3 st2 i_TESTLT_I np (findLabel l)
- TESTEQ_I i l -> do (np, st2) <- int st i
- instr3 st2 i_TESTEQ_I np (findLabel l)
- TESTLT_F f l -> do (np, st2) <- float st f
- instr3 st2 i_TESTLT_F np (findLabel l)
- TESTEQ_F f l -> do (np, st2) <- float st f
- instr3 st2 i_TESTEQ_F np (findLabel l)
- TESTLT_D d l -> do (np, st2) <- double st d
- instr3 st2 i_TESTLT_D np (findLabel l)
- TESTEQ_D d l -> do (np, st2) <- double st d
- instr3 st2 i_TESTEQ_D np (findLabel l)
- TESTLT_P i l -> instr3 st i_TESTLT_P i (findLabel l)
- TESTEQ_P i l -> instr3 st i_TESTEQ_P i (findLabel l)
- CASEFAIL -> instr1 st i_CASEFAIL
- JMP l -> instr2 st i_JMP (findLabel l)
- ENTER -> instr1 st i_ENTER
- RETURN rep -> do (itbl_no,st2) <- itoc_itbl st rep
- instr2 st2 i_RETURN itbl_no
- CCALL m_addr -> do (np, st2) <- addr st m_addr
- instr2 st2 i_CCALL np
-
- i2s :: Int -> Word16
- i2s = fromIntegral
-
- instr1 (st_i0,st_l0,st_p0,st_I0) i1
- = do st_i1 <- addToSS st_i0 (i2s i1)
- return (st_i1,st_l0,st_p0,st_I0)
-
- instr2 (st_i0,st_l0,st_p0,st_I0) i1 i2
- = do st_i1 <- addToSS st_i0 (i2s i1)
- st_i2 <- addToSS st_i1 (i2s i2)
- return (st_i2,st_l0,st_p0,st_I0)
-
- instr3 (st_i0,st_l0,st_p0,st_I0) i1 i2 i3
- = do st_i1 <- addToSS st_i0 (i2s i1)
- st_i2 <- addToSS st_i1 (i2s i2)
- st_i3 <- addToSS st_i2 (i2s i3)
- return (st_i3,st_l0,st_p0,st_I0)
-
- instr4 (st_i0,st_l0,st_p0,st_I0) i1 i2 i3 i4
- = do st_i1 <- addToSS st_i0 (i2s i1)
- st_i2 <- addToSS st_i1 (i2s i2)
- st_i3 <- addToSS st_i2 (i2s i3)
- st_i4 <- addToSS st_i3 (i2s i4)
- return (st_i4,st_l0,st_p0,st_I0)
-
- float (st_i0,st_l0,st_p0,st_I0) f
- = do let ws = mkLitF f
- st_l1 <- addListToSS st_l0 (map Left ws)
- return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
-
- double (st_i0,st_l0,st_p0,st_I0) d
- = do let ws = mkLitD d
- st_l1 <- addListToSS st_l0 (map Left ws)
- return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
-
- int (st_i0,st_l0,st_p0,st_I0) i
- = do let ws = mkLitI i
- st_l1 <- addListToSS st_l0 (map Left ws)
- return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
-
- int64 (st_i0,st_l0,st_p0,st_I0) i
- = do let ws = mkLitI64 i
- st_l1 <- addListToSS st_l0 (map Left ws)
- return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
-
- addr (st_i0,st_l0,st_p0,st_I0) a
- = do let ws = mkLitPtr a
- st_l1 <- addListToSS st_l0 (map Left ws)
- return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
-
- litlabel (st_i0,st_l0,st_p0,st_I0) fs
- = do st_l1 <- addListToSS st_l0 [Right fs]
- return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
-
- ptr (st_i0,st_l0,st_p0,st_I0) p
- = do st_p1 <- addToSS st_p0 p
- return (sizeSS st_p0, (st_i0,st_l0,st_p1,st_I0))
-
- itbl (st_i0,st_l0,st_p0,st_I0) dcon
- = do st_I1 <- addToSS st_I0 (getName dcon)
- return (sizeSS st_I0, (st_i0,st_l0,st_p0,st_I1))
-
- literal st (MachLabel fs) = litlabel st fs
- literal st (MachWord w) = int st (fromIntegral w)
- literal st (MachInt j) = int st (fromIntegral j)
- literal st (MachFloat r) = float st (fromRational r)
- literal st (MachDouble r) = double st (fromRational r)
- literal st (MachChar c) = int st c
- literal st (MachInt64 ii) = int64 st (fromIntegral ii)
- literal st (MachWord64 ii) = int64 st (fromIntegral ii)
- literal st other = pprPanic "ByteCodeLink.literal" (ppr other)
-
- ctoi_itbl st pk
- = addr st ret_itbl_addr
- where
- ret_itbl_addr
- = case pk of
- WordRep -> stg_ctoi_ret_R1n_info
- IntRep -> stg_ctoi_ret_R1n_info
- AddrRep -> stg_ctoi_ret_R1n_info
- CharRep -> stg_ctoi_ret_R1n_info
- FloatRep -> stg_ctoi_ret_F1_info
- DoubleRep -> stg_ctoi_ret_D1_info
- VoidRep -> stg_ctoi_ret_V_info
- other | isFollowableRep pk -> stg_ctoi_ret_R1p_info
- -- Includes ArrayRep, ByteArrayRep, as well as
- -- the obvious PtrRep
- | otherwise
- -> pprPanic "ByteCodeLink.ctoi_itbl" (ppr pk)
-
- itoc_itbl st pk
- = addr st ret_itbl_addr
- where
- ret_itbl_addr
- = case pk of
- CharRep -> stg_gc_unbx_r1_info
- IntRep -> stg_gc_unbx_r1_info
- WordRep -> stg_gc_unbx_r1_info
- AddrRep -> stg_gc_unbx_r1_info
- FloatRep -> stg_gc_f1_info
- DoubleRep -> stg_gc_d1_info
- VoidRep -> nullPtr -- Interpreter.c spots this special case
- other | isFollowableRep pk -> stg_gc_unpt_r1_info
- | otherwise
- -> pprPanic "ByteCodeLink.itoc_itbl" (ppr pk)
-
-foreign label "stg_ctoi_ret_R1p_info" stg_ctoi_ret_R1p_info :: Ptr ()
-foreign label "stg_ctoi_ret_R1n_info" stg_ctoi_ret_R1n_info :: Ptr ()
-foreign label "stg_ctoi_ret_F1_info" stg_ctoi_ret_F1_info :: Ptr ()
-foreign label "stg_ctoi_ret_D1_info" stg_ctoi_ret_D1_info :: Ptr ()
-foreign label "stg_ctoi_ret_V_info" stg_ctoi_ret_V_info :: Ptr ()
-
-foreign label "stg_gc_unbx_r1_info" stg_gc_unbx_r1_info :: Ptr ()
-foreign label "stg_gc_unpt_r1_info" stg_gc_unpt_r1_info :: Ptr ()
-foreign label "stg_gc_f1_info" stg_gc_f1_info :: Ptr ()
-foreign label "stg_gc_d1_info" stg_gc_d1_info :: Ptr ()
-
--- The size in 16-bit entities of an instruction.
-instrSize16s :: BCInstr -> Int
-instrSize16s instr
- = case instr of
- STKCHECK _ -> 2
- ARGCHECK _ -> 2
- PUSH_L _ -> 2
- PUSH_LL _ _ -> 3
- PUSH_LLL _ _ _ -> 4
- PUSH_G _ -> 2
- PUSH_AS _ _ -> 3
- PUSH_UBX _ _ -> 3
- PUSH_TAG _ -> 2
- SLIDE _ _ -> 3
- ALLOC _ -> 2
- MKAP _ _ -> 3
- UNPACK _ -> 2
- UPK_TAG _ _ _ -> 4
- PACK _ _ -> 3
- LABEL _ -> 0 -- !!
- TESTLT_I _ _ -> 3
- TESTEQ_I _ _ -> 3
- TESTLT_F _ _ -> 3
- TESTEQ_F _ _ -> 3
- TESTLT_D _ _ -> 3
- TESTEQ_D _ _ -> 3
- TESTLT_P _ _ -> 3
- TESTEQ_P _ _ -> 3
- JMP _ -> 2
- CASEFAIL -> 1
- ENTER -> 1
- RETURN _ -> 2
-
-
--- Make lists of host-sized words for literals, so that when the
--- words are placed in memory at increasing addresses, the
--- bit pattern is correct for the host's word size and endianness.
-mkLitI :: Int -> [Word]
-mkLitF :: Float -> [Word]
-mkLitD :: Double -> [Word]
-mkLitPtr :: Ptr () -> [Word]
-mkLitI64 :: Int64 -> [Word]
-
-mkLitF f
- = runST (do
- arr <- newArray_ ((0::Int),0)
- writeArray arr 0 f
- f_arr <- castSTUArray arr
- w0 <- readArray f_arr 0
- return [w0 :: Word]
- )
-
-mkLitD d
- | wORD_SIZE == 4
- = runST (do
- arr <- newArray_ ((0::Int),1)
- writeArray arr 0 d
- d_arr <- castSTUArray arr
- w0 <- readArray d_arr 0
- w1 <- readArray d_arr 1
- return [w0 :: Word, w1]
- )
- | wORD_SIZE == 8
- = runST (do
- arr <- newArray_ ((0::Int),0)
- writeArray arr 0 d
- d_arr <- castSTUArray arr
- w0 <- readArray d_arr 0
- return [w0 :: Word]
- )
-
-mkLitI64 ii
- | wORD_SIZE == 4
- = runST (do
- arr <- newArray_ ((0::Int),1)
- writeArray arr 0 ii
- d_arr <- castSTUArray arr
- w0 <- readArray d_arr 0
- w1 <- readArray d_arr 1
- return [w0 :: Word,w1]
- )
- | wORD_SIZE == 8
- = runST (do
- arr <- newArray_ ((0::Int),0)
- writeArray arr 0 ii
- d_arr <- castSTUArray arr
- w0 <- readArray d_arr 0
- return [w0 :: Word]
- )
-
-mkLitI i
- = runST (do
- arr <- newArray_ ((0::Int),0)
- writeArray arr 0 i
- i_arr <- castSTUArray arr
- w0 <- readArray i_arr 0
- return [w0 :: Word]
- )
-
-mkLitPtr a
- = runST (do
- arr <- newArray_ ((0::Int),0)
- writeArray arr 0 a
- a_arr <- castSTUArray arr
- w0 <- readArray a_arr 0
- return [w0 :: Word]
- )
+extendClosureEnv :: ClosureEnv -> [(Name,HValue)] -> ClosureEnv
+extendClosureEnv cl_env pairs
+ = extendNameEnvList cl_env [ (n, (n,v)) | (n,v) <- pairs]
\end{code}
+
%************************************************************************
%* *
\subsection{Linking interpretables into something we can run}
%************************************************************************
\begin{code}
-
{-
data BCO# = BCO# ByteArray# -- instrs :: Array Word16#
ByteArray# -- literals :: Array Word32#
ByteArray# -- itbls :: Array Addr#
-}
+linkBCO :: ItblEnv -> ClosureEnv -> UnlinkedBCO -> IO HValue
linkBCO ie ce (UnlinkedBCO nm insnsSS literalsSS ptrsSS itblsSS)
- = do insns <- listFromSS insnsSS
- literals <- listFromSS literalsSS
- ptrs <- listFromSS ptrsSS
- itbls <- listFromSS itblsSS
+-- Raises an IO exception on failure
+ = do let insns = ssElts insnsSS
+ literals = ssElts literalsSS
+ ptrs = ssElts ptrsSS
+ itbls = ssElts itblsSS
linked_ptrs <- mapM (lookupCE ce) ptrs
linked_itbls <- mapM (lookupIE ie) itbls
lookupLiteral :: Either Word FastString -> IO Word
-lookupLiteral (Left w) = return w
-lookupLiteral (Right addr_of_label_string)
+lookupLiteral (Left lit) = return lit
+lookupLiteral (Right sym) = do Ptr addr <- lookupStaticPtr sym
+ return (W# (unsafeCoerce# addr))
+ -- Can't be bothered to find the official way to convert Addr# to Word#;
+ -- the FFI/Foreign designers make it too damn difficult
+ -- Hence we apply the Blunt Instrument, which works correctly
+ -- on all reasonable architectures anyway
+
+lookupStaticPtr :: FastString -> IO (Ptr ())
+lookupStaticPtr addr_of_label_string
= do let label_to_find = unpackFS addr_of_label_string
m <- lookupSymbol label_to_find
case m of
- -- Can't be bothered to find the official way to convert Addr# to Word#;
- -- the FFI/Foreign designers make it too damn difficult
- -- Hence we apply the Blunt Instrument, which works correctly
- -- on all reasonable architectures anyway
- Just (Ptr addr) -> return (W# (unsafeCoerce# addr))
- Nothing -> linkFail "ByteCodeLink: can't find label"
- label_to_find
+ Just ptr -> return ptr
+ Nothing -> linkFail "ByteCodeLink: can't find label"
+ label_to_find
lookupCE :: ClosureEnv -> Either Name PrimOp -> IO HValue
lookupCE ce (Right primop)
Just (Ptr addr) -> case addrToHValue# addr of
(# hval #) -> return hval
Nothing -> linkFail "ByteCodeLink.lookupCE(primop)" sym_to_find
+
lookupCE ce (Left nm)
- = case lookupFM ce nm of
- Just aa -> return aa
+ = case lookupNameEnv ce nm of
+ Just (_,aa) -> return aa
Nothing
-> ASSERT2(isExternalName nm, ppr nm)
do let sym_to_find = nameToCLabel nm "closure"
lookupIE :: ItblEnv -> Name -> IO (Ptr a)
lookupIE ie con_nm
- = case lookupFM ie con_nm of
- Just (Ptr a) -> return (Ptr a)
+ = case lookupNameEnv ie con_nm of
+ Just (_, Ptr a) -> return (Ptr a)
Nothing
-> do -- try looking up in the object files.
let sym_to_find1 = nameToCLabel con_nm "con_info"
-- HACKS!!! ToDo: cleaner
nameToCLabel :: Name -> String{-suffix-} -> String
nameToCLabel n suffix
- = unpackFS(moduleNameFS (rdrNameModule rn))
- ++ '_':occNameString(rdrNameOcc rn) ++ '_':suffix
- where rn = toRdrName n
+ = moduleString (nameModule n)
+ ++ '_':occNameString (nameOccName n) ++ '_':suffix
primopToCLabel :: PrimOp -> String{-suffix-} -> String
primopToCLabel primop suffix
= let str = "GHCziPrimopWrappers_" ++ occNameString (primOpOcc primop) ++ '_':suffix
in --trace ("primopToCLabel: " ++ str)
str
-
\end{code}
-%************************************************************************
-%* *
-\subsection{Connect to actual values for bytecode opcodes}
-%* *
-%************************************************************************
-
-\begin{code}
-
-#include "Bytecodes.h"
-
-i_ARGCHECK = (bci_ARGCHECK :: Int)
-i_PUSH_L = (bci_PUSH_L :: Int)
-i_PUSH_LL = (bci_PUSH_LL :: Int)
-i_PUSH_LLL = (bci_PUSH_LLL :: Int)
-i_PUSH_G = (bci_PUSH_G :: Int)
-i_PUSH_AS = (bci_PUSH_AS :: Int)
-i_PUSH_UBX = (bci_PUSH_UBX :: Int)
-i_PUSH_TAG = (bci_PUSH_TAG :: Int)
-i_SLIDE = (bci_SLIDE :: Int)
-i_ALLOC = (bci_ALLOC :: Int)
-i_MKAP = (bci_MKAP :: Int)
-i_UNPACK = (bci_UNPACK :: Int)
-i_UPK_TAG = (bci_UPK_TAG :: Int)
-i_PACK = (bci_PACK :: Int)
-i_TESTLT_I = (bci_TESTLT_I :: Int)
-i_TESTEQ_I = (bci_TESTEQ_I :: Int)
-i_TESTLT_F = (bci_TESTLT_F :: Int)
-i_TESTEQ_F = (bci_TESTEQ_F :: Int)
-i_TESTLT_D = (bci_TESTLT_D :: Int)
-i_TESTEQ_D = (bci_TESTEQ_D :: Int)
-i_TESTLT_P = (bci_TESTLT_P :: Int)
-i_TESTEQ_P = (bci_TESTEQ_P :: Int)
-i_CASEFAIL = (bci_CASEFAIL :: Int)
-i_ENTER = (bci_ENTER :: Int)
-i_RETURN = (bci_RETURN :: Int)
-i_STKCHECK = (bci_STKCHECK :: Int)
-i_JMP = (bci_JMP :: Int)
-#ifdef bci_CCALL
-i_CCALL = (bci_CCALL :: Int)
-i_SWIZZLE = (bci_SWIZZLE :: Int)
-#else
-i_CCALL = error "Sorry pal, you need to bootstrap to use i_CCALL."
-i_SWIZZLE = error "Sorry pal, you need to bootstrap to use i_SWIZZLE."
-#endif
-
-iNTERP_STACK_CHECK_THRESH = (INTERP_STACK_CHECK_THRESH :: Int)
-
-\end{code}
{-# OPTIONS -#include "Linker.h" -#include "SchedAPI.h" #-}
-----------------------------------------------------------------------------
--- $Id: InteractiveUI.hs,v 1.133 2002/09/06 14:35:44 simonmar Exp $
+-- $Id: InteractiveUI.hs,v 1.134 2002/09/13 15:02:32 simonpj Exp $
--
-- GHC Interactive User Interface
--
-----------------------------------------------------------------------------
module InteractiveUI (
interactiveUI, -- :: CmState -> [FilePath] -> [LibrarySpec] -> IO ()
- LibrarySpec(..),
ghciWelcomeMsg
) where
#include "../includes/config.h"
#include "HsVersions.h"
-import Packages
-
import CompManager
-import CmTypes ( Linkable, isObjectLinkable, ModSummary(..) )
-import CmLink ( findModuleLinkable_maybe )
-
-import HscTypes ( TyThing(..), showModMsg, InteractiveContext(..) )
+import HscTypes ( TyThing(..), HomeModInfo(hm_linkable), HomePackageTable,
+ isObjectLinkable )
import HsSyn ( TyClDecl(..), ConDecl(..), Sig(..) )
import MkIface ( ifaceTyThing )
import DriverFlags
import DriverState
-import DriverUtil ( handle, remove_spaces )
-import Linker
+import DriverUtil ( remove_spaces, handle )
+import Linker ( initLinker, showLinkerState, linkLibraries )
import Finder ( flushPackageCache )
import Util
import Id ( isRecordSelector, recordSelectorFieldLabel,
import TyCon ( tyConName, tyConClass_maybe, isPrimTyCon, DataConDetails(..) )
import FieldLabel ( fieldLabelTyCon )
import SrcLoc ( isGoodSrcLoc )
-import Module ( moduleName )
+import Module ( showModMsg, lookupModuleEnv )
import Name ( Name, isHomePackageName, nameSrcLoc, nameOccName,
NamedThing(..) )
import OccName ( isSymOcc )
-import BasicTypes ( defaultFixity )
+import BasicTypes ( defaultFixity, SuccessFlag(..) )
import Outputable
import CmdLineOpts ( DynFlag(..), DynFlags(..), getDynFlags, saveDynFlags,
restoreDynFlags, dopt_unset )
#endif
#if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
+import Control.Concurrent ( yield ) -- Used in readline loop
import System.Console.Readline as Readline
#endif
import Foreign.C.String ( CString, peekCString, withCString )
import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
-
-----------------------------------------------------------------------------
ghciWelcomeMsg = "\
\ (eg. -v2, -fglasgow-exts, etc.)\n\
\"
-interactiveUI :: CmState -> [FilePath] -> [LibrarySpec] -> IO ()
-interactiveUI cmstate paths cmdline_libs = do
+interactiveUI :: CmState -> [FilePath] -> [FilePath] -> IO ()
+interactiveUI cmstate paths cmdline_objs = do
hFlush stdout
hSetBuffering stdout NoBuffering
dflags <- getDynFlags
- -- link in the available packages
- pkgs <- getPackageInfo
+ -- Link in the available packages
initLinker
- linkPackages dflags cmdline_libs pkgs
-
- (cmstate, maybe_hval)
- <- cmCompileExpr cmstate dflags "IO.hSetBuffering IO.stdout IO.NoBuffering Prelude.>> IO.hSetBuffering IO.stderr IO.NoBuffering"
- case maybe_hval of
- Just hval -> do
- let action = unsafeCoerce# hval :: IO ()
- action -- do it now
- writeIORef turn_off_buffering action -- and save it for later
- _ -> panic "interactiveUI:buffering"
-
- (cmstate, maybe_hval)
- <- cmCompileExpr cmstate dflags "IO.hFlush IO.stderr"
- case maybe_hval of
- Just hval -> writeIORef flush_stderr (unsafeCoerce# hval :: IO ())
- _ -> panic "interactiveUI:stderr"
-
- (cmstate, maybe_hval)
- <- cmCompileExpr cmstate dflags "IO.hFlush IO.stdout"
- case maybe_hval of
- Just hval -> writeIORef flush_stdout (unsafeCoerce# hval :: IO ())
- _ -> panic "interactiveUI:stdout"
+ -- Now that demand-loading works, we don't really need to pre-load the packages
+ -- pkgs <- getPackages
+ -- linkPackages dflags pkgs
+ linkLibraries dflags cmdline_objs
+
+ -- Initialise buffering for the *interpreted* I/O system
+ cmstate <- initInterpBuffering cmstate dflags
-- We don't want the cmd line to buffer any input that might be
-- intended for the program, so unbuffer stdin.
- hSetBuffering stdin NoBuffering
+ hSetBuffering stdin NoBuffering
-- initial context is just the Prelude
cmstate <- cmSetContext cmstate dflags [] ["Prelude"]
return ()
-
runGHCi :: [FilePath] -> DynFlags -> GHCi ()
runGHCi paths dflags = do
read_dot_files <- io (readIORef v_Read_DotGHCi)
runCommand :: String -> GHCi Bool
runCommand c =
ghciHandle ( \exception -> do
- flushEverything
+ flushInterpBuffers
showException exception
return False
) $
cmstate <- getCmState
when b (mapM_ (showTypeOfName cmstate) names)
+ flushInterpBuffers
b <- isOptionSet RevertCAFs
io (when b revertCAFs)
- flushEverything
return True
showTypeOfName :: CmState -> Name -> GHCi ()
Nothing -> return ()
Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
-flushEverything :: GHCi ()
-flushEverything
- = io $ do Monad.join (readIORef flush_stdout)
- Monad.join (readIORef flush_stderr)
- return ()
-
specialCommand :: String -> GHCi Bool
specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
specialCommand str = do
noArgs c = throwDyn (CmdLineError ("command `" ++ c ++ "' takes no arguments"))
+
+-----------------------------------------------------------------------------
+-- To flush buffers for the *interpreted* computation we need
+-- to refer to *its* stdout/stderr handles
+
+GLOBAL_VAR(flush_interp, error "no flush_interp", IO ())
+GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
+
+no_buf_cmd = "IO.hSetBuffering IO.stdout IO.NoBuffering" ++
+ " Prelude.>> IO.hSetBuffering IO.stderr IO.NoBuffering"
+flush_cmd = "IO.hFlush IO.stdout Prelude.>> IO.hFlush IO.stderr"
+
+initInterpBuffering :: CmState -> DynFlags -> IO CmState
+initInterpBuffering cmstate dflags
+ = do (cmstate, maybe_hval) <- cmCompileExpr cmstate dflags no_buf_cmd
+
+ case maybe_hval of
+ Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
+ other -> panic "interactiveUI:setBuffering"
+
+ (cmstate, maybe_hval) <- cmCompileExpr cmstate dflags flush_cmd
+ case maybe_hval of
+ Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
+ _ -> panic "interactiveUI:flush"
+
+ turnOffBuffering -- Turn it off right now
+
+ return cmstate
+
+
+flushInterpBuffers :: GHCi ()
+flushInterpBuffers
+ = io $ do Monad.join (readIORef flush_interp)
+ return ()
+
+turnOffBuffering :: IO ()
+turnOffBuffering
+ = do Monad.join (readIORef turn_off_buffering)
+ return ()
+
-----------------------------------------------------------------------------
-- Commands
| otherwise = hsep (
punctuate comma (map text mods)) <> text "."
case ok of
- False ->
+ Failed ->
io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
- True ->
+ Succeeded ->
io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
rn_decl{ tcdCons = DataCons (filter conIsVisible cons) }
other -> other
where
- conIsVisible (ConDecl n _ _ _ _ _) = n `elem` thing_names
+ conIsVisible (ConDecl n _ _ _ _) = n `elem` thing_names
io (putStrLn (showSDocForUser unqual (
vcat (map (ppr . thingDecl) things')))
optToStr ShowType = "t"
optToStr RevertCAFs = "r"
-newPackages new_pkgs = do
- state <- getGHCiState
- dflags <- io getDynFlags
+newPackages new_pkgs = do -- The new packages are already in v_Packages
+ state <- getGHCiState
+ dflags <- io getDynFlags
cmstate1 <- io (cmUnload (cmstate state) dflags)
setGHCiState state{ cmstate = cmstate1, targets = [] }
- io $ do
- pkgs <- getPackageInfo
- flushPackageCache pkgs
-
- new_pkg_info <- getPackageDetails new_pkgs
- mapM_ (linkPackage dflags) (reverse new_pkg_info)
+ io $ do pkgs <- getPackageInfo
+ flushPackageCache pkgs
setContextAfterLoad []
case words str of
["modules" ] -> showModules
["bindings"] -> showBindings
+ ["linker"] -> io showLinkerState
_ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
showModules = do
cms <- getCmState
- let mg = cmGetModuleGraph cms
- ls = cmGetLinkables cms
- maybe_linkables = map (findModuleLinkable_maybe ls)
- (map (moduleName.ms_mod) mg)
- zipWithM showModule mg maybe_linkables
- return ()
+ let (mg, hpt) = cmGetModInfo cms
+ mapM_ (showModule hpt) mg
+
-showModule :: ModSummary -> Maybe Linkable -> GHCi ()
-showModule m (Just l) = do
- io (putStrLn (showModMsg (isObjectLinkable l) (ms_mod m) (ms_location m)))
-showModule _ Nothing = panic "missing linkable"
+showModule :: HomePackageTable -> ModSummary -> GHCi ()
+showModule hpt mod_summary
+ = case lookupModuleEnv hpt mod of
+ Nothing -> panic "missing linkable"
+ Just mod_info -> io (putStrLn (showModMsg obj_linkable mod locn))
+ where
+ obj_linkable = isObjectLinkable (hm_linkable mod_info)
+ where
+ mod = ms_mod mod_summary
+ locn = ms_location mod_summary
showBindings = do
cms <- getCmState
io (mapM_ showBinding (cmGetBindings cms))
return ()
+
-----------------------------------------------------------------------------
-- GHCi monad
| RevertCAFs -- revert CAFs after every evaluation
deriving Eq
-GLOBAL_VAR(flush_stdout, error "no flush_stdout", IO ())
-GLOBAL_VAR(flush_stderr, error "no flush_stdout", IO ())
-GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
-
newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
startGHCi :: GHCi a -> GHCiState -> IO a
ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
-----------------------------------------------------------------------------
--- package loader
-
--- Left: full path name of a .o file, including trailing .o
--- Right: "unadorned" name of a .DLL/.so
--- e.g. On unix "qt" denotes "libqt.so"
--- On WinDoze "burble" denotes "burble.DLL"
--- addDLL is platform-specific and adds the lib/.so/.DLL
--- suffixes platform-dependently; we don't do that here.
---
--- For dynamic objects only, try to find the object file in all the
--- directories specified in v_Library_Paths before giving up.
-
-data LibrarySpec = Object FilePath | DLL String
-#ifdef darwin_TARGET_OS
- | Framework String
-#endif
-
--- Packages that don't need loading, because the compiler shares them with
--- the interpreted program.
-dont_load_these = [ "rts" ]
-
--- Packages that are already linked into GHCi. For mingw32, we only
--- skip gmp and rts, since std and after need to load the msvcrt.dll
--- library which std depends on.
-loaded_in_ghci
-# ifndef mingw32_TARGET_OS
- = [ "std", "concurrent", "posix", "text", "util" ]
-# else
- = [ ]
-# endif
-
-showLS (Object nm) = "(static) " ++ nm
-showLS (DLL nm) = "(dynamic) " ++ nm
-#ifdef darwin_TARGET_OS
-showLS (Framework nm) = "(framework) " ++ nm
-#endif
-
-linkPackages :: DynFlags -> [LibrarySpec] -> [PackageConfig] -> IO ()
-linkPackages dflags cmdline_lib_specs pkgs
- = do mapM_ (linkPackage dflags) (reverse pkgs)
- lib_paths <- readIORef v_Library_paths
- mapM_ (preloadLib dflags lib_paths) cmdline_lib_specs
- if (null cmdline_lib_specs)
- then return ()
- else do maybePutStr dflags "final link ... "
-
- ok <- resolveObjs
- if ok then maybePutStrLn dflags "done."
- else throwDyn (InstallationError
- "linking extra libraries/objects failed")
- where
- preloadLib :: DynFlags -> [String] -> LibrarySpec -> IO ()
- preloadLib dflags lib_paths lib_spec
- = do maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ")
- case lib_spec of
- Object static_ish
- -> do b <- preload_static lib_paths static_ish
- maybePutStrLn dflags (if b then "done."
- else "not found")
- DLL dll_unadorned
- -> -- We add "" to the set of paths to try, so that
- -- if none of the real paths match, we force addDLL
- -- to look in the default dynamic-link search paths.
- do maybe_errstr <- loadDynamic (lib_paths++[""])
- dll_unadorned
- case maybe_errstr of
- Nothing -> return ()
- Just mm -> preloadFailed mm lib_paths lib_spec
- maybePutStrLn dflags "done"
-
- preloadFailed :: String -> [String] -> LibrarySpec -> IO ()
- preloadFailed sys_errmsg paths spec
- = do maybePutStr dflags
- ("failed.\nDynamic linker error message was:\n "
- ++ sys_errmsg ++ "\nWhilst trying to load: "
- ++ showLS spec ++ "\nDirectories to search are:\n"
- ++ unlines (map (" "++) paths) )
- give_up
-
- -- not interested in the paths in the static case.
- preload_static paths name
- = do b <- doesFileExist name
- if not b then return False
- else loadObj name >> return True
-
- give_up
- = (throwDyn . CmdLineError)
- "user specified .o/.so/.DLL could not be loaded."
-
-linkPackage :: DynFlags -> PackageConfig -> IO ()
-linkPackage dflags pkg
- | name pkg `elem` dont_load_these = return ()
- | otherwise
- = do
- let dirs = library_dirs pkg
- let libs = hs_libraries pkg ++ extra_libraries pkg
- classifieds <- mapM (locateOneObj dirs) libs
-#ifdef darwin_TARGET_OS
- let fwDirs = framework_dirs pkg
- let frameworks= extra_frameworks pkg
-#endif
-
- -- Complication: all the .so's must be loaded before any of the .o's.
- let dlls = [ dll | DLL dll <- classifieds ]
- objs = [ obj | Object obj <- classifieds ]
-
- maybePutStr dflags ("Loading package " ++ name pkg ++ " ... ")
-
- -- If this package is already part of the GHCi binary, we'll already
- -- have the right DLLs for this package loaded, so don't try to
- -- load them again.
- when (name pkg `notElem` loaded_in_ghci) $ do
-#ifdef darwin_TARGET_OS
- loadFrameworks fwDirs frameworks
-#endif
- loadDynamics dirs dlls
-
- -- After loading all the DLLs, we can load the static objects.
- mapM_ loadObj objs
-
- maybePutStr dflags "linking ... "
- ok <- resolveObjs
- if ok then maybePutStrLn dflags "done."
- else panic ("can't load package `" ++ name pkg ++ "'")
-
-loadDynamics dirs [] = return ()
-loadDynamics dirs (dll:dlls) = do
- r <- loadDynamic dirs dll
- case r of
- Nothing -> loadDynamics dirs dlls
- Just err -> throwDyn (CmdLineError ("can't load .so/.DLL for: "
- ++ dll ++ " (" ++ err ++ ")" ))
-#ifdef darwin_TARGET_OS
-loadFrameworks dirs [] = return ()
-loadFrameworks dirs (fw:fws) = do
- r <- loadFramework dirs fw
- case r of
- Nothing -> loadFrameworks dirs fws
- Just err -> throwDyn (CmdLineError ("can't load framework: "
- ++ fw ++ " (" ++ err ++ ")" ))
-#endif
-
--- Try to find an object file for a given library in the given paths.
--- If it isn't present, we assume it's a dynamic library.
-locateOneObj :: [FilePath] -> String -> IO LibrarySpec
-locateOneObj [] lib
- = return (DLL lib) -- we assume
-locateOneObj (d:ds) lib
- = do let path = d ++ '/':lib ++ ".o"
- b <- doesFileExist path
- if b then return (Object path) else locateOneObj ds lib
-
--- ----------------------------------------------------------------------------
--- Loading a dyanmic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32)
-
-#if defined(mingw32_TARGET_OS) || defined(cygwin32_TARGET_OS)
-loadDynamic paths rootname = addDLL rootname
- -- ignore paths on windows (why? --SDM)
-
-#else
-
--- return Nothing == success, else Just error message from dlopen
-loadDynamic (path:paths) rootname = do
- let dll = path ++ '/':mkSOName rootname
- b <- doesFileExist dll
- if not b
- then loadDynamic paths rootname
- else addDLL dll
-loadDynamic [] rootname = do
- -- tried all our known library paths, let dlopen() search its
- -- own builtin paths now.
- addDLL (mkSOName rootname)
-
-#ifdef darwin_TARGET_OS
-mkSOName root = "lib" ++ root ++ ".dylib"
-#else
-mkSOName root = "lib" ++ root ++ ".so"
-#endif
-
-#endif
-
--- Darwin / MacOS X only: load a framework
--- a framework is a dynamic library packaged inside a directory of the same
--- name. They are searched for in different paths than normal libraries.
-#ifdef darwin_TARGET_OS
-loadFramework extraPaths rootname
- = loadFramework' (extraPaths ++ defaultFrameworkPaths) where
- defaultFrameworkPaths = ["/Library/Frameworks", "/System/Library/Frameworks"]
-
- loadFramework' (path:paths) = do
- let dll = path ++ '/' : rootname ++ ".framework/" ++ rootname
- b <- doesFileExist dll
- if not b
- then loadFramework' paths
- else addDLL dll
- loadFramework' [] = do
- -- tried all our known library paths, but dlopen()
- -- has no built-in paths for frameworks: give up
- return $ Just $ "not found"
-#endif
-
-addDLL :: String -> IO (Maybe String)
-addDLL str = do
- maybe_errmsg <- withCString str $ \dll -> c_addDLL dll
- if maybe_errmsg == nullPtr
- then return Nothing
- else do str <- peekCString maybe_errmsg
- return (Just str)
-
-foreign import ccall "addDLL" unsafe
- c_addDLL :: CString -> IO CString
-
------------------------------------------------------------------------------
-- timing & statistics
timeIt :: GHCi a -> GHCi a
io $ printTimes (allocs2 - allocs1) (time2 - time1)
return a
-foreign import "getAllocations" getAllocations :: IO Int
+foreign import ccall "getAllocations" getAllocations :: IO Int
printTimes :: Int -> Integer -> IO ()
printTimes allocs psecs
isAlphaNumEx c = isAlphaNum c || c == '_' || c == '.'
-maybePutStr dflags s | verbosity dflags > 0 = putStr s
- | otherwise = return ()
-
-maybePutStrLn dflags s | verbosity dflags > 0 = putStrLn s
- | otherwise = return ()
-
-----------------------------------------------------------------------------
-- reverting CAFs
revertCAFs :: IO ()
revertCAFs = do
rts_revertCAFs
- Monad.join (readIORef turn_off_buffering)
- -- have to do this again, because we just reverted
- -- stdout, stderr & stdin to their defaults.
+ turnOffBuffering
+ -- Have to turn off buffering again, because we just
+ -- reverted stdout, stderr & stdin to their defaults.
foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
- -- make it "safe", just in case
+ -- Make it "safe", just in case
%
-% (c) The University of Glasgow, 2000
+% (c) The University of Glasgow 2000
%
-\section[Linker]{The In-Memory Object File Linker}
+
+-- --------------------------------------
+-- The dynamic linker for GHCi
+-- --------------------------------------
+
+This module deals with the top-level issues of dynamic linking,
+calling the object-code linker and the byte-code linker where
+necessary.
+
\begin{code}
-{-# OPTIONS -#include "Linker.h" #-}
-module Linker (
- initLinker, -- :: IO ()
- loadObj, -- :: String -> IO ()
- unloadObj, -- :: String -> IO ()
- lookupSymbol, -- :: String -> IO (Maybe (Ptr a))
- resolveObjs -- :: IO Bool
- ) where
+{-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
-import Monad ( when )
+module Linker ( HValue, initLinker, showLinkerState,
+ linkPackages, linkLibraries,
+ linkModules, unload, extendLinkEnv, linkExpr,
+ LibrarySpec(..)
+ ) where
-import Foreign.C
-import Foreign ( Ptr, nullPtr )
-import Panic ( panic )
-import DriverUtil ( prefixUnderscore )
+#include "../includes/config.h"
+#include "HsVersions.h"
--- ---------------------------------------------------------------------------
--- RTS Linker Interface
--- ---------------------------------------------------------------------------
+import ObjLink ( loadDLL, loadObj, unloadObj, resolveObjs, initLinker )
+import ByteCodeLink ( HValue, ClosureEnv, extendClosureEnv, linkBCO )
+import ByteCodeItbls ( ItblEnv )
+import ByteCodeAsm ( CompiledByteCode(..), bcosFreeNames,
+ UnlinkedBCO, UnlinkedBCOExpr, nameOfUnlinkedBCO )
-lookupSymbol :: String -> IO (Maybe (Ptr a))
-lookupSymbol str_in = do
- let str = prefixUnderscore str_in
- withCString str $ \c_str -> do
- addr <- c_lookupSymbol c_str
- if addr == nullPtr
- then return Nothing
- else return (Just addr)
-
-loadObj :: String -> IO ()
-loadObj str =
- withCString str $ \c_str -> do
- r <- c_loadObj c_str
- when (r == 0) (panic "loadObj: failed")
-
-unloadObj :: String -> IO ()
-unloadObj str =
- withCString str $ \c_str -> do
- r <- c_unloadObj c_str
- when (r == 0) (panic "unloadObj: failed")
-
-resolveObjs :: IO Bool
-resolveObjs = do
- r <- c_resolveObjs
- return (r /= 0) -- returns True <=> success
+import Packages ( PackageConfig(..), PackageName, PackageConfigMap, lookupPkg,
+ packageDependents, packageNameString )
+import DriverState ( v_Library_paths, v_Cmdline_libraries, getPackageConfigMap )
+import HscTypes ( Linkable(..), isObjectLinkable, nameOfObject, byteCodeOfObject,
+ Unlinked(..), isInterpretable, isObject,
+ HscEnv(..), PersistentCompilerState(..), ExternalPackageState(..),
+ HomePackageTable, PackageIfaceTable, ModIface(..), HomeModInfo(..) )
+import Name ( Name, nameModule, isExternalName )
+import NameEnv
+import NameSet ( nameSetToList )
+import Module ( Module, ModuleName, moduleName, lookupModuleEnvByName )
+import FastString ( FastString(..), unpackFS )
+import CmdLineOpts ( DynFlags(verbosity) )
+import BasicTypes ( SuccessFlag(..), succeeded, failed )
+import Outputable
+import Panic ( GhcException(..) )
+import Util ( zipLazy, global )
+import ErrUtils ( Message )
+
+-- Standard libraries
+import Control.Monad ( when, filterM, foldM )
+
+import Data.IORef ( IORef, readIORef, writeIORef )
+import Data.List ( partition )
+
+import System.IO ( putStr, putStrLn, hPutStrLn, stderr, fixIO )
+import System.Directory ( doesFileExist )
+
+import Control.Exception ( block, throwDyn )
+
+#if __GLASGOW_HASKELL__ >= 503
+import GHC.IOBase ( IO(..) )
+#else
+import PrelIOBase ( IO(..) )
+#endif
+\end{code}
+
+
+%************************************************************************
+%* *
+ The Linker's state
+%* *
+%************************************************************************
+
+The persistent linker state *must* match the actual state of the
+C dynamic linker at all times, so we keep it in a private global variable.
+
+
+The PersistentLinkerState maps Names to actual closures (for
+interpreted code only), for use during linking.
+
+\begin{code}
+GLOBAL_VAR(v_PersistentLinkerState, emptyPLS, PersistentLinkerState)
+
+data PersistentLinkerState
+ = PersistentLinkerState {
+
+ -- Current global mapping from Names to their true values
+ closure_env :: ClosureEnv,
+
+ -- The current global mapping from RdrNames of DataCons to
+ -- info table addresses.
+ -- When a new Unlinked is linked into the running image, or an existing
+ -- module in the image is replaced, the itbl_env must be updated
+ -- appropriately.
+ itbl_env :: ItblEnv,
+
+ -- The currently loaded interpreted modules (home package)
+ bcos_loaded :: [Linkable],
+
+ -- And the currently-loaded compiled modules (home package)
+ objs_loaded :: [Linkable],
+
+ -- The currently-loaded packages; always object code
+ -- Held, as usual, in dependency order; though I am not sure if
+ -- that is really important
+ pkgs_loaded :: [PackageName]
+ }
+
+emptyPLS :: PersistentLinkerState
+emptyPLS = PersistentLinkerState { closure_env = emptyNameEnv,
+ itbl_env = emptyNameEnv,
+ pkgs_loaded = init_pkgs_loaded,
+ bcos_loaded = [],
+ objs_loaded = [] }
+
+-- Packages that don't need loading, because the compiler
+-- shares them with the interpreted program.
+init_pkgs_loaded = [ FSLIT("rts") ]
+\end{code}
+
+\begin{code}
+extendLinkEnv :: [(Name,HValue)] -> IO ()
+-- Automatically discards shadowed bindings
+extendLinkEnv new_bindings
+ = do pls <- readIORef v_PersistentLinkerState
+ let new_closure_env = extendClosureEnv (closure_env pls) new_bindings
+ new_pls = pls { closure_env = new_closure_env }
+ writeIORef v_PersistentLinkerState new_pls
+
+-- filterNameMap removes from the environment all entries except
+-- those for a given set of modules;
+-- Note that this removes all *local* (i.e. non-isExternal) names too
+-- (these are the temporary bindings from the command line).
+-- Used to filter both the ClosureEnv and ItblEnv
+
+filterNameMap :: [ModuleName] -> NameEnv (Name, a) -> NameEnv (Name, a)
+filterNameMap mods env
+ = filterNameEnv keep_elt env
+ where
+ keep_elt (n,_) = isExternalName n
+ && (moduleName (nameModule n) `elem` mods)
+\end{code}
+
+
+\begin{code}
+showLinkerState :: IO ()
+-- Display the persistent linker state
+showLinkerState
+ = do pls <- readIORef v_PersistentLinkerState
+ printDump (vcat [text "----- Linker state -----",
+ text "Pkgs:" <+> ppr (pkgs_loaded pls),
+ text "Objs:" <+> ppr (objs_loaded pls),
+ text "BCOs:" <+> ppr (bcos_loaded pls)])
+\end{code}
+
+
+
+%************************************************************************
+%* *
+ Link a byte-code expression
+%* *
+%************************************************************************
+
+\begin{code}
+linkExpr :: HscEnv -> PersistentCompilerState
+ -> UnlinkedBCOExpr -> IO HValue -- IO BCO# really
+
+-- Link a single expression, *including* first linking packages and
+-- modules that this expression depends on.
+--
+-- Raises an IO exception if it can't find a compiled version of the
+-- dependents to link.
+
+linkExpr hsc_env pcs (root_ul_bco, aux_ul_bcos)
+ = -- Find what packages and linkables are required
+ case getLinkDeps hpt pit needed_mods of {
+ Left msg -> dieWith (msg $$ ptext SLIT("When linking an expression")) ;
+ Right (lnks, pkgs) -> do {
+
+ linkPackages dflags pkgs
+ ; ok <- linkModules dflags lnks
+ ; if failed ok then
+ dieWith empty
+ else do {
+
+ -- Link the expression itself
+ pls <- readIORef v_PersistentLinkerState
+ ; let ie = itbl_env pls
+ ce = closure_env pls
+
+ -- Link the necessary packages and linkables
+ ; (_, (root_hval:_)) <- linkSomeBCOs False ie ce all_bcos
+ ; return root_hval
+ }}}
+ where
+ pit = eps_PIT (pcs_EPS pcs)
+ hpt = hsc_HPT hsc_env
+ dflags = hsc_dflags hsc_env
+ all_bcos = root_ul_bco : aux_ul_bcos
+ free_names = nameSetToList (bcosFreeNames all_bcos)
+
+ needed_mods :: [Module]
+ needed_mods = [ nameModule n | n <- free_names, isExternalName n ]
+
+dieWith msg = throwDyn (UsageError (showSDoc msg))
+
+getLinkDeps :: HomePackageTable -> PackageIfaceTable
+ -> [Module] -- If you need these
+ -> Either Message
+ ([Linkable], [PackageName]) -- ... then link these first
+
+-- Find all the packages and linkables that a set of modules depends on
+
+getLinkDeps hpt pit mods
+ = go [] -- Linkables so far
+ [] -- Packages so far
+ [] -- Modules dealt with
+ (map moduleName mods) -- The usage info that we use for
+ -- dependencies has ModuleNames not Modules
+ where
+ go lnks pkgs _ [] = Right (lnks,pkgs)
+ go lnks pkgs mods_done (mod:mods)
+ | mod `elem` mods_done
+ = -- Already dealt with
+ go lnks pkgs mods_done mods
+
+ | Just mod_info <- lookupModuleEnvByName hpt mod
+ = -- OK, so it's a home module
+ let
+ mod_deps = [m | (m,_,_,_) <- mi_usages (hm_iface mod_info)]
+ -- Get the modules that this one depends on
+ in
+ go (hm_linkable mod_info : lnks) pkgs (mod : mods_done) (mod_deps ++ mods)
+
+ | Just pkg_iface <- lookupModuleEnvByName pit mod
+ = -- It's a package module, so add it to the package list
+ let
+ pkg_name = mi_package pkg_iface
+ pkgs' | pkg_name `elem` pkgs = pkgs
+ | otherwise = pkg_name : pkgs
+ in
+ go lnks pkgs' (mod : mods_done) mods
+
+ | otherwise
+ = -- Not in either table
+ Left (ptext SLIT("Can't find compiled code for dependent module") <+> ppr mod)
+\end{code}
+
+
+%************************************************************************
+%* *
+ Link some linkables
+ The linkables may consist of a mixture of
+ byte-code modules and object modules
+%* *
+%************************************************************************
+
+\begin{code}
+linkModules :: DynFlags -> [Linkable] -> IO SuccessFlag
+linkModules dflags linkables
+ = block $ do -- don't want to be interrupted by ^C in here
+
+ let (objs, bcos) = partition isObjectLinkable
+ (concatMap partitionLinkable linkables)
+
+ -- Load objects first; they can't depend on BCOs
+ ok_flag <- dynLinkObjs dflags objs
+
+ if failed ok_flag then
+ return Failed
+ else do
+ dynLinkBCOs bcos
+ return Succeeded
+
+
+-- HACK to support f-x-dynamic in the interpreter; no other purpose
+partitionLinkable :: Linkable -> [Linkable]
+partitionLinkable li
+ = let li_uls = linkableUnlinked li
+ li_uls_obj = filter isObject li_uls
+ li_uls_bco = filter isInterpretable li_uls
+ in
+ case (li_uls_obj, li_uls_bco) of
+ (objs@(_:_), bcos@(_:_))
+ -> [li{linkableUnlinked=li_uls_obj}, li{linkableUnlinked=li_uls_bco}]
+ other
+ -> [li]
+
+findModuleLinkable_maybe :: [Linkable] -> ModuleName -> Maybe Linkable
+findModuleLinkable_maybe lis mod
+ = case [LM time nm us | LM time nm us <- lis, nm == mod] of
+ [] -> Nothing
+ [li] -> Just li
+ many -> pprPanic "findModuleLinkable" (ppr mod)
+
+filterModuleLinkables :: (ModuleName -> Bool) -> [Linkable] -> [Linkable]
+filterModuleLinkables p ls = filter (p . linkableModName) ls
+
+linkableInSet :: Linkable -> [Linkable] -> Bool
+linkableInSet l objs_loaded =
+ case findModuleLinkable_maybe objs_loaded (linkableModName l) of
+ Nothing -> False
+ Just m -> linkableTime l == linkableTime m
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{The object-code linker}
+%* *
+%************************************************************************
+
+\begin{code}
+dynLinkObjs :: DynFlags -> [Linkable] -> IO SuccessFlag
+ -- Side-effects the PersistentLinkerState
+
+dynLinkObjs dflags objs
+ = do pls <- readIORef v_PersistentLinkerState
+
+ -- Load the object files and link them
+ let (objs_loaded', new_objs) = rmDupLinkables (objs_loaded pls) objs
+ pls1 = pls { objs_loaded = objs_loaded' }
+ unlinkeds = concatMap linkableUnlinked new_objs
+
+ mapM loadObj (map nameOfObject unlinkeds)
+
+ -- Link the all together
+ ok <- resolveObjs
+
+ -- If resolving failed, unload all our
+ -- object modules and carry on
+ if succeeded ok then do
+ writeIORef v_PersistentLinkerState pls1
+ return Succeeded
+ else do
+ pls2 <- unload_wkr dflags [] pls1
+ writeIORef v_PersistentLinkerState pls2
+ return Failed
+
+
+rmDupLinkables :: [Linkable] -- Already loaded
+ -> [Linkable] -- New linkables
+ -> ([Linkable], -- New loaded set (including new ones)
+ [Linkable]) -- New linkables (excluding dups)
+rmDupLinkables already ls
+ = go already [] ls
+ where
+ go already extras [] = (already, extras)
+ go already extras (l:ls)
+ | linkableInSet l already = go already extras ls
+ | otherwise = go (l:already) (l:extras) ls
+\end{code}
+
+
+\begin{code}
+linkLibraries :: DynFlags
+ -> [String] -- foo.o files specified on command line
+ -> IO ()
+-- Used just at initialisation time to link in libraries
+-- specified on the command line.
+linkLibraries dflags objs
+ = do { lib_paths <- readIORef v_Library_paths
+ ; minus_ls <- readIORef v_Cmdline_libraries
+ ; let cmdline_lib_specs = map Object objs ++ map DLL minus_ls
+
+ ; if (null cmdline_lib_specs) then return ()
+ else do {
+
+ -- Now link them
+ ; mapM_ (preloadLib dflags lib_paths) cmdline_lib_specs
+
+ ; maybePutStr dflags "final link ... "
+ ; ok <- resolveObjs
+ ; if succeeded ok then maybePutStrLn dflags "done."
+ else throwDyn (InstallationError "linking extra libraries/objects failed")
+ }}
+ where
+ preloadLib :: DynFlags -> [String] -> LibrarySpec -> IO ()
+ preloadLib dflags lib_paths lib_spec
+ = do maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ")
+ case lib_spec of
+ Object static_ish
+ -> do b <- preload_static lib_paths static_ish
+ maybePutStrLn dflags (if b then "done."
+ else "not found")
+ DLL dll_unadorned
+ -> do maybe_errstr <- loadDynamic lib_paths dll_unadorned
+ case maybe_errstr of
+ Nothing -> return ()
+ Just mm -> preloadFailed mm lib_paths lib_spec
+ maybePutStrLn dflags "done"
+
+ preloadFailed :: String -> [String] -> LibrarySpec -> IO ()
+ preloadFailed sys_errmsg paths spec
+ = do maybePutStr dflags
+ ("failed.\nDynamic linker error message was:\n "
+ ++ sys_errmsg ++ "\nWhilst trying to load: "
+ ++ showLS spec ++ "\nDirectories to search are:\n"
+ ++ unlines (map (" "++) paths) )
+ give_up
+
+ -- not interested in the paths in the static case.
+ preload_static paths name
+ = do b <- doesFileExist name
+ if not b then return False
+ else loadObj name >> return True
+
+ give_up
+ = (throwDyn . CmdLineError)
+ "user specified .o/.so/.DLL could not be loaded."
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{The byte-code linker}
+%* *
+%************************************************************************
+
+\begin{code}
+dynLinkBCOs :: [Linkable] -> IO ()
+ -- Side-effects the persistent linker state
+dynLinkBCOs bcos
+ = do pls <- readIORef v_PersistentLinkerState
+
+ let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos
+ pls1 = pls { bcos_loaded = bcos_loaded' }
+ unlinkeds :: [Unlinked]
+ unlinkeds = concatMap linkableUnlinked new_bcos
+
+ cbcs :: [CompiledByteCode]
+ cbcs = map byteCodeOfObject unlinkeds
+
+
+ ul_bcos = [b | ByteCode bs _ <- cbcs, b <- bs]
+ ies = [ie | ByteCode _ ie <- cbcs]
+ gce = closure_env pls
+ final_ie = foldr plusNameEnv (itbl_env pls) ies
+
+ (final_gce, linked_bcos) <- linkSomeBCOs True final_ie gce ul_bcos
+ -- What happens to these linked_bcos?
+
+ let pls2 = pls1 { closure_env = final_gce,
+ itbl_env = final_ie }
+
+ writeIORef v_PersistentLinkerState pls2
+ return ()
+
+-- Link a bunch of BCOs and return them + updated closure env.
+linkSomeBCOs :: Bool -- False <=> add _all_ BCOs to returned closure env
+ -- True <=> add only toplevel BCOs to closure env
+ -> ItblEnv
+ -> ClosureEnv
+ -> [UnlinkedBCO]
+ -> IO (ClosureEnv, [HValue])
+ -- The returned HValues are associated 1-1 with
+ -- the incoming unlinked BCOs. Each gives the
+ -- value of the corresponding unlinked BCO
+
+
+linkSomeBCOs toplevs_only ie ce_in ul_bcos
+ = do let nms = map nameOfUnlinkedBCO ul_bcos
+ hvals <- fixIO
+ ( \ hvs -> let ce_out = extendClosureEnv ce_in (zipLazy nms hvs)
+ in mapM (linkBCO ie ce_out) ul_bcos )
+
+ let ce_all_additions = zip nms hvals
+ ce_top_additions = filter (isExternalName.fst) ce_all_additions
+ ce_additions = if toplevs_only then ce_top_additions
+ else ce_all_additions
+ ce_out = -- make sure we're not inserting duplicate names into the
+ -- closure environment, which leads to trouble.
+ ASSERT (all (not . (`elemNameEnv` ce_in)) (map fst ce_additions))
+ extendClosureEnv ce_in ce_additions
+ return (ce_out, hvals)
+
+\end{code}
+
+
+%************************************************************************
+%* *
+ Unload some object modules
+%* *
+%************************************************************************
+
+\begin{code}
-- ---------------------------------------------------------------------------
--- Foreign declaractions to RTS entry points which does the real work;
--- ---------------------------------------------------------------------------
+-- Unloading old objects ready for a new compilation sweep.
+--
+-- The compilation manager provides us with a list of linkables that it
+-- considers "stable", i.e. won't be recompiled this time around. For
+-- each of the modules current linked in memory,
+--
+-- * if the linkable is stable (and it's the same one - the
+-- user may have recompiled the module on the side), we keep it,
+--
+-- * otherwise, we unload it.
+--
+-- * we also implicitly unload all temporary bindings at this point.
+
+unload :: DynFlags -> [Linkable] -> IO ()
+-- The 'linkables' are the ones to *keep*
+
+unload dflags linkables
+ = block $ do -- block, so we're safe from Ctrl-C in here
-foreign import "initLinker" unsafe
- initLinker :: IO ()
+ pls <- readIORef v_PersistentLinkerState
+ new_pls <- unload_wkr dflags linkables pls
+ writeIORef v_PersistentLinkerState new_pls
-foreign import "lookupSymbol" unsafe
- c_lookupSymbol :: CString -> IO (Ptr a)
+ let verb = verbosity dflags
+ when (verb >= 3) $ do
+ hPutStrLn stderr (showSDoc
+ (text "unload: retaining objs" <+> ppr (objs_loaded new_pls)))
+ hPutStrLn stderr (showSDoc
+ (text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls)))
-foreign import "loadObj" unsafe
- c_loadObj :: CString -> IO Int
+ return ()
-foreign import "unloadObj" unsafe
- c_unloadObj :: CString -> IO Int
+unload_wkr :: DynFlags
+ -> [Linkable] -- stable linkables
+ -> PersistentLinkerState
+ -> IO PersistentLinkerState
+-- Does the core unload business
+-- (the wrapper blocks exceptions and deals with the PLS get and put)
-foreign import "resolveObjs" unsafe
- c_resolveObjs :: IO Int
+unload_wkr dflags linkables pls
+ = do let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable linkables
+
+ objs_loaded' <- filterM (maybeUnload objs_to_keep) (objs_loaded pls)
+ bcos_loaded' <- filterM (maybeUnload bcos_to_keep) (bcos_loaded pls)
+
+ let objs_retained = map linkableModName objs_loaded'
+ bcos_retained = map linkableModName bcos_loaded'
+ itbl_env' = filterNameMap bcos_retained (itbl_env pls)
+ closure_env' = filterNameMap bcos_retained (closure_env pls)
+ new_pls = pls { itbl_env = itbl_env',
+ closure_env = closure_env',
+ bcos_loaded = bcos_loaded',
+ objs_loaded = objs_loaded' }
+
+ return new_pls
+ where
+ maybeUnload :: [Linkable] -> Linkable -> IO Bool
+ maybeUnload keep_linkables lnk
+ | linkableInSet lnk linkables = return True
+ | otherwise
+ = do mapM_ unloadObj [f | DotO f <- linkableUnlinked lnk]
+ -- The components of a BCO linkable may contain
+ -- dot-o files. Which is very confusing.
+ --
+ -- But the BCO parts can be unlinked just by
+ -- letting go of them (plus of course depopulating
+ -- the symbol table which is done in the main body)
+ return False
+\end{code}
+
+
+%************************************************************************
+%* *
+ Loading packages
+%* *
+%************************************************************************
+
+
+\begin{code}
+data LibrarySpec
+ = Object FilePath -- Full path name of a .o file, including trailing .o
+ -- For dynamic objects only, try to find the object
+ -- file in all the directories specified in
+ -- v_Library_paths before giving up.
+
+ | DLL String -- "Unadorned" name of a .DLL/.so
+ -- e.g. On unix "qt" denotes "libqt.so"
+ -- On WinDoze "burble" denotes "burble.DLL"
+ -- loadDLL is platform-specific and adds the lib/.so/.DLL
+ -- suffixes platform-dependently
+#ifdef darwin_TARGET_OS
+ | Framework String
+#endif
+
+-- If this package is already part of the GHCi binary, we'll already
+-- have the right DLLs for this package loaded, so don't try to
+-- load them again.
+--
+-- But on Win32 we must load them 'again'; doing so is a harmless no-op
+-- as far as the loader is concerned, but it does initialise the list
+-- of DLL handles that rts/Linker.c maintains, and that in turn is
+-- used by lookupSymbol. So we must call addDLL for each library
+-- just to get the DLL handle into the list.
+partOfGHCi
+# ifndef mingw32_TARGET_OS
+ = [ "base", "concurrent", "posix", "text", "util" ]
+# else
+ = [ ]
+# endif
+
+showLS (Object nm) = "(static) " ++ nm
+showLS (DLL nm) = "(dynamic) " ++ nm
+#ifdef darwin_TARGET_OS
+showLS (Framework nm) = "(framework) " ++ nm
+#endif
+
+linkPackages :: DynFlags -> [PackageName] -> IO ()
+-- Link exactly the specified packages, and their dependents
+-- (unless of course they are already linked)
+-- The dependents are linked automatically, and it doesn't matter
+-- what order you specify the input packages.
+
+linkPackages dflags new_pkgs
+ = do { pls <- readIORef v_PersistentLinkerState
+ ; pkg_map <- getPackageConfigMap
+
+ ; pkgs' <- link pkg_map (pkgs_loaded pls) new_pkgs
+
+ ; writeIORef v_PersistentLinkerState (pls { pkgs_loaded = pkgs' })
+ }
+ where
+ link :: PackageConfigMap -> [PackageName] -> [PackageName] -> IO [PackageName]
+ link pkg_map pkgs new_pkgs
+ = foldM (link_one pkg_map) pkgs new_pkgs
+
+ link_one pkg_map pkgs new_pkg
+ | new_pkg `elem` pkgs -- Already linked
+ = return pkgs
+
+ | Just pkg_cfg <- lookupPkg pkg_map new_pkg
+ = do { -- Link dependents first
+ pkgs' <- link pkg_map pkgs (packageDependents pkg_cfg)
+ -- Now link the package itself
+ ; linkPackage dflags pkg_cfg
+ ; return (new_pkg : pkgs') }
+
+ | otherwise
+ = throwDyn (CmdLineError ("unknown package name: " ++ packageNameString new_pkg))
+
+
+linkPackage :: DynFlags -> PackageConfig -> IO ()
+linkPackage dflags pkg
+ = do
+ let dirs = Packages.library_dirs pkg
+ let libs = Packages.hs_libraries pkg ++ extra_libraries pkg
+ classifieds <- mapM (locateOneObj dirs) libs
+#ifdef darwin_TARGET_OS
+ let fwDirs = Packages.framework_dirs pkg
+ let frameworks= Packages.extra_frameworks pkg
+#endif
+
+ -- Complication: all the .so's must be loaded before any of the .o's.
+ let dlls = [ dll | DLL dll <- classifieds ]
+ objs = [ obj | Object obj <- classifieds ]
+
+ maybePutStr dflags ("Loading package " ++ Packages.name pkg ++ " ... ")
+
+ -- See comments with partOfGHCi
+ when (Packages.name pkg `notElem` partOfGHCi) $ do
+#ifdef darwin_TARGET_OS
+ loadFrameworks fwDirs frameworks
+#endif
+ loadDynamics dirs dlls
+
+ -- After loading all the DLLs, we can load the static objects.
+ mapM_ loadObj objs
+
+ maybePutStr dflags "linking ... "
+ ok <- resolveObjs
+ if succeeded ok then maybePutStrLn dflags "done."
+ else panic ("can't load package `" ++ name pkg ++ "'")
+
+loadDynamics dirs [] = return ()
+loadDynamics dirs (dll:dlls) = do
+ r <- loadDynamic dirs dll
+ case r of
+ Nothing -> loadDynamics dirs dlls
+ Just err -> throwDyn (CmdLineError ("can't load .so/.DLL for: "
+ ++ dll ++ " (" ++ err ++ ")" ))
+#ifdef darwin_TARGET_OS
+loadFrameworks dirs [] = return ()
+loadFrameworks dirs (fw:fws) = do
+ r <- loadFramework dirs fw
+ case r of
+ Nothing -> loadFrameworks dirs fws
+ Just err -> throwDyn (CmdLineError ("can't load framework: "
+ ++ fw ++ " (" ++ err ++ ")" ))
+#endif
+
+-- Try to find an object file for a given library in the given paths.
+-- If it isn't present, we assume it's a dynamic library.
+locateOneObj :: [FilePath] -> String -> IO LibrarySpec
+locateOneObj dirs lib
+ = do { mb_obj_path <- findFile mk_obj_path dirs
+ ; case mb_obj_path of
+ Just obj_path -> return (Object obj_path)
+ Nothing -> return (DLL lib) } -- we assume
+ where
+ mk_obj_path dir = dir ++ '/':lib ++ ".o"
+
+
+-- ----------------------------------------------------------------------------
+-- Loading a dyanmic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32)
+
+-- return Nothing == success, else Just error message from dlopen
+loadDynamic paths rootname
+ = do { mb_dll <- findFile mk_dll_path paths
+ ; case mb_dll of
+ Just dll -> loadDLL dll
+ Nothing -> loadDLL (mkSOName rootname) }
+ -- Tried all our known library paths, so let
+ -- dlopen() search its own builtin paths now.
+ where
+ mk_dll_path dir = dir ++ '/':mkSOName rootname
+
+#if defined(darwin_TARGET_OS)
+mkSOName root = "lib" ++ root ++ ".dylib"
+#elif defined(mingw32_TARGET_OS)
+-- Win32 DLLs have no .dll extension here, because addDLL tries
+-- both foo.dll and foo.drv
+mkSOName root = root
+#else
+mkSOName root = "lib" ++ root ++ ".so"
+#endif
+
+-- Darwin / MacOS X only: load a framework
+-- a framework is a dynamic library packaged inside a directory of the same
+-- name. They are searched for in different paths than normal libraries.
+#ifdef darwin_TARGET_OS
+loadFramework extraPaths rootname
+ = do { mb_fwk <- findFile mk_fwk (extraPaths ++ defaultFrameworkPaths)
+ ; case mb_fwk of
+ Just fwk_path -> loadDLL fwk_path
+ Nothing -> return (Just "not found")
+ -- Tried all our known library paths, but dlopen()
+ -- has no built-in paths for frameworks: give up
+ where
+ mk_fwk dir = dir ++ '/' : rootname ++ ".framework/" ++ rootname
+#endif
+\end{code}
+
+%************************************************************************
+%* *
+ Helper functions
+%* *
+%************************************************************************
+
+\begin{code}
+findFile :: (FilePath -> FilePath) -- Maps a directory path to a file path
+ -> [FilePath] -- Directories to look in
+ -> IO (Maybe FilePath) -- The first file path to match
+findFile mk_file_path []
+ = return Nothing
+findFile mk_file_path (dir:dirs)
+ = do { let file_path = mk_file_path dir
+ ; b <- doesFileExist file_path
+ ; if b then
+ return (Just file_path)
+ else
+ findFile mk_file_path dirs }
+\end{code}
+
+\begin{code}
+maybePutStr dflags s | verbosity dflags > 0 = putStr s
+ | otherwise = return ()
+maybePutStrLn dflags s | verbosity dflags > 0 = putStrLn s
+ | otherwise = return ()
\end{code}
--- /dev/null
+%
+% (c) The University of Glasgow, 2000
+%
+
+-- ---------------------------------------------------------------------------
+-- The dynamic linker for object code (.o .so .dll files)
+-- ---------------------------------------------------------------------------
+
+Primarily, this module consists of an interface to the C-land dynamic linker.
+
+\begin{code}
+{-# OPTIONS -#include "Linker.h" #-}
+
+module ObjLink (
+ initLinker, -- :: IO ()
+ loadDLL, -- :: String -> IO (Maybe String)
+ loadObj, -- :: String -> IO ()
+ unloadObj, -- :: String -> IO ()
+ lookupSymbol, -- :: String -> IO (Maybe (Ptr a))
+ resolveObjs -- :: IO SuccessFlag
+ ) where
+
+import Monad ( when )
+
+import Foreign.C
+import Foreign ( Ptr, nullPtr )
+import Panic ( panic )
+import DriverUtil ( prefixUnderscore )
+import BasicTypes ( SuccessFlag, successIf )
+import Outputable
+
+-- ---------------------------------------------------------------------------
+-- RTS Linker Interface
+-- ---------------------------------------------------------------------------
+
+lookupSymbol :: String -> IO (Maybe (Ptr a))
+lookupSymbol str_in = do
+ let str = prefixUnderscore str_in
+ withCString str $ \c_str -> do
+ addr <- c_lookupSymbol c_str
+ if addr == nullPtr
+ then return Nothing
+ else return (Just addr)
+
+loadDLL :: String -> IO (Maybe String)
+-- Nothing => success
+-- Just err_msg => failure
+loadDLL str = do
+ maybe_errmsg <- withCString str $ \dll -> c_addDLL dll
+ if maybe_errmsg == nullPtr
+ then return Nothing
+ else do str <- peekCString maybe_errmsg
+ return (Just str)
+
+loadObj :: String -> IO ()
+loadObj str = do
+ withCString str $ \c_str -> do
+ r <- c_loadObj c_str
+ when (r == 0) (panic "loadObj: failed")
+
+unloadObj :: String -> IO ()
+unloadObj str =
+ withCString str $ \c_str -> do
+ r <- c_unloadObj c_str
+ when (r == 0) (panic "unloadObj: failed")
+
+resolveObjs :: IO SuccessFlag
+resolveObjs = do
+ r <- c_resolveObjs
+ return (successIf (r /= 0))
+
+-- ---------------------------------------------------------------------------
+-- Foreign declaractions to RTS entry points which does the real work;
+-- ---------------------------------------------------------------------------
+
+#if __GLASGOW_HASKELL__ >= 504
+foreign import ccall unsafe "addDLL" c_addDLL :: CString -> IO CString
+foreign import ccall unsafe "initLinker" initLinker :: IO ()
+foreign import ccall unsafe "lookupSymbol" c_lookupSymbol :: CString -> IO (Ptr a)
+foreign import ccall unsafe "loadObj" c_loadObj :: CString -> IO Int
+foreign import ccall unsafe "unloadObj" c_unloadObj :: CString -> IO Int
+foreign import ccall unsafe "resolveObjs" c_resolveObjs :: IO Int
+#else
+foreign import "addDLL" unsafe c_addDLL :: CString -> IO CString
+foreign import "initLinker" unsafe initLinker :: IO ()
+foreign import "lookupSymbol" unsafe c_lookupSymbol :: CString -> IO (Ptr a)
+foreign import "loadObj" unsafe c_loadObj :: CString -> IO Int
+foreign import "unloadObj" unsafe c_unloadObj :: CString -> IO Int
+foreign import "resolveObjs" unsafe c_resolveObjs :: IO Int
+#endif
+
+\end{code}
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+
+This module converts Template Haskell syntax into HsSyn
+
+
+\begin{code}
+module Convert( convertToHsExpr, convertToHsDecls ) where
+
+#include "HsVersions.h"
+
+import Language.Haskell.THSyntax as Meta
+
+import HsSyn as Hs
+ ( HsExpr(..), HsLit(..), ArithSeqInfo(..),
+ HsDoContext(..),
+ Match(..), GRHSs(..), GRHS(..), HsPred(..),
+ HsDecl(..), TyClDecl(..), InstDecl(..),
+ Stmt(..), HsBinds(..), MonoBinds(..), Sig(..),
+ Pat(..), HsConDetails(..), HsOverLit, BangType(..),
+ placeHolderType, HsType(..), HsTupCon(..),
+ HsTyVarBndr(..), HsContext,
+ mkSimpleMatch
+ )
+
+import RdrName ( RdrName, mkRdrUnqual, mkRdrQual, mkOrig )
+import Module ( mkModuleName )
+import RdrHsSyn ( mkHsIntegral, mkClassDecl, mkTyData, mkConDecl )
+import OccName
+import SrcLoc ( SrcLoc, generatedSrcLoc )
+import TyCon ( DataConDetails(..) )
+import Type ( Type )
+import BasicTypes( Boxity(..), RecFlag(Recursive),
+ NewOrData(..), StrictnessMark(..) )
+import FastString( mkFastString )
+import Char ( ord, isAlphaNum )
+import List ( partition )
+import Outputable
+
+
+-------------------------------------------------------------------
+convertToHsDecls :: [Meta.Dec] -> [HsDecl RdrName]
+convertToHsDecls ds
+ = ValD (cvtdecs binds_and_sigs) : map cvt_top top_decls
+ where
+ (binds_and_sigs, top_decls) = partition sigOrBindP ds
+
+cvt_top (Data tc tvs constrs derivs)
+ = TyClD (mkTyData DataType
+ (noContext, tconName tc, cvt_tvs tvs)
+ (DataCons (map mk_con constrs))
+ (mk_derivs derivs) loc0)
+ where
+ mk_con (Constr c tys)
+ = mkConDecl (cName c) noExistentials noContext
+ (PrefixCon (map mk_arg tys)) loc0
+
+ mk_arg ty = BangType NotMarkedStrict (cvtType ty)
+
+ mk_derivs [] = Nothing
+ mk_derivs cs = Just [HsClassP (tconName c) [] | c <- cs]
+
+cvt_top (Class ctxt cl tvs decs)
+ = TyClD (mkClassDecl (cvt_context ctxt, tconName cl, cvt_tvs tvs)
+ noFunDeps
+ sigs (Just binds) loc0)
+ where
+ (binds,sigs) = cvtBindsAndSigs decs
+
+cvt_top (Instance tys ty decs)
+ = InstD (InstDecl inst_ty binds sigs Nothing loc0)
+ where
+ (binds, sigs) = cvtBindsAndSigs decs
+ inst_ty = HsForAllTy Nothing
+ (cvt_context tys)
+ (HsPredTy (cvt_pred ty))
+
+noContext = []
+noExistentials = []
+noFunDeps = []
+
+-------------------------------------------------------------------
+convertToHsExpr :: Meta.Exp -> HsExpr RdrName
+convertToHsExpr = cvt
+
+cvt (Var s) = HsVar(vName s)
+cvt (Con s) = HsVar(cName s)
+cvt (Lit l)
+ | overloadedLit l = HsOverLit (cvtOverLit l)
+ | otherwise = HsLit (cvtLit l)
+
+cvt (App x y) = HsApp (cvt x) (cvt y)
+cvt (Lam ps e) = HsLam (mkSimpleMatch (map cvtp ps) (cvt e) void loc0)
+cvt (Tup es) = ExplicitTuple(map cvt es) Boxed
+cvt (Cond x y z) = HsIf (cvt x) (cvt y) (cvt z) loc0
+cvt (Let ds e) = HsLet (cvtdecs ds) (cvt e)
+cvt (Case e ms) = HsCase (cvt e) (map cvtm ms) loc0
+cvt (Do ss) = HsDo DoExpr (cvtstmts ss) [] void loc0
+cvt (Comp ss) = HsDo ListComp (cvtstmts ss) [] void loc0
+cvt (ArithSeq dd) = ArithSeqIn (cvtdd dd)
+cvt (ListExp xs) = ExplicitList void (map cvt xs)
+cvt (Infix (Just x) s (Just y)) = OpApp (cvt x) (HsVar(vName s)) undefined (cvt y)
+cvt (Infix Nothing s (Just y)) = SectionR (HsVar(vName s)) (cvt y)
+cvt (Infix (Just x) s Nothing ) = SectionL (cvt x) (HsVar(vName s))
+cvt (Infix Nothing s Nothing ) = HsVar(vName s) -- Can I indicate this is an infix thing?
+
+
+cvtdecs :: [Meta.Dec] -> HsBinds RdrName
+cvtdecs [] = EmptyBinds
+cvtdecs ds = MonoBind binds sigs Recursive
+ where
+ (binds, sigs) = cvtBindsAndSigs ds
+
+cvtBindsAndSigs ds
+ = (cvtds non_sigs, map cvtSig sigs)
+ where
+ (sigs, non_sigs) = partition sigP ds
+
+cvtSig (Proto nm typ) = Sig (vName nm) (cvtType typ) loc0
+
+cvtds :: [Meta.Dec] -> MonoBinds RdrName
+cvtds [] = EmptyMonoBinds
+cvtds (d:ds) = AndMonoBinds (cvtd d) (cvtds ds)
+
+cvtd :: Meta.Dec -> MonoBinds RdrName
+-- Used only for declarations in a 'let/where' clause,
+-- not for top level decls
+cvtd (Val (Pvar s) body ds) = FunMonoBind (vName s) False
+ (panic "what now?") loc0
+cvtd (Fun nm cls) = FunMonoBind (vName nm) False (map cvtclause cls) loc0
+cvtd (Val p body ds) = PatMonoBind (cvtp p) (GRHSs (cvtguard body)
+ (cvtdecs ds)
+ void) loc0
+cvtd x = panic "Illegal kind of declaration in where clause"
+
+
+cvtclause :: Meta.Clause (Meta.Pat) (Meta.Exp) (Meta.Dec) -> Hs.Match RdrName
+cvtclause (ps,body,wheres) = Match (map cvtp ps) Nothing
+ (GRHSs (cvtguard body) (cvtdecs wheres) void)
+
+
+
+cvtdd :: Meta.DDt -> ArithSeqInfo RdrName
+cvtdd (Meta.From x) = (Hs.From (cvt x))
+cvtdd (Meta.FromThen x y) = (Hs.FromThen (cvt x) (cvt y))
+cvtdd (Meta.FromTo x y) = (Hs.FromTo (cvt x) (cvt y))
+cvtdd (Meta.FromThenTo x y z) = (Hs.FromThenTo (cvt x) (cvt y) (cvt z))
+
+
+cvtstmts :: [Meta.Stm] -> [Hs.Stmt RdrName]
+cvtstmts [] = [] -- this is probably an error as every [stmt] should end with ResultStmt
+cvtstmts [NoBindSt e] = [ResultStmt (cvt e) loc0] -- when its the last element use ResultStmt
+cvtstmts (NoBindSt e : ss) = ExprStmt (cvt e) void loc0 : cvtstmts ss
+cvtstmts (BindSt p e : ss) = BindStmt (cvtp p) (cvt e) loc0 : cvtstmts ss
+cvtstmts (LetSt ds : ss) = LetStmt (cvtdecs ds) : cvtstmts ss
+cvtstmts (ParSt dss : ss) = ParStmt(map cvtstmts dss) : cvtstmts ss
+
+
+cvtm :: Meta.Mat -> Hs.Match RdrName
+cvtm (p,body,wheres) = Match [cvtp p] Nothing
+ (GRHSs (cvtguard body) (cvtdecs wheres) void)
+
+cvtguard :: Meta.Rhs -> [GRHS RdrName]
+cvtguard (Guarded pairs) = map cvtpair pairs
+cvtguard (Normal e) = [GRHS [ ResultStmt (cvt e) loc0 ] loc0]
+
+cvtpair :: (Meta.Exp,Meta.Exp) -> GRHS RdrName
+cvtpair (x,y) = GRHS [BindStmt truePat (cvt x) loc0,
+ ResultStmt (cvt y) loc0] loc0
+
+cvtOverLit :: Lit -> HsOverLit
+cvtOverLit (Int i) = mkHsIntegral (fromInt i)
+-- An Int is like an an (overloaded) '3' in a Haskell source program
+
+cvtLit :: Lit -> HsLit
+cvtLit (Char c) = HsChar (ord c)
+cvtLit (CrossStage s) = error "What do we do about crossStage constants?"
+
+cvtp :: Meta.Pat -> Hs.Pat RdrName
+cvtp (Plit l)
+ | overloadedLit l = NPatIn (cvtOverLit l) Nothing -- Not right for negative
+ -- patterns; need to think
+ -- about that!
+ | otherwise = LitPat (cvtLit l)
+cvtp (Pvar s) = VarPat(vName s)
+cvtp (Ptup ps) = TuplePat (map cvtp ps) Boxed
+cvtp (Pcon s ps) = ConPatIn (cName s) (PrefixCon (map cvtp ps))
+cvtp (Ptilde p) = LazyPat (cvtp p)
+cvtp (Paspat s p) = AsPat (vName s) (cvtp p)
+cvtp Pwild = WildPat void
+
+-----------------------------------------------------------
+-- Types and type variables
+
+cvt_tvs :: [String] -> [HsTyVarBndr RdrName]
+cvt_tvs tvs = map (UserTyVar . tName) tvs
+
+cvt_context :: Context -> HsContext RdrName
+cvt_context tys = map cvt_pred tys
+
+cvt_pred :: Typ -> HsPred RdrName
+cvt_pred ty = case split_ty_app ty of
+ (Tvar tc, tys) -> HsClassP (tconName tc) (map cvtType tys)
+ other -> panic "Malformed predicate"
+
+cvtType :: Meta.Typ -> HsType RdrName
+cvtType (Tvar nm) = HsTyVar(tName nm)
+cvtType (Tapp x y) = trans (root x [y])
+ where root (Tapp a b) zs = root a (b:zs)
+ root t zs = (t,zs)
+ trans (Tcon (Tuple n),args) = HsTupleTy (HsTupCon Boxed n) (map cvtType args)
+ trans (Tcon Arrow,[x,y]) = HsFunTy (cvtType x) (cvtType y)
+ trans (Tcon List,[x]) = HsListTy (cvtType x)
+ trans (Tcon (Name nm),args) = HsTyVar(tconName nm)
+ trans (t,args) = panic "bad type application"
+
+split_ty_app :: Typ -> (Typ, [Typ])
+split_ty_app ty = go ty []
+ where
+ go (Tapp f a) as = go f (a:as)
+ go f as = (f,as)
+
+-----------------------------------------------------------
+sigP :: Dec -> Bool
+sigP (Proto _ _) = True
+sigP other = False
+
+sigOrBindP :: Dec -> Bool
+sigOrBindP (Proto _ _) = True
+sigOrBindP (Val _ _ _) = True
+sigOrBindP (Fun _ _) = True
+sigOrBindP other = False
+
+
+-----------------------------------------------------------
+-- some useful things
+
+truePat = ConPatIn (cName "True") (PrefixCon [])
+falsePat = ConPatIn (cName "False") (PrefixCon [])
+
+overloadedLit :: Lit -> Bool
+-- True for literals that Haskell treats as overloaded
+overloadedLit (Int l) = True
+overloadedLit l = False
+
+void :: Type.Type
+void = placeHolderType
+
+loc0 :: SrcLoc
+loc0 = generatedSrcLoc
+
+fromInt :: Int -> Integer
+fromInt x = toInteger x
+
+-- variable names
+vName :: String -> RdrName
+vName = mkName varName
+
+-- Constructor function names
+cName :: String -> RdrName
+cName = mkName dataName
+
+-- Type variable names
+tName :: String -> RdrName
+tName = mkName tvName
+
+-- Type Constructor names
+tconName = mkName tcName
+
+mkName :: NameSpace -> String -> RdrName
+-- Parse the string to see if it has a "." or ":" in it
+-- so we know whether to generate a qualified or original name
+-- It's a bit tricky because we need to parse
+-- Foo.Baz.x as Qual Foo.Baz x
+-- So we parse it from back to front
+
+mkName ns str
+ = split [] (reverse str)
+ where
+ split occ [] = mkRdrUnqual (mk_occ occ)
+ split occ (c:d:rev) -- 'd' is the last char before the separator
+ | is_sep c -- E.g. Fo.x d='o'
+ && isAlphaNum d -- Fo.+: d='+' perhaps
+ = mk_qual (reverse (d:rev)) c occ
+ split occ (c:rev) = split (c:occ) rev
+
+ mk_qual mod '.' occ = mkRdrQual (mk_mod mod) (mk_occ occ)
+ mk_qual mod ':' occ = mkOrig (mk_mod mod) (mk_occ occ)
+
+ mk_occ occ = mkOccFS ns (mkFastString occ)
+ mk_mod mod = mkModuleName mod
+
+ is_sep '.' = True
+ is_sep ':' = True
+ is_sep other = False
+\end{code}
GRHSs, pprPatBind )
-- friends:
-import HsImpExp ( ppr_var )
+import HsImpExp ( pprHsVar )
+import HsPat ( Pat )
import HsTypes ( HsType )
import CoreSyn ( CoreExpr )
import PprCore ( {- instance Outputable (Expr a) -} )
import Name ( Name )
import PrelNames ( isUnboundName )
import NameSet ( NameSet, elemNameSet, nameSetToList )
-import BasicTypes ( RecFlag(..), Fixity, Activation(..) )
+import BasicTypes ( RecFlag(..), FixitySig(..), Activation(..) )
import Outputable
import SrcLoc ( SrcLoc )
import Var ( TyVar )
Collections of bindings, created by dependency analysis and translation:
\begin{code}
-data HsBinds id pat -- binders and bindees
+data HsBinds id -- binders and bindees
= EmptyBinds
- | ThenBinds (HsBinds id pat)
- (HsBinds id pat)
+ | ThenBinds (HsBinds id)
+ (HsBinds id)
- | MonoBind (MonoBinds id pat)
- [Sig id] -- Empty on typechecker output
+ | MonoBind (MonoBinds id)
+ [Sig id] -- Empty on typechecker output, Type Signatures
RecFlag
\end{code}
\begin{code}
-nullBinds :: HsBinds id pat -> Bool
+nullBinds :: HsBinds id -> Bool
nullBinds EmptyBinds = True
nullBinds (ThenBinds b1 b2) = nullBinds b1 && nullBinds b2
nullBinds (MonoBind b _ _) = nullMonoBinds b
-mkMonoBind :: MonoBinds id pat -> [Sig id] -> RecFlag -> HsBinds id pat
+mkMonoBind :: MonoBinds id -> [Sig id] -> RecFlag -> HsBinds id
mkMonoBind EmptyMonoBinds _ _ = EmptyBinds
mkMonoBind mbinds sigs is_rec = MonoBind mbinds sigs is_rec
\end{code}
\begin{code}
-instance (Outputable pat, Outputable id) =>
- Outputable (HsBinds id pat) where
+instance (OutputableBndr id) => Outputable (HsBinds id) where
ppr binds = ppr_binds binds
ppr_binds EmptyBinds = empty
Global bindings (where clauses)
\begin{code}
-data MonoBinds id pat
+data MonoBinds id
= EmptyMonoBinds
- | AndMonoBinds (MonoBinds id pat)
- (MonoBinds id pat)
+ | AndMonoBinds (MonoBinds id)
+ (MonoBinds id)
| FunMonoBind id -- Used for both functions f x = e
-- and variables f = \x -> e
-- FunMonoBinds, so if you change this, you'll need to
-- change e.g. rnMethodBinds
Bool -- True => infix declaration
- [Match id pat]
+ [Match id]
SrcLoc
- | PatMonoBind pat -- The pattern is never a simple variable;
+ | PatMonoBind (Pat id) -- The pattern is never a simple variable;
-- That case is done by FunMonoBind
- (GRHSs id pat)
+ (GRHSs id)
SrcLoc
| VarMonoBind id -- TRANSLATION
- (HsExpr id pat)
+ (HsExpr id)
| CoreMonoBind id -- TRANSLATION
CoreExpr -- No zonking; this is a final CoreExpr with Ids and Types!
[id] -- Dicts
[([TyVar], id, id)] -- (type variables, polymorphic, momonmorphic) triples
NameSet -- Set of *polymorphic* variables that have an INLINE pragma
- (MonoBinds id pat) -- The "business end"
+ (MonoBinds id) -- The "business end"
-- Creates bindings for *new* (polymorphic, overloaded) locals
-- in terms of *old* (monomorphic, non-overloaded) ones.
-- We keep the invariant that a MonoBinds is only empty
-- if it is exactly EmptyMonoBinds
-nullMonoBinds :: MonoBinds id pat -> Bool
+nullMonoBinds :: MonoBinds id -> Bool
nullMonoBinds EmptyMonoBinds = True
nullMonoBinds other_monobind = False
-andMonoBinds :: MonoBinds id pat -> MonoBinds id pat -> MonoBinds id pat
+andMonoBinds :: MonoBinds id -> MonoBinds id -> MonoBinds id
andMonoBinds EmptyMonoBinds mb = mb
andMonoBinds mb EmptyMonoBinds = mb
andMonoBinds mb1 mb2 = AndMonoBinds mb1 mb2
-andMonoBindList :: [MonoBinds id pat] -> MonoBinds id pat
+andMonoBindList :: [MonoBinds id] -> MonoBinds id
andMonoBindList binds
= loop1 binds
where
\begin{code}
-instance (Outputable id, Outputable pat) =>
- Outputable (MonoBinds id pat) where
+instance OutputableBndr id => Outputable (MonoBinds id) where
ppr mbind = ppr_monobind mbind
-ppr_monobind :: (Outputable id, Outputable pat) => MonoBinds id pat -> SDoc
+ppr_monobind :: OutputableBndr id => MonoBinds id -> SDoc
ppr_monobind EmptyMonoBinds = empty
ppr_monobind (AndMonoBinds binds1 binds2)
= ppr_monobind binds1 $$ ppr_monobind binds2
-- ToDo: print infix if appropriate
ppr_monobind (VarMonoBind name expr)
- = sep [ppr name <+> equals, nest 4 (pprExpr expr)]
+ = sep [pprBndr LetBind name <+> equals, nest 4 (pprExpr expr)]
ppr_monobind (CoreMonoBind name expr)
- = sep [ppr name <+> equals, nest 4 (ppr expr)]
+ = sep [pprBndr LetBind name <+> equals, nest 4 (ppr expr)]
ppr_monobind (AbsBinds tyvars dictvars exports inlines val_binds)
= sep [ptext SLIT("AbsBinds"),
brackets (sep (punctuate comma (map ppr exports))),
brackets (interpp'SP (nameSetToList inlines))]
$$
- nest 4 (ppr val_binds)
+ nest 4 ( vcat [pprBndr LetBind x | (_,x,_) <- exports]
+ -- Print type signatures
+ $$
+ ppr val_binds )
\end{code}
%************************************************************************
SrcLoc
| FixSig (FixitySig name) -- Fixity declaration
-
-
-data FixitySig name = FixitySig name Fixity SrcLoc
-
-instance Eq name => Eq (FixitySig name) where
- (FixitySig n1 f1 _) == (FixitySig n2 f2 _) = n1==n2 && f1==f2
\end{code}
\begin{code}
= sep [ppr var <+> dcolon, nest 4 (ppr ty)]
ppr_sig (ClassOpSig var dm ty _)
- = sep [ ppr_var var <+> dcolon,
+ = sep [ pprHsVar var <+> dcolon,
nest 4 (ppr ty),
nest 4 (pp_dm_comment) ]
where
= hsep [text "{-# SPECIALIZE instance", ppr ty, text "#-}"]
ppr_sig (FixSig fix_sig) = ppr fix_sig
-
-
-instance Outputable name => Outputable (FixitySig name) where
- ppr (FixitySig name fixity loc) = sep [ppr fixity, ppr name]
\end{code}
Checking for distinct signatures; oh, so boring
UfBinding(..), UfConAlt(..),
HsIdInfo(..), pprHsIdInfo,
- eq_ufExpr, eq_ufBinders, pprUfExpr, pprHsIdInfo,
+ eq_ufExpr, eq_ufBinders, pprUfExpr,
toUfExpr, toUfBndr, ufBinderName
) where
import Id ( idArity, idType, isDataConId_maybe, isFCallId_maybe )
import Var ( varType, isId )
import IdInfo ( InlinePragInfo )
-import Name ( Name, NamedThing(..), toRdrName )
+import Name ( Name, NamedThing(..), eqNameByOcc )
import RdrName ( RdrName, rdrNameOcc )
-import OccName ( isTvOcc )
import CoreSyn
import CostCentre ( pprCostCentreCore )
import NewDemand ( StrictSig, pprIfaceStrictSig )
data UfExpr name
= UfVar name
| UfType (HsType name)
- | UfTuple (HsTupCon name) [UfExpr name] -- Type arguments omitted
+ | UfTuple HsTupCon [UfExpr name] -- Type arguments omitted
| UfLam (UfBinder name) (UfExpr name)
| UfApp (UfExpr name) (UfExpr name)
| UfCase (UfExpr name) name [UfAlt name]
data UfConAlt name = UfDefault
| UfDataAlt name
- | UfTupleAlt (HsTupCon name)
+ | UfTupleAlt HsTupCon
| UfLitAlt Literal
| UfLitLitAlt FastString (HsType name)
toUfCon DEFAULT = UfDefault
---------------------
-mk_hs_tup_con tc dc = HsTupCon (getName dc) (tupleTyConBoxity tc) (dataConSourceArity dc)
+mk_hs_tup_con tc dc = HsTupCon (tupleTyConBoxity tc) (dataConSourceArity dc)
---------------------
toUfBndr x | isId x = UfValBinder (getName x) (toHsType (varType x))
%************************************************************************
\begin{code}
-instance (NamedThing name, Outputable name) => Outputable (UfExpr name) where
+instance OutputableBndr name => Outputable (UfExpr name) where
ppr e = pprUfExpr noParens e
noParens :: SDoc -> SDoc
noParens pp = pp
-pprUfExpr :: (NamedThing name, Outputable name) => (SDoc -> SDoc) -> UfExpr name -> SDoc
+pprUfExpr :: OutputableBndr name => (SDoc -> SDoc) -> UfExpr name -> SDoc
-- The function adds parens in context that need
-- an atomic value (e.g. function args)
pprUfExpr add_par (UfFCall cc ty) = braces (ppr cc <+> ppr ty)
pprUfExpr add_par (UfType ty) = char '@' <+> pprParendHsType ty
-pprUfExpr add_par e@(UfLam _ _) = add_par (char '\\' <+> hsep (map ppr bndrs)
+pprUfExpr add_par e@(UfLam _ _) = add_par (char '\\' <+> hsep (map (pprBndr LambdaBind) bndrs)
<+> ptext SLIT("->") <+> pprUfExpr noParens body)
where (bndrs,body) = collectUfBndrs e
pprUfExpr add_par app@(UfApp _ _) = add_par (pprUfApp app)
braces (hsep (map pp_alt alts))])
where
pp_alt (UfTupleAlt tup_con, bs, rhs) = hsTupParens tup_con (interpp'SP bs) <+> ppr_rhs rhs
- pp_alt (c, bs, rhs) = ppr c <+> hsep (map pp_bndr bs) <+> ppr_rhs rhs
+ pp_alt (c, bs, rhs) = ppr c <+> hsep (map (pprBndr CaseBind) bs) <+> ppr_rhs rhs
ppr_rhs rhs = ptext SLIT("->") <+> pprUfExpr noParens rhs <> semi
- -- This use of getOccName is the sole reason for the NamedThing in pprUfExpr's type
- pp_bndr v | isTvOcc (getOccName v) = char '@' <+> ppr v
- | otherwise = ppr v
-
pprUfExpr add_par (UfLet (UfNonRec b rhs) body)
= add_par (hsep [ptext SLIT("let"),
- braces (ppr b <+> equals <+> pprUfExpr noParens rhs),
+ braces (pprBndr LetBind b <+> equals <+> pprUfExpr noParens rhs),
ptext SLIT("in"), pprUfExpr noParens body])
pprUfExpr add_par (UfLet (UfRec pairs) body)
instance Outputable name => Outputable (UfBinder name) where
ppr (UfValBinder name ty) = hsep [ppr name, dcolon, pprParendHsType ty]
ppr (UfTyBinder name kind) = char '@' <+> pprHsTyVarBndr name kind
+
+instance OutputableBndr name => OutputableBndr (UfBinder name) where
+ pprBndr _ (UfValBinder name ty) = hsep [ppr name, dcolon, pprParendHsType ty]
+ pprBndr _ (UfTyBinder name kind) = char '@' <+> pprHsTyVarBndr name kind
\end{code}
-- Compare *Rdr* names. A real hack to avoid gratuitous
-- differences when comparing interface files
eq_ufVar env n1 n2 = case lookupFM env n1 of
- Just n1 -> toRdrName n1 == toRdrName n2
- Nothing -> toRdrName n1 == toRdrName n2
-
+ Just n1 -> check n1
+ Nothing -> check n2
+ where
+ check n1 = eqNameByOcc (getName n1) (getName n2)
-----------------
eq_ufExpr :: (NamedThing name, Ord name) => EqHsEnv name -> UfExpr name -> UfExpr name -> Bool
%************************************************************************
\begin{code}
-pprHsIdInfo :: (NamedThing n, Outputable n) => [HsIdInfo n] -> SDoc
+pprHsIdInfo :: OutputableBndr n => [HsIdInfo n] -> SDoc
pprHsIdInfo [] = empty
pprHsIdInfo info = ptext SLIT("{-##") <+> hsep (map ppr_hs_info info) <+> ptext SLIT("##-}")
DefaultDecl(..),
ForeignDecl(..), ForeignImport(..), ForeignExport(..),
CImportSpec(..), FoType(..),
- ConDecl(..), ConDetails(..),
+ ConDecl(..), CoreDecl(..),
BangType(..), getBangType, getBangStrictness, unbangedType,
DeprecDecl(..), DeprecTxt,
hsDeclName, instDeclName,
- tyClDeclName, tyClDeclNames, tyClDeclSysNames, tyClDeclTyVars,
- isClassDecl, isSynDecl, isDataDecl, isIfaceSigDecl, isCoreDecl,
+ tyClDeclName, tyClDeclNames, tyClDeclTyVars,
+ isClassDecl, isSynDecl, isDataDecl, isIfaceSigDecl,
isTypeOrClassDecl, countTyClDecls,
- mkClassDeclSysNames, isSourceInstDecl, ifaceRuleDeclName,
- getClassDeclSysNames, conDetailsTys,
- collectRuleBndrSigTys
+ isSourceInstDecl, ifaceRuleDeclName,
+ conDetailsTys,
+ collectRuleBndrSigTys, isSrcRule
) where
#include "HsVersions.h"
-- friends:
-import HsBinds ( HsBinds, MonoBinds, Sig(..), FixitySig(..) )
-import HsExpr ( HsExpr )
-import HsImpExp ( ppr_var )
+import {-# SOURCE #-} HsExpr( HsExpr, pprExpr )
+ -- Because Expr imports Decls via HsBracket
+
+import HsBinds ( HsBinds, MonoBinds, Sig(..) )
+import HsPat ( HsConDetails(..), hsConArgs )
+import HsImpExp ( pprHsVar )
import HsTypes
import PprCore ( pprCoreRule )
import HsCore ( UfExpr, UfBinder, HsIdInfo, pprHsIdInfo,
eq_ufBinders, eq_ufExpr, pprUfExpr
)
import CoreSyn ( CoreRule(..), RuleName )
-import BasicTypes ( NewOrData(..), StrictnessMark(..), Activation(..) )
+import BasicTypes ( NewOrData(..), StrictnessMark(..), Activation(..), FixitySig(..) )
import ForeignCall ( CCallTarget(..), DNCallSpec, CCallConv, Safety,
CExportSpec(..))
%************************************************************************
\begin{code}
-data HsDecl name pat
- = TyClD (TyClDecl name pat)
- | InstD (InstDecl name pat)
- | DefD (DefaultDecl name)
- | ValD (HsBinds name pat)
- | ForD (ForeignDecl name)
- | FixD (FixitySig name)
- | DeprecD (DeprecDecl name)
- | RuleD (RuleDecl name pat)
+data HsDecl id
+ = TyClD (TyClDecl id)
+ | InstD (InstDecl id)
+ | DefD (DefaultDecl id)
+ | ValD (HsBinds id)
+ | ForD (ForeignDecl id)
+ | FixD (FixitySig id)
+ | DeprecD (DeprecDecl id)
+ | RuleD (RuleDecl id)
+ | CoreD (CoreDecl id)
+ | SpliceD (HsExpr id) -- Top level splice
-- NB: all top-level fixity decls are contained EITHER
-- EITHER FixDs
\begin{code}
#ifdef DEBUG
-hsDeclName :: (NamedThing name, Outputable name, Outputable pat)
- => HsDecl name pat -> name
+hsDeclName :: (NamedThing name, OutputableBndr name)
+ => HsDecl name -> name
#endif
-hsDeclName (TyClD decl) = tyClDeclName decl
-hsDeclName (InstD decl) = instDeclName decl
-hsDeclName (ForD decl) = foreignDeclName decl
-hsDeclName (FixD (FixitySig name _ _)) = name
+hsDeclName (TyClD decl) = tyClDeclName decl
+hsDeclName (InstD decl) = instDeclName decl
+hsDeclName (ForD decl) = foreignDeclName decl
+hsDeclName (FixD (FixitySig name _ _)) = name
+hsDeclName (CoreD (CoreDecl name _ _ _)) = name
-- Others don't make sense
#ifdef DEBUG
hsDeclName x = pprPanic "HsDecls.hsDeclName" (ppr x)
#endif
-instDeclName :: InstDecl name pat -> name
+instDeclName :: InstDecl name -> name
instDeclName (InstDecl _ _ _ (Just name) _) = name
\end{code}
\begin{code}
-instance (NamedThing name, Outputable name, Outputable pat)
- => Outputable (HsDecl name pat) where
+instance OutputableBndr name => Outputable (HsDecl name) where
ppr (TyClD dcl) = ppr dcl
ppr (ValD binds) = ppr binds
ppr (FixD fd) = ppr fd
ppr (RuleD rd) = ppr rd
ppr (DeprecD dd) = ppr dd
+ ppr (CoreD dd) = ppr dd
+ ppr (SpliceD e) = ptext SLIT("splice") <> parens (pprExpr e)
\end{code}
relevant type or class decl.
Plan of attack:
- - Make up their occurrence names immediately
- This is done in RdrHsSyn.mkClassDecl, mkTyDecl, mkConDecl
-
- Ensure they "point to" the parent data/class decl
when loading that decl from an interface file
- (See RnHiFiles.getTyClDeclSysNames)
+ (See RnHiFiles.getSysBinders)
+
+ - When typechecking the decl, we build the implicit TyCons and Ids.
+ When doing so we look them up in the name cache (RnEnv.lookupSysName),
+ to ensure correct module and provenance is set
- - When renaming the decl look them up in the name cache,
- ensure correct module and provenance is set
+These are the two places that we have to conjure up the magic derived
+names. (The actual magic is in OccName.mkWorkerOcc, etc.)
Default methods
~~~~~~~~~~~~~~~
-- for a module. That's why (despite the misnomer) IfaceSig and ForeignType
-- are both in TyClDecl
-data TyClDecl name pat
+data TyClDecl name
= IfaceSig { tcdName :: name, -- It may seem odd to classify an interface-file signature
tcdType :: HsType name, -- as a 'TyClDecl', but it's very convenient.
tcdIdInfo :: [HsIdInfo name],
tcdLoc :: SrcLoc }
| TyData { tcdND :: NewOrData,
- tcdCtxt :: HsContext name, -- context
- tcdName :: name, -- type constructor
- tcdTyVars :: [HsTyVarBndr name], -- type variables
- tcdCons :: DataConDetails (ConDecl name), -- data constructors (empty if abstract)
- tcdDerivs :: Maybe (HsContext name), -- derivings; Nothing => not specified
+ tcdCtxt :: HsContext name, -- Context
+ tcdName :: name, -- Type constructor
+ tcdTyVars :: [HsTyVarBndr name], -- Type variables
+ tcdCons :: DataConDetails (ConDecl name), -- Data constructors
+ tcdDerivs :: Maybe (HsContext name), -- Derivings; Nothing => not specified
-- Just [] => derive exactly what is asked
- tcdSysNames :: DataSysNames name, -- Generic converter functions
- tcdLoc :: SrcLoc
+ tcdGeneric :: Maybe Bool, -- Nothing <=> source decl
+ -- Just x <=> interface-file decl;
+ -- x=True <=> generic converter functions available
+ -- We need this for imported data decls, since the
+ -- imported modules may have been compiled with
+ -- different flags to the current compilation unit
+ tcdLoc :: SrcLoc
}
| TySynonym { tcdName :: name, -- type constructor
tcdTyVars :: [HsTyVarBndr name], -- The class type variables
tcdFDs :: [FunDep name], -- Functional dependencies
tcdSigs :: [Sig name], -- Methods' signatures
- tcdMeths :: Maybe (MonoBinds name pat), -- Default methods
- -- Nothing for imported class decls
- -- Just bs for source class decls
- tcdSysNames :: ClassSysNames name,
+ tcdMeths :: Maybe (MonoBinds name), -- Default methods
+ -- Nothing for imported class decls
+ -- Just bs for source class decls
tcdLoc :: SrcLoc
}
- -- a Core value binding (coming from 'external Core' input.)
- | CoreDecl { tcdName :: name,
- tcdType :: HsType name,
- tcdRhs :: UfExpr name,
- tcdLoc :: SrcLoc
- }
-
\end{code}
Simple classifiers
\begin{code}
-isIfaceSigDecl, isCoreDecl, isDataDecl, isSynDecl, isClassDecl :: TyClDecl name pat -> Bool
+isIfaceSigDecl, isDataDecl, isSynDecl, isClassDecl :: TyClDecl name -> Bool
isIfaceSigDecl (IfaceSig {}) = True
isIfaceSigDecl other = False
isTypeOrClassDecl (TySynonym {}) = True
isTypeOrClassDecl (ForeignType {}) = True
isTypeOrClassDecl other = False
-
-isCoreDecl (CoreDecl {}) = True
-isCoreDecl other = False
-
\end{code}
Dealing with names
\begin{code}
--------------------------------
-tyClDeclName :: TyClDecl name pat -> name
+tyClDeclName :: TyClDecl name -> name
tyClDeclName tycl_decl = tcdName tycl_decl
--------------------------------
-tyClDeclNames :: Eq name => TyClDecl name pat -> [(name, SrcLoc)]
+tyClDeclNames :: Eq name => TyClDecl name -> [(name, SrcLoc)]
-- Returns all the *binding* names of the decl, along with their SrcLocs
-- The first one is guaranteed to be the name of the decl
-- For record fields, the first one counts as the SrcLoc
tyClDeclNames (TySynonym {tcdName = name, tcdLoc = loc}) = [(name,loc)]
tyClDeclNames (IfaceSig {tcdName = name, tcdLoc = loc}) = [(name,loc)]
-tyClDeclNames (CoreDecl {tcdName = name, tcdLoc = loc}) = [(name,loc)]
tyClDeclNames (ForeignType {tcdName = name, tcdLoc = loc}) = [(name,loc)]
tyClDeclNames (ClassDecl {tcdName = cls_name, tcdSigs = sigs, tcdLoc = loc})
tyClDeclTyVars (ClassDecl {tcdTyVars = tvs}) = tvs
tyClDeclTyVars (ForeignType {}) = []
tyClDeclTyVars (IfaceSig {}) = []
-tyClDeclTyVars (CoreDecl {}) = []
-
-
---------------------------------
--- The "system names" are extra implicit names *bound* by the decl.
--- They are kept in a list rather than a tuple
--- to make the renamer easier.
-
-type ClassSysNames name = [name]
--- For class decls they are:
--- [tycon, datacon wrapper, datacon worker,
--- superclass selector 1, ..., superclass selector n]
-
-type DataSysNames name = [name]
--- For data decls they are
--- [from, to]
--- where from :: T -> Tring
--- to :: Tring -> T
-
-tyClDeclSysNames :: TyClDecl name pat -> [(name, SrcLoc)]
--- Similar to tyClDeclNames, but returns the "implicit"
--- or "system" names of the declaration
-
-tyClDeclSysNames (ClassDecl {tcdSysNames = names, tcdLoc = loc})
- = [(n,loc) | n <- names]
-tyClDeclSysNames (TyData {tcdCons = DataCons cons, tcdSysNames = names, tcdLoc = loc})
- = [(n,loc) | n <- names] ++
- [(wkr_name,loc) | ConDecl _ wkr_name _ _ _ loc <- cons]
-tyClDeclSysNames decl = []
-
-
-mkClassDeclSysNames :: (name, name, name, [name]) -> [name]
-getClassDeclSysNames :: [name] -> (name, name, name, [name])
-mkClassDeclSysNames (a,b,c,ds) = a:b:c:ds
-getClassDeclSysNames (a:b:c:ds) = (a,b,c,ds)
\end{code}
\begin{code}
-instance (NamedThing name, Ord name) => Eq (TyClDecl name pat) where
+instance (NamedThing name, Ord name) => Eq (TyClDecl name) where
-- Used only when building interface files
(==) d1@(IfaceSig {}) d2@(IfaceSig {})
= tcdName d1 == tcdName d2 &&
tcdType d1 == tcdType d2 &&
tcdIdInfo d1 == tcdIdInfo d2
- (==) d1@(CoreDecl {}) d2@(CoreDecl {})
- = tcdName d1 == tcdName d2 &&
- tcdType d1 == tcdType d2 &&
- tcdRhs d1 == tcdRhs d2
-
(==) d1@(ForeignType {}) d2@(ForeignType {})
= tcdName d1 == tcdName d2 &&
tcdFoType d1 == tcdFoType d2
GenDefMeth `eq_dm` GenDefMeth = True
DefMeth _ `eq_dm` DefMeth _ = True
dm1 `eq_dm` dm2 = False
-
-
\end{code}
\begin{code}
-countTyClDecls :: [TyClDecl name pat] -> (Int, Int, Int, Int, Int)
+countTyClDecls :: [TyClDecl name] -> (Int, Int, Int, Int, Int)
-- class, data, newtype, synonym decls
countTyClDecls decls
= (count isClassDecl decls,
count isSynDecl decls,
- count (\ x -> isIfaceSigDecl x || isCoreDecl x) decls,
+ count isIfaceSigDecl decls,
count isDataTy decls,
count isNewTy decls)
where
\end{code}
\begin{code}
-instance (NamedThing name, Outputable name, Outputable pat)
- => Outputable (TyClDecl name pat) where
+instance OutputableBndr name
+ => Outputable (TyClDecl name) where
ppr (IfaceSig {tcdName = var, tcdType = ty, tcdIdInfo = info})
= getPprStyle $ \ sty ->
- hsep [ ppr_var var, dcolon, ppr ty, pprHsIdInfo info ]
+ hsep [ pprHsVar var, dcolon, ppr ty, pprHsIdInfo info ]
ppr (ForeignType {tcdName = tycon})
= hsep [ptext SLIT("foreign import type dotnet"), ppr tycon]
pp_methods = if isNothing methods
then empty
else ppr (fromJust methods)
-
- ppr (CoreDecl {tcdName = var, tcdType = ty, tcdRhs = rhs})
- = getPprStyle $ \ sty ->
- hsep [ ppr_var var, dcolon, ppr ty, ppr rhs ]
-pp_decl_head :: Outputable name => HsContext name -> name -> [HsTyVarBndr name] -> SDoc
+pp_decl_head :: OutputableBndr name => HsContext name -> name -> [HsTyVarBndr name] -> SDoc
pp_decl_head context thing tyvars = hsep [pprHsContext context, ppr thing, interppSP tyvars]
pp_condecls Unknown = ptext SLIT("{- abstract -}")
= ConDecl name -- Constructor name; this is used for the
-- DataCon itself, and for the user-callable wrapper Id
- name -- Name of the constructor's 'worker Id'
- -- Filled in as the ConDecl is built
-
[HsTyVarBndr name] -- Existentially quantified type variables
(HsContext name) -- ...and context
-- If both are empty then there are no existentials
- (ConDetails name)
+ (HsConDetails name (BangType name))
SrcLoc
-
-data ConDetails name
- = VanillaCon -- prefix-style con decl
- [BangType name]
-
- | InfixCon -- infix-style con decl
- (BangType name)
- (BangType name)
-
- | RecCon -- record-style con decl
- [([name], BangType name)] -- list of "fields"
\end{code}
\begin{code}
conDeclsNames cons
= snd (foldl do_one ([], []) (visibleDataCons cons))
where
- do_one (flds_seen, acc) (ConDecl name _ _ _ details loc)
- = do_details ((name,loc):acc) details
+ do_one (flds_seen, acc) (ConDecl name _ _ (RecCon flds) loc)
+ = (new_flds ++ flds_seen, (name,loc) : [(f,loc) | f <- new_flds] ++ acc)
where
- do_details acc (RecCon flds) = foldl do_fld (flds_seen, acc) flds
- do_details acc other = (flds_seen, acc)
-
- do_fld acc (flds, _) = foldl do_fld1 acc flds
+ new_flds = [ f | (f,_) <- flds, not (f `elem` flds_seen) ]
- do_fld1 (flds_seen, acc) fld
- | fld `elem` flds_seen = (flds_seen,acc)
- | otherwise = (fld:flds_seen, (fld,loc):acc)
+ do_one (flds_seen, acc) (ConDecl name _ _ _ loc)
+ = (flds_seen, (name,loc):acc)
\end{code}
\begin{code}
-conDetailsTys :: ConDetails name -> [HsType name]
-conDetailsTys (VanillaCon btys) = map getBangType btys
-conDetailsTys (InfixCon bty1 bty2) = [getBangType bty1, getBangType bty2]
-conDetailsTys (RecCon fields) = [getBangType bty | (_, bty) <- fields]
+conDetailsTys details = map getBangType (hsConArgs details)
-
-eq_ConDecl env (ConDecl n1 _ tvs1 cxt1 cds1 _)
- (ConDecl n2 _ tvs2 cxt2 cds2 _)
+eq_ConDecl env (ConDecl n1 tvs1 cxt1 cds1 _)
+ (ConDecl n2 tvs2 cxt2 cds2 _)
= n1 == n2 &&
(eq_hsTyVars env tvs1 tvs2 $ \ env ->
eq_hsContext env cxt1 cxt2 &&
eq_ConDetails env cds1 cds2)
-eq_ConDetails env (VanillaCon bts1) (VanillaCon bts2)
+eq_ConDetails env (PrefixCon bts1) (PrefixCon bts2)
= eqListBy (eq_btype env) bts1 bts2
eq_ConDetails env (InfixCon bta1 btb1) (InfixCon bta2 btb2)
= eq_btype env bta1 bta2 && eq_btype env btb1 btb2
\end{code}
\begin{code}
-instance (Outputable name) => Outputable (ConDecl name) where
- ppr (ConDecl con _ tvs cxt con_details loc)
+instance (OutputableBndr name) => Outputable (ConDecl name) where
+ ppr (ConDecl con tvs cxt con_details loc)
= sep [pprHsForAll tvs cxt, ppr_con_details con con_details]
ppr_con_details con (InfixCon ty1 ty2)
= hsep [ppr_bang ty1, ppr con, ppr_bang ty2]
--- ConDecls generated by MkIface.ifaceTyThing always have a VanillaCon, even
+-- ConDecls generated by MkIface.ifaceTyThing always have a PrefixCon, even
-- if the constructor is an infix one. This is because in an interface file
-- we don't distinguish between the two. Hence when printing these for the
-- user, we need to parenthesise infix constructor names.
-ppr_con_details con (VanillaCon tys)
- = hsep (ppr_var con : map (ppr_bang) tys)
+ppr_con_details con (PrefixCon tys)
+ = hsep (pprHsVar con : map ppr_bang tys)
ppr_con_details con (RecCon fields)
= ppr con <+> braces (sep (punctuate comma (map ppr_field fields)))
where
- ppr_field (ns, ty) = hsep (map (ppr) ns) <+>
- dcolon <+>
- ppr_bang ty
+ ppr_field (n, ty) = ppr n <+> dcolon <+> ppr_bang ty
-instance Outputable name => Outputable (BangType name) where
+instance OutputableBndr name => Outputable (BangType name) where
ppr = ppr_bang
ppr_bang (BangType s ty) = ppr s <> pprParendHsType ty
%************************************************************************
\begin{code}
-data InstDecl name pat
+data InstDecl name
= InstDecl (HsType name) -- Context => Class Instance-type
-- Using a polytype means that the renamer conveniently
-- figures out the quantified type variables for us.
- (MonoBinds name pat)
+ (MonoBinds name)
[Sig name] -- User-supplied pragmatic info
SrcLoc
-isSourceInstDecl :: InstDecl name pat -> Bool
+isSourceInstDecl :: InstDecl name -> Bool
isSourceInstDecl (InstDecl _ _ _ maybe_dfun _) = isNothing maybe_dfun
\end{code}
\begin{code}
-instance (Outputable name, Outputable pat)
- => Outputable (InstDecl name pat) where
+instance (OutputableBndr name) => Outputable (InstDecl name) where
ppr (InstDecl inst_ty binds uprags maybe_dfun_name src_loc)
= vcat [hsep [ptext SLIT("instance"), ppr inst_ty, ptext SLIT("where")],
\end{code}
\begin{code}
-instance Ord name => Eq (InstDecl name pat) where
+instance Ord name => Eq (InstDecl name) where
-- Used for interface comparison only, so don't compare bindings
(==) (InstDecl inst_ty1 _ _ dfun1 _) (InstDecl inst_ty2 _ _ dfun2 _)
= inst_ty1 == inst_ty2 && dfun1 == dfun2
= DefaultDecl [HsType name]
SrcLoc
-instance (Outputable name)
+instance (OutputableBndr name)
=> Outputable (DefaultDecl name) where
ppr (DefaultDecl tys src_loc)
-- pretty printing of foreign declarations
--
-instance Outputable name => Outputable (ForeignDecl name) where
+instance OutputableBndr name => Outputable (ForeignDecl name) where
ppr (ForeignImport n ty fimport _ _) =
ptext SLIT("foreign import") <+> ppr fimport <+>
ppr n <+> dcolon <+> ppr ty
%************************************************************************
\begin{code}
-data RuleDecl name pat
+data RuleDecl name
= HsRule -- Source rule
RuleName -- Rule name
Activation
[RuleBndr name] -- Forall'd vars; after typechecking this includes tyvars
- (HsExpr name pat) -- LHS
- (HsExpr name pat) -- RHS
+ (HsExpr name) -- LHS
+ (HsExpr name) -- RHS
SrcLoc
| IfaceRule -- One that's come in from an interface file; pre-typecheck
name -- Head of LHS
CoreRule
-ifaceRuleDeclName :: RuleDecl name pat -> name
+isSrcRule (HsRule _ _ _ _ _ _) = True
+isSrcRule other = False
+
+ifaceRuleDeclName :: RuleDecl name -> name
ifaceRuleDeclName (IfaceRule _ _ _ n _ _ _) = n
ifaceRuleDeclName (IfaceRuleOut n r) = n
ifaceRuleDeclName (HsRule fs _ _ _ _ _) = pprPanic "ifaceRuleDeclName" (ppr fs)
collectRuleBndrSigTys :: [RuleBndr name] -> [HsType name]
collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs]
-instance (NamedThing name, Ord name) => Eq (RuleDecl name pat) where
+instance (NamedThing name, Ord name) => Eq (RuleDecl name) where
-- Works for IfaceRules only; used when comparing interface file versions
(IfaceRule n1 a1 bs1 f1 es1 rhs1 _) == (IfaceRule n2 a2 bs2 f2 es2 rhs2 _)
= n1==n2 && f1 == f2 && a1==a2 &&
eq_ufBinders emptyEqHsEnv bs1 bs2 (\env ->
eqListBy (eq_ufExpr env) (rhs1:es1) (rhs2:es2))
-instance (NamedThing name, Outputable name, Outputable pat)
- => Outputable (RuleDecl name pat) where
+instance OutputableBndr name => Outputable (RuleDecl name) where
ppr (HsRule name act ns lhs rhs loc)
= sep [text "{-# RULES" <+> doubleQuotes (ftext name) <+> ppr act,
- pp_forall, ppr lhs, equals <+> ppr rhs,
+ pp_forall, pprExpr lhs, equals <+> pprExpr rhs,
text "#-}" ]
where
pp_forall | null ns = empty
ppr (IfaceRuleOut fn rule) = pprCoreRule (ppr fn) rule
-instance Outputable name => Outputable (RuleBndr name) where
+instance OutputableBndr name => Outputable (RuleBndr name) where
ppr (RuleBndr name) = ppr name
ppr (RuleBndrSig name ty) = ppr name <> dcolon <> ppr ty
\end{code}
type DeprecTxt = FastString -- reason/explanation for deprecation
-instance Outputable name => Outputable (DeprecDecl name) where
+instance OutputableBndr name => Outputable (DeprecDecl name) where
ppr (Deprecation thing txt _)
= hsep [text "{-# DEPRECATED", ppr thing, doubleQuotes (ppr txt), text "#-}"]
\end{code}
+
+
+%************************************************************************
+%* *
+ External-core declarations
+%* *
+%************************************************************************
+
+\begin{code}
+data CoreDecl name -- a Core value binding (from 'external Core' input)
+ = CoreDecl name
+ (HsType name)
+ (UfExpr name)
+ SrcLoc
+
+instance OutputableBndr name => Outputable (CoreDecl name) where
+ ppr (CoreDecl var ty rhs loc)
+ = getPprStyle $ \ sty ->
+ hsep [ pprHsVar var, dcolon, ppr ty, ppr rhs ]
+\end{code}
HsExpr HsExpr pprExpr Match GRHSs pprFunBind pprPatBind ;
_declarations_
1 data HsExpr i p;
-1 pprExpr _:_ _forall_ [i p] {Outputable.Outputable i, Outputable.Outputable p} => HsExpr.HsExpr i p -> Outputable.SDoc ;;
+1 pprExpr _:_ _forall_ [i] {Outputable.OutputableBndr i} => HsExpr.HsExpr i -> Outputable.SDoc ;;
1 data Match a b ;
1 data GRHSs a b ;
-1 pprPatBind _:_ _forall_ [i p] {Outputable.Outputable i, Outputable.Outputable p} => p -> HsExpr.GRHSs i p -> Outputable.SDoc ;;
-1 pprFunBind _:_ _forall_ [i p] {Outputable.Outputable i, Outputable.Outputable p} => i -> [HsExpr.Match i p] -> Outputable.SDoc ;;
+1 pprPatBind _:_ _forall_ [i] {Outputable.OutputableBndr i} => HsPat.Pat i -> HsExpr.GRHSs i -> Outputable.SDoc ;;
+1 pprFunBind _:_ _forall_ [i p] {Outputable.OutputableBndr i} => i -> [HsExpr.Match i] -> Outputable.SDoc ;;
__interface HsExpr 1 0 where
__export HsExpr HsExpr pprExpr Match GRHSs pprPatBind pprFunBind ;
-1 data HsExpr i p ;
-1 pprExpr :: __forall [i p] {Outputable.Outputable i, Outputable.Outputable p} => HsExpr.HsExpr i p -> Outputable.SDoc ;
+1 data HsExpr i ;
+1 pprExpr :: __forall [i] {Outputable.OutputableBndr i} => HsExpr.HsExpr i -> Outputable.SDoc ;
-1 data Match a b ;
-1 data GRHSs a b ;
+1 data Match a ;
+1 data GRHSs a ;
-1 pprPatBind :: __forall [i p] {Outputable.Outputable i, Outputable.Outputable p} => p -> HsExpr.GRHSs i p -> Outputable.SDoc ;
-1 pprFunBind :: __forall [i p] {Outputable.Outputable i, Outputable.Outputable p} => i -> [HsExpr.Match i p] -> Outputable.SDoc ;
+1 pprPatBind :: __forall [i] {Outputable.OutputableBndr i} => HsPat.Pat i -> HsExpr.GRHSs i -> Outputable.SDoc ;
+1 pprFunBind :: __forall [i] {Outputable.OutputableBndr i} => i -> [HsExpr.Match i] -> Outputable.SDoc ;
module HsExpr where
-data HsExpr i p
-data Match a b
-data GRHSs a b
+data HsExpr i
+data Match a
+data GRHSs a
-pprExpr :: (Outputable.Outputable i, Outputable.Outputable p) =>
- HsExpr.HsExpr i p -> Outputable.SDoc
+pprExpr :: (Outputable.OutputableBndr i) =>
+ HsExpr.HsExpr i -> Outputable.SDoc
-pprPatBind :: (Outputable.Outputable i, Outputable.Outputable p) =>
- p -> HsExpr.GRHSs i p -> Outputable.SDoc
+pprPatBind :: (Outputable.OutputableBndr i) =>
+ HsPat.Pat i -> HsExpr.GRHSs i -> Outputable.SDoc
-pprFunBind :: (Outputable.Outputable i, Outputable.Outputable p) =>
- i -> [HsExpr.Match i p] -> Outputable.SDoc
+pprFunBind :: (Outputable.OutputableBndr i) =>
+ i -> [HsExpr.Match i] -> Outputable.SDoc
#include "HsVersions.h"
-- friends:
+import HsDecls ( HsDecl )
import HsBinds ( HsBinds(..), nullBinds )
+import HsPat ( Pat )
import HsLit ( HsLit, HsOverLit )
-import BasicTypes ( Fixity(..) )
import HsTypes ( HsType, PostTcType, SyntaxName )
-import HsImpExp ( isOperator )
+import HsImpExp ( isOperator, pprHsVar )
-- others:
import ForeignCall ( Safety )
import PprType ( pprParendType )
-import Type ( Type )
-import Var ( TyVar )
+import Type ( Type )
+import Var ( TyVar, Id )
+import Name ( Name )
import DataCon ( DataCon )
import CStrings ( CLabelString, pprCLabelString )
-import BasicTypes ( IPName, Boxity, tupleParens )
+import BasicTypes ( IPName, Boxity, tupleParens, Fixity(..) )
import SrcLoc ( SrcLoc )
import Outputable
import FastString
%************************************************************************
\begin{code}
-data HsExpr id pat
+data HsExpr id
= HsVar id -- variable
| HsIPVar (IPName id) -- implicit parameter
| HsOverLit HsOverLit -- Overloaded literals; eliminated by type checker
| HsLit HsLit -- Simple (non-overloaded) literals
- | HsLam (Match id pat) -- lambda
- | HsApp (HsExpr id pat) -- application
- (HsExpr id pat)
+ | HsLam (Match id) -- lambda
+ | HsApp (HsExpr id) -- application
+ (HsExpr id)
-- 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 id pat) -- left operand
- (HsExpr id pat) -- operator
+ | OpApp (HsExpr id) -- left operand
+ (HsExpr id) -- operator
Fixity -- Renamer adds fixity; bottom until then
- (HsExpr id pat) -- right operand
+ (HsExpr id) -- right operand
-- We preserve prefix negation and parenthesis for the precedence parser.
-- They are eventually removed by the type checker.
- | NegApp (HsExpr id pat) -- negated expr
+ | NegApp (HsExpr id) -- negated expr
SyntaxName -- Name of 'negate' (see RnEnv.lookupSyntaxName)
- | HsPar (HsExpr id pat) -- parenthesised expr
+ | HsPar (HsExpr id) -- parenthesised expr
- | SectionL (HsExpr id pat) -- operand
- (HsExpr id pat) -- operator
- | SectionR (HsExpr id pat) -- operator
- (HsExpr id pat) -- operand
+ | SectionL (HsExpr id) -- operand
+ (HsExpr id) -- operator
+ | SectionR (HsExpr id) -- operator
+ (HsExpr id) -- operand
- | HsCase (HsExpr id pat)
- [Match id pat]
+ | HsCase (HsExpr id)
+ [Match id]
SrcLoc
- | HsIf (HsExpr id pat) -- predicate
- (HsExpr id pat) -- then part
- (HsExpr id pat) -- else part
+ | HsIf (HsExpr id) -- predicate
+ (HsExpr id) -- then part
+ (HsExpr id) -- else part
SrcLoc
- | HsLet (HsBinds id pat) -- let(rec)
- (HsExpr id pat)
+ | HsLet (HsBinds id) -- let(rec)
+ (HsExpr id)
- | HsWith (HsExpr id pat) -- implicit parameter binding
- [(IPName id, HsExpr id pat)]
+ | HsWith (HsExpr id) -- implicit parameter binding
+ [(IPName id, HsExpr id)]
Bool -- True <=> this was a 'with' binding
-- (tmp, until 'with' is removed)
| HsDo HsDoContext
- [Stmt id pat] -- "do":one or more stmts
+ [Stmt id] -- "do":one or more stmts
[id] -- Ids for [return,fail,>>=,>>]
-- Brutal but simple
-- Before type checking, used for rebindable syntax
| ExplicitList -- syntactic list
PostTcType -- Gives type of components of list
- [HsExpr id pat]
+ [HsExpr id]
| ExplicitPArr -- syntactic parallel array: [:e1, ..., en:]
PostTcType -- type of elements of the parallel array
- [HsExpr id pat]
+ [HsExpr id]
| ExplicitTuple -- tuple
- [HsExpr id pat]
+ [HsExpr id]
-- NB: Unit is ExplicitTuple []
-- for tuples, we can get the types
-- direct from the components
-- Record construction
| RecordCon id -- The constructor
- (HsRecordBinds id pat)
+ (HsRecordBinds id)
| RecordConOut DataCon
- (HsExpr id pat) -- Data con Id applied to type args
- (HsRecordBinds id pat)
+ (HsExpr id) -- Data con Id applied to type args
+ (HsRecordBinds id)
-- Record update
- | RecordUpd (HsExpr id pat)
- (HsRecordBinds id pat)
+ | RecordUpd (HsExpr id)
+ (HsRecordBinds id)
- | RecordUpdOut (HsExpr id pat) -- TRANSLATION
+ | RecordUpdOut (HsExpr id) -- TRANSLATION
Type -- Type of *input* record
Type -- Type of *result* record (may differ from
-- type of input record)
- (HsRecordBinds id pat)
+ (HsRecordBinds id)
| ExprWithTySig -- signature binding
- (HsExpr id pat)
+ (HsExpr id)
(HsType id)
| ArithSeqIn -- arithmetic sequence
- (ArithSeqInfo id pat)
+ (ArithSeqInfo id)
| ArithSeqOut
- (HsExpr id pat) -- (typechecked, of course)
- (ArithSeqInfo id pat)
+ (HsExpr id) -- (typechecked, of course)
+ (ArithSeqInfo id)
| PArrSeqIn -- arith. sequence for parallel array
- (ArithSeqInfo id pat) -- [:e1..e2:] or [:e1, e2..e3:]
+ (ArithSeqInfo id) -- [:e1..e2:] or [:e1, e2..e3:]
| PArrSeqOut
- (HsExpr id pat) -- (typechecked, of course)
- (ArithSeqInfo id pat)
+ (HsExpr id) -- (typechecked, of course)
+ (ArithSeqInfo id)
| HsCCall CLabelString -- call into the C world; string is
- [HsExpr id pat] -- the C function; exprs are the
+ [HsExpr id] -- the C function; exprs are the
-- arguments to pass.
Safety -- True <=> might cause Haskell
-- garbage-collection (must generate
-- until the typechecker gets ahold of it
| HsSCC FastString -- "set cost centre" (_scc_) annotation
- (HsExpr id pat) -- expr whose cost is to be measured
-
+ (HsExpr id) -- expr whose cost is to be measured
+
+ -- MetaHaskell Extensions
+ | HsBracket (HsBracket id)
+
+ | HsBracketOut (HsBracket Name) -- Output of the type checker is the *original*
+ [PendingSplice] -- renamed expression, plus *typechecked* splices
+ -- to be pasted back in by the desugarer
+
+ | HsSplice id (HsExpr id ) -- $z or $(f 4)
+ -- The id is just a unique name to
+ -- identify this splice point
\end{code}
+
These constructors only appear temporarily in the parser.
The renamer translates them into the Right Thing.
| EWildPat -- wildcard
| EAsPat id -- as pattern
- (HsExpr id pat)
+ (HsExpr id)
- | ELazyPat (HsExpr id pat) -- ~ pattern
+ | ELazyPat (HsExpr id) -- ~ pattern
| HsType (HsType id) -- Explicit type argument; e.g f {| Int |} x y
\end{code}
\begin{code}
| TyLam -- TRANSLATION
[TyVar]
- (HsExpr id pat)
+ (HsExpr id)
| TyApp -- TRANSLATION
- (HsExpr id pat) -- generated by Spec
+ (HsExpr id) -- generated by Spec
[Type]
-- DictLam and DictApp are "inverses"
| DictLam
[id]
- (HsExpr id pat)
+ (HsExpr id)
| DictApp
- (HsExpr id pat)
+ (HsExpr id)
[id]
-type HsRecordBinds id pat
- = [(id, HsExpr id pat, Bool)]
- -- True <=> source code used "punning",
- -- i.e. {op1, op2} rather than {op1=e1, op2=e2}
+type PendingSplice = (Name, HsExpr Id) -- Typechecked splices, waiting to be
+ -- pasted back in by the desugarer
\end{code}
+
A @Dictionary@, unless of length 0 or 1, becomes a tuple. A
@ClassDictLam dictvars methods expr@ is, therefore:
\begin{verbatim}
\end{verbatim}
\begin{code}
-instance (Outputable id, Outputable pat) =>
- Outputable (HsExpr id pat) where
+instance OutputableBndr id => Outputable (HsExpr id) where
ppr expr = pprExpr expr
\end{code}
\begin{code}
-pprExpr :: (Outputable id, Outputable pat)
- => HsExpr id pat -> SDoc
+pprExpr :: OutputableBndr id => HsExpr id -> SDoc
-pprExpr e = pprDeeper (ppr_expr e)
+pprExpr e = pprDeeper (ppr_expr e)
pprBinds b = pprDeeper (ppr b)
-ppr_expr (HsVar v)
- -- Put it in parens if it's an operator
- | isOperator v = parens (ppr v)
- | otherwise = ppr v
-
+ppr_expr (HsVar v) = pprHsVar v
ppr_expr (HsIPVar v) = ppr v
ppr_expr (HsLit lit) = ppr lit
ppr_expr (HsOverLit lit) = ppr lit
pp_infixly v
= sep [pp_e1, hsep [pp_v_op, pp_e2]]
where
- pp_v_op | isOperator v = ppr v
- | otherwise = char '`' <> ppr v <> char '`'
+ ppr_v = ppr v
+ pp_v_op | isOperator ppr_v = ppr_v
+ | otherwise = char '`' <> ppr_v <> char '`'
-- Put it in backquotes if it's not an operator already
ppr_expr (NegApp e _) = char '-' <+> pprParendExpr e
= brackets (fsep (punctuate comma (map ppr_expr exprs)))
ppr_expr (ExplicitPArr _ exprs)
- = pabrackets (fsep (punctuate comma (map ppr_expr exprs)))
+ = pa_brackets (fsep (punctuate comma (map ppr_expr exprs)))
ppr_expr (ExplicitTuple exprs boxity)
= tupleParens boxity (sep (punctuate comma (map ppr_expr exprs)))
= brackets (ppr info)
ppr_expr (PArrSeqIn info)
- = pabrackets (ppr info)
+ = pa_brackets (ppr info)
ppr_expr (PArrSeqOut expr info)
- = pabrackets (ppr info)
+ = pa_brackets (ppr info)
ppr_expr EWildPat = char '_'
ppr_expr (ELazyPat e) = char '~' <> pprParendExpr e
= sep [ ptext SLIT("_scc_") <+> doubleQuotes (ftext lbl), pprParendExpr expr ]
ppr_expr (TyLam tyvars expr)
- = hang (hsep [ptext SLIT("/\\"), interppSP tyvars, ptext SLIT("->")])
+ = hang (hsep [ptext SLIT("/\\"),
+ hsep (map (pprBndr LambdaBind) tyvars),
+ ptext SLIT("->")])
4 (ppr_expr expr)
ppr_expr (TyApp expr [ty])
4 (brackets (interpp'SP tys))
ppr_expr (DictLam dictvars expr)
- = hang (hsep [ptext SLIT("\\{-dict-}"), interppSP dictvars, ptext SLIT("->")])
+ = hang (hsep [ptext SLIT("\\{-dict-}"),
+ hsep (map (pprBndr LambdaBind) dictvars),
+ ptext SLIT("->")])
4 (ppr_expr expr)
ppr_expr (DictApp expr [dname])
ppr_expr (HsType id) = ppr id
+ppr_expr (HsSplice n e) = char '$' <> brackets (ppr n) <> pprParendExpr e
+ppr_expr (HsBracket b) = pprHsBracket b
+ppr_expr (HsBracketOut e ps) = ppr e $$ ptext SLIT("where") <+> ppr ps
+
-- add parallel array brackets around a document
--
-pabrackets :: SDoc -> SDoc
-pabrackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]")
+pa_brackets :: SDoc -> SDoc
+pa_brackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]")
\end{code}
Parenthesize unless very simple:
\begin{code}
-pprParendExpr :: (Outputable id, Outputable pat)
- => HsExpr id pat -> SDoc
+pprParendExpr :: OutputableBndr id => HsExpr id -> SDoc
pprParendExpr expr
= let
%************************************************************************
\begin{code}
-pp_rbinds :: (Outputable id, Outputable pat)
- => SDoc
- -> HsRecordBinds id pat -> SDoc
+type HsRecordBinds id = [(id, HsExpr id)]
+
+recBindFields :: HsRecordBinds id -> [id]
+recBindFields rbinds = [field | (field,_) <- rbinds]
+
+pp_rbinds :: OutputableBndr id => SDoc -> HsRecordBinds id -> SDoc
pp_rbinds thing rbinds
= hang thing
4 (braces (sep (punctuate comma (map (pp_rbind) rbinds))))
where
- pp_rbind (v, e, pun_flag)
- = getPprStyle $ \ sty ->
- if pun_flag && userStyle sty then
- ppr v
- else
- hsep [ppr v, char '=', ppr e]
+ pp_rbind (v, e) = hsep [pprBndr LetBind v, char '=', ppr e]
\end{code}
\begin{code}
-pp_ipbinds :: (Outputable id, Outputable pat)
- => [(IPName id, HsExpr id pat)] -> SDoc
+pp_ipbinds :: OutputableBndr id => [(IPName id, HsExpr id)] -> SDoc
pp_ipbinds pairs = hsep (punctuate semi (map pp_item pairs))
where
- pp_item (id,rhs) = ppr id <+> equals <+> ppr_expr rhs
+ pp_item (id,rhs) = pprBndr LetBind id <+> equals <+> ppr_expr rhs
\end{code}
patterns in each equation.
\begin{code}
-data Match id pat
+data Match id
= Match
- [pat] -- The patterns
+ [Pat id] -- The patterns
(Maybe (HsType id)) -- A type signature for the result of the match
-- Nothing after typechecking
- (GRHSs id pat)
+ (GRHSs id)
-- 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
+data GRHSs id
+ = GRHSs [GRHS id] -- Guarded RHSs
+ (HsBinds id) -- The where clause
PostTcType -- Type of RHS (after type checking)
-data GRHS id pat
- = GRHS [Stmt id pat] -- The RHS is the final ResultStmt
- -- I considered using a RetunStmt, but
- -- it printed 'wrong' in error messages
+data GRHS id
+ = GRHS [Stmt id] -- The RHS is the final ResultStmt
SrcLoc
-mkSimpleMatch :: [pat] -> HsExpr id pat -> Type -> SrcLoc -> Match id pat
+mkSimpleMatch :: [Pat id] -> HsExpr id -> Type -> SrcLoc -> Match id
mkSimpleMatch pats rhs rhs_ty locn
= Match pats Nothing (GRHSs (unguardedRHS rhs locn) EmptyBinds rhs_ty)
-unguardedRHS :: HsExpr id pat -> SrcLoc -> [GRHS id pat]
+unguardedRHS :: HsExpr id -> SrcLoc -> [GRHS id]
unguardedRHS rhs loc = [GRHS [ResultStmt rhs loc] loc]
\end{code}
THis is something of a nuisance, but no more.
\begin{code}
-getMatchLoc :: Match id pat -> SrcLoc
+getMatchLoc :: Match id -> SrcLoc
getMatchLoc (Match _ _ (GRHSs (GRHS _ loc : _) _ _)) = loc
\end{code}
We know the list must have at least one @Match@ in it.
\begin{code}
-pprMatches :: (Outputable id, Outputable pat)
- => HsMatchContext id -> [Match id pat] -> SDoc
+pprMatches :: (OutputableBndr id) => HsMatchContext id -> [Match id] -> SDoc
pprMatches ctxt matches = vcat (map (pprMatch ctxt) matches)
-- Exported to HsBinds, which can't see the defn of HsMatchContext
-pprFunBind :: (Outputable id, Outputable pat)
- => id -> [Match id pat] -> SDoc
+pprFunBind :: (OutputableBndr id) => id -> [Match id] -> SDoc
pprFunBind fun matches = pprMatches (FunRhs fun) matches
-- Exported to HsBinds, which can't see the defn of HsMatchContext
-pprPatBind :: (Outputable id, Outputable pat)
- => pat -> GRHSs id pat -> SDoc
+pprPatBind :: (OutputableBndr id)
+ => Pat id -> GRHSs id -> SDoc
pprPatBind pat grhss = sep [ppr pat, nest 4 (pprGRHSs PatBindRhs grhss)]
-pprMatch :: (Outputable id, Outputable pat)
- => HsMatchContext id -> Match id pat -> SDoc
+pprMatch :: OutputableBndr id => HsMatchContext id -> Match id -> SDoc
pprMatch ctxt (Match pats maybe_ty grhss)
= pp_name ctxt <+> sep [sep (map ppr pats),
ppr_maybe_ty,
nest 2 (pprGRHSs ctxt grhss)]
where
- pp_name (FunRhs fun) = ppr fun
+ pp_name (FunRhs fun) = ppr fun -- Not pprBndr; the AbsBinds will
+ -- have printed the signature
pp_name other = empty
ppr_maybe_ty = case maybe_ty of
Just ty -> dcolon <+> ppr ty
Nothing -> empty
-pprGRHSs :: (Outputable id, Outputable pat)
- => HsMatchContext id -> GRHSs id pat -> SDoc
+pprGRHSs :: OutputableBndr id => HsMatchContext id -> GRHSs id -> SDoc
pprGRHSs ctxt (GRHSs grhss binds ty)
= vcat (map (pprGRHS ctxt) grhss)
$$
else text "where" $$ nest 4 (pprDeeper (ppr binds)))
-pprGRHS :: (Outputable id, Outputable pat)
- => HsMatchContext id -> GRHS id pat -> SDoc
+pprGRHS :: OutputableBndr id => HsMatchContext id -> GRHS id -> SDoc
pprGRHS ctxt (GRHS [ResultStmt expr _] locn)
= pp_rhs ctxt expr
%************************************************************************
\begin{code}
-data Stmt id pat
- = BindStmt pat (HsExpr id pat) SrcLoc
- | LetStmt (HsBinds id pat)
- | ResultStmt (HsExpr id pat) SrcLoc -- See notes that follow
- | ExprStmt (HsExpr id pat) PostTcType SrcLoc -- See notes that follow
+data Stmt id
+ = BindStmt (Pat id) (HsExpr id) SrcLoc
+ | LetStmt (HsBinds id)
+ | ResultStmt (HsExpr id) SrcLoc -- See notes that follow
+ | ExprStmt (HsExpr id) PostTcType SrcLoc -- See notes that follow
-- The type is the *element type* of the expression
- | ParStmt [[Stmt id pat]] -- List comp only: parallel set of quals
- | ParStmtOut [([id], [Stmt id pat])] -- PLC after renaming; the ids are the binders
+ | ParStmt [[Stmt id]] -- List comp only: parallel set of quals
+ | ParStmtOut [([id], [Stmt id])] -- PLC after renaming; the ids are the binders
-- bound by the stmts
\end{code}
Array comprehensions are handled like list comprehensions -=chak
\begin{code}
-consLetStmt :: HsBinds id pat -> [Stmt id pat] -> [Stmt id pat]
+consLetStmt :: HsBinds id -> [Stmt id] -> [Stmt id]
consLetStmt EmptyBinds stmts = stmts
consLetStmt binds stmts = LetStmt binds : stmts
\end{code}
\begin{code}
-instance (Outputable id, Outputable pat) =>
- Outputable (Stmt id pat) where
+instance OutputableBndr id => Outputable (Stmt id) where
ppr stmt = pprStmt stmt
pprStmt (BindStmt pat expr _) = hsep [ppr pat, ptext SLIT("<-"), ppr expr]
pprStmt (ParStmtOut stmtss)
= hsep (map (\stmts -> ptext SLIT("| ") <> ppr stmts) stmtss)
-pprDo :: (Outputable id, Outputable pat)
- => HsDoContext -> [Stmt id pat] -> SDoc
+pprDo :: OutputableBndr id => HsDoContext -> [Stmt id] -> SDoc
pprDo DoExpr stmts = hang (ptext SLIT("do")) 2 (vcat (map ppr stmts))
pprDo ListComp stmts = pprComp brackets stmts
-pprDo PArrComp stmts = pprComp pabrackets stmts
+pprDo PArrComp stmts = pprComp pa_brackets stmts
-pprComp :: (Outputable id, Outputable pat)
- => (SDoc -> SDoc) -> [Stmt id pat] -> SDoc
+pprComp :: OutputableBndr id => (SDoc -> SDoc) -> [Stmt id] -> SDoc
pprComp brack stmts = brack $
hang (pprExpr expr <+> char '|')
4 (interpp'SP quals)
%************************************************************************
%* *
+ Template Haskell quotation brackets
+%* *
+%************************************************************************
+
+\begin{code}
+data HsBracket id = ExpBr (HsExpr id)
+ | PatBr (Pat id)
+ | DecBr [HsDecl id]
+ | TypBr (HsType id)
+
+instance OutputableBndr id => Outputable (HsBracket id) where
+ ppr = pprHsBracket
+
+
+pprHsBracket (ExpBr e) = thBrackets empty (ppr e)
+pprHsBracket (PatBr p) = thBrackets (char 'p') (ppr p)
+pprHsBracket (DecBr d) = thBrackets (char 'd') (vcat (map ppr d))
+pprHsBracket (TypBr t) = thBrackets (char 't') (ppr t)
+
+
+thBrackets pp_kind pp_body = char '[' <> pp_kind <> char '|' <+>
+ pp_body <+> ptext SLIT("|]")
+\end{code}
+
+%************************************************************************
+%* *
\subsection{Enumerations and list comprehensions}
%* *
%************************************************************************
\begin{code}
-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)
+data ArithSeqInfo id
+ = From (HsExpr id)
+ | FromThen (HsExpr id)
+ (HsExpr id)
+ | FromTo (HsExpr id)
+ (HsExpr id)
+ | FromThenTo (HsExpr id)
+ (HsExpr id)
+ (HsExpr id)
\end{code}
\begin{code}
-instance (Outputable id, Outputable pat) =>
- Outputable (ArithSeqInfo id pat) where
+instance OutputableBndr id => Outputable (ArithSeqInfo id) 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 Name ( isLexSym )
-import Module ( ModuleName, WhereFrom )
+import Module ( ModuleName )
import Outputable
import FastString
import SrcLoc ( SrcLoc )
+import Char ( isAlpha )
\end{code}
%************************************************************************
\begin{code}
data ImportDecl name
= ImportDecl ModuleName -- module name
- WhereFrom
+ Bool -- True <=> {-# SOURCE #-} import
Bool -- True => qualified
(Maybe ModuleName) -- as Module
(Maybe (Bool, [IE name])) -- (True => hiding, names)
\begin{code}
instance (Outputable name) => Outputable (ImportDecl name) where
ppr (ImportDecl mod from qual as spec _)
- = hang (hsep [ptext SLIT("import"), ppr from,
+ = hang (hsep [ptext SLIT("import"), ppr_imp from,
pp_qual qual, ppr mod, pp_as as])
4 (pp_spec spec)
where
pp_as Nothing = empty
pp_as (Just a) = ptext SLIT("as ") <+> ppr a
+ ppr_imp True = ptext SLIT("{-# SOURCE #-}")
+ ppr_imp False = empty
+
pp_spec Nothing = empty
pp_spec (Just (False, spec))
= parens (interpp'SP spec)
\begin{code}
instance (Outputable name) => Outputable (IE name) where
- ppr (IEVar var) = ppr_var var
+ ppr (IEVar var) = pprHsVar var
ppr (IEThingAbs thing) = ppr thing
ppr (IEThingAll thing) = hcat [ppr thing, text "(..)"]
ppr (IEThingWith thing withs)
- = ppr thing <> parens (fsep (punctuate comma (map ppr_var withs)))
+ = ppr thing <> parens (fsep (punctuate comma (map pprHsVar withs)))
ppr (IEModuleContents mod)
= ptext SLIT("module") <+> ppr mod
-
-ppr_var v | isOperator v = parens (ppr v)
- | otherwise = ppr v
\end{code}
\begin{code}
-isOperator :: Outputable a => a -> Bool
-isOperator v = isLexSym (mkFastString (showSDocUnqual (ppr v)))
- -- We use (showSDoc (ppr v)), rather than isSymOcc (getOccName v) simply so
- -- that we don't need NamedThing in the context of all these functions.
- -- Gruesome, but simple.
+pprHsVar :: Outputable name => name -> SDoc
+pprHsVar v | isOperator ppr_v = parens ppr_v
+ | otherwise = ppr_v
+ where
+ ppr_v = ppr v
+
+isOperator :: SDoc -> Bool
+isOperator ppr_v
+ = case showSDocUnqual ppr_v of
+ ('(':s) -> False -- (), (,) etc
+ ('[':s) -> False -- []
+ ('$':c:s) -> not (isAlpha c) -- Don't treat $d as an operator
+ (':':c:s) -> not (isAlpha c) -- Don't treat :T as an operator
+ (c:s) -> not (isAlpha c) -- Starts with non-alpha
+ other -> False
+ -- We use (showSDoc (ppr v)), rather than isSymOcc (getOccName v) simply so
+ -- that we don't need NamedThing in the context of all these functions.
+ -- Gruesome, but simple.
\end{code}
\begin{code}
module HsPat (
- InPat(..),
- OutPat(..),
+ Pat(..), InPat, OutPat,
+
+ HsConDetails(..), hsConArgs,
+
+ mkPrefixConPat, mkCharLitPat, mkNilPat,
- irrefutablePat, irrefutablePats,
failureFreePat, isWildPat,
patsAreAllCons, isConPat, isSigPat,
patsAreAllLits, isLitPat,
- collectPatBinders, collectOutPatBinders, collectPatsBinders,
+ collectPatBinders, collectPatsBinders,
collectSigTysFromPat, collectSigTysFromPats
) where
#include "HsVersions.h"
--- friends:
-import HsLit ( HsLit, HsOverLit )
-import HsExpr ( HsExpr )
-import HsTypes ( HsType, SyntaxName )
-import BasicTypes ( Fixity, Boxity, tupleParens )
+import {-# SOURCE #-} HsExpr ( HsExpr )
+-- friends:
+import HsLit ( HsLit(HsCharPrim), HsOverLit )
+import HsTypes ( HsType, SyntaxName, PostTcType )
+import BasicTypes ( Boxity, tupleParens )
-- others:
-import Name ( Name )
-import Var ( Id, TyVar )
+import TysWiredIn ( nilDataCon, charDataCon, charTy )
+import Var ( TyVar )
import DataCon ( DataCon, dataConTyCon )
-import Name ( isDataSymOcc, getOccName, NamedThing )
import Maybes ( maybeToBool )
import Outputable
import TyCon ( maybeTyConSingleCon )
import Type ( Type )
\end{code}
-Patterns come in distinct before- and after-typechecking flavo(u)rs.
+
\begin{code}
-data InPat name
- = WildPatIn -- wild card
- | VarPatIn name -- variable
- | LitPatIn HsLit -- literal
- | 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)
- name
- Fixity -- c.f. OpApp in HsExpr
- (InPat name)
+type InPat id = Pat id -- No 'Out' constructors
+type OutPat id = Pat id -- No 'In' constructors
+
+data Pat id
+ = ------------ Simple patterns ---------------
+ WildPat PostTcType -- Wild card
+ | VarPat id -- Variable
+ | LazyPat (Pat id) -- Lazy pattern
+ | AsPat id (Pat id) -- As pattern
+ | ParPat (Pat id) -- Parenthesised pattern
+
+ ------------ Lists, tuples, arrays ---------------
+ | ListPat [Pat id] -- Syntactic list
+ PostTcType -- The type of the elements
+
+ | TuplePat [Pat id] -- Tuple
+ Boxity -- UnitPat is TuplePat []
+
+ | PArrPat [Pat id] -- Syntactic parallel array
+ PostTcType -- The type of the elements
+
+ ------------ Constructor patterns ---------------
+ | ConPatIn id
+ (HsConDetails id (Pat id))
+
+ | ConPatOut DataCon
+ (HsConDetails id (Pat id))
+ Type -- The type of the pattern
+ [TyVar] -- Existentially bound type variables
+ [id] -- Ditto dictionaries
+
+ ------------ Literal and n+k patterns ---------------
+ | LitPat HsLit -- Used for *non-overloaded* literal patterns:
+ -- Int#, Char#, Int, Char, String, etc.
| NPatIn HsOverLit -- Always positive
(Maybe SyntaxName) -- Just (Name of 'negate') for negative
-- patterns, Nothing otherwise
- | NPlusKPatIn name -- n+k pattern
+ | NPatOut HsLit -- Used for literal patterns where there's an equality function to call
+ -- The literal is retained so that the desugarer can readily identify
+ -- equations with identical literal-patterns
+ -- Always HsInteger, HsRat or HsString.
+ -- Always HsInteger, HsRat or HsString.
+ -- *Unlike* NPatIn, for negative literals, the
+ -- literal is acutally negative!
+ Type -- Type of pattern, t
+ (HsExpr id) -- Of type t -> Bool; detects match
+
+ | NPlusKPatIn id -- n+k pattern
HsOverLit -- It'll always be an HsIntegral
SyntaxName -- Name of '-' (see RnEnv.lookupSyntaxName)
- -- We preserve prefix negation and parenthesis for the precedence parser.
-
- | ParPatIn (InPat name) -- parenthesised pattern
-
- | ListPatIn [InPat name] -- syntactic list
- -- must have >= 1 elements
- | PArrPatIn [InPat name] -- syntactic parallel array
- -- must have >= 1 elements
- | TuplePatIn [InPat name] Boxity -- tuple (boxed?)
+ | NPlusKPatOut id
+ Integer
+ (HsExpr id) -- Of type t -> Bool; detects match
+ (HsExpr id) -- Of type t -> t; subtracts k
- | RecPatIn name -- record
- [(name, InPat name, Bool)] -- True <=> source used punning
--- Generics
- | TypePatIn (HsType name) -- Type pattern for generic definitions
+ ------------ Generics ---------------
+ | TypePat (HsType id) -- Type pattern for generic definitions
-- e.g f{| a+b |} = ...
- -- These show up only in class
- -- declarations,
+ -- These show up only in class declarations,
-- and should be a top-level pattern
--- /Generics
-
-data OutPat id
- = WildPat Type -- wild card
- | VarPat id -- variable (type is in the Id)
- | LazyPat (OutPat id) -- lazy pattern
- | AsPat id -- as pattern
- (OutPat id)
-
- | SigPat (OutPat id) -- Pattern p
- Type -- Type, t, of the whole pattern
- (HsExpr id (OutPat id))
- -- Coercion function,
- -- of type t -> typeof(p)
-
- | ListPat -- Syntactic list
- Type -- The type of the elements
- [OutPat id]
- | PArrPat -- Syntactic parallel array
- Type -- The type of the elements
- [OutPat id]
-
- | TuplePat [OutPat id] -- Tuple
- Boxity
- -- UnitPat is TuplePat []
-
- | ConPat DataCon
- Type -- the type of the pattern
- [TyVar] -- Existentially bound type variables
- [id] -- Ditto dictionaries
- [OutPat id]
-
- -- ConOpPats are only used on the input side
-
- | RecPat DataCon -- Record constructor
- Type -- The type of the pattern
- [TyVar] -- Existentially bound type variables
- [id] -- Ditto dictionaries
- [(Id, OutPat id, Bool)] -- True <=> source used punning
-
- | LitPat -- Used for *non-overloaded* literal patterns:
- -- Int#, Char#, Int, Char, String, etc.
- HsLit
- Type -- Type of pattern
-
- | NPat -- Used for literal patterns where there's an equality function to call
- HsLit -- The literal is retained so that
- -- the desugarer can readily identify
- -- equations with identical literal-patterns
- -- Always HsInteger, HsRat or HsString.
- -- *Unlike* NPatIn, for negative literals, the
- -- literal is acutally negative!
- Type -- Type of pattern, t
- (HsExpr id (OutPat id)) -- Of type t -> Bool; detects match
-
- | NPlusKPat id
- Integer
- 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
+ ------------ Pattern type signatures ---------------
+ | SigPatIn (Pat id) -- Pattern with a type signature
+ (HsType id)
+ | SigPatOut (Pat id) -- Pattern p
+ Type -- Type, t, of the whole pattern
+ (HsExpr id) -- Coercion function,
+ -- of type t -> typeof(p)
+
+ ------------ Dictionary patterns (translation only) ---------------
| DictPat -- Used when destructing Dictionaries with an explicit case
[id] -- superclass dicts
[id] -- methods
\end{code}
-Now name in Inpat is not need to be in NAmedThing to be Outputable.
-Needed by ../deSugar/Check.lhs
+HsConDetails is use both for patterns and for data type declarations
+
+\begin{code}
+data HsConDetails id arg
+ = PrefixCon [arg] -- C p1 p2 p3
+ | RecCon [(id, arg)] -- C { x = p1, y = p2 }
+ | InfixCon arg arg -- p1 `C` p2
+
+hsConArgs :: HsConDetails id arg -> [arg]
+hsConArgs (PrefixCon ps) = ps
+hsConArgs (RecCon fs) = map snd fs
+hsConArgs (InfixCon p1 p2) = [p1,p2]
+\end{code}
+
-JJQC-2-12-97
+%************************************************************************
+%* *
+%* Printing patterns
+%* *
+%************************************************************************
\begin{code}
-instance (Outputable name) => Outputable (InPat name) where
- ppr = pprInPat
-
-pprInPat :: (Outputable name) => InPat name -> SDoc
-
-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])
-pprInPat (ParPatIn pat) = parens (pprInPat pat)
-pprInPat (ListPatIn pats) = brackets (interpp'SP pats)
-pprInPat (PArrPatIn pats) = pabrackets (interpp'SP pats)
-pprInPat (TuplePatIn pats bx) = tupleParens bx (interpp'SP pats)
-pprInPat (NPlusKPatIn n k _) = parens (hcat [ppr n, char '+', ppr k])
-pprInPat (NPatIn l _) = ppr l
-
-pprInPat (ConPatIn c pats)
- | null pats = ppr c
- | otherwise = hsep [ppr c, interppSP pats] -- inner ParPats supply the necessary parens.
-
-pprInPat (ConOpPatIn pat1 op fixity pat2)
- = hsep [ppr pat1, ppr op, ppr pat2] -- ParPats put in parens
+instance (OutputableBndr name) => Outputable (Pat name) where
+ ppr = pprPat
+
+pprPat :: (OutputableBndr name) => Pat name -> SDoc
+
+pprPat (VarPat var) -- Print with type info if -dppr-debug is on
+ = getPprStyle $ \ sty ->
+ if debugStyle sty then
+ parens (pprBndr LambdaBind var) -- Could pass the site to pprPat
+ -- but is it worth it?
+ else
+ ppr var
+pprPat (WildPat _) = char '_'
+pprPat (LazyPat pat) = char '~' <> ppr pat
+pprPat (AsPat name pat) = parens (hcat [ppr name, char '@', ppr pat])
+pprPat (ParPat pat) = parens (pprPat pat)
+
+pprPat (ListPat pats _) = brackets (interpp'SP pats)
+pprPat (PArrPat pats _) = pabrackets (interpp'SP pats)
+pprPat (TuplePat pats bx) = tupleParens bx (interpp'SP pats)
+
+pprPat (ConPatIn c details) = pprConPat c details
+pprPat (ConPatOut c details _ _ _) = pprConPat c details
+
+pprPat (LitPat s) = ppr s
+pprPat (NPatIn l _) = ppr l
+pprPat (NPatOut l _ _) = ppr l
+pprPat (NPlusKPatIn n k _) = hcat [ppr n, char '+', ppr k]
+pprPat (NPlusKPatOut n k _ _) = hcat [ppr n, char '+', integer k]
+
+pprPat (TypePat ty) = ptext SLIT("{|") <> ppr ty <> ptext SLIT("|}")
+
+pprPat (SigPatIn pat ty) = ppr pat <+> dcolon <+> ppr ty
+pprPat (SigPatOut pat ty _) = ppr pat <+> dcolon <+> ppr ty
+
+pprPat (DictPat dicts methods)
+ = parens (sep [ptext SLIT("{-dict-}"),
+ brackets (interpp'SP dicts),
+ brackets (interpp'SP methods)])
+
+
+
+pprConPat con (PrefixCon pats) = ppr con <+> interppSP pats -- inner ParPats supply the necessary parens.
+pprConPat con (InfixCon pat1 pat2) = hsep [ppr pat1, ppr con, ppr pat2] -- ParPats put in parens
-- ToDo: use pprSym to print op (but this involves fiddling various
-- contexts & I'm lazy...); *PatIns are *rarely* printed anyway... (WDP)
-
-pprInPat (RecPatIn con rpats)
- = hsep [ppr con, braces (hsep (punctuate comma (map (pp_rpat) rpats)))]
+pprConPat con (RecCon rpats)
+ = ppr con <+> braces (hsep (punctuate comma (map (pp_rpat) rpats)))
where
- pp_rpat (v, _, True) = ppr v
- pp_rpat (v, p, _) = hsep [ppr v, char '=', ppr p]
+ pp_rpat (v, p) = hsep [ppr v, char '=', ppr p]
-pprInPat (TypePatIn ty) = ptext SLIT("{|") <> ppr ty <> ptext SLIT("|}")
-- add parallel array brackets around a document
--
pabrackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]")
\end{code}
-\begin{code}
-instance (NamedThing id, Outputable id) => Outputable (OutPat id) where
- ppr = pprOutPat
-\end{code}
-
-\begin{code}
-pprOutPat (WildPat ty) = char '_'
-pprOutPat (VarPat var) = ppr var
-pprOutPat (LazyPat pat) = hcat [char '~', ppr pat]
-pprOutPat (AsPat name pat)
- = parens (hcat [ppr name, char '@', ppr pat])
-
-pprOutPat (SigPat pat ty _) = ppr pat <+> dcolon <+> ppr ty
-
-pprOutPat (ConPat name ty [] [] [])
- = ppr name
--- Kludge to get infix constructors to come out right
--- when ppr'ing desugar warnings.
-pprOutPat (ConPat name ty tyvars dicts pats)
- = getPprStyle $ \ sty ->
- parens $
- case pats of
- [p1,p2]
- | userStyle sty && isDataSymOcc (getOccName name) ->
- hsep [ppr p1, ppr name, ppr p2]
- _ -> hsep [ppr name, interppSP tyvars, interppSP dicts, interppSP pats]
-
-pprOutPat (ListPat ty pats) = brackets (interpp'SP pats)
-pprOutPat (PArrPat ty pats) = pabrackets (interpp'SP pats)
-pprOutPat (TuplePat pats boxity) = tupleParens boxity (interpp'SP pats)
-
-pprOutPat (RecPat con ty tvs dicts rpats)
- = hsep [ppr con, interppSP tvs, interppSP dicts, braces (hsep (punctuate comma (map (pp_rpat) rpats)))]
- where
- pp_rpat (v, _, True) = ppr v
- pp_rpat (v, p, _) = hsep [ppr v, char '=', ppr p]
+%************************************************************************
+%* *
+%* Building patterns
+%* *
+%************************************************************************
-pprOutPat (LitPat l ty) = ppr l -- ToDo: print more
-pprOutPat (NPat l ty e) = ppr l -- ToDo: print more
-pprOutPat (NPlusKPat n k ty e1 e2) -- ToDo: print more
- = parens (hcat [ppr n, char '+', integer k])
+\begin{code}
+mkPrefixConPat :: DataCon -> [OutPat id] -> Type -> OutPat id
+-- Make a vanilla Prefix constructor pattern
+mkPrefixConPat dc pats ty = ConPatOut dc (PrefixCon pats) ty [] []
-pprOutPat (DictPat dicts methods)
- = parens (sep [ptext SLIT("{-dict-}"),
- brackets (interpp'SP dicts),
- brackets (interpp'SP methods)])
+mkNilPat :: Type -> OutPat id
+mkNilPat ty = mkPrefixConPat nilDataCon [] ty
+mkCharLitPat :: Int -> OutPat id
+mkCharLitPat c = mkPrefixConPat charDataCon [LitPat (HsCharPrim c)] charTy
\end{code}
+
%************************************************************************
%* *
-%* predicates for checking things about pattern-lists in EquationInfo *
+%* Predicates for checking things about pattern-lists in EquationInfo *
%* *
%************************************************************************
+
\subsection[Pat-list-predicates]{Look for interesting things in patterns}
Unlike in the Wadler chapter, where patterns are either ``variables''
The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are.
\begin{code}
-irrefutablePats :: [OutPat id] -> Bool
-irrefutablePats pat_list = all irrefutablePat pat_list
-
-irrefutablePat (AsPat _ pat) = irrefutablePat pat
-irrefutablePat (WildPat _) = True
-irrefutablePat (VarPat _) = True
-irrefutablePat (LazyPat _) = True
-irrefutablePat (DictPat ds ms) = (length ds + length ms) <= 1
-irrefutablePat other = False
-
failureFreePat :: OutPat id -> Bool
failureFreePat (WildPat _) = True
failureFreePat (VarPat _) = True
failureFreePat (LazyPat _) = True
+failureFreePat (ParPat _) = True
failureFreePat (AsPat _ pat) = failureFreePat pat
-failureFreePat (ConPat con tys _ _ pats) = only_con con && all failureFreePat pats
-failureFreePat (RecPat con _ _ _ fields) = only_con con && and [ failureFreePat pat | (_,pat,_) <- fields ]
+
failureFreePat (ListPat _ _) = False
failureFreePat (PArrPat _ _) = False
failureFreePat (TuplePat pats _) = all failureFreePat pats
+
+failureFreePat (ConPatOut con ps _ _ _) = only_con con && failure_free_con ps
+
+failureFreePat (SigPatOut p _ _) = failureFreePat p
+
failureFreePat (DictPat _ _) = True
+
failureFreePat other_pat = False -- Literals, NPat
+failure_free_con (PrefixCon pats) = all failureFreePat pats
+failure_free_con (InfixCon p1 p2) = failureFreePat p1 && failureFreePat p2
+failure_free_con (RecCon fs) = all (failureFreePat . snd) fs
+
only_con con = maybeToBool (maybeTyConSingleCon (dataConTyCon con))
\end{code}
isWildPat (WildPat _) = True
isWildPat other = False
-patsAreAllCons :: [OutPat id] -> Bool
+patsAreAllCons :: [Pat id] -> Bool
patsAreAllCons pat_list = all isConPat pat_list
isConPat (AsPat _ pat) = isConPat pat
-isConPat (ConPat _ _ _ _ _) = True
+isConPat (ConPatIn _ _) = True
+isConPat (ConPatOut _ _ _ _ _) = True
isConPat (ListPat _ _) = True
isConPat (PArrPat _ _) = True
isConPat (TuplePat _ _) = True
-isConPat (RecPat _ _ _ _ _) = True
isConPat (DictPat ds ms) = (length ds + length ms) > 1
isConPat other = False
-isSigPat (SigPat _ _ _) = True
-isSigPat other = False
+isSigPat (SigPatIn _ _) = True
+isSigPat (SigPatOut _ _ _) = True
+isSigPat other = False
-patsAreAllLits :: [OutPat id] -> Bool
+patsAreAllLits :: [Pat id] -> Bool
patsAreAllLits pat_list = all isLitPat pat_list
-isLitPat (AsPat _ pat) = isLitPat pat
-isLitPat (LitPat _ _) = True
-isLitPat (NPat _ _ _) = True
-isLitPat (NPlusKPat _ _ _ _ _) = True
-isLitPat other = False
+isLitPat (AsPat _ pat) = isLitPat pat
+isLitPat (LitPat _) = True
+isLitPat (NPatIn _ _) = True
+isLitPat (NPatOut _ _ _) = True
+isLitPat (NPlusKPatIn _ _ _) = True
+isLitPat (NPlusKPatOut _ _ _ _) = True
+isLitPat other = False
\end{code}
+%************************************************************************
+%* *
+%* Gathering stuff out of patterns
+%* *
+%************************************************************************
+
This function @collectPatBinders@ works with the ``collectBinders''
functions for @HsBinds@, etc. The order in which the binders are
collected is important; see @HsBinds.lhs@.
+It collects the bounds *value* variables in renamed patterns; type variables
+are *not* collected.
+
\begin{code}
-collectPatBinders :: InPat a -> [a]
+collectPatBinders :: Pat a -> [a]
collectPatBinders pat = collect pat []
-collectOutPatBinders :: OutPat a -> [a]
-collectOutPatBinders pat = collectOut pat []
-
-collectPatsBinders :: [InPat a] -> [a]
+collectPatsBinders :: [Pat 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 (WildPat _) bndrs = bndrs
+collect (VarPat var) bndrs = var : bndrs
+collect (LazyPat pat) bndrs = collect pat bndrs
+collect (AsPat a pat) bndrs = a : collect pat bndrs
+collect (ParPat pat) bndrs = collect pat bndrs
+
+collect (ListPat pats _) bndrs = foldr collect bndrs pats
+collect (PArrPat pats _) bndrs = foldr collect bndrs pats
+collect (TuplePat pats _) bndrs = foldr collect bndrs pats
+
+collect (ConPatIn c ps) bndrs = foldr collect bndrs (hsConArgs ps)
+collect (ConPatOut c ps _ _ ds) bndrs = ds ++ foldr collect bndrs (hsConArgs ps)
+
+collect (LitPat _) bndrs = bndrs
collect (NPatIn _ _) bndrs = bndrs
-collect (ConPatIn c pats) bndrs = foldr collect bndrs pats
-collect (ConOpPatIn p1 c f p2) bndrs = collect p1 (collect p2 bndrs)
-collect (ParPatIn pat) bndrs = collect pat bndrs
-collect (ListPatIn pats) bndrs = foldr collect bndrs pats
-collect (PArrPatIn 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
--- Generics
-collect (TypePatIn ty) bndrs = bndrs
--- assume the type variables do not need to be bound
-
--- collect the bounds *value* variables in renamed patterns; type variables
--- are *not* collected
---
-collectOut (WildPat _) bndrs = bndrs
-collectOut (VarPat var) bndrs = var : bndrs
-collectOut (LazyPat pat) bndrs = collectOut pat bndrs
-collectOut (AsPat a pat) bndrs = a : collectOut pat bndrs
-collectOut (ListPat _ pats) bndrs = foldr collectOut bndrs pats
-collectOut (PArrPat _ pats) bndrs = foldr collectOut bndrs pats
-collectOut (TuplePat pats _) bndrs = foldr collectOut bndrs pats
-collectOut (ConPat _ _ _ ds pats) bndrs = ds ++ foldr collectOut bndrs pats
-collectOut (RecPat _ _ _ ds fields) bndrs = ds ++ foldr comb bndrs fields
- where
- comb (_, pat, _) bndrs = collectOut pat bndrs
-collectOut (LitPat _ _) bndrs = bndrs
-collectOut (NPat _ _ _) bndrs = bndrs
-collectOut (NPlusKPat n _ _ _ _) bndrs = n : bndrs
-collectOut (DictPat ids1 ids2) bndrs = ids1 ++ ids2 ++ bndrs
+collect (NPatOut _ _ _) bndrs = bndrs
+
+collect (NPlusKPatIn n _ _) bndrs = n : bndrs
+collect (NPlusKPatOut n _ _ _) bndrs = n : bndrs
+
+collect (SigPatIn pat _) bndrs = collect pat bndrs
+collect (SigPatOut pat _ _) bndrs = collect pat bndrs
+collect (TypePat ty) bndrs = bndrs
+collect (DictPat ids1 ids2) bndrs = ids1 ++ ids2 ++ bndrs
\end{code}
\begin{code}
collectSigTysFromPat :: InPat name -> [HsType name]
collectSigTysFromPat pat = collect_pat pat []
-collect_pat (SigPatIn pat ty) acc = collect_pat pat (ty:acc)
-collect_pat WildPatIn acc = acc
-collect_pat (VarPatIn var) acc = acc
-collect_pat (LitPatIn _) acc = acc
-collect_pat (LazyPatIn pat) acc = collect_pat pat acc
-collect_pat (AsPatIn a pat) acc = collect_pat pat acc
-collect_pat (NPatIn _ _) acc = acc
-collect_pat (NPlusKPatIn n _ _) acc = acc
-collect_pat (ConPatIn c pats) acc = foldr collect_pat acc pats
-collect_pat (ConOpPatIn p1 c f p2) acc = collect_pat p1 (collect_pat p2 acc)
-collect_pat (ParPatIn pat) acc = collect_pat pat acc
-collect_pat (ListPatIn pats) acc = foldr collect_pat acc pats
-collect_pat (PArrPatIn pats) acc = foldr collect_pat acc pats
-collect_pat (TuplePatIn pats _) acc = foldr collect_pat acc pats
-collect_pat (RecPatIn c fields) acc = foldr (\ (f,pat,_) acc -> collect_pat pat acc) acc fields
--- Generics
-collect_pat (TypePatIn ty) acc = ty:acc
+collect_pat (SigPatIn pat ty) acc = collect_pat pat (ty:acc)
+collect_pat (TypePat ty) acc = ty:acc
+
+collect_pat (LazyPat pat) acc = collect_pat pat acc
+collect_pat (AsPat a pat) acc = collect_pat pat acc
+collect_pat (ParPat pat) acc = collect_pat pat acc
+collect_pat (ListPat pats _) acc = foldr collect_pat acc pats
+collect_pat (PArrPat pats _) acc = foldr collect_pat acc pats
+collect_pat (TuplePat pats _) acc = foldr collect_pat acc pats
+collect_pat (ConPatIn c ps) acc = foldr collect_pat acc (hsConArgs ps)
+collect_pat other acc = acc -- Literals, vars, wildcard
\end{code}
module HsTypes,
Fixity, NewOrData,
- collectHsBinders, collectHsOutBinders, collectLocatedHsBinders,
+ collectHsBinders, collectLocatedHsBinders,
collectMonoBinders, collectLocatedMonoBinders,
collectSigTysFromMonoBinds,
- hsModuleName, hsModuleImports
+ hsModule, hsImports
) where
#include "HsVersions.h"
import Name ( NamedThing )
import Outputable
import SrcLoc ( SrcLoc )
-import Module ( ModuleName )
+import Module ( Module )
\end{code}
All we actually declare here is the top-level structure for a module.
\begin{code}
-data HsModule name pat
+data HsModule name
= HsModule
- ModuleName -- module name
+ Module
(Maybe Version) -- source interface version number
(Maybe [IE name]) -- export list; Nothing => export everything
-- Just [] => export *nothing* (???)
-- imported interfaces early on, adding that
-- info to TyDecls/etc; so this list is
-- often empty, downstream.
- [HsDecl name pat] -- Type, class, value, and interface signature decls
+ [HsDecl name] -- Type, class, value, and interface signature decls
(Maybe DeprecTxt) -- reason/explanation for deprecation of this module
SrcLoc
\end{code}
\begin{code}
-instance (NamedThing name, Outputable name, Outputable pat)
- => Outputable (HsModule name pat) where
+instance (NamedThing name, OutputableBndr name)
+ => Outputable (HsModule name) where
ppr (HsModule name iface_version exports imports
decls deprec src_loc)
pp_nonnull [] = empty
pp_nonnull xs = vcat (map ppr xs)
-hsModuleName (HsModule mod_name _ _ _ _ _ _) = mod_name
-hsModuleImports (HsModule mod_name vers exports imports decls deprec src_loc) = imports
+hsModule (HsModule mod _ _ _ _ _ _) = mod
+hsImports (HsModule mod vers exports imports decls deprec src_loc) = imports
\end{code}
it should return @[x, y, f, a, b]@ (remember, order important).
\begin{code}
-collectLocatedHsBinders :: HsBinds name (InPat name) -> [(name,SrcLoc)]
+collectLocatedHsBinders :: HsBinds name -> [(name,SrcLoc)]
collectLocatedHsBinders EmptyBinds = []
collectLocatedHsBinders (MonoBind b _ _)
= collectLocatedMonoBinders b
collectLocatedHsBinders (ThenBinds b1 b2)
= collectLocatedHsBinders b1 ++ collectLocatedHsBinders b2
-collectHsBinders :: HsBinds name (InPat name) -> [name]
+collectHsBinders :: HsBinds name -> [name]
collectHsBinders EmptyBinds = []
collectHsBinders (MonoBind b _ _)
= collectMonoBinders b
collectHsBinders (ThenBinds b1 b2)
= collectHsBinders b1 ++ collectHsBinders b2
--- corresponds to `collectHsBinders', but operates on renamed patterns
---
-collectHsOutBinders :: HsBinds name (OutPat name) -> [name]
-collectHsOutBinders EmptyBinds = []
-collectHsOutBinders (MonoBind b _ _)
- = collectMonoOutBinders b
-collectHsOutBinders (ThenBinds b1 b2)
- = collectHsOutBinders b1 ++ collectHsOutBinders b2
-
-collectLocatedMonoBinders :: MonoBinds name (InPat name) -> [(name,SrcLoc)]
+collectLocatedMonoBinders :: MonoBinds name -> [(name,SrcLoc)]
collectLocatedMonoBinders binds
= go binds []
where
go (FunMonoBind f _ _ loc) acc = (f,loc) : acc
go (AndMonoBinds bs1 bs2) acc = go bs1 (go bs2 acc)
-collectMonoBinders :: MonoBinds name (InPat name) -> [name]
+collectMonoBinders :: MonoBinds name -> [name]
collectMonoBinders binds
= go binds []
where
go (PatMonoBind pat _ loc) acc = collectPatBinders pat ++ acc
go (FunMonoBind f _ _ loc) acc = f : acc
go (AndMonoBinds bs1 bs2) acc = go bs1 (go bs2 acc)
-
--- corresponds to `collectMonoBinders', but operates on renamed patterns
---
-collectMonoOutBinders :: MonoBinds name (OutPat name) -> [name]
-collectMonoOutBinders binds
- = go binds []
- where
- go EmptyMonoBinds acc = acc
- go (PatMonoBind pat _ loc) acc = collectOutPatBinders pat ++ acc
- go (FunMonoBind f _ _ loc) acc = f : acc
- go (AndMonoBinds bs1 bs2) acc = go bs1 (go bs2 acc)
\end{code}
%************************************************************************
Get all the pattern type signatures out of a bunch of bindings
\begin{code}
-collectSigTysFromMonoBinds :: MonoBinds name (InPat name) -> [HsType name]
+collectSigTysFromMonoBinds :: MonoBinds name -> [HsType name]
collectSigTysFromMonoBinds bind
= go bind []
where
, mkHsForAllTy, mkHsDictTy, mkHsIParamTy
, hsTyVarName, hsTyVarNames, replaceTyVarName
- , getHsInstHead
+ , splitHsInstDeclTy
-- Type place holder
, PostTcType, placeHolderType,
import Subst ( substTyWith )
import PprType ( {- instance Outputable Kind -}, pprParendKind, pprKind )
import BasicTypes ( Boxity(..), Arity, IPName, tupleParens )
-import PrelNames ( mkTupConRdrName, listTyConKey, parrTyConKey,
+import PrelNames ( listTyConKey, parrTyConKey,
usOnceTyConKey, usManyTyConKey, hasKey, unboundKey,
usOnceTyConName, usManyTyConName )
-import SrcLoc ( builtinSrcLoc )
+import SrcLoc ( noSrcLoc )
import Util ( eqListBy, lengthIs )
import FiniteMap
import Outputable
placeHolderName :: SyntaxName
placeHolderName = mkInternalName unboundKey
(mkVarOcc FSLIT("syntaxPlaceHolder"))
- builtinSrcLoc
+ noSrcLoc
\end{code}
| HsPArrTy (HsType name) -- Elem. type of parallel array: [:t:]
- | HsTupleTy (HsTupCon name)
+ | HsTupleTy HsTupCon
[HsType name] -- Element types (length gives arity)
| HsOpTy (HsType name) (HsTyOp name) (HsType name)
hsUsMany_Name = HsTyVar usManyTyConName
-----------------------
-data HsTupCon name = HsTupCon name Boxity Arity
+data HsTupCon = HsTupCon Boxity Arity
-instance Eq name => Eq (HsTupCon name) where
- (HsTupCon _ b1 a1) == (HsTupCon _ b2 a2) = b1==b2 && a1==a2
+instance Eq HsTupCon where
+ (HsTupCon b1 a1) == (HsTupCon b2 a2) = b1==b2 && a1==a2
-mkHsTupCon :: NameSpace -> Boxity -> [a] -> HsTupCon RdrName
-mkHsTupCon space boxity args = HsTupCon (mkTupConRdrName space boxity arity) boxity arity
- where
- arity = length args
+mkHsTupCon :: NameSpace -> Boxity -> [a] -> HsTupCon
+mkHsTupCon space boxity args = HsTupCon boxity (length args)
-hsTupParens :: HsTupCon name -> SDoc -> SDoc
-hsTupParens (HsTupCon _ b _) p = tupleParens b p
+hsTupParens :: HsTupCon -> SDoc -> SDoc
+hsTupParens (HsTupCon b _) p = tupleParens b p
-----------------------
-- Combine adjacent for-alls.
\begin{code}
-getHsInstHead :: HsType name -> ([HsTyVarBndr name], (name, [HsType name]))
- -- Split up an instance decl type, returning the 'head' part
-
--- In interface fiels, the type of the decl is held like this:
--- forall a. Foo a -> Baz (T a)
--- so we have to strip off function argument types,
--- as well as the bit before the '=>' (which is always
--- empty in interface files)
---
--- The parser ensures the type will have the right shape.
+splitHsInstDeclTy
+ :: Outputable name
+ => HsType name
+ -> ([HsTyVarBndr name], HsContext name, name, [HsType name])
+ -- Split up an instance decl type, returning the pieces
+
+-- In interface files, the instance declaration head is created
+-- by HsTypes.toHsType, which does not guarantee to produce a
+-- HsForAllTy. For example, if we had the weird decl
+-- instance Foo T => Foo [T]
+-- then we'd get the instance type
+-- Foo T -> Foo [T]
+-- So when colleting the instance context, to be on the safe side
+-- we gather predicate arguments
+--
+-- For source code, the parser ensures the type will have the right shape.
-- (e.g. see ParseUtil.checkInstType)
-getHsInstHead (HsForAllTy (Just tvs) _ tau) = (tvs, get_head1 tau)
-getHsInstHead tau = ([], get_head1 tau)
+splitHsInstDeclTy inst_ty
+ = case inst_ty of
+ HsForAllTy (Just tvs) cxt1 tau
+ -> (tvs, cxt1++cxt2, cls, tys)
+ where
+ (cxt2, cls, tys) = split_tau tau
+
+ other -> ([], cxt2, cls, tys)
+ where
+ (cxt2, cls, tys) = split_tau inst_ty
-get_head1 (HsFunTy _ ty) = get_head1 ty
-get_head1 (HsPredTy (HsClassP cls tys)) = (cls,tys)
+ where
+ split_tau (HsFunTy (HsPredTy p) ty) = (p:ps, cls, tys)
+ where
+ (ps, cls, tys) = split_tau ty
+ split_tau (HsPredTy (HsClassP cls tys)) = ([], cls,tys)
+ split_tau other = pprPanic "splitHsInstDeclTy" (ppr inst_ty)
\end{code}
toHsType ty@(TyConApp tc tys) -- Must be saturated because toHsType's arg is of kind *
| not saturated = generic_case
- | isTupleTyCon tc = HsTupleTy (HsTupCon (getName tc) (tupleTyConBoxity tc) (tyConArity tc)) tys'
+ | isTupleTyCon tc = HsTupleTy (HsTupCon (tupleTyConBoxity tc) (tyConArity tc)) tys'
| tc `hasKey` listTyConKey = HsListTy (head tys')
| tc `hasKey` parrTyConKey = HsPArrTy (head tys')
| tc `hasKey` usOnceTyConKey = hsUsOnce_Name -- must print !, . unqualified
--
-- Binary interface file support.
-module BinIface ( writeBinIface ) where
+module BinIface ( writeBinIface, readBinIface ) where
#include "HsVersions.h"
import HsCore
import HsDecls
import HsBinds
+import HsPat ( HsConDetails(..) )
import TyCon
import Class
import VarEnv
import CostCentre
-import Name ( Name, nameOccName )
+import RdrName ( mkRdrUnqual, mkRdrQual )
+import Name ( Name, nameOccName, nameModule_maybe )
import NameEnv ( NameEnv, lookupNameEnv, nameEnvElts )
+import Module ( moduleName )
import OccName ( OccName )
-import RnMonad ( ParsedIface(..) )
import RnHsSyn
import DriverState ( v_Build_tag )
import CmdLineOpts ( opt_IgnoreIfacePragmas, opt_HiVersion )
-import StringBuffer ( hGetStringBuffer )
import Panic
import SrcLoc
import Binary
import DATA_IOREF ( readIORef )
import EXCEPTION ( throwDyn )
-
import Monad ( when )
+#include "HsVersions.h"
+
+-- ---------------------------------------------------------------------------
+-- We write out a ModIface, but read it in as a ParsedIface.
+-- There are some big differences, and some subtle ones. We do most
+-- of the conversion on the way out, so there is minimal fuss when we
+-- read it back in again (see RnMonad.lhs)
+
+-- The main difference is that all Names in a ModIface are RdrNames in
+-- a ParsedIface, so when writing out a Name in binary we make sure it
+-- is binary-compatible with a RdrName.
+
+-- Other subtle differences:
+-- - pi_mod is a ModuleName, but mi_mod is a Module. Hence we put
+-- Modules as ModuleNames.
+-- - pi_exports and pi_usages, Names have
+-- to be converted to OccNames.
+-- - pi_fixity is a NameEnv in ModIface,
+-- but a list of (Name,Fixity) pairs in ParsedIface.
+-- - versioning is totally different.
+-- - deprecations are different.
+
+writeBinIface :: FilePath -> ModIface -> IO ()
+writeBinIface hi_path mod_iface
+ = putBinFileWithDict hi_path (mi_module mod_iface) mod_iface
+
+readBinIface :: FilePath -> IO ParsedIface
+readBinIface hi_path = getBinFileWithDict hi_path
+
+
+-- %*********************************************************
+-- %* *
+-- All the Binary instances
+-- %* *
+-- %*********************************************************
+
-- BasicTypes
{-! for IPName derive: Binary !-}
{-! for Fixity derive: Binary !-}
{-! for StrictnessMark derive: Binary !-}
{-! for Activation derive: Binary !-}
+instance Binary Name where
+ -- we must print these as RdrNames, because that's how they will be read in
+ put_ bh name
+ = case nameModule_maybe name of
+ Just mod
+ | this_mod == mod -> put_ bh (mkRdrUnqual occ)
+ | otherwise -> put_ bh (mkRdrQual (moduleName mod) occ)
+ _ -> put_ bh (mkRdrUnqual occ)
+ where
+ occ = nameOccName name
+ (this_mod,_,_,_) = getUserData bh
+
+ get bh = error "can't Binary.get a Name"
+
-- NewDemand
{-! for Demand derive: Binary !-}
{-! for Demands derive: Binary !-}
{-! for ConDetails derive: Binary !-}
{-! for BangType derive: Binary !-}
-instance (Binary name) => Binary (TyClDecl name pat) where
+instance (Binary name) => Binary (TyClDecl name) where
put_ bh (IfaceSig name ty idinfo _) = do
putByte bh 0
put_ bh name
lazyPut bh idinfo
put_ bh (ForeignType ae af ag ah) =
error "Binary.put_(TyClDecl): ForeignType"
- put_ bh (TyData ai aj ak al am an ao _) = do
+ put_ bh (TyData ai aj ak al am _ (Just generics) _) = do
putByte bh 2
put_ bh ai
put_ bh aj
put_ bh al
put_ bh am
-- ignore Derivs
- put_ bh ao -- store the SysNames for now (later: derive them)
+ put_ bh generics -- Record whether generics needed or not
put_ bh (TySynonym aq ar as _) = do
putByte bh 3
put_ bh aq
put_ bh ar
put_ bh as
- put_ bh c@(ClassDecl ctxt nm tyvars fds sigs _ sysnames _) = do
+ put_ bh c@(ClassDecl ctxt nm tyvars fds sigs _ _) = do
putByte bh 4
put_ bh ctxt
put_ bh nm
put_ bh fds
put_ bh sigs
-- ignore methods (there should be none)
- put_ bh sysnames
-- ignore SrcLoc
get bh = do
h <- getByte bh
nm <- get bh
tyvars <- get bh
cons <- get bh
- sysnames <- get bh
+ generics <- get bh
return (TyData n_or_d ctx nm tyvars cons
- Nothing sysnames noSrcLoc)
+ Nothing (Just generics) noSrcLoc)
3 -> do
aq <- get bh
ar <- get bh
tyvars <- get bh
fds <- get bh
sigs <- get bh
- sysnames <- get bh
return (ClassDecl ctxt nm tyvars fds sigs
- Nothing sysnames noSrcLoc)
+ Nothing noSrcLoc)
instance (Binary name) => Binary (ConDecl name) where
- put_ bh (ConDecl aa ab ac ad ae _) = do
+ put_ bh (ConDecl aa ac ad ae _) = do
put_ bh aa
- put_ bh ab
put_ bh ac
put_ bh ad
put_ bh ae
-- ignore SrcLoc
get bh = do
aa <- get bh
- ab <- get bh
ac <- get bh
ad <- get bh
ae <- get bh
- return (ConDecl aa ab ac ad ae noSrcLoc)
+ return (ConDecl aa ac ad ae noSrcLoc)
-instance (Binary name) => Binary (InstDecl name pat) where
+instance (Binary name) => Binary (InstDecl name) where
put_ bh (InstDecl aa _ _ ad _) = do
put_ bh aa
-- ignore MonoBinds
ad <- get bh
return (InstDecl aa EmptyMonoBinds [{-no sigs-}] ad noSrcLoc)
-instance (Binary name) => Binary (RuleDecl name pat) where
+instance (Binary name) => Binary (RuleDecl name) where
put_ bh (IfaceRule ag ah ai aj ak al _) = do
put_ bh ag
put_ bh ah
{-! for IsDupdCC derive: Binary !-}
{-! for CostCentre derive: Binary !-}
--- ---------------------------------------------------------------------------
--- HscTypes
--- NB. we write out a ModIface, but read it in as a ParsedIface.
--- There are some big differences, and some subtle ones. We do most
--- of the conversion on the way out, so there is minimal fuss when we
--- read it back in again (see RnMonad.lhs)
-
--- The main difference is that all Names in a ModIface are RdrNames in
--- a ParsedIface, so when writing out a Name in binary we make sure it
--- is binary-compatible with a RdrName.
-
--- Other subtle differences:
--- - pi_mod is a ModuleName, but mi_mod is a Module. Hence we put
--- Modules as ModuleNames.
--- - pi_exports and pi_usages, Names have
--- to be converted to OccNames.
--- - pi_fixity is a NameEnv in ModIface,
--- but a list of (Name,Fixity) pairs in ParsedIface.
--- - versioning is totally different.
--- - deprecations are different.
instance Binary ModIface where
put_ bh iface = do
pi_deprecs = deprecs })
-- ----------------------------------------------------------------------------
--- Writing a binary interface
-
-writeBinIface :: FilePath -> ModIface -> IO ()
-writeBinIface hi_path mod_iface =
- putBinFileWithDict hi_path (mi_module mod_iface) mod_iface
-
--- ----------------------------------------------------------------------------
{-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-}
-- Imported from other files :-
ab <- get bh
return (Fixity aa ab)
+instance (Binary name) => Binary (FixitySig name) where
+ put_ bh (FixitySig aa ab _) = do
+ put_ bh aa
+ put_ bh ab
+ get bh = do
+ aa <- get bh
+ ab <- get bh
+ return (FixitySig aa ab noSrcLoc)
+
instance (Binary name) => Binary (IPName name) where
put_ bh (Dupable aa) = do
putByte bh 0
ac <- get bh
return (IfaceTyVar ab ac)
-instance (Binary name) => Binary (HsTupCon name) where
- put_ bh (HsTupCon aa ab ac) = do
- put_ bh aa
+instance Binary HsTupCon where
+ put_ bh (HsTupCon ab ac) = do
put_ bh ab
put_ bh ac
get bh = do
- aa <- get bh
ab <- get bh
ac <- get bh
- return (HsTupCon aa ab ac)
+ return (HsTupCon ab ac)
instance (Binary name) => Binary (HsTyOp name) where
put_ bh HsArrow = putByte bh 0
ab <- get bh
return (BangType aa ab)
-instance (Binary name) => Binary (ConDetails name) where
- put_ bh (VanillaCon aa) = do
+instance (Binary name, Binary arg) => Binary (HsConDetails name arg) where
+ put_ bh (PrefixCon aa) = do
putByte bh 0
put_ bh aa
put_ bh (InfixCon ab ac) = do
h <- getByte bh
case h of
0 -> do aa <- get bh
- return (VanillaCon aa)
+ return (PrefixCon aa)
1 -> do ab <- get bh
ac <- get bh
return (InfixCon ab ac)
return (NormalCC aa ab ac ad)
_ -> do ae <- get bh
return (AllCafsCC ae)
-
-
#ifdef JAVA
import JavaGen ( javaGen )
+import OccurAnal ( occurAnalyseBinds )
import qualified PrintJava
import OccurAnal ( occurAnalyseBinds )
#endif
+import FastString ( unpackFS )
import DriverState ( v_HCHeader )
-import TyCon ( TyCon )
import Id ( Id )
-import CoreSyn ( CoreBind )
import StgSyn ( StgBinding )
import AbsCSyn ( AbstractC )
import PprAbsC ( dumpRealC, writeRealC )
-import Module ( Module )
+import HscTypes ( ModGuts(..), ModGuts, ForeignStubs(..), typeEnvTyCons )
import CmdLineOpts
import ErrUtils ( dumpIfSet_dyn, showPass )
import Outputable
import Pretty ( Mode(..), printDoc )
import CmdLineOpts ( DynFlags, HscLang(..), dopt_OutName )
-
-import DATA_IOREF ( readIORef )
-
+import DATA_IOREF ( readIORef, writeIORef )
import Monad ( when )
import IO
\end{code}
\begin{code}
codeOutput :: DynFlags
- -> Module
- -> [TyCon] -- Local tycons
- -> [CoreBind] -- Core bindings
+ -> ModGuts
-> [(StgBinding,[Id])] -- The STG program with SRTs
- -> SDoc -- C stubs for foreign exported functions
- -> SDoc -- Header file prototype for foreign exported functions
- -> AbstractC -- Compiled abstract C
+ -> AbstractC -- Compiled abstract C
-> IO (Bool{-stub_h_exists-}, Bool{-stub_c_exists-})
-codeOutput dflags mod_name tycons core_binds stg_binds
- c_code h_code flat_abstractC
- = -- You can have C (c_output) or assembly-language (ncg_output),
+codeOutput dflags
+ (ModGuts {mg_module = mod_name,
+ mg_types = type_env,
+ mg_foreign = foreign_stubs,
+ mg_binds = core_binds})
+ stg_binds flat_abstractC
+ = let
+ tycons = typeEnvTyCons type_env
+ in
+ -- You can have C (c_output) or assembly-language (ncg_output),
-- but not both. [Allowing for both gives a space leak on
-- flat_abstractC. WDP 94/10]
do { showPass dflags "CodeOutput"
; let filenm = dopt_OutName dflags
- ; stub_names <- outputForeignStubs dflags c_code h_code
+ ; stub_names <- outputForeignStubs dflags foreign_stubs
; case dopt_HscLang dflags of
HscInterpreted -> return stub_names
HscAsm -> outputAsm dflags filenm flat_abstractC
%************************************************************************
\begin{code}
-outputForeignStubs dflags c_code h_code
+ -- Turn the list of headers requested in foreign import
+ -- declarations into a string suitable for emission into generated
+ -- C code...
+mkForeignHeaders headers
+ = unlines
+ . map (\fname -> "#include \"" ++ unpackFS fname ++ "\"")
+ . reverse
+ $ headers
+
+outputForeignStubs :: DynFlags -> ForeignStubs
+ -> IO (Bool, -- Header file created
+ Bool) -- C file created
+outputForeignStubs dflags NoStubs = return (False, False)
+outputForeignStubs dflags (ForeignStubs h_code c_code hdrs _)
= do
dumpIfSet_dyn dflags Opt_D_dump_foreign
"Foreign export header file" stub_h_output_d
dumpIfSet_dyn dflags Opt_D_dump_foreign
"Foreign export stubs" stub_c_output_d
- hc_header <- readIORef v_HCHeader
+ -- Extend the list of foreign headers (used in outputC)
+ fhdrs <- readIORef v_HCHeader
+ let new_fhdrs = fhdrs ++ mkForeignHeaders hdrs
+ writeIORef v_HCHeader new_fhdrs
stub_c_file_exists
<- outputForeignStubs_help (hscStubCOutName dflags) stub_c_output_w
("#define IN_STG_CODE 0\n" ++
- hc_header ++
+ new_fhdrs ++
"#include \"RtsAPI.h\"\n" ++
cplusplus_hdr)
cplusplus_ftr
- -- we're adding the default hc_header to the stub file, but this
+ -- We're adding the default hc_header to the stub file, but this
-- isn't really HC code, so we need to define IN_STG_CODE==0 to
-- avoid the register variables etc. being enabled.
All pretty arbitrary:
\begin{code}
-mAX_TUPLE_SIZE = (37 :: Int)
+mAX_TUPLE_SIZE = (62 :: Int) -- Should really match the number
+ -- of decls in Data.Tuple
mAX_CONTEXT_REDUCTION_DEPTH = (20 :: Int)
\end{code}
-----------------------------------------------------------------------------
--- $Id: DriverFlags.hs,v 1.101 2002/08/29 15:44:15 simonmar Exp $
+-- $Id: DriverFlags.hs,v 1.102 2002/09/13 15:02:34 simonpj Exp $
--
-- Driver flags
--
-----------------------------------------------------------------------------
-- RTS Hooks
+#if __GLASGOW_HASKELL__ >= 504
+foreign import ccall unsafe "setHeapSize" setHeapSize :: Int -> IO ()
+foreign import ccall unsafe "enableTimingStats" enableTimingStats :: IO ()
+#else
foreign import "setHeapSize" unsafe setHeapSize :: Int -> IO ()
foreign import "enableTimingStats" unsafe enableTimingStats :: IO ()
+#endif
-----------------------------------------------------------------------------
-- Build the Hsc static command line opts
-----------------------------------------------------------------------------
--- $Id: DriverMkDepend.hs,v 1.21 2002/08/29 15:44:15 simonmar Exp $
+-- $Id: DriverMkDepend.hs,v 1.22 2002/09/13 15:02:34 simonpj Exp $
--
-- GHC Driver
--
import DriverFlags
import SysTools ( newTempName )
import qualified SysTools
-import Module ( ModuleName, moduleNameUserString, isHomeModule )
+import Module ( ModuleName, ModLocation(..),
+ moduleNameUserString, isHomeModule )
import Finder ( findModuleDep )
-import HscTypes ( ModuleLocation(..) )
import Util ( global )
import Panic
-----------------------------------------------------------------------------
--- $Id: DriverPhases.hs,v 1.21 2002/07/05 20:30:38 sof Exp $
+-- $Id: DriverPhases.hs,v 1.22 2002/09/13 15:02:34 simonpj Exp $
--
-- GHC Driver
--
module DriverPipeline (
- -- interfaces for the batch-mode driver
- genPipeline, runPipeline, pipeLoop,
+ -- Interfaces for the batch-mode driver
+ genPipeline, runPipeline, pipeLoop, staticLink,
- -- interfaces for the compilation manager (interpreted/batch-mode)
- preprocess, compile, CompResult(..),
+ -- Interfaces for the compilation manager (interpreted/batch-mode)
+ preprocess,
+ compile, CompResult(..),
+ link,
- -- batch-mode linking interface
- doLink,
-- DLL building
doMkDLL
) where
#include "HsVersions.h"
import Packages
-import CmTypes
import GetImports
import DriverState
import DriverUtil
import Config
import Panic
import Util
+import BasicTypes ( SuccessFlag(..) )
import Maybes ( expectJust )
import ParserCoreUtils ( getCoreModuleName )
import Monad
import Maybe
+
+-----------------------------------------------------------------------------
+-- Pre process
+-----------------------------------------------------------------------------
+
+-- Just preprocess a file, put the result in a temp. file (used by the
+-- compilation manager during the summary phase).
+
+preprocess :: FilePath -> IO FilePath
+preprocess filename =
+ ASSERT(haskellish_src_file filename)
+ do restoreDynFlags -- Restore to state of last save
+ let fInfo = (filename, getFileSuffix filename)
+ pipeline <- genPipeline (StopBefore Hsc) ("preprocess") False
+ defaultHscLang fInfo
+ (fn,_) <- runPipeline pipeline fInfo
+ False{-no linking-} False{-no -o flag-}
+ return fn
+
+-----------------------------------------------------------------------------
+-- Compile
+-----------------------------------------------------------------------------
+
+-- Compile a single module, under the control of the compilation manager.
+--
+-- This is the interface between the compilation manager and the
+-- compiler proper (hsc), where we deal with tedious details like
+-- reading the OPTIONS pragma from the source file, and passing the
+-- output of hsc through the C compiler.
+
+-- The driver sits between 'compile' and 'hscMain', translating calls
+-- to the former into calls to the latter, and results from the latter
+-- into results from the former. It does things like preprocessing
+-- the .hs file if necessary, and compiling up the .stub_c files to
+-- generate Linkables.
+
+-- NB. No old interface can also mean that the source has changed.
+
+compile :: GhciMode -- distinguish batch from interactive
+ -> Module
+ -> ModLocation
+ -> Bool -- True <=> source unchanged
+ -> Bool -- True <=> have object
+ -> Maybe ModIface -- old interface, if available
+ -> HomePackageTable -- For home-module stuff
+ -> PersistentCompilerState -- persistent compiler state
+ -> IO CompResult
+
+data CompResult
+ = CompOK PersistentCompilerState -- Updated PCS
+ ModDetails -- New details
+ ModIface -- New iface
+ (Maybe Linkable) -- New code; Nothing => compilation was not reqd
+ -- (old code is still valid)
+
+ | CompErrs PersistentCompilerState -- Updated PCS
+
+
+compile ghci_mode this_mod location
+ source_unchanged have_object
+ old_iface hpt pcs = do
+
+ dyn_flags <- restoreDynFlags -- Restore to the state of the last save
+
+
+ showPass dyn_flags
+ (showSDoc (text "Compiling" <+> ppr this_mod))
+
+ let verb = verbosity dyn_flags
+ let input_fn = expectJust "compile:hs" (ml_hs_file location)
+ let input_fnpp = expectJust "compile:hspp" (ml_hspp_file location)
+ let mod_name = moduleName this_mod
+
+ when (verb >= 2) (hPutStrLn stderr ("compile: input file " ++ input_fnpp))
+
+ opts <- getOptionsFromSource input_fnpp
+ processArgs dynamic_flags opts []
+ dyn_flags <- getDynFlags
+
+ let hsc_lang = hscLang dyn_flags
+ (basename, _) = splitFilename input_fn
+
+ keep_hc <- readIORef v_Keep_hc_files
+#ifdef ILX
+ keep_il <- readIORef v_Keep_il_files
+#endif
+ keep_s <- readIORef v_Keep_s_files
+
+ output_fn <-
+ case hsc_lang of
+ HscAsm | keep_s -> return (basename ++ '.':phaseInputExt As)
+ | otherwise -> newTempName (phaseInputExt As)
+ HscC | keep_hc -> return (basename ++ '.':phaseInputExt HCc)
+ | otherwise -> newTempName (phaseInputExt HCc)
+ HscJava -> newTempName "java" -- ToDo
+#ifdef ILX
+ HscILX | keep_il -> return (basename ++ '.':phaseInputExt Ilasm)
+ | otherwise -> newTempName (phaseInputExt Ilx2Il)
+#endif
+ HscInterpreted -> return (error "no output file")
+ HscNothing -> return (error "no output file")
+
+ let dyn_flags' = dyn_flags { hscOutName = output_fn,
+ hscStubCOutName = basename ++ "_stub.c",
+ hscStubHOutName = basename ++ "_stub.h",
+ extCoreName = basename ++ ".hcr" }
+
+ -- figure out which header files to #include in a generated .hc file
+ c_includes <- getPackageCIncludes
+ cmdline_includes <- dynFlag cmdlineHcIncludes -- -#include options
+
+ let cc_injects = unlines (map mk_include
+ (c_includes ++ reverse cmdline_includes))
+ mk_include h_file =
+ case h_file of
+ '"':_{-"-} -> "#include "++h_file
+ '<':_ -> "#include "++h_file
+ _ -> "#include \""++h_file++"\""
+
+ writeIORef v_HCHeader cc_injects
+
+ -- -no-recomp should also work with --make
+ do_recomp <- readIORef v_Recomp
+ let source_unchanged' = source_unchanged && do_recomp
+ hsc_env = HscEnv { hsc_mode = ghci_mode,
+ hsc_dflags = dyn_flags',
+ hsc_HPT = hpt }
+
+ -- run the compiler
+ hsc_result <- hscMain hsc_env pcs this_mod location
+ source_unchanged' have_object old_iface
+
+ case hsc_result of
+ HscFail pcs -> return (CompErrs pcs)
+
+ HscNoRecomp pcs details iface -> return (CompOK pcs details iface Nothing)
+
+ HscRecomp pcs details iface
+ stub_h_exists stub_c_exists maybe_interpreted_code -> do
+ let
+ maybe_stub_o <- compileStub dyn_flags' stub_c_exists
+ let stub_unlinked = case maybe_stub_o of
+ Nothing -> []
+ Just stub_o -> [ DotO stub_o ]
+
+ (hs_unlinked, unlinked_time) <-
+ case hsc_lang of
+
+ -- in interpreted mode, just return the compiled code
+ -- as our "unlinked" object.
+ HscInterpreted ->
+ case maybe_interpreted_code of
+#ifdef GHCI
+ Just comp_bc -> do tm <- getClockTime
+ return ([BCOs comp_bc], tm)
+#endif
+ Nothing -> panic "compile: no interpreted code"
+
+ -- we're in batch mode: finish the compilation pipeline.
+ _other -> do pipe <- genPipeline (StopBefore Ln) "" True
+ hsc_lang (output_fn, getFileSuffix output_fn)
+ -- runPipeline takes input_fn so it can split off
+ -- the base name and use it as the base of
+ -- the output object file.
+ let (basename, suffix) = splitFilename input_fn
+ (o_file,_) <-
+ pipeLoop pipe (output_fn, getFileSuffix output_fn)
+ False False
+ basename suffix
+ o_time <- getModificationTime o_file
+ return ([DotO o_file], o_time)
+
+ let linkable = LM unlinked_time mod_name
+ (hs_unlinked ++ stub_unlinked)
+
+ return (CompOK pcs details iface (Just linkable))
+
-----------------------------------------------------------------------------
--- genPipeline
+-- stub .h and .c files (for foreign export support)
+
+compileStub dflags stub_c_exists
+ | not stub_c_exists = return Nothing
+ | stub_c_exists = do
+ -- compile the _stub.c file w/ gcc
+ let stub_c = hscStubCOutName dflags
+ pipeline <- genPipeline (StopBefore Ln) "" True defaultHscLang (stub_c,"c")
+ (stub_o,_) <- runPipeline pipeline (stub_c,"c") False{-no linking-}
+ False{-no -o option-}
+ return (Just stub_o)
+
+
+-----------------------------------------------------------------------------
+-- Link
+-----------------------------------------------------------------------------
+
+link :: GhciMode -- interactive or batch
+ -> DynFlags -- dynamic flags
+ -> Bool -- attempt linking in batch mode?
+ -> [Linkable]
+ -> IO SuccessFlag
+
+-- For the moment, in the batch linker, we don't bother to tell doLink
+-- which packages to link -- it just tries all that are available.
+-- batch_attempt_linking should only be *looked at* in batch mode. It
+-- should only be True if the upsweep was successful and someone
+-- exports main, i.e., we have good reason to believe that linking
+-- will succeed.
+
+-- There will be (ToDo: are) two lists passed to link. These
+-- correspond to
--
+-- 1. The list of all linkables in the current home package. This is
+-- used by the batch linker to link the program, and by the interactive
+-- linker to decide which modules from the previous link it can
+-- throw away.
+-- 2. The list of modules on which we just called "compile". This list
+-- is used by the interactive linker to decide which modules need
+-- to be actually linked this time around (or unlinked and re-linked
+-- if the module was recompiled).
+
+link mode dflags batch_attempt_linking linkables
+ = do let verb = verbosity dflags
+ when (verb >= 3) $ do
+ hPutStrLn stderr "link: linkables are ..."
+ hPutStrLn stderr (showSDoc (vcat (map ppr linkables)))
+
+ res <- link' mode dflags batch_attempt_linking linkables
+
+ when (verb >= 3) (hPutStrLn stderr "link: done")
+
+ return res
+
+#ifdef GHCI
+link' Interactive dflags batch_attempt_linking linkables
+ = do showPass dflags "Not Linking...(demand linker will do the job)"
+ -- linkModules dflags linkables
+ return Succeeded
+#endif
+
+link' Batch dflags batch_attempt_linking linkables
+ | batch_attempt_linking
+ = do when (verb >= 1) $
+ hPutStrLn stderr "ghc: linking ..."
+
+ -- Don't showPass in Batch mode; doLink will do that for us.
+ staticLink (concatMap getOfiles linkables)
+
+ -- staticLink only returns if it succeeds
+ return Succeeded
+
+ | otherwise
+ = do when (verb >= 3) $ do
+ hPutStrLn stderr "link(batch): upsweep (partially) failed OR"
+ hPutStrLn stderr " Main.main not exported; not linking."
+ return Succeeded
+ where
+ verb = verbosity dflags
+ getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)
+
+
+
+-----------------------------------------------------------------------------
+-- genPipeline: Pipeline construction
+-----------------------------------------------------------------------------
+
-- Herein is all the magic about which phases to run in which order, whether
-- the intermediate files should be in TMPDIR or in the current directory,
-- what the suffix of the intermediate files should be, etc.
else
getImportsFromFile input_fn
- -- build a ModuleLocation to pass to hscMain.
+ -- build a ModLocation to pass to hscMain.
(mod, location')
<- mkHomeModuleLocn mod_name basename (basename ++ '.':suff)
hscStubCOutName = basename ++ "_stub.c",
hscStubHOutName = basename ++ "_stub.h",
extCoreName = basename ++ ".hcr" }
+ hsc_env = HscEnv { hsc_mode = OneShot,
+ hsc_dflags = dyn_flags',
+ hsc_HPT = emptyHomePackageTable }
+
-- run the compiler!
pcs <- initPersistentCompilerState
- result <- hscMain OneShot
- dyn_flags' mod
+ result <- hscMain hsc_env pcs mod
location{ ml_hspp_file=Just input_fn }
source_unchanged
False
Nothing -- no iface
- emptyModuleEnv -- HomeSymbolTable
- emptyModuleEnv -- HomeIfaceTable
- pcs
case result of {
-- wrapper script calling the binary. Currently, we need this only in
-- a parallel way (i.e. in GUM), because PVM expects the binary in a
-- central directory.
--- This is called from doLink below, after linking. I haven't made it
+-- This is called from staticLink below, after linking. I haven't made it
-- a separate phase to minimise interfering with other modules, and
-- we don't need the generality of a phase (MoveBinary is always
-- done after linking and makes only sense in a parallel setup) -- HWL
++ unwords flags)) (ExitFailure 1))
-----------------------------------------------------------------------------
--- Linking
+-- Static linking, of .o files
-doLink :: [String] -> IO ()
-doLink o_files = do
+staticLink :: [String] -> IO ()
+staticLink o_files = do
verb <- getVerbFlag
static <- readIORef v_Static
no_hs_main <- readIORef v_NoHsMain
-- opts from -optl-<blah>
extra_ld_opts <- getStaticOpts v_Opt_l
- rts_pkg <- getPackageDetails ["rts"]
- std_pkg <- getPackageDetails ["std"]
+ [rts_pkg, std_pkg] <- getPackageDetails [rtsPackage, preludePackage]
+
let extra_os = if static || no_hs_main
then []
- else [ head (library_dirs (head rts_pkg)) ++ "/Main.dll_o",
- head (library_dirs (head std_pkg)) ++ "/PrelMain.dll_o" ]
+ else [ head (library_dirs rts_pkg) ++ "/Main.dll_o",
+ head (library_dirs std_pkg) ++ "/PrelMain.dll_o" ]
(md_c_flags, _) <- machdepCCOpts
SysTools.runLink ( [ SysTools.Option verb
-- opts from -optdll-<blah>
extra_ld_opts <- getStaticOpts v_Opt_dll
- rts_pkg <- getPackageDetails ["rts"]
- std_pkg <- getPackageDetails ["std"]
+ [rts_pkg, std_pkg] <- getPackageDetails [rtsPackage, stdPackage]
let extra_os = if static || no_hs_main
then []
- else [ head (library_dirs (head rts_pkg)) ++ "/Main.dll_o",
- head (library_dirs (head std_pkg)) ++ "/PrelMain.dll_o" ]
+ else [ head (library_dirs rts_pkg) ++ "/Main.dll_o",
+ head (library_dirs std_pkg) ++ "/PrelMain.dll_o" ]
(md_c_flags, _) <- machdepCCOpts
SysTools.runMkDLL
else [ "--export-all" ])
++ extra_ld_opts
))
-
------------------------------------------------------------------------------
--- Just preprocess a file, put the result in a temp. file (used by the
--- compilation manager during the summary phase).
-
-preprocess :: FilePath -> IO FilePath
-preprocess filename =
- ASSERT(haskellish_src_file filename)
- do restoreDynFlags -- Restore to state of last save
- let fInfo = (filename, getFileSuffix filename)
- pipeline <- genPipeline (StopBefore Hsc) ("preprocess") False
- defaultHscLang fInfo
- (fn,_) <- runPipeline pipeline fInfo
- False{-no linking-} False{-no -o flag-}
- return fn
-
------------------------------------------------------------------------------
--- Compile a single module, under the control of the compilation manager.
---
--- This is the interface between the compilation manager and the
--- compiler proper (hsc), where we deal with tedious details like
--- reading the OPTIONS pragma from the source file, and passing the
--- output of hsc through the C compiler.
-
--- The driver sits between 'compile' and 'hscMain', translating calls
--- to the former into calls to the latter, and results from the latter
--- into results from the former. It does things like preprocessing
--- the .hs file if necessary, and compiling up the .stub_c files to
--- generate Linkables.
-
--- NB. No old interface can also mean that the source has changed.
-
-compile :: GhciMode -- distinguish batch from interactive
- -> ModSummary -- summary, including source
- -> Bool -- True <=> source unchanged
- -> Bool -- True <=> have object
- -> Maybe ModIface -- old interface, if available
- -> HomeSymbolTable -- for home module ModDetails
- -> HomeIfaceTable -- for home module Ifaces
- -> PersistentCompilerState -- persistent compiler state
- -> IO CompResult
-
-data CompResult
- = CompOK PersistentCompilerState -- updated PCS
- ModDetails -- new details (HST additions)
- ModIface -- new iface (HIT additions)
- (Maybe Linkable)
- -- new code; Nothing => compilation was not reqd
- -- (old code is still valid)
-
- | CompErrs PersistentCompilerState -- updated PCS
-
-
-compile ghci_mode summary source_unchanged have_object
- old_iface hst hit pcs = do
- dyn_flags <- restoreDynFlags -- Restore to the state of the last save
-
-
- showPass dyn_flags
- (showSDoc (text "Compiling" <+> ppr (modSummaryName summary)))
-
- let verb = verbosity dyn_flags
- let location = ms_location summary
- let input_fn = expectJust "compile:hs" (ml_hs_file location)
- let input_fnpp = expectJust "compile:hspp" (ml_hspp_file location)
-
- when (verb >= 2) (hPutStrLn stderr ("compile: input file " ++ input_fnpp))
-
- opts <- getOptionsFromSource input_fnpp
- processArgs dynamic_flags opts []
- dyn_flags <- getDynFlags
-
- let hsc_lang = hscLang dyn_flags
- (basename, _) = splitFilename input_fn
-
- keep_hc <- readIORef v_Keep_hc_files
-#ifdef ILX
- keep_il <- readIORef v_Keep_il_files
-#endif
- keep_s <- readIORef v_Keep_s_files
-
- output_fn <-
- case hsc_lang of
- HscAsm | keep_s -> return (basename ++ '.':phaseInputExt As)
- | otherwise -> newTempName (phaseInputExt As)
- HscC | keep_hc -> return (basename ++ '.':phaseInputExt HCc)
- | otherwise -> newTempName (phaseInputExt HCc)
- HscJava -> newTempName "java" -- ToDo
-#ifdef ILX
- HscILX | keep_il -> return (basename ++ '.':phaseInputExt Ilasm)
- | otherwise -> newTempName (phaseInputExt Ilx2Il)
-#endif
- HscInterpreted -> return (error "no output file")
- HscNothing -> return (error "no output file")
-
- let dyn_flags' = dyn_flags { hscOutName = output_fn,
- hscStubCOutName = basename ++ "_stub.c",
- hscStubHOutName = basename ++ "_stub.h",
- extCoreName = basename ++ ".hcr" }
-
- -- figure out which header files to #include in a generated .hc file
- c_includes <- getPackageCIncludes
- cmdline_includes <- dynFlag cmdlineHcIncludes -- -#include options
-
- let cc_injects = unlines (map mk_include
- (c_includes ++ reverse cmdline_includes))
- mk_include h_file =
- case h_file of
- '"':_{-"-} -> "#include "++h_file
- '<':_ -> "#include "++h_file
- _ -> "#include \""++h_file++"\""
-
- writeIORef v_HCHeader cc_injects
-
- -- -no-recomp should also work with --make
- do_recomp <- readIORef v_Recomp
- let source_unchanged' = source_unchanged && do_recomp
-
- -- run the compiler
- hsc_result <- hscMain ghci_mode dyn_flags'
- (ms_mod summary) location
- source_unchanged' have_object old_iface hst hit pcs
-
- case hsc_result of
- HscFail pcs -> return (CompErrs pcs)
-
- HscNoRecomp pcs details iface -> return (CompOK pcs details iface Nothing)
-
- HscRecomp pcs details iface
- stub_h_exists stub_c_exists maybe_interpreted_code -> do
- let
- maybe_stub_o <- compileStub dyn_flags' stub_c_exists
- let stub_unlinked = case maybe_stub_o of
- Nothing -> []
- Just stub_o -> [ DotO stub_o ]
-
- (hs_unlinked, unlinked_time) <-
- case hsc_lang of
-
- -- in interpreted mode, just return the compiled code
- -- as our "unlinked" object.
- HscInterpreted ->
- case maybe_interpreted_code of
-#ifdef GHCI
- Just (bcos,itbl_env) -> do tm <- getClockTime
- return ([BCOs bcos itbl_env], tm)
-#endif
- Nothing -> panic "compile: no interpreted code"
-
- -- we're in batch mode: finish the compilation pipeline.
- _other -> do pipe <- genPipeline (StopBefore Ln) "" True
- hsc_lang (output_fn, getFileSuffix output_fn)
- -- runPipeline takes input_fn so it can split off
- -- the base name and use it as the base of
- -- the output object file.
- let (basename, suffix) = splitFilename input_fn
- (o_file,_) <-
- pipeLoop pipe (output_fn, getFileSuffix output_fn)
- False False
- basename suffix
- o_time <- getModificationTime o_file
- return ([DotO o_file], o_time)
-
- let linkable = LM unlinked_time (modSummaryName summary)
- (hs_unlinked ++ stub_unlinked)
-
- return (CompOK pcs details iface (Just linkable))
-
-
------------------------------------------------------------------------------
--- stub .h and .c files (for foreign export support)
-
-compileStub dflags stub_c_exists
- | not stub_c_exists = return Nothing
- | stub_c_exists = do
- -- compile the _stub.c file w/ gcc
- let stub_c = hscStubCOutName dflags
- pipeline <- genPipeline (StopBefore Ln) "" True defaultHscLang (stub_c,"c")
- (stub_o,_) <- runPipeline pipeline (stub_c,"c") False{-no linking-}
- False{-no -o option-}
- return (Just stub_o)
-----------------------------------------------------------------------------
--- $Id: DriverState.hs,v 1.81 2002/08/29 15:44:15 simonmar Exp $
+-- $Id: DriverState.hs,v 1.82 2002/09/13 15:02:34 simonpj Exp $
--
-- Settings for the driver
--
import SysTools ( getTopDir )
import ParsePkgConf ( loadPackageConfig )
-import Packages ( PackageConfig(..), mungePackagePaths )
+import Packages ( PackageConfig(..), PackageConfigMap,
+ PackageName, mkPackageName, packageNameString,
+ packageDependents,
+ mungePackagePaths, emptyPkgMap, extendPkgMap, lookupPkg,
+ preludePackage, rtsPackage, haskell98Package )
import CmdLineOpts
import DriverPhases
import DriverUtil
-----------------------------------------------------------------------------
-- Packages
--- package list is maintained in dependency order
-GLOBAL_VAR(v_Packages, ("haskell98":"base":"rts":[]), [String])
+------------------------
+-- The PackageConfigMap is read in from the configuration file
+-- It doesn't change during a run
+GLOBAL_VAR(v_Package_details, emptyPkgMap, PackageConfigMap)
readPackageConf :: String -> IO ()
readPackageConf conf_file = do
- proto_pkg_details <- loadPackageConfig conf_file
- top_dir <- getTopDir
- let pkg_details = mungePackagePaths top_dir proto_pkg_details
- old_pkg_details <- readIORef v_Package_details
+ proto_pkg_configs <- loadPackageConfig conf_file
+ top_dir <- getTopDir
+ old_pkg_map <- readIORef v_Package_details
- let -- new package override old ones
- new_pkg_names = map name pkg_details
- filtered_old_pkg_details =
- filter (\p -> name p `notElem` new_pkg_names) old_pkg_details
+ let pkg_configs = mungePackagePaths top_dir proto_pkg_configs
+ new_pkg_map = extendPkgMap old_pkg_map pkg_configs
+
+ writeIORef v_Package_details new_pkg_map
- writeIORef v_Package_details (pkg_details ++ filtered_old_pkg_details)
+getPackageConfigMap :: IO PackageConfigMap
+getPackageConfigMap = readIORef v_Package_details
+
+
+------------------------
+-- The package list reflects what was given as command-line options,
+-- plus their dependent packages.
+-- It is maintained in dependency order;
+-- earlier ones depend on later ones, but not vice versa
+GLOBAL_VAR(v_Packages, initPackageList, [PackageName])
+
+getPackages :: IO [PackageName]
+getPackages = readIORef v_Packages
+
+initPackageList = [haskell98Package,
+ preludePackage,
+ rtsPackage]
addPackage :: String -> IO ()
addPackage package
- = do pkg_details <- readIORef v_Package_details
- case lookupPkg package pkg_details of
- Nothing -> throwDyn (CmdLineError ("unknown package name: " ++ package))
- Just details -> do
- ps <- readIORef v_Packages
- unless (package `elem` ps) $ do
- mapM_ addPackage (package_deps details)
- ps <- readIORef v_Packages
- writeIORef v_Packages (package:ps)
+ = do { pkg_details <- getPackageConfigMap
+ ; ps <- readIORef v_Packages
+ ; ps' <- add_package pkg_details ps (mkPackageName package)
+ -- Throws an exception if it fails
+ ; writeIORef v_Packages ps' }
+
+add_package :: PackageConfigMap -> [PackageName]
+ -> PackageName -> IO [PackageName]
+add_package pkg_details ps p
+ | p `elem` ps -- Check if we've already added this package
+ = return ps
+ | Just details <- lookupPkg pkg_details p
+ = do { -- Add the package's dependents first
+ ps' <- foldM (add_package pkg_details) ps
+ (packageDependents details)
+ ; return (p : ps') }
+
+ | otherwise
+ = throwDyn (CmdLineError ("unknown package name: " ++ packageNameString p))
getPackageImportPath :: IO [String]
getPackageImportPath = do
#endif
getPackageInfo :: IO [PackageConfig]
-getPackageInfo = do
- ps <- readIORef v_Packages
- getPackageDetails ps
+getPackageInfo = do ps <- getPackages
+ getPackageDetails ps
-getPackageDetails :: [String] -> IO [PackageConfig]
+getPackageDetails :: [PackageName] -> IO [PackageConfig]
getPackageDetails ps = do
- pkg_details <- readIORef v_Package_details
- return [ pkg | p <- ps, Just pkg <- [ lookupPkg p pkg_details ] ]
-
-GLOBAL_VAR(v_Package_details, [], [PackageConfig])
+ pkg_details <- getPackageConfigMap
+ return [ pkg | Just pkg <- map (lookupPkg pkg_details) ps ]
-lookupPkg :: String -> [PackageConfig] -> Maybe PackageConfig
-lookupPkg nm ps
- = case [p | p <- ps, name p == nm] of
- [] -> Nothing
- (p:_) -> Just p
-----------------------------------------------------------------------------
-- Ways
-----------------------------------------------------------------------------
--- $Id: DriverUtil.hs,v 1.33 2002/08/29 15:44:15 simonmar Exp $
+-- $Id: DriverUtil.hs,v 1.34 2002/09/13 15:02:34 simonpj Exp $
--
-- Utils for the driver
--
\begin{code}
module ErrUtils (
- ErrMsg, WarnMsg, Message, Messages, errorsFound, warningsFound,
+ ErrMsg, WarnMsg, Message,
+ Messages, errorsFound, warningsFound, emptyMessages,
addShortErrLocLine, addShortWarnLocLine,
addErrLocHdrLine, addWarnLocHdrLine, dontAddErrLoc,
printError,
ghcExit,
doIfSet, doIfSet_dyn,
- dumpIfSet, dumpIfSet_core, dumpIfSet_dyn, dumpIfSet_dyn_or,
+ dumpIfSet, dumpIfSet_core, dumpIfSet_dyn, dumpIfSet_dyn_or, mkDumpDoc,
showPass
) where
#include "HsVersions.h"
-import Bag ( Bag, bagToList, isEmptyBag )
+import Bag ( Bag, bagToList, isEmptyBag, emptyBag )
import SrcLoc ( SrcLoc, noSrcLoc, isGoodSrcLoc )
import Util ( sortLt )
import Outputable
+import qualified Pretty
import CmdLineOpts ( DynFlags(..), DynFlag(..), dopt )
import List ( replicate )
\end{code}
\begin{code}
-type MsgWithLoc = (SrcLoc, SDoc)
+type MsgWithLoc = (SrcLoc, Pretty.Doc)
+ -- The SrcLoc is used for sorting errors into line-number order
+ -- NB Pretty.Doc not SDoc: we deal with the printing style (in ptic
+ -- whether to qualify an External Name) at the error occurrence
type ErrMsg = MsgWithLoc
type WarnMsg = MsgWithLoc
type Message = SDoc
-addShortErrLocLine :: SrcLoc -> Message -> ErrMsg
-addErrLocHdrLine :: SrcLoc -> Message -> Message -> ErrMsg
-addWarnLocHdrLine :: SrcLoc -> Message -> Message -> ErrMsg
-addShortWarnLocLine :: SrcLoc -> Message -> WarnMsg
-
-addShortErrLocLine locn rest_of_err_msg
- | isGoodSrcLoc locn = (locn, hang (ppr locn <> colon) 4
- rest_of_err_msg)
- | otherwise = (locn, rest_of_err_msg)
-
-addErrLocHdrLine locn hdr rest_of_err_msg
- = ( locn
- , hang (ppr locn <> colon<+> hdr)
- 4 rest_of_err_msg
- )
-
-addWarnLocHdrLine locn hdr rest_of_err_msg
- = ( locn
- , hang (ppr locn <> colon <+> ptext SLIT("Warning:") <+> hdr)
- 4 (rest_of_err_msg)
- )
-
-addShortWarnLocLine locn rest_of_err_msg
- | isGoodSrcLoc locn = (locn, hang (ppr locn <> colon) 4
- (ptext SLIT("Warning:") <+> rest_of_err_msg))
- | otherwise = (locn, rest_of_err_msg)
+addShortErrLocLine :: SrcLoc -> PrintUnqualified -> Message -> ErrMsg
+addShortWarnLocLine :: SrcLoc -> PrintUnqualified -> Message -> WarnMsg
+ -- Used heavily by renamer/typechecker
+ -- Be refined about qualification, return an ErrMsg
-dontAddErrLoc :: Message -> ErrMsg
-dontAddErrLoc msg = (noSrcLoc, msg)
+addErrLocHdrLine :: SrcLoc -> Message -> Message -> Message
+addWarnLocHdrLine :: SrcLoc -> Message -> Message -> Message
+ -- Used by Lint and other system stuff
+ -- Always print qualified, return a Message
+
+addShortErrLocLine locn print_unqual msg
+ = (locn, doc (mkErrStyle print_unqual))
+ where
+ doc = mkErrDoc locn msg
+
+addShortWarnLocLine locn print_unqual msg
+ = (locn, doc (mkErrStyle print_unqual))
+ where
+ doc = mkWarnDoc locn msg
+addErrLocHdrLine locn hdr msg
+ = mkErrDoc locn (hdr $$ msg)
+
+addWarnLocHdrLine locn hdr msg
+ = mkWarnDoc locn (hdr $$ msg)
+
+dontAddErrLoc :: Message -> ErrMsg
+dontAddErrLoc msg = (noSrcLoc, msg defaultErrStyle)
+
+mkErrDoc locn msg
+ | isGoodSrcLoc locn = hang (ppr locn <> colon) 4 msg
+ | otherwise = msg
+
+mkWarnDoc locn msg
+ | isGoodSrcLoc locn = hang (ppr locn <> colon) 4 warn_msg
+ | otherwise = warn_msg
+ where
+ warn_msg = ptext SLIT("Warning:") <+> msg
\end{code}
\begin{code}
\begin{code}
type Messages = (Bag WarnMsg, Bag ErrMsg)
+emptyMessages :: Messages
+emptyMessages = (emptyBag, emptyBag)
+
errorsFound :: Messages -> Bool
errorsFound (warns, errs) = not (isEmptyBag errs)
warningsFound :: Messages -> Bool
warningsFound (warns, errs) = not (isEmptyBag warns)
-printErrorsAndWarnings :: PrintUnqualified -> Messages -> IO ()
+printErrorsAndWarnings :: Messages -> IO ()
-- Don't print any warnings if there are errors
-printErrorsAndWarnings unqual (warns, errs)
+printErrorsAndWarnings (warns, errs)
| no_errs && no_warns = return ()
- | no_errs = printErrs unqual (pprBagOfWarnings warns)
- | otherwise = printErrs unqual (pprBagOfErrors errs)
+ | no_errs = printErrs (pprBagOfWarnings warns)
+ | otherwise = printErrs (pprBagOfErrors errs)
where
no_warns = isEmptyBag warns
no_errs = isEmptyBag errs
-pprBagOfErrors :: Bag ErrMsg -> SDoc
+pprBagOfErrors :: Bag ErrMsg -> Pretty.Doc
pprBagOfErrors bag_of_errors
- = vcat [text "" $$ p | (_,p) <- sorted_errs ]
+ = Pretty.vcat [Pretty.text "" Pretty.$$ p | (_,p) <- sorted_errs ]
where
bag_ls = bagToList bag_of_errors
sorted_errs = sortLt occ'ed_before bag_ls
occ'ed_before (a,_) (b,_) = LT == compare a b
-pprBagOfWarnings :: Bag WarnMsg -> SDoc
+pprBagOfWarnings :: Bag WarnMsg -> Pretty.Doc
pprBagOfWarnings bag_of_warns = pprBagOfErrors bag_of_warns
\end{code}
dumpIfSet :: Bool -> String -> SDoc -> IO ()
dumpIfSet flag hdr doc
| not flag = return ()
- | otherwise = printDump (dump hdr doc)
+ | otherwise = printDump (mkDumpDoc hdr doc)
dumpIfSet_core :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
dumpIfSet_core dflags flag hdr doc
| dopt flag dflags
|| verbosity dflags >= 4
- || dopt Opt_D_verbose_core2core dflags = printDump (dump hdr doc)
+ || dopt Opt_D_verbose_core2core dflags = printDump (mkDumpDoc hdr doc)
| otherwise = return ()
dumpIfSet_dyn :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn dflags flag hdr doc
| dopt flag dflags || verbosity dflags >= 4
= if flag `elem` [Opt_D_dump_stix, Opt_D_dump_asm]
- then printForC stdout (dump hdr doc)
- else printDump (dump hdr doc)
+ then printForC stdout (mkDumpDoc hdr doc)
+ else printDump (mkDumpDoc hdr doc)
| otherwise
= return ()
dumpIfSet_dyn_or dflags flags hdr doc
| or [dopt flag dflags | flag <- flags]
|| verbosity dflags >= 4
- = printDump (dump hdr doc)
+ = printDump (mkDumpDoc hdr doc)
| otherwise = return ()
-dump hdr doc
+mkDumpDoc hdr doc
= vcat [text "",
line <+> text hdr <+> line,
doc,
\begin{code}
module Finder (
initFinder, -- :: [PackageConfig] -> IO (),
- findModule, -- :: ModuleName -> IO (Maybe (Module, ModuleLocation))
- findModuleDep, -- :: ModuleName -> Bool -> IO (Maybe (Module, ModuleLocation))
- findPackageModule, -- :: ModuleName -> IO (Maybe (Module, ModuleLocation))
+ findModule, -- :: ModuleName -> IO (Maybe (Module, ModLocation))
+ findModuleDep, -- :: ModuleName -> Bool -> IO (Maybe (Module, ModLocation))
+ findPackageModule, -- :: ModuleName -> IO (Maybe (Module, ModLocation))
mkHomeModuleLocn, -- :: ModuleName -> String -> FilePath
- -- -> IO ModuleLocation
+ -- -> IO ModLocation
emptyHomeDirCache, -- :: IO ()
flushPackageCache -- :: [PackageConfig] -> IO ()
) where
#include "HsVersions.h"
-import HscTypes ( ModuleLocation(..) )
+import Module ( Module, ModLocation(..), ModuleName,
+ moduleNameUserString, mkHomeModule, mkPackageModule
+ )
import Packages ( PackageConfig(..) )
import DriverPhases
import DriverState
import DriverUtil
-import Module
import FastString
import Config
emptyHomeDirCache :: IO ()
emptyHomeDirCache = return ()
-findModule :: ModuleName -> IO (Maybe (Module, ModuleLocation))
+findModule :: ModuleName -> IO (Maybe (Module, ModLocation))
findModule name = findModuleDep name False
-findModuleDep :: ModuleName -> Bool -> IO (Maybe (Module, ModuleLocation))
+findModuleDep :: ModuleName -> Bool -> IO (Maybe (Module, ModLocation))
findModuleDep name is_source
= do { j <- maybeHomeModule name is_source
; case j of
Nothing -> findPackageMod name False is_source
}
-maybeHomeModule :: ModuleName -> Bool -> IO (Maybe (Module, ModuleLocation))
+maybeHomeModule :: ModuleName -> Bool -> IO (Maybe (Module, ModLocation))
maybeHomeModule mod_name is_source = do
home_path <- readIORef v_Import_paths
hisuf <- readIORef v_Hi_suf
mkHiOnlyModuleLocn mod_name hi_file =
return
( mkHomeModule mod_name
- , ModuleLocation{ ml_hspp_file = Nothing
+ , ModLocation{ ml_hspp_file = Nothing
, ml_hs_file = Nothing
, ml_hi_file = hi_file
, ml_obj_file = Nothing
o_file <- odir_ify (basename ++ '.':phaseInputExt Ln) >>= osuf_ify
return (mkHomeModule mod_name,
- ModuleLocation{ ml_hspp_file = Nothing
+ ModLocation{ ml_hspp_file = Nothing
, ml_hs_file = Just source_fn
, ml_hi_file = hi
, ml_obj_file = Just o_file
findPackageMod :: ModuleName
-> Bool
-> Bool
- -> IO (Maybe (Module, ModuleLocation))
+ -> IO (Maybe (Module, ModLocation))
findPackageMod mod_name hiOnly is_source = do
pkgs <- getPackageInfo
retPackageModule mod_name mbFName path =
return ( mkPackageModule mod_name
- , ModuleLocation{ ml_hspp_file = Nothing
+ , ModLocation{ ml_hspp_file = Nothing
, ml_hs_file = mbFName
, ml_hi_file = path ++ '.':package_hisuf
, ml_obj_file = Nothing
])))
where
-findPackageModule :: ModuleName -> IO (Maybe (Module, ModuleLocation))
+findPackageModule :: ModuleName -> IO (Maybe (Module, ModLocation))
findPackageModule mod_name = findPackageMod mod_name True False
searchPathExts :: [FilePath]
-> String
- -> [(String, FilePath -> String -> IO (Module, ModuleLocation))]
- -> IO (Maybe (Module, ModuleLocation))
+ -> [(String, FilePath -> String -> IO (Module, ModLocation))]
+ -> IO (Maybe (Module, ModLocation))
searchPathExts path basename exts = search path
where
search [] = return Nothing
-----------------------------------------------------------------------------
--- $Id: GetImports.hs,v 1.9 2002/07/16 06:42:04 sof Exp $
+-- $Id: GetImports.hs,v 1.10 2002/09/13 15:02:34 simonpj Exp $
--
-- GHC Driver program
--
\section[GHC_Main]{Main driver for Glasgow Haskell compiler}
\begin{code}
-module HscMain ( HscResult(..), hscMain,
+module HscMain (
+ HscResult(..), hscMain, initPersistentCompilerState
#ifdef GHCI
- hscStmt, hscThing, hscModuleContents,
+ , hscStmt, hscTcExpr, hscThing,
+ , compileExpr
#endif
- initPersistentCompilerState ) where
+ ) where
#include "HsVersions.h"
#ifdef GHCI
-import Interpreter
-import ByteCodeGen ( byteCodeGen )
+import TcHsSyn ( TypecheckedHsExpr )
+import CodeOutput ( outputForeignStubs )
+import ByteCodeGen ( byteCodeGen, coreExprToBCOs )
+import Linker ( HValue, linkExpr )
import TidyPgm ( tidyCoreExpr )
import CorePrep ( corePrepExpr )
-import Rename ( renameStmt, renameRdrName, slurpIface )
-import RdrName ( rdrNameOcc, setRdrNameOcc )
+import Flattening ( flattenExpr )
+import TcRnDriver ( tcRnStmt, tcRnExpr, tcRnThing )
import RdrHsSyn ( RdrNameStmt )
-import OccName ( dataName, tcClsName,
- occNameSpace, setOccNameSpace )
import Type ( Type )
-import Id ( Id, idName, setGlobalIdDetails )
-import IdInfo ( GlobalIdDetails(VanillaGlobal) )
-import Name ( isInternalName )
-import NameEnv ( lookupNameEnv )
-import Module ( lookupModuleEnv )
-import RdrName ( rdrEnvElts )
import PrelNames ( iNTERACTIVE )
import StringBuffer ( stringToStringBuffer )
-import Maybes ( catMaybes )
-
-import List ( nub )
#endif
import HsSyn
-import RdrName ( mkRdrOrig )
+import RdrName ( nameRdrName )
import Id ( idName )
import IdInfo ( CafInfo(..), CgInfoEnv, CgInfo(..) )
import StringBuffer ( hGetStringBuffer, freeStringBuffer )
import Parser
import Lex ( ParseResult(..), ExtFlags(..), mkPState )
import SrcLoc ( mkSrcLoc )
-import Finder ( findModule )
-import Rename ( checkOldIface, renameModule, renameExtCore,
- closeIfaceDecls, RnResult(..) )
+import TcRnDriver ( checkOldIface, tcRnModule, tcRnExtCore, tcRnIface )
import Rules ( emptyRuleBase )
import PrelInfo ( wiredInThingEnv, wiredInThings )
import PrelRules ( builtinRules )
-import PrelNames ( knownKeyNames, gHC_PRIM_Name )
-import MkIface ( mkFinalIface )
-import TcModule
+import PrelNames ( knownKeyNames )
+import MkIface ( mkIface )
import InstEnv ( emptyInstEnv )
import Desugar
-import Flattening ( flatten, flattenExpr )
+import Flattening ( flatten )
import SimplCore
import CoreUtils ( coreBindsSize )
import TidyPgm ( tidyCorePgm )
import CoreToStg ( coreToStg )
import SimplStg ( stg2stg )
import CodeGen ( codeGen )
-import CodeOutput ( codeOutput, outputForeignStubs )
+import CodeOutput ( codeOutput )
-import Module ( ModuleName, moduleName, mkHomeModule )
+import Module ( ModuleName, moduleName )
import CmdLineOpts
-import DriverState ( v_HCHeader )
import DriverPhases ( isExtCore_file )
import ErrUtils ( dumpIfSet_dyn, showPass, printError )
import UniqSupply ( mkSplitUniqSupply )
import OccName ( OccName )
import Name ( Name, nameModule, nameOccName, getName )
import NameEnv ( emptyNameEnv, mkNameEnv )
-import Module ( Module )
+import NameSet ( emptyNameSet )
+import Module ( Module, ModLocation(..), showModMsg )
import FastString
import Maybes ( expectJust )
-import Util ( seqList )
import DATA_IOREF ( newIORef, readIORef, writeIORef )
import UNSAFE_IO ( unsafePerformIO )
ModIface -- new iface (if any compilation was done)
Bool -- stub_h exists
Bool -- stub_c exists
-#ifdef GHCI
- (Maybe ([UnlinkedBCO],ItblEnv)) -- interpreted code, if any
-#else
- (Maybe ()) -- no interpreted code whatsoever
-#endif
+ (Maybe CompiledByteCode)
-- no errors or warnings; the individual passes
-- (parse/rename/typecheck) print messages themselves
hscMain
- :: GhciMode
- -> DynFlags
+ :: HscEnv
+ -> PersistentCompilerState -- IN: persistent compiler state
-> Module
- -> ModuleLocation -- location info
+ -> ModLocation -- location info
-> Bool -- True <=> source unchanged
-> Bool -- True <=> have an object file (for msgs only)
-> Maybe ModIface -- old interface, if available
- -> HomeSymbolTable -- for home module ModDetails
- -> HomeIfaceTable
- -> PersistentCompilerState -- IN: persistent compiler state
-> IO HscResult
-hscMain ghci_mode dflags mod location source_unchanged have_object
- maybe_old_iface hst hit pcs
- = {-# SCC "hscMain" #-}
- do {
- showPass dflags ("Checking old interface for hs = "
- ++ show (ml_hs_file location)
- ++ ", hspp = " ++ show (ml_hspp_file location));
-
- (pcs_ch, errs_found, (recomp_reqd, maybe_checked_iface))
- <- _scc_ "checkOldIface"
- checkOldIface ghci_mode dflags hit hst pcs mod (ml_hi_file location)
- source_unchanged maybe_old_iface;
-
- if errs_found then
- return (HscFail pcs_ch)
- else do {
+hscMain hsc_env pcs mod location
+ source_unchanged have_object maybe_old_iface
+ = do {
+ (pcs_ch, maybe_chk_result) <- _scc_ "checkOldIface"
+ checkOldIface hsc_env pcs mod
+ (ml_hi_file location)
+ source_unchanged maybe_old_iface;
+ case maybe_chk_result of {
+ Nothing -> return (HscFail pcs_ch) ;
+ Just (recomp_reqd, maybe_checked_iface) -> do {
let no_old_iface = not (isJust maybe_checked_iface)
what_next | recomp_reqd || no_old_iface = hscRecomp
| otherwise = hscNoRecomp
- ;
- what_next ghci_mode dflags have_object mod location
- maybe_checked_iface hst hit pcs_ch
- }}
+ ; what_next hsc_env pcs_ch have_object
+ mod location maybe_checked_iface
+ }}}
--- we definitely expect to have the old interface available
-hscNoRecomp ghci_mode dflags have_object
- mod location (Just old_iface) hst hit pcs_ch
- | ghci_mode == OneShot
+
+-- hscNoRecomp definitely expects to have the old interface available
+hscNoRecomp hsc_env pcs_ch have_object
+ mod location (Just old_iface)
+ | hsc_mode hsc_env == OneShot
= do {
- when (verbosity dflags > 0) $
+ when (verbosity (hsc_dflags hsc_env) > 0) $
hPutStrLn stderr "compilation IS NOT required";
let { bomb = panic "hscNoRecomp:OneShot" };
return (HscNoRecomp pcs_ch bomb bomb)
}
| otherwise
= do {
- when (verbosity dflags >= 1) $
+ when (verbosity (hsc_dflags hsc_env) >= 1) $
hPutStrLn stderr ("Skipping " ++
showModMsg have_object mod location);
- -- CLOSURE
- (pcs_cl, closure_errs, cl_hs_decls)
- <- closeIfaceDecls dflags hit hst pcs_ch old_iface ;
- if closure_errs then
- return (HscFail pcs_cl)
- else do {
-
- -- TYPECHECK
- maybe_tc_result
- <- typecheckIface dflags pcs_cl hst old_iface cl_hs_decls;
+ -- Typecheck
+ (pcs_tc, maybe_tc_result) <- tcRnIface hsc_env pcs_ch old_iface ;
case maybe_tc_result of {
- Nothing -> return (HscFail pcs_cl);
- Just (pcs_tc, new_details) ->
+ Nothing -> return (HscFail pcs_tc);
+ Just new_details ->
return (HscNoRecomp pcs_tc new_details old_iface)
- }}}
+ }}
-hscRecomp ghci_mode dflags have_object
- mod location maybe_checked_iface hst hit pcs_ch
+hscRecomp hsc_env pcs_ch have_object
+ mod location maybe_checked_iface
= do {
-- what target are we shooting for?
- ; let toInterp = dopt_HscLang dflags == HscInterpreted
- ; let toNothing = dopt_HscLang dflags == HscNothing
+ ; let one_shot = hsc_mode hsc_env == OneShot
+ ; let dflags = hsc_dflags hsc_env
+ ; let toInterp = dopt_HscLang dflags == HscInterpreted
; let toCore = isJust (ml_hs_file location) &&
isExtCore_file (fromJust (ml_hs_file location))
- ; when (ghci_mode /= OneShot && verbosity dflags >= 1) $
+ ; when (not one_shot && verbosity dflags >= 1) $
hPutStrLn stderr ("Compiling " ++
showModMsg (not toInterp) mod location);
- ; front_res <-
- (if toCore then hscCoreFrontEnd else hscFrontEnd)
- ghci_mode dflags location hst hit pcs_ch
+ ; front_res <- if toCore then
+ hscCoreFrontEnd hsc_env pcs_ch location
+ else
+ hscFrontEnd hsc_env pcs_ch location
+
; case front_res of
Left flure -> return flure;
- Right (this_mod, rdr_module,
- dont_discard, new_iface,
- pcs_tc, ds_details, foreign_stuff) -> do {
+ Right (pcs_tc, ds_result) -> do {
- let {
- imported_module_names =
- filter (/= gHC_PRIM_Name) $
- map ideclName (hsModuleImports rdr_module);
- imported_modules =
- map (moduleNameToModule hit (pcs_PIT pcs_tc))
- imported_module_names;
- }
-
- -- force this out now, so we don't keep a hold of rdr_module or pcs_tc
- ; seqList imported_modules (return ())
+ -- OMITTED:
+ -- ; seqList imported_modules (return ())
-------------------
-- FLATTENING
-------------------
- ; flat_details
- <- _scc_ "Flattening"
- flatten dflags pcs_tc hst ds_details
+ ; flat_result <- _scc_ "Flattening"
+ flatten hsc_env pcs_tc ds_result
+
+ ; let pcs_middle = pcs_tc
+
+{- Again, omit this because it loses the usage info
+ which is needed in mkIface. Maybe we should compute
+ usage info earlier.
; pcs_middle
<- _scc_ "pcs_middle"
- if ghci_mode == OneShot
- then do init_pcs <- initPersistentCompilerState
+ if one_shot then
+ do init_pcs <- initPersistentCompilerState
init_prs <- initPersistentRenamerState
let
rules = pcs_rules pcs_tc
orig_tc `seq` rules `seq` new_prs `seq`
return init_pcs{ pcs_PRS = new_prs,
pcs_rules = rules }
- else return pcs_tc
+ else return pcs_tc
+-}
--- Should we remove bits of flat_details at this point?
--- ; flat_details <- case flat_details of
--- ModDetails { md_binds = binds } ->
+-- Should we remove bits of flat_result at this point?
+-- ; flat_result <- case flat_result of
+-- ModResult { md_binds = binds } ->
-- return ModDetails { md_binds = binds,
-- md_rules = [],
-- md_types = emptyTypeEnv,
-- alive at this point:
-- pcs_middle
- -- foreign_stuff
- -- flat_details
- -- imported_modules (seq'd)
- -- new_iface
+ -- flat_result
-------------------
-- SIMPLIFY
-------------------
- ; simpl_details
- <- _scc_ "Core2Core"
- core2core dflags pcs_middle hst dont_discard flat_details
+ ; simpl_result <- _scc_ "Core2Core"
+ core2core hsc_env pcs_middle flat_result
-------------------
-- TIDY
-- cg_info_ref will be filled in just after restOfCodeGeneration
-- Meanwhile, tidyCorePgm is careful not to look at cg_info!
- ; (pcs_simpl, tidy_details)
+ ; (pcs_simpl, tidy_result)
<- _scc_ "CoreTidy"
- tidyCorePgm dflags this_mod pcs_middle cg_info simpl_details
-
- ; pcs_final <- if ghci_mode == OneShot then initPersistentCompilerState
- else return pcs_simpl
-
- -- alive at this point:
- -- tidy_details
- -- new_iface
+ tidyCorePgm dflags pcs_middle cg_info simpl_result
- ; emitExternalCore dflags new_iface tidy_details
+-- Space-saving ploy doesn't work so well now
+-- because mkIface needs the populated PIT to
+-- generate usage info. Maybe we should re-visit this.
+-- ; pcs_final <- if one_shot then initPersistentCompilerState
+-- else return pcs_simpl
+ ; let pcs_final = pcs_simpl
- ; let final_details = tidy_details {md_binds = []}
- ; final_details `seq` return ()
+ -- Alive at this point:
+ -- tidy_result, pcs_final
-------------------
-- PREPARE FOR CODE GENERATION
- -------------------
- -- Do saturation and convert to A-normal form
- ; prepd_details <- _scc_ "CorePrep"
- corePrepPgm dflags tidy_details
+ -- Do saturation and convert to A-normal form
+ ; prepd_result <- _scc_ "CorePrep"
+ corePrepPgm dflags tidy_result
-------------------
-- CONVERT TO STG and COMPLETE CODE GENERATION
- -------------------
- ; let
- ModDetails{md_binds=binds, md_types=env_tc} = prepd_details
-
- local_tycons = typeEnvTyCons env_tc
- local_classes = typeEnvClasses env_tc
-
- (h_code, c_code, headers, fe_binders) = foreign_stuff
-
- -- turn the list of headers requested in foreign import
- -- declarations into a string suitable for emission into generated
- -- C code...
- --
- foreign_headers =
- unlines
- . map (\fname -> "#include \"" ++ unpackFS fname ++ "\"")
- . reverse
- $ headers
-
- -- ...and add the string to the headers requested via command line
- -- options
- --
- ; fhdrs <- readIORef v_HCHeader
- ; writeIORef v_HCHeader (fhdrs ++ foreign_headers)
-
- ; (stub_h_exists, stub_c_exists, maybe_bcos, final_iface )
- <- if toInterp
-#ifdef GHCI
- then do
- ----------------- Generate byte code ------------------
- (bcos,itbl_env) <- byteCodeGen dflags binds
- local_tycons local_classes
-
- -- Fill in the code-gen info
- writeIORef cg_info_ref (Just emptyNameEnv)
-
- ------------------ BUILD THE NEW ModIface ------------
- final_iface <- _scc_ "MkFinalIface"
- mkFinalIface ghci_mode dflags location
- maybe_checked_iface new_iface tidy_details
-
- ------------------ Create f-x-dynamic C-side stuff ---
- (istub_h_exists, istub_c_exists)
- <- outputForeignStubs dflags c_code h_code
+ ; (stub_h_exists, stub_c_exists, maybe_bcos)
+ <- hscBackEnd dflags cg_info_ref prepd_result
- return ( istub_h_exists, istub_c_exists,
- Just (bcos,itbl_env), final_iface )
-#else
- then error "GHC not compiled with interpreter"
-#endif
-
- else do
- ----------------- Convert to STG ------------------
- (stg_binds, cost_centre_info, stg_back_end_info)
- <- _scc_ "CoreToStg"
- myCoreToStg dflags this_mod binds
-
- -- Fill in the code-gen info for the earlier tidyCorePgm
- writeIORef cg_info_ref (Just stg_back_end_info)
-
- ------------------ BUILD THE NEW ModIface ------------
- final_iface <- _scc_ "MkFinalIface"
- mkFinalIface ghci_mode dflags location
- maybe_checked_iface new_iface tidy_details
- if toNothing
- then do
- return (False, False, Nothing, final_iface)
- else do
- ------------------ Code generation ------------------
- abstractC <- _scc_ "CodeGen"
- codeGen dflags this_mod imported_modules
- cost_centre_info fe_binders
- local_tycons stg_binds
-
- ------------------ Code output -----------------------
- (stub_h_exists, stub_c_exists)
- <- codeOutput dflags this_mod [] --local_tycons
- binds stg_binds
- c_code h_code abstractC
-
- return (stub_h_exists, stub_c_exists, Nothing, final_iface)
+ -------------------
+ -- BUILD THE NEW ModIface and ModDetails
+ -- and emit external core if necessary
+ -- This has to happen *after* code gen so that the back-end
+ -- info has been set. Not yet clear if it matters waiting
+ -- until after code output
+ ; final_iface <- _scc_ "MkFinalIface"
+ mkIface hsc_env location
+ maybe_checked_iface tidy_result
+ ; let final_details = ModDetails { md_types = mg_types tidy_result,
+ md_insts = mg_insts tidy_result,
+ md_rules = mg_rules tidy_result }
+ ; emitExternalCore dflags tidy_result
-- and the answer is ...
; return (HscRecomp pcs_final
maybe_bcos)
}}
-hscCoreFrontEnd ghci_mode dflags location hst hit pcs_ch = do {
+hscCoreFrontEnd hsc_env pcs_ch location = do {
-------------------
-- PARSE
-------------------
; case parseCore inp 1 of
FailP s -> hPutStrLn stderr s >> return (Left (HscFail pcs_ch));
OkP rdr_module -> do {
- ; let this_mod = mkHomeModule (hsModuleName rdr_module)
-------------------
- -- RENAME
+ -- RENAME and TYPECHECK
-------------------
- ; (pcs_rn, print_unqual, maybe_rn_result)
- <- renameExtCore dflags hit hst pcs_ch this_mod rdr_module
- ; case maybe_rn_result of {
- Nothing -> return (Left (HscFail pcs_ch));
- Just (dont_discard, new_iface, rn_decls) -> do {
-
- -------------------
- -- TYPECHECK
- -------------------
- ; maybe_tc_result
- <- _scc_ "TypeCheck"
- typecheckCoreModule dflags pcs_rn hst new_iface rn_decls
+ ; (pcs_tc, maybe_tc_result) <- _scc_ "TypeCheck"
+ tcRnExtCore hsc_env pcs_ch rdr_module
; case maybe_tc_result of {
- Nothing -> return (Left (HscFail pcs_ch));
- Just (pcs_tc, tc_result) -> do {
-
- -------------------
- -- DESUGAR
- -------------------
- ; (ds_details, foreign_stuff) <- deSugarCore tc_result
- ; return (Right (this_mod, rdr_module, dont_discard, new_iface,
- pcs_tc, ds_details, foreign_stuff))
- }}}}}}
+ Nothing -> return (Left (HscFail pcs_tc));
+ Just mod_guts -> return (Right (pcs_tc, mod_guts))
+ -- No desugaring to do!
+ }}}
-hscFrontEnd ghci_mode dflags location hst hit pcs_ch = do {
+hscFrontEnd hsc_env pcs_ch location = do {
-------------------
-- PARSE
-------------------
- ; maybe_parsed <- myParseModule dflags
+ ; maybe_parsed <- myParseModule (hsc_dflags hsc_env)
(expectJust "hscRecomp:hspp" (ml_hspp_file location))
+
; case maybe_parsed of {
Nothing -> return (Left (HscFail pcs_ch));
Just rdr_module -> do {
- ; let this_mod = mkHomeModule (hsModuleName rdr_module)
-------------------
- -- RENAME
- -------------------
- ; (pcs_rn, print_unqual, maybe_rn_result)
- <- _scc_ "Rename"
- renameModule dflags ghci_mode hit hst pcs_ch this_mod rdr_module
- ; case maybe_rn_result of {
- Nothing -> return (Left (HscFail pcs_ch));
- Just (dont_discard, new_iface, rn_result) -> do {
-
- -------------------
- -- TYPECHECK
+ -- RENAME and TYPECHECK
-------------------
- ; maybe_tc_result
- <- _scc_ "TypeCheck"
- typecheckModule dflags pcs_rn hst print_unqual rn_result
+ ; (pcs_tc, maybe_tc_result) <- _scc_ "Typecheck and Rename"
+ tcRnModule hsc_env pcs_ch rdr_module
; case maybe_tc_result of {
Nothing -> return (Left (HscFail pcs_ch));
- Just (pcs_tc, tc_result) -> do {
+ Just tc_result -> do {
-------------------
-- DESUGAR
-------------------
- ; (ds_details, foreign_stuff)
- <- _scc_ "DeSugar"
- deSugar dflags pcs_tc hst this_mod print_unqual tc_result
- ; return (Right (this_mod, rdr_module, dont_discard, new_iface,
- pcs_tc, ds_details, foreign_stuff))
- }}}}}}}
+ ; ds_result <- _scc_ "DeSugar"
+ deSugar hsc_env pcs_tc tc_result
+ ; return (Right (pcs_tc, ds_result))
+ }}}}}
+
+
+hscBackEnd dflags cg_info_ref prepd_result
+ = case dopt_HscLang dflags of
+ HscNothing -> return (False, False, Nothing)
+
+ HscInterpreted ->
+#ifdef GHCI
+ do ----------------- Generate byte code ------------------
+ comp_bc <- byteCodeGen dflags prepd_result
+
+ -- Fill in the code-gen info
+ writeIORef cg_info_ref (Just emptyNameEnv)
+
+ ------------------ Create f-x-dynamic C-side stuff ---
+ (istub_h_exists, istub_c_exists)
+ <- outputForeignStubs dflags (mg_foreign prepd_result)
+
+ return ( istub_h_exists, istub_c_exists,
+ Just comp_bc )
+#else
+ panic "GHC not compiled with interpreter"
+#endif
+
+ other ->
+ do
+ ----------------- Convert to STG ------------------
+ (stg_binds, cost_centre_info, stg_back_end_info)
+ <- _scc_ "CoreToStg"
+ myCoreToStg dflags prepd_result
+
+ -- Fill in the code-gen info for the earlier tidyCorePgm
+ writeIORef cg_info_ref (Just stg_back_end_info)
+
+ ------------------ Code generation ------------------
+ abstractC <- _scc_ "CodeGen"
+ codeGen dflags prepd_result
+ cost_centre_info stg_binds
+
+ ------------------ Code output -----------------------
+ (stub_h_exists, stub_c_exists)
+ <- codeOutput dflags prepd_result
+ stg_binds abstractC
+
+ return (stub_h_exists, stub_c_exists, Nothing)
myParseModule dflags src_filename
freeStringBuffer buf;
return Nothing };
- POk _ rdr_module@(HsModule mod_name _ _ _ _ _ _) -> do {
+ POk _ rdr_module -> do {
dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ;
}}
-myCoreToStg dflags this_mod tidy_binds
+myCoreToStg dflags (ModGuts {mg_module = this_mod, mg_binds = tidy_binds})
= do
() <- coreBindsSize tidy_binds `seq` return ()
-- TEMP: the above call zaps some space usage allocated by the
%* *
%************************************************************************
-\begin{code}
-#ifdef GHCI
-hscStmt
- :: DynFlags
- -> HomeSymbolTable
- -> HomeIfaceTable
- -> PersistentCompilerState -- IN: persistent compiler state
- -> InteractiveContext -- Context for compiling
- -> String -- The statement
- -> Bool -- just treat it as an expression
- -> IO ( PersistentCompilerState,
- Maybe ( [Id],
- Type,
- UnlinkedBCOExpr) )
-\end{code}
-
When the UnlinkedBCOExpr is linked you get an HValue of type
IO [HValue]
When you run it you get a list of HValues that should be
result not showable) ==> error
\begin{code}
-hscStmt dflags hst hit pcs0 icontext stmt just_expr
- = do { maybe_stmt <- hscParseStmt dflags stmt
- ; case maybe_stmt of
- Nothing -> return (pcs0, Nothing)
- Just parsed_stmt -> do {
-
- let { notExprStmt (ExprStmt _ _ _) = False;
- notExprStmt _ = True
- };
-
- if (just_expr && notExprStmt parsed_stmt)
- then do hPutStrLn stderr ("not an expression: `" ++ stmt ++ "'")
- return (pcs0, Nothing)
- else do {
-
- -- Rename it
- (pcs1, print_unqual, maybe_renamed_stmt)
- <- renameStmt dflags hit hst pcs0 icontext parsed_stmt
-
- ; case maybe_renamed_stmt of
- Nothing -> return (pcs0, Nothing)
- Just (bound_names, rn_stmt) -> do {
-
- -- Typecheck it
- maybe_tc_return <-
- if just_expr
- then case rn_stmt of { (ExprStmt e _ _, decls) ->
- typecheckExpr dflags pcs1 hst (ic_type_env icontext)
- print_unqual iNTERACTIVE (e,decls) }
- else typecheckStmt dflags pcs1 hst (ic_type_env icontext)
- print_unqual iNTERACTIVE bound_names rn_stmt
-
- ; case maybe_tc_return of
- Nothing -> return (pcs0, Nothing)
- Just (pcs2, tc_expr, bound_ids, ty) -> do {
-
- -- Desugar it
- ds_expr <- deSugarExpr dflags pcs2 hst iNTERACTIVE print_unqual tc_expr
-
- -- Flatten it
- ; flat_expr <- flattenExpr dflags pcs2 hst ds_expr
+#ifdef GHCI
+hscStmt -- Compile a stmt all the way to an HValue, but don't run it
+ :: HscEnv
+ -> PersistentCompilerState -- IN: persistent compiler state
+ -> InteractiveContext -- Context for compiling
+ -> String -- The statement
+ -> IO ( PersistentCompilerState,
+ Maybe (InteractiveContext, [Name], HValue) )
- -- Simplify it
- ; simpl_expr <- simplifyExpr dflags pcs2 hst flat_expr
+hscStmt hsc_env pcs icontext stmt
+ = do { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) stmt
+ ; case maybe_stmt of {
+ Nothing -> return (pcs, Nothing) ;
+ Just parsed_stmt -> do {
- -- Tidy it (temporary, until coreSat does cloning)
- ; tidy_expr <- tidyCoreExpr simpl_expr
+ -- Rename and typecheck it
+ (pcs1, maybe_tc_result)
+ <- tcRnStmt hsc_env pcs icontext parsed_stmt
- -- Prepare for codegen
- ; prepd_expr <- corePrepExpr dflags tidy_expr
-
- -- Convert to BCOs
- ; bcos <- coreExprToBCOs dflags prepd_expr
+ ; case maybe_tc_result of {
+ Nothing -> return (pcs1, Nothing) ;
+ Just (new_ic, bound_names, tc_expr) -> do {
- ; let
- -- Make all the bound ids "global" ids, now that
- -- they're notionally top-level bindings. This is
- -- important: otherwise when we come to compile an expression
- -- using these ids later, the byte code generator will consider
- -- the occurrences to be free rather than global.
- global_bound_ids = map globaliseId bound_ids;
- globaliseId id = setGlobalIdDetails id VanillaGlobal
+ -- Then desugar, code gen, and link it
+ ; hval <- compileExpr hsc_env pcs1 iNTERACTIVE
+ (icPrintUnqual new_ic) tc_expr
- ; return (pcs2, Just (global_bound_ids, ty, bcos))
+ ; return (pcs1, Just (new_ic, bound_names, hval))
+ }}}}}
- }}}}}
+hscTcExpr -- Typecheck an expression (but don't run it)
+ :: HscEnv
+ -> PersistentCompilerState -- IN: persistent compiler state
+ -> InteractiveContext -- Context for compiling
+ -> String -- The expression
+ -> IO (PersistentCompilerState, Maybe Type)
+
+hscTcExpr hsc_env pcs icontext expr
+ = do { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) expr
+ ; case maybe_stmt of {
+ Just (ExprStmt expr _ _)
+ -> tcRnExpr hsc_env pcs icontext expr ;
+ Just other -> do { hPutStrLn stderr ("not an expression: `" ++ expr ++ "'") ;
+ return (pcs, Nothing) } ;
+ Nothing -> return (pcs, Nothing) } }
+\end{code}
+\begin{code}
hscParseStmt :: DynFlags -> String -> IO (Maybe RdrNameStmt)
hscParseStmt dflags str
- = do -------------------------- Parser ----------------
- showPass dflags "Parser"
+ = do showPass dflags "Parser"
_scc_ "Parser" do
buf <- stringToStringBuffer str
\begin{code}
#ifdef GHCI
hscThing -- like hscStmt, but deals with a single identifier
- :: DynFlags
- -> HomeSymbolTable
- -> HomeIfaceTable
+ :: HscEnv
-> PersistentCompilerState -- IN: persistent compiler state
-> InteractiveContext -- Context for compiling
-> String -- The identifier
-> IO ( PersistentCompilerState,
[TyThing] )
-hscThing dflags hst hit pcs0 ic str
- = do maybe_rdr_name <- myParseIdentifier dflags str
+hscThing hsc_env pcs0 ic str
+ = do let dflags = hsc_dflags hsc_env
+
+ maybe_rdr_name <- myParseIdentifier dflags str
case maybe_rdr_name of {
Nothing -> return (pcs0, []);
Just rdr_name -> do
- -- if the identifier is a constructor (begins with an
- -- upper-case letter), then we need to consider both
- -- constructor and type class identifiers.
- let rdr_names
- | occNameSpace occ == dataName = [ rdr_name, tccls_name ]
- | otherwise = [ rdr_name ]
- where
- occ = rdrNameOcc rdr_name
- tccls_occ = setOccNameSpace occ tcClsName
- tccls_name = setRdrNameOcc rdr_name tccls_occ
-
- (pcs, unqual, maybe_rn_result) <-
- renameRdrName dflags hit hst pcs0 ic rdr_names
-
- case maybe_rn_result of {
- Nothing -> return (pcs, []);
- Just (names, decls) -> do {
-
- maybe_pcs <- typecheckExtraDecls dflags pcs hst unqual
- iNTERACTIVE decls;
-
- case maybe_pcs of {
- Nothing -> return (pcs, []);
- Just pcs ->
- let do_lookup n
- | isInternalName n = lookupNameEnv (ic_type_env ic) n
- | otherwise = lookupType hst (pcs_PTE pcs) n
-
- maybe_ty_things = map do_lookup names
- in
- return (pcs, catMaybes maybe_ty_things) }
- }}}
+ (pcs1, maybe_tc_result) <-
+ tcRnThing hsc_env pcs0 ic rdr_name
+
+ case maybe_tc_result of {
+ Nothing -> return (pcs1, []) ;
+ Just things -> return (pcs1, things)
+ }}
myParseIdentifier dflags str
= do buf <- stringToStringBuffer str
%************************************************************************
%* *
-\subsection{Find all the things defined in a module}
+ Desugar, simplify, convert to bytecode, and link an expression
%* *
%************************************************************************
\begin{code}
#ifdef GHCI
-hscModuleContents
- :: DynFlags
- -> HomeSymbolTable
- -> HomeIfaceTable
- -> PersistentCompilerState -- IN: persistent compiler state
- -> Module -- module to inspect
- -> Bool -- grab just the exports, or the whole toplev
- -> IO (PersistentCompilerState, Maybe [TyThing])
-
-hscModuleContents dflags hst hit pcs0 mod exports_only = do {
+compileExpr :: HscEnv
+ -> PersistentCompilerState
+ -> Module -> PrintUnqualified
+ -> TypecheckedHsExpr
+ -> IO HValue
- -- Slurp the interface if necessary (a home module will certainly
- -- alraedy be loaded, but a package module might not be)
- (pcs1, print_unqual, maybe_rn_stuff)
- <- slurpIface dflags hit hst pcs0 mod;
+compileExpr hsc_env pcs this_mod print_unqual tc_expr
+ = do { let dflags = hsc_dflags hsc_env
- case maybe_rn_stuff of {
- Nothing -> return (pcs0, Nothing);
- Just (names, rn_decls) -> do {
-
- -- Typecheck the declarations
- maybe_pcs <-
- typecheckExtraDecls dflags pcs1 hst print_unqual iNTERACTIVE rn_decls;
+ -- Desugar it
+ ; ds_expr <- deSugarExpr hsc_env pcs this_mod print_unqual tc_expr
+
+ -- Flatten it
+ ; flat_expr <- flattenExpr hsc_env pcs ds_expr
- case maybe_pcs of {
- Nothing -> return (pcs1, Nothing);
- Just pcs2 ->
+ -- Simplify it
+ ; simpl_expr <- simplifyExpr dflags flat_expr
- let { all_names
- | exports_only = names
- | otherwise = -- Invariant; we only have (not exports_only)
- -- for a home module so it must already be in the HIT
- let { iface = fromJust (lookupModuleEnv hit mod);
- env = fromJust (mi_globals iface);
- range = rdrEnvElts env;
- } in
- -- grab all the things from the global env that are locally def'd
- nub [ n | elts <- range, GRE n LocalDef _ <- elts ];
+ -- Tidy it (temporary, until coreSat does cloning)
+ ; tidy_expr <- tidyCoreExpr simpl_expr
- pte = pcs_PTE pcs2;
+ -- Prepare for codegen
+ ; prepd_expr <- corePrepExpr dflags tidy_expr
- ty_things = map (fromJust . lookupType hst pte) all_names;
+ -- Convert to BCOs
+ ; bcos <- coreExprToBCOs dflags prepd_expr
- } in
+ -- link it
+ ; hval <- linkExpr hsc_env pcs bcos
- return (pcs2, Just ty_things)
- }}}}
+ ; return hval
+ }
#endif
\end{code}
+
%************************************************************************
%* *
\subsection{Initial persistent state}
\begin{code}
initPersistentCompilerState :: IO PersistentCompilerState
initPersistentCompilerState
- = do prs <- initPersistentRenamerState
+ = do nc <- initNameCache
return (
- PCS { pcs_PIT = emptyIfaceTable,
- pcs_PTE = wiredInThingEnv,
- pcs_insts = emptyInstEnv,
- pcs_rules = emptyRuleBase,
- pcs_PRS = prs
- }
- )
-
-initPersistentRenamerState :: IO PersistentRenamerState
+ PCS { pcs_EPS = initExternalPackageState,
+ pcs_nc = nc })
+
+initNameCache :: IO NameCache
= do us <- mkSplitUniqSupply 'r'
- return (
- PRS { prsOrig = NameSupply { nsUniqs = us,
- nsNames = initOrigNames,
- nsIPs = emptyFM },
- prsDecls = (emptyNameEnv, 0),
- prsInsts = (emptyBag, 0),
- prsRules = foldr add_rule (emptyBag, 0) builtinRules,
- prsImpMods = emptyFM
- }
- )
+ return (NameCache { nsUniqs = us,
+ nsNames = initOrigNames,
+ nsIPs = emptyFM })
+
+initExternalPackageState :: ExternalPackageState
+initExternalPackageState
+ = EPS {
+ eps_decls = (emptyNameEnv, 0),
+ eps_insts = (emptyBag, 0),
+ eps_inst_gates = emptyNameSet,
+ eps_rules = foldr add_rule (emptyBag, 0) builtinRules,
+ eps_imp_mods = emptyFM,
+
+ eps_PIT = emptyPackageIfaceTable,
+ eps_PTE = wiredInThingEnv,
+ eps_inst_env = emptyInstEnv,
+ eps_rule_base = emptyRuleBase }
+
where
- add_rule (name,rule) (rules, n_rules)
- = (gated_decl `consBag` rules, n_rules+1)
+ add_rule (name,rule) (rules, n_slurped)
+ = (gated_decl `consBag` rules, n_slurped)
where
gated_decl = (gate_fn, (mod, IfaceRuleOut rdr_name rule))
mod = nameModule name
- rdr_name = mkRdrOrig (moduleName mod) (nameOccName name)
+ rdr_name = nameRdrName name
gate_fn vis_fn = vis_fn name -- Load the rule whenever name is visible
initOrigNames :: FiniteMap (ModuleName,OccName) Name
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 (PatMonoBind (VarPatIn n) r _) = (1,0)
- count_monobinds (PatMonoBind p r _) = (0,1)
- count_monobinds (FunMonoBind f _ m _) = (0,1)
+ count_monobinds EmptyMonoBinds = (0,0)
+ count_monobinds (AndMonoBinds b1 b2) = count_monobinds b1 `add2` count_monobinds b2
+ count_monobinds (PatMonoBind (VarPat n) r _) = (1,0)
+ count_monobinds (PatMonoBind p r _) = (0,1)
+ count_monobinds (FunMonoBind f _ m _) = (0,1)
count_mb_monobinds (Just mbs) = count_monobinds mbs
count_mb_monobinds Nothing = (0,0)
\begin{code}
module HscTypes (
+ HscEnv(..),
GhciMode(..),
- ModuleLocation(..), showModMsg,
-
ModDetails(..), ModIface(..),
- HomeSymbolTable, emptySymbolTable,
- PackageTypeEnv,
- HomeIfaceTable, PackageIfaceTable, emptyIfaceTable,
+ ModGuts(..), ModImports(..), ForeignStubs(..),
+ ParsedIface(..), IfaceDeprecs,
+
+ HomePackageTable, HomeModInfo(..), emptyHomePackageTable,
+
+ ExternalPackageState(..),
+ PackageTypeEnv, PackageIfaceTable, emptyPackageIfaceTable,
lookupIface, lookupIfaceByModName, moduleNameToModule,
emptyModIface,
- InteractiveContext(..),
+ InteractiveContext(..), emptyInteractiveContext, icPrintUnqual,
IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts,
VersionInfo(..), initialVersionInfo, lookupVersion,
- FixityEnv, lookupFixity, collectFixities,
+ FixityEnv, lookupFixity, collectFixities, emptyFixityEnv,
TyThing(..), isTyClThing, implicitTyThingIds,
typeEnvElts, typeEnvClasses, typeEnvTyCons, typeEnvIds,
ImportedModuleInfo, WhetherHasOrphans, ImportVersion, WhatsImported(..),
- PersistentRenamerState(..), IsBootInterface, DeclsMap,
- IfaceInsts, IfaceRules, GatedDecl, GatedDecls, GateFn, IsExported,
- NameSupply(..), OrigNameCache, OrigIParamCache,
- Avails, AvailEnv, emptyAvailEnv,
+ IsBootInterface, DeclsMap,
+ IfaceInsts, IfaceRules, GatedDecl, GatedDecls, GateFn,
+ NameCache(..), OrigNameCache, OrigIParamCache,
+ Avails, availsToNameSet, availName, availNames,
GenAvailInfo(..), AvailInfo, RdrAvailInfo,
ExportItem, RdrExportItem,
+
PersistentCompilerState(..),
- Deprecations(..), lookupDeprec,
+ Deprecations(..), lookupDeprec, plusDeprecs,
InstEnv, ClsInstEnv, DFunId,
PackageInstEnv, PackageRuleBase,
- GlobalRdrEnv, GlobalRdrElt(..), pprGlobalRdrEnv,
- LocalRdrEnv, extendLocalRdrEnv,
+ GlobalRdrEnv, GlobalRdrElt(..), emptyGlobalRdrEnv, pprGlobalRdrEnv,
+ LocalRdrEnv, extendLocalRdrEnv, isLocalGRE, unQualInScope,
+ -- Linker stuff
+ Linkable(..), isObjectLinkable,
+ Unlinked(..), CompiledByteCode,
+ isObject, nameOfObject, isInterpretable, byteCodeOfObject,
-- Provenance
Provenance(..), ImportReason(..),
#include "HsVersions.h"
-import RdrName ( RdrName, RdrNameEnv, addListToRdrEnv,
- mkRdrUnqual, rdrEnvToList )
+#ifdef GHCI
+import ByteCodeAsm ( CompiledByteCode )
+#endif
+
+import RdrName ( RdrName, mkRdrUnqual,
+ RdrNameEnv, addListToRdrEnv, foldRdrEnv, isUnqual,
+ rdrEnvToList, emptyRdrEnv )
import Name ( Name, NamedThing, getName, nameOccName, nameModule, nameSrcLoc )
import NameEnv
+import NameSet
import OccName ( OccName )
import Module
import InstEnv ( InstEnv, ClsInstEnv, DFunId )
import Class ( Class, classSelIds )
import TyCon ( TyCon, isNewTyCon, tyConGenIds, tyConSelIds, tyConDataCons_maybe )
import DataCon ( dataConWorkId, dataConWrapId )
+import Packages ( PackageName, preludePackage )
+import CmdLineOpts ( DynFlags )
-import BasicTypes ( Version, initialVersion, Fixity, defaultFixity, IPName )
+import BasicTypes ( Version, initialVersion, IPName,
+ Fixity, FixitySig(..), defaultFixity )
import HsSyn ( DeprecTxt, TyClDecl, tyClDeclName, ifaceRuleDeclName,
tyClDeclNames )
import RnHsSyn ( RenamedTyClDecl, RenamedRuleDecl, RenamedInstDecl )
import CoreSyn ( IdCoreRule )
+import PrelNames ( isBuiltInSyntaxName )
import FiniteMap
import Bag ( Bag )
-import Maybes ( seqMaybe, orElse, expectJust )
+import Maybes ( orElse )
import Outputable
import SrcLoc ( SrcLoc, isGoodSrcLoc )
import Util ( thenCmp, sortLt )
import UniqSupply ( UniqSupply )
import Maybe ( fromJust )
+import FastString ( FastString )
+
+import Time ( ClockTime )
\end{code}
+
%************************************************************************
%* *
-\subsection{Which mode we're in
+\subsection{Compilation environment}
%* *
%************************************************************************
+The HscEnv gives the environment in which to compile a chunk of code.
+
\begin{code}
-data GhciMode = Batch | Interactive | OneShot
- deriving Eq
+data HscEnv = HscEnv { hsc_mode :: GhciMode,
+ hsc_dflags :: DynFlags,
+ hsc_HPT :: HomePackageTable }
\end{code}
+The GhciMode is self-explanatory:
-%************************************************************************
-%* *
-\subsection{Module locations}
-%* *
-%************************************************************************
+\begin{code}
+data GhciMode = Batch | Interactive | OneShot
+ deriving Eq
+\end{code}
\begin{code}
-data ModuleLocation
- = ModuleLocation {
- ml_hs_file :: Maybe FilePath,
- ml_hspp_file :: Maybe FilePath, -- path of preprocessed source
- ml_hi_file :: FilePath,
- ml_obj_file :: Maybe FilePath
- }
- deriving Show
-
-instance Outputable ModuleLocation where
- ppr = text . show
-
--- Probably doesn't really belong here, but used in HscMain and InteractiveUI.
-
-showModMsg :: Bool -> Module -> ModuleLocation -> String
-showModMsg use_object mod location =
- mod_str ++ replicate (max 0 (16 - length mod_str)) ' '
- ++" ( " ++ expectJust "showModMsg" (ml_hs_file location) ++ ", "
- ++ (if use_object
- then expectJust "showModMsg" (ml_obj_file location)
- else "interpreted")
- ++ " )"
- where mod_str = moduleUserString mod
+type HomePackageTable = ModuleEnv HomeModInfo -- Domain = modules in the home package
+type PackageIfaceTable = ModuleEnv ModIface -- Domain = modules in the imported packages
+
+emptyHomePackageTable = emptyModuleEnv
+emptyPackageIfaceTable = emptyModuleEnv
+
+data HomeModInfo = HomeModInfo { hm_iface :: ModIface,
+ hm_details :: ModDetails,
+ hm_linkable :: Linkable }
\end{code}
-For a module in another package, the hs_file and obj_file
-components of ModuleLocation are undefined.
+Simple lookups in the symbol table.
-The locations specified by a ModuleLocation may or may not
-correspond to actual files yet: for example, even if the object
-file doesn't exist, the ModuleLocation still contains the path to
-where the object file will reside if/when it is created.
+\begin{code}
+lookupIface :: HomePackageTable -> PackageIfaceTable -> Name -> Maybe ModIface
+-- We often have two IfaceTables, and want to do a lookup
+lookupIface hpt pit name
+ = case lookupModuleEnv hpt mod of
+ Just mod_info -> Just (hm_iface mod_info)
+ Nothing -> lookupModuleEnv pit mod
+ where
+ mod = nameModule name
+
+lookupIfaceByModName :: HomePackageTable -> PackageIfaceTable -> ModuleName -> Maybe ModIface
+-- We often have two IfaceTables, and want to do a lookup
+lookupIfaceByModName hpt pit mod
+ = case lookupModuleEnvByName hpt mod of
+ Just mod_info -> Just (hm_iface mod_info)
+ Nothing -> lookupModuleEnvByName pit mod
+\end{code}
+
+\begin{code}
+-- Use instead of Finder.findModule if possible: this way doesn't
+-- require filesystem operations, and it is guaranteed not to fail
+-- when the IfaceTables are properly populated (i.e. after the renamer).
+moduleNameToModule :: HomePackageTable -> PackageIfaceTable -> ModuleName -> Module
+moduleNameToModule hpt pit mod
+ = mi_module (fromJust (lookupIfaceByModName hpt pit mod))
+\end{code}
%************************************************************************
mi_module :: !Module,
mi_package :: !PackageName, -- Which package the module comes from
mi_version :: !VersionInfo, -- Module version number
+ mi_orphan :: !WhetherHasOrphans, -- Whether this module has orphans
+ mi_boot :: !IsBootInterface, -- Read from an hi-boot file?
- mi_orphan :: WhetherHasOrphans, -- Whether this module has orphans
- -- NOT STRICT! we fill this field with _|_ sometimes
-
- mi_boot :: !IsBootInterface, -- read from an hi-boot file?
-
- mi_usages :: [ImportVersion Name],
+ mi_usages :: [ImportVersion Name],
-- Usages; kept sorted so that it's easy to decide
-- whether to write a new iface file (changing usages
-- doesn't affect the version of this module)
- -- NOT STRICT! we read this field lazilly from the interface file
+ -- NOT STRICT! we read this field lazily from the interface file
mi_exports :: ![ExportItem],
-- What it exports Kept sorted by (mod,occ), to make
mi_globals :: !(Maybe GlobalRdrEnv),
-- Its top level environment or Nothing if we read this
- -- interface from a file.
+ -- interface from an interface file. (We need the source
+ -- file to figure out the top-level environment.)
mi_fixities :: !FixityEnv, -- Fixities
mi_deprecs :: Deprecations, -- Deprecations
-- NOT STRICT! we fill this field with _|_ sometimes
}
-data IfaceDecls = IfaceDecls { dcl_tycl :: [RenamedTyClDecl], -- Sorted
- dcl_rules :: [RenamedRuleDecl], -- Sorted
- dcl_insts :: [RenamedInstDecl] } -- Unsorted
-
-mkIfaceDecls :: [RenamedTyClDecl] -> [RenamedRuleDecl] -> [RenamedInstDecl] -> IfaceDecls
-mkIfaceDecls tycls rules insts
- = IfaceDecls { dcl_tycl = sortLt lt_tycl tycls,
- dcl_rules = sortLt lt_rule rules,
- dcl_insts = insts }
- where
- d1 `lt_tycl` d2 = tyClDeclName d1 < tyClDeclName d2
- r1 `lt_rule` r2 = ifaceRuleDeclName r1 < ifaceRuleDeclName r2
-
-
--- typechecker should only look at this, not ModIface
-- Should be able to construct ModDetails from mi_decls in ModIface
data ModDetails
= ModDetails {
-- The next three fields are created by the typechecker
md_types :: !TypeEnv,
md_insts :: ![DFunId], -- Dfun-ids for the instances in this module
- md_rules :: ![IdCoreRule], -- Domain may include Ids from other modules
- md_binds :: ![CoreBind]
+ md_rules :: ![IdCoreRule] -- Domain may include Ids from other modules
}
--- The ModDetails takes on several slightly different forms:
---
--- After typecheck + desugar
--- md_types Contains TyCons, Classes, and implicit Ids
--- md_insts All instances from this module (incl derived ones)
--- md_rules All rules from this module
--- md_binds Desugared bindings
+
+
+-- A ModGuts is carried through the compiler, accumulating stuff as it goes
+-- There is only one ModGuts at any time, the one for the module
+-- being compiled right now. Once it is compiled, a ModIface and
+-- ModDetails are extracted and the ModGuts is dicarded.
+
+data ModGuts
+ = ModGuts {
+ mg_module :: !Module,
+ mg_exports :: !Avails, -- What it exports
+ mg_usages :: ![ImportVersion Name], -- What it imports, directly or otherwise
+ -- ...exactly as in ModIface
+ mg_dir_imps :: ![Module], -- Directly imported modules
+
+ mg_rdr_env :: !GlobalRdrEnv, -- Top-level lexical environment
+ mg_fix_env :: !FixityEnv, -- Fixity env, for things declared in this module
+ mg_deprecs :: !Deprecations, -- Deprecations declared in the module
+
+ mg_types :: !TypeEnv,
+ mg_insts :: ![DFunId], -- Instances
+ mg_rules :: ![IdCoreRule], -- Rules from this module
+ mg_binds :: ![CoreBind], -- Bindings for this module
+ mg_foreign :: !ForeignStubs
+ }
+
+-- The ModGuts takes on several slightly different forms:
--
--- After simplification
--- md_types Same as after typecheck
--- md_insts Ditto
--- md_rules Orphan rules only (local ones now attached to binds)
--- md_binds With rules attached
+-- After simplification, the following fields change slightly:
+-- mg_rules Orphan rules only (local ones now attached to binds)
+-- mg_binds With rules attached
--
--- After CoreTidy
--- md_types Now contains Ids as well, replete with final IdInfo
+-- After CoreTidy, the following fields change slightly:
+-- mg_types Now contains Ids as well, replete with final IdInfo
-- The Ids are only the ones that are visible from
-- importing modules. Without -O that means only
-- exported Ids, but with -O importing modules may
-- see ids mentioned in unfoldings of exported Ids
--
--- md_insts Same DFunIds as before, but with final IdInfo,
+-- mg_insts Same DFunIds as before, but with final IdInfo,
-- and the unique might have changed; remember that
-- CoreTidy links up the uniques of old and new versions
--
--- md_rules All rules for exported things, substituted with final Ids
+-- mg_rules All rules for exported things, substituted with final Ids
--
--- md_binds Tidied
---
--- Passed back to compilation manager
--- Just as after CoreTidy, but with md_binds nuked
+-- mg_binds Tidied
+
+
+
+data ModImports
+ = ModImports {
+ imp_direct :: ![(Module,Bool)], -- Explicitly-imported modules
+ -- Boolean is true if we imported the whole
+ -- module (apart, perhaps, from hiding some)
+ imp_pkg_mods :: !ModuleSet, -- Non-home-package modules on which we depend,
+ -- directly or indirectly
+ imp_home_names :: !NameSet -- Home package things on which we depend,
+ -- directly or indirectly
+ }
+
+data ForeignStubs = NoStubs
+ | ForeignStubs
+ SDoc -- Header file prototypes for
+ -- "foreign exported" functions
+ SDoc -- C stubs to use when calling
+ -- "foreign exported" functions
+ [FastString] -- Headers that need to be included
+ -- into C code generated for this module
+ [Id] -- Foreign-exported binders
+ -- we have to generate code to register these
+
+
+data IfaceDecls = IfaceDecls { dcl_tycl :: [RenamedTyClDecl], -- Sorted
+ dcl_rules :: [RenamedRuleDecl], -- Sorted
+ dcl_insts :: [RenamedInstDecl] } -- Unsorted
+mkIfaceDecls :: [RenamedTyClDecl] -> [RenamedRuleDecl] -> [RenamedInstDecl] -> IfaceDecls
+mkIfaceDecls tycls rules insts
+ = IfaceDecls { dcl_tycl = sortLt lt_tycl tycls,
+ dcl_rules = sortLt lt_rule rules,
+ dcl_insts = insts }
+ where
+ d1 `lt_tycl` d2 = tyClDeclName d1 < tyClDeclName d2
+ r1 `lt_rule` r2 = ifaceRuleDeclName r1 < ifaceRuleDeclName r2
\end{code}
\begin{code}
}
\end{code}
-Symbol tables map modules to ModDetails:
-\begin{code}
-type SymbolTable = ModuleEnv ModDetails
-type IfaceTable = ModuleEnv ModIface
-
-type HomeIfaceTable = IfaceTable
-type PackageIfaceTable = IfaceTable
-
-type HomeSymbolTable = SymbolTable -- Domain = modules in the home package
-
-emptySymbolTable :: SymbolTable
-emptySymbolTable = emptyModuleEnv
-
-emptyIfaceTable :: IfaceTable
-emptyIfaceTable = emptyModuleEnv
-\end{code}
+%************************************************************************
+%* *
+ Parsed interface files
+%* *
+%************************************************************************
-Simple lookups in the symbol table.
+A ParsedIface is exactly as read from an interface file.
\begin{code}
-lookupIface :: HomeIfaceTable -> PackageIfaceTable -> Name -> Maybe ModIface
--- We often have two IfaceTables, and want to do a lookup
-lookupIface hit pit name
- = lookupModuleEnv hit mod `seqMaybe` lookupModuleEnv pit mod
- where
- mod = nameModule name
-
-lookupIfaceByModName :: HomeIfaceTable -> PackageIfaceTable -> ModuleName -> Maybe ModIface
--- We often have two IfaceTables, and want to do a lookup
-lookupIfaceByModName hit pit mod
- = lookupModuleEnvByName hit mod `seqMaybe` lookupModuleEnvByName pit mod
-
--- Use instead of Finder.findModule if possible: this way doesn't
--- require filesystem operations, and it is guaranteed not to fail
--- when the IfaceTables are properly populated (i.e. after the renamer).
-moduleNameToModule :: HomeIfaceTable -> PackageIfaceTable -> ModuleName
- -> Module
-moduleNameToModule hit pit mod
- = mi_module (fromJust (lookupIfaceByModName hit pit mod))
+type IfaceDeprecs = Maybe (Either DeprecTxt [(RdrName,DeprecTxt)])
+ -- Nothing => NoDeprecs
+ -- Just (Left t) => DeprecAll
+ -- Just (Right p) => DeprecSome
+
+data ParsedIface
+ = ParsedIface {
+ pi_mod :: ModuleName,
+ pi_pkg :: PackageName,
+ pi_vers :: Version, -- Module version number
+ pi_orphan :: WhetherHasOrphans, -- Whether this module has orphans
+ pi_usages :: [ImportVersion OccName], -- Usages
+ pi_exports :: (Version, [RdrExportItem]), -- Exports
+ pi_decls :: [(Version, RdrNameTyClDecl)], -- Local definitions
+ pi_fixity :: [FixitySig RdrName], -- Local fixity declarations,
+ pi_insts :: [RdrNameInstDecl], -- Local instance declarations
+ pi_rules :: (Version, [RdrNameRuleDecl]), -- Rules, with their version
+ pi_deprecs :: IfaceDeprecs -- Deprecations
+ }
\end{code}
ic_rn_gbl_env :: GlobalRdrEnv, -- The cached GlobalRdrEnv, built from
-- ic_toplev_scope and ic_exports
- ic_print_unqual :: PrintUnqualified,
- -- cached PrintUnqualified, as above
-
ic_rn_local_env :: LocalRdrEnv, -- Lexical context for variables bound
-- during interaction
ic_type_env :: TypeEnv -- Ditto for types
}
+
+emptyInteractiveContext
+ = InteractiveContext { ic_toplev_scope = [],
+ ic_exports = [],
+ ic_rn_gbl_env = emptyRdrEnv,
+ ic_rn_local_env = emptyRdrEnv,
+ ic_type_env = emptyTypeEnv }
+
+icPrintUnqual :: InteractiveContext -> PrintUnqualified
+icPrintUnqual ictxt = unQualInScope (ic_rn_gbl_env ictxt)
\end{code}
\end{code}
\begin{code}
-lookupType :: HomeSymbolTable -> PackageTypeEnv -> Name -> Maybe TyThing
-lookupType hst pte name
- = case lookupModuleEnv hst (nameModule name) of
- Just details -> lookupNameEnv (md_types details) name
+lookupType :: HomePackageTable -> PackageTypeEnv -> Name -> Maybe TyThing
+lookupType hpt pte name
+ = case lookupModuleEnv hpt (nameModule name) of
+ Just details -> lookupNameEnv (md_types (hm_details details)) name
Nothing -> lookupNameEnv pte name
\end{code}
Just (_, txt) -> Just txt
Nothing -> Nothing
+plusDeprecs :: Deprecations -> Deprecations -> Deprecations
+plusDeprecs d NoDeprecs = d
+plusDeprecs NoDeprecs d = d
+plusDeprecs d (DeprecAll t) = DeprecAll t
+plusDeprecs (DeprecAll t) d = DeprecAll t
+plusDeprecs (DeprecSome v1) (DeprecSome v2) = DeprecSome (v1 `plusNameEnv` v2)
+
instance Eq Deprecations where
-- Used when checking whether we need write a new interface
NoDeprecs == NoDeprecs = True
type RdrExportItem = (ModuleName, [RdrAvailInfo])
type ExportItem = (ModuleName, [AvailInfo])
-type AvailEnv = NameEnv AvailInfo -- Maps a Name to the AvailInfo that contains it
+availsToNameSet :: [AvailInfo] -> NameSet
+availsToNameSet avails = foldl add emptyNameSet avails
+ where
+ add set avail = addListToNameSet set (availNames avail)
+
+availName :: GenAvailInfo name -> name
+availName (Avail n) = n
+availName (AvailTC n _) = n
-emptyAvailEnv :: AvailEnv
-emptyAvailEnv = emptyNameEnv
+availNames :: GenAvailInfo name -> [name]
+availNames (Avail n) = [n]
+availNames (AvailTC n ns) = ns
instance Outputable n => Outputable (GenAvailInfo n) where
ppr = pprAvail
\end{code}
\begin{code}
-type FixityEnv = NameEnv Fixity
+type FixityEnv = NameEnv (FixitySig Name)
+ -- We keep the whole fixity sig so that we
+ -- can report line-number info when there is a duplicate
+ -- fixity declaration
+
+emptyFixityEnv :: FixityEnv
+emptyFixityEnv = emptyNameEnv
lookupFixity :: FixityEnv -> Name -> Fixity
-lookupFixity env n = lookupNameEnv env n `orElse` defaultFixity
+lookupFixity env n = case lookupNameEnv env n of
+ Just (FixitySig _ fix _) -> fix
+ Nothing -> defaultFixity
-collectFixities :: FixityEnv -> [TyClDecl Name pat] -> [(Name,Fixity)]
+collectFixities :: FixityEnv -> [TyClDecl Name] -> [FixitySig Name]
+-- Collect fixities for the specified declarations
collectFixities env decls
- = [ (n, fix)
+ = [ fix
| d <- decls, (n,_) <- tyClDeclNames d,
Just fix <- [lookupNameEnv env n]
]
type ImportVersion name = (ModuleName, WhetherHasOrphans, IsBootInterface, WhatsImported name)
-data WhatsImported name = NothingAtAll -- The module is below us in the
- -- hierarchy, but we import nothing
+data WhatsImported name = NothingAtAll -- The module is below us in the
+ -- hierarchy, but we import nothing
+ -- Used for orphan modules, so they appear
+ -- in the usage list
| Everything Version -- Used for modules from other packages;
-- we record only the module's version number
-- we imported the module without saying exactly what we imported
-- We need to recompile if the module exports changes, because we might
-- now have a name clash in the importing module.
-
-type IsExported = Name -> Bool -- True for names that are exported from this module
\end{code}
The @PersistentCompilerState@ persists across successive calls to the
compiler.
- * A ModIface for each non-home-package module
-
- * An accumulated TypeEnv from all the modules in imported packages
-
- * An accumulated InstEnv from all the modules in imported packages
- The point is that we don't want to keep recreating it whenever
- we compile a new module. The InstEnv component of pcPST is empty.
- (This means we might "see" instances that we shouldn't "really" see;
- but the Haskell Report is vague on what is meant to be visible,
- so we just take the easy road here.)
-
- * Ditto for rules
-
- * The persistent renamer state
-
\begin{code}
data PersistentCompilerState
= PCS {
- pcs_PIT :: !PackageIfaceTable, -- Domain = non-home-package modules
- -- the mi_decls component is empty
-
- pcs_PTE :: !PackageTypeEnv, -- Domain = non-home-package modules
- -- except that the InstEnv components is empty
-
- pcs_insts :: !PackageInstEnv, -- The total InstEnv accumulated from all
- -- the non-home-package modules
-
- pcs_rules :: !PackageRuleBase, -- Ditto RuleEnv
-
- pcs_PRS :: !PersistentRenamerState
+ pcs_nc :: !NameCache,
+ pcs_EPS :: !ExternalPackageState
}
\end{code}
-The persistent renamer state contains:
-
- * A name supply, which deals with allocating unique names to
- (Module,OccName) original names,
-
- * A "holding pen" for declarations that have been read out of
- interface files but not yet sucked in, renamed, and typechecked
-
\begin{code}
type PackageTypeEnv = TypeEnv
type PackageRuleBase = RuleBase
type PackageInstEnv = InstEnv
-data PersistentRenamerState
- = PRS { prsOrig :: !NameSupply,
- prsImpMods :: !ImportedModuleInfo,
-
- -- Holding pens for stuff that has been read in
- -- but not yet slurped into the renamer
- prsDecls :: !DeclsMap,
- prsInsts :: !IfaceInsts,
- prsRules :: !IfaceRules
- }
+data ExternalPackageState
+ = EPS {
+ eps_PIT :: !PackageIfaceTable,
+ -- The ModuleIFaces for modules in external packages
+ -- whose interfaces we have opened
+ -- The declarations in these interface files are held in
+ -- eps_decls, eps_insts, eps_rules (below), not in the
+ -- mi_decls fields of the iPIT.
+ -- What _is_ in the iPIT is:
+ -- * The Module
+ -- * Version info
+ -- * Its exports
+ -- * Fixities
+ -- * Deprecations
+
+ eps_imp_mods :: !ImportedModuleInfo,
+ -- Modules that we know something about, because they are mentioned
+ -- in interface files, BUT which we have not loaded yet.
+ -- No module is both in here and in the PIT
+
+ eps_PTE :: !PackageTypeEnv, -- Domain = external-package modules
+
+ eps_inst_env :: !PackageInstEnv, -- The total InstEnv accumulated from
+ -- all the external-package modules
+ eps_rule_base :: !PackageRuleBase, -- Ditto RuleEnv
+
+
+ -- Holding pens for stuff that has been read in from file,
+ -- but not yet slurped into the renamer
+ eps_decls :: !DeclsMap,
+ -- A single, global map of Names to unslurped decls
+ eps_insts :: !IfaceInsts,
+ -- 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.
+ -- Each is 'gated' by the names that must be available before
+ -- this instance decl is needed.
+ eps_rules :: !IfaceRules,
+ -- Similar to instance decls, only for rules
+
+ eps_inst_gates :: !NameSet -- Gates for instance decls
+ -- The instance gates must accumulate across
+ -- all invocations of the renamer;
+ -- see "the gating story" in RnIfaces.lhs
+ -- These names should all be from other packages;
+ -- for the home package we have all the instance
+ -- declarations anyhow
+ }
\end{code}
-The NameSupply makes sure that there is just one Unique assigned for
+The NameCache makes sure that there is just one Unique assigned for
each original name; i.e. (module-name, occ-name) pair. The Name is
always stored as a Global, and has the SrcLoc of its binding location.
Actually that's not quite right. When we first encounter the original
we just store junk. Then when we find the binding site, we fix it up.
\begin{code}
-data NameSupply
- = NameSupply { nsUniqs :: UniqSupply,
+data NameCache
+ = NameCache { nsUniqs :: UniqSupply,
-- Supply of uniques
nsNames :: OrigNameCache,
-- Ensures that one original name gets one unique
And there's no harm in it persisting across multiple compilations.
\begin{code}
-type ImportedModuleInfo = FiniteMap ModuleName (WhetherHasOrphans, IsBootInterface)
+type ImportedModuleInfo
+ = FiniteMap ModuleName (WhetherHasOrphans, IsBootInterface)
\end{code}
A DeclsMap contains a binding for each Name in the declaration
%************************************************************************
%* *
+\subsection{Linkable stuff}
+%* *
+%************************************************************************
+
+This stuff is in here, rather than (say) in Linker.lhs, because the Linker.lhs
+stuff is the *dynamic* linker, and isn't present in a stage-1 compiler
+
+\begin{code}
+data Linkable = LM {
+ linkableTime :: ClockTime, -- Time at which this linkable was built
+ -- (i.e. when the bytecodes were produced,
+ -- or the mod date on the files)
+ linkableModName :: ModuleName, -- Should be Module, but see below
+ linkableUnlinked :: [Unlinked]
+ }
+
+isObjectLinkable :: Linkable -> Bool
+isObjectLinkable l = all isObject (linkableUnlinked l)
+
+instance Outputable Linkable where
+ ppr (LM when_made mod unlinkeds)
+ = (text "LinkableM" <+> parens (text (show when_made)) <+> ppr mod)
+ $$ nest 3 (ppr unlinkeds)
+
+-------------------------------------------
+data Unlinked
+ = DotO FilePath
+ | DotA FilePath
+ | DotDLL FilePath
+ | BCOs CompiledByteCode
+
+#ifndef GHCI
+data CompiledByteCode = NoByteCode
+#endif
+
+instance Outputable Unlinked where
+ ppr (DotO path) = text "DotO" <+> text path
+ ppr (DotA path) = text "DotA" <+> text path
+ ppr (DotDLL path) = text "DotDLL" <+> text path
+#ifdef GHCI
+ ppr (BCOs bcos) = text "BCOs" <+> ppr bcos
+#else
+ ppr (BCOs bcos) = text "No byte code"
+#endif
+
+isObject (DotO _) = True
+isObject (DotA _) = True
+isObject (DotDLL _) = True
+isObject _ = False
+
+isInterpretable = not . isObject
+
+nameOfObject (DotO fn) = fn
+nameOfObject (DotA fn) = fn
+nameOfObject (DotDLL fn) = fn
+
+byteCodeOfObject (BCOs bc) = bc
+\end{code}
+
+
+%************************************************************************
+%* *
\subsection{Provenance and export info}
%* *
%************************************************************************
A LocalRdrEnv is used for local bindings (let, where, lambda, case)
+Also used in
\begin{code}
type LocalRdrEnv = RdrNameEnv Name
-- The list is because there may be name clashes
-- These only get reported on lookup, not on construction
-data GlobalRdrElt = GRE Name Provenance (Maybe DeprecTxt)
- -- The Maybe DeprecTxt tells whether this name is deprecated
+emptyGlobalRdrEnv = emptyRdrEnv
+
+data GlobalRdrElt
+ = GRE { gre_name :: Name,
+ gre_parent :: Name, -- Name of the "parent" structure
+ -- * the tycon of a data con
+ -- * the class of a class op
+ -- For others it's just the same as gre_name
+ gre_prov :: Provenance, -- Why it's in scope
+ gre_deprec :: Maybe DeprecTxt -- Whether this name is deprecated
+ }
+instance Outputable GlobalRdrElt where
+ ppr gre = ppr (gre_name gre) <+>
+ parens (hsep [text "parent:" <+> ppr (gre_parent gre) <> comma,
+ pprNameProvenance gre])
pprGlobalRdrEnv env
= vcat (map pp (rdrEnvToList env))
where
- pp (rn, nps) = ppr rn <> colon <+>
- vcat [ppr n <+> pprNameProvenance n p | (GRE n p _) <- nps]
+ pp (rn, gres) = ppr rn <> colon <+>
+ vcat [ ppr (gre_name gre) <+> pprNameProvenance gre
+ | gre <- gres]
+
+isLocalGRE :: GlobalRdrElt -> Bool
+isLocalGRE (GRE {gre_prov = LocalDef}) = True
+isLocalGRE other = False
+\end{code}
+
+@unQualInScope@ 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}
+unQualInScope :: GlobalRdrEnv -> Name -> Bool
+-- True if 'f' is in scope, and has only one binding,
+-- and the thing it is bound to is the name we are looking for
+-- (i.e. false if A.f and B.f are both in scope as unqualified 'f')
+--
+-- Also checks for built-in syntax, which is always 'in scope'
+--
+-- This fn is only efficient if the shared
+-- partial application is used a lot.
+unQualInScope env
+ = \n -> n `elemNameSet` unqual_names || isBuiltInSyntaxName n
+ where
+ unqual_names :: NameSet
+ unqual_names = foldRdrEnv add emptyNameSet env
+ add rdr_name [gre] unquals | isUnqual rdr_name = addOneToNameSet unquals (gre_name gre)
+ add _ _ unquals = unquals
\end{code}
The "provenance" of something says how it came to be in scope.
hasBetterProv (NonLocalDef (UserImport _ _ _ )) (NonLocalDef ImplicitImport) = True
hasBetterProv _ _ = False
-pprNameProvenance :: Name -> Provenance -> SDoc
-pprNameProvenance name LocalDef = ptext SLIT("defined at") <+> ppr (nameSrcLoc name)
-pprNameProvenance name (NonLocalDef why) = sep [ppr_reason why,
- nest 2 (ppr_defn (nameSrcLoc name))]
+pprNameProvenance :: GlobalRdrElt -> SDoc
+pprNameProvenance (GRE {gre_name = name, gre_prov = prov})
+ = case prov of
+ LocalDef -> ptext SLIT("defined at") <+> ppr (nameSrcLoc name)
+ NonLocalDef why -> sep [ppr_reason why,
+ nest 2 (ppr_defn (nameSrcLoc name))]
ppr_reason ImplicitImport = ptext SLIT("implicitly imported")
ppr_reason (UserImport mod loc _) = ptext SLIT("imported from") <+> ppr mod <+> ptext SLIT("at") <+> ppr loc
-----------------------------------------------------------------------------
--- $Id: Interpreter.hs,v 1.11 2000/12/19 12:36:12 sewardj Exp $
+-- $Id: Interpreter.hs,v 1.12 2002/09/13 15:02:35 simonpj Exp $
--
-- Interpreter subsystem wrapper
--
module ByteCodeGen,
module Linker
#else
- ClosureEnv, emptyClosureEnv,
- ItblEnv, emptyItblEnv,
- byteCodeGen,
- HValue,
- UnlinkedBCO, UnlinkedBCOExpr,
- loadObjs, resolveObjs,
+
#endif
) where
-- NO! No interpreter; generate stubs for all the bits
-- ------------------------------------------------------------
-type ClosureEnv = ()
-emptyClosureEnv = ()
+extendLinkEnv xs = return ()
type ItblEnv = ()
emptyItblEnv = ()
{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}
-----------------------------------------------------------------------------
--- $Id: Main.hs,v 1.110 2002/09/06 14:35:44 simonmar Exp $
+-- $Id: Main.hs,v 1.111 2002/09/13 15:02:35 simonpj Exp $
--
-- GHC Driver program
--
import SysTools ( getPackageConfigPath, initSysTools, cleanTempFiles )
import Packages ( showPackages )
-import DriverPipeline ( doLink, doMkDLL, genPipeline, pipeLoop )
+import DriverPipeline ( staticLink, doMkDLL, genPipeline, pipeLoop )
import DriverState ( buildCoreToDo, buildStgToDo,
- findBuildTag, getPackageInfo, unregFlags,
+ findBuildTag, getPackageInfo, getPackageConfigMap,
+ getPackageExtraGhcOpts, unregFlags,
v_GhcMode, v_GhcModeFlag, GhcMode(..),
- v_Cmdline_libraries, v_Keep_tmp_files, v_Ld_inputs,
+ v_Keep_tmp_files, v_Ld_inputs, v_Ways,
v_OptLevel, v_Output_file, v_Output_hi,
- v_Package_details, v_Ways, getPackageExtraGhcOpts,
readPackageConf, verifyOutputFiles
)
import DriverFlags ( buildStaticHscOpts,
DynFlags(..), HscLang(..), v_Static_hsc_opts,
defaultHscLang
)
+import BasicTypes ( failed )
import Outputable
import Util
import Panic ( GhcException(..), panic )
when (verb >= 2)
(hPutStrLn stderr ("Using package config file: " ++ conf_file))
- pkg_details <- readIORef v_Package_details
+ pkg_details <- getPackageConfigMap
showPackages pkg_details
when (verb >= 3)
o_files <- mapM compileFile srcs
when (mode == DoMkDependHS) endMkDependHS
- when (mode == DoLink) (doLink o_files)
+ when (mode == DoLink) (staticLink o_files)
when (mode == DoMkDLL) (doMkDLL o_files)
_ -> do dflags <- getDynFlags
state <- cmInit Batch
graph <- cmDepAnal state dflags mods
- (_, ok, _) <- cmLoadModules state dflags graph
- when (not ok) (exitWith (ExitFailure 1))
+ (_, ok_flag, _) <- cmLoadModules state dflags graph
+ when (failed ok_flag) (exitWith (ExitFailure 1))
return ()
beginInteractive = throwDyn (CmdLineError "not built for interactive use")
#else
beginInteractive fileish_args
- = do minus_ls <- readIORef v_Cmdline_libraries
+ = do state <- cmInit Interactive
let (objs, mods) = partition objish_file fileish_args
- libs = map Object objs ++ map DLL minus_ls
- state <- cmInit Interactive
- interactiveUI state mods libs
+ interactiveUI state mods objs
#endif
checkOptions :: [String] -> IO ()
\begin{code}
module MkIface (
- showIface, mkFinalIface,
- pprModDetails, pprIface, pprUsage, pprUsages, pprExports,
+ showIface, mkIface, mkUsageInfo,
+ pprIface, pprUsage, pprUsages, pprExports,
ifaceTyThing,
) where
import HsCore ( HsIdInfo(..), UfExpr(..), toUfExpr, toUfBndr )
import HsTypes ( toHsTyVars )
import TysPrim ( alphaTyVars )
-import BasicTypes ( NewOrData(..), Activation(..),
+import BasicTypes ( NewOrData(..), Activation(..), FixitySig(..),
Version, initialVersion, bumpVersion
)
import NewDemand ( isTopSig )
-import RnMonad
+import TcRnMonad
import RnHsSyn ( RenamedInstDecl, RenamedTyClDecl )
-import HscTypes ( VersionInfo(..), ModIface(..), ModDetails(..),
- ModuleLocation(..), GhciMode(..),
+import HscTypes ( VersionInfo(..), ModIface(..), HomeModInfo(..),
+ ModGuts(..), ModGuts,
+ GhciMode(..), HscEnv(..),
FixityEnv, lookupFixity, collectFixities,
IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts,
- TyThing(..), DFunId, TypeEnv,
- GenAvailInfo,
- WhatsImported(..), GenAvailInfo(..),
- ImportVersion, Deprecations(..),
- lookupVersion, typeEnvIds
+ TyThing(..), DFunId,
+ Avails, AvailInfo, GenAvailInfo(..), availName,
+ ExternalPackageState(..),
+ WhatsImported(..), ParsedIface(..),
+ ImportVersion, Deprecations(..), initialVersionInfo,
+ lookupVersion
)
import CmdLineOpts
-import Id ( idType, idInfo, isImplicitId, idCgInfo,
- isLocalId, idName,
- )
+import Id ( idType, idInfo, isImplicitId, idCgInfo )
import DataCon ( dataConWorkId, dataConSig, dataConFieldLabels, dataConStrictMarks )
import IdInfo -- Lots
-import Var ( Var )
import CoreSyn ( CoreRule(..), IdCoreRule )
import CoreFVs ( ruleLhsFreeNames )
import CoreUnfold ( neverUnfold, unfoldingTemplate )
-import PprCore ( pprIdRules )
-import Name ( getName, toRdrName, isExternalName,
+import Name ( getName, nameModule, nameModule_maybe, nameOccName,
nameIsLocalOrFrom, Name, NamedThing(..) )
import NameEnv
import NameSet
-import OccName ( pprOccName )
-import TyCon
+import OccName ( OccName, pprOccName )
+import TyCon ( DataConDetails(..), tyConTyVars, tyConDataCons, tyConTheta,
+ isFunTyCon, isPrimTyCon, isNewTyCon, isClassTyCon,
+ isSynTyCon, isAlgTyCon, isForeignTyCon,
+ getSynTyConDefn, tyConGenInfo, tyConDataConDetails, tyConArity )
import Class ( classExtraBigSig, classTyCon, DefMeth(..) )
import FieldLabel ( fieldLabelType )
-import TcType ( tcSplitSigmaTy, tidyTopType, deNoteType, namesOfDFunHead )
+import TcType ( tcSplitSigmaTy, tidyTopType, deNoteType, tyClsNamesOfDFunHead )
import SrcLoc ( noSrcLoc )
+import Module ( Module, ModuleName, moduleNameFS, moduleName, isHomeModule,
+ ModLocation(..), mkSysModuleNameFS,
+ ModuleEnv, emptyModuleEnv, foldModuleEnv, lookupModuleEnv,
+ extendModuleEnv_C, elemModuleSet, moduleEnvElts
+ )
import Outputable
-import Module ( ModuleName )
-import Util ( sortLt, dropList )
+import Util ( sortLt, dropList, seqList )
import Binary ( getBinFileWithDict )
import BinIface ( writeBinIface )
import ErrUtils ( dumpIfSet_dyn )
+import FiniteMap
import FastString
import Monad ( when )
-import Maybe ( catMaybes )
+import Maybe ( catMaybes, isJust )
import IO ( putStrLn )
\end{code}
-- ppr pi_deprecs
]))
where
- ppr_fix (n,f) = ppr f <+> ppr n
+ ppr_fix (FixitySig n f _) = ppr f <+> ppr n
ppr_inst i = ppr i <+> semi
ppr_decl (v,d) = int v <+> ppr d <> semi
\end{code}
%************************************************************************
\begin{code}
-
-
-
-mkFinalIface :: GhciMode
- -> DynFlags
- -> ModuleLocation
- -> Maybe ModIface -- The old interface, if we have it
- -> ModIface -- The new one, minus the decls and versions
- -> ModDetails -- The ModDetails for this module
- -> IO ModIface -- The new one, complete with decls and versions
+mkIface :: HscEnv
+ -> ModLocation
+ -> Maybe ModIface -- The old interface, if we have it
+ -> ModGuts -- The compiled, tidied module
+ -> IO ModIface -- The new one, complete with decls and versions
-- mkFinalIface
-- a) completes the interface
-- b) writes it out to a file if necessary
-mkFinalIface ghci_mode dflags location maybe_old_iface
- new_iface@ModIface{ mi_module=mod }
- new_details@ModDetails{ md_insts=insts,
- md_rules=rules,
- md_types=types }
- = do {
- -- Add the new declarations, and the is-orphan flag
- let iface_w_decls = new_iface { mi_decls = new_decls,
- mi_orphan = orphan_mod }
+mkIface hsc_env location maybe_old_iface
+ impl@ModGuts{ mg_module = this_mod,
+ mg_usages = usages,
+ mg_exports = exports,
+ mg_rdr_env = rdr_env,
+ mg_fix_env = fix_env,
+ mg_deprecs = deprecs,
+ mg_insts = insts,
+ mg_rules = rules,
+ mg_types = types }
+ = do { -- Sort the exports to make them easier to compare for versions
+ let { my_exports = groupAvails this_mod exports ;
+
+ iface_w_decls = ModIface { mi_module = this_mod,
+ mi_package = opt_InPackage,
+ mi_version = initialVersionInfo,
+ mi_usages = usages,
+ mi_exports = my_exports,
+ mi_decls = new_decls,
+ mi_orphan = orphan_mod,
+ mi_boot = False,
+ mi_fixities = fix_env,
+ mi_globals = Just rdr_env,
+ mi_deprecs = deprecs } }
-- Add version information
; let (final_iface, maybe_diffs) = _scc_ "versioninfo" addVersionInfo maybe_old_iface iface_w_decls
return final_iface }
where
+ dflags = hsc_dflags hsc_env
+ ghci_mode = hsc_mode hsc_env
+
must_write_hi_file Nothing = False
must_write_hi_file (Just _diffs) = ghci_mode /= Interactive
-- We must write a new .hi file if there are some changes
inst_dcls = map ifaceInstance insts
ty_cls_dcls = foldNameEnv ifaceTyThing_acc [] types
rule_dcls = map ifaceRule rules
- orphan_mod = isOrphanModule mod new_details
+ orphan_mod = isOrphanModule impl
write_diffs :: DynFlags -> ModIface -> Maybe SDoc -> IO ()
write_diffs dflags new_iface Nothing
\end{code}
\begin{code}
-isOrphanModule :: Module -> ModDetails -> Bool
-isOrphanModule this_mod (ModDetails {md_insts = insts, md_rules = rules})
+isOrphanModule :: ModGuts -> Bool
+isOrphanModule (ModGuts {mg_module = this_mod, mg_insts = insts, mg_rules = rules})
= any orphan_inst insts || any orphan_rule rules
where
-- A rule is an orphan if the LHS mentions nothing defined locally
- orphan_inst dfun_id = no_locals (namesOfDFunHead (idType dfun_id))
+ orphan_inst dfun_id = no_locals (tyClsNamesOfDFunHead (idType dfun_id))
-- A instance is an orphan if its head mentions nothing defined locally
orphan_rule rule = no_locals (ruleLhsFreeNames rule)
tcdFDs = toHsFDs clas_fds,
tcdSigs = map toClassOpSig op_stuff,
tcdMeths = Nothing,
- tcdSysNames = sys_names,
tcdLoc = noSrcLoc }
(clas_tyvars, clas_fds, sc_theta, sc_sels, op_stuff) = classExtraBigSig clas
tycon = classTyCon clas
data_con = head (tyConDataCons tycon)
- sys_names = mkClassDeclSysNames (getName tycon, getName data_con,
- getName (dataConWorkId data_con), map getName sc_sels)
toClassOpSig (sel_id, def_meth)
= ASSERT(sel_tyvars == clas_tyvars)
tcdLoc = noSrcLoc }
| isAlgTyCon tycon
- = TyData { tcdND = new_or_data,
- tcdCtxt = toHsContext (tyConTheta tycon),
- tcdName = getName tycon,
- tcdTyVars = toHsTyVars tyvars,
- tcdCons = ifaceConDecls (tyConDataConDetails tycon),
- tcdDerivs = Nothing,
- tcdSysNames = map getName (tyConGenIds tycon),
- tcdLoc = noSrcLoc }
+ = TyData { tcdND = new_or_data,
+ tcdCtxt = toHsContext (tyConTheta tycon),
+ tcdName = getName tycon,
+ tcdTyVars = toHsTyVars tyvars,
+ tcdCons = ifaceConDecls (tyConDataConDetails tycon),
+ tcdDerivs = Nothing,
+ tcdGeneric = Just (isJust (tyConGenInfo tycon)),
+ -- Just True <=> has generic stuff
+ tcdLoc = noSrcLoc }
| isForeignTyCon tycon
= ForeignType { tcdName = getName tycon,
tcdTyVars = toHsTyVars (take (tyConArity tycon) alphaTyVars),
tcdCons = Unknown,
tcdDerivs = Nothing,
- tcdSysNames = [],
+ tcdGeneric = Just False,
tcdLoc = noSrcLoc }
| otherwise = pprPanic "ifaceTyThing" (ppr tycon)
ifaceConDecls (DataCons cs) = DataCons (map ifaceConDecl cs)
ifaceConDecl data_con
- = ConDecl (getName data_con) (getName (dataConWorkId data_con))
+ = ConDecl (getName data_con)
(toHsTyVars ex_tyvars)
(toHsContext ex_theta)
details noSrcLoc
-- includes the existential dictionaries
details | null field_labels
= ASSERT( tycon == tycon1 && tyvars == tyvars1 )
- VanillaCon (zipWith BangType strict_marks (map toHsType arg_tys))
+ PrefixCon (zipWith BangType strict_marks (map toHsType arg_tys))
| otherwise
= RecCon (zipWith mk_field strict_marks field_labels)
mk_field strict_mark field_label
- = ([getName field_label], BangType strict_mark (toHsType (fieldLabelType field_label)))
+ = (getName field_label, BangType strict_mark (toHsType (fieldLabelType field_label)))
ifaceTyThing (AnId id) = iface_sig
where
-- and this instance decl wouldn't get imported into a module
-- that mentioned T but not Tibble.
-ifaceRule :: IdCoreRule -> RuleDecl Name pat
+ifaceRule :: IdCoreRule -> RuleDecl Name
ifaceRule (id, BuiltinRule _ _)
= pprTrace "toHsRule: builtin" (ppr id) (bogusIfaceRule id)
= IfaceRule name act (map toUfBndr bndrs) (getName id)
(map toUfExpr args) (toUfExpr rhs) noSrcLoc
-bogusIfaceRule :: (NamedThing a) => a -> RuleDecl Name pat
+bogusIfaceRule :: (NamedThing a) => a -> RuleDecl Name
bogusIfaceRule id
= IfaceRule FSLIT("bogus") NeverActive [] (getName id) [] (UfVar (getName id)) noSrcLoc
\end{code}
+%*********************************************************
+%* *
+\subsection{Keeping track of what we've slurped, and version numbers}
+%* *
+%*********************************************************
+
+mkUsageInfo figures out what the ``usage information'' for this
+moudule is; that is, what it must record in its interface file as the
+things it uses.
+
+We produce a line for every module B below the module, A, currently being
+compiled:
+ import B <n> ;
+to record the fact that A does import B indirectly. This is used to decide
+to look to look for B.hi rather than B.hi-boot when compiling a module that
+imports A. This line says that A imports B, but uses nothing in it.
+So we'll get an early bale-out when compiling A if B's version changes.
+
+The usage information records:
+
+\begin{itemize}
+\item (a) anything reachable from its body code
+\item (b) any module exported with a @module Foo@
+\item (c) anything reachable from an exported item
+\end{itemize}
+
+Why (b)? Because if @Foo@ changes then this module's export list
+will change, so we must recompile this module at least as far as
+making a new interface file --- but in practice that means complete
+recompilation.
+
+Why (c)? Consider this:
+\begin{verbatim}
+ module A( f, g ) where | module B( f ) where
+ import B( f ) | f = h 3
+ g = ... | h = ...
+\end{verbatim}
+
+Here, @B.f@ isn't used in A. Should we nevertheless record @B.f@ in
+@A@'s usages? Our idea is that we aren't going to touch A.hi if it is
+*identical* to what it was before. If anything about @B.f@ changes
+than anyone who imports @A@ should be recompiled in case they use
+@B.f@ (they'll get an early exit if they don't). So, if anything
+about @B.f@ changes we'd better make sure that something in A.hi
+changes, and the convenient way to do that is to record the version
+number @B.f@ in A.hi in the usage list. If B.f changes that'll force a
+complete recompiation of A, which is overkill but it's the only way to
+write a new, slightly different, A.hi.
+
+But the example is tricker. Even if @B.f@ doesn't change at all,
+@B.h@ may do so, and this change may not be reflected in @f@'s version
+number. But with -O, a module that imports A must be recompiled if
+@B.h@ changes! So A must record a dependency on @B.h@. So we treat
+the occurrence of @B.f@ in the export list *just as if* it were in the
+code of A, and thereby haul in all the stuff reachable from it.
+
+ *** Conclusion: if A mentions B.f in its export list,
+ behave just as if A mentioned B.f in its source code,
+ and slurp in B.f and all its transitive closure ***
+
+[NB: If B was compiled with -O, but A isn't, we should really *still*
+haul in all the unfoldings for B, in case the module that imports A *is*
+compiled with -O. I think this is the case.]
+
+\begin{code}
+mkUsageInfo :: HscEnv -> ExternalPackageState
+ -> ImportAvails -> Usages
+ -> [ImportVersion Name]
+
+mkUsageInfo hsc_env eps
+ (ImportAvails { imp_mods = dir_imp_mods })
+ (Usages { usg_ext = pkg_mods,
+ usg_home = home_names })
+ = let
+ hpt = hsc_HPT hsc_env
+ pit = eps_PIT eps
+
+ import_all_mods = [moduleName m | (m,True) <- moduleEnvElts dir_imp_mods]
+
+ -- mv_map groups together all the things imported and used
+ -- from a particular module in this package
+ -- We use a finite map because we want the domain
+ mv_map :: ModuleEnv [Name]
+ mv_map = foldNameSet add_mv emptyModuleEnv home_names
+ add_mv name mv_map = extendModuleEnv_C add_item mv_map mod [name]
+ where
+ mod = nameModule name
+ add_item names _ = name:names
+
+ -- In our usage list we record
+ --
+ -- a) Specifically: Detailed version info for imports
+ -- from modules in this package Gotten from iVSlurp plus
+ -- import_all_mods
+ --
+ -- b) Everything: Just the module version for imports
+ -- from modules in other packages Gotten from iVSlurp plus
+ -- import_all_mods
+ --
+ -- c) NothingAtAll: The name only of modules, Baz, in
+ -- this package that are 'below' us, but which we didn't need
+ -- at all (this is needed only to decide whether to open Baz.hi
+ -- or Baz.hi-boot higher up the tree). This happens when a
+ -- module, Foo, that we explicitly imported has 'import Baz' in
+ -- its interface file, recording that Baz is below Foo in the
+ -- module dependency hierarchy. We want to propagate this
+ -- info. These modules are in a combination of HIT/PIT and
+ -- iImpModInfo
+ --
+ -- d) NothingAtAll: The name only of all orphan modules
+ -- we know of (this is needed so that anyone who imports us can
+ -- find the orphan modules) These modules are in a combination
+ -- of HIT/PIT and iImpModInfo
+
+ import_info0 = foldModuleEnv mk_imp_info [] pit
+ import_info1 = foldModuleEnv (mk_imp_info . hm_iface) import_info0 hpt
+ import_info = not_even_opened_imports ++ import_info1
+
+ -- Recall that iImpModInfo describes modules that have
+ -- been mentioned in the import lists of interfaces we
+ -- have seen mentioned, but which we have not even opened when
+ -- compiling this module
+ not_even_opened_imports =
+ [ (mod_name, orphans, is_boot, NothingAtAll)
+ | (mod_name, (orphans, is_boot)) <- fmToList (eps_imp_mods eps)]
+
+
+ mk_imp_info :: ModIface -> [ImportVersion Name] -> [ImportVersion Name]
+ mk_imp_info iface so_far
+
+ | Just ns <- lookupModuleEnv mv_map mod -- Case (a)
+ = go_for_it (Specifically mod_vers maybe_export_vers
+ (mk_import_items ns) rules_vers)
+
+ | mod `elemModuleSet` pkg_mods -- Case (b)
+ = go_for_it (Everything mod_vers)
+
+ | import_all_mod -- Case (a) and (b); the import-all part
+ = if is_home_pkg_mod then
+ go_for_it (Specifically mod_vers (Just export_vers) [] rules_vers)
+ -- Since the module isn't in the mv_map, presumably we
+ -- didn't actually import anything at all from it
+ else
+ go_for_it (Everything mod_vers)
+
+ | is_home_pkg_mod || has_orphans -- Case (c) or (d)
+ = go_for_it NothingAtAll
+
+ | otherwise = so_far
+ where
+ go_for_it exports = (mod_name, has_orphans, mi_boot iface, exports) : so_far
+
+ mod = mi_module iface
+ mod_name = moduleName mod
+ is_home_pkg_mod = isHomeModule mod
+ version_info = mi_version iface
+ version_env = vers_decls version_info
+ mod_vers = vers_module version_info
+ rules_vers = vers_rules version_info
+ export_vers = vers_exports version_info
+ import_all_mod = mod_name `elem` import_all_mods
+ has_orphans = mi_orphan iface
+
+ -- The sort is to put them into canonical order
+ mk_import_items ns = [(n,v) | n <- sortLt lt_occ ns,
+ let v = lookupVersion version_env n
+ ]
+ where
+ lt_occ n1 n2 = nameOccName n1 < nameOccName n2
+
+ maybe_export_vers | import_all_mod = Just (vers_exports version_info)
+ | otherwise = Nothing
+ in
+
+ -- seq the list of ImportVersions returned: occasionally these
+ -- don't get evaluated for a while and we can end up hanging on to
+ -- the entire collection of Ifaces.
+ import_info `seqList` import_info
+\end{code}
+
+\begin{code}
+groupAvails :: Module -> Avails -> [(ModuleName, Avails)]
+ -- Group by module and sort by occurrence
+ -- This keeps the list in canonical order
+groupAvails this_mod avails
+ = [ (mkSysModuleNameFS fs, sortLt lt avails)
+ | (fs,avails) <- fmToList groupFM
+ ]
+ where
+ groupFM :: FiniteMap FastString Avails
+ -- Deliberately use the FastString so we
+ -- get a canonical ordering
+ groupFM = foldl add emptyFM avails
+
+ add env avail = addToFM_C combine env mod_fs [avail']
+ where
+ mod_fs = moduleNameFS (moduleName avail_mod)
+ avail_mod = case nameModule_maybe (availName avail) of
+ Just m -> m
+ Nothing -> this_mod
+ combine old _ = avail':old
+ avail' = sortAvail avail
+
+ a1 `lt` a2 = occ1 < occ2
+ where
+ occ1 = nameOccName (availName a1)
+ occ2 = nameOccName (availName a2)
+
+sortAvail :: AvailInfo -> AvailInfo
+-- Sort the sub-names into canonical order.
+-- The canonical order has the "main name" at the beginning
+-- (if it's there at all)
+sortAvail (Avail n) = Avail n
+sortAvail (AvailTC n ns) | n `elem` ns = AvailTC n (n : sortLt lt (filter (/= n) ns))
+ | otherwise = AvailTC n ( sortLt lt ns)
+ where
+ n1 `lt` n2 = nameOccName n1 < nameOccName n2
+\end{code}
+
%************************************************************************
%* *
\subsection{Checking if the new interface is up to date
\end{code}
-
-%************************************************************************
-%* *
-\subsection{Writing ModDetails}
-%* *
-%************************************************************************
-
-\begin{code}
-pprModDetails :: ModDetails -> SDoc
-pprModDetails (ModDetails { md_types = type_env, md_insts = dfun_ids, md_rules = rules })
- = vcat [ dump_types dfun_ids type_env
- , dump_insts dfun_ids
- , dump_rules rules]
-
-dump_types :: [Var] -> TypeEnv -> SDoc
-dump_types dfun_ids type_env
- = text "TYPE SIGNATURES" $$ nest 4 (dump_sigs ids)
- where
- ids = [id | id <- typeEnvIds type_env, want_sig id]
- want_sig id | opt_PprStyle_Debug = True
- | otherwise = isLocalId id &&
- isExternalName (idName id) &&
- not (id `elem` dfun_ids)
- -- isLocalId ignores data constructors, records selectors etc
- -- The isExternalName ignores local dictionary and method bindings
- -- that the type checker has invented. User-defined things have
- -- Global names.
-
-dump_insts :: [Var] -> SDoc
-dump_insts [] = empty
-dump_insts dfun_ids = text "INSTANCES" $$ nest 4 (dump_sigs dfun_ids)
-
-dump_sigs :: [Var] -> SDoc
-dump_sigs ids
- -- Print type signatures
- -- Convert to HsType so that we get source-language style printing
- -- And sort by RdrName
- = vcat $ map ppr_sig $ sortLt lt_sig $
- [ (toRdrName id, toHsType (idType id))
- | id <- ids ]
- where
- lt_sig (n1,_) (n2,_) = n1 < n2
- ppr_sig (n,t) = ppr n <+> dcolon <+> ppr t
-
-dump_rules :: [IdCoreRule] -> SDoc
-dump_rules [] = empty
-dump_rules rs = vcat [ptext SLIT("{-# RULES"),
- nest 4 (pprIdRules rs),
- ptext SLIT("#-}")]
-\end{code}
-
-
-%************************************************************************
+b%************************************************************************
%* *
\subsection{Writing an interface file}
%* *
\end{code}
\begin{code}
-pprFixities :: NameEnv Fixity
- -> [TyClDecl Name pat]
+pprFixities :: FixityEnv
+ -> [TyClDecl Name]
-> SDoc
pprFixities fixity_map decls
= hsep [ ppr fix <+> ppr n
- | (n,fix) <- collectFixities fixity_map decls ] <> semi
+ | FixitySig n fix _ <- collectFixities fixity_map decls ] <> semi
-- Disgusting to print these two together, but that's
-- the way the interface parser currently expects them.
\section{Package manipulation}
\begin{code}
-module Packages ( PackageConfig(..),
- defaultPackageConfig,
- mungePackagePaths,
- showPackages
- )
+module Packages (
+ PackageConfig(..),
+ defaultPackageConfig,
+ mungePackagePaths, packageDependents,
+ showPackages,
+
+ PackageName, -- Instance of Outputable
+ mkPackageName, packageNameString,
+ preludePackage, rtsPackage, stdPackage, haskell98Package, -- :: PackageName
+
+ PackageConfigMap, emptyPkgMap, extendPkgMap, lookupPkg
+ )
where
#include "HsVersions.h"
import DriverUtil ( my_prefix_match )
import ErrUtils ( dumpIfSet )
import Outputable ( docToSDoc )
+import FastString
+import UniqFM
\end{code}
+%*********************************************************
+%* *
+\subsection{Basic data types}
+%* *
+%*********************************************************
+
\begin{code}
#define WANT_PRETTY
#define INTERNAL_PRETTY
-- There's a blob of code shared with ghc-pkg,
-- so we just include it from there
+-- Primarily it defines
+-- PackageConfig (a record)
+-- PackageName (FastString)
+
#include "../utils/ghc-pkg/Package.hs"
\end{code}
+\begin{code}
+type PackageName = FastString -- No encoding at all
+
+mkPackageName :: String -> PackageName
+mkPackageName = mkFastString
+
+packageNameString :: PackageName -> String
+packageNameString = unpackFS
+
+stdPackage, rtsPackage, preludePackage, haskell98Package :: PackageName
+preludePackage = FSLIT("base")
+stdPackage = FSLIT("std") -- Do we still have this?
+rtsPackage = FSLIT("rts")
+haskell98Package = FSLIT("haskell98")
+
+packageDependents :: PackageConfig -> [PackageName]
+-- Impedence matcher, because PackageConfig has Strings
+-- not PackageNames at the moment. Sigh.
+packageDependents pkg = map mkPackageName (package_deps pkg)
+\end{code}
+
+A PackageConfigMap maps a PackageName to a PackageConfig
+
+\begin{code}
+type PackageConfigMap = UniqFM PackageConfig
+
+lookupPkg :: PackageConfigMap -> PackageName -> Maybe PackageConfig
+emptyPkgMap :: PackageConfigMap
+
+emptyPkgMap = emptyUFM
+lookupPkg = lookupUFM
+
+extendPkgMap :: PackageConfigMap -> [PackageConfig] -> PackageConfigMap
+extendPkgMap pkg_map new_pkgs
+ = foldl add pkg_map new_pkgs
+ where
+ add pkg_map p = addToUFM pkg_map (mkFastString (name p)) p
+\end{code}
+
%*********************************************************
%* *
\subsection{Load the config file}
%*********************************************************
\begin{code}
-showPackages :: [PackageConfig] -> IO ()
+showPackages :: PackageConfigMap -> IO ()
-- Show package info on console, if verbosity is >= 3
-showPackages ps
+showPackages pkg_map
= do { verb <- dynFlag verbosity
; dumpIfSet (verb >= 3) "Packages"
(docToSDoc (vcat (map dumpPkgGuts ps)))
}
+ where
+ ps = eltsUFM pkg_map
\end{code}
import EXCEPTION ( catchAllIO )
#endif
+import CString ( CString, peekCString )
import DATA_IOREF ( IORef, readIORef, writeIORef )
import DATA_INT
#else
import List ( isPrefixOf )
import Util ( dropList )
-import MarshalArray
+-- import Foreign.Marshal.Array
import Foreign
-import CString
+-- import CString
#endif
#ifdef mingw32_HOST_OS
import OccName ( TidyOccEnv, initTidyOccEnv, tidyOccName )
import Type ( tidyTopType )
import Module ( Module, moduleName )
-import HscTypes ( PersistentCompilerState( pcs_PRS ),
- PersistentRenamerState( prsOrig ),
- NameSupply( nsNames, nsUniqs ),
+import HscTypes ( PersistentCompilerState( pcs_nc ),
+ NameCache( nsNames, nsUniqs ),
TypeEnv, extendTypeEnvList, typeEnvIds,
- ModDetails(..), TyThing(..)
+ ModGuts(..), ModGuts, TyThing(..)
)
import FiniteMap ( lookupFM, addToFM )
import Maybes ( orElse )
[Even non-exported things need system-wide Uniques because the
byte-code generator builds a single Name->BCO symbol table.]
- We use the NameSupply kept in the PersistentRenamerState as the
+ We use the NameCache kept in the PersistentCompilerState as the
source of such system-wide uniques.
- For external Ids, use the original-name cache in the NameSupply
+ For external Ids, use the original-name cache in the NameCache
to ensure that the unique assigned is the same as the Id had
in any previous compilation run.
RHSs, so that they print nicely in interfaces.
\begin{code}
-tidyCorePgm :: DynFlags -> Module
+tidyCorePgm :: DynFlags
-> PersistentCompilerState
-> CgInfoEnv -- Information from the back end,
-- to be splatted into the IdInfo
- -> ModDetails
- -> IO (PersistentCompilerState, ModDetails)
+ -> ModGuts
+ -> IO (PersistentCompilerState, ModGuts)
-tidyCorePgm dflags mod pcs cg_info_env
- (ModDetails { md_types = env_tc, md_insts = insts_tc,
- md_binds = binds_in, md_rules = orphans_in })
+tidyCorePgm dflags pcs cg_info_env
+ mod_impl@(ModGuts { mg_module = mod,
+ mg_types = env_tc, mg_insts = insts_tc,
+ mg_binds = binds_in, mg_rules = orphans_in })
= do { showPass dflags "Tidy Core"
; let ext_ids = findExternalSet binds_in orphans_in
-- 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. tidyTopId then does a no-op on exported binders.
- ; let prs = pcs_PRS pcs
- orig_ns = prsOrig prs
-
+ ; let orig_ns = pcs_nc pcs
init_tidy_env = (orig_ns, initTidyOccEnv avoids, emptyVarEnv)
avoids = [getOccName name | bndr <- typeEnvIds env_tc,
let name = idName bndr,
; let tidy_rules = tidyIdRules (occ_env,subst_env) ext_rules
- ; let prs' = prs { prsOrig = orig_ns' }
- pcs' = pcs { pcs_PRS = prs' }
+ ; let pcs' = pcs { pcs_nc = orig_ns' }
; let final_ids = [ id
| bind <- tidy_binds
; let tidy_type_env = mkFinalTypeEnv env_tc final_ids
tidy_dfun_ids = map lookup_dfun_id insts_tc
- ; let tidy_details = ModDetails { md_types = tidy_type_env,
- md_rules = tidy_rules,
- md_insts = tidy_dfun_ids,
- md_binds = tidy_binds }
+ ; let tidy_result = mod_impl { mg_types = tidy_type_env,
+ mg_rules = tidy_rules,
+ mg_insts = tidy_dfun_ids,
+ mg_binds = tidy_binds }
; endPass dflags "Tidy Core" Opt_D_dump_simpl tidy_binds
; dumpIfSet_core dflags Opt_D_dump_simpl
"Tidy Core Rules"
(pprIdRules tidy_rules)
- ; return (pcs', tidy_details)
+ ; return (pcs', tidy_result)
}
tidyCoreExpr :: CoreExpr -> IO CoreExpr
\begin{code}
-type TopTidyEnv = (NameSupply, TidyOccEnv, VarEnv Var)
+type TopTidyEnv = (NameCache, TidyOccEnv, VarEnv Var)
-- TopTidyEnv: when tidying we need to know
--- * ns: The NameSupply, containing a unique supply and any pre-ordained Names.
+-- * ns: The NameCache, containing a unique supply and any pre-ordained Names.
-- These may have arisen because the
-- renamer read in an interface file mentioning M.$wf, say,
-- and assigned it unique r77. If, on this compilation, we've
pprStixStmts, pprStixStmt,
stixStmt_CountTempUses, stixStmt_Subst,
liftStrings,
- initNat, mapNat,
+ initNat,
mkNatM_State,
uniqOfNatM_State, deltaOfNatM_State )
import UniqSupply ( returnUs, thenUs, initUs,
namesNeededForFlattening :: FreeVars
namesNeededForFlattening
| not opt_Flatten = emptyFVs -- none without -fflatten
- | otherwise = mkFVs
- [fstName, andName, orName, lengthPName, replicatePName, mapPName,
- bpermutePName, bpermuteDftPName, indexOfPName]
+ | otherwise
+ = mkFVs [fstName, andName, orName, lengthPName, replicatePName, mapPName,
+ bpermutePName, bpermuteDftPName, indexOfPName]
-- stuff from PrelGHC doesn't have to go here
import Var (Var(..))
import Id (Id, mkSysLocal)
import Name (Name)
-import VarSet (VarSet, emptyVarSet, unitVarSet, extendVarSet,
- varSetElems, unionVarSet)
-import VarEnv (VarEnv, emptyVarEnv, unitVarEnv, zipVarEnv, plusVarEnv,
+import VarSet (VarSet, emptyVarSet, extendVarSet, varSetElems )
+import VarEnv (VarEnv, emptyVarEnv, zipVarEnv, plusVarEnv,
elemVarEnv, lookupVarEnv, lookupVarEnv_NF, delVarEnvList)
import TyCon (tyConName)
import Type (Type, tyConAppTyCon)
-import HscTypes (HomeSymbolTable, PersistentCompilerState(..),
+import HscTypes (HomePackageTable, PersistentCompilerState(pcs_EPS),
+ ExternalPackageState(eps_PTE), HscEnv(hsc_HPT),
TyThing(..), lookupType)
import PrelNames (charPrimTyConName, intPrimTyConName, floatPrimTyConName,
doublePrimTyConName, fstName, andName, orName,
import PrimOp (eqCharName, eqIntName, eqFloatName, eqDoubleName,
neqIntName)
-- neqCharName, neqFloatName,neqDoubleName,
-import CoreSyn (Expr(..), Bind(..), CoreBndr, CoreExpr, CoreBind, mkApps,
- bindersOfBinds)
+import CoreSyn (Expr(..), Bind(..), CoreBndr, CoreExpr, CoreBind, mkApps)
import CoreUtils (exprType)
-- friends
-- initial value of the flattening state
--
initialFlattenState :: PersistentCompilerState
- -> HomeSymbolTable
+ -> HomePackageTable
-> UniqSupply
-> FlattenState
-initialFlattenState pcs hst us =
+initialFlattenState pcs hpt us =
FlattenState {
us = us,
env = lookup,
}
where
lookup n =
- case lookupType hst (pcs_PTE pcs) n of
+ case lookupType hpt (eps_PTE (pcs_EPS pcs)) n of
Just (AnId v) -> v
_ -> pprPanic "FlattenMonad: unknown name:" (ppr n)
-- execute the given flattening computation (EXPORTED)
--
-runFlatten :: PersistentCompilerState
- -> HomeSymbolTable
+runFlatten :: HscEnv
+ -> PersistentCompilerState
-> UniqSupply
-> Flatten a
-> a
-runFlatten pcs hst us m = fst $ unFlatten m (initialFlattenState pcs hst us)
+runFlatten hsc_env pcs us m
+ = fst $ unFlatten m (initialFlattenState pcs (hsc_HPT hsc_env) us)
-- variable generation
import CmdLineOpts (opt_Flatten)
import Panic (panic)
import ErrUtils (dumpIfSet_dyn)
-import UniqSupply (UniqSupply, mkSplitUniqSupply)
-import CmdLineOpts (DynFlag(..), DynFlags)
+import UniqSupply (mkSplitUniqSupply)
+import CmdLineOpts (DynFlag(..))
import Literal (Literal, literalType)
-import Var (Var(..),TyVar)
+import Var (Var(..))
import DataCon (DataCon, dataConTag)
import TypeRep (Type(..))
import Type (isTypeKind)
-import HscTypes (HomeSymbolTable, PersistentCompilerState, ModDetails(..))
+import HscTypes (PersistentCompilerState, ModGuts(..),
+ ModGuts, HscEnv(..) )
import CoreFVs (exprFreeVars)
import CoreSyn (Expr(..), Bind(..), Alt(..), AltCon(..), Note(..),
- CoreBndr, CoreExpr, CoreBind, CoreAlt, mkLams, mkLets,
+ CoreBndr, CoreExpr, CoreBind, mkLams, mkLets,
mkApps, mkIntLitInt)
import PprCore (pprCoreExpr)
import CoreLint (showPass, endPass)
import CoreUtils (exprType, applyTypeToArg, mkPiType)
-import VarEnv (IdEnv, mkVarEnv, zipVarEnv, extendVarEnv)
+import VarEnv (zipVarEnv)
import TysWiredIn (mkTupleTy)
import BasicTypes (Boxity(..))
-import Outputable (showSDoc, Outputable(..))
+import Outputable
import FastString
+
-- FIXME: fro debugging - remove this
import TRACE (trace)
-- entry point to the flattening transformation for the compiler driver when
-- compiling a complete module (EXPORTED)
--
-flatten :: DynFlags
+flatten :: HscEnv
-> PersistentCompilerState
- -> HomeSymbolTable
- -> ModDetails -- the module to be flattened
- -> IO ModDetails
-flatten dflags pcs hst modDetails@(ModDetails {md_binds = binds})
- | not opt_Flatten = return modDetails -- skip without -fflatten
+ -> ModGuts
+ -> IO ModGuts
+flatten hsc_env pcs mod_impl@(ModGuts {mg_binds = binds})
+ | not opt_Flatten = return mod_impl -- skip without -fflatten
| otherwise =
do
+ let dflags = hsc_dflags hsc_env
+
us <- mkSplitUniqSupply 'l' -- 'l' as in fLattening
--
-- announce vectorisation
--
-- vectorise all toplevel bindings
--
- let binds' = runFlatten pcs hst us $ vectoriseTopLevelBinds binds
+ let binds' = runFlatten hsc_env pcs us $ vectoriseTopLevelBinds binds
--
-- and dump the result if requested
--
endPass dflags "Flattening [first phase: vectorisation]"
Opt_D_dump_vect binds'
- return $ modDetails {md_binds = binds'}
+ return $ mod_impl {mg_binds = binds'}
-- entry point to the flattening transformation for the compiler driver when
-- compiling a single expression in interactive mode (EXPORTED)
--
-flattenExpr :: DynFlags
+flattenExpr :: HscEnv
-> PersistentCompilerState
- -> HomeSymbolTable
-> CoreExpr -- the expression to be flattened
-> IO CoreExpr
-flattenExpr dflags pcs hst expr
+flattenExpr hsc_env pcs expr
| not opt_Flatten = return expr -- skip without -fflatten
| otherwise =
do
+ let dflags = hsc_dflags hsc_env
+
us <- mkSplitUniqSupply 'l' -- 'l' as in fLattening
--
-- announce vectorisation
--
-- vectorise the expression
--
- let expr' = fst . runFlatten pcs hst us $ vectorise expr
+ let expr' = fst . runFlatten hsc_env pcs us $ vectorise expr
--
-- and dump the result if requested
--
| ITclose_prag
| ITdotdot -- reserved symbols
+ | ITcolon
| ITdcolon
| ITequal
| ITlam
| ITprimdouble Rational
| ITlitlit FastString
+ -- MetaHaskell extension tokens
+ | ITopenExpQuote -- [| or [e|
+ | ITopenPatQuote -- [p|
+ | ITopenDecQuote -- [d|
+ | ITopenTypQuote -- [t|
+ | ITcloseQuote -- |]
+ | ITidEscape FastString -- $x
+ | ITparenEscape -- $(
+
| ITunknown String -- Used when the lexer can't make sense of it
| ITeof -- end of file token
deriving Show -- debugging
haskellKeySymsFM = listToUFM $
map (\ (x,y) -> (mkFastString x,y))
[ ("..", ITdotdot)
+ ,(":", ITcolon) -- (:) is a reserved op,
+ -- meaning only list cons
,("::", ITdcolon)
,("=", ITequal)
,("\\", ITlam)
,("*", ITstar)
,(".", ITdot) -- sadly, for 'forall a . t'
]
+
\end{code}
-----------------------------------------------------------------------------
-- processing if necessary).
'{'# | lookAhead# buf 1# `eqChar#` '-'# ->
if lookAhead# buf 2# `eqChar#` '#'# then
- case expandWhile# is_space (setCurrentPos# buf 3#) of { buf1->
+ case expandWhile# is_space (addToCurrentPos buf 3#) of { buf1->
case expandWhile# is_ident (stepOverLexeme buf1) of { buf2->
let lexeme = mkFastString -- ToDo: too slow
(map toUpper (lexemeToString buf2)) in
-- special symbols ----------------------------------------------------
'('# | glaExtsEnabled exts && lookAhead# buf 1# `eqChar#` '#'#
- -> cont IToubxparen (setCurrentPos# buf 2#)
+ -> cont IToubxparen (addToCurrentPos buf 2#)
| otherwise
- -> cont IToparen (incLexeme buf)
+ -> cont IToparen (incCurrentPos buf)
- ')'# -> cont ITcparen (incLexeme buf)
+ ')'# -> cont ITcparen (incCurrentPos buf)
'['# | parrEnabled exts && lookAhead# buf 1# `eqChar#` ':'# ->
- cont ITopabrack (setCurrentPos# buf 2#)
- | otherwise ->
- cont ITobrack (incLexeme buf)
- ']'# -> cont ITcbrack (incLexeme buf)
- ','# -> cont ITcomma (incLexeme buf)
- ';'# -> cont ITsemi (incLexeme buf)
+ cont ITopabrack (addToCurrentPos buf 2#)
+ ------- MetaHaskell Extensions, looking for [| [e| [t| [p| and [d|
+ | glaExtsEnabled exts &&
+ ((lookAhead# buf 1# ) `eqChar#` '|'# ) ->
+ cont ITopenExpQuote (addToCurrentPos buf 2# )
+ | glaExtsEnabled exts &&
+ (let c = (lookAhead# buf 1# )
+ in eqChar# c 'e'# || eqChar# c 't'# || eqChar# c 'd'# || eqChar# c 'p'#) &&
+ ((lookAhead# buf 2#) `eqChar#` '|'#) ->
+ let quote 'e'# = ITopenExpQuote
+ quote 'p'# = ITopenPatQuote
+ quote 'd'# = ITopenDecQuote
+ quote 't'# = ITopenTypQuote
+ in cont (quote (lookAhead# buf 1#)) (addToCurrentPos buf 3# )
+ | otherwise ->
+ cont ITobrack (incCurrentPos buf)
+
+ ']'# -> cont ITcbrack (incCurrentPos buf)
+ ','# -> cont ITcomma (incCurrentPos buf)
+ ';'# -> cont ITsemi (incCurrentPos buf)
'}'# -> \ s@PState{context = ctx} ->
case ctx of
- (_:ctx') -> cont ITccurly (incLexeme buf) s{context=ctx'}
+ (_:ctx') -> cont ITccurly (incCurrentPos buf) s{context=ctx'}
_ -> lexError "too many '}'s" buf s
'|'# -> case lookAhead# buf 1# of
'}'# | glaExtsEnabled exts -> cont ITccurlybar
- (setCurrentPos# buf 2#)
- _ -> lex_sym cont (incLexeme buf)
+ (addToCurrentPos buf 2#)
+ -- MetaHaskell extension
+ ']'# | glaExtsEnabled exts -> cont ITcloseQuote (addToCurrentPos buf 2#)
+ other -> lex_sym cont (incCurrentPos buf)
':'# -> case lookAhead# buf 1# of
']'# | parrEnabled exts -> cont ITcpabrack
- (setCurrentPos# buf 2#)
- _ -> lex_sym cont (incLexeme buf)
+ (addToCurrentPos buf 2#)
+ _ -> lex_sym cont (incCurrentPos buf)
'#'# -> case lookAhead# buf 1# of
')'# | glaExtsEnabled exts
- -> cont ITcubxparen (setCurrentPos# buf 2#)
+ -> cont ITcubxparen (addToCurrentPos buf 2#)
'-'# -> case lookAhead# buf 2# of
- '}'# -> cont ITclose_prag (setCurrentPos# buf 3#)
- _ -> lex_sym cont (incLexeme buf)
- _ -> lex_sym cont (incLexeme buf)
+ '}'# -> cont ITclose_prag (addToCurrentPos buf 3#)
+ _ -> lex_sym cont (incCurrentPos buf)
+ _ -> lex_sym cont (incCurrentPos buf)
'`'# | glaExtsEnabled exts && lookAhead# buf 1# `eqChar#` '`'#
- -> lex_cstring cont (setCurrentPos# buf 2#)
+ -> lex_cstring cont (addToCurrentPos buf 2#)
| otherwise
- -> cont ITbackquote (incLexeme buf)
+ -> cont ITbackquote (incCurrentPos buf)
'{'# -> -- for Emacs: -}
case lookAhead# buf 1# of
'|'# | glaExtsEnabled exts
- -> cont ITocurlybar (setCurrentPos# buf 2#)
+ -> cont ITocurlybar (addToCurrentPos buf 2#)
'-'# -> case lookAhead# buf 2# of
- '#'# -> lex_prag cont (setCurrentPos# buf 3#)
- _ -> cont ITocurly (incLexeme buf)
- _ -> (layoutOff `thenP_` cont ITocurly) (incLexeme buf)
+ '#'# -> lex_prag cont (addToCurrentPos buf 3#)
+ _ -> cont ITocurly (incCurrentPos buf)
+ _ -> (layoutOff `thenP_` cont ITocurly) (incCurrentPos buf)
+
+
+
-- strings/characters -------------------------------------------------
- '\"'#{-"-} -> lex_string cont exts [] (incLexeme buf)
- '\''# -> lex_char (char_end cont) exts (incLexeme buf)
+ '\"'#{-"-} -> lex_string cont exts [] (incCurrentPos buf)
+ '\''# -> lex_char (char_end cont) exts (incCurrentPos buf)
-- Hexadecimal and octal constants
'0'# | (ch `eqChar#` 'x'# || ch `eqChar#` 'X'#) && is_hexdigit ch2
-> readNum (after_lexnum cont exts) buf' is_octdigit 8 oct_or_dec
where ch = lookAhead# buf 1#
ch2 = lookAhead# buf 2#
- buf' = setCurrentPos# buf 2#
+ buf' = addToCurrentPos buf 2#
'\NUL'# ->
if bufferExhausted (stepOn buf) then
trace "lexIface: misplaced NUL?" $
cont (ITunknown "\NUL") (stepOn buf)
- '?'# | glaExtsEnabled exts && is_lower (lookAhead# buf 1#) ->
- lex_ip ITdupipvarid cont (incLexeme buf)
+ '?'# | glaExtsEnabled exts && is_lower (lookAhead# buf 1#) -> -- ?x implicit parameter
+ specialPrefixId ITdupipvarid cont exts (incCurrentPos buf)
'%'# | glaExtsEnabled exts && is_lower (lookAhead# buf 1#) ->
- lex_ip ITsplitipvarid cont (incLexeme buf)
+ specialPrefixId ITsplitipvarid cont exts (incCurrentPos buf)
+
+ ---------------- MetaHaskell Extensions for quotation escape
+ '$'# | glaExtsEnabled exts && is_lower (lookAhead# buf 1#) -> -- $x variable escape
+ specialPrefixId ITidEscape cont exts (addToCurrentPos buf 1#)
+ '$'# | glaExtsEnabled exts && -- $( f x ) expression escape
+ ((lookAhead# buf 1#) `eqChar#` '('#) -> cont ITparenEscape (addToCurrentPos buf 2#)
+
c | is_digit c -> lex_num cont exts 0 buf
| is_symbol c -> lex_sym cont buf
| is_upper c -> lex_con cont exts buf
- | is_ident c -> lex_id cont exts buf
+ | is_lower c -> lex_id cont exts buf
| otherwise -> lexError "illegal character" buf
-- Int# is unlifted, and therefore faster than Bool for flags.
lex_string cont exts s buf
= case currentChar# buf of
'"'#{-"-} ->
- let buf' = incLexeme buf
+ let buf' = incCurrentPos buf
s' = mkFastString (map chr (reverse s))
in case currentChar# buf' of
'#'# | glaExtsEnabled exts -> if all (<= 0xFF) s
- then cont (ITprimstring s') (incLexeme buf')
+ then cont (ITprimstring s') (incCurrentPos buf')
else lexError "primitive string literal must contain only characters <= \'\\xFF\'" buf'
_ -> cont (ITstring s') buf'
'\\'# | next_ch `eqChar#` '&'#
-> lex_string cont exts s buf'
| is_space next_ch
- -> lex_stringgap cont exts s (incLexeme buf)
+ -> lex_stringgap cont exts s (incCurrentPos buf)
where next_ch = lookAhead# buf 1#
- buf' = setCurrentPos# buf 2#
+ buf' = addToCurrentPos buf 2#
_ -> lex_char (lex_next_string cont s) exts buf
lex_stringgap cont exts s buf
- = let buf' = incLexeme buf in
+ = let buf' = incCurrentPos buf in
case currentChar# buf of
'\n'# -> \st@PState{loc = loc} -> lex_stringgap cont exts s buf'
st{loc = incSrcLine loc}
lex_char :: (Int# -> Int -> P a) -> Int# -> P a
lex_char cont exts buf
= case currentChar# buf of
- '\\'# -> lex_escape (cont exts) (incLexeme buf)
- c | is_any c -> cont exts (I# (ord# c)) (incLexeme buf)
+ '\\'# -> lex_escape (cont exts) (incCurrentPos buf)
+ c | is_any c -> cont exts (I# (ord# c)) (incCurrentPos buf)
other -> charError buf
char_end cont exts c buf
= case currentChar# buf of
- '\''# -> let buf' = incLexeme buf in
+ '\''# -> let buf' = incCurrentPos buf in
case currentChar# buf' of
'#'# | glaExtsEnabled exts
- -> cont (ITprimchar c) (incLexeme buf')
+ -> cont (ITprimchar c) (incCurrentPos buf')
_ -> cont (ITchar c) buf'
_ -> charError buf
lex_escape cont buf
- = let buf' = incLexeme buf in
+ = let buf' = incCurrentPos buf in
case currentChar# buf of
'a'# -> cont (ord '\a') buf'
'b'# -> cont (ord '\b') buf'
'\''# -> cont (ord '\'') buf'
'^'# -> let c = currentChar# buf' in
if c `geChar#` '@'# && c `leChar#` '_'#
- then cont (I# (ord# c -# ord# '@'#)) (incLexeme buf')
+ then cont (I# (ord# c -# ord# '@'#)) (incCurrentPos buf')
else charError buf'
'x'# -> readNum (after_charnum cont) buf' is_hexdigit 16 hex
where read buf i
= case currentChar# buf of { c ->
if is_digit c
- then read (incLexeme buf) (i*base + (toInteger (I# (conv c))))
+ then read (incCurrentPos buf) (i*base + (toInteger (I# (conv c))))
else cont i buf
}
-- this case is not optimised at all, as the
-- presence of floating point numbers in interface
-- files is not that common. (ToDo)
- case expandWhile# is_digit (incLexeme buf') of
+ case expandWhile# is_digit (incCurrentPos buf') of
buf2 -> -- points to first non digit char
let l = case currentChar# buf2 of
_ -> buf2
do_exponent
- = let buf3 = incLexeme buf2 in
+ = let buf3 = incCurrentPos buf2 in
case currentChar# buf3 of
'-'# | is_digit (lookAhead# buf3 1#)
- -> expandWhile# is_digit (incLexeme buf3)
+ -> expandWhile# is_digit (incCurrentPos buf3)
'+'# | is_digit (lookAhead# buf3 1#)
- -> expandWhile# is_digit (incLexeme buf3)
+ -> expandWhile# is_digit (incCurrentPos buf3)
x | is_digit x -> expandWhile# is_digit buf3
_ -> buf2
v = readRational__ (lexemeToString l)
in case currentChar# l of -- glasgow exts only
- '#'# | glaExtsEnabled exts -> let l' = incLexeme l in
+ '#'# | glaExtsEnabled exts -> let l' = incCurrentPos l in
case currentChar# l' of
- '#'# -> cont (ITprimdouble v) (incLexeme l')
+ '#'# -> cont (ITprimdouble v) (incCurrentPos l')
_ -> cont (ITprimfloat v) l'
_ -> cont (ITrational v) l
after_lexnum cont exts i buf
= case currentChar# buf of
- '#'# | glaExtsEnabled exts -> cont (ITprimint i) (incLexeme buf)
+ '#'# | glaExtsEnabled exts -> cont (ITprimint i) (incCurrentPos buf)
_ -> cont (ITinteger i) buf
readRational :: ReadS Rational -- NB: doesn't handle leading "-"
lex_cstring cont buf =
case expandUntilMatch (stepOverLexeme buf) "\'\'" of
Just buf' -> cont (ITlitlit (lexemeToFastString
- (setCurrentPos# buf' (negateInt# 2#))))
+ (addToCurrentPos buf' (negateInt# 2#))))
(mergeLexemes buf buf')
Nothing -> lexError "unterminated ``" buf
-----------------------------------------------------------------------------
-- identifiers, symbols etc.
-lex_ip ip_constr cont buf =
+-- used for identifiers with special prefixes like
+-- ?x (implicit parameters), $x (MetaHaskell escapes) and #x
+-- we've already seen the prefix char, so look for an id, and wrap
+-- the new "ip_constr" around the lexeme returned
+
+specialPrefixId ip_constr cont exts buf = lex_id newcont exts buf
+ where newcont (ITvarid lexeme) buf2 = cont (ip_constr (tailFS lexeme)) buf2
+ newcont token buf2 = cont token buf2
+{-
case expandWhile# is_ident buf of
buf' -> cont (ip_constr (tailFS lexeme)) buf'
where lexeme = lexemeToFastString buf'
+-}
lex_id cont exts buf =
let buf1 = expandWhile# is_ident buf in
buf' -> case lookupUFM haskellKeySymsFM lexeme of {
Just kwd_token -> --trace ("keysym: "++unpackFS lexeme) $
cont kwd_token buf' ;
- Nothing -> --trace ("sym: "++unpackFS lexeme) $
- cont (mk_var_token lexeme) buf'
+ Nothing -> --trace ("sym: "++unpackFS lexeme) $
+ cont (mk_var_token lexeme) buf'
}
where lexeme = lexemeToFastString buf'
let all_buf = mergeLexemes buf con_buf
con_lexeme = lexemeToFastString con_buf
- mod_lexeme = lexemeToFastString (decLexeme buf)
+ mod_lexeme = lexemeToFastString (decCurrentPos buf)
all_lexeme = lexemeToFastString all_buf
just_a_conid
case currentChar# all_buf of
'.'# -> maybe_qualified cont exts all_lexeme
- (incLexeme all_buf) just_a_conid
+ (incCurrentPos all_buf) just_a_conid
_ -> just_a_conid
}}
case currentChar# buf of
'['# -> -- Special case for []
case lookAhead# buf 1# of
- ']'# -> cont (ITqconid (mod,FSLIT("[]"))) (setCurrentPos# buf 2#)
+ ']'# -> cont (ITqconid (mod,FSLIT("[]"))) (addToCurrentPos buf 2#)
_ -> just_a_conid
'('# -> -- Special case for (,,,)
-- This *is* necessary to deal with e.g. "instance C PrelBase.(,,)"
case lookAhead# buf 1# of
'#'# | glaExtsEnabled exts -> case lookAhead# buf 2# of
- ','# -> lex_ubx_tuple cont mod (setCurrentPos# buf 3#)
+ ','# -> lex_ubx_tuple cont mod (addToCurrentPos buf 3#)
just_a_conid
_ -> just_a_conid
- ')'# -> cont (ITqconid (mod,FSLIT("()"))) (setCurrentPos# buf 2#)
- ','# -> lex_tuple cont mod (setCurrentPos# buf 2#) just_a_conid
+ ')'# -> cont (ITqconid (mod,FSLIT("()"))) (addToCurrentPos buf 2#)
+ ','# -> lex_tuple cont mod (addToCurrentPos buf 2#) just_a_conid
_ -> just_a_conid
'-'# -> case lookAhead# buf 1# of
- '>'# -> cont (ITqconid (mod,FSLIT("(->)"))) (setCurrentPos# buf 2#)
+ '>'# -> cont (ITqconid (mod,FSLIT("(->)"))) (addToCurrentPos buf 2#)
_ -> lex_id3 cont exts mod buf just_a_conid
_ -> lex_id3 cont exts mod buf just_a_conid
\begin{code}
module ParseUtil (
parseError -- String -> Pa
- , mkVanillaCon, mkRecCon,
+ , mkPrefixCon, mkRecCon
, mkRecConstrOrUpdate -- HsExp -> [HsFieldUpdate] -> P HsExp
, groupBindings
import Lex
import HscTypes ( RdrAvailInfo, GenAvailInfo(..) )
import HsSyn -- Lots of it
+import TysWiredIn ( unitTyCon )
import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
DNCallSpec(..))
import SrcLoc
import RdrHsSyn
import RdrName
-import PrelNames ( unitTyCon_RDR )
-import OccName ( dataName, varName, tcClsName, isDataOcc,
- occNameSpace, setOccNameSpace, occNameUserString )
+import OccName ( dataName, varName, isDataOcc, isTcOcc, occNameUserString )
import CStrings ( CLabelString )
import FastString
import Outputable
-----------------------------------------------------------------------------
--- mkVanillaCon
+-- mkPrefixCon
-- When parsing data declarations, we sometimes inadvertently parse
-- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
-- This function splits up the type application, adds any pending
-- arguments, and converts the type constructor back into a data constructor.
-mkVanillaCon :: RdrNameHsType -> [RdrNameBangType] -> P (RdrName, RdrNameConDetails)
+mkPrefixCon :: RdrNameHsType -> [RdrNameBangType] -> P (RdrName, RdrNameConDetails)
-mkVanillaCon ty tys
+mkPrefixCon ty tys
= split ty tys
where
split (HsAppTy t u) ts = split t (unbangedType u : ts)
split (HsTyVar tc) ts = tyConToDataCon tc `thenP` \ data_con ->
- returnP (data_con, VanillaCon ts)
+ returnP (data_con, PrefixCon ts)
split _ _ = parseError "Illegal data/newtype declaration"
-mkRecCon :: RdrName -> [([RdrName],RdrNameBangType)] -> P (RdrName, RdrNameConDetails)
-mkRecCon con fields
- = tyConToDataCon con `thenP` \ data_con ->
- returnP (data_con, RecCon fields)
+mkRecCon :: [([RdrName],RdrNameBangType)] -> RdrNameConDetails
+mkRecCon fields
+ = RecCon [ (l,t) | (ls,t) <- fields, l <- ls ]
tyConToDataCon :: RdrName -> P RdrName
tyConToDataCon tc
- | occNameSpace tc_occ == tcClsName
- = returnP (setRdrNameOcc tc (setOccNameSpace tc_occ dataName))
+ | isTcOcc (rdrNameOcc tc)
+ = returnP (setRdrNameSpace tc dataName)
| otherwise
= parseError (showSDoc (text "Not a constructor:" <+> quotes (ppr tc)))
- where
- tc_occ = rdrNameOcc tc
-
----------------------------------------------------------------------------
-- Various Syntactic Checks
= checkContext ty
checkContext (HsTyVar t) -- Empty context shows up as a unit type ()
- | t == unitTyCon_RDR = returnP []
+ | t == getRdrName unitTyCon = returnP []
checkContext t
= checkPred t `thenP` \p ->
checkPatterns loc es = mapP (checkPattern loc) es
checkPat :: RdrNameHsExpr -> [RdrNamePat] -> P RdrNamePat
-checkPat (HsVar c) args | isRdrDataCon c = returnP (ConPatIn c args)
+checkPat (HsVar c) args | isRdrDataCon c = returnP (ConPatIn c (PrefixCon args))
checkPat (HsApp f x) args =
checkPat x [] `thenP` \x ->
checkPat f (x:args)
checkPat e [] = case e of
- EWildPat -> returnP WildPatIn
- HsVar x -> returnP (VarPatIn x)
- HsLit l -> returnP (LitPatIn l)
+ EWildPat -> returnP (WildPat placeHolderType)
+ HsVar x -> returnP (VarPat x)
+ HsLit l -> returnP (LitPat l)
HsOverLit l -> returnP (NPatIn l Nothing)
- ELazyPat e -> checkPat e [] `thenP` (returnP . LazyPatIn)
- EAsPat n e -> checkPat e [] `thenP` (returnP . AsPatIn n)
+ ELazyPat e -> checkPat e [] `thenP` (returnP . LazyPat)
+ EAsPat n e -> checkPat e [] `thenP` (returnP . AsPat n)
ExprWithTySig e t -> checkPat e [] `thenP` \e ->
-- Pattern signatures are parsed as sigtypes,
-- but they aren't explicit forall points. Hence
checkPat r [] `thenP` \r ->
case op of
HsVar c | isDataOcc (rdrNameOcc c)
- -> returnP (ConOpPatIn l c fix r)
+ -> returnP (ConPatIn c (InfixCon l r))
_ -> patFail
- HsPar e -> checkPat e [] `thenP` (returnP . ParPatIn)
+ HsPar e -> checkPat e [] `thenP` (returnP . ParPat)
ExplicitList _ es -> mapP (\e -> checkPat e []) es `thenP` \ps ->
- returnP (ListPatIn ps)
+ returnP (ListPat ps placeHolderType)
ExplicitPArr _ es -> mapP (\e -> checkPat e []) es `thenP` \ps ->
- returnP (PArrPatIn ps)
+ returnP (PArrPat ps placeHolderType)
ExplicitTuple es b -> mapP (\e -> checkPat e []) es `thenP` \ps ->
- returnP (TuplePatIn ps b)
+ returnP (TuplePat ps b)
RecordCon c fs -> mapP checkPatField fs `thenP` \fs ->
- returnP (RecPatIn c fs)
+ returnP (ConPatIn c (RecCon fs))
-- Generics
- HsType ty -> returnP (TypePatIn ty)
+ HsType ty -> returnP (TypePat ty)
_ -> patFail
checkPat _ _ = patFail
-checkPatField :: (RdrName, RdrNameHsExpr, Bool)
- -> P (RdrName, RdrNamePat, Bool)
-checkPatField (n,e,b) =
- checkPat e [] `thenP` \p ->
- returnP (n,p,b)
+checkPatField :: (RdrName, RdrNameHsExpr) -> P (RdrName, RdrNamePat)
+checkPatField (n,e) = checkPat e [] `thenP` \p ->
+ returnP (n,p)
patFail = parseError "Parse error in pattern"
{- -*-haskell-*-
-----------------------------------------------------------------------------
-$Id: Parser.y,v 1.101 2002/09/06 14:35:44 simonmar Exp $
+$Id: Parser.y,v 1.102 2002/09/13 15:02:37 simonpj Exp $
Haskell grammar.
import HsTypes ( mkHsTupCon )
import RdrHsSyn
-import RnMonad ( ParsedIface(..) )
+import HscTypes ( ParsedIface(..), IsBootInterface )
import Lex
import ParseUtil
import RdrName
-import PrelNames ( mAIN_Name, unitTyCon_RDR, funTyCon_RDR,
- listTyCon_RDR, parrTyCon_RDR, tupleTyCon_RDR,
- unitCon_RDR, nilCon_RDR, tupleCon_RDR )
+import PrelNames ( mAIN_Name, funTyConName, listTyConName,
+ parrTyConName, consDataConName, nilDataConName )
+import TysWiredIn ( unitTyCon, unitDataCon, tupleTyCon, tupleCon )
import ForeignCall ( Safety(..), CExportSpec(..),
CCallConv(..), CCallTarget(..), defaultCCallConv,
)
import CmdLineOpts ( opt_SccProfilingOn, opt_InPackage )
import Type ( Kind, mkArrowKind, liftedTypeKind )
import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..),
- NewOrData(..), StrictnessMark(..), Activation(..) )
+ NewOrData(..), StrictnessMark(..), Activation(..),
+ FixitySig(..) )
import Panic
import GLAEXTS
-}
'..' { ITdotdot } -- reserved symbols
+ ':' { ITcolon }
'::' { ITdcolon }
'=' { ITequal }
'\\' { ITlam }
PRIMFLOAT { ITprimfloat $$ }
PRIMDOUBLE { ITprimdouble $$ }
CLITLIT { ITlitlit $$ }
+
+-- Template Haskell
+'[|' { ITopenExpQuote }
+'[p|' { ITopenPatQuote }
+'[t|' { ITopenTypQuote }
+'[d|' { ITopenDecQuote }
+'|]' { ITcloseQuote }
+ID_SPLICE { ITidEscape $$ } -- $x
+'$(' { ITparenEscape } -- $( exp )
%monad { P } { thenP } { returnP }
%lexer { lexer } { ITeof }
module :: { RdrNameHsModule }
: srcloc 'module' modid maybemoddeprec maybeexports 'where' body
- { HsModule $3 Nothing $5 (fst $7) (snd $7) $4 $1 }
+ { HsModule (mkHomeModule $3) Nothing $5 (fst $7) (snd $7) $4 $1 }
| srcloc body
- { HsModule mAIN_Name Nothing Nothing (fst $2) (snd $2) Nothing $1 }
+ { HsModule (mkHomeModule mAIN_Name) Nothing Nothing
+ (fst $2) (snd $2) Nothing $1 }
maybemoddeprec :: { Maybe DeprecTxt }
: '{-# DEPRECATED' STRING '#-}' { Just $2 }
| export { [$1] }
| {- empty -} { [] }
- -- GHC extension: we allow things like [] and (,,,) to be exported
+ -- No longer allow things like [] and (,,,) to be exported
+ -- They are built in syntax, always available
export :: { RdrNameIE }
: qvar { IEVar $1 }
- | gtycon { IEThingAbs $1 }
- | gtycon '(' '..' ')' { IEThingAll $1 }
- | gtycon '(' ')' { IEThingWith $1 [] }
- | gtycon '(' qcnames ')' { IEThingWith $1 (reverse $3) }
+ | oqtycon { IEThingAbs $1 }
+ | oqtycon '(' '..' ')' { IEThingAll $1 }
+ | oqtycon '(' ')' { IEThingWith $1 [] }
+ | oqtycon '(' qcnames ')' { IEThingWith $1 (reverse $3) }
| 'module' modid { IEModuleContents $2 }
qcnames :: { [RdrName] }
: qcnames ',' qcname { $3 : $1 }
| qcname { [$1] }
-qcname :: { RdrName }
+qcname :: { RdrName } -- Variable or data constructor
: qvar { $1 }
| gcon { $1 }
: 'import' srcloc maybe_src optqualified modid maybeas maybeimpspec
{ ImportDecl $5 $3 $4 $6 $7 $2 }
-maybe_src :: { WhereFrom }
- : '{-# SOURCE' '#-}' { ImportByUserSource }
- | {- empty -} { ImportByUser }
+maybe_src :: { IsBootInterface }
+ : '{-# SOURCE' '#-}' { True }
+ | {- empty -} { False }
optqualified :: { Bool }
: 'qualified' { True }
| 'foreign' fdecl { RdrHsDecl $2 }
| '{-# DEPRECATED' deprecations '#-}' { $2 }
| '{-# RULES' rules '#-}' { $2 }
+ | '$(' exp ')' { RdrHsDecl (SpliceD $2) }
| decl { $1 }
syn_hdr :: { (RdrName, [RdrNameHsTyVar]) } -- We don't retain the syntax of an infix
gentype :: { RdrNameHsType }
: btype { $1 }
| btype qtyconop gentype { HsOpTy $1 (HsTyOp $2) $3 }
+ | btype '`' tyvar '`' gentype { HsOpTy $1 (HsTyOp $3) $5 }
| btype '->' gentype { HsOpTy $1 HsArrow $3 }
btype :: { RdrNameHsType }
-- Datatype declarations
newconstr :: { RdrNameConDecl }
- : srcloc conid atype { mkConDecl $2 [] [] (VanillaCon [unbangedType $3]) $1 }
+ : srcloc conid atype { ConDecl $2 [] [] (PrefixCon [unbangedType $3]) $1 }
| srcloc conid '{' var '::' ctype '}'
- { mkConDecl $2 [] [] (RecCon [([$4], unbangedType $6)]) $1 }
+ { ConDecl $2 [] [] (RecCon [($4, unbangedType $6)]) $1 }
constrs :: { [RdrNameConDecl] }
: {- empty; a GHC extension -} { [] }
constr :: { RdrNameConDecl }
: srcloc forall context '=>' constr_stuff
- { mkConDecl (fst $5) $2 $3 (snd $5) $1 }
+ { ConDecl (fst $5) $2 $3 (snd $5) $1 }
| srcloc forall constr_stuff
- { mkConDecl (fst $3) $2 [] (snd $3) $1 }
+ { ConDecl (fst $3) $2 [] (snd $3) $1 }
forall :: { [RdrNameHsTyVar] }
: 'forall' tv_bndrs '.' { $2 }
| {- empty -} { [] }
constr_stuff :: { (RdrName, RdrNameConDetails) }
- : btype {% mkVanillaCon $1 [] }
- | btype '!' atype satypes {% mkVanillaCon $1 (BangType MarkedUserStrict $3 : $4) }
- | gtycon '{' '}' {% mkRecCon $1 [] }
- | gtycon '{' fielddecls '}' {% mkRecCon $1 $3 }
+ : btype {% mkPrefixCon $1 [] }
+ | btype '!' atype satypes {% mkPrefixCon $1 (BangType MarkedUserStrict $3 : $4) }
+ | conid '{' '}' { ($1, RecCon []) }
+ | conid '{' fielddecls '}' { ($1, mkRecCon $3) }
| sbtype conop sbtype { ($2, InfixCon $1 $3) }
satypes :: { [RdrNameBangType] }
[ RdrSig (Sig n $6 $4) | n <- $1:$3 ]
}
-
rhs :: { RdrNameGRHSs }
: '=' srcloc exp wherebinds { (GRHSs (unguardedRHS $3 $2) $4 placeHolderType)}
| gdrhs wherebinds { GRHSs (reverse $1) $2 placeHolderType }
| aexp1 { $1 }
aexp1 :: { RdrNameHsExpr }
- : aexp1 '{' fbinds '}' {% (mkRecConstrOrUpdate $1
- (reverse $3)) }
- | aexp2 { $1 }
- | var_or_con '{|' gentype '|}' { HsApp $1 (HsType $3) }
-
+ : aexp1 '{' fbinds '}' {% (mkRecConstrOrUpdate $1 (reverse $3)) }
+ | aexp2 { $1 }
-var_or_con :: { RdrNameHsExpr }
- : qvar { HsVar $1 }
- | gcon { HsVar $1 }
+-- Here was the syntax for type applications that I was planning
+-- but there are difficulties (e.g. what order for type args)
+-- so it's not enabled yet.
+ | qcname '{|' gentype '|}' { (HsApp (HsVar $1) (HsType $3)) }
aexp2 :: { RdrNameHsExpr }
: ipvar { HsIPVar $1 }
- | var_or_con { $1 }
+ | qcname { HsVar $1 }
| literal { HsLit $1 }
| INTEGER { HsOverLit (mkHsIntegral $1) }
| RATIONAL { HsOverLit (mkHsFractional $1) }
| '(' infixexp qop ')' { (SectionL $2 (HsVar $3)) }
| '(' qopm infixexp ')' { (SectionR $2 $3) }
| '_' { EWildPat }
+
+ -- MetaHaskell Extension
+ | ID_SPLICE { mkHsSplice (HsVar (mkUnqual varName $1))} -- $x
+ | '$(' exp ')' { mkHsSplice $2 } -- $( exp )
+ | '[|' exp '|]' { HsBracket (ExpBr $2) }
+ | '[t|' ctype '|]' { HsBracket (TypBr $2) }
+ | '[p|' srcloc infixexp '|]' {% checkPattern $2 $3 `thenP` \p ->
+ returnP (HsBracket (PatBr p)) }
+ | '[d|' cvtopdecls '|]' { HsBracket (DecBr $2) }
+
texps :: { [RdrNameHsExpr] }
: texps ',' exp { $3 : $1 }
| fbind { [$1] }
| {- empty -} { [] }
-fbind :: { (RdrName, RdrNameHsExpr, Bool) }
- : qvar '=' exp { ($1,$3,False) }
+fbind :: { (RdrName, RdrNameHsExpr) }
+ : qvar '=' exp { ($1,$3) }
-----------------------------------------------------------------------------
-- Implicit Parameter Bindings
deprec_var : var { $1 }
| tycon { $1 }
-gtycon :: { RdrName }
- : qtycon { $1 }
- | '(' qtyconop ')' { $2 }
- | '(' ')' { unitTyCon_RDR }
- | '(' '->' ')' { funTyCon_RDR }
- | '[' ']' { listTyCon_RDR }
- | '[:' ':]' { parrTyCon_RDR }
- | '(' commas ')' { tupleTyCon_RDR $2 }
-
gcon :: { RdrName } -- Data constructor namespace
- : '(' ')' { unitCon_RDR }
- | '[' ']' { nilCon_RDR }
- | '(' commas ')' { tupleCon_RDR $2 }
+ : sysdcon { $1 }
| qcon { $1 }
-- the case of '[:' ':]' is part of the production `parr'
+sysdcon :: { RdrName } -- Data constructor namespace
+ : '(' ')' { getRdrName unitDataCon }
+ | '(' commas ')' { getRdrName (tupleCon Boxed $2) }
+ | '[' ']' { nameRdrName nilDataConName }
+
var :: { RdrName }
: varid { $1 }
| '(' varsym ')' { $2 }
-----------------------------------------------------------------------------
-- Type constructors
-tycon :: { RdrName } -- Unqualified
- : CONID { mkUnqual tcClsName $1 }
+gtycon :: { RdrName } -- A "general" qualified tycon
+ : oqtycon { $1 }
+ | '(' ')' { getRdrName unitTyCon }
+ | '(' commas ')' { getRdrName (tupleTyCon Boxed $2) }
+ | '(' '->' ')' { nameRdrName funTyConName }
+ | '[' ']' { nameRdrName listTyConName }
+ | '[:' ':]' { nameRdrName parrTyConName }
-tyconop :: { RdrName } -- Unqualified
- : CONSYM { mkUnqual tcClsName $1 }
- | '`' tyvar '`' { $2 }
- | '`' tycon '`' { $2 }
+oqtycon :: { RdrName } -- An "ordinary" qualified tycon
+ : qtycon { $1 }
+ | '(' qtyconop ')' { $2 }
qtycon :: { RdrName } -- Qualified or unqualified
: QCONID { mkQual tcClsName $1 }
| '`' QCONID '`' { mkQual tcClsName $2 }
| tyconop { $1 }
+tycon :: { RdrName } -- Unqualified
+ : CONID { mkUnqual tcClsName $1 }
+
+tyconop :: { RdrName } -- Unqualified
+ : CONSYM { mkUnqual tcClsName $1 }
+ | '`' tycon '`' { $2 }
+
+
-----------------------------------------------------------------------------
-- Any operator
consym :: { RdrName }
: CONSYM { mkUnqual dataName $1 }
+ | ':' { nameRdrName consDataConName }
+ -- ':' means only list cons
-----------------------------------------------------------------------------
module :: { RdrNameHsModule }
: '%module' modid tdefs vdefgs
- { HsModule $2 Nothing Nothing [] ($3 ++ concat $4) Nothing noSrcLoc}
+ { HsModule (mkHomeModule $2) Nothing Nothing
+ [] ($3 ++ concat $4) Nothing noSrcLoc}
tdefs :: { [RdrNameHsDecl] }
: {- empty -} {[]}
trep :: { (RdrName -> [HsTyVarBndr RdrName] -> DataConDetails (ConDecl RdrName)) }
: {- empty -} { (\ x ts -> Unknown) }
- | '=' ty { (\ x ts -> DataCons [ConDecl x x ts [] (VanillaCon [unbangedType $2]) noSrcLoc]) }
+ | '=' ty { (\ x ts -> DataCons [ConDecl x ts [] (PrefixCon [unbangedType $2]) noSrcLoc]) }
tbind :: { HsTyVarBndr RdrName }
: name { IfaceTyVar $1 liftedTypeKind }
| vdefg ';' vdefgs { ($1:$3) }
vdefg :: { [RdrNameHsDecl] }
- : '%rec' '{' vdefs1 '}' { $3 }
- | vdef { [$1] }
+ : '%rec' '{' vdefs1 '}' { map CoreD $3 }
+ | vdef { [CoreD $1] }
let_bind :: { UfBinding RdrName }
: '%rec' '{' vdefs1 '}' { UfRec (map convBind $3) }
| vdef { let (b,r) = convBind $1
in UfNonRec b r }
-vdefs1 :: { [RdrNameHsDecl] }
+vdefs1 :: { [RdrNameCoreDecl] }
: vdef { [$1] }
| vdef ';' vdefs1 { $1:$3 }
-vdef :: { RdrNameHsDecl }
- : qname '::' ty '=' exp { TyClD (CoreDecl $1 $3 $5 noSrcLoc) }
+vdef :: { RdrNameCoreDecl }
+ : qname '::' ty '=' exp { CoreDecl $1 $3 $5 noSrcLoc }
vbind :: { (RdrName, RdrNameHsType) }
con :: { ConDecl RdrName }
: q_d_name attbinds atys
- { mkConDecl $1 $2 [] (VanillaCon (map unbangedType $3)) noSrcLoc}
+ { ConDecl $1 $2 [] (PrefixCon (map unbangedType $3)) noSrcLoc}
atys :: { [ RdrNameHsType] }
: {- empty -} { [] }
{
-convBind :: RdrNameHsDecl -> (UfBinder RdrName, UfExpr RdrName)
-convBind (TyClD (CoreDecl n ty rhs _)) = (UfValBinder n ty, rhs)
+convBind :: RdrNameCoreDecl -> (UfBinder RdrName, UfExpr RdrName)
+convBind (CoreDecl n ty rhs _) = (UfValBinder n ty, rhs)
happyError :: P a
happyError s l = failP (show l ++ ": Parse error\n") (take 100 s) l
RdrNameContext,
RdrNameDefaultDecl,
RdrNameForeignDecl,
+ RdrNameCoreDecl,
RdrNameGRHS,
RdrNameGRHSs,
RdrNameHsBinds,
extractHsTyRdrNames, extractHsTyRdrTyVars,
extractHsCtxtRdrTyVars, extractGenericPatTyVars,
- mkHsOpApp, mkClassDecl, mkClassOpSigDM, mkConDecl,
+ mkHsOpApp, mkClassDecl, mkClassOpSigDM,
mkHsNegApp, mkNPlusKPat, mkHsIntegral, mkHsFractional,
- mkHsDo,
+ mkHsDo, mkHsSplice,
cvBinds,
cvMonoBindsAndSigs,
#include "HsVersions.h"
import HsSyn -- Lots of it
-import OccName ( mkClassTyConOcc, mkClassDataConOcc, mkWorkerOcc,
- mkSuperDictSelOcc, mkDefaultMethodOcc, mkGenOcc1,
- mkGenOcc2
- )
+import OccName ( mkDefaultMethodOcc, mkVarOcc )
import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc, isRdrTyVar )
import List ( nub )
-import BasicTypes ( RecFlag(..) )
+import BasicTypes ( RecFlag(..), FixitySig )
import Class ( DefMeth (..) )
\end{code}
%************************************************************************
\begin{code}
-type RdrNameArithSeqInfo = ArithSeqInfo RdrName RdrNamePat
+type RdrNameArithSeqInfo = ArithSeqInfo RdrName
type RdrNameBangType = BangType RdrName
type RdrNameClassOpSig = Sig RdrName
type RdrNameConDecl = ConDecl RdrName
-type RdrNameConDetails = ConDetails RdrName
+type RdrNameConDetails = HsConDetails RdrName RdrNameBangType
type RdrNameContext = HsContext RdrName
-type RdrNameHsDecl = HsDecl RdrName RdrNamePat
+type RdrNameHsDecl = HsDecl RdrName
type RdrNameDefaultDecl = DefaultDecl RdrName
type RdrNameForeignDecl = ForeignDecl RdrName
-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 RdrNameCoreDecl = CoreDecl RdrName
+type RdrNameGRHS = GRHS RdrName
+type RdrNameGRHSs = GRHSs RdrName
+type RdrNameHsBinds = HsBinds RdrName
+type RdrNameHsExpr = HsExpr RdrName
+type RdrNameHsModule = HsModule RdrName
type RdrNameIE = IE RdrName
type RdrNameImportDecl = ImportDecl RdrName
-type RdrNameInstDecl = InstDecl RdrName RdrNamePat
-type RdrNameMatch = Match RdrName RdrNamePat
-type RdrNameMonoBinds = MonoBinds RdrName RdrNamePat
+type RdrNameInstDecl = InstDecl RdrName
+type RdrNameMatch = Match RdrName
+type RdrNameMonoBinds = MonoBinds RdrName
type RdrNamePat = InPat RdrName
type RdrNameHsType = HsType RdrName
type RdrNameHsTyVar = HsTyVarBndr RdrName
type RdrNameSig = Sig RdrName
-type RdrNameStmt = Stmt RdrName RdrNamePat
-type RdrNameTyClDecl = TyClDecl RdrName RdrNamePat
+type RdrNameStmt = Stmt RdrName
+type RdrNameTyClDecl = TyClDecl RdrName
type RdrNameRuleBndr = RuleBndr RdrName
-type RdrNameRuleDecl = RuleDecl RdrName RdrNamePat
+type RdrNameRuleDecl = RuleDecl RdrName
type RdrNameDeprecation = DeprecDecl RdrName
type RdrNameFixitySig = FixitySig RdrName
-type RdrNameHsRecordBinds = HsRecordBinds RdrName RdrNamePat
+type RdrNameHsRecordBinds = HsRecordBinds RdrName
\end{code}
get (FunMonoBind _ _ ms _) acc = foldr get_m acc ms
get other acc = acc
- get_m (Match (TypePatIn ty : _) _ _) acc = extract_ty ty acc
- get_m other acc = acc
+ get_m (Match (TypePat ty : _) _ _) acc = extract_ty ty acc
+ get_m other acc = acc
\end{code}
mkClassDecl (cxt, cname, tyvars) fds sigs mbinds loc
= ClassDecl { tcdCtxt = cxt, tcdName = cname, tcdTyVars = tyvars,
tcdFDs = fds, tcdSigs = sigs, tcdMeths = mbinds,
- tcdSysNames = new_names, tcdLoc = loc }
- where
- cls_occ = rdrNameOcc cname
- data_occ = mkClassDataConOcc cls_occ
- dname = mkRdrUnqual data_occ
- dwname = mkRdrUnqual (mkWorkerOcc data_occ)
- tname = mkRdrUnqual (mkClassTyConOcc cls_occ)
- sc_sel_names = [ mkRdrUnqual (mkSuperDictSelOcc n cls_occ)
- | n <- [1..length cxt]]
- -- We number off the superclass selectors, 1, 2, 3 etc so that we
- -- can construct names for the selectors. Thus
- -- class (C a, C b) => D a b where ...
- -- gives superclass selectors
- -- D_sc1, D_sc2
- -- (We used to call them D_C, but now we can have two different
- -- superclasses both called C!)
- new_names = mkClassDeclSysNames (tname, dname, dwname, sc_sel_names)
+ tcdLoc = loc }
mkTyData new_or_data (context, tname, tyvars) data_cons maybe src
- = let t_occ = rdrNameOcc tname
- name1 = mkRdrUnqual (mkGenOcc1 t_occ)
- name2 = mkRdrUnqual (mkGenOcc2 t_occ)
- in TyData { tcdND = new_or_data, tcdCtxt = context, tcdName = tname,
- tcdTyVars = tyvars, tcdCons = data_cons,
- tcdDerivs = maybe, tcdLoc = src, tcdSysNames = [name1, name2] }
+ = TyData { tcdND = new_or_data, tcdCtxt = context, tcdName = tname,
+ tcdTyVars = tyvars, tcdCons = data_cons,
+ tcdDerivs = maybe, tcdLoc = src, tcdGeneric = Nothing }
mkClassOpSigDM op ty loc
= ClassOpSig op (DefMeth dm_rn) ty loc
where
dm_rn = mkRdrUnqual (mkDefaultMethodOcc (rdrNameOcc op))
-
-mkConDecl cname ex_vars cxt details loc
- = ConDecl cname wkr_name ex_vars cxt details loc
- where
- wkr_name = mkRdrUnqual (mkWorkerOcc (rdrNameOcc cname))
\end{code}
\begin{code}
mkHsDo ctxt stmts loc = HsDo ctxt stmts [] placeHolderType loc
\end{code}
+\begin{code}
+mkHsSplice e = HsSplice unqualSplice e
+
+unqualSplice = mkRdrUnqual (mkVarOcc FSLIT("splice"))
+ -- A name (uniquified later) to
+ -- identify the splice
+\end{code}
%************************************************************************
%* *
ghcPrimExports,
cCallableClassDecl, cReturnableClassDecl, assertDecl,
- -- Primop RdrNames
- eqH_Char_RDR, ltH_Char_RDR, eqH_Word_RDR, ltH_Word_RDR,
- eqH_Addr_RDR, ltH_Addr_RDR, eqH_Float_RDR, ltH_Float_RDR,
- eqH_Double_RDR, ltH_Double_RDR, eqH_Int_RDR, ltH_Int_RDR,
- geH_RDR, leH_RDR, minusH_RDR, tagToEnumH_RDR,
-
-- Random other things
maybeCharLikeCon, maybeIntLikeCon,
import PrelNames -- Prelude module names
-import PrimOp ( PrimOp(..), allThePrimOps, primOpRdrName, primOpOcc )
+import PrimOp ( allThePrimOps, primOpOcc )
import DataCon ( DataCon )
import Id ( idName )
import MkId ( mkPrimOpId, wiredInIds )
import MkId -- All of it, for re-export
-import Name ( nameOccName, nameRdrName )
-import RdrName ( mkRdrUnqual )
+import Name ( nameOccName )
+import RdrName ( mkRdrUnqual, getRdrName )
import HsSyn ( HsTyVarBndr(..), TyClDecl(..), HsType(..) )
import OccName ( mkVarOcc )
import TysPrim ( primTyCons )
ghcPrimExports :: [RdrAvailInfo]
= AvailTC cCallableOcc [ cCallableOcc ] :
AvailTC cReturnableOcc [ cReturnableOcc ] :
- Avail (nameOccName assertName) : -- doesn't have an Id
map (Avail . nameOccName . idName) ghcPrimIds ++
map (Avail . primOpOcc) allThePrimOps ++
[ AvailTC occ [occ] |
assertDecl
= IfaceSig {
- tcdName = nameRdrName assertName,
+ tcdName = getRdrName assertName,
tcdType = HsForAllTy (Just [liftedAlpha]) [] (HsTyVar alpha),
tcdIdInfo = [],
tcdLoc = noSrcLoc
cCallableClassDecl
= mkClassDecl
- ([], nameRdrName cCallableClassName, [openAlpha])
+ ([], getRdrName cCallableClassName, [openAlpha])
[] -- no fds
[] -- no sigs
Nothing -- no mbinds
cReturnableClassDecl
= mkClassDecl
- ([], nameRdrName cReturnableClassName, [openAlpha])
+ ([], getRdrName cReturnableClassName, [openAlpha])
[] -- no fds
[] -- no sigs
Nothing -- no mbinds
liftedAlpha = IfaceTyVar alpha liftedTypeKind
\end{code}
-%************************************************************************
-%* *
-\subsection{RdrNames for the primops}
-%* *
-%************************************************************************
-
-These can't be in PrelNames, because we get the RdrName from the PrimOp,
-which is above PrelNames in the module hierarchy.
-
-\begin{code}
-eqH_Char_RDR = primOpRdrName CharEqOp
-ltH_Char_RDR = primOpRdrName CharLtOp
-eqH_Word_RDR = primOpRdrName WordEqOp
-ltH_Word_RDR = primOpRdrName WordLtOp
-eqH_Addr_RDR = primOpRdrName AddrEqOp
-ltH_Addr_RDR = primOpRdrName AddrLtOp
-eqH_Float_RDR = primOpRdrName FloatEqOp
-ltH_Float_RDR = primOpRdrName FloatLtOp
-eqH_Double_RDR = primOpRdrName DoubleEqOp
-ltH_Double_RDR = primOpRdrName DoubleLtOp
-eqH_Int_RDR = primOpRdrName IntEqOp
-ltH_Int_RDR = primOpRdrName IntLtOp
-geH_RDR = primOpRdrName IntGeOp
-leH_RDR = primOpRdrName IntLeOp
-minusH_RDR = primOpRdrName IntSubOp
-
-tagToEnumH_RDR = primOpRdrName TagToEnumOp
-\end{code}
-
%************************************************************************
%* *
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-\section[PrelNames]{Definitions of prelude modules}
+\section[PrelNames]{Definitions of prelude modules and names}
+
+
+-- MetaHaskell Extension
+to do -- three things
+1) Allocate a key
+2) Make a "Name"
+3) Add the name to knownKeyNames
+
The strings identify built-in prelude modules. They are
defined here so as to avod
-[oh dear, looks like the recursive module monster caught up with
- and gobbled whoever was writing the above :-) -- SOF ]
+* ModuleNames for prelude modules,
+ e.g. pREL_BASE_Name :: ModuleName
+
+* Modules for prelude modules
+ e.g. pREL_Base :: Module
+
+* Uniques for Ids, DataCons, TyCons and Classes that the compiler
+ "knows about" in some way
+ e.g. intTyConKey :: Unique
+ minusClassOpKey :: Unique
+
+* Names for Ids, DataCons, TyCons and Classes that the compiler
+ "knows about" in some way
+ e.g. intTyConName :: Name
+ minusName :: Name
+ One of these Names contains
+ (a) the module and occurrence name of the thing
+ (b) its Unique
+ The may way the compiler "knows about" one of these things is
+ where the type checker or desugarer needs to look it up. For
+ example, when desugaring list comprehensions the desugarer
+ needs to conjure up 'foldr'. It does this by looking up
+ foldrName in the environment.
+
+* RdrNames for Ids, DataCons etc that the compiler may emit into
+ generated code (e.g. for deriving). It's not necessary to know
+ the uniques for these guys, only their names
+
\begin{code}
module PrelNames (
Unique, Uniquable(..), hasKey, -- Re-exported for convenience
-----------------------------------------------------------
- module PrelNames, -- A huge bunch of (a) RdrNames, e.g. intTyCon_RDR
- -- (b) Uniques e.g. intTyConKey
+ module PrelNames, -- A huge bunch of (a) Names, e.g. intTyConName
+ -- (b) Uniques e.g. intTyConKey
-- So many that we export them all
-----------------------------------------------------------
- knownKeyNames,
- mkTupNameStr, mkTupConRdrName,
+ knownKeyNames, templateHaskellNames,
+ mkTupNameStr, isBuiltInSyntaxName,
------------------------------------------------------------
-- Goups of classes and types
needsDataDeclCtxtClassKeys, cCallishClassKeys, noDictClassKeys,
fractionalClassKeys, numericClassKeys, standardClassKeys,
- derivingOccurrences, -- For a given class C, this tells what other
derivableClassKeys, -- things are needed as a result of a
-- deriving(C) clause
numericTyKeys, cCallishTyKeys,
#include "HsVersions.h"
-import Module ( ModuleName, mkPrelModule, mkHomeModule, mkModuleName )
-import OccName ( NameSpace, UserFS, varName, dataName, tcName, clsName,
+import Module ( ModuleName, mkPrelModule, mkHomeModule, mkModuleName,mkVanillaModule )
+import OccName ( UserFS, dataName, tcName, clsName,
mkKindOccFS, mkOccFS
)
-import RdrName ( RdrName, mkOrig, mkUnqual )
-import UniqFM
+
+-- to avoid clashes with Meta.var we must make a local alias for OccName.varName
+-- we do this by removing varName from the import of OccName above, making
+-- a qualified instance of OccName and using OccNameAlias.varName where varName
+-- ws previously used in this file.
+import qualified OccName as OccNameAlias
+
+
+import RdrName ( RdrName, nameRdrName, mkOrig, rdrNameOcc )
import Unique ( Unique, Uniquable(..), hasKey,
mkPreludeMiscIdUnique, mkPreludeDataConUnique,
mkPreludeTyConUnique, mkPreludeClassUnique,
- mkTupleTyConUnique
+ mkTupleTyConUnique, isTupleKey
)
-import BasicTypes ( Boxity(..), Arity )
-import UniqFM ( UniqFM, listToUFM )
-import Name ( Name, mkInternalName, mkKnownKeyExternalName, nameRdrName )
-import RdrName ( rdrNameOcc )
-import SrcLoc ( builtinSrcLoc, noSrcLoc )
+import BasicTypes ( Boxity(..) )
+import Name ( Name, mkInternalName, mkKnownKeyExternalName, mkWiredInName, nameUnique )
+import NameSet ( NameSet, mkNameSet )
+import SrcLoc ( noSrcLoc )
import Util ( nOfThem )
import Panic ( panic )
import FastString
+
+
\end{code}
This *local* name is used by the interactive stuff
\begin{code}
-itName uniq = mkInternalName uniq (mkOccFS varName FSLIT("it")) noSrcLoc
+itName uniq = mkInternalName uniq (mkOccFS OccNameAlias.varName FSLIT("it")) noSrcLoc
\end{code}
\begin{code}
-- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly
-- during compiler debugging.
mkUnboundName :: RdrName -> Name
-mkUnboundName rdr_name = mkInternalName unboundKey (rdrNameOcc rdr_name) builtinSrcLoc
+mkUnboundName rdr_name = mkInternalName unboundKey (rdrNameOcc rdr_name) noSrcLoc
isUnboundName :: Name -> Bool
isUnboundName name = name `hasKey` unboundKey
%************************************************************************
%* *
+\subsection{Built-in-syntax names
+%* *
+%************************************************************************
+
+Built-in syntax names are parsed directly into Exact RdrNames.
+This predicate just identifies them.
+
+\begin{code}
+isBuiltInSyntaxName :: Name -> Bool
+isBuiltInSyntaxName n
+ = isTupleKey uniq
+ || uniq `elem` [listTyConKey, nilDataConKey, consDataConKey,
+ funTyConKey, parrTyConKey]
+ where
+ uniq = nameUnique n
+\end{code}
+
+%************************************************************************
+%* *
\subsection{Known key Names}
%* *
%************************************************************************
names with uniques. These ones are the *non* wired-in ones. The
wired in ones are defined in TysWiredIn etc.
+
+MetaHaskell Extension
+It is here that the names defiend in module Meta must be added
\begin{code}
knownKeyNames :: [Name]
knownKeyNames
- = [
- -- Type constructors (synonyms especially)
+ = [ -- Type constructors (synonyms especially)
ioTyConName, ioDataConName,
runIOName,
orderingTyConName,
enumClassName, -- derivable
monadClassName,
functorClassName,
- showClassName, -- derivable
realClassName, -- numeric
integralClassName, -- numeric
fractionalClassName, -- numeric
floatingClassName, -- numeric
realFracClassName, -- numeric
realFloatClassName, -- numeric
- readClassName, -- derivable
- ixClassName, -- derivable (but it isn't Prelude.Ix; hmmm)
cCallableClassName, -- mentioned, ccallish
cReturnableClassName, -- mentioned, ccallish
- -- ClassOps
- fromIntegerName,
- negateName,
- geName,
- minusName,
- enumFromName,
- enumFromThenName,
- enumFromToName,
- enumFromThenToName,
- fromEnumName,
- toEnumName,
- eqName,
- thenMName,
- bindMName,
- returnMName,
- failMName,
- fromRationalName,
-
- -- not class methods, but overloaded (for parallel arrays)
- enumFromToPName,
- enumFromThenToPName,
-
- deRefStablePtrName,
+ -- Numeric stuff
+ negateName, minusName,
+ fromRationalName, fromIntegerName,
+ geName, eqName,
+
+ -- Enum stuff
+ enumFromName, enumFromThenName,
+ enumFromThenToName, enumFromToName,
+ enumFromToPName, enumFromThenToPName,
+
+ -- Monad stuff
+ thenMName, bindMName, returnMName, failMName,
+ thenIOName, bindIOName, returnIOName, failIOName,
+
+ -- Ix stuff
+ ixClassName,
+
+ -- Show stuff
+ showClassName,
+
+ -- Read stuff
+ readClassName,
+
+ -- Stable pointers
newStablePtrName,
- bindIOName,
- thenIOName,
- returnIOName,
- failIOName,
-- Strings and lists
- mapName,
- appendName,
- unpackCStringName,
- unpackCStringAppendName,
- unpackCStringFoldrName,
- unpackCStringUtf8Name,
+ unpackCStringName, unpackCStringAppendName,
+ unpackCStringFoldrName, unpackCStringUtf8Name,
-- List operations
- concatName,
- filterName,
- zipName,
- foldrName,
- buildName,
- augmentName,
+ concatName, filterName,
+ zipName, foldrName, buildName, augmentName, appendName,
-- Parallel array operations
- nullPName,
- lengthPName,
- replicatePName,
- mapPName,
- filterPName,
- zipPName,
- crossPName,
- indexPName,
- toPName,
- bpermutePName,
- bpermuteDftPName,
- indexOfPName,
-
+ nullPName, lengthPName, replicatePName, mapPName,
+ filterPName, zipPName, crossPName, indexPName,
+ toPName, bpermutePName, bpermuteDftPName, indexOfPName,
+
+ -- MetaHaskell Extension, "the smart constructors"
+ -- text1 from Meta/work/gen.hs
+ intLName,
+ charLName,
+ plitName,
+ pvarName,
+ ptupName,
+ pconName,
+ ptildeName,
+ paspatName,
+ pwildName,
+ varName,
+ conName,
+ litName,
+ appName,
+ infixEName,
+ lamName,
+ tupName,
+ doEName,
+ compName,
+ listExpName,
+ condName,
+ letEName,
+ caseEName,
+ infixAppName,
+ sectionLName,
+ sectionRName,
+ guardedName,
+ normalName,
+ bindStName,
+ letStName,
+ noBindStName,
+ parStName,
+ fromName,
+ fromThenName,
+ fromToName,
+ fromThenToName,
+ liftName,
+ gensymName,
+ returnQName,
+ bindQName,
+ funName,
+ valName,
+ protoName, matchName, clauseName,
+ exprTyConName, declTyConName, pattTyConName, mtchTyConName, clseTyConName,
+ qTyConName, expTyConName, matTyConName, clsTyConName,
+
-- FFI primitive types that are not wired-in.
- int8TyConName,
- int16TyConName,
- int32TyConName,
- int64TyConName,
- word8TyConName,
- word16TyConName,
- word32TyConName,
- word64TyConName,
+ int8TyConName, int16TyConName, int32TyConName, int64TyConName,
+ word8TyConName, word16TyConName, word32TyConName, word64TyConName,
-- Others
- unsafeCoerceName,
- otherwiseIdName,
- plusIntegerName,
- timesIntegerName,
- eqStringName,
- assertName,
- runSTRepName,
- printName,
- splitName, fstName, sndName, -- Used by splittery
-
- -- Others (needed for flattening and not mentioned before)
- andName,
- orName
+ unsafeCoerceName, otherwiseIdName,
+ plusIntegerName, timesIntegerName,
+ eqStringName, assertName, runSTRepName,
+ printName, splitName, fstName, sndName,
+ errorName,
+
+ -- Booleans
+ andName, orName
]
monadNames :: [Name] -- The monad ops need by a HsDo
%* *
%************************************************************************
+
+--MetaHaskell Extension Add a new module here
\begin{code}
pRELUDE_Name = mkModuleName "Prelude"
gHC_PRIM_Name = mkModuleName "GHC.Prim" -- Primitive types and values
pRELUDE = mkPrelModule pRELUDE_Name
iNTERACTIVE = mkHomeModule (mkModuleName "$Interactive")
+
+-- MetaHaskell Extension text2 from Meta/work/gen.hs
+mETA_META_Name = mkModuleName "Language.Haskell.THSyntax"
+
\end{code}
%************************************************************************
mkTupNameStr Unboxed 3 = (gHC_PRIM_Name, mkFastString "(#,,#)")
mkTupNameStr Unboxed 4 = (gHC_PRIM_Name, mkFastString "(#,,,#)")
mkTupNameStr Unboxed n = (gHC_PRIM_Name, mkFastString ("(#" ++ nOfThem (n-1) ',' ++ "#)"))
-
-mkTupConRdrName :: NameSpace -> Boxity -> Arity -> RdrName
-mkTupConRdrName space boxity arity = case mkTupNameStr boxity arity of
- (mod, occ) -> mkOrig space mod occ
\end{code}
%************************************************************************
%* *
-\subsection{Unqualified RdrNames}
+ RdrNames
%* *
%************************************************************************
\begin{code}
-main_RDR_Unqual :: RdrName
-main_RDR_Unqual = mkUnqual varName FSLIT("main")
--- Don't get a RdrName from PrelNames.mainName, because nameRdrName
--- gets an Orig RdrName, and we want a Qual or Unqual one. An Unqual
--- one will do fine.
+getTag_RDR = nameRdrName getTagName
+
+eq_RDR = nameRdrName eqName
+ge_RDR = nameRdrName geName
+ne_RDR = varQual_RDR pREL_BASE_Name FSLIT("/=")
+le_RDR = varQual_RDR pREL_BASE_Name FSLIT("<=")
+gt_RDR = varQual_RDR pREL_BASE_Name FSLIT(">")
+compare_RDR = varQual_RDR pREL_BASE_Name FSLIT("compare")
+ltTag_RDR = dataQual_RDR pREL_BASE_Name FSLIT("LT")
+eqTag_RDR = dataQual_RDR pREL_BASE_Name FSLIT("EQ")
+gtTag_RDR = dataQual_RDR pREL_BASE_Name FSLIT("GT")
+
+eqClass_RDR = nameRdrName eqClassName
+numClass_RDR = nameRdrName numClassName
+ordClass_RDR = nameRdrName ordClassName
+enumClass_RDR = nameRdrName enumClassName
+monadClass_RDR = nameRdrName monadClassName
+cCallableClass_RDR = nameRdrName cCallableClassName
+cReturnableClass_RDR = nameRdrName cReturnableClassName
+
+map_RDR = varQual_RDR pREL_BASE_Name FSLIT("map")
+append_RDR = varQual_RDR pREL_BASE_Name FSLIT("++")
+
+foldr_RDR = nameRdrName foldrName
+build_RDR = nameRdrName buildName
+returnM_RDR = nameRdrName returnMName
+bindM_RDR = nameRdrName bindMName
+failM_RDR = nameRdrName failMName
+
+false_RDR = nameRdrName falseDataConName
+true_RDR = nameRdrName trueDataConName
+and_RDR = nameRdrName andName
+
+error_RDR = nameRdrName errorName
+
+fromEnum_RDR = varQual_RDR pREL_ENUM_Name FSLIT("fromEnum")
+toEnum_RDR = varQual_RDR pREL_ENUM_Name FSLIT("toEnum")
+mkInt_RDR = nameRdrName intDataConName
+
+enumFrom_RDR = nameRdrName enumFromName
+enumFromTo_RDR = nameRdrName enumFromToName
+enumFromThen_RDR = nameRdrName enumFromThenName
+enumFromThenTo_RDR = nameRdrName enumFromThenToName
+
+ratioDataCon_RDR = nameRdrName ratioDataConName
+plusInteger_RDR = nameRdrName plusIntegerName
+timesInteger_RDR = nameRdrName timesIntegerName
+
+ioDataCon_RDR = nameRdrName ioDataConName
+
+eqString_RDR = nameRdrName eqStringName
+unpackCString_RDR = nameRdrName unpackCStringName
+unpackCStringFoldr_RDR = nameRdrName unpackCStringFoldrName
+unpackCStringUtf8_RDR = nameRdrName unpackCStringUtf8Name
+
+newStablePtr_RDR = nameRdrName newStablePtrName
+
+bindIO_RDR = nameRdrName bindIOName
+returnIO_RDR = nameRdrName returnIOName
+
+fromInteger_RDR = nameRdrName fromIntegerName
+fromRational_RDR = nameRdrName fromRationalName
+minus_RDR = nameRdrName minusName
+times_RDR = varQual_RDR pREL_NUM_Name FSLIT("*")
+plus_RDR = varQual_RDR pREL_NUM_Name FSLIT("+")
+
+compose_RDR = varQual_RDR pREL_BASE_Name FSLIT(".")
+
+not_RDR = varQual_RDR pREL_BASE_Name FSLIT("not")
+succ_RDR = varQual_RDR pREL_ENUM_Name FSLIT("succ")
+pred_RDR = varQual_RDR pREL_ENUM_Name FSLIT("pred")
+minBound_RDR = varQual_RDR pREL_ENUM_Name FSLIT("minBound")
+maxBound_RDR = varQual_RDR pREL_ENUM_Name FSLIT("maxBound")
+range_RDR = varQual_RDR pREL_ARR_Name FSLIT("range")
+inRange_RDR = varQual_RDR pREL_ARR_Name FSLIT("inRange")
+index_RDR = varQual_RDR pREL_ARR_Name FSLIT("index")
+
+readList_RDR = varQual_RDR pREL_READ_Name FSLIT("readList")
+readListDefault_RDR = varQual_RDR pREL_READ_Name FSLIT("readListDefault")
+readListPrec_RDR = varQual_RDR pREL_READ_Name FSLIT("readListPrec")
+readListPrecDefault_RDR = varQual_RDR pREL_READ_Name FSLIT("readListPrecDefault")
+readPrec_RDR = varQual_RDR pREL_READ_Name FSLIT("readPrec")
+parens_RDR = varQual_RDR pREL_READ_Name FSLIT("parens")
+choose_RDR = varQual_RDR pREL_READ_Name FSLIT("choose")
+lexP_RDR = varQual_RDR pREL_READ_Name FSLIT("lexP")
+
+punc_RDR = dataQual_RDR lEX_Name FSLIT("Punc")
+ident_RDR = dataQual_RDR lEX_Name FSLIT("Ident")
+symbol_RDR = dataQual_RDR lEX_Name FSLIT("Symbol")
+
+step_RDR = varQual_RDR rEAD_PREC_Name FSLIT("step")
+alt_RDR = varQual_RDR rEAD_PREC_Name FSLIT("+++")
+reset_RDR = varQual_RDR rEAD_PREC_Name FSLIT("reset")
+prec_RDR = varQual_RDR rEAD_PREC_Name FSLIT("prec")
+
+showList_RDR = varQual_RDR pREL_SHOW_Name FSLIT("showList")
+showList___RDR = varQual_RDR pREL_SHOW_Name FSLIT("showList__")
+showsPrec_RDR = varQual_RDR pREL_SHOW_Name FSLIT("showsPrec")
+showString_RDR = varQual_RDR pREL_SHOW_Name FSLIT("showString")
+showSpace_RDR = varQual_RDR pREL_SHOW_Name FSLIT("showSpace")
+showParen_RDR = varQual_RDR pREL_SHOW_Name FSLIT("showParen")
\end{code}
%************************************************************************
%* *
-\subsection{Commonly-used RdrNames}
+\subsection{Known-key names}
%* *
%************************************************************************
compiler (notably the deriving mechanism) need to mention their names,
and it's convenient to write them all down in one place.
+--MetaHaskell Extension add the constrs and the lower case case
+-- guys as well (perhaps) e.g. see trueDataConName below
+
+
\begin{code}
dollarMainName = varQual mAIN_Name FSLIT("$main") dollarMainKey
runIOName = varQual pREL_TOP_HANDLER_Name FSLIT("runIO") runMainKey
cCallableClassName = clsQual gHC_PRIM_Name FSLIT("CCallable") cCallableClassKey
cReturnableClassName = clsQual gHC_PRIM_Name FSLIT("CReturnable") cReturnableClassKey
+getTagName = wVarQual gHC_PRIM_Name FSLIT("getTag#") getTagIdKey
+unsafeCoerceName = wVarQual gHC_PRIM_Name FSLIT("unsafeCoerce#") unsafeCoerceIdKey
+nullAddrName = wVarQual gHC_PRIM_Name FSLIT("nullAddr#") nullAddrIdKey
+seqName = wVarQual gHC_PRIM_Name FSLIT("seq") seqIdKey
+realWorldName = wVarQual gHC_PRIM_Name FSLIT("realWorld#") realWorldPrimIdKey
+
-- PrelBase data types and constructors
-charTyConName = tcQual pREL_BASE_Name FSLIT("Char") charTyConKey
-charDataConName = dataQual pREL_BASE_Name FSLIT("C#") charDataConKey
-intTyConName = tcQual pREL_BASE_Name FSLIT("Int") intTyConKey
-intDataConName = dataQual pREL_BASE_Name FSLIT("I#") intDataConKey
+charTyConName = wTcQual pREL_BASE_Name FSLIT("Char") charTyConKey
+charDataConName = wDataQual pREL_BASE_Name FSLIT("C#") charDataConKey
+intTyConName = wTcQual pREL_BASE_Name FSLIT("Int") intTyConKey
+intDataConName = wDataQual pREL_BASE_Name FSLIT("I#") intDataConKey
orderingTyConName = tcQual pREL_BASE_Name FSLIT("Ordering") orderingTyConKey
-boolTyConName = tcQual pREL_BASE_Name FSLIT("Bool") boolTyConKey
-falseDataConName = dataQual pREL_BASE_Name FSLIT("False") falseDataConKey
-trueDataConName = dataQual pREL_BASE_Name FSLIT("True") trueDataConKey
-listTyConName = tcQual pREL_BASE_Name FSLIT("[]") listTyConKey
-nilDataConName = dataQual pREL_BASE_Name FSLIT("[]") nilDataConKey
-consDataConName = dataQual pREL_BASE_Name FSLIT(":") consDataConKey
-
--- PrelTup
-fstName = varQual pREL_TUP_Name FSLIT("fst") fstIdKey
-sndName = varQual pREL_TUP_Name FSLIT("snd") sndIdKey
+boolTyConName = wTcQual pREL_BASE_Name FSLIT("Bool") boolTyConKey
+falseDataConName = wDataQual pREL_BASE_Name FSLIT("False") falseDataConKey
+trueDataConName = wDataQual pREL_BASE_Name FSLIT("True") trueDataConKey
+listTyConName = wTcQual pREL_BASE_Name FSLIT("[]") listTyConKey
+nilDataConName = wDataQual pREL_BASE_Name FSLIT("[]") nilDataConKey
+consDataConName = wDataQual pREL_BASE_Name FSLIT(":") consDataConKey
+eqName = varQual pREL_BASE_Name FSLIT("==") eqClassOpKey
+geName = varQual pREL_BASE_Name FSLIT(">=") geClassOpKey
-- Generics
crossTyConName = tcQual pREL_BASE_Name FSLIT(":*:") crossTyConKey
crossDataConName = dataQual pREL_BASE_Name FSLIT(":*:") crossDataConKey
-plusTyConName = tcQual pREL_BASE_Name FSLIT(":+:") plusTyConKey
-inlDataConName = dataQual pREL_BASE_Name FSLIT("Inl") inlDataConKey
-inrDataConName = dataQual pREL_BASE_Name FSLIT("Inr") inrDataConKey
-genUnitTyConName = tcQual pREL_BASE_Name FSLIT("Unit") genUnitTyConKey
-genUnitDataConName = dataQual pREL_BASE_Name FSLIT("Unit") genUnitDataConKey
-
--- Random PrelBase functions
-unsafeCoerceName = varQual pREL_BASE_Name FSLIT("unsafeCoerce")
- unsafeCoerceIdKey
-otherwiseIdName = varQual pREL_BASE_Name FSLIT("otherwise") otherwiseIdKey
-appendName = varQual pREL_BASE_Name FSLIT("++") appendIdKey
-foldrName = varQual pREL_BASE_Name FSLIT("foldr") foldrIdKey
-mapName = varQual pREL_BASE_Name FSLIT("map") mapIdKey
-buildName = varQual pREL_BASE_Name FSLIT("build") buildIdKey
-augmentName = varQual pREL_BASE_Name FSLIT("augment") augmentIdKey
-eqStringName = varQual pREL_BASE_Name FSLIT("eqString") eqStringIdKey
-andName = varQual pREL_BASE_Name FSLIT("&&") andIdKey
-orName = varQual pREL_BASE_Name FSLIT("||") orIdKey
+plusTyConName = wTcQual pREL_BASE_Name FSLIT(":+:") plusTyConKey
+inlDataConName = wDataQual pREL_BASE_Name FSLIT("Inl") inlDataConKey
+inrDataConName = wDataQual pREL_BASE_Name FSLIT("Inr") inrDataConKey
+genUnitTyConName = wTcQual pREL_BASE_Name FSLIT("Unit") genUnitTyConKey
+genUnitDataConName = wDataQual pREL_BASE_Name FSLIT("Unit") genUnitDataConKey
--- Strings
+-- Base strings Strings
unpackCStringName = varQual pREL_BASE_Name FSLIT("unpackCString#") unpackCStringIdKey
unpackCStringAppendName = varQual pREL_BASE_Name FSLIT("unpackAppendCString#") unpackCStringAppendIdKey
unpackCStringFoldrName = varQual pREL_BASE_Name FSLIT("unpackFoldrCString#") unpackCStringFoldrIdKey
unpackCStringUtf8Name = varQual pREL_BASE_Name FSLIT("unpackCStringUtf8#") unpackCStringUtf8IdKey
+eqStringName = varQual pREL_BASE_Name FSLIT("eqString") eqStringIdKey
--- Classes Eq and Ord
+-- Base classes (Eq, Ord, Functor)
eqClassName = clsQual pREL_BASE_Name FSLIT("Eq") eqClassKey
+functorClassName = clsQual pREL_BASE_Name FSLIT("Functor") functorClassKey
ordClassName = clsQual pREL_BASE_Name FSLIT("Ord") ordClassKey
-eqName = varQual pREL_BASE_Name FSLIT("==") eqClassOpKey
-geName = varQual pREL_BASE_Name FSLIT(">=") geClassOpKey
-- Class Monad
monadClassName = clsQual pREL_BASE_Name FSLIT("Monad") monadClassKey
returnMName = varQual pREL_BASE_Name FSLIT("return") returnMClassOpKey
failMName = varQual pREL_BASE_Name FSLIT("fail") failMClassOpKey
--- Class Functor
-functorClassName = clsQual pREL_BASE_Name FSLIT("Functor") functorClassKey
--- Class Show
-showClassName = clsQual pREL_SHOW_Name FSLIT("Show") showClassKey
+-- Random PrelBase functions
+otherwiseIdName = varQual pREL_BASE_Name FSLIT("otherwise") otherwiseIdKey
+foldrName = varQual pREL_BASE_Name FSLIT("foldr") foldrIdKey
+buildName = varQual pREL_BASE_Name FSLIT("build") buildIdKey
+augmentName = varQual pREL_BASE_Name FSLIT("augment") augmentIdKey
+appendName = varQual pREL_BASE_Name FSLIT("++") appendIdKey
+andName = varQual pREL_BASE_Name FSLIT("&&") andIdKey
+orName = varQual pREL_BASE_Name FSLIT("||") orIdKey
+assertName = varQual pREL_BASE_Name FSLIT("assert") assertIdKey
+lazyIdName = wVarQual pREL_BASE_Name FSLIT("lazy") lazyIdKey
--- Class Read
-readClassName = clsQual pREL_READ_Name FSLIT("Read") readClassKey
+-- PrelTup
+fstName = varQual pREL_TUP_Name FSLIT("fst") fstIdKey
+sndName = varQual pREL_TUP_Name FSLIT("snd") sndIdKey
-- Module PrelNum
numClassName = clsQual pREL_NUM_Name FSLIT("Num") numClassKey
negateName = varQual pREL_NUM_Name FSLIT("negate") negateClassOpKey
plusIntegerName = varQual pREL_NUM_Name FSLIT("plusInteger") plusIntegerIdKey
timesIntegerName = varQual pREL_NUM_Name FSLIT("timesInteger") timesIntegerIdKey
-integerTyConName = tcQual pREL_NUM_Name FSLIT("Integer") integerTyConKey
-smallIntegerDataConName = dataQual pREL_NUM_Name FSLIT("S#") smallIntegerDataConKey
-largeIntegerDataConName = dataQual pREL_NUM_Name FSLIT("J#") largeIntegerDataConKey
+integerTyConName = wTcQual pREL_NUM_Name FSLIT("Integer") integerTyConKey
+smallIntegerDataConName = wDataQual pREL_NUM_Name FSLIT("S#") smallIntegerDataConKey
+largeIntegerDataConName = wDataQual pREL_NUM_Name FSLIT("J#") largeIntegerDataConKey
-- PrelReal types and classes
rationalTyConName = tcQual pREL_REAL_Name FSLIT("Rational") rationalTyConKey
fromRationalName = varQual pREL_REAL_Name FSLIT("fromRational") fromRationalClassOpKey
-- PrelFloat classes
-floatTyConName = tcQual pREL_FLOAT_Name FSLIT("Float") floatTyConKey
-floatDataConName = dataQual pREL_FLOAT_Name FSLIT("F#") floatDataConKey
-doubleTyConName = tcQual pREL_FLOAT_Name FSLIT("Double") doubleTyConKey
-doubleDataConName = dataQual pREL_FLOAT_Name FSLIT("D#") doubleDataConKey
+floatTyConName = wTcQual pREL_FLOAT_Name FSLIT("Float") floatTyConKey
+floatDataConName = wDataQual pREL_FLOAT_Name FSLIT("F#") floatDataConKey
+doubleTyConName = wTcQual pREL_FLOAT_Name FSLIT("Double") doubleTyConKey
+doubleDataConName = wDataQual pREL_FLOAT_Name FSLIT("D#") doubleDataConKey
floatingClassName = clsQual pREL_FLOAT_Name FSLIT("Floating") floatingClassKey
realFloatClassName = clsQual pREL_FLOAT_Name FSLIT("RealFloat") realFloatClassKey
-- Class Ix
ixClassName = clsQual pREL_ARR_Name FSLIT("Ix") ixClassKey
--- Class Enum
+-- Enum module (Enum, Bounded)
enumClassName = clsQual pREL_ENUM_Name FSLIT("Enum") enumClassKey
-toEnumName = varQual pREL_ENUM_Name FSLIT("toEnum") toEnumClassOpKey
-fromEnumName = varQual pREL_ENUM_Name FSLIT("fromEnum") fromEnumClassOpKey
enumFromName = varQual pREL_ENUM_Name FSLIT("enumFrom") enumFromClassOpKey
enumFromToName = varQual pREL_ENUM_Name FSLIT("enumFromTo") enumFromToClassOpKey
enumFromThenName = varQual pREL_ENUM_Name FSLIT("enumFromThen") enumFromThenClassOpKey
enumFromThenToName = varQual pREL_ENUM_Name FSLIT("enumFromThenTo") enumFromThenToClassOpKey
-
--- Overloaded via Class Enum
-enumFromToPName = varQual pREL_PARR_Name FSLIT("enumFromToP") enumFromToPIdKey
-enumFromThenToPName= varQual pREL_PARR_Name FSLIT("enumFromThenToP") enumFromThenToPIdKey
-
--- Class Bounded
boundedClassName = clsQual pREL_ENUM_Name FSLIT("Bounded") boundedClassKey
-- List functions
filterName = varQual pREL_LIST_Name FSLIT("filter") filterIdKey
zipName = varQual pREL_LIST_Name FSLIT("zip") zipIdKey
+-- MetaHaskell Extension, "the smart constructors"
+-- text3 from Meta/work/gen.hs
+intLName = varQual mETA_META_Name FSLIT("intL") intLIdKey
+charLName = varQual mETA_META_Name FSLIT("charL") charLIdKey
+plitName = varQual mETA_META_Name FSLIT("plit") plitIdKey
+pvarName = varQual mETA_META_Name FSLIT("pvar") pvarIdKey
+ptupName = varQual mETA_META_Name FSLIT("ptup") ptupIdKey
+pconName = varQual mETA_META_Name FSLIT("pcon") pconIdKey
+ptildeName = varQual mETA_META_Name FSLIT("ptilde") ptildeIdKey
+paspatName = varQual mETA_META_Name FSLIT("paspat") paspatIdKey
+pwildName = varQual mETA_META_Name FSLIT("pwild") pwildIdKey
+varName = varQual mETA_META_Name FSLIT("var") varIdKey
+conName = varQual mETA_META_Name FSLIT("con") conIdKey
+litName = varQual mETA_META_Name FSLIT("lit") litIdKey
+appName = varQual mETA_META_Name FSLIT("app") appIdKey
+infixEName = varQual mETA_META_Name FSLIT("infixE") infixEIdKey
+lamName = varQual mETA_META_Name FSLIT("lam") lamIdKey
+tupName = varQual mETA_META_Name FSLIT("tup") tupIdKey
+doEName = varQual mETA_META_Name FSLIT("doE") doEIdKey
+compName = varQual mETA_META_Name FSLIT("comp") compIdKey
+listExpName = varQual mETA_META_Name FSLIT("listExp") listExpIdKey
+condName = varQual mETA_META_Name FSLIT("cond") condIdKey
+letEName = varQual mETA_META_Name FSLIT("letE") letEIdKey
+caseEName = varQual mETA_META_Name FSLIT("caseE") caseEIdKey
+infixAppName = varQual mETA_META_Name FSLIT("infixApp") infixAppIdKey
+sectionLName = varQual mETA_META_Name FSLIT("sectionL") sectionLIdKey
+sectionRName = varQual mETA_META_Name FSLIT("sectionR") sectionRIdKey
+guardedName = varQual mETA_META_Name FSLIT("guarded") guardedIdKey
+normalName = varQual mETA_META_Name FSLIT("normal") normalIdKey
+bindStName = varQual mETA_META_Name FSLIT("bindSt") bindStIdKey
+letStName = varQual mETA_META_Name FSLIT("letSt") letStIdKey
+noBindStName = varQual mETA_META_Name FSLIT("noBindSt") noBindStIdKey
+parStName = varQual mETA_META_Name FSLIT("parSt") parStIdKey
+fromName = varQual mETA_META_Name FSLIT("from") fromIdKey
+fromThenName = varQual mETA_META_Name FSLIT("fromThen") fromThenIdKey
+fromToName = varQual mETA_META_Name FSLIT("fromTo") fromToIdKey
+fromThenToName = varQual mETA_META_Name FSLIT("fromThenTo") fromThenToIdKey
+liftName = varQual mETA_META_Name FSLIT("lift") liftIdKey
+gensymName = varQual mETA_META_Name FSLIT("gensym") gensymIdKey
+returnQName = varQual mETA_META_Name FSLIT("returnQ") returnQIdKey
+bindQName = varQual mETA_META_Name FSLIT("bindQ") bindQIdKey
+funName = varQual mETA_META_Name FSLIT("fun") funIdKey
+valName = varQual mETA_META_Name FSLIT("val") valIdKey
+matchName = varQual mETA_META_Name FSLIT("match") matchIdKey
+clauseName = varQual mETA_META_Name FSLIT("clause") clauseIdKey
+protoName = varQual mETA_META_Name FSLIT("proto") protoIdKey
+exprTyConName = tcQual mETA_META_Name FSLIT("Expr") exprTyConKey
+declTyConName = tcQual mETA_META_Name FSLIT("Decl") declTyConKey
+pattTyConName = tcQual mETA_META_Name FSLIT("Patt") pattTyConKey
+mtchTyConName = tcQual mETA_META_Name FSLIT("Mtch") mtchTyConKey
+clseTyConName = tcQual mETA_META_Name FSLIT("Clse") clseTyConKey
+stmtTyConName = tcQual mETA_META_Name FSLIT("Stmt") stmtTyConKey
+
+qTyConName = tcQual mETA_META_Name FSLIT("Q") qTyConKey
+expTyConName = tcQual mETA_META_Name FSLIT("Exp") expTyConKey
+matTyConName = tcQual mETA_META_Name FSLIT("Mat") matTyConKey
+clsTyConName = tcQual mETA_META_Name FSLIT("Cls") clsTyConKey
+
+-- Class Show
+showClassName = clsQual pREL_SHOW_Name FSLIT("Show") showClassKey
+
+-- Class Read
+readClassName = clsQual pREL_READ_Name FSLIT("Read") readClassKey
+
-- parallel array types and functions
-parrTyConName = tcQual pREL_PARR_Name FSLIT("[::]") parrTyConKey
-parrDataConName = dataQual pREL_PARR_Name FSLIT("PArr") parrDataConKey
-nullPName = varQual pREL_PARR_Name FSLIT("nullP") nullPIdKey
-lengthPName = varQual pREL_PARR_Name FSLIT("lengthP") lengthPIdKey
-replicatePName = varQual pREL_PARR_Name FSLIT("replicateP") replicatePIdKey
-mapPName = varQual pREL_PARR_Name FSLIT("mapP") mapPIdKey
-filterPName = varQual pREL_PARR_Name FSLIT("filterP") filterPIdKey
-zipPName = varQual pREL_PARR_Name FSLIT("zipP") zipPIdKey
-crossPName = varQual pREL_PARR_Name FSLIT("crossP") crossPIdKey
-indexPName = varQual pREL_PARR_Name FSLIT("!:") indexPIdKey
-toPName = varQual pREL_PARR_Name FSLIT("toP") toPIdKey
-bpermutePName = varQual pREL_PARR_Name FSLIT("bpermuteP") bpermutePIdKey
-bpermuteDftPName = varQual pREL_PARR_Name FSLIT("bpermuteDftP")
- bpermuteDftPIdKey
-indexOfPName = varQual pREL_PARR_Name FSLIT("indexOfP") indexOfPIdKey
+enumFromToPName = varQual pREL_PARR_Name FSLIT("enumFromToP") enumFromToPIdKey
+enumFromThenToPName= varQual pREL_PARR_Name FSLIT("enumFromThenToP") enumFromThenToPIdKey
+parrTyConName = wTcQual pREL_PARR_Name FSLIT("[::]") parrTyConKey
+parrDataConName = wDataQual pREL_PARR_Name FSLIT("PArr") parrDataConKey
+nullPName = varQual pREL_PARR_Name FSLIT("nullP") nullPIdKey
+lengthPName = varQual pREL_PARR_Name FSLIT("lengthP") lengthPIdKey
+replicatePName = varQual pREL_PARR_Name FSLIT("replicateP") replicatePIdKey
+mapPName = varQual pREL_PARR_Name FSLIT("mapP") mapPIdKey
+filterPName = varQual pREL_PARR_Name FSLIT("filterP") filterPIdKey
+zipPName = varQual pREL_PARR_Name FSLIT("zipP") zipPIdKey
+crossPName = varQual pREL_PARR_Name FSLIT("crossP") crossPIdKey
+indexPName = varQual pREL_PARR_Name FSLIT("!:") indexPIdKey
+toPName = varQual pREL_PARR_Name FSLIT("toP") toPIdKey
+bpermutePName = varQual pREL_PARR_Name FSLIT("bpermuteP") bpermutePIdKey
+bpermuteDftPName = varQual pREL_PARR_Name FSLIT("bpermuteDftP") bpermuteDftPIdKey
+indexOfPName = varQual pREL_PARR_Name FSLIT("indexOfP") indexOfPIdKey
-- IOBase things
ioTyConName = tcQual pREL_IO_BASE_Name FSLIT("IO") ioTyConKey
int32TyConName = tcQual pREL_INT_Name FSLIT("Int32") int32TyConKey
int64TyConName = tcQual pREL_INT_Name FSLIT("Int64") int64TyConKey
-word8TyConName = tcQual pREL_WORD_Name FSLIT("Word8") word8TyConKey
-word16TyConName = tcQual pREL_WORD_Name FSLIT("Word16") word16TyConKey
-word32TyConName = tcQual pREL_WORD_Name FSLIT("Word32") word32TyConKey
-word64TyConName = tcQual pREL_WORD_Name FSLIT("Word64") word64TyConKey
-
-wordTyConName = tcQual pREL_WORD_Name FSLIT("Word") wordTyConKey
-wordDataConName = dataQual pREL_WORD_Name FSLIT("W#") wordDataConKey
-
-addrTyConName = tcQual aDDR_Name FSLIT("Addr") addrTyConKey
-addrDataConName = dataQual aDDR_Name FSLIT("A#") addrDataConKey
+-- Word module
+word8TyConName = tcQual pREL_WORD_Name FSLIT("Word8") word8TyConKey
+word16TyConName = tcQual pREL_WORD_Name FSLIT("Word16") word16TyConKey
+word32TyConName = tcQual pREL_WORD_Name FSLIT("Word32") word32TyConKey
+word64TyConName = tcQual pREL_WORD_Name FSLIT("Word64") word64TyConKey
+wordTyConName = wTcQual pREL_WORD_Name FSLIT("Word") wordTyConKey
+wordDataConName = wDataQual pREL_WORD_Name FSLIT("W#") wordDataConKey
-ptrTyConName = tcQual pREL_PTR_Name FSLIT("Ptr") ptrTyConKey
-ptrDataConName = dataQual pREL_PTR_Name FSLIT("Ptr") ptrDataConKey
+-- Addr module
+addrTyConName = wTcQual aDDR_Name FSLIT("Addr") addrTyConKey
+addrDataConName = wDataQual aDDR_Name FSLIT("A#") addrDataConKey
-funPtrTyConName = tcQual pREL_PTR_Name FSLIT("FunPtr") funPtrTyConKey
-funPtrDataConName = dataQual pREL_PTR_Name FSLIT("FunPtr") funPtrDataConKey
+-- PrelPtr module
+ptrTyConName = wTcQual pREL_PTR_Name FSLIT("Ptr") ptrTyConKey
+ptrDataConName = wDataQual pREL_PTR_Name FSLIT("Ptr") ptrDataConKey
+funPtrTyConName = wTcQual pREL_PTR_Name FSLIT("FunPtr") funPtrTyConKey
+funPtrDataConName = wDataQual pREL_PTR_Name FSLIT("FunPtr") funPtrDataConKey
-- Byte array types
byteArrayTyConName = tcQual pREL_BYTEARR_Name FSLIT("ByteArray") byteArrayTyConKey
-- Foreign objects and weak pointers
stablePtrTyConName = tcQual pREL_STABLE_Name FSLIT("StablePtr") stablePtrTyConKey
stablePtrDataConName = dataQual pREL_STABLE_Name FSLIT("StablePtr") stablePtrDataConKey
-deRefStablePtrName = varQual pREL_STABLE_Name FSLIT("deRefStablePtr") deRefStablePtrIdKey
newStablePtrName = varQual pREL_STABLE_Name FSLIT("newStablePtr") newStablePtrIdKey
-assertName = varQual gHC_PRIM_Name FSLIT("assert") assertIdKey
-getTagName = varQual gHC_PRIM_Name FSLIT("getTag#") getTagIdKey
-
-errorName = varQual pREL_ERR_Name FSLIT("error") errorIdKey
+-- Error module
+errorName = wVarQual pREL_ERR_Name FSLIT("error") errorIdKey
+recSelErrorName = wVarQual pREL_ERR_Name FSLIT("recSelError") recSelErrorIdKey
+runtimeErrorName = wVarQual pREL_ERR_Name FSLIT("runtimeError") runtimeErrorIdKey
+irrefutPatErrorName = wVarQual pREL_ERR_Name FSLIT("irrefutPatError") irrefutPatErrorIdKey
+recConErrorName = wVarQual pREL_ERR_Name FSLIT("recConError") recConErrorIdKey
+patErrorName = wVarQual pREL_ERR_Name FSLIT("patError") patErrorIdKey
+noMethodBindingErrorName = wVarQual pREL_ERR_Name FSLIT("noMethodBindingError") noMethodBindingErrorIdKey
+nonExhaustiveGuardsErrorName
+ = wVarQual pREL_ERR_Name FSLIT("nonExhaustiveGuardsError") nonExhaustiveGuardsErrorIdKey
+
+-- PrelST module
runSTRepName = varQual pREL_ST_Name FSLIT("runSTRep") runSTRepIdKey
-- The "split" Id for splittable implicit parameters
%************************************************************************
%* *
-\subsection{Known names}
+\subsection{Standard groups of names}
%* *
%************************************************************************
-The following names are known to the compiler, but they don't require
-pre-assigned keys. Mostly these names are used in generating deriving
-code, which is passed through the renamer anyway.
-
- THEY ARE ALL ORIGINAL NAMES, HOWEVER
-
\begin{code}
--- Lists and tuples
-tupleCon_RDR, tupleTyCon_RDR :: Int -> RdrName
-ubxTupleCon_RDR, ubxTupleTyCon_RDR :: Int -> RdrName
-
-tupleCon_RDR = mkTupConRdrName dataName Boxed
-tupleTyCon_RDR = mkTupConRdrName tcName Boxed
-ubxTupleCon_RDR = mkTupConRdrName dataName Unboxed
-ubxTupleTyCon_RDR = mkTupConRdrName tcName Unboxed
-
-unitCon_RDR = dataQual_RDR pREL_BASE_Name FSLIT("()")
-unitTyCon_RDR = tcQual_RDR pREL_BASE_Name FSLIT("()")
-
-and_RDR = varQual_RDR pREL_BASE_Name FSLIT("&&")
-not_RDR = varQual_RDR pREL_BASE_Name FSLIT("not")
-compose_RDR = varQual_RDR pREL_BASE_Name FSLIT(".")
-ne_RDR = varQual_RDR pREL_BASE_Name FSLIT("/=")
-le_RDR = varQual_RDR pREL_BASE_Name FSLIT("<=")
-lt_RDR = varQual_RDR pREL_BASE_Name FSLIT("<")
-gt_RDR = varQual_RDR pREL_BASE_Name FSLIT(">")
-ltTag_RDR = dataQual_RDR pREL_BASE_Name FSLIT("LT")
-eqTag_RDR = dataQual_RDR pREL_BASE_Name FSLIT("EQ")
-gtTag_RDR = dataQual_RDR pREL_BASE_Name FSLIT("GT")
-max_RDR = varQual_RDR pREL_BASE_Name FSLIT("max")
-min_RDR = varQual_RDR pREL_BASE_Name FSLIT("min")
-compare_RDR = varQual_RDR pREL_BASE_Name FSLIT("compare")
-showList_RDR = varQual_RDR pREL_SHOW_Name FSLIT("showList")
-showList___RDR = varQual_RDR pREL_SHOW_Name FSLIT("showList__")
-showsPrec_RDR = varQual_RDR pREL_SHOW_Name FSLIT("showsPrec")
-showSpace_RDR = varQual_RDR pREL_SHOW_Name FSLIT("showSpace")
-showString_RDR = varQual_RDR pREL_SHOW_Name FSLIT("showString")
-showParen_RDR = varQual_RDR pREL_SHOW_Name FSLIT("showParen")
-
-readsPrec_RDR = varQual_RDR pREL_READ_Name FSLIT("readsPrec")
-readPrec_RDR = varQual_RDR pREL_READ_Name FSLIT("readPrec")
-readListPrec_RDR = varQual_RDR pREL_READ_Name FSLIT("readListPrec")
-readList_RDR = varQual_RDR pREL_READ_Name FSLIT("readList")
-
-readListDefault_RDR = varQual_RDR pREL_READ_Name FSLIT("readListDefault")
-readListPrecDefault_RDR = varQual_RDR pREL_READ_Name FSLIT("readListPrecDefault")
-parens_RDR = varQual_RDR pREL_READ_Name FSLIT("parens")
-choose_RDR = varQual_RDR pREL_READ_Name FSLIT("choose")
-lexP_RDR = varQual_RDR pREL_READ_Name FSLIT("lexP")
-
--- Module ReadPrec
-step_RDR = varQual_RDR rEAD_PREC_Name FSLIT("step")
-reset_RDR = varQual_RDR rEAD_PREC_Name FSLIT("reset")
-alt_RDR = varQual_RDR rEAD_PREC_Name FSLIT("+++")
-prec_RDR = varQual_RDR rEAD_PREC_Name FSLIT("prec")
-
--- Module Lex
-symbol_RDR = dataQual_RDR lEX_Name FSLIT("Symbol")
-ident_RDR = dataQual_RDR lEX_Name FSLIT("Ident")
-punc_RDR = dataQual_RDR lEX_Name FSLIT("Punc")
-
-times_RDR = varQual_RDR pREL_NUM_Name FSLIT("*")
-plus_RDR = varQual_RDR pREL_NUM_Name FSLIT("+")
-negate_RDR = varQual_RDR pREL_NUM_Name FSLIT("negate")
-range_RDR = varQual_RDR pREL_ARR_Name FSLIT("range")
-index_RDR = varQual_RDR pREL_ARR_Name FSLIT("index")
-inRange_RDR = varQual_RDR pREL_ARR_Name FSLIT("inRange")
-succ_RDR = varQual_RDR pREL_ENUM_Name FSLIT("succ")
-pred_RDR = varQual_RDR pREL_ENUM_Name FSLIT("pred")
-minBound_RDR = varQual_RDR pREL_ENUM_Name FSLIT("minBound")
-maxBound_RDR = varQual_RDR pREL_ENUM_Name FSLIT("maxBound")
-assertErr_RDR = varQual_RDR pREL_ERR_Name FSLIT("assertError")
-\end{code}
-
-These RDR names also have known keys, so we need to get back the RDR names to
-populate the occurrence list above.
-
-\begin{code}
-funTyCon_RDR = nameRdrName funTyConName
-nilCon_RDR = nameRdrName nilDataConName
-listTyCon_RDR = nameRdrName listTyConName
-parrTyCon_RDR = nameRdrName parrTyConName
-ioTyCon_RDR = nameRdrName ioTyConName
-intTyCon_RDR = nameRdrName intTyConName
-eq_RDR = nameRdrName eqName
-ge_RDR = nameRdrName geName
-numClass_RDR = nameRdrName numClassName
-ordClass_RDR = nameRdrName ordClassName
-map_RDR = nameRdrName mapName
-append_RDR = nameRdrName appendName
-foldr_RDR = nameRdrName foldrName
-build_RDR = nameRdrName buildName
-enumFromTo_RDR = nameRdrName enumFromToName
-returnM_RDR = nameRdrName returnMName
-bindM_RDR = nameRdrName bindMName
-failM_RDR = nameRdrName failMName
-false_RDR = nameRdrName falseDataConName
-true_RDR = nameRdrName trueDataConName
-error_RDR = nameRdrName errorName
-getTag_RDR = nameRdrName getTagName
-fromEnum_RDR = nameRdrName fromEnumName
-toEnum_RDR = nameRdrName toEnumName
-enumFrom_RDR = nameRdrName enumFromName
-mkInt_RDR = nameRdrName intDataConName
-enumFromThen_RDR = nameRdrName enumFromThenName
-enumFromThenTo_RDR = nameRdrName enumFromThenToName
-ratioDataCon_RDR = nameRdrName ratioDataConName
-plusInteger_RDR = nameRdrName plusIntegerName
-timesInteger_RDR = nameRdrName timesIntegerName
-enumClass_RDR = nameRdrName enumClassName
-monadClass_RDR = nameRdrName monadClassName
-ioDataCon_RDR = nameRdrName ioDataConName
-cCallableClass_RDR = nameRdrName cCallableClassName
-cReturnableClass_RDR = nameRdrName cReturnableClassName
-eqClass_RDR = nameRdrName eqClassName
-eqString_RDR = nameRdrName eqStringName
-unpackCString_RDR = nameRdrName unpackCStringName
-unpackCStringFoldr_RDR = nameRdrName unpackCStringFoldrName
-unpackCStringUtf8_RDR = nameRdrName unpackCStringUtf8Name
-deRefStablePtr_RDR = nameRdrName deRefStablePtrName
-newStablePtr_RDR = nameRdrName newStablePtrName
-bindIO_RDR = nameRdrName bindIOName
-returnIO_RDR = nameRdrName returnIOName
-fromInteger_RDR = nameRdrName fromIntegerName
-fromRational_RDR = nameRdrName fromRationalName
-minus_RDR = nameRdrName minusName
+templateHaskellNames :: NameSet
+-- The names that are implicitly mentioned by ``bracket''
+-- Should stay in sync with the import list of DsMeta
+templateHaskellNames
+ = mkNameSet [ intLName,charLName, plitName, pvarName, ptupName,
+ pconName, ptildeName, paspatName, pwildName,
+ varName, conName, litName, appName, lamName,
+ tupName, doEName, compName,
+ listExpName, condName, letEName, caseEName,
+ infixAppName, guardedName, normalName,
+ bindStName, letStName, noBindStName, parStName,
+ fromName, fromThenName, fromToName, fromThenToName,
+ funName, valName, liftName,gensymName, bindQName,
+ appendName, matchName, clauseName ]
\end{code}
%************************************************************************
All these are original names; hence mkOrig
\begin{code}
-varQual mod str uq = mkKnownKeyExternalName (varQual_RDR mod str) uq
-dataQual mod str uq = mkKnownKeyExternalName (dataQual_RDR mod str) uq
-tcQual mod str uq = mkKnownKeyExternalName (tcQual_RDR mod str) uq
-clsQual mod str uq = mkKnownKeyExternalName (clsQual_RDR mod str) uq
-
-kindQual str uq = mkInternalName uq (mkKindOccFS tcName str) builtinSrcLoc
+varQual = mk_known_key_name OccNameAlias.varName -- Note use of local alias vName
+dataQual = mk_known_key_name dataName
+tcQual = mk_known_key_name tcName
+clsQual = mk_known_key_name clsName
+
+wVarQual = mk_wired_in_name OccNameAlias.varName -- The wired-in analogues
+wDataQual = mk_wired_in_name dataName
+wTcQual = mk_wired_in_name tcName
+
+varQual_RDR mod str = mkOrig mod (mkOccFS OccNameAlias.varName str) -- note use of local alias vName
+tcQual_RDR mod str = mkOrig mod (mkOccFS tcName str)
+clsQual_RDR mod str = mkOrig mod (mkOccFS clsName str)
+dataQual_RDR mod str = mkOrig mod (mkOccFS dataName str)
+
+mk_known_key_name space mod str uniq
+ = mkKnownKeyExternalName mod (mkOccFS space str) uniq
+mk_wired_in_name space mod str uniq
+ = mkWiredInName (mkVanillaModule mod) (mkOccFS space str) uniq
+
+kindQual str uq = mkInternalName uq (mkKindOccFS tcName str) noSrcLoc
-- Kinds are not z-encoded in interface file, hence mkKindOccFS
-- And they don't come from any particular module; indeed we always
-- want to print them unqualified. Hence the LocalName
-
-varQual_RDR mod str = mkOrig varName mod str
-tcQual_RDR mod str = mkOrig tcName mod str
-clsQual_RDR mod str = mkOrig clsName mod str
-dataQual_RDR mod str = mkOrig dataName mod str
\end{code}
%************************************************************************
\subsubsection[Uniques-prelude-Classes]{@Uniques@ for wired-in @Classes@}
%* *
%************************************************************************
+--MetaHaskell extension hand allocate keys here
\begin{code}
boundedClassKey = mkPreludeClassUnique 1
-- Parallel array type constructor
parrTyConKey = mkPreludeTyConUnique 82
+-- Template Haskell
+qTyConKey = mkPreludeTyConUnique 83
+exprTyConKey = mkPreludeTyConUnique 84
+declTyConKey = mkPreludeTyConUnique 85
+pattTyConKey = mkPreludeTyConUnique 86
+mtchTyConKey = mkPreludeTyConUnique 87
+clseTyConKey = mkPreludeTyConUnique 88
+stmtTyConKey = mkPreludeTyConUnique 89
+expTyConKey = mkPreludeTyConUnique 90
+matTyConKey = mkPreludeTyConUnique 91
+clsTyConKey = mkPreludeTyConUnique 92
+
unitTyConKey = mkTupleTyConUnique Boxed 0
\end{code}
\begin{code}
absentErrorIdKey = mkPreludeMiscIdUnique 1
-appendIdKey = mkPreludeMiscIdUnique 2
+getTagIdKey = mkPreludeMiscIdUnique 2
augmentIdKey = mkPreludeMiscIdUnique 3
-buildIdKey = mkPreludeMiscIdUnique 4
-errorIdKey = mkPreludeMiscIdUnique 5
-foldlIdKey = mkPreludeMiscIdUnique 6
-foldrIdKey = mkPreludeMiscIdUnique 7
-recSelErrIdKey = mkPreludeMiscIdUnique 8
-integerMinusOneIdKey = mkPreludeMiscIdUnique 9
-integerPlusOneIdKey = mkPreludeMiscIdUnique 10
-integerPlusTwoIdKey = mkPreludeMiscIdUnique 11
-integerZeroIdKey = mkPreludeMiscIdUnique 12
-int2IntegerIdKey = mkPreludeMiscIdUnique 13
-seqIdKey = mkPreludeMiscIdUnique 14
-irrefutPatErrorIdKey = mkPreludeMiscIdUnique 15
-eqStringIdKey = mkPreludeMiscIdUnique 16
-noMethodBindingErrorIdKey = mkPreludeMiscIdUnique 17
-nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 18
-runtimeErrorIdKey = mkPreludeMiscIdUnique 19
-parErrorIdKey = mkPreludeMiscIdUnique 20
-parIdKey = mkPreludeMiscIdUnique 21
-patErrorIdKey = mkPreludeMiscIdUnique 22
-realWorldPrimIdKey = mkPreludeMiscIdUnique 23
-recConErrorIdKey = mkPreludeMiscIdUnique 24
-recUpdErrorIdKey = mkPreludeMiscIdUnique 25
-traceIdKey = mkPreludeMiscIdUnique 26
-unpackCStringUtf8IdKey = mkPreludeMiscIdUnique 27
-unpackCStringAppendIdKey = mkPreludeMiscIdUnique 28
-unpackCStringFoldrIdKey = mkPreludeMiscIdUnique 29
-unpackCStringIdKey = mkPreludeMiscIdUnique 30
-ushowListIdKey = mkPreludeMiscIdUnique 31
+appendIdKey = mkPreludeMiscIdUnique 4
+buildIdKey = mkPreludeMiscIdUnique 5
+errorIdKey = mkPreludeMiscIdUnique 6
+foldlIdKey = mkPreludeMiscIdUnique 7
+foldrIdKey = mkPreludeMiscIdUnique 8
+recSelErrorIdKey = mkPreludeMiscIdUnique 9
+integerMinusOneIdKey = mkPreludeMiscIdUnique 10
+integerPlusOneIdKey = mkPreludeMiscIdUnique 11
+integerPlusTwoIdKey = mkPreludeMiscIdUnique 12
+integerZeroIdKey = mkPreludeMiscIdUnique 13
+int2IntegerIdKey = mkPreludeMiscIdUnique 14
+seqIdKey = mkPreludeMiscIdUnique 15
+irrefutPatErrorIdKey = mkPreludeMiscIdUnique 16
+eqStringIdKey = mkPreludeMiscIdUnique 17
+noMethodBindingErrorIdKey = mkPreludeMiscIdUnique 18
+nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 19
+runtimeErrorIdKey = mkPreludeMiscIdUnique 20
+parErrorIdKey = mkPreludeMiscIdUnique 21
+parIdKey = mkPreludeMiscIdUnique 22
+patErrorIdKey = mkPreludeMiscIdUnique 23
+realWorldPrimIdKey = mkPreludeMiscIdUnique 24
+recConErrorIdKey = mkPreludeMiscIdUnique 25
+recUpdErrorIdKey = mkPreludeMiscIdUnique 26
+traceIdKey = mkPreludeMiscIdUnique 27
+unpackCStringUtf8IdKey = mkPreludeMiscIdUnique 28
+unpackCStringAppendIdKey = mkPreludeMiscIdUnique 29
+unpackCStringFoldrIdKey = mkPreludeMiscIdUnique 30
+unpackCStringIdKey = mkPreludeMiscIdUnique 31
+
unsafeCoerceIdKey = mkPreludeMiscIdUnique 32
concatIdKey = mkPreludeMiscIdUnique 33
filterIdKey = mkPreludeMiscIdUnique 34
returnIOIdKey = mkPreludeMiscIdUnique 37
deRefStablePtrIdKey = mkPreludeMiscIdUnique 38
newStablePtrIdKey = mkPreludeMiscIdUnique 39
-getTagIdKey = mkPreludeMiscIdUnique 40
plusIntegerIdKey = mkPreludeMiscIdUnique 41
timesIntegerIdKey = mkPreludeMiscIdUnique 42
printIdKey = mkPreludeMiscIdUnique 43
fstIdKey = mkPreludeMiscIdUnique 49
sndIdKey = mkPreludeMiscIdUnique 50
otherwiseIdKey = mkPreludeMiscIdUnique 51
-mapIdKey = mkPreludeMiscIdUnique 52
assertIdKey = mkPreludeMiscIdUnique 53
runSTRepIdKey = mkPreludeMiscIdUnique 54
lazyIdKey = mkPreludeMiscIdUnique 60
-- Parallel array functions
-nullPIdKey = mkPreludeMiscIdUnique 70
-lengthPIdKey = mkPreludeMiscIdUnique 71
-replicatePIdKey = mkPreludeMiscIdUnique 72
-mapPIdKey = mkPreludeMiscIdUnique 73
-filterPIdKey = mkPreludeMiscIdUnique 74
-zipPIdKey = mkPreludeMiscIdUnique 75
-crossPIdKey = mkPreludeMiscIdUnique 76
-indexPIdKey = mkPreludeMiscIdUnique 77
-toPIdKey = mkPreludeMiscIdUnique 78
-enumFromToPIdKey = mkPreludeMiscIdUnique 79
-enumFromThenToPIdKey = mkPreludeMiscIdUnique 80
-bpermutePIdKey = mkPreludeMiscIdUnique 81
-bpermuteDftPIdKey = mkPreludeMiscIdUnique 82
-indexOfPIdKey = mkPreludeMiscIdUnique 83
+nullPIdKey = mkPreludeMiscIdUnique 80
+lengthPIdKey = mkPreludeMiscIdUnique 81
+replicatePIdKey = mkPreludeMiscIdUnique 82
+mapPIdKey = mkPreludeMiscIdUnique 83
+filterPIdKey = mkPreludeMiscIdUnique 84
+zipPIdKey = mkPreludeMiscIdUnique 85
+crossPIdKey = mkPreludeMiscIdUnique 86
+indexPIdKey = mkPreludeMiscIdUnique 87
+toPIdKey = mkPreludeMiscIdUnique 88
+enumFromToPIdKey = mkPreludeMiscIdUnique 89
+enumFromThenToPIdKey = mkPreludeMiscIdUnique 90
+bpermutePIdKey = mkPreludeMiscIdUnique 91
+bpermuteDftPIdKey = mkPreludeMiscIdUnique 92
+indexOfPIdKey = mkPreludeMiscIdUnique 93
\end{code}
Certain class operations from Prelude classes. They get their own
\begin{code}
-- Just a place holder for unbound variables produced by the renamer:
unboundKey = mkPreludeMiscIdUnique 101
+
fromIntegerClassOpKey = mkPreludeMiscIdUnique 102
minusClassOpKey = mkPreludeMiscIdUnique 103
fromRationalClassOpKey = mkPreludeMiscIdUnique 104
failMClassOpKey = mkPreludeMiscIdUnique 112
bindMClassOpKey = mkPreludeMiscIdUnique 113 -- (>>=)
thenMClassOpKey = mkPreludeMiscIdUnique 114 -- (>>)
-fromEnumClassOpKey = mkPreludeMiscIdUnique 115
returnMClassOpKey = mkPreludeMiscIdUnique 117
-toEnumClassOpKey = mkPreludeMiscIdUnique 119
+
+-- MetaHaskell Extension, (text4 118) from Meta/work/gen.hs
+intLIdKey = mkPreludeMiscIdUnique 118
+charLIdKey = mkPreludeMiscIdUnique 119
+plitIdKey = mkPreludeMiscIdUnique 120
+pvarIdKey = mkPreludeMiscIdUnique 121
+ptupIdKey = mkPreludeMiscIdUnique 122
+pconIdKey = mkPreludeMiscIdUnique 123
+ptildeIdKey = mkPreludeMiscIdUnique 124
+paspatIdKey = mkPreludeMiscIdUnique 125
+pwildIdKey = mkPreludeMiscIdUnique 126
+varIdKey = mkPreludeMiscIdUnique 127
+conIdKey = mkPreludeMiscIdUnique 128
+litIdKey = mkPreludeMiscIdUnique 129
+appIdKey = mkPreludeMiscIdUnique 130
+infixEIdKey = mkPreludeMiscIdUnique 131
+lamIdKey = mkPreludeMiscIdUnique 132
+tupIdKey = mkPreludeMiscIdUnique 133
+doEIdKey = mkPreludeMiscIdUnique 134
+compIdKey = mkPreludeMiscIdUnique 135
+listExpIdKey = mkPreludeMiscIdUnique 137
+condIdKey = mkPreludeMiscIdUnique 138
+letEIdKey = mkPreludeMiscIdUnique 139
+caseEIdKey = mkPreludeMiscIdUnique 140
+infixAppIdKey = mkPreludeMiscIdUnique 141
+sectionLIdKey = mkPreludeMiscIdUnique 142
+sectionRIdKey = mkPreludeMiscIdUnique 143
+guardedIdKey = mkPreludeMiscIdUnique 144
+normalIdKey = mkPreludeMiscIdUnique 145
+bindStIdKey = mkPreludeMiscIdUnique 146
+letStIdKey = mkPreludeMiscIdUnique 147
+noBindStIdKey = mkPreludeMiscIdUnique 148
+parStIdKey = mkPreludeMiscIdUnique 149
+fromIdKey = mkPreludeMiscIdUnique 150
+fromThenIdKey = mkPreludeMiscIdUnique 151
+fromToIdKey = mkPreludeMiscIdUnique 152
+fromThenToIdKey = mkPreludeMiscIdUnique 153
+liftIdKey = mkPreludeMiscIdUnique 154
+gensymIdKey = mkPreludeMiscIdUnique 155
+returnQIdKey = mkPreludeMiscIdUnique 156
+bindQIdKey = mkPreludeMiscIdUnique 157
+funIdKey = mkPreludeMiscIdUnique 158
+valIdKey = mkPreludeMiscIdUnique 159
+protoIdKey = mkPreludeMiscIdUnique 160
+matchIdKey = mkPreludeMiscIdUnique 161
+clauseIdKey = mkPreludeMiscIdUnique 162
\end{code}
%* *
%************************************************************************
-@derivableClassKeys@ is also used in checking \tr{deriving} constructs
-(@TcDeriv@).
-
-@derivingOccurrences@ maps a class name to a list of the (qualified)
-occurrences that will be mentioned by the derived code for the class
-when it is later generated. We don't need to put in things that are
-WiredIn (because they are already mapped to their correct name by the
-@NameSupply@. The class itself, and all its class ops, is already
-flagged as an occurrence so we don't need to mention that either.
-
-@derivingOccurrences@ has an item for every derivable class, even if
-that item is empty, because we treat lookup failure as indicating that
-the class is illegal in a deriving clause.
-
-\begin{code}
-derivingOccurrences :: UniqFM [RdrName]
-derivingOccurrences = listToUFM deriving_occ_info
-
-derivableClassKeys = map fst deriving_occ_info
-
-deriving_occ_info
- = [ (eqClassKey, [intTyCon_RDR, and_RDR, not_RDR])
- , (ordClassKey, [intTyCon_RDR, compose_RDR, eqTag_RDR, error_RDR])
- -- EQ (from Ordering) is needed to force in the constructors
- -- as well as the type constructor.
- , (enumClassKey, [intTyCon_RDR, eq_RDR, ge_RDR, and_RDR, map_RDR, plus_RDR,
- error_RDR, showsPrec_RDR, append_RDR])
- -- The last two Enum deps are only used to produce better
- -- error msgs for derived toEnum methods.
- , (boundedClassKey, [intTyCon_RDR])
- , (showClassKey, [intTyCon_RDR, numClass_RDR, ordClass_RDR, compose_RDR, showString_RDR,
- showParen_RDR, showSpace_RDR, showList___RDR])
- , (readClassKey, [intTyCon_RDR, numClass_RDR, ordClass_RDR,
- lexP_RDR, readPrec_RDR,
- readListDefault_RDR, readListPrecDefault_RDR,
- step_RDR, parens_RDR, reset_RDR, prec_RDR, alt_RDR, choose_RDR,
- ident_RDR, -- Pulls in the entire Lex.Lexeme data type
- bindM_RDR -- Pulls in the entire Monad class decl
- ] )
- , (ixClassKey, [intTyCon_RDR, numClass_RDR, and_RDR, map_RDR, enumFromTo_RDR, error_RDR,
- foldr_RDR, build_RDR,
- -- foldr and build required for list comprehension used
- -- with single constructor types -- KSW 2000-06
- returnM_RDR, failM_RDR])
- -- the last two are needed to force returnM, thenM and failM
- -- in before typechecking the list(monad) comprehension
- -- generated for derived Ix instances (range method)
- -- of single constructor types. -- SOF 8/97
- ]
- -- intTyCon: Practically any deriving needs Int, either for index calculations,
- -- or for taggery.
- -- ordClass: really it's the methods that are actually used.
- -- numClass: for Int literals
-\end{code}
-
-
NOTE: @Eq@ and @Text@ do need to appear in @standardClasses@
even though every numeric class has these two as a superclass,
because the list of ambiguous dictionaries hasn't been simplified.
= cCallishClassKeys
\end{code}
+@derivableClassKeys@ is also used in checking \tr{deriving} constructs
+(@TcDeriv@).
+
+\begin{code}
+derivableClassKeys
+ = [ eqClassKey, ordClassKey, enumClassKey, ixClassKey,
+ boundedClassKey, showClassKey, readClassKey ]
+\end{code}
+
import TysWiredIn ( trueDataConId, falseDataConId )
import TyCon ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon )
import DataCon ( dataConTag, dataConTyCon, dataConWorkId, fIRST_TAG )
-import CoreUtils ( exprIsValue, cheapEqExpr, exprIsConApp_maybe )
+import CoreUtils ( cheapEqExpr, exprIsConApp_maybe )
import Type ( tyConAppTyCon, eqType )
import OccName ( occNameUserString)
import PrelNames ( unpackCStringFoldrName, unpackCStringFoldrIdKey, hasKey,
module PrimOp (
PrimOp(..), allThePrimOps,
primOpType, primOpSig, primOpArity,
- mkPrimOpIdName, primOpRdrName, primOpTag, primOpOcc,
+ mkPrimOpIdName, primOpTag, primOpOcc,
commutableOp,
getPrimOpResultInfo, PrimOpResultInfo(..),
- eqCharName, eqIntName, eqFloatName, eqDoubleName, neqIntName,
+ eqCharName, eqIntName, neqIntName,
+ ltCharName, eqWordName, ltWordName, eqAddrName, ltAddrName,
+ eqFloatName, ltFloatName, eqDoubleName, ltDoubleName,
+ ltIntName, geIntName, leIntName, minusIntName, tagToEnumName
) where
#include "HsVersions.h"
import NewDemand
import Var ( TyVar )
import Name ( Name, mkWiredInName )
-import RdrName ( RdrName, mkRdrOrig )
import OccName ( OccName, pprOccName, mkVarOcc )
import TyCon ( TyCon, isPrimTyCon, tyConPrimRep )
import Type ( Type, mkForAllTys, mkFunTy, mkFunTys, typePrimRep, tyConAppTyCon )
import PprType () -- get at Outputable Type instance.
import Unique ( mkPrimOpIdUnique )
import BasicTypes ( Arity, Boxity(..) )
-import PrelNames ( gHC_PRIM, gHC_PRIM_Name )
+import PrelNames ( gHC_PRIM )
import Outputable
import FastTypes
\end{code}
mkPrimOpIdName op
= mkWiredInName gHC_PRIM (primOpOcc op) (mkPrimOpIdUnique (primOpTag op))
-primOpRdrName :: PrimOp -> RdrName
-primOpRdrName op = mkRdrOrig gHC_PRIM_Name (primOpOcc op)
-
primOpOcc :: PrimOp -> OccName
primOpOcc op = case (primOpInfo op) of
Dyadic occ _ -> occ
pprPrimOp other_op = pprOccName (primOpOcc other_op)
\end{code}
-Names for some primops (for ndpFlatten/FlattenMonad.lhs)
+
+%************************************************************************
+%* *
+ Names for some primops (for ndpFlatten/FlattenMonad.lhs)
+%* *
+%************************************************************************
\begin{code}
-eqCharName = mkPrimOpIdName CharEqOp
-eqIntName = mkPrimOpIdName IntEqOp
-eqFloatName = mkPrimOpIdName FloatEqOp
-eqDoubleName = mkPrimOpIdName DoubleEqOp
-neqIntName = mkPrimOpIdName IntNeOp
+eqIntName = mkPrimOpIdName IntEqOp
+ltIntName = mkPrimOpIdName IntLtOp
+geIntName = mkPrimOpIdName IntGeOp
+leIntName = mkPrimOpIdName IntLeOp
+neqIntName = mkPrimOpIdName IntNeOp
+minusIntName = mkPrimOpIdName IntSubOp
+
+eqCharName = mkPrimOpIdName CharEqOp
+ltCharName = mkPrimOpIdName CharLtOp
+
+eqFloatName = mkPrimOpIdName FloatEqOp
+ltFloatName = mkPrimOpIdName FloatLtOp
+
+eqDoubleName = mkPrimOpIdName DoubleEqOp
+ltDoubleName = mkPrimOpIdName DoubleLtOp
+
+eqWordName = mkPrimOpIdName WordEqOp
+ltWordName = mkPrimOpIdName WordLtOp
+
+eqAddrName = mkPrimOpIdName AddrEqOp
+ltAddrName = mkPrimOpIdName AddrLtOp
+
+tagToEnumName = mkPrimOpIdName TagToEnumOp
\end{code}
-- tuples
mkTupleTy,
tupleTyCon, tupleCon,
- unitTyCon, unitDataConId, pairTyCon,
+ unitTyCon, unitDataCon, unitDataConId, pairTyCon,
unboxedSingletonTyCon, unboxedSingletonDataCon,
unboxedPairTyCon, unboxedPairDataCon,
-- others:
import Constants ( mAX_TUPLE_SIZE )
import Module ( mkPrelModule )
-import Name ( Name, nameRdrName, nameUnique, nameOccName,
+import Name ( Name, nameUnique, nameOccName,
nameModule, mkWiredInName )
import OccName ( mkOccFS, tcName, dataName, mkWorkerOcc, mkGenOcc1, mkGenOcc2 )
-import RdrName ( rdrNameOcc )
import DataCon ( DataCon, mkDataCon, dataConWorkId, dataConSourceArity )
import Var ( TyVar, tyVarKind )
import TyCon ( TyCon, AlgTyConFlavour(..), DataConDetails(..), tyConDataCons,
%* *
%************************************************************************
+If you change which things are wired in, make sure you change their
+names in PrelNames, so they use wTcQual, wDataQual, etc
+
\begin{code}
wiredInTyCons :: [TyCon]
wiredInTyCons = data_tycons ++ tuple_tycons ++ unboxed_tuple_tycons
genericTyCons :: [TyCon]
genericTyCons = [ plusTyCon, crossTyCon, genUnitTyCon ]
-
tuple_tycons = unitTyCon : [tupleTyCon Boxed i | i <- [2..mAX_TUPLE_SIZE] ]
unboxed_tuple_tycons = [tupleTyCon Unboxed i | i <- [1..mAX_TUPLE_SIZE] ]
\end{code}
[ {- no labelled fields -} ]
tyvars context [] [] arg_tys tycon work_id wrap_id
- wrap_rdr = nameRdrName name
- wrap_occ = rdrNameOcc wrap_rdr
+ wrap_occ = nameOccName name
mod = nameModule name
wrap_id = mkDataConWrapId data_con
gen_info = mk_tc_gen_info mod tc_uniq tc_name tycon
unitTyCon = tupleTyCon Boxed 0
-unitDataConId = dataConWorkId (head (tyConDataCons unitTyCon))
+unitDataCon = head (tyConDataCons unitTyCon)
+unitDataConId = dataConWorkId unitDataCon
pairTyCon = tupleTyCon Boxed 2
+++ /dev/null
-%
-% (c) The GRASP Project, Glasgow University, 1992-1998
-%
-\section[Rename]{Renaming and dependency analysis passes}
-
-\begin{code}
-module Rename
- ( renameModule
- , RnResult(..)
- , renameStmt
- , renameRdrName
- , renameExtCore
- , mkGlobalContext
- , closeIfaceDecls
- , checkOldIface
- , slurpIface
- ) where
-
-#include "HsVersions.h"
-
-import HsSyn
-import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameDeprecation,
- RdrNameTyClDecl, RdrNameRuleDecl, RdrNameInstDecl, RdrNameImportDecl,
- RdrNameStmt
- )
-import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, RenamedRuleDecl, RenamedInstDecl,
- RenamedStmt,
- instDeclFVs, tyClDeclFVs, ruleDeclFVs
- )
-
-import CmdLineOpts ( DynFlags, DynFlag(..), opt_InPackage )
-import RnMonad
-import RnExpr ( rnStmt )
-import RnNames ( getGlobalNames, exportsFromAvail )
-import RnSource ( rnSourceDecls, rnTyClDecl, rnIfaceRuleDecl, rnInstDecl )
-import RnIfaces ( slurpImpDecls, mkImportInfo, recordLocalSlurps,
- closeDecls,
- RecompileRequired, outOfDate, recompileRequired
- )
-import RnHiFiles ( readIface, loadInterface,
- loadExports, loadFixDecls, loadDeprecs,
- )
-import RnEnv ( availsToNameSet,
- unitAvailEnv, availEnvElts, availNames,
- plusAvailEnv, groupAvails, warnUnusedImports,
- warnUnusedLocalBinds, warnUnusedModules,
- lookupSrcName, getImplicitStmtFVs, mkTopFixityEnv,
- getImplicitModuleFVs, newGlobalName, unQualInScope,
- ubiquitousNames, lookupOccRn, checkMain,
- plusGlobalRdrEnv, mkGlobalRdrEnv
- )
-import Module ( Module, ModuleName, WhereFrom(..),
- moduleNameUserString, moduleName,
- moduleEnvElts
- )
-import Name ( Name, nameModule, isExternalName )
-import NameEnv
-import NameSet
-import RdrName ( foldRdrEnv, isQual, emptyRdrEnv )
-import PrelNames ( iNTERACTIVE, pRELUDE_Name )
-import ErrUtils ( dumpIfSet, dumpIfSet_dyn, showPass,
- printErrorsAndWarnings, errorsFound )
-import Bag ( bagToList )
-import FiniteMap ( FiniteMap, fmToList, emptyFM, lookupFM,
- addToFM_C, elemFM, addToFM
- )
-import Maybes ( maybeToBool, catMaybes )
-import Outputable
-import IO ( openFile, IOMode(..) )
-import HscTypes -- lots of it
-import List ( partition, nub )
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{The main wrappers}
-%* *
-%*********************************************************
-
-\begin{code}
-renameModule :: DynFlags -> GhciMode
- -> HomeIfaceTable -> HomeSymbolTable
- -> PersistentCompilerState
- -> Module -> RdrNameHsModule
- -> IO (PersistentCompilerState, PrintUnqualified,
- Maybe (IsExported, ModIface, RnResult))
- -- Nothing => some error occurred in the renamer
-
-renameModule dflags ghci_mode hit hst pcs this_module rdr_module
- = renameSource dflags hit hst pcs this_module $
- rename ghci_mode this_module rdr_module
-\end{code}
-
-\begin{code}
-renameStmt :: DynFlags
- -> HomeIfaceTable -> HomeSymbolTable
- -> PersistentCompilerState
- -> InteractiveContext
- -> RdrNameStmt -- parsed stmt
- -> IO ( PersistentCompilerState,
- PrintUnqualified,
- Maybe ([Name], (RenamedStmt, [RenamedHsDecl]))
- )
-
-renameStmt dflags hit hst pcs ic stmt
- = renameSource dflags hit hst pcs iNTERACTIVE $
-
- -- load the context module
- let InteractiveContext{ ic_rn_gbl_env = rdr_env,
- ic_print_unqual = print_unqual,
- ic_rn_local_env = local_rdr_env,
- ic_type_env = type_env } = ic
- in
-
- extendTypeEnvRn type_env $
-
- -- Rename the stmt
- initRnMS rdr_env emptyAvailEnv local_rdr_env emptyLocalFixityEnv CmdLineMode (
- rnStmt stmt $ \ stmt' ->
- returnRn (([], stmt'), emptyFVs)
- ) `thenRn` \ ((binders, stmt), fvs) ->
-
- -- Bale out if we fail
- checkErrsRn `thenRn` \ no_errs_so_far ->
- if not no_errs_so_far then
- doDump dflags [] stmt [] `thenRn_` returnRn (print_unqual, Nothing)
- else
-
- -- Add implicit free vars, and close decls
- getImplicitStmtFVs `thenRn` \ implicit_fvs ->
- slurpImpDecls (fvs `plusFV` implicit_fvs) `thenRn` \ decls ->
- -- NB: an earlier version deleted (rdrEnvElts local_env) from
- -- the fvs. But (a) that isn't necessary, because previously
- -- bound things in the local_env will be in the TypeEnv, and
- -- the renamer doesn't re-slurp such things, and
- -- (b) it's WRONG to delete them. Consider in GHCi:
- -- Mod> let x = e :: T
- -- Mod> let y = x + 3
- -- We need to pass 'x' among the fvs to slurpImpDecls, so that
- -- the latter can see that T is a gate, and hence import the Num T
- -- instance decl. (See the InTypEnv case in RnIfaces.slurpSourceRefs.)
-
- doDump dflags binders stmt decls `thenRn_`
- returnRn (print_unqual, Just (binders, (stmt, decls)))
-
- where
- doDump :: DynFlags -> [Name] -> RenamedStmt -> [RenamedHsDecl]
- -> RnMG (Either IOError ())
- doDump dflags bndrs stmt decls
- = ioToRnM (dumpIfSet_dyn dflags Opt_D_dump_rn "Renamer:"
- (vcat [text "Binders:" <+> ppr bndrs,
- ppr stmt, text "",
- vcat (map ppr decls)]))
-
-
-renameRdrName
- :: DynFlags
- -> HomeIfaceTable -> HomeSymbolTable
- -> PersistentCompilerState
- -> InteractiveContext
- -> [RdrName] -- name to rename
- -> IO ( PersistentCompilerState,
- PrintUnqualified,
- Maybe ([Name], [RenamedHsDecl])
- )
-
-renameRdrName dflags hit hst pcs ic rdr_names =
- renameSource dflags hit hst pcs iNTERACTIVE $
-
- -- load the context module
- let InteractiveContext{ ic_rn_gbl_env = rdr_env,
- ic_print_unqual = print_unqual,
- ic_rn_local_env = local_rdr_env,
- ic_type_env = type_env } = ic
- in
-
- extendTypeEnvRn type_env $
-
- -- rename the rdr_name
- initRnMS rdr_env emptyAvailEnv local_rdr_env emptyLocalFixityEnv CmdLineMode
- (mapRn (tryRn.lookupOccRn) rdr_names) `thenRn` \ maybe_names ->
- let
- ok_names = [ a | Right a <- maybe_names ]
- in
- if null ok_names
- then let errs = head [ e | Left e <- maybe_names ]
- in setErrsRn errs `thenRn_`
- doDump dflags ok_names [] `thenRn_`
- returnRn (print_unqual, Nothing)
- else
-
- slurpImpDecls (mkNameSet ok_names) `thenRn` \ decls ->
-
- doDump dflags ok_names decls `thenRn_`
- returnRn (print_unqual, Just (ok_names, decls))
- where
- doDump :: DynFlags -> [Name] -> [RenamedHsDecl] -> RnMG (Either IOError ())
- doDump dflags names decls
- = ioToRnM (dumpIfSet_dyn dflags Opt_D_dump_rn "Renamer:"
- (vcat [ppr names, text "",
- vcat (map ppr decls)]))
-\end{code}
-
-\begin{code}
-renameExtCore :: DynFlags
- -> HomeIfaceTable -> HomeSymbolTable
- -> PersistentCompilerState
- -> Module
- -> RdrNameHsModule
- -> IO (PersistentCompilerState, PrintUnqualified,
- Maybe (IsExported, ModIface, [RenamedHsDecl]))
-
- -- Nothing => some error occurred in the renamer
-renameExtCore dflags hit hst pcs this_module
- rdr_module@(HsModule _ _ _ _ local_decls _ loc)
- -- Rename the (Core) module
- = renameSource dflags hit hst pcs this_module $
- pushSrcLocRn loc $
-
- -- Rename the source
- initIfaceRnMS this_module (rnExtCoreDecls local_decls) `thenRn` \ (rn_local_decls, binders, fvs) ->
- recordLocalSlurps binders `thenRn_`
- closeDecls rn_local_decls fvs `thenRn` \ final_decls ->
-
- -- Bail out if we fail (but dump debug output anyway for debugging)
- rnDump final_decls `thenRn_`
- checkErrsRn `thenRn` \ no_errs_so_far ->
- if not no_errs_so_far then
- returnRn (print_unqualified, Nothing)
- else
- let
- mod_iface = ModIface { mi_module = this_module,
- mi_package = opt_InPackage,
- mi_version = initialVersionInfo,
- mi_usages = [],
- mi_boot = False,
- mi_orphan = panic "is_orphan",
- -- ToDo: export the data types also.
- mi_exports = [(moduleName this_module,
- map Avail (nameSetToList binders))],
- mi_globals = Nothing,
- mi_fixities = mkNameEnv [],
- mi_deprecs = NoDeprecs,
- mi_decls = panic "mi_decls"
- }
-
- is_exported _ = True
- in
- returnRn (print_unqualified, Just (is_exported, mod_iface, final_decls))
-
- where
- print_unqualified = const False -- print everything qualified.
-
-
-rnExtCoreDecls :: [RdrNameHsDecl]
- -> RnMS ([RenamedHsDecl],
- NameSet, -- Binders
- FreeVars) -- Free variables
-
-rnExtCoreDecls decls
- -- Renaming external-core decls is rather like renaming an interface file
- -- All the decls are TyClDecls, and all the names are original names
- = go [] emptyNameSet emptyNameSet decls
- where
- go rn_decls bndrs fvs [] = returnRn (rn_decls, bndrs, fvs)
-
- go rn_decls bndrs fvs (TyClD decl : decls)
- = rnTyClDecl decl `thenRn` \ rn_decl ->
- go (TyClD rn_decl : rn_decls)
- (addListToNameSet bndrs (map fst (tyClDeclSysNames rn_decl ++ tyClDeclNames rn_decl)))
- (fvs `plusFV` tyClDeclFVs rn_decl)
- decls
-
- go rn_decls bndrs fvs (decl : decls)
- = addErrRn (text "Unexpected decl in ExtCore file" $$ ppr decl) `thenRn_`
- go rn_decls bndrs fvs decls
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{Make up an interactive context}
-%* *
-%*********************************************************
-
-\begin{code}
-mkGlobalContext
- :: DynFlags -> HomeIfaceTable -> HomeSymbolTable
- -> PersistentCompilerState
- -> [Module] -> [Module]
- -> IO (PersistentCompilerState, PrintUnqualified, Maybe GlobalRdrEnv)
-mkGlobalContext dflags hit hst pcs toplevs exports
- = renameSource dflags hit hst pcs iNTERACTIVE $
-
- mapRn getTopLevScope toplevs `thenRn` \ toplev_envs ->
- mapRn getModuleExports exports `thenRn` \ export_envs ->
- let full_env = foldr plusGlobalRdrEnv emptyRdrEnv
- (toplev_envs ++ export_envs)
- print_unqual = unQualInScope full_env
- in
- checkErrsRn `thenRn` \ no_errs_so_far ->
- if not no_errs_so_far then
- returnRn (print_unqual, Nothing)
- else
- returnRn (print_unqual, Just full_env)
-
-contextDoc = text "context for compiling statements"
-
-getTopLevScope :: Module -> RnM d GlobalRdrEnv
-getTopLevScope mod =
- loadInterface contextDoc (moduleName mod) ImportByUser `thenRn` \ iface ->
- case mi_globals iface of
- Nothing -> panic "getTopLevScope"
- Just env -> returnRn env
-
-getModuleExports :: Module -> RnM d GlobalRdrEnv
-getModuleExports mod =
- loadInterface contextDoc (moduleName mod) ImportByUser `thenRn` \ iface ->
- returnRn (foldl add emptyRdrEnv (mi_exports iface))
- where
- prov_fn n = NonLocalDef ImplicitImport
- add env (mod,avails) =
- plusGlobalRdrEnv env (mkGlobalRdrEnv mod True prov_fn avails NoDeprecs)
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{Slurp in a whole module eagerly}
-%* *
-%*********************************************************
-
-\begin{code}
-slurpIface
- :: DynFlags -> HomeIfaceTable -> HomeSymbolTable
- -> PersistentCompilerState -> Module
- -> IO (PersistentCompilerState, PrintUnqualified,
- Maybe ([Name], [RenamedHsDecl]))
-slurpIface dflags hit hst pcs mod =
- renameSource dflags hit hst pcs iNTERACTIVE $
-
- let mod_name = moduleName mod
- in
- loadInterface contextDoc mod_name ImportByUser `thenRn` \ iface ->
- let fvs = availsToNameSet [ avail | (mn,avails) <- mi_exports iface,
- avail <- avails ]
- in
- slurpImpDecls fvs `thenRn` \ rn_imp_decls ->
- returnRn (alwaysQualify, Just (nameSetToList fvs, rn_imp_decls))
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{The main function: rename}
-%* *
-%*********************************************************
-
-\begin{code}
-renameSource :: DynFlags
- -> HomeIfaceTable -> HomeSymbolTable
- -> PersistentCompilerState
- -> Module
- -> RnMG (PrintUnqualified, Maybe r)
- -> IO (PersistentCompilerState, PrintUnqualified, Maybe r)
- -- Nothing => some error occurred in the renamer
-
-renameSource dflags hit hst old_pcs this_module thing_inside
- = do { showPass dflags "Renamer"
-
- -- Initialise the renamer monad
- ; (new_pcs, msgs, (print_unqual, maybe_rn_stuff))
- <- initRn dflags hit hst old_pcs this_module thing_inside
-
- -- Print errors from renaming
- ; printErrorsAndWarnings print_unqual msgs ;
-
- -- Return results. No harm in updating the PCS
- ; if errorsFound msgs then
- return (new_pcs, print_unqual, Nothing)
- else
- return (new_pcs, print_unqual, maybe_rn_stuff)
- }
-\end{code}
-
-\begin{code}
-data RnResult -- A RenamedModule ia passed from renamer to typechecker
- = RnResult { rr_mod :: Module, -- Same as in the ModIface,
- rr_fixities :: FixityEnv, -- but convenient to have it here
-
- rr_main :: Maybe Name, -- Just main, for module Main,
- -- Nothing for other modules
-
- rr_decls :: [RenamedHsDecl]
- -- The other declarations of the module
- -- Fixity and deprecations have already been slurped out
- } -- and are now in the ModIface for the module
-
-rename :: GhciMode -> Module -> RdrNameHsModule
- -> RnMG (PrintUnqualified, Maybe (IsExported, ModIface, RnResult))
-rename ghci_mode this_module
- contents@(HsModule _ _ exports imports local_decls mod_deprec loc)
- = pushSrcLocRn loc $
-
- -- FIND THE GLOBAL NAME ENVIRONMENT
- getGlobalNames this_module contents `thenRn` \ (gbl_env, local_gbl_env,
- (mod_avail_env, global_avail_env)) ->
- let
- print_unqualified = unQualInScope gbl_env
-
- full_avail_env :: NameEnv AvailInfo
- -- The domain of global_avail_env is just the 'major' things;
- -- variables, type constructors, classes.
- -- E.g. Functor |-> Functor( Functor, fmap )
- -- The domain of full_avail_env is everything in scope
- -- E.g. Functor |-> Functor( Functor, fmap )
- -- fmap |-> Functor( Functor, fmap )
- --
- -- This filled-out avail_env is needed to generate
- -- exports (mkExportAvails), and for generating minimal
- -- exports (reportUnusedNames)
- full_avail_env = mkNameEnv [ (name,avail)
- | avail <- availEnvElts global_avail_env,
- name <- availNames avail]
- in
- -- Exit if we've found any errors
- checkErrsRn `thenRn` \ no_errs_so_far ->
- if not no_errs_so_far then
- -- Found errors already, so exit now
- returnRn (print_unqualified, Nothing)
- else
-
- -- PROCESS EXPORT LIST
- exportsFromAvail mod_name exports mod_avail_env
- full_avail_env gbl_env `thenRn` \ export_avails ->
-
- traceRn (text "Local top-level environment" $$
- nest 4 (pprGlobalRdrEnv local_gbl_env)) `thenRn_`
-
- -- DEAL WITH DEPRECATIONS
- rnDeprecs local_gbl_env mod_deprec
- [d | DeprecD d <- local_decls] `thenRn` \ my_deprecs ->
-
- -- DEAL WITH LOCAL FIXITIES
- fixitiesFromLocalDecls local_gbl_env local_decls `thenRn` \ local_fixity_env ->
-
- -- RENAME THE SOURCE
- rnSourceDecls gbl_env global_avail_env
- local_fixity_env SourceMode local_decls `thenRn` \ (rn_local_decls, source_fvs) ->
-
- -- GET ANY IMPLICIT FREE VARIALBES
- getImplicitModuleFVs rn_local_decls `thenRn` \ implicit_fvs ->
- checkMain ghci_mode mod_name gbl_env `thenRn` \ (maybe_main_name, main_fvs, implicit_main_fvs) ->
- let
- export_fvs = availsToNameSet export_avails
- used_fvs = source_fvs `plusFV` export_fvs `plusFV` main_fvs
- -- The export_fvs make the exported names look just as if they
- -- occurred in the source program. For the reasoning, see the
- -- comments with RnIfaces.mkImportInfo
- -- It also helps reportUnusedNames, which of course must not complain
- -- that 'f' isn't mentioned if it is mentioned in the export list
-
- needed_fvs = implicit_fvs `plusFV` implicit_main_fvs `plusFV` used_fvs
- -- It's important to do the "plus" this way round, so that
- -- when compiling the prelude, locally-defined (), Bool, etc
- -- override the implicit ones.
-
- in
- traceRn (text "Needed FVs:" <+> fsep (map ppr (nameSetToList needed_fvs))) `thenRn_`
-
- -- EXIT IF ERRORS FOUND
- -- We exit here if there are any errors in the source, *before*
- -- we attempt to slurp the decls from the interfaces, otherwise
- -- the slurped decls may get lost when we return up the stack
- -- to hscMain/hscExpr.
- checkErrsRn `thenRn` \ no_errs_so_far ->
- if not no_errs_so_far then
- -- Found errors already, so exit now
- rnDump rn_local_decls `thenRn_`
- returnRn (print_unqualified, Nothing)
- else
-
- -- SLURP IN ALL THE NEEDED DECLARATIONS
- slurpImpDecls needed_fvs `thenRn` \ rn_imp_decls ->
-
- -- GENERATE THE VERSION/USAGE INFO
- mkImportInfo mod_name imports `thenRn` \ my_usages ->
-
- -- BUILD THE MODULE INTERFACE
- let
- -- We record fixities even for things that aren't exported,
- -- so that we can change into the context of this moodule easily
- fixities = mkNameEnv [ (name, fixity)
- | FixitySig name fixity loc <- nameEnvElts local_fixity_env
- ]
-
- -- Sort the exports to make them easier to compare for versions
- my_exports = groupAvails this_module export_avails
-
- final_decls = rn_local_decls ++ rn_imp_decls
-
- -- In interactive mode, we don't want to discard any top-level
- -- entities at all (eg. do not inline them away during
- -- simplification), and retain them all in the TypeEnv so they are
- -- available from the command line.
- --
- -- isExternalName separates the user-defined top-level names from those
- -- introduced by the type checker.
- dont_discard :: Name -> Bool
- dont_discard | ghci_mode == Interactive = isExternalName
- | otherwise = (`elemNameSet` export_fvs)
-
- mod_iface = ModIface { mi_module = this_module,
- mi_package = opt_InPackage,
- mi_version = initialVersionInfo,
- mi_usages = my_usages,
- mi_boot = False,
- mi_orphan = panic "is_orphan",
- mi_exports = my_exports,
- mi_globals = Just gbl_env,
- mi_fixities = fixities,
- mi_deprecs = my_deprecs,
- mi_decls = panic "mi_decls"
- }
-
- rn_result = RnResult { rr_mod = this_module,
- rr_fixities = fixities,
- rr_decls = final_decls,
- rr_main = maybe_main_name }
- in
-
- rnDump final_decls `thenRn_`
- rnStats rn_imp_decls `thenRn_`
-
- -- REPORT UNUSED NAMES, AND DEBUG DUMP
- reportUnusedNames mod_iface print_unqualified
- imports full_avail_env gbl_env
- used_fvs rn_imp_decls `thenRn_`
- -- NB: used_fvs: include exports (else we get bogus
- -- warnings of unused things) but not implicit FVs.
-
- returnRn (print_unqualified, Just (dont_discard, mod_iface, rn_result))
- where
- mod_name = moduleName this_module
-\end{code}
-
-
-
-%*********************************************************
-%* *
-\subsection{Fixities}
-%* *
-%*********************************************************
-
-\begin{code}
-fixitiesFromLocalDecls :: GlobalRdrEnv -> [RdrNameHsDecl] -> RnMG LocalFixityEnv
-fixitiesFromLocalDecls gbl_env decls
- = mkTopFixityEnv gbl_env (foldr get_fix_sigs [] decls) `thenRn` \ env ->
- traceRn (text "fixity env" <+> vcat (map ppr (nameEnvElts env))) `thenRn_`
- returnRn env
- where
- get_fix_sigs (FixD fix) acc = fix:acc
- get_fix_sigs (TyClD (ClassDecl { tcdSigs = sigs})) acc
- = [sig | FixSig sig <- sigs] ++ acc -- Get fixities from class decl sigs too.
- get_fix_sigs other_decl acc = acc
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{Deprecations}
-%* *
-%*********************************************************
-
-For deprecations, all we do is check that the names are in scope.
-It's only imported deprecations, dealt with in RnIfaces, that we
-gather them together.
-
-\begin{code}
-rnDeprecs :: GlobalRdrEnv -> Maybe DeprecTxt
- -> [RdrNameDeprecation] -> RnMG Deprecations
-rnDeprecs gbl_env Nothing []
- = returnRn NoDeprecs
-
-rnDeprecs gbl_env (Just txt) decls
- = mapRn (addErrRn . badDeprec) decls `thenRn_`
- returnRn (DeprecAll txt)
-
-rnDeprecs gbl_env Nothing decls
- = mapRn rn_deprec decls `thenRn` \ pairs ->
- returnRn (DeprecSome (mkNameEnv (catMaybes pairs)))
- where
- rn_deprec (Deprecation rdr_name txt loc)
- = pushSrcLocRn loc $
- lookupSrcName gbl_env rdr_name `thenRn` \ name ->
- returnRn (Just (name, (name,txt)))
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Grabbing the old interface file and checking versions}
-%* *
-%************************************************************************
-
-\begin{code}
-checkOldIface :: GhciMode
- -> DynFlags
- -> HomeIfaceTable -> HomeSymbolTable
- -> PersistentCompilerState
- -> Module
- -> FilePath
- -> Bool -- Source unchanged
- -> Maybe ModIface -- Old interface from compilation manager, if any
- -> IO (PersistentCompilerState, Bool, (RecompileRequired, Maybe ModIface))
- -- True <=> errors happened
-
-checkOldIface ghci_mode dflags hit hst pcs mod iface_path source_unchanged maybe_iface
- = runRn dflags hit hst pcs (panic "Bogus module") $
-
- -- CHECK WHETHER THE SOURCE HAS CHANGED
- ( if not source_unchanged then
- traceHiDiffsRn (nest 4 (text "Source file changed or recompilation check turned off"))
- else returnRn () ) `thenRn_`
-
- -- If the source has changed and we're in interactive mode, avoid reading
- -- an interface; just return the one we might have been supplied with.
- if ghci_mode == Interactive && not source_unchanged then
- returnRn (outOfDate, maybe_iface)
- else
-
- setModuleRn mod $
- case maybe_iface of
- Just old_iface -> -- Use the one we already have
- check_versions old_iface
-
- Nothing -- try and read it from a file
- -> readIface iface_path `thenRn` \ read_result ->
- case read_result of
- Left err -> -- Old interface file not found, or garbled; give up
- traceHiDiffsRn (
- text "Cannot read old interface file:"
- $$ nest 4 err) `thenRn_`
- returnRn (outOfDate, Nothing)
-
- Right parsed_iface ->
- let read_mod_name = pi_mod parsed_iface
- wanted_mod_name = moduleName mod
- in
- if (wanted_mod_name /= read_mod_name) then
- traceHiDiffsRn (
- text "Existing interface file has wrong module name: "
- <> quotes (ppr read_mod_name)
- ) `thenRn_`
- returnRn (outOfDate, Nothing)
- else
- loadOldIface mod parsed_iface `thenRn` \ m_iface ->
- check_versions m_iface
- where
- check_versions :: ModIface -> RnMG (RecompileRequired, Maybe ModIface)
- check_versions iface
- | not source_unchanged
- = returnRn (outOfDate, Just iface)
- | otherwise
- = -- Check versions
- recompileRequired iface_path iface `thenRn` \ recompile ->
- returnRn (recompile, Just iface)
-\end{code}
-
-I think the following function should now have a more representative name,
-but what?
-
-\begin{code}
-loadOldIface :: Module -> ParsedIface -> RnMG ModIface
-
-loadOldIface mod parsed_iface
- = let iface = parsed_iface
- in
- initIfaceRnMS mod (
- loadHomeDecls (pi_decls iface) `thenRn` \ decls ->
- loadHomeRules (pi_rules iface) `thenRn` \ rules ->
- loadHomeInsts (pi_insts iface) `thenRn` \ insts ->
- returnRn (decls, rules, insts)
- )
- `thenRn` \ ((decls_vers, new_decls), (rule_vers, new_rules), new_insts) ->
-
- mapRn loadHomeUsage (pi_usages iface) `thenRn` \ usages ->
- loadExports (pi_exports iface) `thenRn` \ (export_vers, avails) ->
- loadFixDecls mod (pi_fixity iface) `thenRn` \ fix_env ->
- loadDeprecs mod (pi_deprecs iface) `thenRn` \ deprec_env ->
- let
- version = VersionInfo { vers_module = pi_vers iface,
- vers_exports = export_vers,
- vers_rules = rule_vers,
- vers_decls = decls_vers }
-
- decls = mkIfaceDecls new_decls new_rules new_insts
-
- mod_iface = ModIface { mi_module = mod, mi_package = pi_pkg parsed_iface,
- mi_version = version,
- mi_exports = avails, mi_usages = usages,
- mi_boot = False, mi_orphan = pi_orphan iface,
- mi_fixities = fix_env, mi_deprecs = deprec_env,
- mi_decls = decls,
- mi_globals = Nothing
- }
- in
- returnRn mod_iface
-\end{code}
-
-\begin{code}
-loadHomeDecls :: [(Version, RdrNameTyClDecl)]
- -> RnMS (NameEnv Version, [RenamedTyClDecl])
-loadHomeDecls decls = foldlRn loadHomeDecl (emptyNameEnv, []) decls
-
-loadHomeDecl :: (NameEnv Version, [RenamedTyClDecl])
- -> (Version, RdrNameTyClDecl)
- -> RnMS (NameEnv Version, [RenamedTyClDecl])
-loadHomeDecl (version_map, decls) (version, decl)
- = rnTyClDecl decl `thenRn` \ decl' ->
- returnRn (extendNameEnv version_map (tyClDeclName decl') version, decl':decls)
-
-------------------
-loadHomeRules :: (Version, [RdrNameRuleDecl])
- -> RnMS (Version, [RenamedRuleDecl])
-loadHomeRules (version, rules)
- = mapRn rnIfaceRuleDecl rules `thenRn` \ rules' ->
- returnRn (version, rules')
-
-------------------
-loadHomeInsts :: [RdrNameInstDecl]
- -> RnMS [RenamedInstDecl]
-loadHomeInsts insts = mapRn rnInstDecl insts
-
-------------------
-loadHomeUsage :: ImportVersion OccName
- -> RnMG (ImportVersion Name)
-loadHomeUsage (mod_name, orphans, is_boot, whats_imported)
- = rn_imps whats_imported `thenRn` \ whats_imported' ->
- returnRn (mod_name, orphans, is_boot, whats_imported')
- where
- rn_imps NothingAtAll = returnRn NothingAtAll
- rn_imps (Everything v) = returnRn (Everything v)
- rn_imps (Specifically mv ev items rv) = mapRn rn_imp items `thenRn` \ items' ->
- returnRn (Specifically mv ev items' rv)
- rn_imp (occ,vers) = newGlobalName mod_name occ `thenRn` \ name ->
- returnRn (name,vers)
-\end{code}
-
-
-
-%*********************************************************
-%* *
-\subsection{Closing up the interface decls}
-%* *
-%*********************************************************
-
-Suppose we discover we don't need to recompile. Then we start from the
-IfaceDecls in the ModIface, and fluff them up by sucking in all the decls they need.
-
-\begin{code}
-closeIfaceDecls :: DynFlags
- -> HomeIfaceTable -> HomeSymbolTable
- -> PersistentCompilerState
- -> ModIface -- Get the decls from here
- -> IO (PersistentCompilerState, Bool, [RenamedHsDecl])
- -- True <=> errors happened
-closeIfaceDecls dflags hit hst pcs
- mod_iface@(ModIface { mi_module = mod, mi_decls = iface_decls })
- = runRn dflags hit hst pcs mod $
-
- let
- rule_decls = dcl_rules iface_decls
- inst_decls = dcl_insts iface_decls
- tycl_decls = dcl_tycl iface_decls
- decls = map RuleD rule_decls ++
- map InstD inst_decls ++
- map TyClD tycl_decls
- needed = unionManyNameSets (map ruleDeclFVs rule_decls) `unionNameSets`
- unionManyNameSets (map instDeclFVs inst_decls) `unionNameSets`
- unionManyNameSets (map tyClDeclFVs tycl_decls) `unionNameSets`
- ubiquitousNames
- -- Data type decls with record selectors,
- -- which may appear in the decls, need unpackCString
- -- and friends. It's easier to just grab them right now.
-
- local_names = foldl add emptyNameSet tycl_decls
- add names decl = addListToNameSet names (map fst (tyClDeclSysNames decl ++ tyClDeclNames decl))
- in
- recordLocalSlurps local_names `thenRn_`
-
- -- Do the transitive closure
- closeDecls decls needed `thenRn` \closed_decls ->
- rnDump closed_decls `thenRn_`
- returnRn closed_decls
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{Unused names}
-%* *
-%*********************************************************
-
-\begin{code}
-reportUnusedNames :: ModIface -> PrintUnqualified
- -> [RdrNameImportDecl]
- -> AvailEnv
- -> GlobalRdrEnv
- -> NameSet -- Used in this module
- -> [RenamedHsDecl]
- -> RnMG ()
-reportUnusedNames my_mod_iface unqual imports avail_env gbl_env
- used_names imported_decls
- = warnUnusedModules unused_imp_mods `thenRn_`
- warnUnusedLocalBinds bad_locals `thenRn_`
- warnUnusedImports bad_imp_names `thenRn_`
- printMinimalImports this_mod unqual minimal_imports
- where
- this_mod = mi_module my_mod_iface
-
- -- 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 [ parent_name
- | sub_name <- nameSetToList used_names
-
- -- Usually, every used name will appear in avail_env, but there
- -- is one time when it doesn't: tuples and other built in syntax. When you
- -- write (a,b) that gives rise to a *use* of "(,)", so that the
- -- instances will get pulled in, but the tycon "(,)" isn't actually
- -- in scope. Also, (-x) gives rise to an implicit use of 'negate';
- -- similarly, 3.5 gives rise to an implcit use of :%
- -- Hence the silent 'False' in all other cases
-
- , Just parent_name <- [case lookupNameEnv avail_env sub_name of
- Just (AvailTC n _) -> Just n
- other -> Nothing]
- ]
-
- -- Collect the defined names from the in-scope environment
- -- Look for the qualified ones only, else get duplicates
- defined_names :: [GlobalRdrElt]
- defined_names = foldRdrEnv add [] gbl_env
- add rdr_name ns acc | isQual rdr_name = ns ++ acc
- | otherwise = acc
-
- defined_and_used, defined_but_not_used :: [GlobalRdrElt]
- (defined_and_used, defined_but_not_used) = partition used defined_names
- used (GRE name _ _) = name `elemNameSet` really_used_names
-
- -- Filter out the ones only defined implicitly
- bad_locals :: [Name]
- bad_locals = [n | (GRE n LocalDef _) <- defined_but_not_used]
-
- bad_imp_names :: [(Name,Provenance)]
- bad_imp_names = [(n,p) | GRE n p@(NonLocalDef (UserImport mod _ True)) _ <- defined_but_not_used,
- not (module_unused mod)]
-
- -- inst_mods are directly-imported modules that
- -- contain instance decl(s) that the renamer decided to suck in
- -- It's not necessarily redundant to import such modules.
- --
- -- NOTE: Consider
- -- module This
- -- import M ()
- --
- -- The import M() is not *necessarily* redundant, even if
- -- we suck in no instance decls from M (e.g. it contains
- -- no instance decls, or This contains no code). It may be
- -- that we import M solely to ensure that M's orphan instance
- -- decls (or those in its imports) are visible to people who
- -- import This. Sigh.
- -- There's really no good way to detect this, so the error message
- -- in RnEnv.warnUnusedModules is weakened instead
- inst_mods :: [ModuleName]
- inst_mods = [m | InstD (InstDecl _ _ _ (Just dfun) _) <- imported_decls,
- let m = moduleName (nameModule dfun),
- m `elem` direct_import_mods
- ]
-
- -- To figure out the minimal set of imports, start with the things
- -- that are in scope (i.e. in gbl_env). Then just combine them
- -- into a bunch of avails, so they are properly grouped
- minimal_imports :: FiniteMap ModuleName AvailEnv
- minimal_imports0 = emptyFM
- minimal_imports1 = foldr add_name minimal_imports0 defined_and_used
- minimal_imports = foldr add_inst_mod minimal_imports1 inst_mods
-
- -- We've carefully preserved the provenance so that we can
- -- construct minimal imports that import the name by (one of)
- -- the same route(s) as the programmer originally did.
- add_name (GRE n (NonLocalDef (UserImport m _ _)) _) acc = addToFM_C plusAvailEnv acc (moduleName m)
- (unitAvailEnv (mk_avail n))
- add_name (GRE n other_prov _) acc = acc
-
- mk_avail n = case lookupNameEnv avail_env n of
- Just (AvailTC m _) | n==m -> AvailTC n [n]
- | otherwise -> AvailTC m [n,m]
- Just avail -> Avail n
- Nothing -> pprPanic "mk_avail" (ppr n)
-
- add_inst_mod m acc
- | m `elemFM` acc = acc -- We import something already
- | otherwise = addToFM acc m emptyAvailEnv
- -- Add an empty collection of imports for a module
- -- from which we have sucked only instance decls
-
- direct_import_mods :: [ModuleName]
- direct_import_mods = nub [m | ImportDecl m _ _ _ _ _ <- imports]
-
- -- unused_imp_mods are the directly-imported modules
- -- that are not mentioned in minimal_imports
- unused_imp_mods = [m | m <- direct_import_mods,
- not (maybeToBool (lookupFM minimal_imports m)),
- m /= pRELUDE_Name]
-
- module_unused :: Module -> Bool
- module_unused mod = moduleName mod `elem` unused_imp_mods
-
-
--- ToDo: deal with original imports with 'qualified' and 'as M' clauses
-printMinimalImports :: Module -- This module
- -> PrintUnqualified
- -> FiniteMap ModuleName AvailEnv -- Minimal imports
- -> RnMG ()
-printMinimalImports this_mod unqual imps
- = ifOptRn Opt_D_dump_minimal_imports $
-
- mapRn to_ies (fmToList imps) `thenRn` \ mod_ies ->
- ioToRnM (do { h <- openFile filename WriteMode ;
- printForUser h unqual (vcat (map ppr_mod_ie mod_ies))
- }) `thenRn_`
- returnRn ()
- where
- filename = moduleNameUserString (moduleName this_mod) ++ ".imports"
- ppr_mod_ie (mod_name, ies)
- | mod_name == pRELUDE_Name
- = empty
- | otherwise
- = ptext SLIT("import") <+> ppr mod_name <>
- parens (fsep (punctuate comma (map ppr ies)))
-
- to_ies (mod, avail_env) = mapRn to_ie (availEnvElts avail_env) `thenRn` \ ies ->
- returnRn (mod, ies)
-
- to_ie :: AvailInfo -> RnMG (IE Name)
- -- The main trick here is that if we're importing all the constructors
- -- we want to say "T(..)", but if we're importing only a subset we want
- -- to say "T(A,B,C)". So we have to find out what the module exports.
- to_ie (Avail n) = returnRn (IEVar n)
- to_ie (AvailTC n [m]) = ASSERT( n==m )
- returnRn (IEThingAbs n)
- to_ie (AvailTC n ns)
- = loadInterface (text "Compute minimal imports from" <+> ppr n_mod)
- n_mod ImportBySystem `thenRn` \ iface ->
- case [xs | (m,as) <- mi_exports iface,
- m == n_mod,
- AvailTC x xs <- as,
- x == n] of
- [xs] | all (`elem` ns) xs -> returnRn (IEThingAll n)
- | otherwise -> returnRn (IEThingWith n (filter (/= n) ns))
- other -> pprTrace "to_ie" (ppr n <+> ppr (nameModule n) <+> ppr other) $
- returnRn (IEVar n)
- where
- n_mod = moduleName (nameModule n)
-
-rnDump :: [RenamedHsDecl] -- Renamed decls
- -> RnMG ()
-rnDump decls
- = doptRn Opt_D_dump_rn_trace `thenRn` \ dump_rn_trace ->
- doptRn Opt_D_dump_rn_stats `thenRn` \ dump_rn_stats ->
- doptRn Opt_D_dump_rn `thenRn` \ dump_rn ->
- getIfacesRn `thenRn` \ ifaces ->
-
- ioToRnM ( dumpIfSet dump_rn "Renamer:"
- (vcat (map ppr decls)) )
- `thenRn_`
-
- returnRn ()
-
-rnStats :: [RenamedHsDecl] -- Imported decls
- -> RnMG ()
-rnStats imp_decls
- = doptRn Opt_D_dump_rn_trace `thenRn` \ dump_rn_trace ->
- doptRn Opt_D_dump_rn_stats `thenRn` \ dump_rn_stats ->
- doptRn Opt_D_dump_rn `thenRn` \ dump_rn ->
- getIfacesRn `thenRn` \ ifaces ->
-
- ioToRnM (dumpIfSet (dump_rn_trace || dump_rn_stats || dump_rn)
- "Renamer statistics"
- (getRnStats imp_decls ifaces)) `thenRn_`
- returnRn ()
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{Statistics}
-%* *
-%*********************************************************
-
-\begin{code}
-getRnStats :: [RenamedHsDecl] -> Ifaces -> SDoc
-getRnStats imported_decls ifaces
- = hcat [text "Renamer stats: ", stats]
- where
- n_mods = length [() | _ <- moduleEnvElts (iPIT ifaces)]
- -- This is really only right for a one-shot compile
-
- (decls_map, n_decls_slurped) = iDecls ifaces
-
- n_decls_left = length [decl | (avail, True, (_,decl)) <- nameEnvElts decls_map
- -- Data, newtype, and class decls are in the decls_fm
- -- under multiple names; the tycon/class, and each
- -- constructor/class op too.
- -- The 'True' selects just the 'main' decl
- ]
-
- (insts_left, n_insts_slurped) = iInsts ifaces
- n_insts_left = length (bagToList insts_left)
-
- (rules_left, n_rules_slurped) = iRules ifaces
- n_rules_left = length (bagToList rules_left)
-
- stats = vcat
- [int n_mods <+> text "interfaces read",
- hsep [ int n_decls_slurped, text "type/class/variable imported, out of",
- int (n_decls_slurped + n_decls_left), text "read"],
- hsep [ int n_insts_slurped, text "instance decls imported, out of",
- int (n_insts_slurped + n_insts_left), text "read"],
- hsep [ int n_rules_slurped, text "rule decls imported, out of",
- int (n_rules_slurped + n_rules_left), text "read"]
- ]
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Errors and warnings}
-%* *
-%************************************************************************
-
-\begin{code}
-badDeprec d
- = sep [ptext SLIT("Illegal deprecation when whole module is deprecated"),
- nest 4 (ppr d)]
-\end{code}
-
-
+++ /dev/null
-_interface_ RnBinds 1
-_exports_
-RnBinds rnBinds;
-_declarations_
-1 rnBinds _:_ _forall_ [b] => RdrHsSyn.RdrNameHsBinds -> (RnHsSyn.RenamedHsBinds -> RnMonad.RnMS (b, NameSet.FreeVars)) -> RnMonad.RnMS (b, NameSet.FreeVars) ;;
+++ /dev/null
-__interface RnBinds 1 0 where
-__export RnBinds rnBinds;
-1 rnBinds :: __forall [b] => RdrHsSyn.RdrNameHsBinds -> (RnHsSyn.RenamedHsBinds -> RnMonad.RnMS (b, NameSet.FreeVars)) -> RnMonad.RnMS (b, NameSet.FreeVars) ;
+++ /dev/null
-module RnBinds where
-
-rnBinds :: forall b . RdrHsSyn.RdrNameHsBinds
- -> (RnHsSyn.RenamedHsBinds
- -> RnMonad.RnMS (b, NameSet.FreeVars))
- -> RnMonad.RnMS (b, NameSet.FreeVars)
\begin{code}
module RnBinds (
- rnTopBinds, rnTopMonoBinds,
- rnMethodBinds, renameSigs, renameSigsFVs,
- rnBinds,
- unknownSigErr
+ rnTopMonoBinds, rnMonoBinds, rnMethodBinds,
+ renameSigs, renameSigsFVs, unknownSigErr
) where
#include "HsVersions.h"
import HsBinds ( eqHsSig, sigName, hsSigDoc )
import RdrHsSyn
import RnHsSyn
-import RnMonad
+import TcRnMonad
import RnTypes ( rnHsSigType, rnHsType )
import RnExpr ( rnMatch, rnGRHSs, rnPat, checkPrecMatch )
import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, lookupInstDeclBndr,
- lookupSigOccRn, bindPatSigTyVars, extendNestedFixityEnv,
+ lookupSigOccRn, bindPatSigTyVars, bindLocalFixities,
warnUnusedLocalBinds, mapFvRn, extendTyVarEnvFVRn,
)
import CmdLineOpts ( DynFlag(..) )
import Name ( Name, nameOccName, nameSrcLoc )
import NameSet
import RdrName ( RdrName, rdrNameOcc )
-import BasicTypes ( RecFlag(..) )
+import BasicTypes ( RecFlag(..), FixitySig(..) )
import List ( partition )
import Outputable
import PrelNames ( isUnboundName )
%* *
%************************************************************************
-@rnTopBinds@ assumes that the environment already
+@rnTopMonoBinds@ assumes that the environment already
contains bindings for the binders of this particular binding.
\begin{code}
-rnTopBinds :: RdrNameHsBinds -> RnMS (RenamedHsBinds, FreeVars)
-
-rnTopBinds EmptyBinds = returnRn (EmptyBinds, emptyFVs)
-rnTopBinds (MonoBind bind sigs _) = rnTopMonoBinds bind sigs
- -- The parser doesn't produce other forms
-
-
rnTopMonoBinds mbinds sigs
- = mapRn lookupBndrRn binder_rdr_names `thenRn` \ binder_names ->
+ = mappM lookupBndrRn binder_rdr_names `thenM` \ binder_names ->
bindPatSigTyVars (collectSigTysFromMonoBinds mbinds) $
let
bndr_name_set = mkNameSet binder_names
in
- renameSigsFVs (okBindSig bndr_name_set) sigs `thenRn` \ (siglist, sig_fvs) ->
+ renameSigsFVs (okBindSig bndr_name_set) sigs `thenM` \ (siglist, sig_fvs) ->
- ifOptRn Opt_WarnMissingSigs (
+ ifOptM Opt_WarnMissingSigs (
let
type_sig_vars = [n | Sig n _ _ <- siglist]
un_sigd_binders = nameSetToList (delListFromNameSet bndr_name_set type_sig_vars)
in
- mapRn_ missingSigWarn un_sigd_binders
- ) `thenRn_`
+ mappM_ missingSigWarn un_sigd_binders
+ ) `thenM_`
- rn_mono_binds siglist mbinds `thenRn` \ (final_binds, bind_fvs) ->
- returnRn (final_binds, bind_fvs `plusFV` sig_fvs)
+ rn_mono_binds siglist mbinds `thenM` \ (final_binds, bind_fvs) ->
+ returnM (final_binds, bind_fvs `plusFV` sig_fvs)
where
binder_rdr_names = collectMonoBinders mbinds
\end{code}
\end{itemize}
%
\begin{code}
-rnBinds :: RdrNameHsBinds
- -> (RenamedHsBinds -> RnMS (result, FreeVars))
- -> RnMS (result, FreeVars)
-
-rnBinds EmptyBinds thing_inside = thing_inside EmptyBinds
-rnBinds (MonoBind bind sigs _) thing_inside = rnMonoBinds bind sigs thing_inside
- -- the parser doesn't produce other forms
-
-
rnMonoBinds :: RdrNameMonoBinds
-> [RdrNameSig]
- -> (RenamedHsBinds -> RnMS (result, FreeVars))
- -> RnMS (result, FreeVars)
+ -> (RenamedHsBinds -> RnM (result, FreeVars))
+ -> RnM (result, FreeVars)
rnMonoBinds mbinds sigs thing_inside -- Non-empty monobinds
= -- Extract all the binders in this group,
binder_set = mkNameSet new_mbinders
in
-- Rename the signatures
- renameSigsFVs (okBindSig binder_set) sigs `thenRn` \ (siglist, sig_fvs) ->
+ renameSigsFVs (okBindSig binder_set) sigs `thenM` \ (siglist, sig_fvs) ->
-- Report the fixity declarations in this group that
-- don't refer to any of the group's binders.
-- Then install the fixity declarations that do apply here
-- Notice that they scope over thing_inside too
- let
- fixity_sigs = [(name,sig) | FixSig sig@(FixitySig name _ _) <- siglist ]
- in
- extendNestedFixityEnv fixity_sigs $
+ bindLocalFixities [sig | FixSig sig <- siglist ] $
- rn_mono_binds siglist mbinds `thenRn` \ (binds, bind_fvs) ->
+ rn_mono_binds siglist mbinds `thenM` \ (binds, bind_fvs) ->
-- Now do the "thing inside", and deal with the free-variable calculations
- thing_inside binds `thenRn` \ (result,result_fvs) ->
+ thing_inside binds `thenM` \ (result,result_fvs) ->
let
all_fvs = result_fvs `plusFV` bind_fvs `plusFV` sig_fvs
unused_binders = nameSetToList (binder_set `minusNameSet` all_fvs)
in
- warnUnusedLocalBinds unused_binders `thenRn_`
- returnRn (result, delListFromNameSet all_fvs new_mbinders)
+ warnUnusedLocalBinds unused_binders `thenM_`
+ returnM (result, delListFromNameSet all_fvs new_mbinders)
where
mbinders_w_srclocs = collectLocatedMonoBinders mbinds
doc = text "In the binding group for" <+> pp_bndrs mbinders_w_srclocs
\begin{code}
rn_mono_binds :: [RenamedSig] -- Signatures attached to this group
-> RdrNameMonoBinds
- -> RnMS (RenamedHsBinds, -- Dependency analysed
+ -> RnM (RenamedHsBinds, -- Dependency analysed
FreeVars) -- Free variables
rn_mono_binds siglist mbinds
-- Rename the bindings, returning a MonoBindsInfo
-- which is a list of indivisible vertices so far as
-- the strongly-connected-components (SCC) analysis is concerned
- flattenMonoBinds siglist mbinds `thenRn` \ mbinds_info ->
+ flattenMonoBinds siglist mbinds `thenM` \ mbinds_info ->
-- Do the SCC analysis
let
-- Deal with bound and free-var calculation
rhs_fvs = plusFVs [fvs | (_,fvs,_,_) <- mbinds_info]
in
- returnRn (final_binds, rhs_fvs)
+ returnM (final_binds, rhs_fvs)
\end{code}
@flattenMonoBinds@ is ever-so-slightly magical in that it sticks
\begin{code}
flattenMonoBinds :: [RenamedSig] -- Signatures
-> RdrNameMonoBinds
- -> RnMS [FlatMonoBindsInfo]
+ -> RnM [FlatMonoBindsInfo]
-flattenMonoBinds sigs EmptyMonoBinds = returnRn []
+flattenMonoBinds sigs EmptyMonoBinds = returnM []
flattenMonoBinds sigs (AndMonoBinds bs1 bs2)
- = flattenMonoBinds sigs bs1 `thenRn` \ flat1 ->
- flattenMonoBinds sigs bs2 `thenRn` \ flat2 ->
- returnRn (flat1 ++ flat2)
+ = flattenMonoBinds sigs bs1 `thenM` \ flat1 ->
+ flattenMonoBinds sigs bs2 `thenM` \ flat2 ->
+ returnM (flat1 ++ flat2)
flattenMonoBinds sigs (PatMonoBind pat grhss locn)
- = pushSrcLocRn locn $
- rnPat pat `thenRn` \ (pat', pat_fvs) ->
+ = addSrcLoc locn $
+ rnPat pat `thenM` \ (pat', pat_fvs) ->
-- Find which things are bound in this group
let
names_bound_here = mkNameSet (collectPatBinders pat')
in
- sigsForMe names_bound_here sigs `thenRn` \ sigs_for_me ->
- rnGRHSs grhss `thenRn` \ (grhss', fvs) ->
- returnRn
+ sigsForMe names_bound_here sigs `thenM` \ sigs_for_me ->
+ rnGRHSs grhss `thenM` \ (grhss', fvs) ->
+ returnM
[(names_bound_here,
fvs `plusFV` pat_fvs,
PatMonoBind pat' grhss' locn,
)]
flattenMonoBinds sigs (FunMonoBind name inf matches locn)
- = pushSrcLocRn locn $
- lookupBndrRn name `thenRn` \ new_name ->
+ = addSrcLoc locn $
+ lookupBndrRn name `thenM` \ new_name ->
let
names_bound_here = unitNameSet new_name
in
- sigsForMe names_bound_here sigs `thenRn` \ sigs_for_me ->
- mapFvRn (rnMatch (FunRhs name)) matches `thenRn` \ (new_matches, fvs) ->
- mapRn_ (checkPrecMatch inf new_name) new_matches `thenRn_`
- returnRn
+ sigsForMe names_bound_here sigs `thenM` \ sigs_for_me ->
+ mapFvRn (rnMatch (FunRhs name)) matches `thenM` \ (new_matches, fvs) ->
+ mappM_ (checkPrecMatch inf new_name) new_matches `thenM_`
+ returnM
[(unitNameSet new_name,
fvs,
FunMonoBind new_name inf new_matches locn,
sigsForMe names_bound_here sigs
- = foldlRn check [] (filter (sigForThisGroup names_bound_here) sigs)
+ = foldlM check [] (filter (sigForThisGroup names_bound_here) sigs)
where
check sigs sig = case filter (eqHsSig sig) sigs of
- [] -> returnRn (sig:sigs)
- other -> dupSigDeclErr sig `thenRn_`
- returnRn sigs
+ [] -> returnM (sig:sigs)
+ other -> dupSigDeclErr sig `thenM_`
+ returnM sigs
\end{code}
rnMethodBinds :: Name -- Class name
-> [Name] -- Names for generic type variables
-> RdrNameMonoBinds
- -> RnMS (RenamedMonoBinds, FreeVars)
+ -> RnM (RenamedMonoBinds, FreeVars)
-rnMethodBinds cls gen_tyvars EmptyMonoBinds = returnRn (EmptyMonoBinds, emptyFVs)
+rnMethodBinds cls gen_tyvars EmptyMonoBinds = returnM (EmptyMonoBinds, emptyFVs)
rnMethodBinds cls gen_tyvars (AndMonoBinds mb1 mb2)
- = rnMethodBinds cls gen_tyvars mb1 `thenRn` \ (mb1', fvs1) ->
- rnMethodBinds cls gen_tyvars mb2 `thenRn` \ (mb2', fvs2) ->
- returnRn (mb1' `AndMonoBinds` mb2', fvs1 `plusFV` fvs2)
+ = rnMethodBinds cls gen_tyvars mb1 `thenM` \ (mb1', fvs1) ->
+ rnMethodBinds cls gen_tyvars mb2 `thenM` \ (mb2', fvs2) ->
+ returnM (mb1' `AndMonoBinds` mb2', fvs1 `plusFV` fvs2)
rnMethodBinds cls gen_tyvars (FunMonoBind name inf matches locn)
- = pushSrcLocRn locn $
+ = addSrcLoc locn $
- lookupInstDeclBndr cls name `thenRn` \ sel_name ->
+ lookupInstDeclBndr cls name `thenM` \ sel_name ->
-- We use the selector name as the binder
- mapFvRn rn_match matches `thenRn` \ (new_matches, fvs) ->
- mapRn_ (checkPrecMatch inf sel_name) new_matches `thenRn_`
- returnRn (FunMonoBind sel_name inf new_matches locn, fvs `addOneFV` sel_name)
+ mapFvRn rn_match matches `thenM` \ (new_matches, fvs) ->
+ mappM_ (checkPrecMatch inf sel_name) new_matches `thenM_`
+ returnM (FunMonoBind sel_name inf new_matches locn, fvs `addOneFV` sel_name)
where
-- Gruesome; bring into scope the correct members of the generic type variables
-- See comments in RnSource.rnSourceDecl(ClassDecl)
- rn_match match@(Match (TypePatIn ty : _) _ _)
+ rn_match match@(Match (TypePat ty : _) _ _)
= extendTyVarEnvFVRn gen_tvs (rnMatch (FunRhs name) match)
where
tvs = map rdrNameOcc (extractHsTyRdrNames ty)
-- Can't handle method pattern-bindings which bind multiple methods.
rnMethodBinds cls gen_tyvars mbind@(PatMonoBind other_pat _ locn)
- = pushSrcLocRn locn $
- failWithRn (EmptyMonoBinds, emptyFVs) (methodBindErr mbind)
+ = addSrcLoc locn (addErr (methodBindErr mbind)) `thenM_`
+ returnM (EmptyMonoBinds, emptyFVs)
\end{code}
\begin{code}
renameSigsFVs ok_sig sigs
- = renameSigs ok_sig sigs `thenRn` \ sigs' ->
- returnRn (sigs', hsSigsFVs sigs')
+ = renameSigs ok_sig sigs `thenM` \ sigs' ->
+ returnM (sigs', hsSigsFVs sigs')
renameSigs :: (RenamedSig -> Bool) -- OK-sig predicate
-> [RdrNameSig]
- -> RnMS [RenamedSig]
+ -> RnM [RenamedSig]
-renameSigs ok_sig [] = returnRn []
+renameSigs ok_sig [] = returnM []
renameSigs ok_sig sigs
= -- Rename the signatures
- mapRn renameSig sigs `thenRn` \ sigs' ->
+ mappM renameSig sigs `thenM` \ sigs' ->
-- Check for (a) duplicate signatures
-- (b) signatures for things not in this group
Nothing -> True
(goods, bads) = partition ok_sig in_scope
in
- mapRn_ unknownSigErr bads `thenRn_`
- returnRn goods
+ mappM_ unknownSigErr bads `thenM_`
+ returnM goods
-- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory
-- because this won't work for:
-- is in scope. (I'm assuming that Baz.op isn't in scope unqualified.)
-- Doesn't seem worth much trouble to sort this.
-renameSig :: Sig RdrName -> RnMS (Sig Name)
+renameSig :: Sig RdrName -> RnM (Sig Name)
-- ClassOpSig is renamed elsewhere.
renameSig (Sig v ty src_loc)
- = pushSrcLocRn src_loc $
- lookupSigOccRn v `thenRn` \ new_v ->
- rnHsSigType (quotes (ppr v)) ty `thenRn` \ new_ty ->
- returnRn (Sig new_v new_ty src_loc)
+ = addSrcLoc src_loc $
+ lookupSigOccRn v `thenM` \ new_v ->
+ rnHsSigType (quotes (ppr v)) ty `thenM` \ new_ty ->
+ returnM (Sig new_v new_ty src_loc)
renameSig (SpecInstSig ty src_loc)
- = pushSrcLocRn src_loc $
- rnHsType (text "A SPECIALISE instance pragma") ty `thenRn` \ new_ty ->
- returnRn (SpecInstSig new_ty src_loc)
+ = addSrcLoc src_loc $
+ rnHsType (text "A SPECIALISE instance pragma") ty `thenM` \ new_ty ->
+ returnM (SpecInstSig new_ty src_loc)
renameSig (SpecSig v ty src_loc)
- = pushSrcLocRn src_loc $
- lookupSigOccRn v `thenRn` \ new_v ->
- rnHsSigType (quotes (ppr v)) ty `thenRn` \ new_ty ->
- returnRn (SpecSig new_v new_ty src_loc)
+ = addSrcLoc src_loc $
+ lookupSigOccRn v `thenM` \ new_v ->
+ rnHsSigType (quotes (ppr v)) ty `thenM` \ new_ty ->
+ returnM (SpecSig new_v new_ty src_loc)
renameSig (FixSig (FixitySig v fix src_loc))
- = pushSrcLocRn src_loc $
- lookupSigOccRn v `thenRn` \ new_v ->
- returnRn (FixSig (FixitySig new_v fix src_loc))
+ = addSrcLoc src_loc $
+ lookupSigOccRn v `thenM` \ new_v ->
+ returnM (FixSig (FixitySig new_v fix src_loc))
renameSig (InlineSig b v p src_loc)
- = pushSrcLocRn src_loc $
- lookupSigOccRn v `thenRn` \ new_v ->
- returnRn (InlineSig b new_v p src_loc)
+ = addSrcLoc src_loc $
+ lookupSigOccRn v `thenM` \ new_v ->
+ returnM (InlineSig b new_v p src_loc)
\end{code}
\begin{code}
dupSigDeclErr sig
- = pushSrcLocRn loc $
- addErrRn (sep [ptext SLIT("Duplicate") <+> what_it_is <> colon,
+ = addSrcLoc loc $
+ addErr (sep [ptext SLIT("Duplicate") <+> what_it_is <> colon,
ppr sig])
where
(what_it_is, loc) = hsSigDoc sig
unknownSigErr sig
- = pushSrcLocRn loc $
- addErrRn (sep [ptext SLIT("Misplaced") <+> what_it_is <> colon,
+ = addSrcLoc loc $
+ addErr (sep [ptext SLIT("Misplaced") <+> what_it_is <> colon,
ppr sig])
where
(what_it_is, loc) = hsSigDoc sig
missingSigWarn var
- = pushSrcLocRn (nameSrcLoc var) $
- addWarnRn (sep [ptext SLIT("Definition but no type signature for"), quotes (ppr var)])
+ = addSrcLoc (nameSrcLoc var) $
+ addWarn (sep [ptext SLIT("Definition but no type signature for"), quotes (ppr var)])
methodBindErr mbind
= hang (ptext SLIT("Can't handle multiple methods defined by one pattern binding"))
import FlattenInfo ( namesNeededForFlattening )
import HsSyn
import RnHsSyn ( RenamedFixitySig )
-import RdrHsSyn ( RdrNameIE, RdrNameHsType, RdrNameFixitySig, extractHsTyRdrTyVars )
+import RdrHsSyn ( RdrNameHsType, extractHsTyRdrTyVars )
import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, isOrig,
- mkRdrUnqual, mkRdrQual, setRdrNameOcc,
- lookupRdrEnv, foldRdrEnv, rdrEnvToList, elemRdrEnv,
- unqualifyRdrName
+ mkRdrUnqual, mkRdrQual, setRdrNameSpace, rdrNameOcc,
+ lookupRdrEnv, rdrEnvToList, elemRdrEnv,
+ extendRdrEnv, addListToRdrEnv, emptyRdrEnv,
+ isExact_maybe, unqualifyRdrName
)
import HsTypes ( hsTyVarName, replaceTyVarName )
import HscTypes ( Provenance(..), pprNameProvenance, hasBetterProv,
- ImportReason(..), GlobalRdrEnv, GlobalRdrElt(..), AvailEnv,
- AvailInfo, Avails, GenAvailInfo(..), NameSupply(..),
- ModIface(..), GhciMode(..),
- Deprecations(..), lookupDeprec,
- extendLocalRdrEnv, lookupFixity
+ ImportReason(..), GlobalRdrEnv, GlobalRdrElt(..),
+ GenAvailInfo(..), AvailInfo, Avails,
+ ModIface(..), NameCache(..),
+ Deprecations(..), lookupDeprec, isLocalGRE,
+ extendLocalRdrEnv, availName, availNames,
+ lookupFixity
)
-import RnMonad
-import Name ( Name,
- getSrcLoc, nameIsLocalOrFrom,
- mkInternalName, mkExternalName,
- mkIPName, nameOccName, nameModule_maybe,
- setNameModuleAndLoc, nameModule
- )
-import NameEnv
+import TcRnMonad
+import Name ( Name, getName, getSrcLoc, nameIsLocalOrFrom, isWiredInName,
+ mkInternalName, mkExternalName, mkIPName,
+ nameOccName, setNameModuleAndLoc, nameModule )
import NameSet
-import OccName ( OccName, occNameUserString, occNameFlavour,
- isDataSymOcc, setOccNameSpace, tcName )
-import Module ( ModuleName, moduleName, mkVanillaModule,
- mkSysModuleNameFS, moduleNameFS, WhereFrom(..) )
-import PrelNames ( mkUnboundName,
- derivingOccurrences,
- mAIN_Name, main_RDR_Unqual,
- runIOName, intTyConName,
+import OccName ( OccName, tcName, isDataOcc, occNameUserString, occNameFlavour )
+import Module ( Module, ModuleName, moduleName, mkVanillaModule )
+import PrelNames ( mkUnboundName, intTyConName, qTyConName,
boolTyConName, funTyConName,
unpackCStringName, unpackCStringFoldrName, unpackCStringUtf8Name,
eqStringName, printName,
- bindIOName, returnIOName, failIOName, thenIOName
+ bindIOName, returnIOName, failIOName, thenIOName,
+ templateHaskellNames
)
import TysWiredIn ( unitTyCon ) -- A little odd
import FiniteMap
import SrcLoc ( SrcLoc, noSrcLoc )
import Outputable
import ListSetOps ( removeDups, equivClasses )
-import Util ( sortLt )
-import BasicTypes ( mapIPName, defaultFixity )
+import BasicTypes ( mapIPName, FixitySig(..) )
import List ( nub )
-import UniqFM ( lookupWithDefaultUFM )
-import Maybe ( mapMaybe )
-import Maybes ( orElse, catMaybes )
import CmdLineOpts
import FastString ( FastString )
\end{code}
%*********************************************************
\begin{code}
-newTopBinder :: Module -> RdrName -> SrcLoc -> RnM d Name
+newTopBinder :: Module -> RdrName -> SrcLoc -> TcRn m Name
-- newTopBinder puts into the cache the binder with the
-- module information set correctly. When the decl is later renamed,
-- the binding site will thereby get the correct module.
-- the occurrences, so that doesn't matter
newTopBinder mod rdr_name loc
- = -- First check the cache
+ | Just name <- isExact_maybe rdr_name
+ = returnM name
- -- There should never be a qualified name in a binding position (except in instance decls)
- -- The parser doesn't check this because the same parser parses instance decls
- (if isQual rdr_name then
- qualNameErr (text "In its declaration") (rdr_name,loc)
- else
- returnRn ()
- ) `thenRn_`
-
- getNameSupplyRn `thenRn` \ name_supply ->
+ | otherwise
+ = -- First check the cache
+ getNameCache `thenM` \ name_supply ->
let
occ = rdrNameOcc rdr_name
key = (moduleName mod, occ)
-- b) its defining SrcLoc
-- So we update this info
- Just name -> let
- new_name = setNameModuleAndLoc name mod loc
- new_cache = addToFM cache key new_name
- in
- setNameSupplyRn (name_supply {nsNames = new_cache}) `thenRn_`
--- traceRn (text "newTopBinder: overwrite" <+> ppr new_name) `thenRn_`
- returnRn new_name
+ Just name
+ | isWiredInName name -> returnM name
+ -- Don't mess with wired-in names. Apart from anything
+ -- else, their wired-in-ness is in the SrcLoca
+ | otherwise
+ -> let
+ new_name = setNameModuleAndLoc name mod loc
+ new_cache = addToFM cache key new_name
+ in
+ setNameCache (name_supply {nsNames = new_cache}) `thenM_`
+ returnM new_name
-- Miss in the cache!
-- Build a completely new Name, and put it in the cache
-- Even for locally-defined names we use implicitImportProvenance;
-- updateProvenances will set it to rights
- Nothing -> let
- (us', us1) = splitUniqSupply (nsUniqs name_supply)
- uniq = uniqFromSupply us1
- new_name = mkExternalName uniq mod occ loc
- new_cache = addToFM cache key new_name
- in
- setNameSupplyRn (name_supply {nsUniqs = us', nsNames = new_cache}) `thenRn_`
--- traceRn (text "newTopBinder: new" <+> ppr new_name) `thenRn_`
- returnRn new_name
-
-
-newGlobalName :: ModuleName -> OccName -> RnM d Name
+ Nothing -> addNewName name_supply key mod occ loc
+
+newGlobalName :: ModuleName -> OccName -> TcRn m Name
-- Used for *occurrences*. We make a place-holder Name, really just
-- to agree on its unique, which gets overwritten when we read in
-- the binding occurence later (newTopBinder)
-- (but since it affects DLL-ery it does matter that we get it right
-- in the end).
newGlobalName mod_name occ
- = getNameSupplyRn `thenRn` \ name_supply ->
+ = getNameCache `thenM` \ name_supply ->
let
key = (mod_name, occ)
cache = nsNames name_supply
in
case lookupFM cache key of
- Just name -> -- traceRn (text "newGlobalName: hit" <+> ppr name) `thenRn_`
- returnRn name
-
- Nothing -> setNameSupplyRn (name_supply {nsUniqs = us', nsNames = new_cache}) `thenRn_`
- -- traceRn (text "newGlobalName: new" <+> ppr name) `thenRn_`
- returnRn name
- where
- (us', us1) = splitUniqSupply (nsUniqs name_supply)
- uniq = uniqFromSupply us1
- mod = mkVanillaModule mod_name
- name = mkExternalName uniq mod occ noSrcLoc
- new_cache = addToFM cache key name
+ Just name -> -- traceRn (text "newGlobalName: hit" <+> ppr name) `thenM_`
+ returnM name
+
+ Nothing -> -- traceRn (text "newGlobalName: new" <+> ppr name) `thenM_`
+ addNewName name_supply key (mkVanillaModule mod_name) occ noSrcLoc
+
+-- Look up a "system name" in the name cache.
+-- This is done by the type checker...
+-- For *source* declarations, this will put the thing into the name cache
+-- For *interface* declarations, RnHiFiles.getSysBinders will already have
+-- put it into the cache.
+lookupSysName :: Name -- Base name
+ -> (OccName -> OccName) -- Occurrence name modifier
+ -> TcRn m Name -- System name
+lookupSysName base_name mk_sys_occ
+ = getNameCache `thenM` \ name_supply ->
+ let
+ mod = nameModule base_name
+ occ = mk_sys_occ (nameOccName base_name)
+ key = (moduleName mod, occ)
+ in
+ case lookupFM (nsNames name_supply) key of
+ Just name -> returnM name
+ Nothing -> addNewName name_supply key mod occ noSrcLoc
newIPName rdr_name_ip
- = getNameSupplyRn `thenRn` \ name_supply ->
+ = getNameCache `thenM` \ name_supply ->
let
ipcache = nsIPs name_supply
in
case lookupFM ipcache key of
- Just name_ip -> returnRn name_ip
- Nothing -> setNameSupplyRn new_ns `thenRn_`
- returnRn name_ip
+ Just name_ip -> returnM name_ip
+ Nothing -> setNameCache new_ns `thenM_`
+ returnM name_ip
where
(us', us1) = splitUniqSupply (nsUniqs name_supply)
uniq = uniqFromSupply us1
new_ns = name_supply {nsUniqs = us', nsIPs = new_ipcache}
where
key = rdr_name_ip -- Ensures that ?x and %x get distinct Names
+
+addNewName :: NameCache -> (ModuleName,OccName)
+ -> Module -> OccName -> SrcLoc -> TcRn m Name
+-- Internal function: extend the name cache, dump it back into
+-- the monad, and return the new name
+-- (internal, hence the rather redundant interface)
+addNewName name_supply key mod occ loc
+ = setNameCache new_name_supply `thenM_`
+ returnM name
+ where
+ (us', us1) = splitUniqSupply (nsUniqs name_supply)
+ uniq = uniqFromSupply us1
+ name = mkExternalName uniq mod occ loc
+ new_cache = addToFM (nsNames name_supply) key name
+ new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache}
\end{code}
%*********************************************************
\begin{code}
lookupBndrRn rdr_name
- = getLocalNameEnv `thenRn` \ local_env ->
+ = getLocalRdrEnv `thenM` \ local_env ->
case lookupRdrEnv local_env rdr_name of
- Just name -> returnRn name
+ Just name -> returnM name
Nothing -> lookupTopBndrRn rdr_name
lookupTopBndrRn rdr_name
-- A separate function (importsFromLocalDecls) reports duplicate top level
-- decls, so here it's safe just to choose an arbitrary one.
- | isOrig rdr_name
+ -- There should never be a qualified name in a binding position
+ -- The parser could check this, but doesn't (yet)
+ | isQual rdr_name
+ = getSrcLocM `thenM` \ loc ->
+ qualNameErr (text "In its declaration") (rdr_name,loc) `thenM_`
+ returnM (mkUnboundName rdr_name)
+
+ | otherwise
+ = ASSERT( not (isOrig rdr_name) )
+ -- Original names are used only for occurrences,
+ -- not binding sites
+
+ getModeRn `thenM` \ mode ->
+ case mode of
+ InterfaceMode mod ->
+ getSrcLocM `thenM` \ loc ->
+ newTopBinder mod rdr_name loc
+
+ other -> lookupTopSrcBndr rdr_name
+
+lookupTopSrcBndr :: RdrName -> TcRn m Name
+lookupTopSrcBndr rdr_name
+ = lookupTopSrcBndr_maybe rdr_name `thenM` \ maybe_name ->
+ case maybe_name of
+ Just name -> returnM name
+ Nothing -> unboundName rdr_name
+
+
+lookupTopSrcBndr_maybe :: RdrName -> TcRn m (Maybe Name)
+-- Look up a source-code binder
+
+-- Ignores imported names; for example, this is OK:
+-- import Foo( f )
+-- infix 9 f -- The 'f' here does not need to be qualified
+-- f x = x -- Nor here, of course
+
+lookupTopSrcBndr_maybe rdr_name
+ | Just name <- isExact_maybe rdr_name
-- This is here just to catch the PrelBase defn of (say) [] and similar
- -- The parser reads the special syntax and returns an Orig RdrName
+ -- The parser reads the special syntax and returns an Exact RdrName
-- But the global_env contains only Qual RdrNames, so we won't
-- find it there; instead just get the name via the Orig route
--
- = -- This is a binding site for the name, so check first that it
+ -- We are at a binding site for the name, so check first that it
-- the current module is the correct one; otherwise GHC can get
-- very confused indeed. This test rejects code like
-- data T = (,) Int Int
-- unless we are in GHC.Tup
- getModuleRn `thenRn` \ mod ->
- checkRn (moduleName mod == rdrNameModule rdr_name)
- (badOrigBinding rdr_name) `thenRn_`
- lookupOrigName rdr_name
+ = getModule `thenM` \ mod ->
+ checkErr (moduleName mod == moduleName (nameModule name))
+ (badOrigBinding rdr_name) `thenM_`
+ returnM (Just name)
| otherwise
- = getModeRn `thenRn` \ mode ->
- if isInterfaceMode mode
- then lookupSysBinder rdr_name
- -- lookupSysBinder uses the Module in the monad to set
- -- the correct module for the binder. This is important because
- -- when GHCi is reading in an old interface, it just sucks it
- -- in entire (Rename.loadHomeDecls) which uses lookupTopBndrRn
- -- rather than via the iface file cache which uses newTopBndrRn
- -- We must get the correct Module into the thing.
-
- else
- getModuleRn `thenRn` \ mod ->
- getGlobalNameEnv `thenRn` \ global_env ->
- case lookup_local mod global_env rdr_name of
- Just name -> returnRn name
- Nothing -> failWithRn (mkUnboundName rdr_name)
- (unknownNameErr rdr_name)
-
-lookup_local mod global_env rdr_name
- = case lookupRdrEnv global_env rdr_name of
- Nothing -> Nothing
- Just gres -> case [n | GRE n _ _ <- gres, nameIsLocalOrFrom mod n] of
- [] -> Nothing
- (n:ns) -> Just n
+ = getGlobalRdrEnv `thenM` \ global_env ->
+ case lookupRdrEnv global_env rdr_name of
+ Nothing -> returnM Nothing
+ Just gres -> case [gre_name gre | gre <- gres, isLocalGRE gre] of
+ [] -> returnM Nothing
+ (n:ns) -> returnM (Just n)
-- lookupSigOccRn is used for type signatures and pragmas
-- The Haskell98 report does not stipulate this, but it will!
-- So we must treat the 'f' in the signature in the same way
-- as the binding occurrence of 'f', using lookupBndrRn
-lookupSigOccRn :: RdrName -> RnMS Name
+lookupSigOccRn :: RdrName -> RnM Name
lookupSigOccRn = lookupBndrRn
-- lookupInstDeclBndr is used for the binders in an
-- instance declaration. Here we use the class name to
-- disambiguate.
-lookupInstDeclBndr :: Name -> RdrName -> RnMS Name
+lookupInstDeclBndr :: Name -> RdrName -> RnM Name
-- We use the selector name as the binder
lookupInstDeclBndr cls_name rdr_name
- | isOrig rdr_name -- Occurs in derived instances, where we just
- -- refer diectly to the right method
- = lookupOrigName rdr_name
-
- | otherwise
- = getGlobalAvails `thenRn` \ avail_env ->
- case lookupNameEnv avail_env cls_name of
- -- The class itself isn't in scope, so cls_name is unboundName
- -- e.g. import Prelude hiding( Ord )
- -- instance Ord T where ...
- -- The program is wrong, but that should not cause a crash.
- Nothing -> returnRn (mkUnboundName rdr_name)
+ | isUnqual rdr_name
+ = -- Find all the things the class op name maps to
+ -- and pick the one with the right parent name
+ getGblEnv `thenM` \ gbl_env ->
+ let
+ avail_env = imp_env (tcg_imports gbl_env)
+ in
+ case lookupAvailEnv avail_env cls_name of
+ Nothing ->
+ -- If the class itself isn't in scope, then cls_name will
+ -- be unboundName, and there'll already be an error for
+ -- that in the error list. Example:
+ -- e.g. import Prelude hiding( Ord )
+ -- instance Ord T where ...
+ -- The program is wrong, but that should not cause a crash.
+ returnM (mkUnboundName rdr_name)
+
Just (AvailTC _ ns) -> case [n | n <- ns, nameOccName n == occ] of
- (n:ns)-> ASSERT( null ns ) returnRn n
- [] -> failWithRn (mkUnboundName rdr_name)
- (unknownNameErr rdr_name)
+ (n:ns)-> ASSERT( null ns ) returnM n
+ [] -> unboundName rdr_name
+
other -> pprPanic "lookupInstDeclBndr" (ppr cls_name)
+
+ | isQual rdr_name -- Should never have a qualified name in a binding position
+ = getSrcLocM `thenM` \ loc ->
+ qualNameErr (text "In an instance method") (rdr_name,loc) `thenM_`
+ returnM (mkUnboundName rdr_name)
+
+ | otherwise -- Occurs in derived instances, where we just
+ -- refer directly to the right method, and avail_env
+ -- isn't available
+ = ASSERT2( not (isQual rdr_name), ppr rdr_name )
+ lookupOrigName rdr_name
+
where
occ = rdrNameOcc rdr_name
+lookupSysBndr :: RdrName -> RnM Name
+-- Used for the 'system binders' in a data type or class declaration
+-- Do *not* look up in the RdrEnv; these system binders are never in scope
+-- Instead, get the module from the monad... but remember that
+-- where the module is depends on whether we are renaming source or
+-- interface file stuff
+lookupSysBndr rdr_name
+ = getSrcLocM `thenM` \ loc ->
+ getModeRn `thenM` \ mode ->
+ case mode of
+ InterfaceMode mod -> newTopBinder mod rdr_name loc
+ other -> getModule `thenM` \ mod ->
+ newTopBinder mod rdr_name loc
+
-- lookupOccRn looks up an occurrence of a RdrName
-lookupOccRn :: RdrName -> RnMS Name
+lookupOccRn :: RdrName -> RnM Name
lookupOccRn rdr_name
- = getLocalNameEnv `thenRn` \ local_env ->
+ = getLocalRdrEnv `thenM` \ local_env ->
case lookupRdrEnv local_env rdr_name of
- Just name -> returnRn name
+ Just name -> returnM name
Nothing -> lookupGlobalOccRn rdr_name
-- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global
-- class op names in class and instance decls
lookupGlobalOccRn rdr_name
- = getModeRn `thenRn` \ mode ->
- if (isInterfaceMode mode)
- then lookupIfaceName rdr_name
- else
+ = getModeRn `thenM` \ mode ->
+ case mode of
+ InterfaceMode mod -> lookupIfaceName mod rdr_name
+ SourceMode -> lookupSrcName rdr_name
- getGlobalNameEnv `thenRn` \ global_env ->
- case mode of
- SourceMode -> lookupSrcName global_env rdr_name
-
- CmdLineMode
+ CmdLineMode
| not (isQual rdr_name) ->
- lookupSrcName global_env rdr_name
+ lookupSrcName rdr_name
-- We allow qualified names on the command line to refer to
-- *any* name exported by any module in scope, just as if
-- it isn't there, we manufacture a new occurrence of an
-- original name.
| otherwise ->
- case lookupRdrEnv global_env rdr_name of
- Just _ -> lookupSrcName global_env rdr_name
- Nothing -> lookupQualifiedName rdr_name
+ lookupSrcName_maybe rdr_name `thenM` \ mb_name ->
+ case mb_name of
+ Just name -> returnM name
+ Nothing -> lookupQualifiedName rdr_name
--- a qualified name on the command line can refer to any module at all: we
+-- A qualified name on the command line can refer to any module at all: we
-- try to load the interface if we don't already have it.
-lookupQualifiedName :: RdrName -> RnM d Name
+lookupQualifiedName :: RdrName -> TcRn m Name
lookupQualifiedName rdr_name
= let
mod = rdrNameModule rdr_name
occ = rdrNameOcc rdr_name
in
- loadInterface (ppr rdr_name) mod ImportByUser `thenRn` \ iface ->
+ loadInterface (ppr rdr_name) mod (ImportByUser False) `thenM` \ iface ->
case [ name | (_,avails) <- mi_exports iface,
avail <- avails,
name <- availNames avail,
nameOccName name == occ ] of
- (n:ns) -> ASSERT (null ns) returnRn n
- _ -> failWithRn (mkUnboundName rdr_name) (unknownNameErr rdr_name)
-
-lookupSrcName :: GlobalRdrEnv -> RdrName -> RnM d Name
--- NB: passed GlobalEnv explicitly, not necessarily in RnMS monad
-lookupSrcName global_env rdr_name
- | isOrig rdr_name -- Can occur in source code too
- = lookupOrigName rdr_name
+ (n:ns) -> ASSERT (null ns) returnM n
+ _ -> unboundName rdr_name
+
+lookupSrcName :: RdrName -> TcRn m Name
+lookupSrcName rdr_name
+ = lookupSrcName_maybe rdr_name `thenM` \ mb_name ->
+ case mb_name of
+ Nothing -> unboundName rdr_name
+ Just name -> returnM name
+
+lookupSrcName_maybe :: RdrName -> TcRn m (Maybe Name)
+lookupSrcName_maybe rdr_name
+ | Just name <- isExact_maybe rdr_name -- Can occur in source code too
+ = returnM (Just name)
+
+ | isOrig rdr_name -- An original name
+ = newGlobalName (rdrNameModule rdr_name)
+ (rdrNameOcc rdr_name) `thenM` \ name ->
+ returnM (Just name)
| otherwise
- = case lookupRdrEnv global_env rdr_name of
- Just [GRE name _ Nothing] -> returnRn name
- Just [GRE name _ (Just deprec)] -> warnDeprec name deprec `thenRn_`
- returnRn name
- Just stuff@(GRE name _ _ : _) -> addNameClashErrRn rdr_name stuff `thenRn_`
- returnRn name
- Nothing -> failWithRn (mkUnboundName rdr_name)
- (unknownNameErr rdr_name)
-
-lookupOrigName :: RdrName -> RnM d Name
-lookupOrigName rdr_name
- = -- NO: ASSERT( isOrig rdr_name )
- -- Now that .hi-boot files are read by the main parser, they contain
- -- ordinary qualified names (which we treat as Orig names here).
- newGlobalName (rdrNameModule rdr_name) (rdrNameOcc rdr_name)
-
-lookupIfaceUnqual :: RdrName -> RnM d Name
-lookupIfaceUnqual rdr_name
- = ASSERT( isUnqual rdr_name )
+ = lookupGRE rdr_name `thenM` \ mb_gre ->
+ case mb_gre of
+ Nothing -> returnM Nothing
+ Just gre -> returnM (Just (gre_name gre))
+
+lookupGRE :: RdrName -> TcRn m (Maybe GlobalRdrElt)
+lookupGRE rdr_name
+ = getGlobalRdrEnv `thenM` \ global_env ->
+ case lookupRdrEnv global_env rdr_name of
+ Just [gre] -> case gre_deprec gre of
+ Nothing -> returnM (Just gre)
+ Just _ -> warnDeprec gre `thenM_`
+ returnM (Just gre)
+ Just stuff@(gre : _) -> addNameClashErrRn rdr_name stuff `thenM_`
+ returnM (Just gre)
+ Nothing -> return Nothing
+
+lookupIfaceName :: Module -> RdrName -> TcRn m Name
-- An Unqual is allowed; interface files contain
-- unqualified names for locally-defined things, such as
-- constructors of a data type.
- getModuleRn `thenRn ` \ mod ->
- newGlobalName (moduleName mod) (rdrNameOcc rdr_name)
-
-lookupIfaceName :: RdrName -> RnM d Name
-lookupIfaceName rdr_name
- | isUnqual rdr_name = lookupIfaceUnqual rdr_name
+lookupIfaceName mod rdr_name
+ | isUnqual rdr_name = newGlobalName (moduleName mod) (rdrNameOcc rdr_name)
| otherwise = lookupOrigName rdr_name
-\end{code}
-@lookupOrigName@ takes an RdrName representing an {\em original}
-name, and adds it to the occurrence pool so that it'll be loaded
-later. This is used when language constructs (such as monad
-comprehensions, overloaded literals, or deriving clauses) require some
-stuff to be loaded that isn't explicitly mentioned in the code.
-
-This doesn't apply in interface mode, where everything is explicit,
-but we don't check for this case: it does no harm to record an
-``extra'' occurrence and @lookupOrigNames@ isn't used much in
-interface mode (it's only the @Nothing@ clause of @rnDerivs@ that
-calls it at all I think).
-
- \fbox{{\em Jan 98: this comment is wrong: @rnHsType@ uses it quite a bit.}}
-
-\begin{code}
-lookupOrigNames :: [RdrName] -> RnM d NameSet
-lookupOrigNames rdr_names
- = mapRn lookupOrigName rdr_names `thenRn` \ names ->
- returnRn (mkNameSet names)
+lookupOrigName :: RdrName -> TcRn m Name
+ -- Just for original or exact names
+lookupOrigName rdr_name
+ | Just n <- isExact_maybe rdr_name
+ -- This happens in derived code, which we
+ -- rename in InterfaceMode
+ = returnM n
+
+ | otherwise -- Usually Orig, but can be a Qual when
+ -- we are reading a .hi-boot file
+ = newGlobalName (rdrNameModule rdr_name) (rdrNameOcc rdr_name)
+
+
+dataTcOccs :: RdrName -> [RdrName]
+-- If the input is a data constructor, return both it and a type
+-- constructor. This is useful when we aren't sure which we are
+-- looking at
+dataTcOccs rdr_name
+ | isDataOcc occ = [rdr_name, rdr_name_tc]
+ | otherwise = [rdr_name]
+ where
+ occ = rdrNameOcc rdr_name
+ rdr_name_tc = setRdrNameSpace rdr_name tcName
\end{code}
-lookupSysBinder is used for the "system binders" of a type, class, or
-instance decl. It ensures that the module is set correctly in the
-name cache, and sets the provenance on the returned name too. The
-returned name will end up actually in the type, class, or instance.
-
\begin{code}
-lookupSysBinder rdr_name
- = ASSERT( isUnqual rdr_name )
- getModuleRn `thenRn` \ mod ->
- getSrcLocRn `thenRn` \ loc ->
- newTopBinder mod rdr_name loc
+unboundName rdr_name = addErr (unknownNameErr rdr_name) `thenM_`
+ returnM (mkUnboundName rdr_name)
\end{code}
-
%*********************************************************
%* *
-\subsection{Looking up fixities}
+ Fixities
%* *
%*********************************************************
+\begin{code}
+--------------------------------
+bindLocalFixities :: [RenamedFixitySig] -> RnM a -> RnM a
+-- Used for nested fixity decls
+-- No need to worry about type constructors here,
+-- Should check for duplicates but we don't
+bindLocalFixities fixes thing_inside
+ | null fixes = thing_inside
+ | otherwise = extendFixityEnv new_bit thing_inside
+ where
+ new_bit = [(n,s) | s@(FixitySig n _ _) <- fixes]
+\end{code}
+
+--------------------------------
lookupFixity is a bit strange.
* Nested local fixity decls are put in the local fixity env, which we
We put them all in the local fixity environment
\begin{code}
-lookupFixityRn :: Name -> RnMS Fixity
+lookupFixityRn :: Name -> RnM Fixity
lookupFixityRn name
- = getModuleRn `thenRn` \ this_mod ->
+ = getModule `thenM` \ this_mod ->
if nameIsLocalOrFrom this_mod name
then -- It's defined in this module
- getFixityEnv `thenRn` \ local_fix_env ->
- returnRn (lookupLocalFixity local_fix_env name)
+ getFixityEnv `thenM` \ local_fix_env ->
+ returnM (lookupFixity local_fix_env name)
else -- It's imported
-- For imported names, we have to get their fixities by doing a
-- nothing from B will be used). When we come across a use of
-- 'f', we need to know its fixity, and it's then, and only
-- then, that we load B.hi. That is what's happening here.
- loadInterface doc name_mod ImportBySystem `thenRn` \ iface ->
- returnRn (lookupFixity (mi_fixities iface) name)
+ loadInterface doc name_mod ImportBySystem `thenM` \ iface ->
+ returnM (lookupFixity (mi_fixities iface) name)
where
doc = ptext SLIT("Checking fixity for") <+> ppr name
name_mod = moduleName (nameModule name)
-
---------------------------------
-lookupLocalFixity :: LocalFixityEnv -> Name -> Fixity
-lookupLocalFixity env name
- = case lookupNameEnv env name of
- Just (FixitySig _ fix _) -> fix
- Nothing -> defaultFixity
-
-extendNestedFixityEnv :: [(Name, RenamedFixitySig)] -> RnMS a -> RnMS a
--- Used for nested fixity decls
--- No need to worry about type constructors here,
--- Should check for duplicates but we don't
-extendNestedFixityEnv fixes enclosed_scope
- = getFixityEnv `thenRn` \ fix_env ->
- let
- new_fix_env = extendNameEnvList fix_env fixes
- in
- setFixityEnv new_fix_env enclosed_scope
-
-mkTopFixityEnv :: GlobalRdrEnv -> [RdrNameFixitySig] -> RnMG LocalFixityEnv
-mkTopFixityEnv gbl_env fix_sigs
- = getModuleRn `thenRn` \ mod ->
- let
- -- GHC extension: look up both the tycon and data con
- -- for con-like things
- -- If neither are in scope, report an error; otherwise
- -- add both to the fixity env
- go fix_env (FixitySig rdr_name fixity loc)
- = case catMaybes (map (lookup_local mod gbl_env) rdr_names) of
- [] -> pushSrcLocRn loc $
- addErrRn (unknownNameErr rdr_name) `thenRn_`
- returnRn fix_env
- ns -> foldlRn add fix_env ns
-
- where
- add fix_env name
- = case lookupNameEnv fix_env name of
- Just (FixitySig _ _ loc') -> addErrRn (dupFixityDecl rdr_name loc loc') `thenRn_`
- returnRn fix_env
- Nothing -> returnRn (extendNameEnv fix_env name (FixitySig name fixity loc))
-
- rdr_names | isDataSymOcc occ = [rdr_name, rdr_name_tc]
- | otherwise = [rdr_name]
-
- occ = rdrNameOcc rdr_name
- rdr_name_tc = setRdrNameOcc rdr_name (setOccNameSpace occ tcName)
- in
- foldlRn go emptyLocalFixityEnv fix_sigs
\end{code}
mentioned explicitly, but which might be needed by the type checker.
\begin{code}
-getImplicitStmtFVs -- Compiling a statement
- = returnRn (mkFVs [printName, bindIOName, thenIOName,
- returnIOName, failIOName]
- `plusFV` ubiquitousNames)
+implicitStmtFVs source_fvs -- Compiling a statement
+ = stmt_fvs `plusFV` implicitModuleFVs source_fvs
+ where
+ stmt_fvs = mkFVs [printName, bindIOName, thenIOName, returnIOName, failIOName]
-- These are all needed implicitly when compiling a statement
-- See TcModule.tc_stmts
-getImplicitModuleFVs decls -- Compiling a module
- = lookupOrigNames deriv_occs `thenRn` \ deriving_names ->
- returnRn (deriving_names `plusFV` ubiquitousNames)
- where
- -- deriv_classes is now a list of HsTypes, so a "normal" one
- -- appears as a (HsClassP c []). The non-normal ones for the new
- -- newtype-deriving extension, and they don't require any
- -- implicit names, so we can silently filter them out.
- deriv_occs = [occ | TyClD (TyData {tcdDerivs = Just deriv_classes}) <- decls,
- HsClassP cls [] <- deriv_classes,
- occ <- lookupWithDefaultUFM derivingOccurrences [] cls ]
+implicitModuleFVs source_fvs
+ = mkTemplateHaskellFVs source_fvs `plusFV`
+ namesNeededForFlattening `plusFV`
+ ubiquitousNames
+
+ -- This is a bit of a hack. When we see the Template-Haskell construct
+ -- [| expr |]
+ -- we are going to need lots of the ``smart constructors'' defined in
+ -- the main Template Haskell data type module. Rather than treat them
+ -- all as free vars at every occurrence site, we just make the Q type
+ -- consructor a free var.... and then use that here to haul in the others
+mkTemplateHaskellFVs source_fvs
+#ifdef GHCI
+ -- Only if Template Haskell is enabled
+ | qTyConName `elemNameSet` source_fvs = templateHaskellNames
+#endif
+ | otherwise = emptyFVs
-- ubiquitous_names are loaded regardless, because
-- they are needed in virtually every program
ubiquitousNames
= mkFVs [unpackCStringName, unpackCStringFoldrName,
unpackCStringUtf8Name, eqStringName]
- -- Virtually every program has error messages in it somewhere
-
- `plusFV`
+ -- Virtually every program has error messages in it somewhere
+ `plusFV`
mkFVs [getName unitTyCon, funTyConName, boolTyConName, intTyConName]
- -- Add occurrences for very frequently used types.
- -- (e.g. we don't want to be bothered with making funTyCon a
- -- free var at every function application!)
- `plusFV`
- namesNeededForFlattening
- -- this will be empty unless flattening is activated
-
-checkMain ghci_mode mod_name gbl_env
- -- LOOKUP main IF WE'RE IN MODULE Main
- -- The main point of this is to drag in the declaration for 'main',
- -- its in another module, and for the Prelude function 'runIO',
- -- so that the type checker will find them
- --
- -- We have to return the main_name separately, because it's a
- -- bona fide 'use', and should be recorded as such, but the others
- -- aren't
- | mod_name /= mAIN_Name
- = returnRn (Nothing, emptyFVs, emptyFVs)
-
- | not (main_RDR_Unqual `elemRdrEnv` gbl_env)
- = complain_no_main `thenRn_`
- returnRn (Nothing, emptyFVs, emptyFVs)
-
- | otherwise
- = lookupSrcName gbl_env main_RDR_Unqual `thenRn` \ main_name ->
- returnRn (Just main_name, unitFV main_name, unitFV runIOName)
-
- where
- complain_no_main | ghci_mode == Interactive = addWarnRn noMainMsg
- | otherwise = addErrRn noMainMsg
- -- In interactive mode, only warn about the absence of main
+ -- Add occurrences for very frequently used types.
+ -- (e.g. we don't want to be bothered with making
+ -- funTyCon a free var at every function application!)
\end{code}
%************************************************************************
\begin{code}
lookupSyntaxName :: Name -- The standard name
- -> RnMS (Name, FreeVars) -- Possibly a non-standard name
+ -> RnM (Name, FreeVars) -- Possibly a non-standard name
lookupSyntaxName std_name
- = getModeRn `thenRn` \ mode ->
- case mode of {
- InterfaceMode -> returnRn (std_name, unitFV std_name) ;
+ = getModeRn `thenM` \ mode ->
+ if isInterfaceMode mode then
+ returnM (std_name, unitFV std_name)
-- Happens for 'derived' code
-- where we don't want to rebind
- other ->
+ else
- doptRn Opt_NoImplicitPrelude `thenRn` \ no_prelude ->
+ doptM Opt_NoImplicitPrelude `thenM` \ no_prelude ->
if not no_prelude then
- returnRn (std_name, unitFV std_name) -- Normal case
+ returnM (std_name, unitFV std_name) -- Normal case
+
else
-- Get the similarly named thing from the local environment
- lookupOccRn (mkRdrUnqual (nameOccName std_name)) `thenRn` \ usr_name ->
- returnRn (usr_name, mkFVs [usr_name, std_name]) }
+ lookupOccRn (mkRdrUnqual (nameOccName std_name)) `thenM` \ usr_name ->
+ returnM (usr_name, mkFVs [usr_name, std_name])
\end{code}
\begin{code}
newLocalsRn :: [(RdrName,SrcLoc)]
- -> RnMS [Name]
+ -> RnM [Name]
newLocalsRn rdr_names_w_loc
- = getNameSupplyRn `thenRn` \ name_supply ->
+ = newUniqueSupply `thenM` \ us ->
let
- (us', us1) = splitUniqSupply (nsUniqs name_supply)
- uniqs = uniqsFromSupply us1
+ uniqs = uniqsFromSupply us
names = [ mkInternalName uniq (rdrNameOcc rdr_name) loc
| ((rdr_name,loc), uniq) <- rdr_names_w_loc `zip` uniqs
]
in
- setNameSupplyRn (name_supply {nsUniqs = us'}) `thenRn_`
- returnRn names
+ returnM names
bindLocatedLocalsRn :: SDoc -- Documentation string for error message
-> [(RdrName,SrcLoc)]
- -> ([Name] -> RnMS a)
- -> RnMS a
+ -> ([Name] -> RnM a)
+ -> RnM a
bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope
- = getModeRn `thenRn` \ mode ->
- getLocalNameEnv `thenRn` \ local_env ->
- getGlobalNameEnv `thenRn` \ global_env ->
+ = getModeRn `thenM` \ mode ->
+ getLocalRdrEnv `thenM` \ local_env ->
+ getGlobalRdrEnv `thenM` \ global_env ->
-- Check for duplicate names
- checkDupOrQualNames doc_str rdr_names_w_loc `thenRn_`
+ checkDupOrQualNames doc_str rdr_names_w_loc `thenM_`
-- Warn about shadowing, but only in source modules
let
check_shadow (rdr_name,loc)
| rdr_name `elemRdrEnv` local_env
|| rdr_name `elemRdrEnv` global_env
- = pushSrcLocRn loc $ addWarnRn (shadowedNameWarn rdr_name)
+ = addSrcLoc loc $ addWarn (shadowedNameWarn rdr_name)
| otherwise
- = returnRn ()
+ = returnM ()
in
(case mode of
- SourceMode -> ifOptRn Opt_WarnNameShadowing $
- mapRn_ check_shadow rdr_names_w_loc
- other -> returnRn ()
- ) `thenRn_`
+ SourceMode -> ifOptM Opt_WarnNameShadowing $
+ mappM_ check_shadow rdr_names_w_loc
+ other -> returnM ()
+ ) `thenM_`
- newLocalsRn rdr_names_w_loc `thenRn` \ names ->
+ newLocalsRn rdr_names_w_loc `thenM` \ names ->
let
new_local_env = addListToRdrEnv local_env (map fst rdr_names_w_loc `zip` names)
in
- setLocalNameEnv new_local_env (enclosed_scope names)
+ setLocalRdrEnv new_local_env (enclosed_scope names)
-bindCoreLocalRn :: RdrName -> (Name -> RnMS a) -> RnMS a
+bindCoreLocalRn :: RdrName -> (Name -> RnM a) -> RnM a
-- A specialised variant when renaming stuff from interface
-- files (of which there is a lot)
-- * one at a time
-- * always imported
-- * deal with free vars
bindCoreLocalRn rdr_name enclosed_scope
- = getSrcLocRn `thenRn` \ loc ->
- getLocalNameEnv `thenRn` \ name_env ->
- getNameSupplyRn `thenRn` \ name_supply ->
- let
- (us', us1) = splitUniqSupply (nsUniqs name_supply)
- uniq = uniqFromSupply us1
- name = mkInternalName uniq (rdrNameOcc rdr_name) loc
- in
- setNameSupplyRn (name_supply {nsUniqs = us'}) `thenRn_`
+ = getSrcLocM `thenM` \ loc ->
+ getLocalRdrEnv `thenM` \ name_env ->
+ newUnique `thenM` \ uniq ->
let
+ name = mkInternalName uniq (rdrNameOcc rdr_name) loc
new_name_env = extendRdrEnv name_env rdr_name name
in
- setLocalNameEnv new_name_env (enclosed_scope name)
+ setLocalRdrEnv new_name_env (enclosed_scope name)
bindCoreLocalsRn [] thing_inside = thing_inside []
bindCoreLocalsRn (b:bs) thing_inside = bindCoreLocalRn b $ \ name' ->
thing_inside (name':names')
bindLocalNames names enclosed_scope
- = getLocalNameEnv `thenRn` \ name_env ->
- setLocalNameEnv (extendLocalRdrEnv name_env names)
+ = getLocalRdrEnv `thenM` \ name_env ->
+ setLocalRdrEnv (extendLocalRdrEnv name_env names)
enclosed_scope
bindLocalNamesFV names enclosed_scope
= bindLocalNames names $
- enclosed_scope `thenRn` \ (thing, fvs) ->
- returnRn (thing, delListFromNameSet fvs names)
+ enclosed_scope `thenM` \ (thing, fvs) ->
+ returnM (thing, delListFromNameSet fvs names)
-------------------------------------
bindLocalRn doc rdr_name enclosed_scope
- = getSrcLocRn `thenRn` \ loc ->
+ = getSrcLocM `thenM` \ loc ->
bindLocatedLocalsRn doc [(rdr_name,loc)] $ \ (n:ns) ->
ASSERT( null ns )
enclosed_scope n
bindLocalsRn doc rdr_names enclosed_scope
- = getSrcLocRn `thenRn` \ loc ->
+ = getSrcLocM `thenM` \ loc ->
bindLocatedLocalsRn doc
(rdr_names `zip` repeat loc)
enclosed_scope
-- except that it deals with free vars
bindLocalsFVRn doc rdr_names enclosed_scope
= bindLocalsRn doc rdr_names $ \ names ->
- enclosed_scope names `thenRn` \ (thing, fvs) ->
- returnRn (thing, delListFromNameSet fvs names)
+ enclosed_scope names `thenM` \ (thing, fvs) ->
+ returnM (thing, delListFromNameSet fvs names)
-------------------------------------
-extendTyVarEnvFVRn :: [Name] -> RnMS (a, FreeVars) -> RnMS (a, FreeVars)
+extendTyVarEnvFVRn :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
-- This tiresome function is used only in rnSourceDecl on InstDecl
extendTyVarEnvFVRn tyvars enclosed_scope
- = bindLocalNames tyvars enclosed_scope `thenRn` \ (thing, fvs) ->
- returnRn (thing, delListFromNameSet fvs tyvars)
+ = bindLocalNames tyvars enclosed_scope `thenM` \ (thing, fvs) ->
+ returnM (thing, delListFromNameSet fvs tyvars)
bindTyVarsRn :: SDoc -> [HsTyVarBndr RdrName]
- -> ([HsTyVarBndr Name] -> RnMS a)
- -> RnMS a
+ -> ([HsTyVarBndr Name] -> RnM a)
+ -> RnM a
bindTyVarsRn doc_str tyvar_names enclosed_scope
- = getSrcLocRn `thenRn` \ loc ->
+ = getSrcLocM `thenM` \ loc ->
let
located_tyvars = [(hsTyVarName tv, loc) | tv <- tyvar_names]
in
enclosed_scope (zipWith replaceTyVarName tyvar_names names)
bindPatSigTyVars :: [RdrNameHsType]
- -> RnMS (a, FreeVars)
- -> RnMS (a, FreeVars)
+ -> RnM (a, FreeVars)
+ -> RnM (a, FreeVars)
-- Find the type variables in the pattern type
-- signatures that must be brought into scope
bindPatSigTyVars tys enclosed_scope
- = getLocalNameEnv `thenRn` \ name_env ->
- getSrcLocRn `thenRn` \ loc ->
+ = getLocalRdrEnv `thenM` \ name_env ->
+ getSrcLocM `thenM` \ loc ->
let
forall_tyvars = nub [ tv | ty <- tys,
tv <- extractHsTyRdrTyVars ty,
doc_sig = text "In a pattern type-signature"
in
bindLocatedLocalsRn doc_sig located_tyvars $ \ names ->
- enclosed_scope `thenRn` \ (thing, fvs) ->
- returnRn (thing, delListFromNameSet fvs names)
+ enclosed_scope `thenM` \ (thing, fvs) ->
+ returnM (thing, delListFromNameSet fvs names)
-------------------------------------
checkDupOrQualNames, checkDupNames :: SDoc
-> [(RdrName, SrcLoc)]
- -> RnM d ()
+ -> TcRn m ()
-- Works in any variant of the renamer monad
checkDupOrQualNames doc_str rdr_names_w_loc
= -- Check for use of qualified names
- mapRn_ (qualNameErr doc_str) quals `thenRn_`
+ mappM_ (qualNameErr doc_str) quals `thenM_`
checkDupNames doc_str rdr_names_w_loc
where
quals = filter (isQual . fst) rdr_names_w_loc
checkDupNames doc_str rdr_names_w_loc
= -- Check for duplicated names in a binding group
- mapRn_ (dupNamesErr doc_str) dups
+ mappM_ (dupNamesErr doc_str) dups
where
(_, dups) = removeDups (\(n1,l1) (n2,l2) -> n1 `compare` n2) rdr_names_w_loc
\end{code}
-- duplicates. So the simple thing is to do the fold.
add_avail :: GlobalRdrEnv -> AvailInfo -> GlobalRdrEnv
- add_avail env avail = foldl add_name env (availNames avail)
+ add_avail env avail = foldl (add_name (availName avail)) env (availNames avail)
- add_name env name -- Add qualified name only
- = addOneToGlobalRdrEnv env (mkRdrQual this_mod occ) elt
+ add_name parent env name -- Add qualified name only
+ = addOneToGlobalRdrEnv env (mkRdrQual this_mod occ) elt
where
occ = nameOccName name
- elt = GRE name (mk_provenance name) (lookupDeprec deprecs name)
+ elt = GRE {gre_name = name,
+ gre_parent = parent,
+ gre_prov = mk_provenance name,
+ gre_deprec = lookupDeprec deprecs name}
+
\end{code}
\begin{code}
choose n m | n `beats` m = n
| otherwise = m
- (GRE n pn _) `beats` (GRE m pm _) = n==m && pn `hasBetterProv` pm
+ g1 `beats` g2 = gre_name g1 == gre_name g2 &&
+ gre_prov g1 `hasBetterProv` gre_prov g2
is_duplicate :: GlobalRdrElt -> GlobalRdrElt -> Bool
- is_duplicate (GRE n1 LocalDef _) (GRE n2 LocalDef _) = False
- is_duplicate (GRE n1 _ _) (GRE n2 _ _) = n1 == n2
+ is_duplicate g1 g2 | isLocalGRE g1 && isLocalGRE g2 = False
+ is_duplicate g1 g2 = gre_name g1 == gre_name g2
\end{code}
We treat two bindings of a locally-defined name as a duplicate,
will still have different provenances.
-@unQualInScope@ 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}
-unQualInScope :: GlobalRdrEnv -> Name -> Bool
--- True if 'f' is in scope, and has only one binding,
--- and the thing it is bound to is the name we are looking for
--- (i.e. false if A.f and B.f are both in scope as unqualified 'f')
---
--- This fn is only efficient if the shared
--- partial application is used a lot.
-unQualInScope env
- = (`elemNameSet` unqual_names)
- where
- unqual_names :: NameSet
- unqual_names = foldRdrEnv add emptyNameSet env
- add rdr_name [GRE name _ _] unquals | isUnqual rdr_name = addOneToNameSet unquals name
- add _ _ unquals = unquals
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Avails}
-%* *
-%************************************************************************
-
-\begin{code}
-plusAvail (Avail n1) (Avail n2) = Avail n1
-plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n2 (nub (ns1 ++ ns2))
--- Added SOF 4/97
-#ifdef DEBUG
-plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [ppr a1,ppr a2])
-#endif
-
-addAvail :: AvailEnv -> AvailInfo -> AvailEnv
-addAvail avails avail = extendNameEnv_C plusAvail avails (availName avail) avail
-
-unitAvailEnv :: AvailInfo -> AvailEnv
-unitAvailEnv a = unitNameEnv (availName a) a
-
-plusAvailEnv :: AvailEnv -> AvailEnv -> AvailEnv
-plusAvailEnv = plusNameEnv_C plusAvail
-
-availEnvElts = nameEnvElts
-
-addAvailToNameSet :: NameSet -> AvailInfo -> NameSet
-addAvailToNameSet names avail = addListToNameSet names (availNames avail)
-
-availsToNameSet :: [AvailInfo] -> NameSet
-availsToNameSet avails = foldl addAvailToNameSet emptyNameSet avails
-
-availName :: GenAvailInfo name -> name
-availName (Avail n) = n
-availName (AvailTC n _) = n
-
-availNames :: GenAvailInfo name -> [name]
-availNames (Avail n) = [n]
-availNames (AvailTC n ns) = ns
-
--------------------------------------
-filterAvail :: RdrNameIE -- Wanted
- -> AvailInfo -- Available
- -> Maybe AvailInfo -- Resulting available;
- -- Nothing if (any of the) wanted stuff isn't there
-
-filterAvail ie@(IEThingWith want wants) avail@(AvailTC n ns)
- | sub_names_ok = Just (AvailTC n (filter is_wanted ns))
- | otherwise = Nothing
- where
- is_wanted name = nameOccName name `elem` wanted_occs
- sub_names_ok = all (`elem` avail_occs) wanted_occs
- avail_occs = map nameOccName ns
- wanted_occs = map rdrNameOcc (want:wants)
-
-filterAvail (IEThingAbs _) (AvailTC n ns) = ASSERT( n `elem` ns )
- Just (AvailTC n [n])
-
-filterAvail (IEThingAbs _) avail@(Avail n) = Just avail -- Type synonyms
-
-filterAvail (IEVar _) avail@(Avail n) = Just avail
-filterAvail (IEVar v) avail@(AvailTC n ns) = Just (AvailTC n (filter wanted ns))
- where
- wanted n = nameOccName n == occ
- occ = rdrNameOcc v
- -- The second equation happens if we import a class op, thus
- -- import A( op )
- -- where op is a class operation
-
-filterAvail (IEThingAll _) avail@(AvailTC _ _) = Just avail
- -- We don't complain even if the IE says T(..), but
- -- no constrs/class ops of T are available
- -- Instead that's caught with a warning by the caller
-
-filterAvail ie avail = Nothing
-
--------------------------------------
-groupAvails :: Module -> Avails -> [(ModuleName, Avails)]
- -- Group by module and sort by occurrence
- -- This keeps the list in canonical order
-groupAvails this_mod avails
- = [ (mkSysModuleNameFS fs, sortLt lt avails)
- | (fs,avails) <- fmToList groupFM
- ]
- where
- groupFM :: FiniteMap FastString Avails
- -- Deliberately use the FastString so we
- -- get a canonical ordering
- groupFM = foldl add emptyFM avails
-
- add env avail = addToFM_C combine env mod_fs [avail']
- where
- mod_fs = moduleNameFS (moduleName avail_mod)
- avail_mod = case nameModule_maybe (availName avail) of
- Just m -> m
- Nothing -> this_mod
- combine old _ = avail':old
- avail' = sortAvail avail
-
- a1 `lt` a2 = occ1 < occ2
- where
- occ1 = nameOccName (availName a1)
- occ2 = nameOccName (availName a2)
-
-sortAvail :: AvailInfo -> AvailInfo
--- Sort the sub-names into canonical order.
--- The canonical order has the "main name" at the beginning
--- (if it's there at all)
-sortAvail (Avail n) = Avail n
-sortAvail (AvailTC n ns) | n `elem` ns = AvailTC n (n : sortLt lt (filter (/= n) ns))
- | otherwise = AvailTC n ( sortLt lt ns)
- where
- n1 `lt` n2 = nameOccName n1 < nameOccName n2
-\end{code}
-
-\begin{code}
-pruneAvails :: (Name -> Bool) -- Keep if this is True
- -> [AvailInfo]
- -> [AvailInfo]
-pruneAvails keep avails
- = mapMaybe del avails
- where
- del :: AvailInfo -> Maybe AvailInfo -- Nothing => nothing left!
- del (Avail n) | keep n = Just (Avail n)
- | otherwise = Nothing
- del (AvailTC n ns) | null ns' = Nothing
- | otherwise = Just (AvailTC n ns')
- where
- ns' = filter keep ns
-\end{code}
-
%************************************************************************
%* *
\subsection{Free variable manipulation}
\begin{code}
-- A useful utility
-mapFvRn f xs = mapRn f xs `thenRn` \ stuff ->
+mapFvRn f xs = mappM f xs `thenM` \ stuff ->
let
(ys, fvs_s) = unzip stuff
in
- returnRn (ys, plusFVs fvs_s)
+ returnM (ys, plusFVs fvs_s)
\end{code}
%************************************************************************
\begin{code}
-warnUnusedModules :: [ModuleName] -> RnM d ()
+warnUnusedModules :: [ModuleName] -> TcRn m ()
warnUnusedModules mods
- = ifOptRn Opt_WarnUnusedImports (mapRn_ (addWarnRn . unused_mod) mods)
+ = ifOptM Opt_WarnUnusedImports (mappM_ (addWarn . unused_mod) mods)
where
unused_mod m = vcat [ptext SLIT("Module") <+> quotes (ppr m) <+>
text "is imported, but nothing from it is used",
- parens (ptext SLIT("except perhaps to re-export instances visible in") <+>
+ parens (ptext SLIT("except perhaps instances visible in") <+>
quotes (ppr m))]
-warnUnusedImports :: [(Name,Provenance)] -> RnM d ()
-warnUnusedImports names
- = ifOptRn Opt_WarnUnusedImports (warnUnusedBinds names)
+warnUnusedImports, warnUnusedTopBinds :: [GlobalRdrElt] -> TcRn m ()
+warnUnusedImports gres = ifOptM Opt_WarnUnusedImports (warnUnusedGREs gres)
+warnUnusedTopBinds gres = ifOptM Opt_WarnUnusedBinds (warnUnusedGREs gres)
-warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> RnM d ()
-warnUnusedLocalBinds names
- = ifOptRn Opt_WarnUnusedBinds (warnUnusedBinds [(n,LocalDef) | n<-names])
-
-warnUnusedMatches names
- = ifOptRn Opt_WarnUnusedMatches (warnUnusedGroup [(n,LocalDef) | n<-names])
+warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> TcRn m ()
+warnUnusedLocalBinds names = ifOptM Opt_WarnUnusedBinds (warnUnusedLocals names)
+warnUnusedMatches names = ifOptM Opt_WarnUnusedMatches (warnUnusedLocals names)
-------------------------
+-- Helpers
+warnUnusedGREs gres = warnUnusedBinds [(n,p) | GRE {gre_name = n, gre_prov = p} <- gres]
+warnUnusedLocals names = warnUnusedBinds [(n,LocalDef) | n<-names]
-warnUnusedBinds :: [(Name,Provenance)] -> RnM d ()
+warnUnusedBinds :: [(Name,Provenance)] -> TcRn m ()
warnUnusedBinds names
- = mapRn_ warnUnusedGroup groups
+ = mappM_ warnUnusedGroup groups
where
-- Group by provenance
groups = equivClasses cmp names
-------------------------
-warnUnusedGroup :: [(Name,Provenance)] -> RnM d ()
+warnUnusedGroup :: [(Name,Provenance)] -> TcRn m ()
warnUnusedGroup names
- | null filtered_names = returnRn ()
- | not is_local = returnRn ()
+ | null filtered_names = returnM ()
+ | not is_local = returnM ()
| otherwise
- = pushSrcLocRn def_loc $
- addWarnRn $
+ = addSrcLoc def_loc $
+ addWarn $
sep [msg <> colon, nest 4 (fsep (punctuate comma (map (ppr.fst) filtered_names)))]
where
filtered_names = filter reportable names
\begin{code}
addNameClashErrRn rdr_name (np1:nps)
- = addErrRn (vcat [ptext SLIT("Ambiguous occurrence") <+> quotes (ppr rdr_name),
+ = addErr (vcat [ptext SLIT("Ambiguous occurrence") <+> quotes (ppr rdr_name),
ptext SLIT("It could refer to") <+> vcat (msg1 : msgs)])
where
msg1 = ptext SLIT("either") <+> mk_ref np1
msgs = [ptext SLIT(" or") <+> mk_ref np | np <- nps]
- mk_ref (GRE name prov _) = quotes (ppr name) <> comma <+> pprNameProvenance name prov
+ mk_ref gre = quotes (ppr (gre_name gre)) <> comma <+> pprNameProvenance gre
shadowedNameWarn shadow
= hsep [ptext SLIT("This binding for"),
quotes (ppr shadow),
ptext SLIT("shadows an existing binding")]
-noMainMsg = ptext SLIT("No 'main' defined in module Main")
-
unknownNameErr name
= sep [text flavour, ptext SLIT("not in scope:"), quotes (ppr name)]
where
-- The rdrNameOcc is because we don't want to print Prelude.(,)
qualNameErr descriptor (name,loc)
- = pushSrcLocRn loc $
- addErrRn (vcat [ ptext SLIT("Invalid use of qualified name") <+> quotes (ppr name),
+ = addSrcLoc loc $
+ addErr (vcat [ ptext SLIT("Invalid use of qualified name") <+> quotes (ppr name),
descriptor])
dupNamesErr descriptor ((name,loc) : dup_things)
- = pushSrcLocRn loc $
- addErrRn ((ptext SLIT("Conflicting definitions for") <+> quotes (ppr name))
+ = addSrcLoc loc $
+ addErr ((ptext SLIT("Conflicting definitions for") <+> quotes (ppr name))
$$
descriptor)
-warnDeprec :: Name -> DeprecTxt -> RnM d ()
-warnDeprec name txt
- = ifOptRn Opt_WarnDeprecations $
- addWarnRn (sep [ text (occNameFlavour (nameOccName name)) <+>
+warnDeprec :: GlobalRdrElt -> TcRn m ()
+warnDeprec (GRE {gre_name = name, gre_deprec = Just txt})
+ = ifOptM Opt_WarnDeprecations $
+ addWarn (sep [ text (occNameFlavour (nameOccName name)) <+>
quotes (ppr name) <+> text "is deprecated:",
nest 4 (ppr txt) ])
-
-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}
\begin{code}
module RnExpr (
- rnMatch, rnGRHSs, rnPat, rnExpr, rnExprs, rnStmt,
- checkPrecMatch
+ rnMatch, rnGRHSs, rnPat, rnExpr, rnExprs,
+ rnStmt, rnStmts, checkPrecMatch
) where
#include "HsVersions.h"
-import {-# SOURCE #-} RnBinds ( rnBinds )
+import {-# SOURCE #-} RnSource ( rnSrcDecls, rnBinds )
import HsSyn
import RdrHsSyn
import RnHsSyn
-import RnMonad
+import TcRnMonad
import RnEnv
import RnTypes ( rnHsTypeFVs, precParseErr, sectionPrecErr )
import CmdLineOpts ( DynFlag(..), opt_IgnoreAsserts )
import PrelNames ( hasKey, assertIdKey,
eqClassName, foldrName, buildName, eqStringName,
cCallableClassName, cReturnableClassName,
- monadClassName, enumClassName, ordClassName,
+ enumClassName, ordClassName,
ratioDataConName, splitName, fstName, sndName,
ioDataConName, plusIntegerName, timesIntegerName,
- assertErr_RDR,
replicatePName, mapPName, filterPName,
- falseDataConName, trueDataConName, crossPName,
- zipPName, lengthPName, indexPName, toPName,
- enumFromToPName, enumFromThenToPName,
+ crossPName, zipPName, lengthPName, indexPName, toPName,
+ enumFromToPName, enumFromThenToPName, assertName,
fromIntegerName, fromRationalName, minusName, negateName,
- monadNames )
+ qTyConName, monadNames )
import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon,
floatPrimTyCon, doublePrimTyCon )
import TysWiredIn ( intTyCon )
-import Name ( NamedThing(..), mkSystemName, nameSrcLoc )
+import RdrName ( RdrName )
+import Name ( Name, NamedThing(..), mkSystemName, nameSrcLoc, nameOccName )
import NameSet
import UnicodeUtil ( stringToUtf8 )
import UniqFM ( isNullUFM )
*********************************************************
\begin{code}
-rnPat :: RdrNamePat -> RnMS (RenamedPat, FreeVars)
+rnPat :: RdrNamePat -> RnM (RenamedPat, FreeVars)
-rnPat WildPatIn = returnRn (WildPatIn, emptyFVs)
+rnPat (WildPat _) = returnM (WildPat placeHolderType, emptyFVs)
-rnPat (VarPatIn name)
- = lookupBndrRn name `thenRn` \ vname ->
- returnRn (VarPatIn vname, emptyFVs)
+rnPat (VarPat name)
+ = lookupBndrRn name `thenM` \ vname ->
+ returnM (VarPat vname, emptyFVs)
rnPat (SigPatIn pat ty)
- = doptRn Opt_GlasgowExts `thenRn` \ glaExts ->
+ = doptM Opt_GlasgowExts `thenM` \ glaExts ->
if glaExts
- then rnPat pat `thenRn` \ (pat', fvs1) ->
- rnHsTypeFVs doc ty `thenRn` \ (ty', fvs2) ->
- returnRn (SigPatIn pat' ty', fvs1 `plusFV` fvs2)
+ then rnPat pat `thenM` \ (pat', fvs1) ->
+ rnHsTypeFVs doc ty `thenM` \ (ty', fvs2) ->
+ returnM (SigPatIn pat' ty', fvs1 `plusFV` fvs2)
- else addErrRn (patSigErr ty) `thenRn_`
+ else addErr (patSigErr ty) `thenM_`
rnPat pat
where
- doc = text "a pattern type-signature"
+ doc = text "In a pattern type-signature"
-rnPat (LitPatIn s@(HsString _))
- = returnRn (LitPatIn s, unitFV eqStringName)
+rnPat (LitPat s@(HsString _))
+ = returnM (LitPat s, unitFV eqStringName)
-rnPat (LitPatIn lit)
- = litFVs lit `thenRn` \ fvs ->
- returnRn (LitPatIn lit, fvs)
+rnPat (LitPat lit)
+ = litFVs lit `thenM` \ fvs ->
+ returnM (LitPat lit, fvs)
rnPat (NPatIn lit mb_neg)
- = rnOverLit lit `thenRn` \ (lit', fvs1) ->
+ = rnOverLit lit `thenM` \ (lit', fvs1) ->
(case mb_neg of
- Nothing -> returnRn (Nothing, emptyFVs)
- Just _ -> lookupSyntaxName negateName `thenRn` \ (neg, fvs) ->
- returnRn (Just neg, fvs)
- ) `thenRn` \ (mb_neg', fvs2) ->
- returnRn (NPatIn lit' mb_neg',
+ Nothing -> returnM (Nothing, emptyFVs)
+ Just _ -> lookupSyntaxName negateName `thenM` \ (neg, fvs) ->
+ returnM (Just neg, fvs)
+ ) `thenM` \ (mb_neg', fvs2) ->
+ returnM (NPatIn lit' mb_neg',
fvs1 `plusFV` fvs2 `addOneFV` eqClassName)
-- Needed to find equality on pattern
rnPat (NPlusKPatIn name lit _)
- = rnOverLit lit `thenRn` \ (lit', fvs1) ->
- lookupBndrRn name `thenRn` \ name' ->
- lookupSyntaxName minusName `thenRn` \ (minus, fvs2) ->
- returnRn (NPlusKPatIn name' lit' minus,
+ = rnOverLit lit `thenM` \ (lit', fvs1) ->
+ lookupBndrRn name `thenM` \ name' ->
+ lookupSyntaxName minusName `thenM` \ (minus, fvs2) ->
+ returnM (NPlusKPatIn name' lit' minus,
fvs1 `plusFV` fvs2 `addOneFV` ordClassName)
-rnPat (LazyPatIn pat)
- = rnPat pat `thenRn` \ (pat', fvs) ->
- returnRn (LazyPatIn pat', fvs)
+rnPat (LazyPat pat)
+ = rnPat pat `thenM` \ (pat', fvs) ->
+ returnM (LazyPat pat', fvs)
-rnPat (AsPatIn name pat)
- = rnPat pat `thenRn` \ (pat', fvs) ->
- lookupBndrRn name `thenRn` \ vname ->
- returnRn (AsPatIn vname pat', fvs)
+rnPat (AsPat name pat)
+ = rnPat pat `thenM` \ (pat', fvs) ->
+ lookupBndrRn name `thenM` \ vname ->
+ returnM (AsPat vname pat', fvs)
-rnPat (ConPatIn con pats)
- = lookupOccRn con `thenRn` \ con' ->
- mapFvRn rnPat pats `thenRn` \ (patslist, fvs) ->
- returnRn (ConPatIn con' patslist, fvs `addOneFV` con')
+rnPat (ConPatIn con stuff) = rnConPat con stuff
-rnPat (ConOpPatIn pat1 con _ pat2)
- = rnPat pat1 `thenRn` \ (pat1', fvs1) ->
- lookupOccRn con `thenRn` \ con' ->
- rnPat pat2 `thenRn` \ (pat2', fvs2) ->
- getModeRn `thenRn` \ mode ->
- -- See comments with rnExpr (OpApp ...)
- (if isInterfaceMode mode
- then returnRn (ConOpPatIn pat1' con' defaultFixity pat2')
- else lookupFixityRn con' `thenRn` \ fixity ->
- mkConOpPatRn pat1' con' fixity pat2'
- ) `thenRn` \ pat' ->
- returnRn (pat', fvs1 `plusFV` fvs2 `addOneFV` con')
-
-rnPat (ParPatIn pat)
- = rnPat pat `thenRn` \ (pat', fvs) ->
- returnRn (ParPatIn pat', fvs)
-
-rnPat (ListPatIn pats)
- = mapFvRn rnPat pats `thenRn` \ (patslist, fvs) ->
- returnRn (ListPatIn patslist, fvs `addOneFV` listTyCon_name)
-
-rnPat (PArrPatIn pats)
- = mapFvRn rnPat pats `thenRn` \ (patslist, fvs) ->
- returnRn (PArrPatIn patslist,
+rnPat (ParPat pat)
+ = rnPat pat `thenM` \ (pat', fvs) ->
+ returnM (ParPat pat', fvs)
+
+rnPat (ListPat pats _)
+ = mapFvRn rnPat pats `thenM` \ (patslist, fvs) ->
+ returnM (ListPat patslist placeHolderType, fvs `addOneFV` listTyCon_name)
+
+rnPat (PArrPat pats _)
+ = mapFvRn rnPat pats `thenM` \ (patslist, fvs) ->
+ returnM (PArrPat patslist placeHolderType,
fvs `plusFV` implicit_fvs `addOneFV` parrTyCon_name)
where
implicit_fvs = mkFVs [lengthPName, indexPName]
-rnPat (TuplePatIn pats boxed)
- = mapFvRn rnPat pats `thenRn` \ (patslist, fvs) ->
- returnRn (TuplePatIn patslist boxed, fvs `addOneFV` tycon_name)
+rnPat (TuplePat pats boxed)
+ = mapFvRn rnPat pats `thenM` \ (patslist, fvs) ->
+ returnM (TuplePat patslist boxed, fvs `addOneFV` tycon_name)
where
tycon_name = tupleTyCon_name boxed (length pats)
-rnPat (RecPatIn con rpats)
- = lookupOccRn con `thenRn` \ con' ->
- rnRpats rpats `thenRn` \ (rpats', fvs) ->
- returnRn (RecPatIn con' rpats', fvs `addOneFV` con')
+rnPat (TypePat name) =
+ rnHsTypeFVs (text "In a type pattern") name `thenM` \ (name', fvs) ->
+ returnM (TypePat name', fvs)
+
+------------------------------
+rnConPat con (PrefixCon pats)
+ = lookupOccRn con `thenM` \ con' ->
+ mapFvRn rnPat pats `thenM` \ (pats', fvs) ->
+ returnM (ConPatIn con' (PrefixCon pats'), fvs `addOneFV` con')
-rnPat (TypePatIn name)
- = rnHsTypeFVs (text "type pattern") name `thenRn` \ (name', fvs) ->
- returnRn (TypePatIn name', fvs)
+rnConPat con (RecCon rpats)
+ = lookupOccRn con `thenM` \ con' ->
+ rnRpats rpats `thenM` \ (rpats', fvs) ->
+ returnM (ConPatIn con' (RecCon rpats'), fvs `addOneFV` con')
+
+rnConPat con (InfixCon pat1 pat2)
+ = lookupOccRn con `thenM` \ con' ->
+ rnPat pat1 `thenM` \ (pat1', fvs1) ->
+ rnPat pat2 `thenM` \ (pat2', fvs2) ->
+
+ getModeRn `thenM` \ mode ->
+ -- See comments with rnExpr (OpApp ...)
+ (if isInterfaceMode mode
+ then returnM (ConPatIn con' (InfixCon pat1' pat2'))
+ else lookupFixityRn con' `thenM` \ fixity ->
+ mkConOpPatRn con' fixity pat1' pat2'
+ ) `thenM` \ pat' ->
+ returnM (pat', fvs1 `plusFV` fvs2 `addOneFV` con')
\end{code}
+
************************************************************************
* *
\subsection{Match}
************************************************************************
\begin{code}
-rnMatch :: HsMatchContext RdrName -> RdrNameMatch -> RnMS (RenamedMatch, FreeVars)
+rnMatch :: HsMatchContext RdrName -> RdrNameMatch -> RnM (RenamedMatch, FreeVars)
rnMatch ctxt match@(Match pats maybe_rhs_sig grhss)
- = pushSrcLocRn (getMatchLoc match) $
+ = addSrcLoc (getMatchLoc match) $
-- Bind pattern-bound type variables
let
-- f x x = 1
bindLocalsFVRn doc_pat (collectPatsBinders pats) $ \ new_binders ->
- mapFvRn rnPat pats `thenRn` \ (pats', pat_fvs) ->
- rnGRHSs grhss `thenRn` \ (grhss', grhss_fvs) ->
- doptRn Opt_GlasgowExts `thenRn` \ opt_GlasgowExts ->
+ mapFvRn rnPat pats `thenM` \ (pats', pat_fvs) ->
+ rnGRHSs grhss `thenM` \ (grhss', grhss_fvs) ->
+ doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts ->
(case maybe_rhs_sig of
- Nothing -> returnRn (Nothing, emptyFVs)
- Just ty | opt_GlasgowExts -> rnHsTypeFVs doc_sig ty `thenRn` \ (ty', ty_fvs) ->
- returnRn (Just ty', ty_fvs)
- | otherwise -> addErrRn (patSigErr ty) `thenRn_`
- returnRn (Nothing, emptyFVs)
- ) `thenRn` \ (maybe_rhs_sig', ty_fvs) ->
+ Nothing -> returnM (Nothing, emptyFVs)
+ Just ty | opt_GlasgowExts -> rnHsTypeFVs doc_sig ty `thenM` \ (ty', ty_fvs) ->
+ returnM (Just ty', ty_fvs)
+ | otherwise -> addErr (patSigErr ty) `thenM_`
+ returnM (Nothing, emptyFVs)
+ ) `thenM` \ (maybe_rhs_sig', ty_fvs) ->
let
binder_set = mkNameSet new_binders
unused_binders = nameSetToList (binder_set `minusNameSet` grhss_fvs)
all_fvs = grhss_fvs `plusFV` pat_fvs `plusFV` ty_fvs
in
- warnUnusedMatches unused_binders `thenRn_`
+ warnUnusedMatches unused_binders `thenM_`
- returnRn (Match pats' maybe_rhs_sig' grhss', all_fvs)
+ returnM (Match pats' maybe_rhs_sig' grhss', all_fvs)
-- The bindLocals and bindTyVars will remove the bound FVs
\end{code}
%************************************************************************
\begin{code}
-rnGRHSs :: RdrNameGRHSs -> RnMS (RenamedGRHSs, FreeVars)
+rnGRHSs :: RdrNameGRHSs -> RnM (RenamedGRHSs, FreeVars)
rnGRHSs (GRHSs grhss binds _)
= rnBinds binds $ \ binds' ->
- mapFvRn rnGRHS grhss `thenRn` \ (grhss', fvGRHSs) ->
- returnRn (GRHSs grhss' binds' placeHolderType, fvGRHSs)
+ mapFvRn rnGRHS grhss `thenM` \ (grhss', fvGRHSs) ->
+ returnM (GRHSs grhss' binds' placeHolderType, fvGRHSs)
rnGRHS (GRHS guarded locn)
- = doptRn Opt_GlasgowExts `thenRn` \ opt_GlasgowExts ->
- pushSrcLocRn locn $
+ = doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts ->
+ addSrcLoc locn $
(if not (opt_GlasgowExts || is_standard_guard guarded) then
- addWarnRn (nonStdGuardErr guarded)
+ addWarn (nonStdGuardErr guarded)
else
- returnRn ()
- ) `thenRn_`
+ returnM ()
+ ) `thenM_`
- rnStmts guarded `thenRn` \ ((_, guarded'), fvs) ->
- returnRn (GRHS guarded' locn, fvs)
+ rnStmts guarded `thenM` \ ((_, guarded'), fvs) ->
+ returnM (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
%************************************************************************
\begin{code}
-rnExprs :: [RdrNameHsExpr] -> RnMS ([RenamedHsExpr], FreeVars)
+rnExprs :: [RdrNameHsExpr] -> RnM ([RenamedHsExpr], FreeVars)
rnExprs ls = rnExprs' ls emptyUniqSet
where
- rnExprs' [] acc = returnRn ([], acc)
+ rnExprs' [] acc = returnM ([], acc)
rnExprs' (expr:exprs) acc
- = rnExpr expr `thenRn` \ (expr', fvExpr) ->
+ = rnExpr expr `thenM` \ (expr', fvExpr) ->
-- 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 `plusFV` fvExpr
in
- (grubby_seqNameSet acc' rnExprs') exprs acc' `thenRn` \ (exprs', fvExprs) ->
- returnRn (expr':exprs', fvExprs)
+ (grubby_seqNameSet acc' rnExprs') exprs acc' `thenM` \ (exprs', fvExprs) ->
+ returnM (expr':exprs', fvExprs)
-- Grubby little function to do "seq" on namesets; replace by proper seq when GHC can do seq
grubby_seqNameSet ns result | isNullUFM ns = result
Variables. We look up the variable and return the resulting name.
\begin{code}
-rnExpr :: RdrNameHsExpr -> RnMS (RenamedHsExpr, FreeVars)
+rnExpr :: RdrNameHsExpr -> RnM (RenamedHsExpr, FreeVars)
rnExpr (HsVar v)
- = lookupOccRn v `thenRn` \ name ->
+ = lookupOccRn v `thenM` \ name ->
if name `hasKey` assertIdKey then
-- We expand it to (GHCerr.assert__ location)
mkAssertExpr
else
-- The normal case
- returnRn (HsVar name, unitFV name)
+ returnM (HsVar name, unitFV name)
rnExpr (HsIPVar v)
- = newIPName v `thenRn` \ name ->
+ = newIPName v `thenM` \ name ->
let
fvs = case name of
Linear _ -> mkFVs [splitName, fstName, sndName]
Dupable _ -> emptyFVs
in
- returnRn (HsIPVar name, fvs)
+ returnM (HsIPVar name, fvs)
rnExpr (HsLit lit)
- = litFVs lit `thenRn` \ fvs ->
- returnRn (HsLit lit, fvs)
+ = litFVs lit `thenM` \ fvs ->
+ returnM (HsLit lit, fvs)
rnExpr (HsOverLit lit)
- = rnOverLit lit `thenRn` \ (lit', fvs) ->
- returnRn (HsOverLit lit', fvs)
+ = rnOverLit lit `thenM` \ (lit', fvs) ->
+ returnM (HsOverLit lit', fvs)
rnExpr (HsLam match)
- = rnMatch LambdaExpr match `thenRn` \ (match', fvMatch) ->
- returnRn (HsLam match', fvMatch)
+ = rnMatch LambdaExpr match `thenM` \ (match', fvMatch) ->
+ returnM (HsLam match', fvMatch)
rnExpr (HsApp fun arg)
- = rnExpr fun `thenRn` \ (fun',fvFun) ->
- rnExpr arg `thenRn` \ (arg',fvArg) ->
- returnRn (HsApp fun' arg', fvFun `plusFV` fvArg)
+ = rnExpr fun `thenM` \ (fun',fvFun) ->
+ rnExpr arg `thenM` \ (arg',fvArg) ->
+ returnM (HsApp fun' arg', fvFun `plusFV` fvArg)
rnExpr (OpApp e1 op _ e2)
- = rnExpr e1 `thenRn` \ (e1', fv_e1) ->
- rnExpr e2 `thenRn` \ (e2', fv_e2) ->
- rnExpr op `thenRn` \ (op'@(HsVar op_name), fv_op) ->
+ = rnExpr e1 `thenM` \ (e1', fv_e1) ->
+ rnExpr e2 `thenM` \ (e2', fv_e2) ->
+ rnExpr op `thenM` \ (op'@(HsVar op_name), fv_op) ->
-- Deal with fixity
-- When renaming code synthesised from "deriving" declarations
-- we're in Interface mode, and we should ignore fixity; assume
-- that the deriving code generator got the association correct
-- Don't even look up the fixity when in interface mode
- getModeRn `thenRn` \ mode ->
+ getModeRn `thenM` \ mode ->
(if isInterfaceMode mode
- then returnRn (OpApp e1' op' defaultFixity e2')
- else lookupFixityRn op_name `thenRn` \ fixity ->
+ then returnM (OpApp e1' op' defaultFixity e2')
+ else lookupFixityRn op_name `thenM` \ fixity ->
mkOpAppRn e1' op' fixity e2'
- ) `thenRn` \ final_e ->
+ ) `thenM` \ final_e ->
- returnRn (final_e,
+ returnM (final_e,
fv_e1 `plusFV` fv_op `plusFV` fv_e2)
rnExpr (NegApp e _)
- = rnExpr e `thenRn` \ (e', fv_e) ->
- lookupSyntaxName negateName `thenRn` \ (neg_name, fv_neg) ->
- mkNegAppRn e' neg_name `thenRn` \ final_e ->
- returnRn (final_e, fv_e `plusFV` fv_neg)
+ = rnExpr e `thenM` \ (e', fv_e) ->
+ lookupSyntaxName negateName `thenM` \ (neg_name, fv_neg) ->
+ mkNegAppRn e' neg_name `thenM` \ final_e ->
+ returnM (final_e, fv_e `plusFV` fv_neg)
rnExpr (HsPar e)
- = rnExpr e `thenRn` \ (e', fvs_e) ->
- returnRn (HsPar e', fvs_e)
+ = rnExpr e `thenM` \ (e', fvs_e) ->
+ returnM (HsPar e', fvs_e)
+
+-- Template Haskell extensions
+rnExpr (HsBracket br_body)
+ = checkGHCI (thErr "bracket") `thenM_`
+ rnBracket br_body `thenM` \ (body', fvs_e) ->
+ returnM (HsBracket body', fvs_e `addOneFV` qTyConName)
+ -- We use the Q tycon as a proxy to haul in all the smart
+ -- constructors; see the hack in RnIfaces
+
+rnExpr (HsSplice n e)
+ = checkGHCI (thErr "splice") `thenM_`
+ getSrcLocM `thenM` \ loc ->
+ newLocalsRn [(n,loc)] `thenM` \ [n'] ->
+ rnExpr e `thenM` \ (e', fvs_e) ->
+ returnM (HsSplice n' e', fvs_e)
rnExpr section@(SectionL expr op)
- = rnExpr expr `thenRn` \ (expr', fvs_expr) ->
- rnExpr op `thenRn` \ (op', fvs_op) ->
- checkSectionPrec InfixL section op' expr' `thenRn_`
- returnRn (SectionL expr' op', fvs_op `plusFV` fvs_expr)
+ = rnExpr expr `thenM` \ (expr', fvs_expr) ->
+ rnExpr op `thenM` \ (op', fvs_op) ->
+ checkSectionPrec InfixL section op' expr' `thenM_`
+ returnM (SectionL expr' op', fvs_op `plusFV` fvs_expr)
rnExpr section@(SectionR op expr)
- = rnExpr op `thenRn` \ (op', fvs_op) ->
- rnExpr expr `thenRn` \ (expr', fvs_expr) ->
- checkSectionPrec InfixR section op' expr' `thenRn_`
- returnRn (SectionR op' expr', fvs_op `plusFV` fvs_expr)
+ = rnExpr op `thenM` \ (op', fvs_op) ->
+ rnExpr expr `thenM` \ (expr', fvs_expr) ->
+ checkSectionPrec InfixR section op' expr' `thenM_`
+ returnM (SectionR op' expr', fvs_op `plusFV` fvs_expr)
rnExpr (HsCCall fun args may_gc is_casm _)
-- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls
- = lookupOrigNames [] `thenRn` \ implicit_fvs ->
- rnExprs args `thenRn` \ (args', fvs_args) ->
- returnRn (HsCCall fun args' may_gc is_casm placeHolderType,
+ = rnExprs args `thenM` \ (args', fvs_args) ->
+ returnM (HsCCall fun args' may_gc is_casm placeHolderType,
fvs_args `plusFV` mkFVs [cCallableClassName,
cReturnableClassName,
ioDataConName])
rnExpr (HsSCC lbl expr)
- = rnExpr expr `thenRn` \ (expr', fvs_expr) ->
- returnRn (HsSCC lbl expr', fvs_expr)
+ = rnExpr expr `thenM` \ (expr', fvs_expr) ->
+ returnM (HsSCC lbl expr', fvs_expr)
rnExpr (HsCase expr ms src_loc)
- = pushSrcLocRn src_loc $
- rnExpr expr `thenRn` \ (new_expr, e_fvs) ->
- mapFvRn (rnMatch CaseAlt) ms `thenRn` \ (new_ms, ms_fvs) ->
- returnRn (HsCase new_expr new_ms src_loc, e_fvs `plusFV` ms_fvs)
+ = addSrcLoc src_loc $
+ rnExpr expr `thenM` \ (new_expr, e_fvs) ->
+ mapFvRn (rnMatch CaseAlt) ms `thenM` \ (new_ms, ms_fvs) ->
+ returnM (HsCase new_expr new_ms src_loc, e_fvs `plusFV` ms_fvs)
rnExpr (HsLet binds expr)
= rnBinds binds $ \ binds' ->
- rnExpr expr `thenRn` \ (expr',fvExpr) ->
- returnRn (HsLet binds' expr', fvExpr)
+ rnExpr expr `thenM` \ (expr',fvExpr) ->
+ returnM (HsLet binds' expr', fvExpr)
rnExpr (HsWith expr binds is_with)
- = warnCheckRn (not is_with) withWarning `thenRn_`
- rnExpr expr `thenRn` \ (expr',fvExpr) ->
- rnIPBinds binds `thenRn` \ (binds',fvBinds) ->
- returnRn (HsWith expr' binds' is_with, fvExpr `plusFV` fvBinds)
+ = warnIf is_with withWarning `thenM_`
+ rnExpr expr `thenM` \ (expr',fvExpr) ->
+ rnIPBinds binds `thenM` \ (binds',fvBinds) ->
+ returnM (HsWith expr' binds' is_with, fvExpr `plusFV` fvBinds)
rnExpr e@(HsDo do_or_lc stmts _ ty src_loc)
- = pushSrcLocRn src_loc $
- rnStmts stmts `thenRn` \ ((_, stmts'), fvs) ->
+ = addSrcLoc src_loc $
+ rnStmts stmts `thenM` \ ((_, stmts'), fvs) ->
-- Check the statement list ends in an expression
case last stmts' of {
- ResultStmt _ _ -> returnRn () ;
- _ -> addErrRn (doStmtListErr e)
- } `thenRn_`
+ ResultStmt _ _ -> returnM () ;
+ _ -> addErr (doStmtListErr e)
+ } `thenM_`
-- Generate the rebindable syntax for the monad
(case do_or_lc of
- DoExpr -> mapAndUnzipRn lookupSyntaxName monadNames
- other -> returnRn ([], [])
- ) `thenRn` \ (monad_names', monad_fvs) ->
+ DoExpr -> mapAndUnzipM lookupSyntaxName monadNames
+ other -> returnM ([], [])
+ ) `thenM` \ (monad_names', monad_fvs) ->
- returnRn (HsDo do_or_lc stmts' monad_names' placeHolderType src_loc,
+ returnM (HsDo do_or_lc stmts' monad_names' placeHolderType src_loc,
fvs `plusFV` implicit_fvs `plusFV` plusFVs monad_fvs)
where
implicit_fvs = case do_or_lc of
PArrComp -> mkFVs [replicatePName, mapPName, filterPName,
- falseDataConName, trueDataConName, crossPName,
- zipPName]
+ crossPName, zipPName]
ListComp -> mkFVs [foldrName, buildName]
- other -> emptyFVs
- -- monadClassName pulls in the standard names
- -- Monad stuff should not be necessary for a list comprehension
- -- but the typechecker looks up the bind and return Ids anyway
- -- Oh well.
+ DoExpr -> emptyFVs
rnExpr (ExplicitList _ exps)
- = rnExprs exps `thenRn` \ (exps', fvs) ->
- returnRn (ExplicitList placeHolderType exps', fvs `addOneFV` listTyCon_name)
+ = rnExprs exps `thenM` \ (exps', fvs) ->
+ returnM (ExplicitList placeHolderType exps', fvs `addOneFV` listTyCon_name)
rnExpr (ExplicitPArr _ exps)
- = rnExprs exps `thenRn` \ (exps', fvs) ->
- returnRn (ExplicitPArr placeHolderType exps',
+ = rnExprs exps `thenM` \ (exps', fvs) ->
+ returnM (ExplicitPArr placeHolderType exps',
fvs `addOneFV` toPName `addOneFV` parrTyCon_name)
rnExpr (ExplicitTuple exps boxity)
- = rnExprs exps `thenRn` \ (exps', fvs) ->
- returnRn (ExplicitTuple exps' boxity, fvs `addOneFV` tycon_name)
+ = rnExprs exps `thenM` \ (exps', fvs) ->
+ returnM (ExplicitTuple exps' boxity, fvs `addOneFV` tycon_name)
where
tycon_name = tupleTyCon_name boxity (length exps)
rnExpr (RecordCon con_id rbinds)
- = lookupOccRn con_id `thenRn` \ conname ->
- rnRbinds "construction" rbinds `thenRn` \ (rbinds', fvRbinds) ->
- returnRn (RecordCon conname rbinds', fvRbinds `addOneFV` conname)
+ = lookupOccRn con_id `thenM` \ conname ->
+ rnRbinds "construction" rbinds `thenM` \ (rbinds', fvRbinds) ->
+ returnM (RecordCon conname rbinds', fvRbinds `addOneFV` conname)
rnExpr (RecordUpd expr rbinds)
- = rnExpr expr `thenRn` \ (expr', fvExpr) ->
- rnRbinds "update" rbinds `thenRn` \ (rbinds', fvRbinds) ->
- returnRn (RecordUpd expr' rbinds', fvExpr `plusFV` fvRbinds)
+ = rnExpr expr `thenM` \ (expr', fvExpr) ->
+ rnRbinds "update" rbinds `thenM` \ (rbinds', fvRbinds) ->
+ returnM (RecordUpd expr' rbinds', fvExpr `plusFV` fvRbinds)
rnExpr (ExprWithTySig expr pty)
- = rnExpr expr `thenRn` \ (expr', fvExpr) ->
- rnHsTypeFVs (text "an expression type signature") pty `thenRn` \ (pty', fvTy) ->
- returnRn (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy)
+ = rnExpr expr `thenM` \ (expr', fvExpr) ->
+ rnHsTypeFVs doc pty `thenM` \ (pty', fvTy) ->
+ returnM (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy)
+ where
+ doc = text "In an expression type signature"
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, plusFVs [fvP, fvB1, fvB2])
+ = addSrcLoc src_loc $
+ rnExpr p `thenM` \ (p', fvP) ->
+ rnExpr b1 `thenM` \ (b1', fvB1) ->
+ rnExpr b2 `thenM` \ (b2', fvB2) ->
+ returnM (HsIf p' b1' b2' src_loc, plusFVs [fvP, fvB1, fvB2])
rnExpr (HsType a)
- = rnHsTypeFVs doc a `thenRn` \ (t, fvT) ->
- returnRn (HsType t, fvT)
+ = rnHsTypeFVs doc a `thenM` \ (t, fvT) ->
+ returnM (HsType t, fvT)
where
- doc = text "in a type argument"
+ doc = text "In a type argument"
rnExpr (ArithSeqIn seq)
- = rn_seq seq `thenRn` \ (new_seq, fvs) ->
- returnRn (ArithSeqIn new_seq, fvs `addOneFV` enumClassName)
+ = rn_seq seq `thenM` \ (new_seq, fvs) ->
+ returnM (ArithSeqIn new_seq, fvs `addOneFV` enumClassName)
where
rn_seq (From expr)
- = rnExpr expr `thenRn` \ (expr', fvExpr) ->
- returnRn (From expr', fvExpr)
+ = rnExpr expr `thenM` \ (expr', fvExpr) ->
+ returnM (From expr', fvExpr)
rn_seq (FromThen expr1 expr2)
- = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
- rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
- returnRn (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
+ = rnExpr expr1 `thenM` \ (expr1', fvExpr1) ->
+ rnExpr expr2 `thenM` \ (expr2', fvExpr2) ->
+ returnM (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 `plusFV` fvExpr2)
+ = rnExpr expr1 `thenM` \ (expr1', fvExpr1) ->
+ rnExpr expr2 `thenM` \ (expr2', fvExpr2) ->
+ returnM (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',
+ = rnExpr expr1 `thenM` \ (expr1', fvExpr1) ->
+ rnExpr expr2 `thenM` \ (expr2', fvExpr2) ->
+ rnExpr expr3 `thenM` \ (expr3', fvExpr3) ->
+ returnM (FromThenTo expr1' expr2' expr3',
plusFVs [fvExpr1, fvExpr2, fvExpr3])
rnExpr (PArrSeqIn seq)
- = rn_seq seq `thenRn` \ (new_seq, fvs) ->
- returnRn (PArrSeqIn new_seq,
+ = rn_seq seq `thenM` \ (new_seq, fvs) ->
+ returnM (PArrSeqIn new_seq,
fvs `plusFV` mkFVs [enumFromToPName, enumFromThenToPName])
where
rn_seq (FromThen _ _) = panic "RnExpr.rnExpr: Infinite parallel array!"
rn_seq (FromTo expr1 expr2)
- = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
- rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
- returnRn (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
+ = rnExpr expr1 `thenM` \ (expr1', fvExpr1) ->
+ rnExpr expr2 `thenM` \ (expr2', fvExpr2) ->
+ returnM (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',
+ = rnExpr expr1 `thenM` \ (expr1', fvExpr1) ->
+ rnExpr expr2 `thenM` \ (expr2', fvExpr2) ->
+ rnExpr expr3 `thenM` \ (expr3', fvExpr3) ->
+ returnM (FromThenTo expr1' expr2' expr3',
plusFVs [fvExpr1, fvExpr2, fvExpr3])
\end{code}
We return a (bogus) EWildPat in each case.
\begin{code}
-rnExpr e@EWildPat = addErrRn (patSynErr e) `thenRn_`
- returnRn (EWildPat, emptyFVs)
+rnExpr e@EWildPat = addErr (patSynErr e) `thenM_`
+ returnM (EWildPat, emptyFVs)
-rnExpr e@(EAsPat _ _) = addErrRn (patSynErr e) `thenRn_`
- returnRn (EWildPat, emptyFVs)
+rnExpr e@(EAsPat _ _) = addErr (patSynErr e) `thenM_`
+ returnM (EWildPat, emptyFVs)
-rnExpr e@(ELazyPat _) = addErrRn (patSynErr e) `thenRn_`
- returnRn (EWildPat, emptyFVs)
+rnExpr e@(ELazyPat _) = addErr (patSynErr e) `thenM_`
+ returnM (EWildPat, emptyFVs)
\end{code}
\begin{code}
rnRbinds str rbinds
- = mapRn_ field_dup_err dup_fields `thenRn_`
- mapFvRn rn_rbind rbinds `thenRn` \ (rbinds', fvRbind) ->
- returnRn (rbinds', fvRbind)
+ = mappM_ field_dup_err dup_fields `thenM_`
+ mapFvRn rn_rbind rbinds `thenM` \ (rbinds', fvRbind) ->
+ returnM (rbinds', fvRbind)
where
- (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rbinds ]
+ (_, dup_fields) = removeDups compare [ f | (f,_) <- rbinds ]
- field_dup_err dups = addErrRn (dupFieldErr str dups)
+ field_dup_err dups = addErr (dupFieldErr str dups)
- rn_rbind (field, expr, pun)
- = lookupGlobalOccRn field `thenRn` \ fieldname ->
- rnExpr expr `thenRn` \ (expr', fvExpr) ->
- returnRn ((fieldname, expr', pun), fvExpr `addOneFV` fieldname)
+ rn_rbind (field, expr)
+ = lookupGlobalOccRn field `thenM` \ fieldname ->
+ rnExpr expr `thenM` \ (expr', fvExpr) ->
+ returnM ((fieldname, expr'), fvExpr `addOneFV` fieldname)
rnRpats rpats
- = mapRn_ field_dup_err dup_fields `thenRn_`
- mapFvRn rn_rpat rpats `thenRn` \ (rpats', fvs) ->
- returnRn (rpats', fvs)
+ = mappM_ field_dup_err dup_fields `thenM_`
+ mapFvRn rn_rpat rpats `thenM` \ (rpats', fvs) ->
+ returnM (rpats', fvs)
where
- (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rpats ]
+ (_, dup_fields) = removeDups compare [ f | (f,_) <- rpats ]
- field_dup_err dups = addErrRn (dupFieldErr "pattern" dups)
+ field_dup_err dups = addErr (dupFieldErr "pattern" dups)
- rn_rpat (field, pat, pun)
- = lookupGlobalOccRn field `thenRn` \ fieldname ->
- rnPat pat `thenRn` \ (pat', fvs) ->
- returnRn ((fieldname, pat', pun), fvs `addOneFV` fieldname)
+ rn_rpat (field, pat)
+ = lookupGlobalOccRn field `thenM` \ fieldname ->
+ rnPat pat `thenM` \ (pat', fvs) ->
+ returnM ((fieldname, pat'), fvs `addOneFV` fieldname)
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-rnIPBinds [] = returnRn ([], emptyFVs)
+rnIPBinds [] = returnM ([], emptyFVs)
rnIPBinds ((n, expr) : binds)
- = newIPName n `thenRn` \ name ->
- rnExpr expr `thenRn` \ (expr',fvExpr) ->
- rnIPBinds binds `thenRn` \ (binds',fvBinds) ->
- returnRn ((name, expr') : binds', fvExpr `plusFV` fvBinds)
+ = newIPName n `thenM` \ name ->
+ rnExpr expr `thenM` \ (expr',fvExpr) ->
+ rnIPBinds binds `thenM` \ (binds',fvBinds) ->
+ returnM ((name, expr') : binds', fvExpr `plusFV` fvBinds)
+
+\end{code}
+
+%************************************************************************
+%* *
+ Template Haskell brackets
+%* *
+%************************************************************************
+\begin{code}
+rnBracket (ExpBr e) = rnExpr e `thenM` \ (e', fvs) ->
+ returnM (ExpBr e', fvs)
+rnBracket (PatBr p) = rnPat p `thenM` \ (p', fvs) ->
+ returnM (PatBr p', fvs)
+rnBracket (TypBr t) = rnHsTypeFVs doc t `thenM` \ (t', fvs) ->
+ returnM (TypBr t', fvs)
+ where
+ doc = ptext SLIT("In a Template-Haskell quoted type")
+rnBracket (DecBr ds) = rnSrcDecls ds `thenM` \ (tcg_env, ds', fvs) ->
+ -- Discard the tcg_env; it contains the extended global RdrEnv
+ -- because there is no scope that these decls cover (yet!)
+ returnM (DecBr ds', fvs)
\end{code}
%************************************************************************
\begin{code}
rnStmts :: [RdrNameStmt]
- -> RnMS (([Name], [RenamedStmt]), FreeVars)
+ -> RnM (([Name], [RenamedStmt]), FreeVars)
rnStmts []
- = returnRn (([], []), emptyFVs)
+ = returnM (([], []), emptyFVs)
rnStmts (stmt:stmts)
- = getLocalNameEnv `thenRn` \ name_env ->
+ = getLocalRdrEnv `thenM` \ name_env ->
rnStmt stmt $ \ stmt' ->
- rnStmts stmts `thenRn` \ ((binders, stmts'), fvs) ->
- returnRn ((binders, stmt' : stmts'), fvs)
+ rnStmts stmts `thenM` \ ((binders, stmts'), fvs) ->
+ returnM ((binders, stmt' : stmts'), fvs)
rnStmt :: RdrNameStmt
- -> (RenamedStmt -> RnMS (([Name], a), FreeVars))
- -> RnMS (([Name], a), FreeVars)
+ -> (RenamedStmt -> RnM (([Name], a), FreeVars))
+ -> RnM (([Name], a), FreeVars)
-- The thing list of names returned is the list returned by the
-- thing_inside, plus the binders of the arguments stmt
rnStmt (ParStmt stmtss) thing_inside
- = mapFvRn rnStmts stmtss `thenRn` \ (bndrstmtss, fv_stmtss) ->
+ = mapFvRn rnStmts stmtss `thenM` \ (bndrstmtss, fv_stmtss) ->
let binderss = map fst bndrstmtss
checkBndrs all_bndrs bndrs
- = checkRn (null (intersectBy eqOcc all_bndrs bndrs)) err `thenRn_`
- returnRn (bndrs ++ all_bndrs)
+ = checkErr (null (intersectBy eqOcc all_bndrs bndrs)) err `thenM_`
+ returnM (bndrs ++ all_bndrs)
eqOcc n1 n2 = nameOccName n1 == nameOccName n2
err = text "duplicate binding in parallel list comprehension"
in
- foldlRn checkBndrs [] binderss `thenRn` \ new_binders ->
+ foldlM checkBndrs [] binderss `thenM` \ new_binders ->
bindLocalNamesFV new_binders $
- thing_inside (ParStmtOut bndrstmtss)`thenRn` \ ((rest_bndrs, result), fv_rest) ->
- returnRn ((new_binders ++ rest_bndrs, result), fv_stmtss `plusFV` fv_rest)
+ thing_inside (ParStmtOut bndrstmtss)`thenM` \ ((rest_bndrs, result), fv_rest) ->
+ returnM ((new_binders ++ rest_bndrs, result), fv_stmtss `plusFV` fv_rest)
rnStmt (BindStmt pat expr src_loc) thing_inside
- = pushSrcLocRn src_loc $
- rnExpr expr `thenRn` \ (expr', fv_expr) ->
+ = addSrcLoc src_loc $
+ rnExpr expr `thenM` \ (expr', fv_expr) ->
bindPatSigTyVars (collectSigTysFromPat pat) $
bindLocalsFVRn doc (collectPatBinders pat) $ \ new_binders ->
- rnPat pat `thenRn` \ (pat', fv_pat) ->
- thing_inside (BindStmt pat' expr' src_loc) `thenRn` \ ((rest_binders, result), fvs) ->
- returnRn ((new_binders ++ rest_binders, result),
+ rnPat pat `thenM` \ (pat', fv_pat) ->
+ thing_inside (BindStmt pat' expr' src_loc) `thenM` \ ((rest_binders, result), fvs) ->
+ returnM ((new_binders ++ rest_binders, result),
fv_expr `plusFV` fvs `plusFV` fv_pat)
where
doc = text "In a pattern in 'do' binding"
rnStmt (ExprStmt expr _ src_loc) thing_inside
- = pushSrcLocRn src_loc $
- rnExpr expr `thenRn` \ (expr', fv_expr) ->
- thing_inside (ExprStmt expr' placeHolderType src_loc) `thenRn` \ (result, fvs) ->
- returnRn (result, fv_expr `plusFV` fvs)
+ = addSrcLoc src_loc $
+ rnExpr expr `thenM` \ (expr', fv_expr) ->
+ thing_inside (ExprStmt expr' placeHolderType src_loc) `thenM` \ (result, fvs) ->
+ returnM (result, fv_expr `plusFV` fvs)
rnStmt (ResultStmt expr src_loc) thing_inside
- = pushSrcLocRn src_loc $
- rnExpr expr `thenRn` \ (expr', fv_expr) ->
- thing_inside (ResultStmt expr' src_loc) `thenRn` \ (result, fvs) ->
- returnRn (result, fv_expr `plusFV` fvs)
+ = addSrcLoc src_loc $
+ rnExpr expr `thenM` \ (expr', fv_expr) ->
+ thing_inside (ResultStmt expr' src_loc) `thenM` \ (result, fvs) ->
+ returnM (result, fv_expr `plusFV` fvs)
rnStmt (LetStmt binds) thing_inside
= rnBinds binds $ \ binds' ->
let new_binders = collectHsBinders binds' in
- thing_inside (LetStmt binds') `thenRn` \ ((rest_binders, result), fvs) ->
- returnRn ((new_binders ++ rest_binders, result), fvs )
+ thing_inside (LetStmt binds') `thenM` \ ((rest_binders, result), fvs) ->
+ returnM ((new_binders ++ rest_binders, result), fvs )
\end{code}
%************************************************************************
-> RenamedHsExpr -> Fixity -- Operator and fixity
-> RenamedHsExpr -- Right operand (not an OpApp, but might
-- be a NegApp)
- -> RnMS RenamedHsExpr
+ -> RnM RenamedHsExpr
---------------------------
-- (e11 `op1` e12) `op2` e2
mkOpAppRn e1@(OpApp e11 op1 fix1 e12) op2 fix2 e2
| nofix_error
- = addErrRn (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenRn_`
- returnRn (OpApp e1 op2 fix2 e2)
+ = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenM_`
+ returnM (OpApp e1 op2 fix2 e2)
| associate_right
- = mkOpAppRn e12 op2 fix2 e2 `thenRn` \ new_e ->
- returnRn (OpApp e11 op1 fix1 new_e)
+ = mkOpAppRn e12 op2 fix2 e2 `thenM` \ new_e ->
+ returnM (OpApp e11 op1 fix1 new_e)
where
(nofix_error, associate_right) = compareFixity fix1 fix2
-- (- neg_arg) `op` e2
mkOpAppRn e1@(NegApp neg_arg neg_name) op2 fix2 e2
| nofix_error
- = addErrRn (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2)) `thenRn_`
- returnRn (OpApp e1 op2 fix2 e2)
+ = addErr (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2)) `thenM_`
+ returnM (OpApp e1 op2 fix2 e2)
| associate_right
- = mkOpAppRn neg_arg op2 fix2 e2 `thenRn` \ new_e ->
- returnRn (NegApp new_e neg_name)
+ = mkOpAppRn neg_arg op2 fix2 e2 `thenM` \ new_e ->
+ returnM (NegApp new_e neg_name)
where
(nofix_error, associate_right) = compareFixity negateFixity fix2
-- e1 `op` - neg_arg
mkOpAppRn e1 op1 fix1 e2@(NegApp neg_arg _) -- NegApp can occur on the right
| not associate_right -- We *want* right association
- = addErrRn (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity)) `thenRn_`
- returnRn (OpApp e1 op1 fix1 e2)
+ = addErr (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity)) `thenM_`
+ returnM (OpApp e1 op1 fix1 e2)
where
(_, associate_right) = compareFixity fix1 negateFixity
= ASSERT2( right_op_ok fix e2,
ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
)
- returnRn (OpApp e1 op fix e2)
+ returnM (OpApp e1 op fix e2)
-- Parser left-associates everything, but
-- derived instances may have correctly-associated things to
mkNegAppRn neg_arg neg_name
=
#ifdef DEBUG
- getModeRn `thenRn` \ mode ->
+ getModeRn `thenM` \ mode ->
ASSERT( not_op_app mode neg_arg )
#endif
- returnRn (NegApp neg_arg neg_name)
+ returnM (NegApp neg_arg neg_name)
not_op_app SourceMode (OpApp _ _ _ _) = False
not_op_app mode other = True
\end{code}
\begin{code}
-mkConOpPatRn :: RenamedPat -> Name -> Fixity -> RenamedPat
- -> RnMS RenamedPat
+mkConOpPatRn :: Name -> Fixity -> RenamedPat -> RenamedPat
+ -> RnM RenamedPat
-mkConOpPatRn p1@(ConOpPatIn p11 op1 fix1 p12)
- op2 fix2 p2
- | nofix_error
- = addErrRn (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenRn_`
- returnRn (ConOpPatIn p1 op2 fix2 p2)
-
- | associate_right
- = mkConOpPatRn p12 op2 fix2 p2 `thenRn` \ new_p ->
- returnRn (ConOpPatIn p11 op1 fix1 new_p)
-
- where
- (nofix_error, associate_right) = compareFixity fix1 fix2
+mkConOpPatRn op2 fix2 p1@(ConPatIn op1 (InfixCon p11 p12)) p2
+ = lookupFixityRn op1 `thenM` \ fix1 ->
+ let
+ (nofix_error, associate_right) = compareFixity fix1 fix2
+ in
+ if nofix_error then
+ addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenM_`
+ returnM (ConPatIn op2 (InfixCon p1 p2))
+ else
+ if associate_right then
+ mkConOpPatRn op2 fix2 p12 p2 `thenM` \ new_p ->
+ returnM (ConPatIn op1 (InfixCon p11 new_p))
+ else
+ returnM (ConPatIn op2 (InfixCon p1 p2))
-mkConOpPatRn p1 op fix p2 -- Default case, no rearrangment
+mkConOpPatRn op fix p1 p2 -- Default case, no rearrangment
= ASSERT( not_op_pat p2 )
- returnRn (ConOpPatIn p1 op fix p2)
+ returnM (ConPatIn op (InfixCon p1 p2))
-not_op_pat (ConOpPatIn _ _ _ _) = False
-not_op_pat other = True
+not_op_pat (ConPatIn _ (InfixCon _ _)) = False
+not_op_pat other = True
\end{code}
\begin{code}
-checkPrecMatch :: Bool -> Name -> RenamedMatch -> RnMS ()
+checkPrecMatch :: Bool -> Name -> RenamedMatch -> RnM ()
checkPrecMatch False fn match
- = returnRn ()
+ = returnM ()
checkPrecMatch True op (Match (p1:p2:_) _ _)
-- True indicates an infix lhs
- = getModeRn `thenRn` \ mode ->
+ = getModeRn `thenM` \ mode ->
-- See comments with rnExpr (OpApp ...)
if isInterfaceMode mode
- then returnRn ()
- else checkPrec op p1 False `thenRn_`
+ then returnM ()
+ else checkPrec op p1 False `thenM_`
checkPrec op p2 True
checkPrecMatch True op _ = panic "checkPrecMatch"
-checkPrec op (ConOpPatIn _ op1 _ _) right
- = lookupFixityRn op `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
- lookupFixityRn op1 `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) ->
+checkPrec op (ConPatIn op1 (InfixCon _ _)) right
+ = lookupFixityRn op `thenM` \ op_fix@(Fixity op_prec op_dir) ->
+ lookupFixityRn op1 `thenM` \ op1_fix@(Fixity op1_prec op1_dir) ->
let
inf_ok = op1_prec > op_prec ||
(op1_prec == op_prec &&
info1 = (ppr_op op1, op1_fix)
(infol, infor) = if right then (info, info1) else (info1, info)
in
- checkRn inf_ok (precParseErr infol infor)
+ checkErr inf_ok (precParseErr infol infor)
checkPrec op pat right
- = returnRn ()
+ = returnM ()
-- Check precedence of (arg op) or (op arg) respectively
-- If arg is itself an operator application, then either
= case arg of
OpApp _ op fix _ -> go_for_it (ppr_op op) fix
NegApp _ _ -> go_for_it pp_prefix_minus negateFixity
- other -> returnRn ()
+ other -> returnM ()
where
HsVar op_name = op
go_for_it pp_arg_op arg_fix@(Fixity arg_prec assoc)
- = lookupFixityRn op_name `thenRn` \ op_fix@(Fixity op_prec _) ->
- checkRn (op_prec < arg_prec
+ = lookupFixityRn op_name `thenM` \ op_fix@(Fixity op_prec _) ->
+ checkErr (op_prec < arg_prec
|| op_prec == arg_prec && direction == assoc)
(sectionPrecErr (ppr_op op_name, op_fix)
(pp_arg_op, arg_fix) section)
\begin{code}
litFVs (HsChar c)
- = checkRn (inCharRange c) (bogusCharError c) `thenRn_`
- returnRn (unitFV charTyCon_name)
-
-litFVs (HsCharPrim c) = returnRn (unitFV (getName charPrimTyCon))
-litFVs (HsString s) = returnRn (mkFVs [listTyCon_name, charTyCon_name])
-litFVs (HsStringPrim s) = returnRn (unitFV (getName addrPrimTyCon))
-litFVs (HsInt i) = returnRn (unitFV (getName intTyCon))
-litFVs (HsIntPrim i) = returnRn (unitFV (getName intPrimTyCon))
-litFVs (HsFloatPrim f) = returnRn (unitFV (getName floatPrimTyCon))
-litFVs (HsDoublePrim d) = returnRn (unitFV (getName doublePrimTyCon))
-litFVs (HsLitLit l bogus_ty) = returnRn (unitFV cCallableClassName)
+ = checkErr (inCharRange c) (bogusCharError c) `thenM_`
+ returnM (unitFV charTyCon_name)
+
+litFVs (HsCharPrim c) = returnM (unitFV (getName charPrimTyCon))
+litFVs (HsString s) = returnM (mkFVs [listTyCon_name, charTyCon_name])
+litFVs (HsStringPrim s) = returnM (unitFV (getName addrPrimTyCon))
+litFVs (HsInt i) = returnM (unitFV (getName intTyCon))
+litFVs (HsIntPrim i) = returnM (unitFV (getName intPrimTyCon))
+litFVs (HsFloatPrim f) = returnM (unitFV (getName floatPrimTyCon))
+litFVs (HsDoublePrim d) = returnM (unitFV (getName doublePrimTyCon))
+litFVs (HsLitLit l bogus_ty) = returnM (unitFV cCallableClassName)
litFVs lit = pprPanic "RnExpr.litFVs" (ppr lit) -- HsInteger and HsRat only appear
-- in post-typechecker translations
rnOverLit (HsIntegral i _)
- = lookupSyntaxName fromIntegerName `thenRn` \ (from_integer_name, fvs) ->
+ = lookupSyntaxName fromIntegerName `thenM` \ (from_integer_name, fvs) ->
if inIntRange i then
- returnRn (HsIntegral i from_integer_name, fvs)
+ returnM (HsIntegral i from_integer_name, fvs)
else let
extra_fvs = mkFVs [plusIntegerName, timesIntegerName]
-- Big integer literals are built, using + and *,
-- they are used to construct the argument to fromInteger,
-- which is the rebindable one.]
in
- returnRn (HsIntegral i from_integer_name, fvs `plusFV` extra_fvs)
+ returnM (HsIntegral i from_integer_name, fvs `plusFV` extra_fvs)
rnOverLit (HsFractional i _)
- = lookupSyntaxName fromRationalName `thenRn` \ (from_rat_name, fvs) ->
+ = lookupSyntaxName fromRationalName `thenM` \ (from_rat_name, fvs) ->
let
extra_fvs = mkFVs [ratioDataConName, plusIntegerName, timesIntegerName]
-- We have to make sure that the Ratio type is imported with
-- The plus/times integer operations may be needed to construct the numerator
-- and denominator (see DsUtils.mkIntegerLit)
in
- returnRn (HsFractional i from_rat_name, fvs `plusFV` extra_fvs)
+ returnM (HsFractional i from_rat_name, fvs `plusFV` extra_fvs)
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-mkAssertExpr :: RnMS (RenamedHsExpr, FreeVars)
-mkAssertExpr =
- lookupOrigName assertErr_RDR `thenRn` \ name ->
- getSrcLocRn `thenRn` \ sloc ->
+mkAssertExpr :: RnM (RenamedHsExpr, FreeVars)
+mkAssertExpr
+ = getSrcLocM `thenM` \ sloc ->
-- if we're ignoring asserts, return (\ _ e -> e)
-- if not, return (assertError "src-loc")
- if opt_IgnoreAsserts then
- getUniqRn `thenRn` \ uniq ->
- let
- vname = mkSystemName uniq FSLIT("v")
- expr = HsLam ignorePredMatch
- loc = nameSrcLoc vname
- ignorePredMatch = mkSimpleMatch [WildPatIn, VarPatIn vname] (HsVar vname) placeHolderType loc
- in
- returnRn (expr, unitFV name)
- else
- let
- expr =
- HsApp (HsVar name)
+ if opt_IgnoreAsserts then
+ newUnique `thenM` \ uniq ->
+ let
+ vname = mkSystemName uniq FSLIT("v")
+ expr = HsLam ignorePredMatch
+ loc = nameSrcLoc vname
+ ignorePredMatch = mkSimpleMatch [WildPat placeHolderType, VarPat vname]
+ (HsVar vname) placeHolderType loc
+ in
+ returnM (expr, emptyFVs)
+ else
+ let
+ expr =
+ HsApp (HsVar assertName)
(HsLit (HsStringPrim (mkFastString (stringToUtf8 (showSDoc (ppr sloc))))))
- in
- returnRn (expr, unitFV name)
+ in
+ returnM (expr, unitFV assertName)
\end{code}
%************************************************************************
= sep [ptext SLIT("Pattern syntax in expression context:"),
nest 4 (ppr e)]
+thErr what
+ = ptext SLIT("Template Haskell") <+> text what <+>
+ ptext SLIT("illegal in a stage-1 compiler")
+
doStmtListErr e
= sep [ptext SLIT("`do' statements must end in expression:"),
nest 4 (ppr e)]
__interface RnHiFiles 1 0 where
__export RnHiFiles loadInterface;
-1 loadInterface :: __forall [d] => Outputable.SDoc -> Module.ModuleName -> Module.WhereFrom -> RnMonad.RnM d HscTypes.ModIface;
+1 loadInterface :: __forall [m] => Outputable.SDoc -> Module.ModuleName -> TcRnTypes.WhereFrom
+ -> TcRnTypes.TcRn m HscTypes.ModIface;
loadInterface
:: Outputable.SDoc
-> Module.ModuleName
- -> Module.WhereFrom
- -> RnMonad.RnM d HscTypes.ModIface
+ -> TcRnTypes.WhereFrom
+ -> TcRnTypes.TcRn m HscTypes.ModIface
\begin{code}
module RnHiFiles (
- readIface, findAndReadIface, loadInterface, loadHomeInterface,
- tryLoadInterface, loadOrphanModules,
- loadExports, loadFixDecls, loadDeprecs,
-
- getTyClDeclBinders
+ readIface, loadInterface, loadHomeInterface,
+ loadOrphanModules,
+ loadOldIface,
+ ParsedIface(..)
) where
#include "HsVersions.h"
import DriverUtil ( splitFilename )
import CmdLineOpts ( opt_IgnoreIfacePragmas )
import Parser ( parseIface )
-import HscTypes ( ModuleLocation(..),
- ModIface(..), emptyModIface,
+import HscTypes ( ModIface(..), emptyModIface,
+ ExternalPackageState(..),
VersionInfo(..), ImportedModuleInfo,
- lookupIfaceByModName, RdrExportItem,
+ lookupIfaceByModName, RdrExportItem, WhatsImported(..),
ImportVersion, WhetherHasOrphans, IsBootInterface,
- DeclsMap, GatedDecl, IfaceInsts, IfaceRules,
- AvailInfo, GenAvailInfo(..), Avails, Deprecations(..)
+ DeclsMap, GatedDecl, IfaceInsts, IfaceRules, mkIfaceDecls,
+ AvailInfo, GenAvailInfo(..), ParsedIface(..), IfaceDeprecs,
+ Avails, availNames, availName, Deprecations(..)
)
-import HsSyn ( TyClDecl(..), InstDecl(..), RuleDecl(..),
- tyClDeclNames, tyClDeclSysNames, hsTyVarNames,
- getHsInstHead,
+import HsSyn ( TyClDecl(..), InstDecl(..), RuleDecl(..), ConDecl(..),
+ hsTyVarNames, splitHsInstDeclTy, tyClDeclName, tyClDeclNames
)
import RdrHsSyn ( RdrNameTyClDecl, RdrNameInstDecl, RdrNameRuleDecl )
-import RnHsSyn ( extractHsTyNames_s )
-import BasicTypes ( Version )
+import RnHsSyn ( RenamedInstDecl, RenamedRuleDecl, RenamedTyClDecl,
+ extractHsTyNames_s )
+import BasicTypes ( Version, FixitySig(..), Fixity(..), FixityDirection(..) )
+import RnSource ( rnIfaceRuleDecl, rnTyClDecl, rnInstDecl )
import RnTypes ( rnHsType )
import RnEnv
-import RnMonad
+import TcRnMonad
import PrelNames ( gHC_PRIM_Name, gHC_PRIM )
+import PrelInfo ( ghcPrimExports, cCallableClassDecl, cReturnableClassDecl, assertDecl )
import Name ( Name {-instance NamedThing-},
- nameModule, isInternalName
- )
+ nameModule, isInternalName )
import NameEnv
import NameSet
-import Module
-import RdrName ( rdrNameOcc )
-import SrcLoc ( mkSrcLoc )
+import Id ( idName )
+import MkId ( seqId )
+import Packages ( preludePackage )
+import Module ( Module, ModuleName, ModLocation(ml_hi_file),
+ moduleName, isHomeModule, mkVanillaModule,
+ extendModuleEnv
+ )
+import RdrName ( RdrName, mkRdrUnqual, rdrNameOcc, nameRdrName )
+import OccName ( OccName, mkWorkerOcc, mkClassTyConOcc, mkClassDataConOcc,
+ mkSuperDictSelOcc, mkGenOcc1, mkGenOcc2 )
+import TyCon ( DataConDetails(..) )
+import SrcLoc ( noSrcLoc, mkSrcLoc )
import Maybes ( maybeToBool )
import StringBuffer ( hGetStringBuffer )
import FastString ( mkFastString )
import ListSetOps ( minusList )
import Outputable
import Bag
-import BinIface ( {- just instances -} )
-import qualified Binary
+import BinIface ( readBinIface )
import Panic
import Config
import EXCEPTION as Exception
-import DYNAMIC ( fromDynamic )
import DATA_IOREF ( readIORef )
import Directory
-import List ( isSuffixOf )
\end{code}
%*********************************************************
\begin{code}
-loadHomeInterface :: SDoc -> Name -> RnM d ModIface
+loadHomeInterface :: SDoc -> Name -> TcRn m ModIface
loadHomeInterface doc_str name
= ASSERT2( not (isInternalName name), ppr name <+> parens doc_str )
loadInterface doc_str (moduleName (nameModule name)) ImportBySystem
-loadOrphanModules :: [ModuleName] -> RnM d ()
+loadOrphanModules :: [ModuleName] -> TcRn m ()
loadOrphanModules mods
- | null mods = returnRn ()
+ | null mods = returnM ()
| otherwise = traceRn (text "Loading orphan modules:" <+>
- fsep (map ppr mods)) `thenRn_`
- mapRn_ load mods `thenRn_`
- returnRn ()
+ fsep (map ppr mods)) `thenM_`
+ mappM_ load mods `thenM_`
+ returnM ()
where
load mod = loadInterface (mk_doc mod) mod ImportBySystem
mk_doc mod = ppr mod <+> ptext SLIT("is a orphan-instance module")
-loadInterface :: SDoc -> ModuleName -> WhereFrom -> RnM d ModIface
-loadInterface doc mod from
- = tryLoadInterface doc mod from `thenRn` \ (ifaces, maybe_err) ->
- case maybe_err of
- Nothing -> returnRn ifaces
- Just err -> failWithRn ifaces (elaborate err)
- where
- elaborate err = hang (ptext SLIT("failed to load interface for") <+> quotes (ppr mod) <> colon)
- 4 err
-
-tryLoadInterface :: SDoc -> ModuleName -> WhereFrom -> RnM d (ModIface, Maybe Message)
- -- Returns (Just err) if an error happened
- -- It *doesn't* add an error to the monad, because sometimes it's ok to fail...
- -- Specifically, when we read the usage information from an interface file,
- -- we try to read the interfaces it mentions. But it's OK to fail; perhaps
- -- the module has changed, and that interface is no longer used.
+loadInterface :: SDoc -> ModuleName -> WhereFrom -> TcRn m ModIface
+ -- Returns Nothing if failed
+ -- If we can't find an interface file, and we are doing ImportForUsage,
+ -- just fail in the monad, and modify anything else
+ -- Otherwise, if we can't find an interface file,
+ -- add an error message to the monad (the first time only)
+ -- and return emptyIface
+ -- The "first time only" part is done by modifying the PackageIfaceTable
+ -- to have an empty entry
+ --
+ -- The ImportForUsage case is because when we read the usage information from
+ -- an interface file, we try to read the interfaces it mentions.
+ -- But it's OK to fail; perhaps the module has changed, and that interface
+ -- is no longer used.
- -- tryLoadInterface guarantees to return with iImpModInfo m --> (..., True)
+ -- tryLoadInterface guarantees to return with eps_mod_info m --> (..., True)
-- (If the load fails, we plug in a vanilla placeholder)
-tryLoadInterface doc_str mod_name from
- = getHomeIfaceTableRn `thenRn` \ hit ->
- getModuleRn `thenRn` \ this_mod ->
- getIfacesRn `thenRn` \ ifaces@(Ifaces { iPIT = pit }) ->
+loadInterface doc_str mod_name from
+ = getHpt `thenM` \ hpt ->
+ getModule `thenM` \ this_mod ->
+ getEps `thenM` \ eps@(EPS { eps_PIT = pit }) ->
-- CHECK WHETHER WE HAVE IT ALREADY
- case lookupIfaceByModName hit pit mod_name of {
+ case lookupIfaceByModName hpt pit mod_name of {
Just iface | case from of
- ImportByUser -> not (mi_boot iface)
- ImportByUserSource -> mi_boot iface
- ImportBySystem -> True
- -> returnRn (iface, Nothing) ; -- Already loaded
+ ImportByUser src_imp -> src_imp == mi_boot iface
+ ImportForUsage src_imp -> src_imp == mi_boot iface
+ ImportBySystem -> True
+ -> returnM iface ; -- Already loaded
-- The not (mi_boot iface) test checks that the already-loaded
-- interface isn't a boot iface. This can conceivably happen,
-- if the version checking happened to load a boot interface
other ->
let
- mod_map = iImpModInfo ifaces
+ mod_map = eps_imp_mods eps
mod_info = lookupFM mod_map mod_name
hi_boot_file
= case (from, mod_info) of
- (ImportByUser, _) -> False -- Not hi-boot
- (ImportByUserSource, _) -> True -- hi-boot
+ (ImportByUser is_boot, _) -> is_boot
+ (ImportForUsage is_boot, _) -> is_boot
(ImportBySystem, Just (_, is_boot)) -> is_boot
(ImportBySystem, Nothing) -> False
-- We're importing a module we know absolutely
redundant_source_import
= case (from, mod_info) of
- (ImportByUserSource, Just (_,False)) -> True
- other -> False
+ (ImportByUser True, Just (_,False)) -> True
+ other -> False
in
-- Issue a warning for a redundant {- SOURCE -} import
-- NB that we arrange to read all the ordinary imports before
-- any of the {- SOURCE -} imports
- warnCheckRn (not redundant_source_import)
- (warnRedundantSourceImport mod_name) `thenRn_`
+ warnIf redundant_source_import
+ (warnRedundantSourceImport mod_name) `thenM_`
-- Check that we aren't importing ourselves.
-- That only happens in Rename.checkOldIface,
- -- which doesn't call tryLoadInterface
- warnCheckRn
- (not (isHomeModule this_mod) || moduleName this_mod /= mod_name)
- (warnSelfImport this_mod) `thenRn_`
+ -- which doesn't call loadInterface
+ warnIf
+ (isHomeModule this_mod && moduleName this_mod == mod_name)
+ (warnSelfImport this_mod) `thenM_`
-- READ THE MODULE IN
findAndReadIface doc_str mod_name hi_boot_file
- `thenRn` \ read_result ->
+ `thenM` \ read_result ->
case read_result of {
- Left err -> -- Not found, so add an empty export env to the Ifaces map
- -- so that we don't look again
- let
- fake_mod = mkVanillaModule mod_name
- fake_iface = emptyModIface fake_mod
- new_ifaces = ifaces { iPIT = extendModuleEnv pit fake_mod fake_iface }
- in
- setIfacesRn new_ifaces `thenRn_`
- returnRn (fake_iface, Just err) ;
+ Left err
+ | case from of { ImportForUsage _ -> True ; other -> False }
+ -> failM -- Fail with no error messages
+
+ | otherwise
+ -> let -- Not found, so add an empty export env to
+ -- the EPS map so that we don't look again
+ fake_mod = mkVanillaModule mod_name
+ fake_iface = emptyModIface fake_mod
+ new_eps = eps { eps_PIT = extendModuleEnv pit fake_mod fake_iface }
+ in
+ setEps new_eps `thenM_`
+ addErr (elaborate err) `thenM_`
+ returnM fake_iface
+ where
+ elaborate err = hang (ptext SLIT("Failed to load interface for") <+>
+ quotes (ppr mod_name) <> colon) 4 err
+ ;
-- Found and parsed!
Right (mod, iface) ->
- -- LOAD IT INTO Ifaces
+ -- LOAD IT INTO EPS
-- 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).
isHomeModule mod,
ppr mod )
- loadDecls mod (iDecls ifaces) (pi_decls iface) `thenRn` \ (decls_vers, new_decls) ->
- loadRules mod (iRules ifaces) (pi_rules iface) `thenRn` \ (rule_vers, new_rules) ->
- loadInstDecls mod (iInsts ifaces) (pi_insts iface) `thenRn` \ new_insts ->
- loadExports (pi_exports iface) `thenRn` \ (export_vers, avails) ->
- loadFixDecls mod (pi_fixity iface) `thenRn` \ fix_env ->
- loadDeprecs mod (pi_deprecs iface) `thenRn` \ deprec_env ->
- let
+ initRn (InterfaceMode mod) $
+ -- Set the module, for use when looking up occurrences
+ -- of names in interface decls and rules
+ loadDecls mod (eps_decls eps) (pi_decls iface) `thenM` \ (decls_vers, new_decls) ->
+ loadRules mod (eps_rules eps) (pi_rules iface) `thenM` \ (rule_vers, new_rules) ->
+ loadInstDecls mod (eps_insts eps) (pi_insts iface) `thenM` \ new_insts ->
+ loadExports (pi_exports iface) `thenM` \ (export_vers, avails) ->
+ loadFixDecls (pi_fixity iface) `thenM` \ fix_env ->
+ loadDeprecs (pi_deprecs iface) `thenM` \ deprec_env ->
+ let
version = VersionInfo { vers_module = pi_vers iface,
vers_exports = export_vers,
vers_rules = rule_vers,
-- For an explicit user import, add to mod_map info about
-- the things the imported module depends on, extracted
-- from its usage info; and delete the module itself, which is now in the PIT
+ usages = pi_usages iface
mod_map1 = case from of
- ImportByUser -> addModDeps mod is_loaded (pi_usages iface) mod_map
- other -> mod_map
+ ImportByUser _ -> addModDeps mod is_loaded usages mod_map
+ other -> mod_map
mod_map2 = delFromFM mod_map1 mod_name
+ -- mod_deps is a pruned version of usages that records only what
+ -- module imported, but nothing about versions.
+ -- This info is used when demand-linking the dependencies
+ mod_deps = [ (mod,orph,boot,NothingAtAll) | (mod,orph,boot,_) <- usages]
+
this_mod_name = moduleName this_mod
is_loaded m = m == this_mod_name
- || maybeToBool (lookupIfaceByModName hit pit m)
+ || maybeToBool (lookupIfaceByModName hpt pit m)
-- We treat the currently-being-compiled module as 'loaded' because
-- even though it isn't yet in the HIT or PIT; otherwise it gets
-- put into iImpModInfo, and then spat out into its own interface
mi_orphan = has_orphans, mi_boot = hi_boot_file,
mi_exports = avails,
mi_fixities = fix_env, mi_deprecs = deprec_env,
- mi_usages = [], -- Will be filled in later
- mi_decls = panic "No mi_decls in PIT",
- mi_globals = Nothing
+ mi_usages = mod_deps, -- Used for demand-loading,
+ -- not for version info
+ mi_decls = panic "No mi_decls in PIT",
+ mi_globals = Nothing
}
- new_ifaces = ifaces { iPIT = new_pit,
- iDecls = new_decls,
- iInsts = new_insts,
- iRules = new_rules,
- iImpModInfo = mod_map2 }
+ new_eps = eps { eps_PIT = new_pit,
+ eps_decls = new_decls,
+ eps_insts = new_insts,
+ eps_rules = new_rules,
+ eps_imp_mods = mod_map2 }
in
- setIfacesRn new_ifaces `thenRn_`
- returnRn (mod_iface, Nothing)
+ setEps new_eps `thenM_`
+ returnM mod_iface
}}
-----------------------------------------------------
-- Loading the export list
-----------------------------------------------------
-loadExports :: (Version, [RdrExportItem]) -> RnM d (Version, [(ModuleName,Avails)])
+loadExports :: (Version, [RdrExportItem]) -> TcRn m (Version, [(ModuleName,Avails)])
loadExports (vers, items)
- = mapRn loadExport items `thenRn` \ avails_s ->
- returnRn (vers, avails_s)
+ = mappM loadExport items `thenM` \ avails_s ->
+ returnM (vers, avails_s)
-loadExport :: RdrExportItem -> RnM d (ModuleName, Avails)
+loadExport :: RdrExportItem -> TcRn m (ModuleName, Avails)
loadExport (mod, entities)
- = mapRn (load_entity mod) entities `thenRn` \ avails ->
- returnRn (mod, avails)
+ = mappM (load_entity mod) entities `thenM` \ avails ->
+ returnM (mod, avails)
where
load_entity mod (Avail occ)
- = newGlobalName mod occ `thenRn` \ name ->
- returnRn (Avail name)
+ = newGlobalName mod occ `thenM` \ name ->
+ returnM (Avail name)
load_entity mod (AvailTC occ occs)
- = newGlobalName mod occ `thenRn` \ name ->
- mapRn (newGlobalName mod) occs `thenRn` \ names ->
- returnRn (AvailTC name names)
+ = newGlobalName mod occ `thenM` \ name ->
+ mappM (newGlobalName mod) occs `thenM` \ names ->
+ returnM (AvailTC name names)
-----------------------------------------------------
loadDecls :: Module
-> DeclsMap
-> [(Version, RdrNameTyClDecl)]
- -> RnM d (NameEnv Version, DeclsMap)
+ -> TcRn m (NameEnv Version, DeclsMap)
loadDecls mod (decls_map, n_slurped) decls
- = foldlRn (loadDecl mod) (emptyNameEnv, decls_map) decls `thenRn` \ (vers, decls_map') ->
- returnRn (vers, (decls_map', n_slurped))
+ = foldlM (loadDecl mod) (emptyNameEnv, decls_map) decls `thenM` \ (vers, decls_map') ->
+ returnM (vers, (decls_map', n_slurped))
loadDecl mod (version_map, decls_map) (version, decl)
- = getTyClDeclBinders mod decl `thenRn` \ (avail, sys_names) ->
+ = getTyClDeclBinders mod decl `thenM` \ avail ->
+ getSysBinders mod decl `thenM` \ sys_names ->
let
full_avail = case avail of
Avail n -> avail
new_version_map = extendNameEnv version_map main_name version
in
- traceRn (text "Loading" <+> ppr full_avail) `thenRn_`
- returnRn (new_version_map, new_decls_map)
+ traceRn (text "Loading" <+> ppr full_avail) `thenM_`
+ returnM (new_version_map, new_decls_map)
+
+
+
+-----------------
+getTyClDeclBinders :: Module -> RdrNameTyClDecl -> TcRn m AvailInfo
+
+getTyClDeclBinders mod (IfaceSig {tcdName = var, tcdLoc = src_loc})
+ = newTopBinder mod var src_loc `thenM` \ var_name ->
+ returnM (Avail var_name)
+
+getTyClDeclBinders mod tycl_decl
+ = mapM new (tyClDeclNames tycl_decl) `thenM` \ names@(main_name:_) ->
+ returnM (AvailTC main_name names)
+ where
+ new (nm,loc) = newTopBinder mod nm loc
+
+--------------------------------
+-- The "system names" are extra implicit names *bound* by the decl.
+
+getSysBinders :: Module -> TyClDecl RdrName -> TcRn m [Name]
+-- Similar to tyClDeclNames, but returns the "implicit"
+-- or "system" names of the declaration. And it only works
+-- on RdrNames, returning OccNames
+
+getSysBinders mod (ClassDecl {tcdName = cname, tcdCtxt = cxt, tcdLoc = loc})
+ = sequenceM [new_sys_bndr mod n loc | n <- sys_occs]
+ where
+ -- C.f. TcClassDcl.tcClassDecl1
+ sys_occs = tc_occ : data_occ : dw_occ : sc_sel_occs
+ cls_occ = rdrNameOcc cname
+ data_occ = mkClassDataConOcc cls_occ
+ dw_occ = mkWorkerOcc data_occ
+ tc_occ = mkClassTyConOcc cls_occ
+ sc_sel_occs = [mkSuperDictSelOcc n cls_occ | n <- [1..length cxt]]
+
+getSysBinders mod (TyData {tcdName = tc_name, tcdCons = DataCons cons,
+ tcdGeneric = Just want_generic, tcdLoc = loc})
+ -- The 'Just' is because this is an interface-file decl
+ -- so it will say whether to derive generic stuff for it or not
+ = sequenceM ([new_sys_bndr mod n loc | n <- gen_occs] ++
+ map con_sys_occ cons)
+ where
+ -- c.f. TcTyDecls.tcTyDecl
+ tc_occ = rdrNameOcc tc_name
+ gen_occs | want_generic = [mkGenOcc1 tc_occ, mkGenOcc2 tc_occ]
+ | otherwise = []
+ con_sys_occ (ConDecl name _ _ _ loc)
+ = new_sys_bndr mod (mkWorkerOcc (rdrNameOcc name)) loc
+
+getSysBinders mod decl = returnM []
+
+new_sys_bndr mod occ loc = newTopBinder mod (mkRdrUnqual occ) loc
+
-----------------------------------------------------
-- Loading fixity decls
-----------------------------------------------------
-loadFixDecls mod decls
- = mapRn (loadFixDecl mod_name) decls `thenRn` \ to_add ->
- returnRn (mkNameEnv to_add)
- where
- mod_name = moduleName mod
+loadFixDecls decls
+ = mappM loadFixDecl decls `thenM` \ to_add ->
+ returnM (mkNameEnv to_add)
-loadFixDecl mod_name (rdr_name, fixity)
- = newGlobalName mod_name (rdrNameOcc rdr_name) `thenRn` \ name ->
- returnRn (name, fixity)
+loadFixDecl (FixitySig rdr_name fixity loc)
+ = lookupGlobalOccRn rdr_name `thenM` \ name ->
+ returnM (name, FixitySig name fixity loc)
-----------------------------------------------------
-- Loading instance decls
-----------------------------------------------------
-loadInstDecls :: Module
- -> IfaceInsts
+loadInstDecls :: Module -> IfaceInsts
-> [RdrNameInstDecl]
- -> RnM d IfaceInsts
+ -> RnM IfaceInsts
loadInstDecls mod (insts, n_slurped) decls
- = setModuleRn mod $
- foldlRn (loadInstDecl mod) insts decls `thenRn` \ insts' ->
- returnRn (insts', n_slurped)
+ = foldlM (loadInstDecl mod) insts decls `thenM` \ insts' ->
+ returnM (insts', n_slurped)
loadInstDecl mod insts decl@(InstDecl inst_ty _ _ _ _)
-- NOTICE that we rename the type before extracting its free
-- variables. The free-variable finder for a renamed HsType
-- does the Right Thing for built-in syntax like [] and (,).
- initIfaceRnMS mod (
- rnHsType (text "In an interface instance decl") inst_ty
- ) `thenRn` \ inst_ty' ->
+ rnHsType (text "In an interface instance decl") inst_ty `thenM` \ inst_ty' ->
let
- (tvs,(cls,tys)) = getHsInstHead inst_ty'
+ (tvs,_,cls,tys) = splitHsInstDeclTy inst_ty'
free_tcs = nameSetToList (extractHsTyNames_s tys) `minusList` hsTyVarNames tvs
gate_fn vis_fn = vis_fn cls && (null free_tcs || any vis_fn free_tcs)
+ -- The 'vis_fn' returns True for visible names
-- Here is the implementation of HOWEVER above
-- (Note that we do let the inst decl in if it mentions
-- no tycons at all. Hence the null free_ty_names.)
in
- returnRn ((gate_fn, (mod, decl)) `consBag` insts)
+ traceRn ((text "Load instance for" <+> ppr inst_ty') $$ ppr free_tcs) `thenM_`
+ returnM ((gate_fn, (mod, decl)) `consBag` insts)
-- Loading Rules
-----------------------------------------------------
-loadRules :: Module -> IfaceRules
+loadRules :: Module
+ -> IfaceRules
-> (Version, [RdrNameRuleDecl])
- -> RnM d (Version, IfaceRules)
+ -> RnM (Version, IfaceRules)
loadRules mod (rule_bag, n_slurped) (version, rules)
| null rules || opt_IgnoreIfacePragmas
- = returnRn (version, (rule_bag, n_slurped))
+ = returnM (version, (rule_bag, n_slurped))
| otherwise
- = setModuleRn mod $
- mapRn (loadRule mod) rules `thenRn` \ new_rules ->
- returnRn (version, (rule_bag `unionBags` listToBag new_rules, n_slurped))
+ = mappM (loadRule mod) rules `thenM` \ new_rules ->
+ returnM (version, (rule_bag `unionBags` listToBag new_rules, n_slurped))
-loadRule :: Module -> RdrNameRuleDecl -> RnM d (GatedDecl RdrNameRuleDecl)
+loadRule :: Module -> RdrNameRuleDecl -> RnM (GatedDecl RdrNameRuleDecl)
-- "Gate" the rule simply by whether the rule variable is
-- needed. We can refine this later.
loadRule mod decl@(IfaceRule _ _ _ var _ _ src_loc)
- = lookupIfaceName var `thenRn` \ var_name ->
- returnRn (\vis_fn -> vis_fn var_name, (mod, decl))
+ = lookupGlobalOccRn var `thenM` \ var_name ->
+ returnM (\vis_fn -> vis_fn var_name, (mod, decl))
-----------------------------------------------------
-- Loading Deprecations
-----------------------------------------------------
-loadDeprecs :: Module -> IfaceDeprecs -> RnM d Deprecations
-loadDeprecs m Nothing = returnRn NoDeprecs
-loadDeprecs m (Just (Left txt)) = returnRn (DeprecAll txt)
-loadDeprecs m (Just (Right prs)) = setModuleRn m $
- foldlRn loadDeprec emptyNameEnv prs `thenRn` \ env ->
- returnRn (DeprecSome env)
+loadDeprecs :: IfaceDeprecs -> RnM Deprecations
+loadDeprecs Nothing = returnM NoDeprecs
+loadDeprecs (Just (Left txt)) = returnM (DeprecAll txt)
+loadDeprecs (Just (Right prs)) = foldlM loadDeprec emptyNameEnv prs `thenM` \ env ->
+ returnM (DeprecSome env)
loadDeprec deprec_env (n, txt)
- = lookupIfaceName n `thenRn` \ name ->
- traceRn (text "Loaded deprecation(s) for" <+> ppr name <> colon <+> ppr txt) `thenRn_`
- returnRn (extendNameEnv deprec_env name (name,txt))
+ = lookupGlobalOccRn n `thenM` \ name ->
+ traceRn (text "Loaded deprecation(s) for" <+> ppr name <> colon <+> ppr txt) `thenM_`
+ returnM (extendNameEnv deprec_env name (name,txt))
\end{code}
-%*********************************************************
+%********************************************************
%* *
-\subsection{Getting binders out of a declaration}
+ Load the ParsedIface for the *current* module
+ into a ModIface; then it can be checked
+ for up-to-date-ness
%* *
-%*********************************************************
-
-@getDeclBinders@ returns the names for a @RdrNameHsDecl@.
-It's used for both source code (from @availsFromDecl@) and interface files
-(from @loadDecl@).
-
-It doesn't deal with source-code specific things: @ValD@, @DefD@. They
-are handled by the sourc-code specific stuff in @RnNames@.
-
- *** See "THE NAMING STORY" in HsDecls ****
-
+%********************************************************
\begin{code}
-getTyClDeclBinders
- :: Module
- -> RdrNameTyClDecl
- -> RnM d (AvailInfo, [Name]) -- The [Name] are the system names
-
------------------
-getTyClDeclBinders mod (IfaceSig {tcdName = var, tcdLoc = src_loc})
- = newTopBinder mod var src_loc `thenRn` \ var_name ->
- returnRn (Avail var_name, [])
+loadOldIface :: ParsedIface -> RnM ModIface
+
+loadOldIface iface
+ = loadHomeDecls (pi_decls iface) `thenM` \ (decls_vers, new_decls) ->
+ loadHomeRules (pi_rules iface) `thenM` \ (rule_vers, new_rules) ->
+ loadHomeInsts (pi_insts iface) `thenM` \ new_insts ->
+ mappM loadHomeUsage (pi_usages iface) `thenM` \ usages ->
+ loadExports (pi_exports iface) `thenM` \ (export_vers, avails) ->
+ loadFixDecls (pi_fixity iface) `thenM` \ fix_env ->
+ loadDeprecs (pi_deprecs iface) `thenM` \ deprec_env ->
+
+ getModeRn `thenM` \ (InterfaceMode mod) ->
+ -- Caller sets the module before the call; also needed
+ -- by the newGlobalName stuff in some of the loadHomeX calls
+ let
+ version = VersionInfo { vers_module = pi_vers iface,
+ vers_exports = export_vers,
+ vers_rules = rule_vers,
+ vers_decls = decls_vers }
-getTyClDeclBinders mod (CoreDecl {tcdName = var, tcdLoc = src_loc})
- = newTopBinder mod var src_loc `thenRn` \ var_name ->
- returnRn (Avail var_name, [])
+ decls = mkIfaceDecls new_decls new_rules new_insts
-getTyClDeclBinders mod tycl_decl
- = new_top_bndrs mod (tyClDeclNames tycl_decl) `thenRn` \ names@(main_name:_) ->
- new_top_bndrs mod (tyClDeclSysNames tycl_decl) `thenRn` \ sys_names ->
- returnRn (AvailTC main_name names, sys_names)
+ mod_iface = ModIface { mi_module = mod, mi_package = pi_pkg iface,
+ mi_version = version,
+ mi_exports = avails, mi_usages = usages,
+ mi_boot = False, mi_orphan = pi_orphan iface,
+ mi_fixities = fix_env, mi_deprecs = deprec_env,
+ mi_decls = decls,
+ mi_globals = Nothing
+ }
+ in
+ returnM mod_iface
+\end{code}
------------------
-new_top_bndrs mod names_w_locs
- = sequenceRn [newTopBinder mod name loc | (name,loc) <- names_w_locs]
+\begin{code}
+loadHomeDecls :: [(Version, RdrNameTyClDecl)]
+ -> RnM (NameEnv Version, [RenamedTyClDecl])
+loadHomeDecls decls = foldlM loadHomeDecl (emptyNameEnv, []) decls
+
+loadHomeDecl :: (NameEnv Version, [RenamedTyClDecl])
+ -> (Version, RdrNameTyClDecl)
+ -> RnM (NameEnv Version, [RenamedTyClDecl])
+loadHomeDecl (version_map, decls) (version, decl)
+ = rnTyClDecl decl `thenM` \ decl' ->
+ returnM (extendNameEnv version_map (tyClDeclName decl') version, decl':decls)
+
+------------------
+loadHomeRules :: (Version, [RdrNameRuleDecl])
+ -> RnM (Version, [RenamedRuleDecl])
+loadHomeRules (version, rules)
+ = mappM rnIfaceRuleDecl rules `thenM` \ rules' ->
+ returnM (version, rules')
+
+------------------
+loadHomeInsts :: [RdrNameInstDecl]
+ -> RnM [RenamedInstDecl]
+loadHomeInsts insts = mappM rnInstDecl insts
+
+------------------
+loadHomeUsage :: ImportVersion OccName
+ -> TcRn m (ImportVersion Name)
+loadHomeUsage (mod_name, orphans, is_boot, whats_imported)
+ = rn_imps whats_imported `thenM` \ whats_imported' ->
+ returnM (mod_name, orphans, is_boot, whats_imported')
+ where
+ rn_imps NothingAtAll = returnM NothingAtAll
+ rn_imps (Everything v) = returnM (Everything v)
+ rn_imps (Specifically mv ev items rv) = mappM rn_imp items `thenM` \ items' ->
+ returnM (Specifically mv ev items' rv)
+ rn_imp (occ,vers) = newGlobalName mod_name occ `thenM` \ name ->
+ returnM (name,vers)
\end{code}
findAndReadIface :: SDoc -> ModuleName
-> IsBootInterface -- True <=> Look for a .hi-boot file
-- False <=> Look for .hi file
- -> RnM d (Either Message (Module, ParsedIface))
+ -> TcRn m (Either Message (Module, ParsedIface))
-- Nothing <=> file not found, or unreadable, or illegible
-- Just x <=> successfully found and parsed
+ -- It *doesn't* add an error to the monad, because
+ -- sometimes it's ok to fail... see notes with loadInterface
+
findAndReadIface doc_str mod_name hi_boot_file
- = traceRn trace_msg `thenRn_`
+ = traceRn trace_msg `thenM_`
-- Check for GHC.Prim, and return its static interface
if mod_name == gHC_PRIM_Name
- then returnRn (Right (gHC_PRIM, ghcPrimIface))
+ then returnM (Right (gHC_PRIM, ghcPrimIface))
else
- -- In interactive or --make mode, we are *not allowed* to demand-load
- -- a home package .hi file. So don't even look for them.
- -- This helps in the case where you are sitting in eg. ghc/lib/std
- -- and start up GHCi - it won't complain that all the modules it tries
- -- to load are found in the home location.
- ioToRnM_no_fail (readIORef v_GhcMode) `thenRn` \ mode ->
- let home_allowed = hi_boot_file || not (isCompManagerMode mode)
- in
-
- ioToRnM (if home_allowed
- then findModule mod_name
- else findPackageModule mod_name) `thenRn` \ maybe_found ->
+ ioToTcRn (findHiFile mod_name hi_boot_file) `thenM` \ maybe_found ->
case maybe_found of
+ Nothing ->
+ traceRn (ptext SLIT("...not found")) `thenM_`
+ returnM (Left (noIfaceErr mod_name hi_boot_file))
- Right (Just (wanted_mod,locn))
- -> mkHiPath hi_boot_file locn `thenRn` \ file ->
- readIface file `thenRn` \ read_result ->
- case read_result of
- Left bad -> returnRn (Left bad)
- Right iface -> -- check that the module names agree
- let read_mod_name = pi_mod iface
- wanted_mod_name = moduleName wanted_mod
- in
- checkRn
- (wanted_mod_name == read_mod_name)
- (hiModuleNameMismatchWarn wanted_mod_name read_mod_name)
- `thenRn_`
- returnRn (Right (wanted_mod, iface))
- -- Can't find it
- other -> traceRn (ptext SLIT("...not found")) `thenRn_`
- returnRn (Left (noIfaceErr mod_name hi_boot_file))
+ Just (wanted_mod, file_path) ->
+ traceRn (ptext SLIT("readIFace") <+> text file_path) `thenM_`
+
+ readIface wanted_mod file_path hi_boot_file `thenM` \ read_result ->
+ -- Catch exceptions here
+
+ case read_result of
+ Left exn -> returnM (Left (badIfaceFile file_path
+ (text (showException exn))))
+
+ Right iface -> returnM (Right (wanted_mod, iface))
where
trace_msg = sep [hsep [ptext SLIT("Reading"),
ppr mod_name <> semi],
nest 4 (ptext SLIT("reason:") <+> doc_str)]
-mkHiPath hi_boot_file locn
- | hi_boot_file =
- ioToRnM_no_fail (doesFileExist hi_boot_ver_path) `thenRn` \ b ->
- if b then returnRn hi_boot_ver_path
- else returnRn hi_boot_path
- | otherwise = returnRn hi_path
- where hi_path = ml_hi_file locn
- (hi_base, _hi_suf) = splitFilename hi_path
- hi_boot_path = hi_base ++ ".hi-boot"
- hi_boot_ver_path = hi_base ++ ".hi-boot-" ++ cHscIfaceFileVersion
+findHiFile :: ModuleName -> IsBootInterface -> IO (Maybe (Module, FilePath))
+findHiFile mod_name hi_boot_file
+ = do {
+ -- In interactive or --make mode, we are *not allowed* to demand-load
+ -- a home package .hi file. So don't even look for them.
+ -- This helps in the case where you are sitting in eg. ghc/lib/std
+ -- and start up GHCi - it won't complain that all the modules it tries
+ -- to load are found in the home location.
+ ghci_mode <- readIORef v_GhcMode ;
+ let { home_allowed = hi_boot_file ||
+ not (isCompManagerMode ghci_mode) } ;
+ maybe_found <- if home_allowed
+ then findModule mod_name
+ else findPackageModule mod_name ;
+
+ case maybe_found of {
+ Nothing -> return Nothing ;
+
+ Just (mod,loc) -> do {
+
+ -- Return the path to M.hi, M.hi-boot, or M.hi-boot-n as appropriate
+ let { hi_path = ml_hi_file loc ;
+ (hi_base, _hi_suf) = splitFilename hi_path ;
+ hi_boot_path = hi_base ++ ".hi-boot" ;
+ hi_boot_ver_path = hi_base ++ ".hi-boot-" ++ cHscIfaceFileVersion } ;
+
+ if not hi_boot_file then
+ return (Just (mod, hi_path))
+ else do {
+ hi_ver_exists <- doesFileExist hi_boot_ver_path ;
+ if hi_ver_exists then return (Just (mod, hi_boot_ver_path))
+ else return (Just (mod, hi_boot_path))
+ }}}}
\end{code}
@readIface@ tries just the one file.
\begin{code}
-readIface :: String -> RnM d (Either Message ParsedIface)
+readIface :: Module -> String -> IsBootInterface -> TcRn m (Either IOError ParsedIface)
-- Nothing <=> file not found, or unreadable, or illegible
-- Just x <=> successfully found and parsed
-readIface file_path
- = --ioToRnM (putStrLn ("reading iface " ++ file_path)) `thenRn_`
- traceRn (ptext SLIT("readIFace") <+> text file_path) `thenRn_`
-
- let hi_boot_ver = "hi-boot-" ++ cHscIfaceFileVersion in
- if ".hi-boot" `isSuffixOf` file_path
- || hi_boot_ver `isSuffixOf` file_path then
-
- ioToRnM (hGetStringBuffer file_path) `thenRn` \ read_result ->
- case read_result of {
- Left io_error -> bale_out (text (show io_error));
- Right contents ->
-
- case parseIface contents (mkPState loc exts) of {
- POk _ iface -> returnRn (Right iface);
- PFailed err -> bale_out err
- }}
-
- else
- ioToRnM_no_fail (myTry (Binary.getBinFileWithDict file_path))
- `thenRn` \ either_iface ->
-
- case either_iface of
- Right iface -> returnRn (Right iface)
- Left (DynException d) | Just e <- fromDynamic d
- -> bale_out (text (show (e :: GhcException)))
-
- Left err -> bale_out (text (show err))
- where
+readIface mod file_path is_hi_boot_file
+ = ioToTcRn_no_fail (read_iface mod file_path is_hi_boot_file)
+
+read_iface mod file_path is_hi_boot_file
+ | is_hi_boot_file -- Read ascii
+ = do { buffer <- hGetStringBuffer file_path ;
+ case parseIface buffer (mkPState loc exts) of
+ POk _ iface | wanted_mod_name == actual_mod_name
+ -> return iface
+ | otherwise
+ -> throwDyn (ProgramError (showSDoc err))
+ -- 'showSDoc' is a bit yukky
+ where
+ wanted_mod_name = moduleName mod
+ actual_mod_name = pi_mod iface
+ err = hiModuleNameMismatchWarn wanted_mod_name actual_mod_name
+
+ PFailed err -> throwDyn (ProgramError (showSDoc err))
+ }
+
+ | otherwise -- Read binary
+ = readBinIface file_path
+
+ where
exts = ExtFlags {glasgowExtsEF = True,
ffiEF = True,
withEF = True,
parrEF = True}
loc = mkSrcLoc (mkFastString file_path) 1
+\end{code}
- bale_out err = returnRn (Left (badIfaceFile file_path err))
-#if __GLASGOW_HASKELL__ < 501
-myTry = Exception.tryAllIO
-#else
-myTry = Exception.try
-#endif
+%*********************************************************
+%* *
+ Wired-in interface for GHC.Prim
+%* *
+%*********************************************************
+
+\begin{code}
+ghcPrimIface :: ParsedIface
+ghcPrimIface = ParsedIface {
+ pi_mod = gHC_PRIM_Name,
+ pi_pkg = preludePackage,
+ pi_vers = 1,
+ pi_orphan = False,
+ pi_usages = [],
+ pi_exports = (1, [(gHC_PRIM_Name, ghcPrimExports)]),
+ pi_decls = [(1,cCallableClassDecl),
+ (1,cReturnableClassDecl),
+ (1,assertDecl)],
+ pi_fixity = [FixitySig (nameRdrName (idName seqId))
+ (Fixity 0 InfixR) noSrcLoc],
+ -- seq is infixr 0
+ pi_insts = [],
+ pi_rules = (1,[]),
+ pi_deprecs = Nothing
+ }
\end{code}
%*********************************************************
import HsSyn
import HsCore
import Class ( FunDep, DefMeth(..) )
-import TyCon ( visibleDataCons )
+import TyCon ( visibleDataCons, tyConName )
import TysWiredIn ( tupleTyCon, listTyCon, parrTyCon, charTyCon )
import Name ( Name, getName, isTyVarName )
import NameSet
-import BasicTypes ( Boxity )
+import BasicTypes ( Boxity, FixitySig )
import Outputable
\end{code}
\begin{code}
-type RenamedHsDecl = HsDecl Name RenamedPat
-type RenamedArithSeqInfo = ArithSeqInfo Name RenamedPat
+type RenamedHsDecl = HsDecl Name
+type RenamedArithSeqInfo = ArithSeqInfo Name
type RenamedClassOpSig = Sig Name
type RenamedConDecl = ConDecl Name
type RenamedContext = HsContext Name
-type RenamedRuleDecl = RuleDecl Name RenamedPat
-type RenamedTyClDecl = TyClDecl Name RenamedPat
+type RenamedRuleDecl = RuleDecl Name
+type RenamedTyClDecl = TyClDecl Name
type RenamedDefaultDecl = DefaultDecl Name
type RenamedForeignDecl = ForeignDecl Name
-type RenamedGRHS = GRHS Name RenamedPat
-type RenamedGRHSs = GRHSs Name RenamedPat
-type RenamedHsBinds = HsBinds Name RenamedPat
-type RenamedHsExpr = HsExpr Name RenamedPat
-type RenamedInstDecl = InstDecl Name RenamedPat
+type RenamedCoreDecl = CoreDecl Name
+type RenamedGRHS = GRHS Name
+type RenamedGRHSs = GRHSs Name
+type RenamedHsBinds = HsBinds Name
+type RenamedHsExpr = HsExpr Name
+type RenamedInstDecl = InstDecl Name
type RenamedMatchContext = HsMatchContext Name
-type RenamedMatch = Match Name RenamedPat
-type RenamedMonoBinds = MonoBinds Name RenamedPat
+type RenamedMatch = Match Name
+type RenamedMonoBinds = MonoBinds Name
type RenamedPat = InPat Name
type RenamedHsType = HsType Name
type RenamedHsPred = HsPred Name
-type RenamedRecordBinds = HsRecordBinds Name RenamedPat
+type RenamedRecordBinds = HsRecordBinds Name
type RenamedSig = Sig Name
-type RenamedStmt = Stmt Name RenamedPat
+type RenamedStmt = Stmt Name
type RenamedFixitySig = FixitySig Name
type RenamedDeprecation = DeprecDecl Name
\end{code}
*** See "THE NAMING STORY" in HsDecls ****
\begin{code}
+----------------
+impDeclFVs :: RenamedHsDecl -> NameSet
+ -- Just the ones that come from imports
+impDeclFVs (InstD d) = instDeclFVs d
+impDeclFVs (TyClD d) = tyClDeclFVs d
+
+----------------
tyClDeclFVs :: RenamedTyClDecl -> NameSet
tyClDeclFVs (ForeignType {})
= emptyFVs
Just _ -> emptyFVs -- Source code, so the default methods
-- are *bound* not *free*
-tyClDeclFVs (CoreDecl {tcdType = ty, tcdRhs = rhs})
- = extractHsTyNames ty `plusFV` ufExprFVs rhs
-
----------------
hsSigsFVs sigs = plusFVs (map hsSigFVs sigs)
ufExprFVs rhs `plusFV` plusFVs (map ufExprFVs args)
----------------
-conDeclFVs (ConDecl _ _ tyvars context details _)
+conDeclFVs (ConDecl _ tyvars context details _)
= delFVs (map hsTyVarName tyvars) $
extractHsCtxtTyNames context `plusFV`
conDetailsFVs details
-conDetailsFVs (VanillaCon btys) = plusFVs (map bangTyFVs btys)
+conDetailsFVs (PrefixCon btys) = plusFVs (map bangTyFVs btys)
conDetailsFVs (InfixCon bty1 bty2) = bangTyFVs bty1 `plusFV` bangTyFVs bty2
conDetailsFVs (RecCon flds) = plusFVs [bangTyFVs bty | (_, bty) <- flds]
ufNoteFVs (UfCoerce ty) = extractHsTyNames ty
ufNoteFVs note = emptyFVs
-hsTupConFVs (HsTupCon n _ _) = unitFV n
+hsTupConFVs (HsTupCon bx n) = unitFV (tyConName (tupleTyCon bx n))
+ -- Always return the TyCon; that'll suck in the data con
\end{code}
+
%************************************************************************
%* *
\subsection{A few functions on generic defintions
-- Tells whether a Match is for a generic definition
-- and extract the type from a generic match and put it at the front
-maybeGenericMatch (Match (TypePatIn ty : pats) sig_ty grhss)
+maybeGenericMatch (Match (TypePat ty : pats) sig_ty grhss)
= Just (ty, Match pats sig_ty grhss)
maybeGenericMatch other_match = Nothing
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
-\section[RnIfaces]{Cacheing and Renaming of Interfaces}
+section
+\%[RnIfaces]{Cacheing and Renaming of Interfaces}
\begin{code}
module RnIfaces
- (
- recordLocalSlurps,
- mkImportInfo,
-
- slurpImpDecls, closeDecls,
-
- RecompileRequired, outOfDate, upToDate, recompileRequired
+ ( slurpImpDecls, importSupportingDecls,
+ RecompileRequired, outOfDate, upToDate, checkVersions
)
where
import CmdLineOpts ( opt_IgnoreIfacePragmas, opt_NoPruneDecls )
import HscTypes
-import HsSyn ( HsDecl(..), Sig(..), TyClDecl(..), ConDecl(..), ConDetails(..),
+import HsSyn ( HsDecl(..), Sig(..), TyClDecl(..), ConDecl(..), HsConDetails(..),
InstDecl(..), HsType(..), hsTyVarNames, getBangType
)
-import HsImpExp ( ImportDecl(..) )
import RdrHsSyn ( RdrNameTyClDecl, RdrNameInstDecl, RdrNameRuleDecl )
import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl,
extractHsTyNames, extractHsCtxtTyNames,
- tyClDeclFVs, ruleDeclFVs, instDeclFVs
- )
-import RnHiFiles ( tryLoadInterface, loadHomeInterface,
- loadOrphanModules
+ tyClDeclFVs, ruleDeclFVs, impDeclFVs
)
+import RnHiFiles ( loadInterface, loadHomeInterface, loadOrphanModules )
import RnSource ( rnTyClDecl, rnInstDecl, rnIfaceRuleDecl )
-import RnEnv
-import RnMonad
+import TcEnv ( getInGlobalScope, tcLookupGlobal_maybe )
+import TcRnMonad
import Id ( idType, idName, globalIdDetails )
import IdInfo ( GlobalIdDetails(..) )
-import TcType ( namesOfType )
+import TcType ( tyClsNamesOfType, classNamesOfTheta )
import FieldLabel ( fieldLabelTyCon )
import DataCon ( dataConTyCon )
import TyCon ( visibleDataCons, isSynTyCon, getSynTyConDefn, tyConClass_maybe, tyConName )
-import Class ( className )
-import Name ( Name {-instance NamedThing-}, nameOccName,
- nameModule, isInternalName, NamedThing(..)
+import Class ( className, classSCTheta )
+import Name ( Name {-instance NamedThing-}, isWiredInName, isInternalName, nameModule, NamedThing(..)
)
-import NameEnv ( elemNameEnv, delFromNameEnv, lookupNameEnv )
+import NameEnv ( delFromNameEnv, lookupNameEnv )
import NameSet
-import Module ( Module, ModuleEnv,
- moduleName, isHomeModule,
- ModuleName, WhereFrom(..),
- emptyModuleEnv,
- extendModuleEnv_C, foldModuleEnv, lookupModuleEnv,
- elemModuleSet, extendModuleSet
- )
-import PrelInfo ( wiredInThingEnv, hasKey, fractionalClassKey, numClassKey,
+import Module ( Module, isHomeModule, extendModuleSet )
+import PrelInfo ( hasKey, fractionalClassKey, numClassKey,
integerTyConName, doubleTyConName )
-import Maybe ( isJust )
import FiniteMap
import Outputable
import Bag
-import Util ( sortLt, seqList )
+import Maybe( fromJust )
\end{code}
%*********************************************************
-%* *
-\subsection{Keeping track of what we've slurped, and version numbers}
-%* *
-%*********************************************************
-
-mkImportInfo figures out what the ``usage information'' for this
-moudule is; that is, what it must record in its interface file as the
-things it uses.
-
-We produce a line for every module B below the module, A, currently being
-compiled:
- import B <n> ;
-to record the fact that A does import B indirectly. This is used to decide
-to look to look for B.hi rather than B.hi-boot when compiling a module that
-imports A. This line says that A imports B, but uses nothing in it.
-So we'll get an early bale-out when compiling A if B's version changes.
-
-The usage information records:
-
-\begin{itemize}
-\item (a) anything reachable from its body code
-\item (b) any module exported with a @module Foo@
-\item (c) anything reachable from an exported item
-\end{itemize}
-
-Why (b)? Because if @Foo@ changes then this module's export list
-will change, so we must recompile this module at least as far as
-making a new interface file --- but in practice that means complete
-recompilation.
-
-Why (c)? Consider this:
-\begin{verbatim}
- module A( f, g ) where | module B( f ) where
- import B( f ) | f = h 3
- g = ... | h = ...
-\end{verbatim}
-
-Here, @B.f@ isn't used in A. Should we nevertheless record @B.f@ in
-@A@'s usages? Our idea is that we aren't going to touch A.hi if it is
-*identical* to what it was before. If anything about @B.f@ changes
-than anyone who imports @A@ should be recompiled in case they use
-@B.f@ (they'll get an early exit if they don't). So, if anything
-about @B.f@ changes we'd better make sure that something in A.hi
-changes, and the convenient way to do that is to record the version
-number @B.f@ in A.hi in the usage list. If B.f changes that'll force a
-complete recompiation of A, which is overkill but it's the only way to
-write a new, slightly different, A.hi.
-
-But the example is tricker. Even if @B.f@ doesn't change at all,
-@B.h@ may do so, and this change may not be reflected in @f@'s version
-number. But with -O, a module that imports A must be recompiled if
-@B.h@ changes! So A must record a dependency on @B.h@. So we treat
-the occurrence of @B.f@ in the export list *just as if* it were in the
-code of A, and thereby haul in all the stuff reachable from it.
-
- *** Conclusion: if A mentions B.f in its export list,
- behave just as if A mentioned B.f in its source code,
- and slurp in B.f and all its transitive closure ***
-
-[NB: If B was compiled with -O, but A isn't, we should really *still*
-haul in all the unfoldings for B, in case the module that imports A *is*
-compiled with -O. I think this is the case.]
-
-\begin{code}
-mkImportInfo :: ModuleName -- Name of this module
- -> [ImportDecl n] -- The import decls
- -> RnMG [ImportVersion Name]
-
-mkImportInfo this_mod imports
- = getIfacesRn `thenRn` \ ifaces ->
- getHomeIfaceTableRn `thenRn` \ hit ->
- let
- (imp_pkg_mods, imp_home_names) = iVSlurp ifaces
- pit = iPIT ifaces
-
- import_all_mods :: [ModuleName]
- -- Modules where we imported all the names
- -- (apart from hiding some, perhaps)
- import_all_mods = [ m | ImportDecl m _ _ _ imp_list _ <- imports,
- import_all imp_list ]
- where
- import_all (Just (False, _)) = False -- Imports are spec'd explicitly
- import_all other = True -- Everything is imported
-
- -- mv_map groups together all the things imported and used
- -- from a particular module in this package
- -- We use a finite map because we want the domain
- mv_map :: ModuleEnv [Name]
- mv_map = foldNameSet add_mv emptyModuleEnv imp_home_names
- add_mv name mv_map = extendModuleEnv_C add_item mv_map mod [name]
- where
- mod = nameModule name
- add_item names _ = name:names
-
- -- In our usage list we record
- --
- -- a) Specifically: Detailed version info for imports
- -- from modules in this package Gotten from iVSlurp plus
- -- import_all_mods
- --
- -- b) Everything: Just the module version for imports
- -- from modules in other packages Gotten from iVSlurp plus
- -- import_all_mods
- --
- -- c) NothingAtAll: The name only of modules, Baz, in
- -- this package that are 'below' us, but which we didn't need
- -- at all (this is needed only to decide whether to open Baz.hi
- -- or Baz.hi-boot higher up the tree). This happens when a
- -- module, Foo, that we explicitly imported has 'import Baz' in
- -- its interface file, recording that Baz is below Foo in the
- -- module dependency hierarchy. We want to propagate this
- -- info. These modules are in a combination of HIT/PIT and
- -- iImpModInfo
- --
- -- d) NothingAtAll: The name only of all orphan modules
- -- we know of (this is needed so that anyone who imports us can
- -- find the orphan modules) These modules are in a combination
- -- of HIT/PIT and iImpModInfo
-
- import_info0 = foldModuleEnv mk_imp_info [] pit
- import_info1 = foldModuleEnv mk_imp_info import_info0 hit
- import_info = not_even_opened_imports ++ import_info1
-
- -- Recall that iImpModInfo describes modules that have
- -- been mentioned in the import lists of interfaces we
- -- have opened, but which we have not even opened when
- -- compiling this module
- not_even_opened_imports =
- [ (mod_name, orphans, is_boot, NothingAtAll)
- | (mod_name, (orphans, is_boot)) <- fmToList (iImpModInfo ifaces) ]
-
-
- mk_imp_info :: ModIface -> [ImportVersion Name] -> [ImportVersion Name]
- mk_imp_info iface so_far
-
- | Just ns <- lookupModuleEnv mv_map mod -- Case (a)
- = go_for_it (Specifically mod_vers maybe_export_vers
- (mk_import_items ns) rules_vers)
-
- | mod `elemModuleSet` imp_pkg_mods -- Case (b)
- = go_for_it (Everything mod_vers)
-
- | import_all_mod -- Case (a) and (b); the import-all part
- = if is_home_pkg_mod then
- go_for_it (Specifically mod_vers (Just export_vers) [] rules_vers)
- -- Since the module isn't in the mv_map, presumably we
- -- didn't actually import anything at all from it
- else
- go_for_it (Everything mod_vers)
-
- | is_home_pkg_mod || has_orphans -- Case (c) or (d)
- = go_for_it NothingAtAll
-
- | otherwise = so_far
- where
- go_for_it exports = (mod_name, has_orphans, mi_boot iface, exports) : so_far
-
- mod = mi_module iface
- mod_name = moduleName mod
- is_home_pkg_mod = isHomeModule mod
- version_info = mi_version iface
- version_env = vers_decls version_info
- mod_vers = vers_module version_info
- rules_vers = vers_rules version_info
- export_vers = vers_exports version_info
- import_all_mod = mod_name `elem` import_all_mods
- has_orphans = mi_orphan iface
-
- -- The sort is to put them into canonical order
- mk_import_items ns = [(n,v) | n <- sortLt lt_occ ns,
- let v = lookupVersion version_env n
- ]
- where
- lt_occ n1 n2 = nameOccName n1 < nameOccName n2
-
- maybe_export_vers | import_all_mod = Just (vers_exports version_info)
- | otherwise = Nothing
- in
-
- -- seq the list of ImportVersions returned: occasionally these
- -- don't get evaluated for a while and we can end up hanging on to
- -- the entire collection of Ifaces.
- seqList import_info (returnRn import_info)
-\end{code}
-
-%*********************************************************
%* *
\subsection{Slurping declarations}
%* *
\begin{code}
-------------------------------------------------------
+slurpImpDecls :: FreeVars -> TcRn m [RenamedHsDecl]
slurpImpDecls source_fvs
- = traceRn (text "slurpImp" <+> fsep (map ppr (nameSetToList source_fvs))) `thenRn_`
+ = traceRn (text "slurpImp" <+> fsep (map ppr (nameSetToList source_fvs))) `thenM_`
- -- The current slurped-set records all local things
- slurpSourceRefs source_fvs `thenRn` \ (decls, needed) ->
+ -- Slurp in things which might be 'gates' for instance
+ -- declarations, plus the instance declarations themselves
+ slurpSourceRefs source_fvs `thenM` \ (gate_decls, bndrs) ->
-- Then get everything else
- closeDecls decls needed
+ let
+ needed = foldr (plusFV . impDeclFVs) emptyFVs gate_decls
+ in
+ import_supporting_decls (gate_decls, bndrs) needed
-------------------------------------------------------
slurpSourceRefs :: FreeVars -- Variables referenced in source
- -> RnMG ([RenamedHsDecl],
- FreeVars) -- Un-satisfied needs
--- The declaration (and hence home module) of each gate has
--- already been loaded
+ -> TcRn m ([RenamedHsDecl], -- Needed declarations
+ NameSet) -- Names bound by those declarations
+-- Slurp imported declarations needed directly by the source code;
+-- and some of the ones they need. The goal is to find all the 'gates'
+-- for instance declarations.
slurpSourceRefs source_fvs
- = go_outer [] -- Accumulating decls
- emptyFVs -- Unsatisfied needs
- emptyFVs -- Accumulating gates
+ = go_outer [] emptyFVs -- Accumulating decls
(nameSetToList source_fvs) -- Things whose defn hasn't been loaded yet
where
-- The outer loop repeatedly slurps the decls for the current gates
-- so that its superclasses are discovered. The point is that Wib is a gate too.
-- We do this for tycons too, so that we look through type synonyms.
- go_outer decls fvs all_gates []
- = returnRn (decls, fvs)
-
- go_outer decls fvs all_gates refs -- refs are not necessarily slurped yet
- = traceRn (text "go_outer" <+> ppr refs) `thenRn_`
- foldlRn go_inner (decls, fvs, emptyFVs) refs `thenRn` \ (decls1, fvs1, gates1) ->
- getImportedInstDecls (all_gates `plusFV` gates1) `thenRn` \ inst_decls ->
- rnIfaceInstDecls decls1 fvs1 gates1 inst_decls `thenRn` \ (decls2, fvs2, gates2) ->
- go_outer decls2 fvs2 (all_gates `plusFV` gates2)
- (nameSetToList (gates2 `minusNameSet` all_gates))
- -- Knock out the all_gates because even if we don't slurp any new
- -- decls we can get some apparently-new gates from wired-in names
- -- and we get an infinite loop
-
- go_inner (decls, fvs, gates) wanted_name
- = importDecl wanted_name `thenRn` \ import_result ->
+ go_outer decls bndrs [] = returnM (decls, bndrs)
+
+ go_outer decls bndrs refs -- 'refs' are not necessarily slurped yet
+ = traceRn (text "go_outer" <+> ppr refs) `thenM_`
+ foldlM go_inner (decls, bndrs, emptyFVs) refs `thenM` \ (decls1, bndrs1, gates1) ->
+ getImportedInstDecls gates1 `thenM` \ (inst_decls, new_gates) ->
+ rnIfaceDecls rnInstDecl inst_decls `thenM` \ inst_decls' ->
+ go_outer (map InstD inst_decls' ++ decls1)
+ bndrs1
+ (nameSetToList (new_gates `plusFV` plusFVs (map getInstDeclGates inst_decls')))
+ -- NB: we go round again to fetch the decls for any gates of any decls
+ -- we have loaded. For example, if we mention
+ -- print :: Show a => a -> String
+ -- then we must load the decl for Show before stopping, to ensure
+ -- that instances from its home module are available
+
+ go_inner (decls, bndrs, gates) wanted_name
+ = importDecl bndrs wanted_name `thenM` \ import_result ->
case import_result of
- AlreadySlurped -> returnRn (decls, fvs, gates)
- InTypeEnv ty_thing -> returnRn (decls, fvs, gates `plusFV` getWiredInGates ty_thing)
-
- HereItIs decl -> rnIfaceTyClDecl decl `thenRn` \ (new_decl, fvs1) ->
- returnRn (TyClD new_decl : decls,
- fvs1 `plusFV` fvs,
- gates `plusFV` getGates source_fvs new_decl)
+ AlreadySlurped -> returnM (decls, bndrs, gates)
+
+ InTypeEnv ty_thing
+ -> returnM (decls,
+ bndrs `addOneFV` wanted_name, -- Avoid repeated calls to getWiredInGates
+ gates `plusFV` getWiredInGates ty_thing)
+
+ HereItIs decl new_bndrs
+ -> rnIfaceDecl rnTyClDecl decl `thenM` \ new_decl ->
+ returnM (TyClD new_decl : decls,
+ bndrs `plusFV` new_bndrs,
+ gates `plusFV` getGates source_fvs new_decl)
\end{code}
-
\begin{code}
-------------------------------------------------------
--- closeDecls keeps going until the free-var set is empty
-closeDecls decls needed
- = slurpIfaceDecls decls needed `thenRn` \ decls1 ->
- getImportedRules `thenRn` \ rule_decls ->
+-- import_supporting_decls keeps going until the free-var set is empty
+importSupportingDecls needed
+ = import_supporting_decls ([], emptyNameSet) needed
+
+import_supporting_decls
+ :: ([RenamedHsDecl], NameSet) -- Some imported decls, with their binders
+ -> FreeVars -- Remaining un-slurped names
+ -> TcRn m [RenamedHsDecl]
+import_supporting_decls decls needed
+ = slurpIfaceDecls decls needed `thenM` \ (decls1, bndrs1) ->
+ getImportedRules bndrs1 `thenM` \ rule_decls ->
case rule_decls of
- [] -> returnRn decls1 -- No new rules, so we are done
- other -> rnIfaceDecls rnIfaceRuleDecl rule_decls `thenRn` \ rule_decls' ->
+ [] -> returnM decls1 -- No new rules, so we are done
+ other -> rnIfaceDecls rnIfaceRuleDecl rule_decls `thenM` \ rule_decls' ->
let
- rule_fvs = plusFVs (map ruleDeclFVs rule_decls')
+ rule_fvs = plusFVs (map ruleDeclFVs rule_decls')
+ decls2 = decls1 ++ map RuleD rule_decls'
in
traceRn (text "closeRules" <+> ppr rule_decls' $$
- fsep (map ppr (nameSetToList rule_fvs))) `thenRn_`
- closeDecls (map RuleD rule_decls' ++ decls1) rule_fvs
-
+ fsep (map ppr (nameSetToList rule_fvs))) `thenM_`
+ import_supporting_decls (decls2, bndrs1) rule_fvs
+
-------------------------------------------------------
-- Augment decls with any decls needed by needed,
-- and so on transitively
-slurpIfaceDecls :: [RenamedHsDecl] -> FreeVars -> RnMG [RenamedHsDecl]
-slurpIfaceDecls decls needed
- = slurp decls (nameSetToList needed)
+slurpIfaceDecls :: ([RenamedHsDecl], NameSet) -- Already slurped
+ -> FreeVars -- Still needed
+ -> TcRn m ([RenamedHsDecl], NameSet)
+slurpIfaceDecls (decls, bndrs) needed
+ = slurp decls bndrs (nameSetToList needed)
where
- slurp decls [] = returnRn decls
- slurp decls (n:ns) = slurp_one decls n `thenRn` \ decls1 ->
- slurp decls1 ns
-
- slurp_one decls wanted_name
- = importDecl wanted_name `thenRn` \ import_result ->
+ slurp decls bndrs [] = returnM (decls, bndrs)
+ slurp decls bndrs (n:ns)
+ = importDecl bndrs n `thenM` \ import_result ->
case import_result of
- HereItIs decl -> -- Found a declaration... rename it
- -- and get the things it needs
- rnIfaceTyClDecl decl `thenRn` \ (new_decl, fvs) ->
- slurp (TyClD new_decl : decls) (nameSetToList fvs)
+ HereItIs decl new_bndrs -- Found a declaration... rename it
+ -> rnIfaceDecl rnTyClDecl decl `thenM` \ new_decl ->
+ slurp (TyClD new_decl : decls)
+ (bndrs `plusFV` new_bndrs)
+ (nameSetToList (tyClDeclFVs new_decl) ++ ns)
other -> -- No declaration... (wired in thing, or deferred,
- -- or already slurped)
- returnRn decls
-
+ -- or already slurped)
+ slurp decls (bndrs `addOneFV` n) ns
-------------------------------------------------------
-rnIfaceDecls rn decls = mapRn (rnIfaceDecl rn) decls
-rnIfaceDecl rn (mod, decl) = initIfaceRnMS mod (rn decl)
+rnIfaceDecls rn decls = mappM (rnIfaceDecl rn) decls
+rnIfaceDecl rn (mod, decl) = initRn (InterfaceMode mod) (rn decl)
+\end{code}
-rnIfaceInstDecls decls fvs gates inst_decls
- = rnIfaceDecls rnInstDecl inst_decls `thenRn` \ inst_decls' ->
- returnRn (map InstD inst_decls' ++ decls,
- fvs `plusFV` plusFVs (map instDeclFVs inst_decls'),
- gates `plusFV` plusFVs (map getInstDeclGates inst_decls'))
-rnIfaceTyClDecl (mod, decl) = initIfaceRnMS mod (rnTyClDecl decl) `thenRn` \ decl' ->
- returnRn (decl', tyClDeclFVs decl')
+\begin{code}
+ -- Tiresomely, we must get the "main" name for the
+ -- thing, because that's what VSlurp contains, and what
+ -- is recorded in the usage information
+get_main_name (AClass cl) = className cl
+get_main_name (ATyCon tc)
+ | Just clas <- tyConClass_maybe tc = get_main_name (AClass clas)
+ | otherwise = tyConName tc
+get_main_name (AnId id)
+ = case globalIdDetails id of
+ DataConId dc -> get_main_name (ATyCon (dataConTyCon dc))
+ DataConWrapId dc -> get_main_name (ATyCon (dataConTyCon dc))
+ RecordSelId lbl -> get_main_name (ATyCon (fieldLabelTyCon lbl))
+ other -> idName id
+
+
+recordUsage :: Name -> TcRn m ()
+-- Record that the Name has been used, for
+-- later generation of usage info in the interface file
+recordUsage name = updUsages (upd_usg name)
+
+upd_usg name usages
+ | isHomeModule mod = usages { usg_home = addOneToNameSet (usg_home usages) name }
+ | otherwise = usages { usg_ext = extendModuleSet (usg_ext usages) mod }
+ where
+ mod = nameModule name
\end{code}
+%*********************************************************
+%* *
+\subsection{Getting in a declaration}
+%* *
+%*********************************************************
+
\begin{code}
-recordDeclSlurp ifaces@(Ifaces { iDecls = (decls_map, n_slurped),
- iSlurp = slurped_names,
- iVSlurp = vslurp })
- avail
- = ASSERT2( not (isInternalName (availName avail)), ppr avail )
- ifaces { iDecls = (new_decls_map, n_slurped+1),
- iSlurp = new_slurped_names,
- iVSlurp = updateVSlurp vslurp (availName avail) }
- where
- new_decls_map = foldl delFromNameEnv decls_map (availNames avail)
- new_slurped_names = addAvailToNameSet slurped_names avail
+importDecl :: NameSet -> Name -> TcRn m ImportDeclResult
+data ImportDeclResult
+ = AlreadySlurped
+ | InTypeEnv TyThing
+ | HereItIs (Module, RdrNameTyClDecl) NameSet
+ -- The NameSet is the bunch of names bound by this decl
+
+importDecl already_slurped name
+ = -- STEP 0: Check if it's from this module
+ -- Doing this catches a common case quickly
+ getModule `thenM` \ this_mod ->
+ if isInternalName name || nameModule name == this_mod then
+ -- Variables defined on the GHCi command line (e.g. let x = 3)
+ -- are Internal names (which don't have a Module)
+ returnM AlreadySlurped
+ else
--- recordTypeEnvSlurp is used when we slurp something that's
--- already in the type environment, that was not slurped in an earlier compilation.
--- We record it in the iVSlurp set, because that's used to
--- generate usage information
+ -- STEP 1: Check if we've slurped it in while compiling this module
+ if name `elemNameSet` already_slurped then
+ returnM AlreadySlurped
+ else
-recordTypeEnvSlurp ifaces ty_thing
- = ifaces { iVSlurp = updateVSlurp (iVSlurp ifaces) (get_main_name ty_thing) }
- where
- -- Tiresomely, we must get the "main" name for the
- -- thing, because that's what VSlurp contains, and what
- -- is recorded in the usage information
- get_main_name (AClass cl) = className cl
- get_main_name (ATyCon tc)
- | Just clas <- tyConClass_maybe tc = get_main_name (AClass clas)
- | otherwise = tyConName tc
- get_main_name (AnId id)
- = case globalIdDetails id of
- DataConId dc -> get_main_name (ATyCon (dataConTyCon dc))
- DataConWrapId dc -> get_main_name (ATyCon (dataConTyCon dc))
- RecordSelId lbl -> get_main_name (ATyCon (fieldLabelTyCon lbl))
- other -> idName id
-
-updateVSlurp (imp_mods, imp_names) main_name
- | isHomeModule mod = (imp_mods, addOneToNameSet imp_names main_name)
- | otherwise = (extendModuleSet imp_mods mod, imp_names)
+ -- STEP 2: Check if it's already in the type environment
+ tcLookupGlobal_maybe name `thenM` \ maybe_thing ->
+ case maybe_thing of {
+
+ Just ty_thing
+ | isWiredInName name
+ -> -- When we find a wired-in name we must load its home
+ -- module so that we find any instance decls lurking therein
+ loadHomeInterface wi_doc name `thenM_`
+ returnM (InTypeEnv ty_thing)
+
+ | otherwise
+ -> -- We have slurp something that's already in the type environment,
+ -- that was not slurped in an earlier compilation.
+ -- Must still record it in the Usages info, because that's used to
+ -- generate usage information
+
+ traceRn (text "not wired in" <+> ppr name) `thenM_`
+ recordUsage (get_main_name ty_thing) `thenM_`
+ returnM (InTypeEnv ty_thing) ;
+
+ Nothing ->
+
+ -- STEP 4: OK, we have to slurp it in from an interface file
+ -- First load the interface file
+ traceRn nd_doc `thenM_`
+ loadHomeInterface nd_doc name `thenM_`
+
+ -- STEP 4: Get the declaration out
+ getEps `thenM` \ eps ->
+ let
+ (decls_map, n_slurped) = eps_decls eps
+ in
+ case lookupNameEnv decls_map name of
+ Just (avail,_,decl) -> setEps eps' `thenM_`
+ recordUsage (availName avail) `thenM_`
+ returnM (HereItIs decl (mkFVs avail_names))
+ where
+ avail_names = availNames avail
+ new_decls_map = foldl delFromNameEnv decls_map avail_names
+ eps' = eps { eps_decls = (new_decls_map, n_slurped+1) }
+
+ Nothing -> addErr (getDeclErr name) `thenM_`
+ returnM AlreadySlurped
+ }
where
- mod = nameModule main_name
-
-recordLocalSlurps new_names
- = getIfacesRn `thenRn` \ ifaces ->
- setIfacesRn (ifaces { iSlurp = iSlurp ifaces `unionNameSets` new_names })
-\end{code}
+ wi_doc = ptext SLIT("need home module for wired in thing") <+> ppr name
+ nd_doc = ptext SLIT("need decl for") <+> ppr name
+\end{code}
%*********************************************************
More precisely, the gates of a module are the types and classes
that are mentioned in:
- a) the source code
+ a) the source code [Note: in fact these don't seem
+ to be treated as gates, perhaps
+ because no imported instance decl
+ can mention them; mutter mutter
+ recursive modules.]
b) the type of an Id that's mentioned in the source code
[includes constructors and selectors]
c) the RHS of a type synonym that is a gate
We slurp in an instance decl from the gated instance pool iff
- all its gates are either in the gates of the module,
- or are a previously-loaded tycon or class.
+ all its gates are either in the gates of the module,
+ or the gates of a previously-loaded module
The latter constraint is because there might have been an instance
decl slurped in during an earlier compilation, like this:
instance Foo a => Baz (Maybe a) where ...
-In the module being compiled we might need (Baz (Maybe T)), where T
-is defined in this module, and hence we need (Foo T). So @Foo@ becomes
-a gate. But there's no way to 'see' that. More generally, types
-might be involved as well:
+In the module being compiled we might need (Baz (Maybe T)), where T is
+defined in this module, and hence we need the instance for (Foo T).
+So @Foo@ becomes a gate. But there's no way to 'see' that. More
+generally, types might be involved as well:
- instance Foo2 T a => Baz2 a where ...
+ instance Foo2 S a => Baz2 a where ...
-Now we must treat T as a gate too, as well as Foo. So the solution
+Now we must treat S as a gate too, as well as Foo2. So the solution
we adopt is:
- we simply treat all previously-loaded
- tycons and classes as gates.
+ we simply treat the gates of all previously-loaded
+ modules as gates of this one
+
+So the gates are remembered across invocations of the renamer in the
+PersistentRenamerState. This gloss mainly affects ghc --make and ghc
+--interactive.
-This gloss only affects ghc --make and ghc --interactive.
+(We used to use the persistent type environment for this purpose,
+but it has too much. For a start, it contains all tuple types,
+because they are in the wired-in type env!)
Consructors and class operations
get_gates is_used (ForeignType {tcdName = tycon}) = unitNameSet tycon
get_gates is_used (IfaceSig {tcdType = ty}) = extractHsTyNames ty
-get_gates is_used (CoreDecl {tcdType = ty}) = extractHsTyNames ty
get_gates is_used (ClassDecl { tcdCtxt = ctxt, tcdName = cls, tcdTyVars = tvs, tcdSigs = sigs})
= (super_cls_and_sigs `addOneToNameSet` cls) `unionNameSets`
(hsTyVarNames tvs)
`addOneToNameSet` tycon
where
- get (ConDecl n _ tvs ctxt details _)
+ get (ConDecl n tvs ctxt details _)
| is_used n
-- If the constructor is method, get fvs from all its fields
= delListFromNameSet (get_details details `plusFV`
extractHsCtxtTyNames ctxt)
(hsTyVarNames tvs)
- get (ConDecl n _ tvs ctxt (RecCon fields) _)
+ get (ConDecl n tvs ctxt (RecCon fields) _)
-- Even if the constructor isn't mentioned, the fields
-- might be, as selectors. They can't mention existentially
-- bound tyvars (typechecker checks for that) so no need for
get other_con = emptyFVs
- get_details (VanillaCon tys) = plusFVs (map get_bang tys)
+ get_details (PrefixCon tys) = plusFVs (map get_bang tys)
get_details (InfixCon t1 t2) = get_bang t1 `plusFV` get_bang t2
get_details (RecCon fields) = plusFVs [get_bang t | (_, t) <- fields]
- get_field (fs,t) | any is_used fs = get_bang t
- | otherwise = emptyFVs
+ get_field (f,t) | is_used f = get_bang t
+ | otherwise = emptyFVs
get_bang bty = extractHsTyNames (getBangType bty)
-- The TyThing is one that we already have in our type environment, either
-- a) because the TyCon or Id is wired in, or
-- b) from a previous compile
+--
-- Either way, we might have instance decls in the (persistent) collection
-- of parsed-but-not-slurped instance decls that should be slurped in.
-- This might be the first module that mentions both the type and the class
-- for that instance decl, even though both the type and the class were
-- mentioned in other modules, and hence are in the type environment
-getWiredInGates (AnId the_id) = namesOfType (idType the_id)
-getWiredInGates (AClass cl) = implicitClassGates (getName cl)
- -- The superclasses must also be previously
- -- loaded, and hence are automatically gates
- -- All previously-loaded classes are automatically gates
- -- See "The gating story" above
+getWiredInGates (AClass cl)
+ = unitFV (getName cl) `plusFV` mkFVs super_classes
+ where
+ super_classes = classNamesOfTheta (classSCTheta cl)
+
+getWiredInGates (AnId the_id) = tyClsNamesOfType (idType the_id)
getWiredInGates (ATyCon tc)
- | isSynTyCon tc = delListFromNameSet (namesOfType ty) (map getName tyvars)
+ | isSynTyCon tc = tyClsNamesOfType ty
| otherwise = unitFV (getName tc)
where
- (tyvars,ty) = getSynTyConDefn tc
+ (_,ty) = getSynTyConDefn tc
getInstDeclGates (InstDecl inst_ty _ _ _ _) = extractHsTyNames inst_ty
\end{code}
\begin{code}
-getImportedInstDecls :: NameSet -> RnMG [(Module,RdrNameInstDecl)]
+getImportedInstDecls :: NameSet -> TcRn m ([(Module,RdrNameInstDecl)], NameSet)
+ -- Returns the gates that are new since last time
getImportedInstDecls gates
= -- First, load any orphan-instance modules that aren't aready loaded
-- Orphan-instance modules are recorded in the module dependecnies
- getIfacesRn `thenRn` \ ifaces ->
+ getEps `thenM` \ eps ->
let
- orphan_mods =
- [mod | (mod, (True, _)) <- fmToList (iImpModInfo ifaces)]
+ old_gates = eps_inst_gates eps
+ new_gates = gates `minusNameSet` old_gates
+ all_gates = new_gates `unionNameSets` old_gates
+ orphan_mods = [mod | (mod, (True, _)) <- fmToList (eps_imp_mods eps)]
in
- loadOrphanModules orphan_mods `thenRn_`
+ loadOrphanModules orphan_mods `thenM_`
-- Now we're ready to grab the instance declarations
-- Find the un-gated ones and return them,
- -- removing them from the bag kept in Ifaces
- getIfacesRn `thenRn` \ ifaces ->
- getTypeEnvRn `thenRn` \ lookup ->
+ -- removing them from the bag kept in EPS
+ -- Don't foget to get the EPS a second time...
+ -- loadOrphanModules may have side-effected it!
+ getEps `thenM` \ eps ->
let
- available n = n `elemNameSet` gates || isJust (lookup n)
- -- See "The gating story" above for the isJust thing
-
- (decls, new_insts) = selectGated available (iInsts ifaces)
+ available n = n `elemNameSet` all_gates
+ (decls, new_insts) = selectGated available (eps_insts eps)
in
- setIfacesRn (ifaces { iInsts = new_insts }) `thenRn_`
+ setEps (eps { eps_insts = new_insts,
+ eps_inst_gates = all_gates }) `thenM_`
traceRn (sep [text "getImportedInstDecls:",
- nest 4 (fsep (map ppr gate_list)),
+ nest 4 (fsep (map ppr (nameSetToList gates))),
+ nest 4 (fsep (map ppr (nameSetToList all_gates))),
+ nest 4 (fsep (map ppr (nameSetToList new_gates))),
text "Slurped" <+> int (length decls) <+> text "instance declarations",
- nest 4 (vcat (map ppr_brief_inst_decl decls))]) `thenRn_`
- returnRn decls
- where
- gate_list = nameSetToList gates
+ nest 4 (vcat (map ppr_brief_inst_decl decls))]) `thenM_`
+ returnM (decls, new_gates)
ppr_brief_inst_decl (mod, InstDecl inst_ty _ _ _ _)
= case inst_ty of
HsForAllTy _ _ tau -> ppr tau
other -> ppr inst_ty
-getImportedRules :: RnMG [(Module,RdrNameRuleDecl)]
-getImportedRules
- | opt_IgnoreIfacePragmas = returnRn []
+getImportedRules :: NameSet -- Slurped already
+ -> TcRn m [(Module,RdrNameRuleDecl)]
+getImportedRules slurped
+ | opt_IgnoreIfacePragmas = returnM []
| otherwise
- = getIfacesRn `thenRn` \ ifaces ->
- getTypeEnvRn `thenRn` \ lookup ->
+ = getEps `thenM` \ eps ->
+ getInGlobalScope `thenM` \ in_type_env ->
let
-- Slurp rules for anything that is slurped,
- -- either now or previously
- gates = iSlurp ifaces
- available n = n `elemNameSet` gates || isJust (lookup n)
- (decls, new_rules) = selectGated available (iRules ifaces)
+ -- either now, or previously
+ available n = n `elemNameSet` slurped || in_type_env n
+ (decls, new_rules) = selectGated available (eps_rules eps)
in
if null decls then
- returnRn []
+ returnM []
else
- setIfacesRn (ifaces { iRules = new_rules }) `thenRn_`
+ setEps (eps { eps_rules = new_rules }) `thenM_`
traceRn (sep [text "getImportedRules:",
- text "Slurped" <+> int (length decls) <+> text "rules"]) `thenRn_`
- returnRn decls
+ text "Slurped" <+> int (length decls) <+> text "rules"]) `thenM_`
+ returnM decls
selectGated :: (Name->Bool) -> GatedDecls d
-> ([(Module,d)], GatedDecls d)
\end{code}
-%*********************************************************
-%* *
-\subsection{Getting in a declaration}
-%* *
-%*********************************************************
-
-\begin{code}
-importDecl :: Name -> RnMG ImportDeclResult
-
-data ImportDeclResult
- = AlreadySlurped
- | InTypeEnv TyThing
- | HereItIs (Module, RdrNameTyClDecl)
-
-importDecl name
- = -- STEP 1: Check if we've slurped it in while compiling this module
- getIfacesRn `thenRn` \ ifaces ->
- if name `elemNameSet` iSlurp ifaces then
- returnRn AlreadySlurped
- else
-
-
- -- STEP 2: Check if it's already in the type environment
- getTypeEnvRn `thenRn` \ lookup ->
- case lookup name of {
- Just ty_thing
- | name `elemNameEnv` wiredInThingEnv
- -> -- When we find a wired-in name we must load its home
- -- module so that we find any instance decls lurking therein
- loadHomeInterface wi_doc name `thenRn_`
- returnRn (InTypeEnv ty_thing)
-
- | otherwise
- -> -- Very important: record that we've seen it
- -- See comments with recordTypeEnvSlurp
- setIfacesRn (recordTypeEnvSlurp ifaces ty_thing) `thenRn_`
- returnRn (InTypeEnv ty_thing) ;
-
- Nothing ->
-
- -- STEP 3: OK, we have to slurp it in from an interface file
- -- First load the interface file
- traceRn nd_doc `thenRn_`
- loadHomeInterface nd_doc name `thenRn_`
- getIfacesRn `thenRn` \ ifaces ->
-
- -- STEP 4: Get the declaration out
- let
- (decls_map, _) = iDecls ifaces
- in
- case lookupNameEnv decls_map name of
- Just (avail,_,decl) -> setIfacesRn (recordDeclSlurp ifaces avail) `thenRn_`
- returnRn (HereItIs decl)
-
- Nothing -> addErrRn (getDeclErr name) `thenRn_`
- returnRn AlreadySlurped
- }
- where
- wi_doc = ptext SLIT("need home module for wired in thing") <+> ppr name
- nd_doc = ptext SLIT("need decl for") <+> ppr name
-
-\end{code}
-
-
%********************************************************
%* *
\subsection{Checking usage information}
upToDate = False -- Recompile not required
outOfDate = True -- Recompile required
-recompileRequired :: FilePath -- Only needed for debug msgs
- -> ModIface -- Old interface
- -> RnMG RecompileRequired
-recompileRequired iface_path iface
- = traceHiDiffsRn (text "Considering whether compilation is required for" <+> text iface_path <> colon) `thenRn_`
+checkVersions :: Bool -- True <=> source unchanged
+ -> ModIface -- Old interface
+ -> TcRn m RecompileRequired
+checkVersions source_unchanged iface
+ | not source_unchanged
+ = returnM outOfDate
+ | otherwise
+ = traceHiDiffs (text "Considering whether compilation is required for" <+>
+ ppr (mi_module iface) <> colon) `thenM_`
-- Source code unchanged and no errors yet... carry on
checkList [checkModUsage u | u <- mi_usages iface]
-checkList :: [RnMG RecompileRequired] -> RnMG RecompileRequired
-checkList [] = returnRn upToDate
-checkList (check:checks) = check `thenRn` \ recompile ->
+checkList :: [TcRn m RecompileRequired] -> TcRn m RecompileRequired
+checkList [] = returnM upToDate
+checkList (check:checks) = check `thenM` \ recompile ->
if recompile then
- returnRn outOfDate
+ returnM outOfDate
else
checkList checks
\end{code}
\begin{code}
-checkModUsage :: ImportVersion Name -> RnMG RecompileRequired
+checkModUsage :: ImportVersion Name -> TcRn m RecompileRequired
-- Given the usage information extracted from the old
-- M.hi file for the module being compiled, figure out
-- whether M needs to be recompiled.
= -- Load the imported interface is possible
-- We use tryLoadInterface, because failure is not an error
-- (might just be that the old .hi file for this module is out of date)
- -- We use ImportByUser/ImportByUserSource as the 'from' flag,
- -- a) because we need to know whether to load the .hi-boot file
- -- b) because loadInterface things matters are amiss if we
- -- ImportBySystem an interface it knows nothing about
let
doc_str = sep [ptext SLIT("need version info for"), ppr mod_name]
- from | is_boot = ImportByUserSource
- | otherwise = ImportByUser
+ from = ImportForUsage is_boot
in
- traceHiDiffsRn (text "Checking usages for module" <+> ppr mod_name) `thenRn_`
- tryLoadInterface doc_str mod_name from `thenRn` \ (iface, maybe_err) ->
+ traceHiDiffs (text "Checking usages for module" <+> ppr mod_name) `thenM_`
- case maybe_err of {
- Just err -> out_of_date (sep [ptext SLIT("Can't find version number for module"),
- ppr mod_name]) ;
+ recoverM (returnM Nothing)
+ (loadInterface doc_str mod_name from `thenM` \ iface ->
+ returnM (Just iface)) `thenM` \ mb_iface ->
+
+ case mb_iface of {
+ Nothing -> (out_of_date (sep [ptext SLIT("Can't find version number for module"),
+ ppr mod_name]));
-- Couldn't find or parse a module mentioned in the
-- old interface file. Don't complain -- it might just be that
-- the current module doesn't need that import and it's been deleted
- Nothing ->
+ Just iface ->
let
- new_vers = mi_version iface
- new_decl_vers = vers_decls new_vers
+ new_vers = mi_version iface
+ new_mod_vers = vers_module new_vers
+ new_decl_vers = vers_decls new_vers
+ new_export_vers = vers_exports new_vers
+ new_rule_vers = vers_rules new_vers
in
case whats_imported of { -- NothingAtAll dealt with earlier
- Everything old_mod_vers -> checkModuleVersion old_mod_vers new_vers `thenRn` \ recompile ->
+ Everything old_mod_vers -> checkModuleVersion old_mod_vers new_mod_vers `thenM` \ recompile ->
if recompile then
out_of_date (ptext SLIT("...and I needed the whole module"))
else
- returnRn upToDate ;
+ returnM upToDate ;
Specifically old_mod_vers maybe_old_export_vers old_decl_vers old_rule_vers ->
-- CHECK MODULE
- checkModuleVersion old_mod_vers new_vers `thenRn` \ recompile ->
+ checkModuleVersion old_mod_vers new_mod_vers `thenM` \ recompile ->
if not recompile then
- returnRn upToDate
+ returnM upToDate
else
-- CHECK EXPORT LIST
- if checkExportList maybe_old_export_vers new_vers then
- out_of_date (ptext SLIT("Export list changed"))
+ if checkExportList maybe_old_export_vers new_export_vers then
+ out_of_date_vers (ptext SLIT(" Export list changed"))
+ (fromJust maybe_old_export_vers)
+ new_export_vers
else
-- CHECK RULES
- if old_rule_vers /= vers_rules new_vers then
- out_of_date (ptext SLIT("Rules changed"))
+ if old_rule_vers /= new_rule_vers then
+ out_of_date_vers (ptext SLIT(" Rules changed"))
+ old_rule_vers new_rule_vers
else
-- CHECK ITEMS ONE BY ONE
- checkList [checkEntityUsage new_decl_vers u | u <- old_decl_vers] `thenRn` \ recompile ->
+ checkList [checkEntityUsage new_decl_vers u | u <- old_decl_vers] `thenM` \ recompile ->
if recompile then
- returnRn outOfDate -- This one failed, so just bail out now
+ returnM outOfDate -- This one failed, so just bail out now
else
- up_to_date (ptext SLIT("...but the bits I use haven't."))
+ up_to_date (ptext SLIT(" Great! The bits I use are up to date"))
}}
------------------------
-checkModuleVersion old_mod_vers new_vers
- | vers_module new_vers == old_mod_vers
+checkModuleVersion old_mod_vers new_mod_vers
+ | new_mod_vers == old_mod_vers
= up_to_date (ptext SLIT("Module version unchanged"))
| otherwise
- = out_of_date (ptext SLIT("Module version has changed"))
+ = out_of_date_vers (ptext SLIT(" Module version has changed"))
+ old_mod_vers new_mod_vers
------------------------
checkExportList Nothing new_vers = upToDate
-checkExportList (Just v) new_vers = v /= vers_exports new_vers
+checkExportList (Just v) new_vers = v /= new_vers
------------------------
checkEntityUsage new_vers (name,old_vers)
out_of_date (sep [ptext SLIT("No longer exported:"), ppr name])
Just new_vers -- It's there, but is it up to date?
- | new_vers == old_vers -> traceHiDiffsRn (text "Up to date" <+> ppr name <+> parens (ppr new_vers)) `thenRn_`
- returnRn upToDate
- | otherwise -> out_of_date (sep [ptext SLIT("Out of date:"), ppr name, ppr
- old_vers, ptext SLIT("->"), ppr new_vers])
-
-up_to_date msg = traceHiDiffsRn msg `thenRn_` returnRn upToDate
-out_of_date msg = traceHiDiffsRn msg `thenRn_` returnRn outOfDate
+ | new_vers == old_vers -> traceHiDiffs (text " Up to date" <+> ppr name <+> parens (ppr new_vers)) `thenM_`
+ returnM upToDate
+ | otherwise -> out_of_date_vers (ptext SLIT(" Out of date:") <+> ppr name)
+ old_vers new_vers
+
+up_to_date msg = traceHiDiffs msg `thenM_` returnM upToDate
+out_of_date msg = traceHiDiffs msg `thenM_` returnM outOfDate
+out_of_date_vers msg old_vers new_vers
+ = out_of_date (hsep [msg, ppr old_vers, ptext SLIT("->"), ppr new_vers])
\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
-\section[RnMonad]{The monad used by the renamer}
-
-\begin{code}
-module RnMonad(
- module RnMonad,
-
- module RdrName, -- Re-exports
- module Name, -- from these two
-
- Module,
- FiniteMap,
- Bag,
- RdrNameHsDecl,
- RdrNameInstDecl,
- Version,
- NameSet,
- OccName,
- Fixity
- ) where
-
-#include "HsVersions.h"
-
-import HsSyn
-import RdrHsSyn
-import RnHsSyn ( RenamedFixitySig )
-import HscTypes ( AvailEnv, emptyAvailEnv, lookupType,
- NameSupply(..),
- ImportedModuleInfo, WhetherHasOrphans, ImportVersion,
- PersistentRenamerState(..), RdrExportItem,
- DeclsMap, IfaceInsts, IfaceRules,
- HomeSymbolTable, TyThing,
- PersistentCompilerState(..), GlobalRdrEnv,
- LocalRdrEnv,
- HomeIfaceTable, PackageIfaceTable )
-import BasicTypes ( Version, defaultFixity,
- Fixity(..), FixityDirection(..) )
-import ErrUtils ( addShortErrLocLine, addShortWarnLocLine,
- Message, Messages, errorsFound, warningsFound,
- printErrorsAndWarnings
- )
-import RdrName ( RdrName, dummyRdrVarName, rdrNameModule, rdrNameOcc,
- RdrNameEnv, emptyRdrEnv, extendRdrEnv,
- addListToRdrEnv, rdrEnvToList, rdrEnvElts
- )
-import Id ( idName )
-import MkId ( seqId )
-import Name ( Name, OccName, NamedThing(..),
- nameOccName, nameRdrName,
- decode, mkInternalName
- )
-import NameEnv ( NameEnv, lookupNameEnv, emptyNameEnv,
- extendNameEnvList )
-import Module ( Module, ModuleName, ModuleSet, emptyModuleSet,
- PackageName, preludePackage )
-import PrelInfo ( ghcPrimExports,
- cCallableClassDecl, cReturnableClassDecl, assertDecl )
-import PrelNames ( mkUnboundName, gHC_PRIM_Name )
-import NameSet
-import CmdLineOpts ( DynFlags, DynFlag(..), dopt )
-import SrcLoc ( SrcLoc, generatedSrcLoc, noSrcLoc )
-import Unique ( Unique )
-import FiniteMap ( FiniteMap )
-import Maybes ( seqMaybe )
-import Bag ( Bag, emptyBag, isEmptyBag, snocBag )
-import UniqSupply
-import Outputable
-
-import DATA_IOREF ( IORef, newIORef, readIORef, writeIORef )
-import UNSAFE_IO ( unsafePerformIO )
-import FIX_IO ( fixIO )
-
-import IO ( hPutStr, stderr )
-
-infixr 9 `thenRn`, `thenRn_`
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Somewhat magical interface to other monads}
-%* *
-%************************************************************************
-
-\begin{code}
-ioToRnM :: IO r -> RnM d (Either IOError r)
-ioToRnM io rn_down g_down = (io >>= \ ok -> return (Right ok))
- `catch`
- (\ err -> return (Left err))
-
-ioToRnM_no_fail :: IO r -> RnM d r
-ioToRnM_no_fail io rn_down g_down
- = (io >>= \ ok -> return ok)
- `catch`
- (\ err -> panic "ioToRnM_no_fail: the I/O operation failed!")
-
-traceRn :: SDoc -> RnM d ()
-traceRn msg = ifOptRn Opt_D_dump_rn_trace (putDocRn msg)
-
-traceHiDiffsRn :: SDoc -> RnM d ()
-traceHiDiffsRn msg = ifOptRn Opt_D_dump_hi_diffs (putDocRn msg)
-
-putDocRn :: SDoc -> RnM d ()
-putDocRn msg = ioToRnM (printErrs alwaysQualify msg) `thenRn_`
- returnRn ()
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Data types}
-%* *
-%************************************************************************
-
-%===================================================
-\subsubsection{ MONAD TYPES}
-%===================================================
-
-\begin{code}
-type RnM d r = RnDown -> d -> IO r
-type RnMS r = RnM SDown r -- Renaming source
-type RnMG r = RnM () r -- Getting global names etc
-
- -- Common part
-data RnDown
- = RnDown {
- rn_mod :: Module, -- This module
- rn_loc :: SrcLoc, -- Current locn
-
- rn_dflags :: DynFlags,
-
- rn_hit :: HomeIfaceTable,
- rn_done :: Name -> Maybe TyThing, -- Tells what things (both in the
- -- home package and other packages)
- -- were already available (i.e. in
- -- the relevant SymbolTable) before
- -- compiling this module
- -- The Name passed to rn_done is guaranteed to be a Global,
- -- so it has a Module, so it can be looked up
-
- rn_errs :: IORef Messages,
- rn_ns :: IORef NameSupply,
- rn_ifaces :: IORef Ifaces
- }
-
- -- For renaming source code
-data SDown = SDown {
- rn_mode :: RnMode,
-
- rn_genv :: GlobalRdrEnv, -- Top level environment
-
- rn_avails :: AvailEnv,
- -- Top level AvailEnv; contains all the things that
- -- are nameable in the top-level scope, regardless of
- -- *how* they can be named (qualified, unqualified...)
- -- It is used only to map a Class to its class ops, and
- -- hence to resolve the binders in an instance decl
-
- rn_lenv :: LocalRdrEnv, -- Local name envt
- -- Does *not* include 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
-
- rn_fixenv :: LocalFixityEnv -- Local fixities (for non-top-level
- -- declarations)
- -- The global fixities are held in the
- -- HIT or PIT. Why? See the comments
- -- with RnIfaces.lookupLocalFixity
- }
-
-data RnMode = SourceMode -- Renaming source code
- | InterfaceMode -- Renaming interface declarations.
- | CmdLineMode -- Renaming a command-line expression
-
-isInterfaceMode InterfaceMode = True
-isInterfaceMode _ = False
-
-isCmdLineMode CmdLineMode = True
-isCmdLineMode _ = False
-\end{code}
-
-\begin{code}
-type LocalFixityEnv = NameEnv RenamedFixitySig
- -- We keep the whole fixity sig so that we
- -- can report line-number info when there is a duplicate
- -- fixity declaration
-
-emptyLocalFixityEnv :: LocalFixityEnv
-emptyLocalFixityEnv = emptyNameEnv
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Interface file stuff}
-%* *
-%************************************************************************
-
-\begin{code}
-type IfaceDeprecs = Maybe (Either DeprecTxt [(RdrName,DeprecTxt)])
- -- Nothing => NoDeprecs
- -- Just (Left t) => DeprecAll
- -- Just (Right p) => DeprecSome
-
-data ParsedIface
- = ParsedIface {
- pi_mod :: ModuleName,
- pi_pkg :: PackageName,
- pi_vers :: Version, -- Module version number
- pi_orphan :: WhetherHasOrphans, -- Whether this module has orphans
- pi_usages :: [ImportVersion OccName], -- Usages
- pi_exports :: (Version, [RdrExportItem]), -- Exports
- pi_decls :: [(Version, RdrNameTyClDecl)], -- Local definitions
- pi_fixity :: [(RdrName,Fixity)], -- Local fixity declarations,
- pi_insts :: [RdrNameInstDecl], -- Local instance declarations
- pi_rules :: (Version, [RdrNameRuleDecl]), -- Rules, with their version
- pi_deprecs :: IfaceDeprecs -- Deprecations
- }
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Wired-in interfaces}
-%* *
-%************************************************************************
-
-\begin{code}
-ghcPrimIface :: ParsedIface
-ghcPrimIface = ParsedIface {
- pi_mod = gHC_PRIM_Name,
- pi_pkg = preludePackage,
- pi_vers = 1,
- pi_orphan = False,
- pi_usages = [],
- pi_exports = (1, [(gHC_PRIM_Name, ghcPrimExports)]),
- pi_decls = [(1,cCallableClassDecl),
- (1,cReturnableClassDecl),
- (1,assertDecl)],
- pi_fixity = [(nameRdrName (idName seqId), Fixity 0 InfixR)],
- -- seq is infixr 0
- pi_insts = [],
- pi_rules = (1,[]),
- pi_deprecs = Nothing
- }
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{The renamer state}
-%* *
-%************************************************************************
-
-\begin{code}
-data Ifaces = Ifaces {
- -- PERSISTENT FIELDS
- iPIT :: PackageIfaceTable,
- -- The ModuleIFaces for modules in other packages
- -- whose interfaces we have opened
- -- The declarations in these interface files are held in
- -- iDecls, iInsts, iRules (below), not in the mi_decls fields
- -- of the iPIT. What _is_ in the iPIT is:
- -- * The Module
- -- * Version info
- -- * Its exports
- -- * Fixities
- -- * Deprecations
- -- The iPIT field is initialised from the compiler's persistent
- -- package symbol table, and the renamer incrementally adds
- -- to it.
-
- iImpModInfo :: ImportedModuleInfo,
- -- Modules that we know something about, because they are mentioned
- -- in interface files, BUT which we have not loaded yet.
- -- No module is both in here and in the PIT
-
- iDecls :: DeclsMap,
- -- A single, global map of Names to unslurped decls
-
- iInsts :: IfaceInsts,
- -- 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.
- -- Each is 'gated' by the names that must be available before
- -- this instance decl is needed.
-
- iRules :: IfaceRules,
- -- Similar to instance decls, only for rules
-
- -- EPHEMERAL FIELDS
- -- These fields persist during the compilation of a single module only
- 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.
- --
- -- It's used for two things:
- -- a) To record what we've already slurped, so
- -- we can no-op if we try to slurp it again
- -- b) As the 'gates' for importing rules. We import a rule
- -- if all its LHS free vars have been slurped
-
- iVSlurp :: (ModuleSet, NameSet)
- -- The Names are all the (a) non-wired-in
- -- (b) "big"
- -- (c) non-locally-defined
- -- (d) home-package
- -- 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.
- --
- -- The module set is the non-home-package modules from which we have
- -- slurped at least one name.
- -- It's worth keeping separately, because there's no very easy
- -- way to distinguish the "big" names from the "non-big" ones.
- -- But this is a decision we might want to revisit.
- }
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Main monad code}
-%* *
-%************************************************************************
-
-\begin{code}
-runRn dflags hit hst pcs mod do_rn
- = do { (pcs, msgs, r) <- initRn dflags hit hst pcs mod do_rn ;
- printErrorsAndWarnings alwaysQualify msgs ;
- return (pcs, errorsFound msgs, r)
- }
-
-initRn :: DynFlags
- -> HomeIfaceTable -> HomeSymbolTable
- -> PersistentCompilerState
- -> Module
- -> RnMG t
- -> IO (PersistentCompilerState, Messages, t)
-
-initRn dflags hit hst pcs mod do_rn
- = do
- let prs = pcs_PRS pcs
- let pte = pcs_PTE pcs
- let ifaces = Ifaces { iPIT = pcs_PIT pcs,
- iDecls = prsDecls prs,
- iInsts = prsInsts prs,
- iRules = prsRules prs,
-
- iImpModInfo = prsImpMods prs,
- iSlurp = unitNameSet (mkUnboundName dummyRdrVarName),
- -- Pretend that the dummy unbound name has already been
- -- slurped. This is what's returned for an out-of-scope name,
- -- and we don't want thereby to try to suck it in!
- iVSlurp = (emptyModuleSet, emptyNameSet)
- }
- names_var <- newIORef (prsOrig prs)
- errs_var <- newIORef (emptyBag,emptyBag)
- iface_var <- newIORef ifaces
- let rn_down = RnDown { rn_mod = mod,
- rn_loc = noSrcLoc,
-
- rn_dflags = dflags,
- rn_hit = hit,
- rn_done = lookupType hst pte,
-
- rn_ns = names_var,
- rn_errs = errs_var,
- rn_ifaces = iface_var,
- }
-
- -- do the business
- res <- do_rn rn_down ()
-
- -- Grab state and record it
- (warns, errs) <- readIORef errs_var
- new_ifaces <- readIORef iface_var
- new_orig <- readIORef names_var
- let new_prs = prs { prsOrig = new_orig,
- prsImpMods = iImpModInfo new_ifaces,
- prsDecls = iDecls new_ifaces,
- prsInsts = iInsts new_ifaces,
- prsRules = iRules new_ifaces }
- let new_pcs = pcs { pcs_PIT = iPIT new_ifaces,
- pcs_PRS = new_prs }
-
- return (new_pcs, (warns, errs), res)
-
-initRnMS :: GlobalRdrEnv -> AvailEnv -> LocalRdrEnv -> LocalFixityEnv -> RnMode
- -> RnMS a -> RnM d a
-
-initRnMS rn_env avails local_env fixity_env mode thing_inside rn_down g_down
- -- The fixity_env appears in both the rn_fixenv field
- -- and in the HIT. See comments with RnHiFiles.lookupFixityRn
- = let
- s_down = SDown { rn_genv = rn_env, rn_avails = avails,
- rn_lenv = local_env, rn_fixenv = fixity_env,
- rn_mode = mode }
- in
- thing_inside rn_down s_down
-
-initIfaceRnMS :: Module -> RnMS r -> RnM d r
-initIfaceRnMS mod thing_inside
- = initRnMS emptyRdrEnv emptyAvailEnv emptyRdrEnv
- emptyLocalFixityEnv InterfaceMode
- (setModuleRn mod thing_inside)
-\end{code}
-
-@renameDerivedCode@ is used to rename stuff ``out-of-line'';
-that is, not as part of the main renamer.
-Sole examples: derived definitions,
-which are only generated in the type checker.
-
-The @NameSupply@ includes a @UniqueSupply@, so if you call it more than
-once you must either split it, or install a fresh unique supply.
-
-\begin{code}
-renameDerivedCode :: DynFlags
- -> Module
- -> PersistentRenamerState
- -> RnMS r
- -> r
-
-renameDerivedCode dflags mod prs thing_inside
- = unsafePerformIO $
- -- It's not really unsafe! When renaming source code we
- -- only do any I/O if we need to read in a fixity declaration;
- -- and that doesn't happen in pragmas etc
-
- do { us <- mkSplitUniqSupply 'r'
- ; names_var <- newIORef ((prsOrig prs) { nsUniqs = us })
- ; errs_var <- newIORef (emptyBag,emptyBag)
-
- ; let rn_down = RnDown { rn_dflags = dflags,
- rn_loc = generatedSrcLoc, rn_ns = names_var,
- rn_errs = errs_var,
- rn_mod = mod,
- rn_done = bogus "rn_done",
- rn_hit = bogus "rn_hit",
- rn_ifaces = bogus "rn_ifaces"
- }
- ; let s_down = SDown { rn_mode = InterfaceMode,
- -- So that we can refer to PrelBase.True etc
- rn_avails = emptyAvailEnv,
- rn_genv = emptyRdrEnv, rn_lenv = emptyRdrEnv,
- rn_fixenv = emptyLocalFixityEnv }
-
- ; result <- thing_inside rn_down s_down
- ; messages <- readIORef errs_var
-
- ; if bad messages then
- do { hPutStr stderr "Urk! renameDerivedCode found errors or warnings"
- ; printErrorsAndWarnings alwaysQualify messages
- }
- else
- return()
-
- ; return result
- }
- where
-#ifdef DEBUG
- bad messages = errorsFound messages || warningsFound messages
-#else
- bad messages = errorsFound messages
-#endif
-
-bogus s = panic ("rnameSourceCode: " ++ s) -- Used for unused record fields
-
-{-# INLINE thenRn #-}
-{-# INLINE thenRn_ #-}
-{-# INLINE returnRn #-}
-{-# INLINE andRn #-}
-
-returnRn :: a -> RnM d a
-thenRn :: RnM d a -> (a -> RnM d b) -> RnM d b
-thenRn_ :: RnM d a -> RnM d b -> RnM d b
-andRn :: (a -> a -> a) -> RnM d a -> RnM d a -> RnM d a
-mapRn :: (a -> RnM d b) -> [a] -> RnM d [b]
-mapRn_ :: (a -> RnM d b) -> [a] -> RnM d ()
-mapMaybeRn :: (a -> RnM d (Maybe b)) -> [a] -> RnM d [b]
-flatMapRn :: (a -> RnM d [b]) -> [a] -> RnM d [b]
-sequenceRn :: [RnM d a] -> RnM d [a]
-sequenceRn_ :: [RnM d a] -> RnM d ()
-foldlRn :: (b -> a -> RnM d b) -> b -> [a] -> RnM d b
-mapAndUnzipRn :: (a -> RnM d (b,c)) -> [a] -> RnM d ([b],[c])
-fixRn :: (a -> RnM d a) -> RnM d a
-
-returnRn v gdown ldown = return v
-thenRn m k gdown ldown = m gdown ldown >>= \ r -> k r gdown ldown
-thenRn_ m k gdown ldown = m gdown ldown >> k gdown ldown
-fixRn m gdown ldown = fixIO (\r -> m r gdown ldown)
-andRn combiner m1 m2 gdown ldown
- = m1 gdown ldown >>= \ res1 ->
- m2 gdown ldown >>= \ res2 ->
- return (combiner res1 res2)
-
-sequenceRn [] = returnRn []
-sequenceRn (m:ms) = m `thenRn` \ r ->
- sequenceRn ms `thenRn` \ rs ->
- returnRn (r:rs)
-
-sequenceRn_ [] = returnRn ()
-sequenceRn_ (m:ms) = m `thenRn_` sequenceRn_ ms
-
-mapRn f [] = returnRn []
-mapRn f (x:xs)
- = f x `thenRn` \ r ->
- mapRn f xs `thenRn` \ rs ->
- returnRn (r:rs)
-
-mapRn_ f [] = returnRn ()
-mapRn_ f (x:xs) =
- f x `thenRn_`
- mapRn_ f xs
-
-foldlRn k z [] = returnRn z
-foldlRn k z (x:xs) = k z x `thenRn` \ z' ->
- foldlRn k z' xs
-
-mapAndUnzipRn f [] = returnRn ([],[])
-mapAndUnzipRn f (x:xs)
- = f x `thenRn` \ (r1, r2) ->
- mapAndUnzipRn f xs `thenRn` \ (rs1, rs2) ->
- returnRn (r1:rs1, r2:rs2)
-
-mapAndUnzip3Rn f [] = returnRn ([],[],[])
-mapAndUnzip3Rn f (x:xs)
- = f x `thenRn` \ (r1, r2, r3) ->
- mapAndUnzip3Rn f xs `thenRn` \ (rs1, rs2, rs3) ->
- returnRn (r1:rs1, r2:rs2, r3:rs3)
-
-mapMaybeRn f [] = returnRn []
-mapMaybeRn f (x:xs) = f x `thenRn` \ maybe_r ->
- mapMaybeRn f xs `thenRn` \ rs ->
- case maybe_r of
- Nothing -> returnRn rs
- Just r -> returnRn (r:rs)
-
-flatMapRn f [] = returnRn []
-flatMapRn f (x:xs) = f x `thenRn` \ r ->
- flatMapRn f xs `thenRn` \ rs ->
- returnRn (r ++ rs)
-\end{code}
-
-
-
-%************************************************************************
-%* *
-\subsection{Boring plumbing for common part}
-%* *
-%************************************************************************
-
-
-%================
-\subsubsection{ Errors and warnings}
-%=====================
-
-\begin{code}
-failWithRn :: a -> Message -> RnM d a
-failWithRn res msg (RnDown {rn_errs = errs_var, rn_loc = loc}) l_down
- = readIORef errs_var >>= \ (warns,errs) ->
- writeIORef errs_var (warns, errs `snocBag` err) >>
- return res
- where
- err = addShortErrLocLine loc msg
-
-warnWithRn :: a -> Message -> RnM d a
-warnWithRn res msg (RnDown {rn_errs = errs_var, rn_loc = loc}) l_down
- = readIORef errs_var >>= \ (warns,errs) ->
- writeIORef errs_var (warns `snocBag` warn, errs) >>
- return res
- where
- warn = addShortWarnLocLine loc msg
-
-tryRn :: RnM d a -> RnM d (Either Messages a)
-tryRn try_this down@(RnDown {rn_errs = errs_var}) l_down
- = do current_msgs <- readIORef errs_var
- writeIORef errs_var (emptyBag,emptyBag)
- a <- try_this down l_down
- (warns, errs) <- readIORef errs_var
- writeIORef errs_var current_msgs
- if (isEmptyBag errs)
- then return (Right a)
- else return (Left (warns,errs))
-
-setErrsRn :: Messages -> RnM d ()
-setErrsRn msgs down@(RnDown {rn_errs = errs_var}) l_down
- = do writeIORef errs_var msgs; return ()
-
-addErrRn :: Message -> RnM d ()
-addErrRn err = failWithRn () err
-
-checkRn :: Bool -> Message -> RnM d () -- Check that a condition is true
-checkRn False err = addErrRn err
-checkRn True err = returnRn ()
-
-warnCheckRn :: Bool -> Message -> RnM d () -- Check that a condition is true
-warnCheckRn False err = addWarnRn err
-warnCheckRn True err = returnRn ()
-
-addWarnRn :: Message -> RnM d ()
-addWarnRn warn = warnWithRn () warn
-
-checkErrsRn :: RnM d Bool -- True <=> no errors so far
-checkErrsRn (RnDown {rn_errs = errs_var}) l_down
- = readIORef errs_var >>= \ (warns,errs) ->
- return (isEmptyBag errs)
-
-doptRn :: DynFlag -> RnM d Bool
-doptRn dflag (RnDown { rn_dflags = dflags}) l_down
- = return (dopt dflag dflags)
-
-ifOptRn :: DynFlag -> RnM d a -> RnM d ()
-ifOptRn dflag thing_inside down@(RnDown { rn_dflags = dflags}) l_down
- | dopt dflag dflags = thing_inside down l_down >> return ()
- | otherwise = return ()
-
-getDOptsRn :: RnM d DynFlags
-getDOptsRn (RnDown { rn_dflags = dflags}) l_down
- = return dflags
-\end{code}
-
-
-%================
-\subsubsection{Source location}
-%=====================
-
-\begin{code}
-pushSrcLocRn :: SrcLoc -> RnM d a -> RnM d a
-pushSrcLocRn loc' m down l_down
- = m (down {rn_loc = loc'}) l_down
-
-getSrcLocRn :: RnM d SrcLoc
-getSrcLocRn down l_down
- = return (rn_loc down)
-\end{code}
-
-%================
-\subsubsection{The finder and home symbol table}
-%=====================
-
-\begin{code}
-getHomeIfaceTableRn :: RnM d HomeIfaceTable
-getHomeIfaceTableRn down l_down = return (rn_hit down)
-
-getTypeEnvRn :: RnM d (Name -> Maybe TyThing)
-getTypeEnvRn down l_down = return (rn_done down)
-
-extendTypeEnvRn :: NameEnv TyThing -> RnM d a -> RnM d a
-extendTypeEnvRn env inside down l_down
- = inside down{rn_done=new_rn_done} l_down
- where new_rn_done = \nm -> lookupNameEnv env nm `seqMaybe` rn_done down nm
-\end{code}
-
-%================
-\subsubsection{Name supply}
-%=====================
-
-\begin{code}
-getNameSupplyRn :: RnM d NameSupply
-getNameSupplyRn rn_down l_down
- = readIORef (rn_ns rn_down)
-
-setNameSupplyRn :: NameSupply -> RnM d ()
-setNameSupplyRn names' (RnDown {rn_ns = names_var}) l_down
- = writeIORef names_var names'
-
-getUniqRn :: RnM d Unique
-getUniqRn (RnDown {rn_ns = names_var}) l_down
- = readIORef names_var >>= \ ns ->
- let
- (us1,us') = splitUniqSupply (nsUniqs ns)
- in
- writeIORef names_var (ns {nsUniqs = us'}) >>
- return (uniqFromSupply us1)
-\end{code}
-
-%================
-\subsubsection{ Module}
-%=====================
-
-\begin{code}
-getModuleRn :: RnM d Module
-getModuleRn (RnDown {rn_mod = mod}) l_down
- = return mod
-
-setModuleRn :: Module -> RnM d a -> RnM d a
-setModuleRn new_mod enclosed_thing rn_down l_down
- = enclosed_thing (rn_down {rn_mod = new_mod}) l_down
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Plumbing for rename-source part}
-%* *
-%************************************************************************
-
-%================
-\subsubsection{ RnEnv}
-%=====================
-
-\begin{code}
-getLocalNameEnv :: RnMS LocalRdrEnv
-getLocalNameEnv rn_down (SDown {rn_lenv = local_env})
- = return local_env
-
-getGlobalNameEnv :: RnMS GlobalRdrEnv
-getGlobalNameEnv rn_down (SDown {rn_genv = global_env})
- = return global_env
-
-getGlobalAvails :: RnMS AvailEnv
-getGlobalAvails rn_down (SDown {rn_avails = avails})
- = return avails
-
-setLocalNameEnv :: LocalRdrEnv -> RnMS a -> RnMS a
-setLocalNameEnv local_env' m rn_down l_down
- = m rn_down (l_down {rn_lenv = local_env'})
-
-getFixityEnv :: RnMS LocalFixityEnv
-getFixityEnv rn_down (SDown {rn_fixenv = fixity_env})
- = return fixity_env
-
-setFixityEnv :: LocalFixityEnv -> RnMS a -> RnMS a
-setFixityEnv fixes enclosed_scope rn_down l_down
- = enclosed_scope rn_down (l_down {rn_fixenv = fixes})
-\end{code}
-
-%================
-\subsubsection{ Mode}
-%=====================
-
-\begin{code}
-getModeRn :: RnMS RnMode
-getModeRn rn_down (SDown {rn_mode = mode})
- = return mode
-
-setModeRn :: RnMode -> RnMS a -> RnMS a
-setModeRn new_mode thing_inside rn_down l_down
- = thing_inside rn_down (l_down {rn_mode = new_mode})
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Plumbing for rename-globals part}
-%* *
-%************************************************************************
-
-\begin{code}
-getIfacesRn :: RnM d Ifaces
-getIfacesRn (RnDown {rn_ifaces = iface_var}) _
- = readIORef iface_var
-
-setIfacesRn :: Ifaces -> RnM d ()
-setIfacesRn ifaces (RnDown {rn_ifaces = iface_var}) _
- = writeIORef iface_var ifaces
-\end{code}
\begin{code}
module RnNames (
- ExportAvails, getGlobalNames, exportsFromAvail
+ rnImports, importsFromLocalDecls, exportsFromAvail,
+ reportUnusedNames
) where
#include "HsVersions.h"
+import {-# SOURCE #-} RnHiFiles ( loadInterface )
+
import CmdLineOpts ( DynFlag(..) )
-import HsSyn ( HsModule(..), HsDecl(..), IE(..), ieName, ImportDecl(..),
+import HsSyn ( HsDecl(..), IE(..), ieName, ImportDecl(..),
ForeignDecl(..),
- collectLocatedHsBinders
- )
-import RdrHsSyn ( RdrNameIE, RdrNameImportDecl,
- RdrNameHsModule, RdrNameHsDecl
+ collectLocatedHsBinders, tyClDeclNames
)
-import RnIfaces ( recordLocalSlurps )
-import RnHiFiles ( getTyClDeclBinders, loadInterface )
+import RdrHsSyn ( RdrNameIE, RdrNameImportDecl, RdrNameHsDecl )
import RnEnv
-import RnMonad
+import TcRnMonad
import FiniteMap
-import PrelNames ( pRELUDE_Name, mAIN_Name, isUnboundName )
-import Module ( ModuleName, moduleName, WhereFrom(..) )
-import Name ( Name, nameSrcLoc, nameOccName )
+import PrelNames ( pRELUDE_Name, mAIN_Name, isBuiltInSyntaxName )
+import Module ( Module, ModuleName, moduleName,
+ moduleNameUserString,
+ unitModuleEnvByName, lookupModuleEnvByName,
+ moduleEnvElts )
+import Name ( Name, nameSrcLoc, nameOccName, nameModule )
import NameSet
import NameEnv
+import OccName ( OccName, dataName, isTcOcc )
import HscTypes ( Provenance(..), ImportReason(..), GlobalRdrEnv,
- GenAvailInfo(..), AvailInfo, Avails, AvailEnv,
- Deprecations(..), ModIface(..), emptyAvailEnv
+ GenAvailInfo(..), AvailInfo, Avails, IsBootInterface,
+ availName, availNames, availsToNameSet,
+ Deprecations(..), ModIface(..),
+ GlobalRdrElt(..), unQualInScope, isLocalGRE
)
-import RdrName ( rdrNameOcc, setRdrNameOcc )
-import OccName ( setOccNameSpace, dataName )
-import NameSet ( elemNameSet, emptyNameSet )
+import RdrName ( rdrNameOcc, setRdrNameSpace, emptyRdrEnv, foldRdrEnv, isQual )
+import SrcLoc ( noSrcLoc )
import Outputable
import Maybes ( maybeToBool, catMaybes )
import ListSetOps ( removeDups )
import Util ( sortLt, notNull )
import List ( partition )
+import IO ( openFile, IOMode(..) )
\end{code}
%************************************************************************
%* *
-\subsection{Get global names}
+ rnImports
%* *
%************************************************************************
\begin{code}
-getGlobalNames :: Module -> RdrNameHsModule
- -> RnMG (GlobalRdrEnv, -- Maps all in-scope things
- GlobalRdrEnv, -- Maps just *local* things
- ExportAvails) -- The exported stuff
-
-getGlobalNames this_mod (HsModule _ _ _ imports decls _ mod_loc)
- = -- PROCESS LOCAL DECLS
- -- Do these *first* so that the correct provenance gets
- -- into the global name cache.
- importsFromLocalDecls this_mod decls `thenRn` \ (local_gbl_env, local_mod_avails) ->
-
- -- PROCESS IMPORT DECLS
+rnImports :: [RdrNameImportDecl]
+ -> TcRn m (GlobalRdrEnv, ImportAvails)
+
+rnImports imports
+ = -- PROCESS IMPORT DECLS
-- Do the non {- SOURCE -} ones first, so that we get a helpful
-- warning for {- SOURCE -} ones that are unnecessary
- doptRn Opt_NoImplicitPrelude `thenRn` \ opt_no_prelude ->
+ getModule `thenM` \ this_mod ->
+ getSrcLocM `thenM` \ loc ->
+ doptM Opt_NoImplicitPrelude `thenM` \ opt_no_prelude ->
let
- all_imports = mk_prel_imports opt_no_prelude ++ imports
+ all_imports = mk_prel_imports this_mod loc opt_no_prelude ++ imports
(source, ordinary) = partition is_source_import all_imports
- is_source_import (ImportDecl _ ImportByUserSource _ _ _ _) = True
- is_source_import other = False
+ is_source_import (ImportDecl _ is_boot _ _ _ _) = is_boot
- get_imports = importsFromImportDecl this_mod_name
+ get_imports = importsFromImportDecl (moduleName this_mod)
in
- mapAndUnzipRn get_imports ordinary `thenRn` \ (imp_gbl_envs1, imp_avails_s1) ->
- mapAndUnzipRn get_imports source `thenRn` \ (imp_gbl_envs2, imp_avails_s2) ->
+ mappM get_imports ordinary `thenM` \ stuff1 ->
+ mappM get_imports source `thenM` \ stuff2 ->
-- COMBINE RESULTS
- -- We put the local env second, so that a local provenance
- -- "wins", even if a module imports itself.
let
+ (imp_gbl_envs, imp_avails) = unzip (stuff1 ++ stuff2)
gbl_env :: GlobalRdrEnv
- imp_gbl_env = foldr plusGlobalRdrEnv emptyRdrEnv (imp_gbl_envs2 ++ imp_gbl_envs1)
- gbl_env = imp_gbl_env `plusGlobalRdrEnv` local_gbl_env
+ gbl_env = foldr plusGlobalRdrEnv emptyRdrEnv imp_gbl_envs
- all_avails :: ExportAvails
- all_avails = foldr plusExportAvails local_mod_avails (imp_avails_s2 ++ imp_avails_s1)
+ all_avails :: ImportAvails
+ all_avails = foldr plusImportAvails emptyImportAvails imp_avails
in
-
-- ALL DONE
- returnRn (gbl_env, local_gbl_env, all_avails)
+ returnM (gbl_env, all_avails)
where
- this_mod_name = moduleName this_mod
-
-- NB: opt_NoImplicitPrelude is slightly different to import Prelude ();
- -- because the former doesn't even look at Prelude.hi for instance declarations,
- -- whereas the latter does.
- mk_prel_imports no_prelude
- | this_mod_name == pRELUDE_Name ||
- explicit_prelude_import ||
- no_prelude
+ -- because the former doesn't even look at Prelude.hi for instance
+ -- declarations, whereas the latter does.
+ mk_prel_imports this_mod loc no_prelude
+ | moduleName this_mod == pRELUDE_Name
+ || explicit_prelude_import
+ || no_prelude
= []
- | otherwise = [ImportDecl pRELUDE_Name
- ImportByUser
- False {- Not qualified -}
- Nothing {- No "as" -}
- Nothing {- No import list -}
- mod_loc]
-
+ | otherwise = [preludeImportDecl loc]
+
explicit_prelude_import
- = notNull [ () | (ImportDecl mod _ _ _ _ _) <- imports, mod == pRELUDE_Name ]
+ = notNull [ () | (ImportDecl mod _ _ _ _ _) <- imports,
+ mod == pRELUDE_Name ]
+
+preludeImportDecl loc
+ = ImportDecl pRELUDE_Name
+ False {- Not a boot interface -}
+ False {- Not qualified -}
+ Nothing {- No "as" -}
+ Nothing {- No import list -}
+ loc
\end{code}
\begin{code}
importsFromImportDecl :: ModuleName
-> RdrNameImportDecl
- -> RnMG (GlobalRdrEnv,
- ExportAvails)
+ -> TcRn m (GlobalRdrEnv, ImportAvails)
+
+importsFromImportDecl this_mod_name
+ (ImportDecl imp_mod_name is_boot qual_only as_mod import_spec iloc)
+ = addSrcLoc iloc $
+ let
+ doc = ppr imp_mod_name <+> ptext SLIT("is directly imported")
+ in
+
+ -- If there's an error in loadInterface, (e.g. interface
+ -- file not found) we get lots of spurious errors from 'filterImports'
+ recoverM (returnM Nothing)
+ (loadInterface doc imp_mod_name (ImportByUser is_boot) `thenM` \ iface ->
+ returnM (Just iface)) `thenM` \ mb_iface ->
-importsFromImportDecl this_mod_name (ImportDecl imp_mod_name from qual_only as_mod import_spec iloc)
- = pushSrcLocRn iloc $
+ case mb_iface of {
+ Nothing -> returnM (emptyRdrEnv, emptyImportAvails ) ;
+ Just iface ->
- loadInterface (ppr imp_mod_name <+> ptext SLIT("is directly imported"))
- imp_mod_name from `thenRn` \ iface ->
let
imp_mod = mi_module iface
avails_by_module = mi_exports iface
deprecs = mi_deprecs iface
+ dir_imp = unitModuleEnvByName imp_mod_name (imp_mod, import_all import_spec)
avails :: Avails
avails = [ avail | (mod_name, avails) <- avails_by_module,
-- then you'll get a 'B does not export AType' message. Oh well.
in
- if null avails_by_module then
- -- If there's an error in loadInterface, (e.g. interface
- -- file not found) we get lots of spurious errors from 'filterImports'
- returnRn (emptyRdrEnv, mkEmptyExportAvails imp_mod_name)
- else
-
-- Complain if we import a deprecated module
- ifOptRn Opt_WarnDeprecations (
+ ifOptM Opt_WarnDeprecations (
case deprecs of
- DeprecAll txt -> addWarnRn (moduleDeprec imp_mod_name txt)
- other -> returnRn ()
- ) `thenRn_`
+ DeprecAll txt -> addWarn (moduleDeprec imp_mod_name txt)
+ other -> returnM ()
+ ) `thenM_`
-- Filter the imports according to the import list
- filterImports imp_mod_name from import_spec avails `thenRn` \ (filtered_avails, explicits) ->
+ filterImports imp_mod_name is_boot import_spec avails `thenM` \ (filtered_avails, explicits) ->
let
- unqual_imp = not qual_only -- Maybe want unqualified names
+ unqual_imp = not qual_only -- Maybe want unqualified names
qual_mod = case as_mod of
Nothing -> imp_mod_name
Just another_name -> another_name
mk_prov name = NonLocalDef (UserImport imp_mod iloc (name `elemNameSet` explicits))
gbl_env = mkGlobalRdrEnv qual_mod unqual_imp mk_prov filtered_avails deprecs
- exports = mkExportAvails qual_mod unqual_imp gbl_env filtered_avails
+ imports = mkImportAvails qual_mod unqual_imp gbl_env filtered_avails
in
- returnRn (gbl_env, exports)
+ returnM (gbl_env, imports { imp_mods = dir_imp})
+ }
+
+import_all (Just (False, _)) = False -- Imports are spec'd explicitly
+import_all other = True -- Everything is imported
\end{code}
+%************************************************************************
+%* *
+ importsFromLocalDecls
+%* *
+%************************************************************************
+
+From the top-level declarations of this module produce
+ * the lexical environment
+ * the ImportAvails
+created by its bindings.
+
+Complain about duplicate bindings
+
\begin{code}
-importsFromLocalDecls this_mod decls
- = mapRn (getLocalDeclBinders this_mod) decls `thenRn` \ avails_s ->
+importsFromLocalDecls :: [RdrNameHsDecl]
+ -> TcRn m (GlobalRdrEnv, ImportAvails)
+importsFromLocalDecls decls
+ = getModule `thenM` \ this_mod ->
+ mappM (getLocalDeclBinders this_mod) decls `thenM` \ avails_s ->
-- The avails that are returned don't include the "system" names
let
avails = concat avails_s
-- The complaint will come out as "Multiple declarations of Foo.f" because
-- since 'f' is in the env twice, the unQualInScope used by the error-msg
-- printer returns False. It seems awkward to fix, unfortunately.
- mapRn_ (addErrRn . dupDeclErr) dups `thenRn_`
-
+ mappM_ (addErr . dupDeclErr) dups `thenM_`
- -- Record that locally-defined things are available
- recordLocalSlurps (availsToNameSet avails) `thenRn_`
+ doptM Opt_NoImplicitPrelude `thenM` \ implicit_prelude ->
let
mod_name = moduleName this_mod
unqual_imp = True -- Want unqualified names
mk_prov n = LocalDef -- Provenance is local
- gbl_env = mkGlobalRdrEnv mod_name unqual_imp mk_prov avails NoDeprecs
+ gbl_env = mkGlobalRdrEnv mod_name unqual_imp mk_prov avails NoDeprecs
-- NoDeprecs: don't complain about locally defined names
-- For a start, we may be exporting a deprecated thing
-- Also we may use a deprecated thing in the defn of another
-- the defn of a non-deprecated thing, when changing a module's
-- interface
- exports = mkExportAvails mod_name unqual_imp gbl_env avails
+
+ -- Optimisation: filter out names for built-in syntax
+ -- They just clutter up the environment (esp tuples), and the parser
+ -- will generate Exact RdrNames for them, so the cluttered
+ -- envt is no use. To avoid doing this filter all the type,
+ -- we use -fno-implicit-prelude as a clue that the filter is
+ -- worth while. Really, it's only useful for Base and Tuple.
+ --
+ -- It's worth doing because it makes the environment smaller for
+ -- every module that imports the Prelude
+ --
+ -- Note: don't filter the gbl_env (hence avails, not avails' in
+ -- defn of gbl_env above). Stupid reason: when parsing
+ -- data type decls, the constructors start as Exact tycon-names,
+ -- and then get turned into data con names by zapping the name space;
+ -- but that stops them being Exact, so they get looked up. Sigh.
+ -- It doesn't matter because it only affects the Data.Tuple really.
+ -- The important thing is to trim down the exports.
+ imports = mkImportAvails mod_name unqual_imp gbl_env avails'
+ avails' | implicit_prelude = filter not_built_in_syntax avails
+ | otherwise = avails
+ not_built_in_syntax a = not (all isBuiltInSyntaxName (availNames a))
+ -- Only filter it if all the names of the avail are built-in
+ -- In particular, lists have (:) which is not built in syntax
+ -- so we don't filter it out.
in
- returnRn (gbl_env, exports)
+ returnM (gbl_env, imports)
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Getting binders out of a declaration}
+%* *
+%*********************************************************
+
+@getLocalDeclBinders@ returns the names for a @RdrNameHsDecl@. It's
+used for both source code (from @importsFromLocalDecls@) and interface
+files (@loadDecl@ calls @getTyClDeclBinders@).
----------------------------
-getLocalDeclBinders :: Module -> RdrNameHsDecl -> RnMG [AvailInfo]
+ *** See "THE NAMING STORY" in HsDecls ****
+
+\begin{code}
+getLocalDeclBinders :: Module -> RdrNameHsDecl -> TcRn m [AvailInfo]
getLocalDeclBinders mod (TyClD tycl_decl)
= -- For type and class decls, we generate Global names, with
-- no export indicator. They need to be global because they get
-- permanently bound into the TyCons and Classes. They don't need
-- an export indicator because they are all implicitly exported.
- getTyClDeclBinders mod tycl_decl `thenRn` \ (avail, sys_names) ->
-
- -- Record that the system names are available
- recordLocalSlurps (mkNameSet sys_names) `thenRn_`
- returnRn [avail]
+ mapM new (tyClDeclNames tycl_decl) `thenM` \ names@(main_name:_) ->
+ returnM [AvailTC main_name names]
+ where
+ new (nm,loc) = newTopBinder mod nm loc
getLocalDeclBinders mod (ValD binds)
- = mapRn new (collectLocatedHsBinders binds) `thenRn` \ avails ->
- returnRn avails
+ = mappM new (collectLocatedHsBinders binds) `thenM` \ avails ->
+ returnM avails
where
- new (rdr_name, loc) = newTopBinder mod rdr_name loc `thenRn` \ name ->
- returnRn (Avail name)
+ new (rdr_name, loc) = newTopBinder mod rdr_name loc `thenM` \ name ->
+ returnM (Avail name)
getLocalDeclBinders mod (ForD (ForeignImport nm _ _ _ loc))
- = newTopBinder mod nm loc `thenRn` \ name ->
- returnRn [Avail name]
+ = newTopBinder mod nm loc `thenM` \ name ->
+ returnM [Avail name]
getLocalDeclBinders mod (ForD _)
- = returnRn []
+ = returnM []
-getLocalDeclBinders mod (FixD _) = returnRn []
-getLocalDeclBinders mod (DeprecD _) = returnRn []
-getLocalDeclBinders mod (DefD _) = returnRn []
-getLocalDeclBinders mod (InstD _) = returnRn []
-getLocalDeclBinders mod (RuleD _) = returnRn []
+getLocalDeclBinders mod (FixD _) = returnM []
+getLocalDeclBinders mod (DeprecD _) = returnM []
+getLocalDeclBinders mod (DefD _) = returnM []
+getLocalDeclBinders mod (InstD _) = returnM []
+getLocalDeclBinders mod (RuleD _) = returnM []
\end{code}
\begin{code}
filterImports :: ModuleName -- The module being imported
- -> WhereFrom -- Tells whether it's a {-# SOURCE #-} import
+ -> IsBootInterface -- Tells whether it's a {-# SOURCE #-} import
-> Maybe (Bool, [RdrNameIE]) -- Import spec; True => hiding
-> [AvailInfo] -- What's available
- -> RnMG ([AvailInfo], -- What's imported
+ -> TcRn m ([AvailInfo], -- What's imported
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 from Nothing imports
- = returnRn (imports, emptyNameSet)
+ = returnM (imports, emptyNameSet)
filterImports mod from (Just (want_hiding, import_items)) total_avails
- = flatMapRn get_item import_items `thenRn` \ avails_w_explicits ->
+ = mappM get_item import_items `thenM` \ avails_w_explicits_s ->
let
- (item_avails, explicits_s) = unzip avails_w_explicits
+ (item_avails, explicits_s) = unzip (concat avails_w_explicits_s)
explicits = foldl addListToNameSet emptyNameSet explicits_s
in
if want_hiding then
hidden = availsToNameSet item_avails
keep n = not (n `elemNameSet` hidden)
in
- returnRn (pruneAvails keep total_avails, emptyNameSet)
+ returnM (pruneAvails keep total_avails, emptyNameSet)
else
-- Just item_avails imported; nothing to be hidden
- returnRn (item_avails, explicits)
+ returnM (item_avails, explicits)
where
import_fm :: FiniteMap OccName AvailInfo
import_fm = listToFM [ (nameOccName name, avail)
-- they won't make any difference because naked entities like T
-- in an import list map to TcOccs, not VarOccs.
- bale_out item = addErrRn (badImportItemErr mod from item) `thenRn_`
- returnRn []
+ bale_out item = addErr (badImportItemErr mod from item) `thenM_`
+ returnM []
- get_item :: RdrNameIE -> RnMG [(AvailInfo, [Name])]
+ get_item :: RdrNameIE -> TcRn m [(AvailInfo, [Name])]
-- Empty list for a bad item.
-- Singleton is typical case.
-- Can have two when we are hiding, and mention C which might be
Just avail@(AvailTC _ [n]) -> -- This occurs when you import T(..), but
-- only export T abstractly. The single [n]
-- in the AvailTC is the type or class itself
- ifOptRn Opt_WarnMisc (addWarnRn (dodgyImportWarn mod item)) `thenRn_`
- returnRn [(avail, [availName avail])]
- Just avail -> returnRn [(avail, [availName avail])]
+ ifOptM Opt_WarnMisc (addWarn (dodgyImportWarn mod item)) `thenM_`
+ returnM [(avail, [availName avail])]
+ Just avail -> returnM [(avail, [availName avail])]
get_item item@(IEThingAbs n)
| want_hiding -- hiding( C )
-- Here the 'C' can be a data constructor *or* a type/class
= case catMaybes [check_item item, check_item (IEVar data_n)] of
[] -> bale_out item
- avails -> returnRn [(a, []) | a <- avails]
+ avails -> returnM [(a, []) | a <- avails]
-- The 'explicits' list is irrelevant when hiding
where
- data_n = setRdrNameOcc n (setOccNameSpace (rdrNameOcc n) dataName)
+ data_n = setRdrNameSpace n dataName
get_item item
= case check_item item of
Nothing -> bale_out item
- Just avail -> returnRn [(avail, availNames avail)]
+ Just avail -> returnM [(avail, availNames avail)]
check_item item
| not (maybeToBool maybe_in_import_avails) ||
Just filtered_avail = maybe_filtered_avail
\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Qualifiying imports}
-%* *
-%************************************************************************
-
\begin{code}
-type ExportAvails
- = (FiniteMap ModuleName Avails,
- -- Used to figure out "module M" export specifiers
- -- Includes avails only from *unqualified* imports
- -- (see 1.4 Report Section 5.1.1)
-
- AvailEnv) -- All the things that are available.
- -- Its domain is all the "main" things;
- -- i.e. *excluding* class ops and constructors
- -- (which appear inside their parent AvailTC)
-
-mkEmptyExportAvails :: ModuleName -> ExportAvails
-mkEmptyExportAvails mod_name = (unitFM mod_name [], emptyNameEnv)
-
-plusExportAvails :: ExportAvails -> ExportAvails -> ExportAvails
-plusExportAvails (m1, e1) (m2, e2) = (plusFM_C (++) m1 m2, plusAvailEnv e1 e2)
-
-mkExportAvails :: ModuleName -> Bool -> GlobalRdrEnv -> [AvailInfo] -> ExportAvails
-mkExportAvails mod_name unqual_imp gbl_env avails
- = (mod_avail_env, entity_avail_env)
+filterAvail :: RdrNameIE -- Wanted
+ -> AvailInfo -- Available
+ -> Maybe AvailInfo -- Resulting available;
+ -- Nothing if (any of the) wanted stuff isn't there
+
+filterAvail ie@(IEThingWith want wants) avail@(AvailTC n ns)
+ | sub_names_ok = Just (AvailTC n (filter is_wanted ns))
+ | otherwise = Nothing
where
- mod_avail_env = unitFM mod_name unqual_avails
-
- -- unqual_avails is the Avails that are visible in *unqualified* form
- -- We need to know this so we know what to export when we see
- -- module M ( module P ) where ...
- -- Then we must export whatever came from P unqualified.
-
- unqual_avails | not unqual_imp = [] -- Short cut when no unqualified imports
- | otherwise = pruneAvails (unQualInScope gbl_env) avails
-
- entity_avail_env = foldl insert emptyAvailEnv avails
- insert env avail = extendNameEnv_C plusAvail env (availName avail) avail
- -- 'avails' may have several items with the same availName
- -- E.g import Ix( Ix(..), index )
- -- will give Ix(Ix,index,range) and Ix(index)
- -- We want to combine these
+ is_wanted name = nameOccName name `elem` wanted_occs
+ sub_names_ok = all (`elem` avail_occs) wanted_occs
+ avail_occs = map nameOccName ns
+ wanted_occs = map rdrNameOcc (want:wants)
+
+filterAvail (IEThingAbs _) (AvailTC n ns) = ASSERT( n `elem` ns )
+ Just (AvailTC n [n])
+
+filterAvail (IEThingAbs _) avail@(Avail n) = Just avail -- Type synonyms
+
+filterAvail (IEVar _) avail@(Avail n) = Just avail
+filterAvail (IEVar v) avail@(AvailTC n ns) = Just (AvailTC n (filter wanted ns))
+ where
+ wanted n = nameOccName n == occ
+ occ = rdrNameOcc v
+ -- The second equation happens if we import a class op, thus
+ -- import A( op )
+ -- where op is a class operation
+
+filterAvail (IEThingAll _) avail@(AvailTC _ _) = Just avail
+ -- We don't complain even if the IE says T(..), but
+ -- no constrs/class ops of T are available
+ -- Instead that's caught with a warning by the caller
+
+filterAvail ie avail = Nothing
\end{code}
Processing the export list.
-You might think that we should record things that appear in the export list
-as ``occurrences'' (using @addOccurrenceName@), but you'd be wrong.
-We do check (here) that they are in scope,
-but there is no need to slurp in their actual declaration
-(which is what @addOccurrenceName@ forces).
+You might think that we should record things that appear in the export
+list as ``occurrences'' (using @addOccurrenceName@), but you'd be
+wrong. We do check (here) that they are in scope, but there is no
+need to slurp in their actual declaration (which is what
+@addOccurrenceName@ forces).
-Indeed, doing so would big trouble when
-compiling @PrelBase@, because it re-exports @GHC@, which includes @takeMVar#@,
-whose type includes @ConcBase.StateAndSynchVar#@, and so on...
+Indeed, doing so would big trouble when compiling @PrelBase@, because
+it re-exports @GHC@, which includes @takeMVar#@, whose type includes
+@ConcBase.StateAndSynchVar#@, and so on...
\begin{code}
type ExportAccum -- The type of the accumulating parameter of
ExportOccMap, -- Tracks exported occurrence names
AvailEnv) -- The accumulated exported stuff, kept in an env
-- so we can common-up related AvailInfos
+emptyExportAccum = ([], emptyFM, emptyAvailEnv)
type ExportOccMap = FiniteMap OccName (Name, RdrNameIE)
-- Tracks what a particular exported OccName
-- that have the same occurrence name
-exportsFromAvail :: ModuleName
- -> Maybe [RdrNameIE] -- Export spec
- -> FiniteMap ModuleName Avails -- Used for (module M) exports
- -> NameEnv AvailInfo -- Domain is every in-scope thing
- -> GlobalRdrEnv
- -> RnMG Avails
+exportsFromAvail :: Maybe [RdrNameIE] -> TcRn m Avails
-- Complains if two distinct exports have same OccName
-- Warns about identical exports.
-- Complains about exports items not in scope
-exportsFromAvail this_mod Nothing
- mod_avail_env entity_avail_env global_name_env
- = exportsFromAvail this_mod (Just true_exports) mod_avail_env
- entity_avail_env global_name_env
- where
- true_exports
- | this_mod == mAIN_Name = []
+exportsFromAvail Nothing
+ = do { this_mod <- getModule ;
+ if moduleName this_mod == mAIN_Name then
+ return []
-- Export nothing; Main.$main is automatically exported
- | otherwise = [IEModuleContents this_mod]
+ else
+ exportsFromAvail (Just [IEModuleContents (moduleName this_mod)])
-- but for all other modules export everything.
+ }
-exportsFromAvail this_mod (Just export_items)
- mod_avail_env entity_avail_env global_name_env
- = doptRn Opt_WarnDuplicateExports `thenRn` \ warn_dup_exports ->
- foldlRn (exports_from_item warn_dup_exports)
- ([], emptyFM, emptyAvailEnv) export_items
- `thenRn` \ (_, _, export_avail_map) ->
- let
- export_avails :: [AvailInfo]
- export_avails = nameEnvElts export_avail_map
- in
- returnRn export_avails
+exportsFromAvail (Just exports)
+ = do { TcGblEnv { tcg_imports = imports } <- getGblEnv ;
+ warn_dup_exports <- doptM Opt_WarnDuplicateExports ;
+ exports_from_avail exports warn_dup_exports imports }
+
+exports_from_avail export_items warn_dup_exports
+ (ImportAvails { imp_unqual = mod_avail_env,
+ imp_env = entity_avail_env })
+ = foldlM exports_from_item emptyExportAccum
+ export_items `thenM` \ (_, _, export_avail_map) ->
+ returnM (nameEnvElts export_avail_map)
where
- exports_from_item :: Bool -> ExportAccum -> RdrNameIE -> RnMG ExportAccum
+ exports_from_item :: ExportAccum -> RdrNameIE -> TcRn m ExportAccum
- exports_from_item warn_dups acc@(mods, occs, avails) ie@(IEModuleContents mod)
+ exports_from_item acc@(mods, occs, avails) ie@(IEModuleContents mod)
| mod `elem` mods -- Duplicate export of M
- = warnCheckRn warn_dups (dupModuleExport mod) `thenRn_`
- returnRn acc
+ = warnIf warn_dup_exports (dupModuleExport mod) `thenM_`
+ returnM 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 addAvail avails mod_avails
- in
- returnRn (mod:mods, occs', avails')
-
- exports_from_item warn_dups acc@(mods, occs, avails) ie
- = lookupSrcName global_name_env (ieName ie) `thenRn` \ name ->
-
- -- See what's available in the current environment
- case lookupNameEnv entity_avail_env name of {
- Nothing -> -- Presumably this happens because lookupSrcName didn't find
- -- the name and returned an unboundName, which won't be in
- -- the entity_avail_env, of course
- WARN( not (isUnboundName name), ppr name )
- returnRn acc ;
-
- Just avail ->
+ = case lookupModuleEnvByName mod_avail_env mod of
+ Nothing -> addErr (modExportErr mod) `thenM_`
+ returnM acc
+ Just mod_avails
+ -> foldlM (check_occs warn_dup_exports ie)
+ occs mod_avails `thenM` \ occs' ->
+ let
+ avails' = foldl addAvail avails mod_avails
+ in
+ returnM (mod:mods, occs', avails')
+
+ exports_from_item acc@(mods, occs, avails) ie
+ = lookupGRE (ieName ie) `thenM` \ mb_gre ->
+ case mb_gre of {
+ Nothing -> addErr (unknownNameErr (ieName ie)) `thenM_`
+ returnM acc ;
+ Just gre ->
+
+ -- Get the AvailInfo for the parent of the specified name
+ case lookupAvailEnv entity_avail_env (gre_parent gre) of {
+ Nothing -> pprPanic "exportsFromAvail"
+ ((ppr (ieName ie)) <+> ppr gre) ;
+ Just avail ->
-- Filter out the bits we want
case filterAvail ie avail of {
Nothing -> -- Not enough availability
- failWithRn acc (exportItemErr ie) ;
+ addErr (exportItemErr ie) `thenM_`
+ returnM acc ;
Just export_avail ->
-- Phew! It's OK! Now to check the occurrence stuff!
- warnCheckRn (ok_item ie avail) (dodgyExportWarn ie) `thenRn_`
- check_occs ie occs export_avail `thenRn` \ occs' ->
- returnRn (mods, occs', addAvail avails export_avail)
- }}
+ warnIf (not (ok_item ie avail)) (dodgyExportWarn ie) `thenM_`
+ check_occs warn_dup_exports ie occs export_avail `thenM` \ occs' ->
+ returnM (mods, occs', addAvail avails export_avail)
+ }}}
-- in the AvailTC is the type or class itself
ok_item _ _ = True
-check_occs :: RdrNameIE -> ExportOccMap -> AvailInfo -> RnMG ExportOccMap
-check_occs ie occs avail
- = doptRn Opt_WarnDuplicateExports `thenRn` \ warn_dup_exports ->
- foldlRn (check warn_dup_exports) occs (availNames avail)
+check_occs :: Bool -> RdrNameIE -> ExportOccMap -> AvailInfo -> TcRn m ExportOccMap
+check_occs warn_dup_exports ie occs avail
+ = foldlM check occs (availNames avail)
where
- check warn_dup occs name
+ check occs name
= case lookupFM occs name_occ of
- Nothing -> returnRn (addToFM occs name_occ (name, ie))
+ Nothing -> returnM (addToFM occs name_occ (name, ie))
Just (name', ie')
| name == name' -> -- Duplicate export
- warnCheckRn warn_dup
- (dupExportWarn name_occ ie ie')
- `thenRn_` returnRn occs
+ warnIf warn_dup_exports
+ (dupExportWarn name_occ ie ie')
+ `thenM_` returnM occs
| otherwise -> -- Same occ name but different names: an error
- failWithRn occs (exportClashErr name_occ ie ie')
+ addErr (exportClashErr name_occ ie ie') `thenM_`
+ returnM occs
where
name_occ = nameOccName name
\end{code}
+%*********************************************************
+%* *
+\subsection{Unused names}
+%* *
+%*********************************************************
+
+\begin{code}
+reportUnusedNames :: TcGblEnv
+ -> NameSet -- Used in this module
+ -> TcRn m ()
+reportUnusedNames gbl_env used_names
+ = warnUnusedModules unused_imp_mods `thenM_`
+ warnUnusedTopBinds bad_locals `thenM_`
+ warnUnusedImports bad_imports `thenM_`
+ printMinimalImports minimal_imports
+ where
+ direct_import_mods :: [ModuleName]
+ direct_import_mods = map (moduleName . fst)
+ (moduleEnvElts (imp_mods (tcg_imports gbl_env)))
+
+ -- Now, a use of C implies a use of T,
+ -- if C was brought into scope by T(..) or T(C)
+ really_used_names :: NameSet
+ really_used_names = used_names `unionNameSets`
+ mkNameSet [ gre_parent gre
+ | gre <- defined_names,
+ gre_name gre `elemNameSet` used_names]
+
+ -- Collect the defined names from the in-scope environment
+ -- Look for the qualified ones only, else get duplicates
+ defined_names :: [GlobalRdrElt]
+ defined_names = foldRdrEnv add [] (tcg_rdr_env gbl_env)
+ add rdr_name ns acc | isQual rdr_name = ns ++ acc
+ | otherwise = acc
+
+ defined_and_used, defined_but_not_used :: [GlobalRdrElt]
+ (defined_and_used, defined_but_not_used) = partition used defined_names
+ used gre = gre_name gre `elemNameSet` really_used_names
+
+ -- Filter out the ones only defined implicitly
+ bad_locals :: [GlobalRdrElt]
+ bad_locals = filter isLocalGRE defined_but_not_used
+
+ bad_imports :: [GlobalRdrElt]
+ bad_imports = filter bad_imp defined_but_not_used
+ bad_imp (GRE {gre_prov = NonLocalDef (UserImport mod _ True)}) = not (module_unused mod)
+ bad_imp other = False
+
+ -- To figure out the minimal set of imports, start with the things
+ -- that are in scope (i.e. in gbl_env). Then just combine them
+ -- into a bunch of avails, so they are properly grouped
+ minimal_imports :: FiniteMap ModuleName AvailEnv
+ minimal_imports0 = emptyFM
+ minimal_imports1 = foldr add_name minimal_imports0 defined_and_used
+ minimal_imports = foldr add_inst_mod minimal_imports1 direct_import_mods
+ -- The last line makes sure that we retain all direct imports
+ -- even if we import nothing explicitly.
+ -- It's not necessarily redundant to import such modules. Consider
+ -- module This
+ -- import M ()
+ --
+ -- The import M() is not *necessarily* redundant, even if
+ -- we suck in no instance decls from M (e.g. it contains
+ -- no instance decls, or This contains no code). It may be
+ -- that we import M solely to ensure that M's orphan instance
+ -- decls (or those in its imports) are visible to people who
+ -- import This. Sigh.
+ -- There's really no good way to detect this, so the error message
+ -- in RnEnv.warnUnusedModules is weakened instead
+
+
+ -- We've carefully preserved the provenance so that we can
+ -- construct minimal imports that import the name by (one of)
+ -- the same route(s) as the programmer originally did.
+ add_name (GRE {gre_name = n, gre_parent = p,
+ gre_prov = NonLocalDef (UserImport m _ _)}) acc
+ = addToFM_C plusAvailEnv acc (moduleName m)
+ (unitAvailEnv (mk_avail n p))
+ add_name other acc
+ = acc
+
+ -- n is the name of the thing, p is the name of its parent
+ mk_avail n p | n/=p = AvailTC p [p,n]
+ | isTcOcc (nameOccName p) = AvailTC n [n]
+ | otherwise = Avail n
+
+ add_inst_mod m acc
+ | m `elemFM` acc = acc -- We import something already
+ | otherwise = addToFM acc m emptyAvailEnv
+ -- Add an empty collection of imports for a module
+ -- from which we have sucked only instance decls
+
+ -- unused_imp_mods are the directly-imported modules
+ -- that are not mentioned in minimal_imports
+ unused_imp_mods = [m | m <- direct_import_mods,
+ not (maybeToBool (lookupFM minimal_imports m)),
+ m /= pRELUDE_Name]
+
+ module_unused :: Module -> Bool
+ module_unused mod = moduleName mod `elem` unused_imp_mods
+
+
+-- ToDo: deal with original imports with 'qualified' and 'as M' clauses
+printMinimalImports :: FiniteMap ModuleName AvailEnv -- Minimal imports
+ -> TcRn m ()
+printMinimalImports imps
+ = ifOptM Opt_D_dump_minimal_imports $ do {
+
+ mod_ies <- mappM to_ies (fmToList imps) ;
+ this_mod <- getModule ;
+ rdr_env <- getGlobalRdrEnv ;
+ ioToTcRn (do { h <- openFile (mkFilename this_mod) WriteMode ;
+ printForUser h (unQualInScope rdr_env)
+ (vcat (map ppr_mod_ie mod_ies)) })
+ }
+ where
+ mkFilename this_mod = moduleNameUserString (moduleName this_mod) ++ ".imports"
+ ppr_mod_ie (mod_name, ies)
+ | mod_name == pRELUDE_Name
+ = empty
+ | otherwise
+ = ptext SLIT("import") <+> ppr mod_name <>
+ parens (fsep (punctuate comma (map ppr ies)))
+
+ to_ies (mod, avail_env) = mappM to_ie (availEnvElts avail_env) `thenM` \ ies ->
+ returnM (mod, ies)
+
+ to_ie :: AvailInfo -> TcRn m (IE Name)
+ -- The main trick here is that if we're importing all the constructors
+ -- we want to say "T(..)", but if we're importing only a subset we want
+ -- to say "T(A,B,C)". So we have to find out what the module exports.
+ to_ie (Avail n) = returnM (IEVar n)
+ to_ie (AvailTC n [m]) = ASSERT( n==m )
+ returnM (IEThingAbs n)
+ to_ie (AvailTC n ns)
+ = loadInterface (text "Compute minimal imports from" <+> ppr n_mod)
+ n_mod ImportBySystem `thenM` \ iface ->
+ case [xs | (m,as) <- mi_exports iface,
+ m == n_mod,
+ AvailTC x xs <- as,
+ x == n] of
+ [xs] | all (`elem` ns) xs -> returnM (IEThingAll n)
+ | otherwise -> returnM (IEThingWith n (filter (/= n) ns))
+ other -> pprTrace "to_ie" (ppr n <+> ppr (nameModule n) <+> ppr other) $
+ returnM (IEVar n)
+ where
+ n_mod = moduleName (nameModule n)
+\end{code}
+
+
%************************************************************************
%* *
\subsection{Errors}
ptext SLIT("does not export"), quotes (ppr ie)]
where
source_import = case from of
- ImportByUserSource -> ptext SLIT("(hi-boot interface)")
- other -> empty
+ True -> ptext SLIT("(hi-boot interface)")
+ other -> empty
dodgyImportWarn mod item = dodgyMsg (ptext SLIT("import")) item
dodgyExportWarn item = dodgyMsg (ptext SLIT("export")) item
--- /dev/null
+__interface RnSource 1 0 where
+__export RnSource rnBinds rnSrcDecls;
+
+1 rnBinds :: __forall [b] => RdrHsSyn.RdrNameHsBinds
+ -> (RnHsSyn.RenamedHsBinds
+ -> TcRnTypes.RnM (b, NameSet.FreeVars))
+ -> TcRnTypes.RnM (b, NameSet.FreeVars) ;
+
+1 rnSrcDecls :: [RdrHsSyn.RdrNameHsDecl]
+ -> TcRnTypes.RnM (TcRnTypes.TcGblEnv, [RnHsSyn.RenamedHsDecl], NameSet.FreeVars) ;
+
+
--- /dev/null
+module RnSource where
+
+rnBinds :: forall b . RdrHsSyn.RdrNameHsBinds
+ -> (RnHsSyn.RenamedHsBinds
+ -> TcRnTypes.RnM (b, NameSet.FreeVars))
+ -> TcRnTypes.RnM (b, NameSet.FreeVars) ;
+
+rnSrcDecls :: [RdrHsSyn.RdrNameHsDecl]
+ -> TcRnTypes.RnM (TcRnTypes.TcGblEnv, [RnHsSyn.RenamedHsDecl], NameSet.FreeVars)
+
\section[RnSource]{Main pass of renamer}
\begin{code}
-module RnSource ( rnTyClDecl, rnIfaceRuleDecl, rnInstDecl, rnSourceDecls,
- ) where
+module RnSource (
+ rnSrcDecls, rnExtCoreDecls, checkModDeprec,
+ rnTyClDecl, rnIfaceRuleDecl, rnInstDecl,
+ rnBinds, rnStats,
+ ) where
#include "HsVersions.h"
import RnExpr
import HsSyn
-import HscTypes ( GlobalRdrEnv, AvailEnv )
import RdrName ( RdrName, isRdrDataCon, elemRdrEnv )
-import RdrHsSyn ( RdrNameConDecl, RdrNameTyClDecl,
+import RdrHsSyn ( RdrNameConDecl, RdrNameTyClDecl, RdrNameHsDecl,
+ RdrNameDeprecation, RdrNameFixitySig,
+ RdrNameHsBinds,
extractGenericPatTyVars
)
import RnHsSyn
import HsCore
+import RnNames ( importsFromLocalDecls )
import RnTypes ( rnHsType, rnHsSigType, rnHsTypeFVs, rnContext )
-import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs, renameSigsFVs )
-import RnEnv ( lookupTopBndrRn, lookupOccRn, lookupIfaceName,
- lookupSysBinder, newLocalsRn,
+import RnBinds ( rnTopMonoBinds, rnMonoBinds, rnMethodBinds,
+ renameSigs, renameSigsFVs )
+import RnEnv ( lookupTopBndrRn, lookupOccRn, lookupSysBndr,
+ newLocalsRn, lookupGlobalOccRn,
bindLocalsFVRn, bindPatSigTyVars,
bindTyVarsRn, extendTyVarEnvFVRn,
bindCoreLocalRn, bindCoreLocalsRn, bindLocalNames,
- checkDupOrQualNames, checkDupNames, mapFvRn
+ checkDupOrQualNames, checkDupNames, mapFvRn,
+ lookupTopSrcBndr_maybe, lookupTopSrcBndr,
+ dataTcOccs, unknownNameErr,
+ plusGlobalRdrEnv
)
-import RnMonad
+import TcRnMonad
+import BasicTypes ( FixitySig(..) )
+import HscTypes ( ExternalPackageState(..), FixityEnv,
+ Deprecations(..), plusDeprecs )
+import Module ( moduleEnvElts )
import Class ( FunDep, DefMeth (..) )
import TyCon ( DataConDetails(..), visibleDataCons )
-import DataCon ( dataConWorkId )
-import Name ( Name, NamedThing(..) )
+import Name ( Name )
import NameSet
-import PrelNames ( deRefStablePtrName, newStablePtrName,
- bindIOName, returnIOName
- )
-import TysWiredIn ( tupleCon )
+import NameEnv
+import ErrUtils ( dumpIfSet )
+import PrelNames ( newStablePtrName, bindIOName, returnIOName )
import List ( partition )
+import Bag ( bagToList )
import Outputable
import SrcLoc ( SrcLoc )
import CmdLineOpts ( DynFlag(..) )
-- Warn of unused for-all'd tyvars
import Maybes ( maybeToBool )
-import Maybe ( maybe )
+import Maybe ( maybe, catMaybes )
\end{code}
@rnSourceDecl@ `renames' declarations.
\end{enumerate}
-%*********************************************************
-%* *
-\subsection{Source code declarations}
-%* *
-%*********************************************************
-
\begin{code}
-rnSourceDecls :: GlobalRdrEnv -> AvailEnv -> LocalFixityEnv -> RnMode
- -> [RdrNameHsDecl]
- -> RnMG ([RenamedHsDecl], FreeVars)
- -- The decls get reversed, but that's ok
-
-rnSourceDecls gbl_env avails local_fixity_env mode decls
- = initRnMS gbl_env avails emptyRdrEnv local_fixity_env mode (go emptyFVs [] decls)
+rnSrcDecls :: [RdrNameHsDecl] -> RnM (TcGblEnv, [RenamedHsDecl], FreeVars)
+
+rnSrcDecls decls
+ = do { (rdr_env, imports) <- importsFromLocalDecls decls ;
+ updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv`
+ tcg_rdr_env gbl,
+ tcg_imports = imports `plusImportAvails`
+ tcg_imports gbl })
+ $ do {
+
+ -- Deal with deprecations (returns only the extra deprecations)
+ deprecs <- rnSrcDeprecDecls [d | DeprecD d <- decls] ;
+ updGblEnv (\gbl -> gbl { tcg_deprecs = tcg_deprecs gbl `plusDeprecs` deprecs })
+ $ do {
+
+ -- Deal with top-level fixity decls
+ -- (returns the total new fixity env)
+ fix_env <- rnSrcFixityDecls decls ;
+ updGblEnv (\gbl -> gbl { tcg_fix_env = fix_env })
+ $ do {
+
+ -- Rename remaining declarations
+ (rn_src_decls, src_fvs) <- rn_src_decls decls ;
+
+ tcg_env <- getGblEnv ;
+ return (tcg_env, rn_src_decls, src_fvs)
+ }}}}
+
+rnExtCoreDecls :: [RdrNameHsDecl] -> RnM ([RenamedHsDecl], FreeVars)
+rnExtCoreDecls decls = rn_src_decls decls
+
+rn_src_decls decls -- Declarartions get reversed, but no matter
+ = go emptyFVs [] decls
where
-- Fixity and deprecations have been dealt with already; ignore them
- go fvs ds' [] = returnRn (ds', fvs)
+ go fvs ds' [] = returnM (ds', fvs)
go fvs ds' (FixD _:ds) = go fvs ds' ds
go fvs ds' (DeprecD _:ds) = go fvs ds' ds
- go fvs ds' (d:ds) = rnSourceDecl d `thenRn` \(d', fvs') ->
+ go fvs ds' (d:ds) = rnSrcDecl d `thenM` \(d', fvs') ->
go (fvs `plusFV` fvs') (d':ds') ds
+\end{code}
+
+
+%*********************************************************
+%* *
+ Source-code fixity declarations
+%* *
+%*********************************************************
+
+\begin{code}
+rnSrcFixityDecls :: [RdrNameHsDecl] -> TcRn m FixityEnv
+rnSrcFixityDecls decls
+ = getGblEnv `thenM` \ gbl_env ->
+ foldlM rnFixityDecl (tcg_fix_env gbl_env)
+ fix_decls `thenM` \ fix_env ->
+ traceRn (text "fixity env" <+> ppr fix_env) `thenM_`
+ returnM fix_env
+ where
+ fix_decls = foldr get_fix_sigs [] decls
+
+ -- Get fixities from top level decls, and from class decl sigs too
+ get_fix_sigs (FixD fix) acc = fix:acc
+ get_fix_sigs (TyClD (ClassDecl { tcdSigs = sigs})) acc
+ = [sig | FixSig sig <- sigs] ++ acc
+ get_fix_sigs other_decl acc = acc
+
+rnFixityDecl :: FixityEnv -> RdrNameFixitySig -> TcRn m FixityEnv
+rnFixityDecl fix_env (FixitySig rdr_name fixity loc)
+ = -- GHC extension: look up both the tycon and data con
+ -- for con-like things
+ -- If neither are in scope, report an error; otherwise
+ -- add both to the fixity env
+ mappM lookupTopSrcBndr_maybe (dataTcOccs rdr_name) `thenM` \ maybe_ns ->
+ case catMaybes maybe_ns of
+ [] -> addSrcLoc loc $
+ addErr (unknownNameErr rdr_name) `thenM_`
+ returnM fix_env
+ ns -> foldlM add fix_env ns
+ where
+ add fix_env name
+ = case lookupNameEnv fix_env name of
+ Just (FixitySig _ _ loc') -> addErr (dupFixityDecl rdr_name loc loc') `thenM_`
+ returnM fix_env
+ Nothing -> returnM (extendNameEnv fix_env name (FixitySig name fixity loc))
+
+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}
+
+
+%*********************************************************
+%* *
+ Source-code deprecations declarations
+%* *
+%*********************************************************
+
+For deprecations, all we do is check that the names are in scope.
+It's only imported deprecations, dealt with in RnIfaces, that we
+gather them together.
+
+\begin{code}
+rnSrcDeprecDecls :: [RdrNameDeprecation] -> TcRn m Deprecations
+rnSrcDeprecDecls []
+ = returnM NoDeprecs
+
+rnSrcDeprecDecls decls
+ = mappM rn_deprec decls `thenM` \ pairs ->
+ returnM (DeprecSome (mkNameEnv (catMaybes pairs)))
+ where
+ rn_deprec (Deprecation rdr_name txt loc)
+ = addSrcLoc loc $
+ lookupTopSrcBndr rdr_name `thenM` \ name ->
+ returnM (Just (name, (name,txt)))
+
+checkModDeprec :: Maybe DeprecTxt -> Deprecations
+-- Check for a module deprecation; done once at top level
+checkModDeprec Nothing = NoDeprecs
+checkModdeprec (Just txt) = DeprecAll txt
+
+badDeprec d
+ = sep [ptext SLIT("Illegal deprecation when whole module is deprecated"),
+ nest 4 (ppr d)]
+\end{code}
+%*********************************************************
+%* *
+\subsection{Source code declarations}
+%* *
+%*********************************************************
-rnSourceDecl :: RdrNameHsDecl -> RnMS (RenamedHsDecl, FreeVars)
+\begin{code}
+rnSrcDecl :: RdrNameHsDecl -> RnM (RenamedHsDecl, FreeVars)
-rnSourceDecl (ValD binds) = rnTopBinds binds `thenRn` \ (new_binds, fvs) ->
- returnRn (ValD new_binds, fvs)
+rnSrcDecl (ValD binds) = rnTopBinds binds `thenM` \ (new_binds, fvs) ->
+ returnM (ValD new_binds, fvs)
-rnSourceDecl (TyClD tycl_decl)
- = rnTyClDecl tycl_decl `thenRn` \ new_decl ->
- finishSourceTyClDecl tycl_decl new_decl `thenRn` \ (new_decl', fvs) ->
- returnRn (TyClD new_decl', fvs `plusFV` tyClDeclFVs new_decl')
+rnSrcDecl (TyClD tycl_decl)
+ = rnTyClDecl tycl_decl `thenM` \ new_decl ->
+ finishSourceTyClDecl tycl_decl new_decl `thenM` \ (new_decl', fvs) ->
+ returnM (TyClD new_decl', fvs `plusFV` tyClDeclFVs new_decl')
-rnSourceDecl (InstD inst)
- = rnInstDecl inst `thenRn` \ new_inst ->
- finishSourceInstDecl inst new_inst `thenRn` \ (new_inst', fvs) ->
- returnRn (InstD new_inst', fvs `plusFV` instDeclFVs new_inst')
+rnSrcDecl (InstD inst)
+ = rnInstDecl inst `thenM` \ new_inst ->
+ finishSourceInstDecl inst new_inst `thenM` \ (new_inst', fvs) ->
+ returnM (InstD new_inst', fvs `plusFV` instDeclFVs new_inst')
-rnSourceDecl (RuleD rule)
- = rnHsRuleDecl rule `thenRn` \ (new_rule, fvs) ->
- returnRn (RuleD new_rule, fvs)
+rnSrcDecl (RuleD rule)
+ = rnHsRuleDecl rule `thenM` \ (new_rule, fvs) ->
+ returnM (RuleD new_rule, fvs)
-rnSourceDecl (ForD ford)
- = rnHsForeignDecl ford `thenRn` \ (new_ford, fvs) ->
- returnRn (ForD new_ford, fvs)
+rnSrcDecl (ForD ford)
+ = rnHsForeignDecl ford `thenM` \ (new_ford, fvs) ->
+ returnM (ForD new_ford, fvs)
-rnSourceDecl (DefD (DefaultDecl tys src_loc))
- = pushSrcLocRn src_loc $
- mapFvRn (rnHsTypeFVs doc_str) tys `thenRn` \ (tys', fvs) ->
- returnRn (DefD (DefaultDecl tys' src_loc), fvs)
+rnSrcDecl (DefD (DefaultDecl tys src_loc))
+ = addSrcLoc src_loc $
+ mapFvRn (rnHsTypeFVs doc_str) tys `thenM` \ (tys', fvs) ->
+ returnM (DefD (DefaultDecl tys' src_loc), fvs)
where
doc_str = text "In a `default' declaration"
+
+
+rnSrcDecl (CoreD (CoreDecl name ty rhs loc))
+ = addSrcLoc loc $
+ lookupTopBndrRn name `thenM` \ name' ->
+ rnHsTypeFVs doc_str ty `thenM` \ (ty', ty_fvs) ->
+ rnCoreExpr rhs `thenM` \ rhs' ->
+ returnM (CoreD (CoreDecl name' ty' rhs' loc),
+ ty_fvs `plusFV` ufExprFVs rhs')
+ where
+ doc_str = text "In the Core declaration for" <+> quotes (ppr name)
+\end{code}
+
+%*********************************************************
+%* *
+ Bindings
+%* *
+%*********************************************************
+
+These chaps are here, rather than in TcBinds, so that there
+is just one hi-boot file (for RnSource). rnSrcDecls is part
+of the loop too, and it must be defined in this module.
+
+\begin{code}
+rnTopBinds :: RdrNameHsBinds -> RnM (RenamedHsBinds, FreeVars)
+rnTopBinds EmptyBinds = returnM (EmptyBinds, emptyFVs)
+rnTopBinds (MonoBind bind sigs _) = rnTopMonoBinds bind sigs
+ -- The parser doesn't produce other forms
+
+rnBinds :: RdrNameHsBinds
+ -> (RenamedHsBinds -> RnM (result, FreeVars))
+ -> RnM (result, FreeVars)
+rnBinds EmptyBinds thing_inside = thing_inside EmptyBinds
+rnBinds (MonoBind bind sigs _) thing_inside = rnMonoBinds bind sigs thing_inside
+ -- the parser doesn't produce other forms
\end{code}
\begin{code}
rnHsForeignDecl (ForeignImport name ty spec isDeprec src_loc)
- = pushSrcLocRn src_loc $
- lookupTopBndrRn name `thenRn` \ name' ->
- rnHsTypeFVs (fo_decl_msg name) ty `thenRn` \ (ty', fvs) ->
- returnRn (ForeignImport name' ty' spec isDeprec src_loc,
+ = addSrcLoc src_loc $
+ lookupTopBndrRn name `thenM` \ name' ->
+ rnHsTypeFVs (fo_decl_msg name) ty `thenM` \ (ty', fvs) ->
+ returnM (ForeignImport name' ty' spec isDeprec src_loc,
fvs `plusFV` extras spec)
where
extras (CImport _ _ _ _ CWrapper) = mkFVs [newStablePtrName,
- deRefStablePtrName,
bindIOName, returnIOName]
extras _ = emptyFVs
rnHsForeignDecl (ForeignExport name ty spec isDeprec src_loc)
- = pushSrcLocRn src_loc $
- lookupOccRn name `thenRn` \ name' ->
- rnHsTypeFVs (fo_decl_msg name) ty `thenRn` \ (ty', fvs) ->
- returnRn (ForeignExport name' ty' spec isDeprec src_loc,
+ = addSrcLoc src_loc $
+ lookupOccRn name `thenM` \ name' ->
+ rnHsTypeFVs (fo_decl_msg name) ty `thenM` \ (ty', fvs) ->
+ returnM (ForeignExport name' ty' spec isDeprec src_loc,
mkFVs [bindIOName, returnIOName] `plusFV` fvs)
-fo_decl_msg name = ptext SLIT("The foreign declaration for") <+> ppr name
+fo_decl_msg name = ptext SLIT("In the foreign declaration for") <+> ppr name
\end{code}
\begin{code}
rnInstDecl (InstDecl inst_ty mbinds uprags maybe_dfun_rdr_name src_loc)
-- Used for both source and interface file decls
- = pushSrcLocRn src_loc $
- rnHsSigType (text "an instance decl") inst_ty `thenRn` \ inst_ty' ->
+ = addSrcLoc src_loc $
+ rnHsSigType (text "an instance decl") inst_ty `thenM` \ inst_ty' ->
(case maybe_dfun_rdr_name of
- Nothing -> returnRn Nothing
- Just dfun_rdr_name -> lookupIfaceName dfun_rdr_name `thenRn` \ dfun_name ->
- returnRn (Just dfun_name)
- ) `thenRn` \ maybe_dfun_name ->
+ Nothing -> returnM Nothing
+ Just dfun_rdr_name -> lookupGlobalOccRn dfun_rdr_name `thenM` \ dfun_name ->
+ returnM (Just dfun_name)
+ ) `thenM` \ maybe_dfun_name ->
-- The typechecker checks that all the bindings are for the right class.
- returnRn (InstDecl inst_ty' EmptyMonoBinds [] maybe_dfun_name src_loc)
+ returnM (InstDecl inst_ty' EmptyMonoBinds [] maybe_dfun_name src_loc)
-- Compare finishSourceTyClDecl
finishSourceInstDecl (InstDecl _ mbinds uprags _ _ )
let
meth_doc = text "In the bindings in an instance declaration"
meth_names = collectLocatedMonoBinders mbinds
- (inst_tyvars, (cls,_)) = getHsInstHead inst_ty
+ (inst_tyvars, _, cls,_) = splitHsInstDeclTy inst_ty
-- (Slightly strangely) the forall-d tyvars scope over
-- the method bindings too
in
-- Rename the bindings
-- NB meth_names can be qualified!
- checkDupNames meth_doc meth_names `thenRn_`
+ checkDupNames meth_doc meth_names `thenM_`
extendTyVarEnvForMethodBinds inst_tyvars (
rnMethodBinds cls [] mbinds
- ) `thenRn` \ (mbinds', meth_fvs) ->
+ ) `thenM` \ (mbinds', meth_fvs) ->
let
binders = collectMonoBinders mbinds'
binder_set = mkNameSet binders
-- But the (unqualified) method names are in scope
bindLocalNames binders (
renameSigsFVs (okInstDclSig binder_set) uprags
- ) `thenRn` \ (uprags', prag_fvs) ->
+ ) `thenM` \ (uprags', prag_fvs) ->
- returnRn (InstDecl inst_ty mbinds' uprags' maybe_dfun_name src_loc,
+ returnM (InstDecl inst_ty mbinds' uprags' maybe_dfun_name src_loc,
meth_fvs `plusFV` prag_fvs)
\end{code}
\begin{code}
rnIfaceRuleDecl (IfaceRule rule_name act vars fn args rhs src_loc)
- = pushSrcLocRn src_loc $
- lookupOccRn fn `thenRn` \ fn' ->
+ = addSrcLoc src_loc $
+ lookupOccRn fn `thenM` \ fn' ->
rnCoreBndrs vars $ \ vars' ->
- mapRn rnCoreExpr args `thenRn` \ args' ->
- rnCoreExpr rhs `thenRn` \ rhs' ->
- returnRn (IfaceRule rule_name act vars' fn' args' rhs' src_loc)
+ mappM rnCoreExpr args `thenM` \ args' ->
+ rnCoreExpr rhs `thenM` \ rhs' ->
+ returnM (IfaceRule rule_name act vars' fn' args' rhs' src_loc)
rnIfaceRuleDecl (IfaceRuleOut fn rule) -- Builtin rules come this way
- = lookupOccRn fn `thenRn` \ fn' ->
- returnRn (IfaceRuleOut fn' rule)
+ = lookupOccRn fn `thenM` \ fn' ->
+ returnM (IfaceRuleOut fn' rule)
rnHsRuleDecl (HsRule rule_name act vars lhs rhs src_loc)
- = pushSrcLocRn src_loc $
+ = addSrcLoc src_loc $
bindPatSigTyVars (collectRuleBndrSigTys vars) $
bindLocalsFVRn doc (map get_var vars) $ \ ids ->
- mapFvRn rn_var (vars `zip` ids) `thenRn` \ (vars', fv_vars) ->
+ mapFvRn rn_var (vars `zip` ids) `thenM` \ (vars', fv_vars) ->
- rnExpr lhs `thenRn` \ (lhs', fv_lhs) ->
- rnExpr rhs `thenRn` \ (rhs', fv_rhs) ->
- checkRn (validRuleLhs ids lhs')
- (badRuleLhsErr rule_name lhs') `thenRn_`
+ rnExpr lhs `thenM` \ (lhs', fv_lhs) ->
+ rnExpr rhs `thenM` \ (rhs', fv_rhs) ->
+ checkErr (validRuleLhs ids lhs')
+ (badRuleLhsErr rule_name lhs') `thenM_`
let
bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs)]
in
- mapRn (addErrRn . badRuleVar rule_name) bad_vars `thenRn_`
- returnRn (HsRule rule_name act vars' lhs' rhs' src_loc,
+ mappM (addErr . badRuleVar rule_name) bad_vars `thenM_`
+ returnM (HsRule rule_name act vars' lhs' rhs' src_loc,
fv_vars `plusFV` fv_lhs `plusFV` fv_rhs)
where
doc = text "In the transformation rule" <+> ftext rule_name
get_var (RuleBndr v) = v
get_var (RuleBndrSig v _) = v
- rn_var (RuleBndr v, id) = returnRn (RuleBndr id, emptyFVs)
- rn_var (RuleBndrSig v t, id) = rnHsTypeFVs doc t `thenRn` \ (t', fvs) ->
- returnRn (RuleBndrSig id t', fvs)
+ rn_var (RuleBndr v, id) = returnM (RuleBndr id, emptyFVs)
+ rn_var (RuleBndrSig v t, id) = rnHsTypeFVs doc t `thenM` \ (t', fvs) ->
+ returnM (RuleBndrSig id t', fvs)
+\end{code}
+
+Check the shape of a transformation rule LHS. Currently
+we only allow LHSs of the form @(f e1 .. en)@, where @f@ is
+not one of the @forall@'d variables.
+
+\begin{code}
+validRuleLhs foralls lhs
+ = check lhs
+ where
+ check (OpApp _ op _ _) = check op
+ check (HsApp e1 e2) = check e1
+ check (HsVar v) | v `notElem` foralls = True
+ check other = False
\end{code}
\begin{code}
rnTyClDecl (IfaceSig {tcdName = name, tcdType = ty, tcdIdInfo = id_infos, tcdLoc = loc})
- = pushSrcLocRn loc $
- lookupTopBndrRn name `thenRn` \ name' ->
- rnHsType doc_str ty `thenRn` \ ty' ->
- mapRn rnIdInfo id_infos `thenRn` \ id_infos' ->
- returnRn (IfaceSig {tcdName = name', tcdType = ty', tcdIdInfo = id_infos', tcdLoc = loc})
+ = addSrcLoc loc $
+ lookupTopBndrRn name `thenM` \ name' ->
+ rnHsType doc_str ty `thenM` \ ty' ->
+ mappM rnIdInfo id_infos `thenM` \ id_infos' ->
+ returnM (IfaceSig {tcdName = name', tcdType = ty', tcdIdInfo = id_infos', tcdLoc = loc})
where
doc_str = text "In the interface signature for" <+> quotes (ppr name)
-rnTyClDecl (CoreDecl {tcdName = name, tcdType = ty, tcdRhs = rhs, tcdLoc = loc})
- = pushSrcLocRn loc $
- lookupTopBndrRn name `thenRn` \ name' ->
- rnHsType doc_str ty `thenRn` \ ty' ->
- rnCoreExpr rhs `thenRn` \ rhs' ->
- returnRn (CoreDecl {tcdName = name', tcdType = ty', tcdRhs = rhs', tcdLoc = loc})
- where
- doc_str = text "In the Core declaration for" <+> quotes (ppr name)
-
rnTyClDecl (ForeignType {tcdName = name, tcdFoType = fo_type, tcdExtName = ext_name, tcdLoc = loc})
- = pushSrcLocRn loc $
- lookupTopBndrRn name `thenRn` \ name' ->
- returnRn (ForeignType {tcdName = name', tcdFoType = fo_type, tcdExtName = ext_name, tcdLoc = loc})
+ = addSrcLoc loc $
+ lookupTopBndrRn name `thenM` \ name' ->
+ returnM (ForeignType {tcdName = name', tcdFoType = fo_type, tcdExtName = ext_name, tcdLoc = loc})
rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon,
- tcdTyVars = tyvars, tcdCons = condecls,
- tcdDerivs = derivs, tcdLoc = src_loc, tcdSysNames = sys_names})
- = pushSrcLocRn src_loc $
- lookupTopBndrRn tycon `thenRn` \ tycon' ->
+ tcdTyVars = tyvars, tcdCons = condecls, tcdGeneric = want_generic,
+ tcdDerivs = derivs, tcdLoc = src_loc})
+ = addSrcLoc src_loc $
+ lookupTopBndrRn tycon `thenM` \ tycon' ->
bindTyVarsRn data_doc tyvars $ \ tyvars' ->
- rnContext data_doc context `thenRn` \ context' ->
- rn_derivs derivs `thenRn` \ derivs' ->
- checkDupOrQualNames data_doc con_names `thenRn_`
-
- rnConDecls tycon' condecls `thenRn` \ condecls' ->
- mapRn lookupSysBinder sys_names `thenRn` \ sys_names' ->
- returnRn (TyData {tcdND = new_or_data, tcdCtxt = context', tcdName = tycon',
- tcdTyVars = tyvars', tcdCons = condecls',
- tcdDerivs = derivs', tcdLoc = src_loc, tcdSysNames = sys_names'})
+ rnContext data_doc context `thenM` \ context' ->
+ rn_derivs derivs `thenM` \ derivs' ->
+ checkDupOrQualNames data_doc con_names `thenM_`
+
+ rnConDecls tycon' condecls `thenM` \ condecls' ->
+ returnM (TyData {tcdND = new_or_data, tcdCtxt = context', tcdName = tycon',
+ tcdTyVars = tyvars', tcdCons = condecls', tcdGeneric = want_generic,
+ tcdDerivs = derivs', tcdLoc = src_loc})
where
data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
con_names = map conDeclName (visibleDataCons condecls)
- rn_derivs Nothing = returnRn Nothing
- rn_derivs (Just ds) = rnContext data_doc ds `thenRn` \ ds' -> returnRn (Just ds')
+ rn_derivs Nothing = returnM Nothing
+ rn_derivs (Just ds) = rnContext data_doc ds `thenM` \ ds' -> returnM (Just ds')
rnTyClDecl (TySynonym {tcdName = name, tcdTyVars = tyvars, tcdSynRhs = ty, tcdLoc = src_loc})
- = pushSrcLocRn src_loc $
- lookupTopBndrRn name `thenRn` \ name' ->
+ = addSrcLoc src_loc $
+ lookupTopBndrRn name `thenM` \ name' ->
bindTyVarsRn syn_doc tyvars $ \ tyvars' ->
- rnHsType syn_doc ty `thenRn` \ ty' ->
- returnRn (TySynonym {tcdName = name', tcdTyVars = tyvars', tcdSynRhs = ty', tcdLoc = src_loc})
+ rnHsType syn_doc ty `thenM` \ ty' ->
+ returnM (TySynonym {tcdName = name', tcdTyVars = tyvars', tcdSynRhs = ty', tcdLoc = src_loc})
where
syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
rnTyClDecl (ClassDecl {tcdCtxt = context, tcdName = cname,
tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
- tcdSysNames = names, tcdLoc = src_loc})
+ tcdLoc = src_loc})
-- Used for both source and interface file decls
- = pushSrcLocRn src_loc $
+ = addSrcLoc src_loc $
- lookupTopBndrRn cname `thenRn` \ cname' ->
-
- -- 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!
- mapRn lookupSysBinder names `thenRn` \ names' ->
+ lookupTopBndrRn cname `thenM` \ cname' ->
-- Tyvars scope over superclass context and method signatures
bindTyVarsRn cls_doc tyvars $ \ tyvars' ->
-- Check the superclasses
- rnContext cls_doc context `thenRn` \ context' ->
+ rnContext cls_doc context `thenM` \ context' ->
-- Check the functional dependencies
- rnFds cls_doc fds `thenRn` \ fds' ->
+ rnFds cls_doc fds `thenM` \ fds' ->
-- Check the signatures
-- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
(op_sigs, non_op_sigs) = partition isClassOpSig sigs
sig_rdr_names_w_locs = [(op,locn) | ClassOpSig op _ _ locn <- sigs]
in
- checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenRn_`
- mapRn (rnClassOp cname' fds') op_sigs `thenRn` \ sigs' ->
+ checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenM_`
+ mappM (rnClassOp cname' fds') op_sigs `thenM` \ sigs' ->
let
binders = mkNameSet [ nm | (ClassOpSig nm _ _ _) <- sigs' ]
in
- renameSigs (okClsDclSig binders) non_op_sigs `thenRn` \ non_ops' ->
+ renameSigs (okClsDclSig binders) non_op_sigs `thenM` \ non_ops' ->
-- Typechecker is responsible for checking that we only
-- give default-method bindings for things in this class.
-- The renamer *could* check this for class decls, but can't
-- for instance decls.
- returnRn (ClassDecl { tcdCtxt = context', tcdName = cname', tcdTyVars = tyvars',
- tcdFDs = fds', tcdSigs = non_ops' ++ sigs', tcdMeths = Nothing,
- tcdSysNames = names', tcdLoc = src_loc})
+ returnM (ClassDecl { tcdCtxt = context', tcdName = cname', tcdTyVars = tyvars',
+ tcdFDs = fds', tcdSigs = non_ops' ++ sigs', tcdMeths = Nothing,
+ tcdLoc = src_loc})
where
cls_doc = text "In the declaration for class" <+> ppr cname
sig_doc = text "In the signatures for class" <+> ppr cname
rnClassOp clas clas_fds sig@(ClassOpSig op dm_stuff ty locn)
- = pushSrcLocRn locn $
- lookupTopBndrRn op `thenRn` \ op_name ->
+ = addSrcLoc locn $
+ lookupTopBndrRn op `thenM` \ op_name ->
-- Check the signature
- rnHsSigType (quotes (ppr op)) ty `thenRn` \ new_ty ->
+ rnHsSigType (quotes (ppr op)) ty `thenM` \ new_ty ->
-- Make the default-method name
(case dm_stuff of
DefMeth dm_rdr_name
-> -- Imported class that has a default method decl
- -- See comments with tname, snames, above
- lookupSysBinder dm_rdr_name `thenRn` \ dm_name ->
- returnRn (DefMeth dm_name)
+ lookupSysBndr dm_rdr_name `thenM` \ dm_name ->
+ returnM (DefMeth dm_name)
-- An imported class decl for a class decl that had an explicit default
-- method, mentions, rather than defines,
-- the default method, so we must arrange to pull it in
- GenDefMeth -> returnRn GenDefMeth
- NoDefMeth -> returnRn NoDefMeth
- ) `thenRn` \ dm_stuff' ->
+ GenDefMeth -> returnM GenDefMeth
+ NoDefMeth -> returnM NoDefMeth
+ ) `thenM` \ dm_stuff' ->
- returnRn (ClassOpSig op_name dm_stuff' new_ty locn)
+ returnM (ClassOpSig op_name dm_stuff' new_ty locn)
-finishSourceTyClDecl :: RdrNameTyClDecl -> RenamedTyClDecl -> RnMS (RenamedTyClDecl, FreeVars)
+finishSourceTyClDecl :: RdrNameTyClDecl -> RenamedTyClDecl -> RnM (RenamedTyClDecl, FreeVars)
-- Used for source file decls only
-- Renames the default-bindings of a class decl
finishSourceTyClDecl (ClassDecl {tcdMeths = Just mbinds, tcdLoc = src_loc}) -- Get mbinds from here
-- we want to name both "x" tyvars with the same unique, so that they are
-- easy to group together in the typechecker.
-- Hence the
- pushSrcLocRn src_loc $
+ addSrcLoc src_loc $
extendTyVarEnvForMethodBinds tyvars $
- getLocalNameEnv `thenRn` \ name_env ->
+ getLocalRdrEnv `thenM` \ name_env ->
let
meth_rdr_names_w_locs = collectLocatedMonoBinders mbinds
gen_rdr_tyvars_w_locs = [(tv,src_loc) | tv <- extractGenericPatTyVars mbinds,
not (tv `elemRdrEnv` name_env)]
in
- checkDupOrQualNames meth_doc meth_rdr_names_w_locs `thenRn_`
- newLocalsRn gen_rdr_tyvars_w_locs `thenRn` \ gen_tyvars ->
- rnMethodBinds cls gen_tyvars mbinds `thenRn` \ (mbinds', meth_fvs) ->
- returnRn (rn_cls_decl {tcdMeths = Just mbinds'}, meth_fvs)
+ checkDupOrQualNames meth_doc meth_rdr_names_w_locs `thenM_`
+ newLocalsRn gen_rdr_tyvars_w_locs `thenM` \ gen_tyvars ->
+ rnMethodBinds cls gen_tyvars mbinds `thenM` \ (mbinds', meth_fvs) ->
+ returnM (rn_cls_decl {tcdMeths = Just mbinds'}, meth_fvs)
where
meth_doc = text "In the default-methods for class" <+> ppr (tcdName rn_cls_decl)
-- FVs that are `needed' by the interface file declaration, and
-- derivings do not appear in this. It also means that the tcGroups
-- are smaller, which turned out to be important for the usage inference. KSW 2002-02.
- = returnRn (tycl_decl,
+ = returnM (tycl_decl,
maybe emptyFVs extractHsCtxtTyNames derivings)
-finishSourceTyClDecl _ tycl_decl = returnRn (tycl_decl, emptyFVs)
+finishSourceTyClDecl _ tycl_decl = returnM (tycl_decl, emptyFVs)
-- Not a class declaration
\end{code}
\begin{code}
extendTyVarEnvForMethodBinds tyvars thing_inside
- = doptRn Opt_GlasgowExts `thenRn` \ opt_GlasgowExts ->
+ = doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts ->
if opt_GlasgowExts then
extendTyVarEnvFVRn (map hsTyVarName tyvars) thing_inside
else
\begin{code}
conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc)
-conDeclName (ConDecl n _ _ _ _ l) = (n,l)
+conDeclName (ConDecl n _ _ _ l) = (n,l)
-rnConDecls :: Name -> DataConDetails RdrNameConDecl -> RnMS (DataConDetails RenamedConDecl)
-rnConDecls tycon Unknown = returnRn Unknown
-rnConDecls tycon (HasCons n) = returnRn (HasCons n)
+rnConDecls :: Name -> DataConDetails RdrNameConDecl -> RnM (DataConDetails RenamedConDecl)
+rnConDecls tycon Unknown = returnM Unknown
+rnConDecls tycon (HasCons n) = returnM (HasCons n)
rnConDecls tycon (DataCons condecls)
= -- Check that there's at least one condecl,
-- or else we're reading an interface file, or -fglasgow-exts
(if null condecls then
- doptRn Opt_GlasgowExts `thenRn` \ glaExts ->
- getModeRn `thenRn` \ mode ->
- checkRn (glaExts || isInterfaceMode mode)
+ doptM Opt_GlasgowExts `thenM` \ glaExts ->
+ getModeRn `thenM` \ mode ->
+ checkErr (glaExts || isInterfaceMode mode)
(emptyConDeclsErr tycon)
- else returnRn ()
- ) `thenRn_`
-
- mapRn rnConDecl condecls `thenRn` \ condecls' ->
- returnRn (DataCons condecls')
+ else returnM ()
+ ) `thenM_`
-rnConDecl :: RdrNameConDecl -> RnMS RenamedConDecl
-rnConDecl (ConDecl name wkr tvs cxt details locn)
- = pushSrcLocRn locn $
- checkConName name `thenRn_`
- lookupTopBndrRn name `thenRn` \ new_name ->
+ mappM rnConDecl condecls `thenM` \ condecls' ->
+ returnM (DataCons condecls')
- lookupSysBinder wkr `thenRn` \ new_wkr ->
- -- See comments with ClassDecl
+rnConDecl :: RdrNameConDecl -> RnM RenamedConDecl
+rnConDecl (ConDecl name tvs cxt details locn)
+ = addSrcLoc locn $
+ checkConName name `thenM_`
+ lookupTopBndrRn name `thenM` \ 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_wkr new_tyvars new_context new_details locn)
+ rnContext doc cxt `thenM` \ new_context ->
+ rnConDetails doc locn details `thenM` \ new_details ->
+ returnM (ConDecl new_name new_tyvars new_context new_details locn)
where
doc = text "In the definition of data constructor" <+> quotes (ppr name)
-rnConDetails doc locn (VanillaCon tys)
- = mapRn (rnBangTy doc) tys `thenRn` \ new_tys ->
- returnRn (VanillaCon new_tys)
+rnConDetails doc locn (PrefixCon tys)
+ = mappM (rnBangTy doc) tys `thenM` \ new_tys ->
+ returnM (PrefixCon new_tys)
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 `thenM` \ new_ty1 ->
+ rnBangTy doc ty2 `thenM` \ new_ty2 ->
+ returnM (InfixCon new_ty1 new_ty2)
rnConDetails doc locn (RecCon fields)
- = checkDupOrQualNames doc field_names `thenRn_`
- mapRn (rnField doc) fields `thenRn` \ new_fields ->
- returnRn (RecCon new_fields)
+ = checkDupOrQualNames doc field_names `thenM_`
+ mappM (rnField doc) fields `thenM` \ new_fields ->
+ returnM (RecCon new_fields)
where
- field_names = [(fld, locn) | (flds, _) <- fields, fld <- flds]
+ field_names = [(fld, locn) | (fld, _) <- fields]
-rnField doc (names, ty)
- = mapRn lookupTopBndrRn names `thenRn` \ new_names ->
- rnBangTy doc ty `thenRn` \ new_ty ->
- returnRn (new_names, new_ty)
+rnField doc (name, ty)
+ = lookupTopBndrRn name `thenM` \ new_name ->
+ rnBangTy doc ty `thenM` \ new_ty ->
+ returnM (new_name, new_ty)
rnBangTy doc (BangType s ty)
- = rnHsType doc ty `thenRn` \ new_ty ->
- returnRn (BangType s new_ty)
+ = rnHsType doc ty `thenM` \ new_ty ->
+ returnM (BangType s new_ty)
-- This data decl will parse OK
-- data T = a Int
-- from interface files, which always print in prefix form
checkConName name
- = checkRn (isRdrDataCon name)
- (badDataCon name)
+ = checkErr (isRdrDataCon name) (badDataCon name)
\end{code}
%*********************************************************
\begin{code}
-rnFds :: SDoc -> [FunDep RdrName] -> RnMS [FunDep Name]
+rnFds :: SDoc -> [FunDep RdrName] -> RnM [FunDep Name]
rnFds doc fds
- = mapRn rn_fds fds
+ = mappM rn_fds fds
where
rn_fds (tys1, tys2)
- = rnHsTyVars doc tys1 `thenRn` \ tys1' ->
- rnHsTyVars doc tys2 `thenRn` \ tys2' ->
- returnRn (tys1', tys2')
+ = rnHsTyVars doc tys1 `thenM` \ tys1' ->
+ rnHsTyVars doc tys2 `thenM` \ tys2' ->
+ returnM (tys1', tys2')
-rnHsTyVars doc tvs = mapRn (rnHsTyvar doc) tvs
+rnHsTyVars doc tvs = mappM (rnHsTyvar doc) tvs
rnHsTyvar doc tyvar = lookupOccRn tyvar
\end{code}
\begin{code}
rnIdInfo (HsWorker worker arity)
- = lookupOccRn worker `thenRn` \ worker' ->
- returnRn (HsWorker worker' arity)
-
-rnIdInfo (HsUnfold inline expr) = rnCoreExpr expr `thenRn` \ expr' ->
- returnRn (HsUnfold inline expr')
-rnIdInfo (HsStrictness str) = returnRn (HsStrictness str)
-rnIdInfo (HsArity arity) = returnRn (HsArity arity)
-rnIdInfo HsNoCafRefs = returnRn HsNoCafRefs
+ = lookupOccRn worker `thenM` \ worker' ->
+ returnM (HsWorker worker' arity)
+
+rnIdInfo (HsUnfold inline expr) = rnCoreExpr expr `thenM` \ expr' ->
+ returnM (HsUnfold inline expr')
+rnIdInfo (HsStrictness str) = returnM (HsStrictness str)
+rnIdInfo (HsArity arity) = returnM (HsArity arity)
+rnIdInfo HsNoCafRefs = returnM HsNoCafRefs
\end{code}
@UfCore@ expressions.
\begin{code}
rnCoreExpr (UfType ty)
- = rnHsType (text "unfolding type") ty `thenRn` \ ty' ->
- returnRn (UfType ty')
+ = rnHsType (text "unfolding type") ty `thenM` \ ty' ->
+ returnM (UfType ty')
rnCoreExpr (UfVar v)
- = lookupOccRn v `thenRn` \ v' ->
- returnRn (UfVar v')
+ = lookupOccRn v `thenM` \ v' ->
+ returnM (UfVar v')
rnCoreExpr (UfLit l)
- = returnRn (UfLit l)
+ = returnM (UfLit l)
rnCoreExpr (UfLitLit l ty)
- = rnHsType (text "litlit") ty `thenRn` \ ty' ->
- returnRn (UfLitLit l ty')
+ = rnHsType (text "litlit") ty `thenM` \ ty' ->
+ returnM (UfLitLit l ty')
rnCoreExpr (UfFCall cc ty)
- = rnHsType (text "ccall") ty `thenRn` \ ty' ->
- returnRn (UfFCall cc ty')
+ = rnHsType (text "ccall") ty `thenM` \ ty' ->
+ returnM (UfFCall cc ty')
-rnCoreExpr (UfTuple (HsTupCon _ boxity arity) args)
- = mapRn rnCoreExpr args `thenRn` \ args' ->
- returnRn (UfTuple (HsTupCon tup_name boxity arity) args')
- where
- tup_name = getName (dataConWorkId (tupleCon boxity arity))
- -- Get the *worker* name and use that
+rnCoreExpr (UfTuple (HsTupCon boxity arity) args)
+ = mappM rnCoreExpr args `thenM` \ args' ->
+ returnM (UfTuple (HsTupCon boxity arity) args')
rnCoreExpr (UfApp fun arg)
- = rnCoreExpr fun `thenRn` \ fun' ->
- rnCoreExpr arg `thenRn` \ arg' ->
- returnRn (UfApp fun' arg')
+ = rnCoreExpr fun `thenM` \ fun' ->
+ rnCoreExpr arg `thenM` \ arg' ->
+ returnM (UfApp fun' arg')
rnCoreExpr (UfCase scrut bndr alts)
- = rnCoreExpr scrut `thenRn` \ scrut' ->
+ = rnCoreExpr scrut `thenM` \ scrut' ->
bindCoreLocalRn bndr $ \ bndr' ->
- mapRn rnCoreAlt alts `thenRn` \ alts' ->
- returnRn (UfCase scrut' bndr' alts')
+ mappM rnCoreAlt alts `thenM` \ alts' ->
+ returnM (UfCase scrut' bndr' alts')
rnCoreExpr (UfNote note expr)
- = rnNote note `thenRn` \ note' ->
- rnCoreExpr expr `thenRn` \ expr' ->
- returnRn (UfNote note' expr')
+ = rnNote note `thenM` \ note' ->
+ rnCoreExpr expr `thenM` \ expr' ->
+ returnM (UfNote note' expr')
rnCoreExpr (UfLam bndr body)
= rnCoreBndr bndr $ \ bndr' ->
- rnCoreExpr body `thenRn` \ body' ->
- returnRn (UfLam bndr' body')
+ rnCoreExpr body `thenM` \ body' ->
+ returnM (UfLam bndr' body')
rnCoreExpr (UfLet (UfNonRec bndr rhs) body)
- = rnCoreExpr rhs `thenRn` \ rhs' ->
+ = rnCoreExpr rhs `thenM` \ rhs' ->
rnCoreBndr bndr $ \ bndr' ->
- rnCoreExpr body `thenRn` \ body' ->
- returnRn (UfLet (UfNonRec bndr' rhs') body')
+ rnCoreExpr body `thenM` \ body' ->
+ returnM (UfLet (UfNonRec bndr' rhs') body')
rnCoreExpr (UfLet (UfRec pairs) body)
= rnCoreBndrs bndrs $ \ bndrs' ->
- mapRn rnCoreExpr rhss `thenRn` \ rhss' ->
- rnCoreExpr body `thenRn` \ body' ->
- returnRn (UfLet (UfRec (bndrs' `zip` rhss')) body')
+ mappM rnCoreExpr rhss `thenM` \ rhss' ->
+ rnCoreExpr body `thenM` \ body' ->
+ returnM (UfLet (UfRec (bndrs' `zip` rhss')) body')
where
(bndrs, rhss) = unzip pairs
\end{code}
\begin{code}
rnCoreBndr (UfValBinder name ty) thing_inside
- = rnHsType doc ty `thenRn` \ ty' ->
+ = rnHsType doc ty `thenM` \ ty' ->
bindCoreLocalRn name $ \ name' ->
thing_inside (UfValBinder name' ty')
where
\begin{code}
rnCoreAlt (con, bndrs, rhs)
- = rnUfCon con `thenRn` \ con' ->
+ = rnUfCon con `thenM` \ con' ->
bindCoreLocalsRn bndrs $ \ bndrs' ->
- rnCoreExpr rhs `thenRn` \ rhs' ->
- returnRn (con', bndrs', rhs')
+ rnCoreExpr rhs `thenM` \ rhs' ->
+ returnM (con', bndrs', rhs')
rnNote (UfCoerce ty)
- = rnHsType (text "unfolding coerce") ty `thenRn` \ ty' ->
- returnRn (UfCoerce ty')
+ = rnHsType (text "unfolding coerce") ty `thenM` \ ty' ->
+ returnM (UfCoerce ty')
-rnNote (UfSCC cc) = returnRn (UfSCC cc)
-rnNote UfInlineCall = returnRn UfInlineCall
-rnNote UfInlineMe = returnRn UfInlineMe
+rnNote (UfSCC cc) = returnM (UfSCC cc)
+rnNote UfInlineCall = returnM UfInlineCall
+rnNote UfInlineMe = returnM UfInlineMe
rnUfCon UfDefault
- = returnRn UfDefault
+ = returnM UfDefault
-rnUfCon (UfTupleAlt (HsTupCon _ boxity arity))
- = returnRn (UfTupleAlt (HsTupCon tup_name boxity arity))
- where
- tup_name = getName (tupleCon boxity arity)
+rnUfCon (UfTupleAlt tup_con)
+ = returnM (UfTupleAlt tup_con)
rnUfCon (UfDataAlt con)
- = lookupOccRn con `thenRn` \ con' ->
- returnRn (UfDataAlt con')
+ = lookupOccRn con `thenM` \ con' ->
+ returnM (UfDataAlt con')
rnUfCon (UfLitAlt lit)
- = returnRn (UfLitAlt lit)
+ = returnM (UfLitAlt lit)
rnUfCon (UfLitLitAlt lit ty)
- = rnHsType (text "litlit") ty `thenRn` \ ty' ->
- returnRn (UfLitLitAlt lit ty')
+ = rnHsType (text "litlit") ty `thenM` \ ty' ->
+ returnM (UfLitLitAlt lit ty')
\end{code}
%*********************************************************
-%* *
-\subsection{Rule shapes}
-%* *
+%* *
+\subsection{Statistics}
+%* *
%*********************************************************
-Check the shape of a transformation rule LHS. Currently
-we only allow LHSs of the form @(f e1 .. en)@, where @f@ is
-not one of the @forall@'d variables.
-
\begin{code}
-validRuleLhs foralls lhs
- = check lhs
+rnStats :: [RenamedHsDecl] -- Imported decls
+ -> TcRn m ()
+rnStats imp_decls
+ = doptM Opt_D_dump_rn_trace `thenM` \ dump_rn_trace ->
+ doptM Opt_D_dump_rn_stats `thenM` \ dump_rn_stats ->
+ doptM Opt_D_dump_rn `thenM` \ dump_rn ->
+ getEps `thenM` \ eps ->
+
+ ioToTcRn (dumpIfSet (dump_rn_trace || dump_rn_stats || dump_rn)
+ "Renamer statistics"
+ (getRnStats eps imp_decls)) `thenM_`
+ returnM ()
+
+getRnStats :: ExternalPackageState -> [RenamedHsDecl] -> SDoc
+getRnStats eps imported_decls
+ = hcat [text "Renamer stats: ", stats]
where
- check (OpApp _ op _ _) = check op
- check (HsApp e1 e2) = check e1
- check (HsVar v) | v `notElem` foralls = True
- check other = False
-\end{code}
+ n_mods = length [() | _ <- moduleEnvElts (eps_PIT eps)]
+ -- This is really only right for a one-shot compile
+ (decls_map, n_decls_slurped) = eps_decls eps
+
+ n_decls_left = length [decl | (avail, True, (_,decl)) <- nameEnvElts decls_map
+ -- Data, newtype, and class decls are in the decls_fm
+ -- under multiple names; the tycon/class, and each
+ -- constructor/class op too.
+ -- The 'True' selects just the 'main' decl
+ ]
+
+ (insts_left, n_insts_slurped) = eps_insts eps
+ n_insts_left = length (bagToList insts_left)
+
+ (rules_left, n_rules_slurped) = eps_rules eps
+ n_rules_left = length (bagToList rules_left)
+
+ stats = vcat
+ [int n_mods <+> text "interfaces read",
+ hsep [ int n_decls_slurped, text "type/class/variable imported, out of",
+ int (n_decls_slurped + n_decls_left), text "read"],
+ hsep [ int n_insts_slurped, text "instance decls imported, out of",
+ int (n_insts_slurped + n_insts_left), text "read"],
+ hsep [ int n_rules_slurped, text "rule decls imported, out of",
+ int (n_rules_slurped + n_rules_left), text "read"]
+ ]
+\end{code}
%*********************************************************
%* *
import HsSyn
import RdrHsSyn ( RdrNameContext, RdrNameHsType, extractHsTyRdrTyVars, extractHsCtxtRdrTyVars )
-import RnHsSyn ( RenamedContext, RenamedHsType, extractHsTyNames, tupleTyCon_name )
+import RnHsSyn ( RenamedContext, RenamedHsType, extractHsTyNames )
import RnEnv ( lookupOccRn, newIPName, bindTyVarsRn, lookupFixityRn )
-import RnMonad
+import TcRnMonad
import PrelInfo ( cCallishClassKeys )
import RdrName ( elemRdrEnv )
+import Name ( Name )
import NameSet ( FreeVars )
import Unique ( Uniquable(..) )
%*********************************************************
\begin{code}
-rnHsTypeFVs :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
+rnHsTypeFVs :: SDoc -> RdrNameHsType -> RnM (RenamedHsType, FreeVars)
rnHsTypeFVs doc_str ty
- = rnHsType doc_str ty `thenRn` \ ty' ->
- returnRn (ty', extractHsTyNames ty')
+ = rnHsType doc_str ty `thenM` \ ty' ->
+ returnM (ty', extractHsTyNames ty')
-rnHsSigTypeFVs :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
+rnHsSigTypeFVs :: SDoc -> RdrNameHsType -> RnM (RenamedHsType, FreeVars)
rnHsSigTypeFVs doc_str ty
- = rnHsSigType doc_str ty `thenRn` \ ty' ->
- returnRn (ty', extractHsTyNames ty')
+ = rnHsSigType doc_str ty `thenM` \ ty' ->
+ returnM (ty', extractHsTyNames ty')
-rnHsSigType :: SDoc -> RdrNameHsType -> RnMS RenamedHsType
+rnHsSigType :: SDoc -> RdrNameHsType -> RnM RenamedHsType
-- rnHsSigType is used for source-language type signatures,
-- which use *implicit* universal quantification.
rnHsSigType doc_str ty
want a gratuitous knot.
\begin{code}
-rnHsType :: SDoc -> RdrNameHsType -> RnMS RenamedHsType
+rnHsType :: SDoc -> RdrNameHsType -> RnM RenamedHsType
rnHsType doc (HsForAllTy Nothing ctxt ty)
-- Implicit quantifiction in source code (no kinds on tyvars)
-- Given the signature C => T we universally quantify
-- over FV(T) \ {in-scope-tyvars}
- = getLocalNameEnv `thenRn` \ name_env ->
+ = getLocalRdrEnv `thenM` \ name_env ->
let
mentioned_in_tau = extractHsTyRdrTyVars ty
mentioned_in_ctxt = extractHsCtxtRdrTyVars ctxt
-- Explicitly quantified but not mentioned in ctxt or tau
warn_guys = filter (`notElem` mentioned) forall_tyvar_names
in
- mapRn_ (forAllWarn doc tau) warn_guys `thenRn_`
+ mappM_ (forAllWarn doc tau) warn_guys `thenM_`
rnForAll doc forall_tyvars ctxt tau
rnHsType doc (HsTyVar tyvar)
- = lookupOccRn tyvar `thenRn` \ tyvar' ->
- returnRn (HsTyVar tyvar')
+ = lookupOccRn tyvar `thenM` \ tyvar' ->
+ returnM (HsTyVar tyvar')
rnHsType doc (HsOpTy ty1 op ty2)
= (case op of
- HsArrow -> returnRn HsArrow
- HsTyOp n -> lookupOccRn n `thenRn` \ n' ->
- returnRn (HsTyOp n')
- ) `thenRn` \ op' ->
- rnHsType doc ty1 `thenRn` \ ty1' ->
- rnHsType doc ty2 `thenRn` \ ty2' ->
- lookupTyFixityRn op' `thenRn` \ fix ->
+ HsArrow -> returnM HsArrow
+ HsTyOp n -> lookupOccRn n `thenM` \ n' ->
+ returnM (HsTyOp n')
+ ) `thenM` \ op' ->
+ rnHsType doc ty1 `thenM` \ ty1' ->
+ rnHsType doc ty2 `thenM` \ ty2' ->
+ lookupTyFixityRn op' `thenM` \ fix ->
mkHsOpTyRn op' fix ty1' ty2'
rnHsType doc (HsParTy ty)
- = rnHsType doc ty `thenRn` \ ty' ->
- returnRn (HsParTy ty')
+ = rnHsType doc ty `thenM` \ ty' ->
+ returnM (HsParTy ty')
rnHsType doc (HsNumTy i)
- | i == 1 = returnRn (HsNumTy i)
- | otherwise = failWithRn (HsNumTy i)
- (ptext SLIT("Only unit numeric type pattern is valid"))
+ | i == 1 = returnM (HsNumTy i)
+ | otherwise = addErr err_msg `thenM_` returnM (HsNumTy i)
+ where
+ err_msg = ptext SLIT("Only unit numeric type pattern is valid")
+
rnHsType doc (HsFunTy ty1 ty2)
- = rnHsType doc ty1 `thenRn` \ ty1' ->
+ = rnHsType doc ty1 `thenM` \ ty1' ->
-- Might find a for-all as the arg of a function type
- rnHsType doc ty2 `thenRn` \ ty2' ->
+ rnHsType doc ty2 `thenM` \ ty2' ->
-- Or as the result. This happens when reading Prelude.hi
-- when we find return :: forall m. Monad m -> forall a. a -> m a
- returnRn (HsFunTy ty1' ty2')
+ returnM (HsFunTy ty1' ty2')
rnHsType doc (HsListTy ty)
- = rnHsType doc ty `thenRn` \ ty' ->
- returnRn (HsListTy ty')
+ = rnHsType doc ty `thenM` \ ty' ->
+ returnM (HsListTy ty')
rnHsType doc (HsKindSig ty k)
- = rnHsType doc ty `thenRn` \ ty' ->
- returnRn (HsKindSig ty' k)
+ = rnHsType doc ty `thenM` \ ty' ->
+ returnM (HsKindSig ty' k)
rnHsType doc (HsPArrTy ty)
- = rnHsType doc ty `thenRn` \ ty' ->
- returnRn (HsPArrTy ty')
+ = rnHsType doc ty `thenM` \ ty' ->
+ returnM (HsPArrTy ty')
-- Unboxed tuples are allowed to have poly-typed arguments. These
-- sometimes crop up as a result of CPR worker-wrappering dictionaries.
-rnHsType doc (HsTupleTy (HsTupCon _ boxity arity) tys)
- -- Don't do lookupOccRn, because this is built-in syntax
- -- so it doesn't need to be in scope
- = mapRn (rnHsType doc) tys `thenRn` \ tys' ->
- returnRn (HsTupleTy (HsTupCon tup_name boxity arity) tys')
- where
- tup_name = tupleTyCon_name boxity arity
-
+rnHsType doc (HsTupleTy tup_con tys)
+ = mappM (rnHsType doc) tys `thenM` \ tys' ->
+ returnM (HsTupleTy tup_con tys')
rnHsType doc (HsAppTy ty1 ty2)
- = rnHsType doc ty1 `thenRn` \ ty1' ->
- rnHsType doc ty2 `thenRn` \ ty2' ->
- returnRn (HsAppTy ty1' ty2')
+ = rnHsType doc ty1 `thenM` \ ty1' ->
+ rnHsType doc ty2 `thenM` \ ty2' ->
+ returnM (HsAppTy ty1' ty2')
rnHsType doc (HsPredTy pred)
- = rnPred doc pred `thenRn` \ pred' ->
- returnRn (HsPredTy pred')
+ = rnPred doc pred `thenM` \ pred' ->
+ returnM (HsPredTy pred')
-rnHsTypes doc tys = mapRn (rnHsType doc) tys
+rnHsTypes doc tys = mappM (rnHsType doc) tys
\end{code}
\begin{code}
rnForAll doc forall_tyvars ctxt ty
= bindTyVarsRn doc forall_tyvars $ \ new_tyvars ->
- rnContext doc ctxt `thenRn` \ new_ctxt ->
- rnHsType doc ty `thenRn` \ new_ty ->
- returnRn (mkHsForAllTy (Just new_tyvars) new_ctxt new_ty)
+ rnContext doc ctxt `thenM` \ new_ctxt ->
+ rnHsType doc ty `thenM` \ new_ty ->
+ returnM (mkHsForAllTy (Just new_tyvars) new_ctxt new_ty)
\end{code}
by the presence of ->
\begin{code}
-lookupTyFixityRn HsArrow = returnRn arrowFixity
+lookupTyFixityRn HsArrow = returnM arrowFixity
lookupTyFixityRn (HsTyOp n)
- = doptRn Opt_GlasgowExts `thenRn` \ glaExts ->
- warnCheckRn glaExts (infixTyConWarn n) `thenRn_`
+ = doptM Opt_GlasgowExts `thenM` \ glaExts ->
+ warnIf (not glaExts) (infixTyConWarn n) `thenM_`
lookupFixityRn n
-- Building (ty1 `op1` (ty21 `op2` ty22))
mkHsOpTyRn :: HsTyOp Name -> Fixity
-> RenamedHsType -> RenamedHsType
- -> RnMS RenamedHsType
+ -> RnM RenamedHsType
mkHsOpTyRn op1 fix1 ty1 ty2@(HsOpTy ty21 op2 ty22)
- = lookupTyFixityRn op2 `thenRn` \ fix2 ->
+ = lookupTyFixityRn op2 `thenM` \ fix2 ->
let
(nofix_error, associate_right) = compareFixity fix1 fix2
in
if nofix_error then
- addErrRn (precParseErr (quotes (ppr op1),fix1)
- (quotes (ppr op2),fix2)) `thenRn_`
- returnRn (HsOpTy ty1 op1 ty2)
+ addErr (precParseErr (quotes (ppr op1),fix1)
+ (quotes (ppr op2),fix2)) `thenM_`
+ returnM (HsOpTy ty1 op1 ty2)
else
if not associate_right then
-- Rearrange to ((ty1 `op1` ty21) `op2` ty22)
- mkHsOpTyRn op1 fix1 ty1 ty21 `thenRn` \ new_ty ->
- returnRn (HsOpTy new_ty op2 ty22)
+ mkHsOpTyRn op1 fix1 ty1 ty21 `thenM` \ new_ty ->
+ returnM (HsOpTy new_ty op2 ty22)
else
- returnRn (HsOpTy ty1 op1 ty2)
+ returnM (HsOpTy ty1 op1 ty2)
mkHsOpTyRn op fix ty1 ty2 -- Default case, no rearrangment
- = returnRn (HsOpTy ty1 op ty2)
+ = returnM (HsOpTy ty1 op ty2)
mkHsFunTyRn ty1 ty2 -- Precedence of function arrow is 0
- = returnRn (HsFunTy ty1 ty2) -- so no rearrangement reqd. Change
+ = returnM (HsFunTy ty1 ty2) -- so no rearrangement reqd. Change
-- this if fixity of -> increases.
not_op_ty (HsOpTy _ _ _) = False
%*********************************************************
\begin{code}
-rnContext :: SDoc -> RdrNameContext -> RnMS RenamedContext
+rnContext :: SDoc -> RdrNameContext -> RnM RenamedContext
rnContext doc ctxt
- = mapRn rn_pred ctxt `thenRn` \ theta ->
+ = mappM rn_pred ctxt `thenM` \ theta ->
-- Check for duplicate assertions
-- If this isn't an error, then it ought to be:
- ifOptRn Opt_WarnMisc (
+ ifOptM Opt_WarnMisc (
let
(_, dups) = removeDupsEq theta
-- We only have equality, not ordering
in
- mapRn (addWarnRn . dupClassAssertWarn theta) dups
- ) `thenRn_`
+ mappM_ (addWarn . dupClassAssertWarn theta) dups
+ ) `thenM_`
- returnRn theta
+ returnM theta
where
--Someone discovered that @CCallable@ and @CReturnable@
-- could be used in contexts such as:
-- foo :: CCallable a => a -> PrimIO Int
-- Doing this utterly wrecks the whole point of introducing these
-- classes so we specifically check that this isn't being done.
- rn_pred pred = rnPred doc pred `thenRn` \ pred'->
- checkRn (not (bad_pred pred'))
- (naughtyCCallContextErr pred') `thenRn_`
- returnRn pred'
+ rn_pred pred = rnPred doc pred `thenM` \ pred'->
+ checkErr (not (bad_pred pred'))
+ (naughtyCCallContextErr pred') `thenM_`
+ returnM pred'
bad_pred (HsClassP clas _) = getUnique clas `elem` cCallishClassKeys
bad_pred other = False
rnPred doc (HsClassP clas tys)
- = lookupOccRn clas `thenRn` \ clas_name ->
- rnHsTypes doc tys `thenRn` \ tys' ->
- returnRn (HsClassP clas_name tys')
+ = lookupOccRn clas `thenM` \ clas_name ->
+ rnHsTypes doc tys `thenM` \ tys' ->
+ returnM (HsClassP clas_name tys')
rnPred doc (HsIParam n ty)
- = newIPName n `thenRn` \ name ->
- rnHsType doc ty `thenRn` \ ty' ->
- returnRn (HsIParam name ty')
+ = newIPName n `thenM` \ name ->
+ rnHsType doc ty `thenM` \ ty' ->
+ returnM (HsIParam name ty')
\end{code}
\end{code}
\begin{code}
forAllWarn doc ty tyvar
- = ifOptRn Opt_WarnUnusedMatches $
- getModeRn `thenRn` \ mode ->
+ = ifOptM Opt_WarnUnusedMatches $
+ getModeRn `thenM` \ mode ->
case mode of {
#ifndef DEBUG
- InterfaceMode -> returnRn () ; -- Don't warn of unused tyvars in interface files
+ InterfaceMode _ -> returnM () ; -- Don't warn of unused tyvars in interface files
-- unless DEBUG is on, in which case it is slightly
-- informative. They can arise from mkRhsTyLam,
#endif -- leading to (say) f :: forall a b. [b] -> [b]
other ->
- addWarnRn (
+ addWarn (
sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar),
nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
$$
import CostCentre ( dupifyCC, CostCentre )
import Id ( Id )
import CoreLint ( showPass, endPass )
-import SetLevels ( setLevels, Level(..), ltMajLvl, ltLvl, isTopLvl )
+import SetLevels ( Level(..), LevelledExpr, LevelledBind,
+ setLevels, ltMajLvl, ltLvl, isTopLvl )
import UniqSupply ( UniqSupply )
import List ( partition )
import Outputable
Well, maybe. We don't do this at the moment.
\begin{code}
-type LevelledExpr = TaggedExpr Level
-type LevelledBind = TaggedBind Level
type FloatBind = (Level, CoreBind)
type FloatBinds = [FloatBind]
\end{code}
floatBind :: LevelledBind
-> (FloatStats, FloatBinds, CoreBind)
-floatBind (NonRec (name,level) rhs)
+floatBind (NonRec (TB name level) rhs)
= case (floatRhs level rhs) of { (fs, rhs_floats, rhs') ->
(fs, rhs_floats, NonRec name rhs') }
where
bind_level = getBindLevel bind
- do_pair ((name, level), rhs)
+ do_pair (TB name level, rhs)
= case (floatRhs level rhs) of { (fs, rhs_floats, rhs') ->
(fs, rhs_floats, (name, rhs'))
}
floatExpr lvl lam@(Lam _ _)
= let
(bndrs_w_lvls, body) = collectBinders lam
- (bndrs, lvls) = unzip bndrs_w_lvls
+ bndrs = [b | TB b _ <- bndrs_w_lvls]
+ lvls = [l | TB b l <- bndrs_w_lvls]
-- For the all-tyvar case we are prepared to pull
-- the lets out, to implement the float-out-of-big-lambda
where
bind_lvl = getBindLevel bind
-floatExpr lvl (Case scrut (case_bndr, case_lvl) alts)
+floatExpr lvl (Case scrut (TB case_bndr case_lvl) alts)
= case floatExpr lvl scrut of { (fse, fde, scrut') ->
case floatList float_alt alts of { (fsa, fda, alts') ->
(add_stats fse fsa, fda ++ fde, Case scrut' case_bndr alts')
-- don't gratuitiously float bindings out of the RHSs
float_alt (con, bs, rhs)
= case (floatRhs case_lvl rhs) of { (fs, rhs_floats, rhs') ->
- (fs, rhs_floats, (con, map fst bs, rhs')) }
+ (fs, rhs_floats, (con, [b | TB b _ <- bs], rhs')) }
floatList :: (a -> (FloatStats, FloatBinds, b)) -> [a] -> (FloatStats, FloatBinds, [b])
%************************************************************************
\begin{code}
-getBindLevel (NonRec (_, lvl) _) = lvl
-getBindLevel (Rec (((_,lvl), _) : _)) = lvl
+getBindLevel (NonRec (TB _ lvl) _) = lvl
+getBindLevel (Rec (((TB _ lvl), _) : _)) = lvl
\end{code}
\begin{code}
setLevels,
Level(..), tOP_LEVEL,
+ LevelledBind, LevelledExpr,
incMinorLvl, ltMajLvl, ltLvl, isTopLvl, isInlineCtxt
) where
alts_env = extendCaseBndrLvlEnv env expr' case_bndr incd_lvl
in
mapLvl (lvl_alt alts_env) alts `thenLvl` \ alts' ->
- returnLvl (Case expr' (case_bndr, incd_lvl) alts')
+ returnLvl (Case expr' (TB case_bndr incd_lvl) alts')
where
incd_lvl = incMinorLvl ctxt_lvl
= lvlMFE True incd_lvl new_env rhs `thenLvl` \ rhs' ->
returnLvl (con, bs', rhs')
where
- bs' = [ (b, incd_lvl) | b <- bs ]
+ bs' = [ TB b incd_lvl | b <- bs ]
new_env = extendLvlEnv alts_env bs'
\end{code}
| otherwise -- Float it out!
= lvlFloatRhs abs_vars dest_lvl env ann_expr `thenLvl` \ expr' ->
newLvlVar "lvl" abs_vars ty `thenLvl` \ var ->
- returnLvl (Let (NonRec (var,dest_lvl) expr')
+ returnLvl (Let (NonRec (TB var dest_lvl) expr')
(mkVarApps (Var var) abs_vars))
where
expr = deAnnotate ann_expr
lvlBind top_lvl ctxt_lvl env (AnnNonRec bndr rhs@(rhs_fvs,_))
| isInlineCtxt ctxt_lvl -- Don't do anything inside InlineMe
= lvlExpr ctxt_lvl env rhs `thenLvl` \ rhs' ->
- returnLvl (NonRec (bndr, ctxt_lvl) rhs', env)
+ returnLvl (NonRec (TB bndr ctxt_lvl) rhs', env)
| null abs_vars
= -- No type abstraction; clone existing binder
lvlExpr dest_lvl env rhs `thenLvl` \ rhs' ->
cloneVar top_lvl env bndr ctxt_lvl dest_lvl `thenLvl` \ (env', bndr') ->
- returnLvl (NonRec (bndr', dest_lvl) rhs', env')
+ returnLvl (NonRec (TB bndr' dest_lvl) rhs', env')
| otherwise
= -- Yes, type abstraction; create a new binder, extend substitution, etc
lvlFloatRhs abs_vars dest_lvl env rhs `thenLvl` \ rhs' ->
newPolyBndrs dest_lvl env abs_vars [bndr] `thenLvl` \ (env', [bndr']) ->
- returnLvl (NonRec (bndr', dest_lvl) rhs', env')
+ returnLvl (NonRec (TB bndr' dest_lvl) rhs', env')
where
bind_fvs = rhs_fvs `unionVarSet` idFreeVars bndr
lvlBind top_lvl ctxt_lvl env (AnnRec pairs)
| isInlineCtxt ctxt_lvl -- Don't do anything inside InlineMe
= mapLvl (lvlExpr ctxt_lvl env) rhss `thenLvl` \ rhss' ->
- returnLvl (Rec ((bndrs `zip` repeat ctxt_lvl) `zip` rhss'), env)
+ returnLvl (Rec ([TB b ctxt_lvl | b <- bndrs] `zip` rhss'), env)
| null abs_vars
= cloneRecVars top_lvl env bndrs ctxt_lvl dest_lvl `thenLvl` \ (new_env, new_bndrs) ->
mapLvl (lvlExpr ctxt_lvl new_env) rhss `thenLvl` \ new_rhss ->
- returnLvl (Rec ((new_bndrs `zip` repeat dest_lvl) `zip` new_rhss), new_env)
+ returnLvl (Rec ([TB b dest_lvl | b <- new_bndrs] `zip` new_rhss), new_env)
| isSingleton pairs && count isId abs_vars > 1
= -- Special case for self recursion where there are
in
lvlExpr body_lvl body_env rhs_body `thenLvl` \ new_rhs_body ->
newPolyBndrs dest_lvl env abs_vars [bndr] `thenLvl` \ (poly_env, [poly_bndr]) ->
- returnLvl (Rec [((poly_bndr,dest_lvl), mkLams abs_vars_w_lvls $
- mkLams new_lam_bndrs $
- Let (Rec [((new_bndr,rhs_lvl), mkLams new_lam_bndrs new_rhs_body)])
- (mkVarApps (Var new_bndr) lam_bndrs))],
+ returnLvl (Rec [(TB poly_bndr dest_lvl,
+ mkLams abs_vars_w_lvls $
+ mkLams new_lam_bndrs $
+ Let (Rec [(TB new_bndr rhs_lvl, mkLams new_lam_bndrs new_rhs_body)])
+ (mkVarApps (Var new_bndr) lam_bndrs))],
poly_env)
| otherwise -- Non-null abs_vars
= newPolyBndrs dest_lvl env abs_vars bndrs `thenLvl` \ (new_env, new_bndrs) ->
mapLvl (lvlFloatRhs abs_vars dest_lvl new_env) rhss `thenLvl` \ new_rhss ->
- returnLvl (Rec ((new_bndrs `zip` repeat dest_lvl) `zip` new_rhss), new_env)
+ returnLvl (Rec ([TB b dest_lvl | b <- new_bndrs] `zip` new_rhss), new_env)
where
(bndrs,rhss) = unzip pairs
%************************************************************************
\begin{code}
-lvlLamBndrs :: Level -> [CoreBndr] -> (Level, [(CoreBndr, Level)])
+lvlLamBndrs :: Level -> [CoreBndr] -> (Level, [TaggedBndr Level])
-- Compute the levels for the binders of a lambda group
-- The binders returned are exactly the same as the ones passed,
-- but they are now paired with a level
| isId bndr && -- Go to the next major level if this is a value binder,
not bumped_major && -- and we havn't already gone to the next level (one jump per group)
not (isOneShotLambda bndr) -- and it isn't a one-shot lambda
- = go new_lvl True ((bndr,new_lvl) : rev_lvld_bndrs) bndrs
+ = go new_lvl True (TB bndr new_lvl : rev_lvld_bndrs) bndrs
| otherwise
- = go old_lvl bumped_major ((bndr,old_lvl) : rev_lvld_bndrs) bndrs
+ = go old_lvl bumped_major (TB bndr old_lvl : rev_lvld_bndrs) bndrs
where
new_lvl = incMajorLvl old_lvl
floatConsts :: LevelEnv -> Bool
floatConsts (FloatOutSw _ float_consts, _, _, _) = float_consts
-extendLvlEnv :: LevelEnv -> [(Var,Level)] -> LevelEnv
+extendLvlEnv :: LevelEnv -> [TaggedBndr Level] -> LevelEnv
-- Used when *not* cloning
extendLvlEnv (float_lams, lvl_env, subst, id_env) prs
= (float_lams,
foldl del_subst subst prs,
foldl del_id id_env prs)
where
- add_lvl env (v,l) = extendVarEnv env v l
- del_subst env (v,_) = extendInScope env v
- del_id env (v,_) = delVarEnv env v
+ add_lvl env (TB v l) = extendVarEnv env v l
+ del_subst env (TB v _) = extendInScope env v
+ del_id env (TB v _) = delVarEnv env v
-- We must remove any clone for this variable name in case of
-- shadowing. This bit me in the following case
-- (in nofib/real/gg/Spark.hs):
extendVarEnv id_env case_bndr ([scrut_var], Var scrut_var))
extendCaseBndrLvlEnv env scrut case_bndr lvl
- = extendLvlEnv env [(case_bndr,lvl)]
+ = extendLvlEnv env [TB case_bndr lvl]
extendPolyLvlEnv dest_lvl (float_lams, lvl_env, subst, id_env) abs_vars bndr_pairs
= (float_lams,
)
import CoreSyn
import CoreFVs ( ruleRhsFreeVars )
-import HscTypes ( PersistentCompilerState(..),
- PackageRuleBase, HomeSymbolTable, IsExported, ModDetails(..)
+import HscTypes ( PersistentCompilerState(..), ExternalPackageState(..),
+ HscEnv(..), GhciMode(..),
+ ModGuts(..), ModGuts, Avails, availsToNameSet,
+ PackageRuleBase, HomePackageTable, ModDetails(..),
+ HomeModInfo(..)
)
import CSE ( cseProgram )
import Rules ( RuleBase, emptyRuleBase, ruleBaseFVs, ruleBaseIds,
extendRuleBaseList, addRuleBaseFVs, pprRuleBase,
ruleCheckProgram )
import Module ( moduleEnvElts )
+import Name ( Name, isExternalName )
+import NameSet ( elemNameSet )
import PprCore ( pprCoreBindings, pprCoreExpr )
import OccurAnal ( occurAnalyseBinds, occurAnalyseGlobalExpr )
import CoreUtils ( coreBindsSize )
%************************************************************************
\begin{code}
-core2core :: DynFlags -- includes spec of what core-to-core passes to do
+core2core :: HscEnv
-> PersistentCompilerState
- -> HomeSymbolTable
- -> IsExported
- -> ModDetails
- -> IO ModDetails
+ -> ModGuts
+ -> IO ModGuts
-core2core dflags pcs hst is_exported
- mod_details@(ModDetails { md_binds = binds_in, md_rules = rules_in })
+core2core hsc_env pcs
+ mod_impl@(ModGuts { mg_exports = exports,
+ mg_binds = binds_in,
+ mg_rules = rules_in })
= do
- let core_todos = dopt_CoreToDo dflags
- let pkg_rule_base = pcs_rules pcs -- Rule-base accumulated from imported packages
-
+ let dflags = hsc_dflags hsc_env
+ hpt = hsc_HPT hsc_env
+ ghci_mode = hsc_mode hsc_env
+ core_todos = dopt_CoreToDo dflags
+ pkg_rule_base = eps_rule_base (pcs_EPS pcs) -- Rule-base accumulated from imported packages
us <- mkSplitUniqSupply 's'
let (cp_us, ru_us) = splitUniqSupply us
-- COMPUTE THE RULE BASE TO USE
(rule_base, local_rule_ids, orphan_rules, rule_rhs_fvs)
- <- prepareRules dflags pkg_rule_base hst ru_us binds_in rules_in
+ <- prepareRules dflags pkg_rule_base hpt ru_us binds_in rules_in
-- PREPARE THE BINDINGS
- let binds1 = updateBinders local_rule_ids rule_rhs_fvs is_exported binds_in
+ let binds1 = updateBinders ghci_mode local_rule_ids
+ rule_rhs_fvs exports binds_in
-- DO THE BUSINESS
(stats, processed_binds)
-- Return results
-- We only return local orphan rules, i.e., local rules not attached to an Id
-- The bindings cotain more rules, embedded in the Ids
- return (mod_details { md_binds = processed_binds, md_rules = orphan_rules})
+ return (mod_impl { mg_binds = processed_binds, mg_rules = orphan_rules})
simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
- -> PersistentCompilerState
- -> HomeSymbolTable
-> CoreExpr
-> IO CoreExpr
-- simplifyExpr is called by the driver to simplify an
-- expression typed in at the interactive prompt
-simplifyExpr dflags pcs hst expr
+simplifyExpr dflags expr
= do {
; showPass dflags "Simplify"
-- so that the opportunity to apply the rule isn't lost too soon
\begin{code}
-prepareRules :: DynFlags -> PackageRuleBase -> HomeSymbolTable
+prepareRules :: DynFlags -> PackageRuleBase -> HomePackageTable
-> UniqSupply
-> [CoreBind]
-> [IdCoreRule] -- Local rules
[IdCoreRule], -- Orphan rules
IdSet) -- RHS free vars of all rules
-prepareRules dflags pkg_rule_base hst us binds local_rules
+prepareRules dflags pkg_rule_base hpt us binds local_rules
= do { let env = emptySimplEnv SimplGently [] local_ids
(better_rules,_) = initSmpl dflags us (mapSmpl (simplRule env) local_rules)
rule_rhs_fvs = unionVarSets (map (ruleRhsFreeVars . snd) better_rules)
local_rule_base = extendRuleBaseList emptyRuleBase local_rules
local_rule_ids = ruleBaseIds local_rule_base -- Local Ids with rules attached
- imp_rule_base = foldl add_rules pkg_rule_base (moduleEnvElts hst)
+ imp_rule_base = foldl add_rules pkg_rule_base (moduleEnvElts hpt)
rule_base = extendRuleBaseList imp_rule_base orphan_rules
final_rule_base = addRuleBaseFVs rule_base (ruleBaseFVs local_rule_base)
-- The last step black-lists the free vars of local rules too
; return (final_rule_base, local_rule_ids, orphan_rules, rule_rhs_fvs)
}
where
- add_rules rule_base mds = extendRuleBaseList rule_base (md_rules mds)
+ add_rules rule_base mod_info = extendRuleBaseList rule_base (md_rules (hm_details mod_info))
-- Boringly, we need to gather the in-scope set.
local_ids = foldr (unionVarSet . mkVarSet . bindersOf) emptyVarSet binds
-updateBinders :: IdSet -- Locally defined ids with their Rules attached
+updateBinders :: GhciMode
+ -> IdSet -- Locally defined ids with their Rules attached
-> IdSet -- Ids free in the RHS of local rules
- -> IsExported
+ -> Avails -- What is exported
-> [CoreBind] -> [CoreBind]
-- A horrible function
-- the rules (maybe we should?), so this substitution would make the rule
-- bogus.
-updateBinders rule_ids rule_rhs_fvs is_exported binds
+updateBinders ghci_mode rule_ids rule_rhs_fvs exports binds
= map update_bndrs binds
where
update_bndrs (NonRec b r) = NonRec (update_bndr b) r
dont_discard bndr = is_exported (idName bndr)
|| bndr `elemVarSet` rule_rhs_fvs
+
+ -- In interactive mode, we don't want to discard any top-level
+ -- entities at all (eg. do not inline them away during
+ -- simplification), and retain them all in the TypeEnv so they are
+ -- available from the command line.
+ --
+ -- isExternalName separates the user-defined top-level names from those
+ -- introduced by the type checker.
+ is_exported :: Name -> Bool
+ is_exported | ghci_mode == Interactive = isExternalName
+ | otherwise = (`elemNameSet` export_fvs)
+
+ export_fvs = availsToNameSet exports
\end{code}
import WwLib ( mkWorkerArgs )
import DataCon ( dataConRepArity )
import Type ( tyConAppArgs )
-import Id ( Id, idName, idType, idSpecialisation,
+import Id ( Id, idName, idType,
isDataConId_maybe,
mkUserLocal, mkSysLocal )
import Var ( Var )
#include "HsVersions.h"
import CmdLineOpts ( DynFlags, DynFlag(..) )
-import Id ( Id, idName, idType, mkUserLocal, idSpecialisation, isDataConWrapId )
+import Id ( Id, idName, idType, mkUserLocal, isDataConWrapId )
import TcType ( Type, mkTyVarTy, tcSplitSigmaTy,
tyVarsOfTypes, tyVarsOfTheta, isClassPred,
mkForAllTys, tcCmpType
import Maybes ( maybeToBool )
import Name ( getOccName, isExternalName, isDllName )
import OccName ( occNameUserString )
-import BasicTypes ( TopLevelFlag(..), isNotTopLevel, Arity )
+import BasicTypes ( Arity )
import CmdLineOpts ( DynFlags, opt_RuntimeTypes )
import FastTypes hiding ( fastOr )
import Util ( listLengthCmp, mapAndUnzip )
import StgSyn
-import Bag ( Bag, emptyBag, isEmptyBag, snocBag )
+import Bag ( Bag, emptyBag, isEmptyBag, snocBag, bagToList )
import Id ( Id, idType, isLocalId )
import VarSet
import DataCon ( DataCon, dataConArgTys, dataConRepType )
import Literal ( literalType, Literal )
import Maybes ( catMaybes )
import Name ( getSrcLoc )
-import ErrUtils ( ErrMsg, Message, addErrLocHdrLine, pprBagOfErrors, dontAddErrLoc )
+import ErrUtils ( Message, addErrLocHdrLine )
import Type ( mkFunTys, splitFunTys, splitTyConApp_maybe,
isUnLiftedType, isTyVarTy, dropForAlls, Type
)
\begin{code}
type LintM a = [LintLocInfo] -- Locations
-> IdSet -- Local vars in scope
- -> Bag ErrMsg -- Error messages so far
- -> (a, Bag ErrMsg) -- Result and error messages (if any)
+ -> Bag Message -- Error messages so far
+ -> (a, Bag Message) -- Result and error messages (if any)
data LintLocInfo
= RhsOf Id -- The variable bound
if isEmptyBag errs then
Nothing
else
- Just (pprBagOfErrors errs)
+ Just (vcat (punctuate (text "") (bagToList errs)))
}
returnL :: a -> LintM a
addErrL :: Message -> LintM ()
addErrL msg loc scope errs = ((), addErr errs msg loc)
-addErr :: Bag ErrMsg -> Message -> [LintLocInfo] -> Bag ErrMsg
+addErr :: Bag Message -> Message -> [LintLocInfo] -> Bag Message
addErr errs_so_far msg locs
= errs_so_far `snocBag` mk_msg locs
where
- mk_msg (loc:_) = let (l,hdr) = dumpLoc loc in addErrLocHdrLine l hdr msg
- mk_msg [] = dontAddErrLoc msg
+ mk_msg (loc:_) = let (l,hdr) = dumpLoc loc
+ in addErrLocHdrLine l hdr msg
+ mk_msg [] = msg
addLoc :: LintLocInfo -> LintM a -> LintM a
addLoc extra_loc m loc scope errs
import Id ( Id, idType, idInlinePragma,
isDataConId, isGlobalId, idArity,
#ifdef OLD_STRICTNESS
- idDemandInfo, idStrictness, idCprInfo,
+ idDemandInfo, idStrictness, idCprInfo, idName,
#endif
idNewStrictness, idNewStrictness_maybe,
setIdNewStrictness, idNewDemandInfo,
idNewDemandInfo_maybe,
- setIdNewDemandInfo, idName
+ setIdNewDemandInfo
)
#ifdef OLD_STRICTNESS
import IdInfo ( newStrictnessFromOld, newDemand )
argDemand (Eval ds) = Eval (mapDmds argDemand ds)
argDemand (Box Bot) = evalDmd
argDemand (Box d) = box (argDemand d)
-argDemand Bot = Abs -- Don't pass args that are consumed by bottom/err
+argDemand Bot = Abs -- Don't pass args that are consumed (only) by bottom
argDemand d = d
\end{code}
\begin{code}
module Inst (
- LIE, emptyLIE, unitLIE, plusLIE, consLIE, zonkLIE,
+ LIE, emptyLIE, unitLIE, plusLIE, consLIE,
plusLIEs, mkLIE, isEmptyLIE, lieToList, listToLIE,
+ showLIE,
Inst,
pprInst, pprInsts, pprInstsInFull, tidyInsts, tidyMoreInsts,
newDictsFromOld, newDicts, cloneDict,
- newMethod, newMethodFromName, newMethodWithGivenTy, newMethodAtLoc,
+ newMethod, newMethodFromName, newMethodWithGivenTy,
+ newMethodWith, newMethodAtLoc,
newOverloadedLit, newIPDict,
tcInstCall, tcInstDataCon, tcSyntaxName,
tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
- ipNamesOfInst, ipNamesOfInsts, predsOfInst, predsOfInsts,
+ ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
instLoc, getDictClassTys, dictPred,
lookupInst, lookupSimpleInst, LookupInstResult(..),
isDict, isClassDict, isMethod,
- isLinearInst, linearInstType,
+ isLinearInst, linearInstType, isIPDict, isInheritableInst,
isTyVarDict, isStdClassTyVarDict, isMethodFor,
instBindingRequired, instCanBeGeneralised,
import {-# SOURCE #-} TcExpr( tcExpr )
import HsSyn ( HsLit(..), HsOverLit(..), HsExpr(..) )
-import TcHsSyn ( TcExpr, TcId, TypecheckedHsExpr,
+import TcHsSyn ( TcExpr, TcId, TcIdSet, TypecheckedHsExpr,
mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId
)
-import TcMonad
-import TcEnv ( TcIdSet, tcGetInstEnv, tcLookupId, tcLookupGlobalId, tcLookupTyCon )
+import TcRnMonad
+import TcEnv ( tcGetInstEnv, tcLookupId, tcLookupTyCon )
import InstEnv ( InstLookupResult(..), lookupInstEnv )
import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType, zapToType,
zonkTcThetaType, tcInstTyVar, tcInstType, tcInstTyVars
)
-import TcType ( Type, TcType, TcThetaType, TcPredType, TcTauType, TcTyVarSet,
+import TcType ( Type, TcType, TcThetaType, TcTyVarSet,
SourceType(..), PredType, ThetaType, TyVarDetails(VanillaTv),
tcSplitForAllTys, tcSplitForAllTys, mkTyConApp,
tcSplitMethodTy, tcSplitPhiTy, mkGenTyConApp,
isIntTy,isFloatTy, isIntegerTy, isDoubleTy,
tcIsTyVarTy, mkPredTy, mkTyVarTy, mkTyVarTys,
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred,
- isClassPred, isTyVarClassPred, isLinearPred,
+ isClassPred, isTyVarClassPred, isLinearPred, predHasFDs,
getClassPredTys, getClassPredTys_maybe, mkPredName,
- tidyType, tidyTypes, tidyFreeTyVars,
- tcCmpType, tcCmpTypes, tcCmpPred, tcSplitSigmaTy
+ isInheritablePred, isIPPred,
+ tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy
)
import CoreFVs ( idFreeTyVars )
import Class ( Class )
-import DataCon ( dataConSig )
+import DataCon ( DataCon,dataConSig )
import Id ( Id, idName, idType, mkUserLocal, mkSysLocal, mkLocalId, setIdUnique )
import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass )
import Name ( Name, mkMethodOcc, getOccName )
substTy, substTyWith, substTheta, mkTyVarSubst, mkTopTyVarSubst
)
import Literal ( inIntRange )
-import VarEnv ( TidyEnv, lookupSubstEnv, SubstResult(..) )
+import Var ( TyVar )
+import VarEnv ( TidyEnv, emptyTidyEnv, lookupSubstEnv, SubstResult(..) )
import VarSet ( elemVarSet, emptyVarSet, unionVarSet )
import TysWiredIn ( floatDataCon, doubleDataCon )
import PrelNames( fromIntegerName, fromRationalName, rationalTyConName )
-import Util ( thenCmp, equalLength )
+import Util ( equalLength )
import BasicTypes( IPName(..), mapIPName, ipNameName )
-
+import UniqSupply( uniqsFromSupply )
import Bag
import Outputable
\end{code}
-%************************************************************************
-%* *
-\subsection[Inst-collections]{LIE: a collection of Insts}
-%* *
-%************************************************************************
-
-\begin{code}
-type LIE = Bag Inst
-
-isEmptyLIE = isEmptyBag
-emptyLIE = emptyBag
-unitLIE inst = unitBag inst
-mkLIE insts = listToBag insts
-plusLIE lie1 lie2 = lie1 `unionBags` lie2
-consLIE inst lie = inst `consBag` lie
-plusLIEs lies = unionManyBags lies
-lieToList = bagToList
-listToLIE = listToBag
-
-zonkLIE :: LIE -> NF_TcM LIE
-zonkLIE lie = mapBagNF_Tc zonkInst lie
-
-pprInsts :: [Inst] -> SDoc
-pprInsts insts = parens (sep (punctuate comma (map pprInst insts)))
-
-
-pprInstsInFull insts
- = vcat (map go insts)
- where
- go inst = quotes (ppr inst) <+> pprInstLoc (instLoc inst)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Inst-types]{@Inst@ types}
-%* *
-%************************************************************************
-
-An @Inst@ is either a dictionary, an instance of an overloaded
-literal, or an instance of an overloaded value. We call the latter a
-``method'' even though it may not correspond to a class operation.
-For example, we might have an instance of the @double@ function at
-type Int, represented by
-
- Method 34 doubleId [Int] origin
-
-\begin{code}
-data Inst
- = Dict
- Id
- TcPredType
- InstLoc
-
- | Method
- Id
-
- 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] -- The types to which its polymorphic tyvars
- -- should be instantiated.
- -- These types must saturate the Id's foralls.
-
- TcThetaType -- The (types of the) dictionaries to which the function
- -- must be applied to get the method
-
- TcTauType -- The type of the method
-
- InstLoc
-
- -- INVARIANT: in (Method u f tys theta tau loc)
- -- type of (f tys dicts(from theta)) = tau
-
- | LitInst
- Id
- HsOverLit -- The literal from the occurrence site
- -- INVARIANT: never a rebindable-syntax literal
- -- Reason: tcSyntaxName does unification, and we
- -- don't want to deal with that during tcSimplify
- TcType -- The type at which the literal is used
- InstLoc
-\end{code}
-
-Ordering
-~~~~~~~~
-@Insts@ are ordered by their class/type info, rather than by their
-unique. This allows the context-reduction mechanism to use standard finite
-maps to do their stuff.
-
-\begin{code}
-instance Ord Inst where
- compare = cmpInst
-
-instance Eq Inst where
- (==) i1 i2 = case i1 `cmpInst` i2 of
- EQ -> True
- other -> False
-
-cmpInst (Dict _ pred1 _) (Dict _ pred2 _) = pred1 `tcCmpPred` pred2
-cmpInst (Dict _ _ _) other = LT
-
-cmpInst (Method _ _ _ _ _ _) (Dict _ _ _) = GT
-cmpInst (Method _ id1 tys1 _ _ _) (Method _ id2 tys2 _ _ _) = (id1 `compare` id2) `thenCmp` (tys1 `tcCmpTypes` tys2)
-cmpInst (Method _ _ _ _ _ _) other = LT
-
-cmpInst (LitInst _ lit1 ty1 _) (LitInst _ lit2 ty2 _) = (lit1 `compare` lit2) `thenCmp` (ty1 `tcCmpType` ty2)
-cmpInst (LitInst _ _ _ _) other = GT
-
--- and they can only have HsInt or HsFracs in them.
-\end{code}
-
Selection
~~~~~~~~~
getDictClassTys (Dict _ pred _) = getClassPredTys pred
-predsOfInsts :: [Inst] -> [PredType]
-predsOfInsts insts = concatMap predsOfInst insts
+-- fdPredsOfInst is used to get predicates that contain functional
+-- dependencies; i.e. should participate in improvement
+fdPredsOfInst (Dict _ pred _) | predHasFDs pred = [pred]
+ | otherwise = []
+fdPredsOfInst (Method _ _ _ theta _ _) = filter predHasFDs theta
+fdPredsOfInst other = []
+
+fdPredsOfInsts :: [Inst] -> [PredType]
+fdPredsOfInsts insts = concatMap fdPredsOfInst insts
+
+isInheritableInst (Dict _ pred _) = isInheritablePred pred
+isInheritableInst (Method _ _ _ theta _ _) = all isInheritablePred theta
+isInheritableInst other = True
-predsOfInst (Dict _ pred _) = [pred]
-predsOfInst (Method _ _ _ theta _ _) = theta
-predsOfInst (LitInst _ _ _ _) = []
- -- The last case is is really a big cheat
- -- LitInsts to give rise to a (Num a) or (Fractional a) predicate
- -- But Num and Fractional have only one parameter and no functional
- -- dependencies, so I think no caller of predsOfInst will care.
ipNamesOfInsts :: [Inst] -> [Name]
ipNamesOfInst :: Inst -> [Name]
-- Get the implicit parameters mentioned by these Insts
-- NB: ?x and %x get different Names
-
ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
ipNamesOfInst (Dict _ (IParam n _) _) = [ipNameName n]
-- The id might have free type variables; in the case of
-- locally-overloaded class methods, for example
+
tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
tyVarsOfLIE lie = tyVarsOfInsts (lieToList lie)
\end{code}
isTyVarDict (Dict _ pred _) = isTyVarClassPred pred
isTyVarDict other = False
+isIPDict :: Inst -> Bool
+isIPDict (Dict _ pred _) = isIPPred pred
+isIPDict other = False
+
isMethod :: Inst -> Bool
isMethod (Method _ _ _ _ _ _) = True
isMethod other = False
\begin{code}
newDicts :: InstOrigin
-> TcThetaType
- -> NF_TcM [Inst]
+ -> TcM [Inst]
newDicts orig theta
- = tcGetInstLoc orig `thenNF_Tc` \ loc ->
+ = getInstLoc orig `thenM` \ loc ->
newDictsAtLoc loc theta
-cloneDict :: Inst -> NF_TcM Inst
-cloneDict (Dict id ty loc) = tcGetUnique `thenNF_Tc` \ uniq ->
- returnNF_Tc (Dict (setIdUnique id uniq) ty loc)
+cloneDict :: Inst -> TcM Inst
+cloneDict (Dict id ty loc) = newUnique `thenM` \ uniq ->
+ returnM (Dict (setIdUnique id uniq) ty loc)
-newDictsFromOld :: Inst -> TcThetaType -> NF_TcM [Inst]
+newDictsFromOld :: Inst -> TcThetaType -> TcM [Inst]
newDictsFromOld (Dict _ _ loc) theta = newDictsAtLoc loc theta
-- Local function, similar to newDicts,
-- but with slightly different interface
newDictsAtLoc :: InstLoc
-> TcThetaType
- -> NF_TcM [Inst]
+ -> TcM [Inst]
newDictsAtLoc inst_loc@(_,loc,_) theta
- = tcGetUniques `thenNF_Tc` \ new_uniqs ->
- returnNF_Tc (zipWith mk_dict new_uniqs theta)
+ = newUniqueSupply `thenM` \ us ->
+ returnM (zipWith mk_dict (uniqsFromSupply us) theta)
where
mk_dict uniq pred = Dict (mkLocalId (mkPredName uniq loc pred) (mkPredTy pred)) pred inst_loc
-- But with splittable implicit parameters there may be many in
-- scope, so we make up a new name.
newIPDict :: InstOrigin -> IPName Name -> Type
- -> NF_TcM (IPName Id, Inst)
+ -> TcM (IPName Id, Inst)
newIPDict orig ip_name ty
- = tcGetInstLoc orig `thenNF_Tc` \ inst_loc@(_,loc,_) ->
- tcGetUnique `thenNF_Tc` \ uniq ->
+ = getInstLoc orig `thenM` \ inst_loc@(_,loc,_) ->
+ newUnique `thenM` \ uniq ->
let
pred = IParam ip_name ty
id = mkLocalId (mkPredName uniq loc pred) (mkPredTy pred)
in
- returnNF_Tc (mapIPName (\n -> id) ip_name, Dict id pred inst_loc)
+ returnM (mapIPName (\n -> id) ip_name, Dict id pred inst_loc)
\end{code}
+
%************************************************************************
%* *
\subsection{Building methods (calls of overloaded functions)}
\begin{code}
-tcInstCall :: InstOrigin -> TcType -> NF_TcM (TypecheckedHsExpr -> TypecheckedHsExpr, LIE, TcType)
+tcInstCall :: InstOrigin -> TcType -> TcM (TypecheckedHsExpr -> TypecheckedHsExpr, TcType)
tcInstCall orig fun_ty -- fun_ty is usually a sigma-type
- = tcInstType VanillaTv fun_ty `thenNF_Tc` \ (tyvars, theta, tau) ->
- newDicts orig theta `thenNF_Tc` \ dicts ->
+ = tcInstType VanillaTv fun_ty `thenM` \ (tyvars, theta, tau) ->
+ newDicts orig theta `thenM` \ dicts ->
+ extendLIEs dicts `thenM_`
let
inst_fn e = mkHsDictApp (mkHsTyApp e (mkTyVarTys tyvars)) (map instToId dicts)
in
- returnNF_Tc (inst_fn, mkLIE dicts, tau)
-
+ returnM (inst_fn, tau)
+
+tcInstDataCon :: InstOrigin -> DataCon
+ -> TcM ([TcType], -- Types to instantiate at
+ [Inst], -- Existential dictionaries to apply to
+ [TcType], -- Argument types of constructor
+ TcType, -- Result type
+ [TyVar]) -- Existential tyvars
tcInstDataCon orig data_con
= let
(tvs, stupid_theta, ex_tvs, ex_theta, arg_tys, tycon) = dataConSig data_con
-- We generate constraints for the stupid theta even when
-- pattern matching (as the Report requires)
in
- tcInstTyVars VanillaTv (tvs ++ ex_tvs) `thenNF_Tc` \ (all_tvs', ty_args', tenv) ->
+ tcInstTyVars VanillaTv (tvs ++ ex_tvs) `thenM` \ (all_tvs', ty_args', tenv) ->
let
stupid_theta' = substTheta tenv stupid_theta
ex_theta' = substTheta tenv ex_theta
ex_tvs' = drop n_normal_tvs all_tvs'
result_ty = mkTyConApp tycon (take n_normal_tvs ty_args')
in
- newDicts orig stupid_theta' `thenNF_Tc` \ stupid_dicts ->
- newDicts orig ex_theta' `thenNF_Tc` \ ex_dicts ->
+ newDicts orig stupid_theta' `thenM` \ stupid_dicts ->
+ newDicts orig ex_theta' `thenM` \ ex_dicts ->
-- Note that we return the stupid theta *only* in the LIE;
-- we don't otherwise use it at all
- returnNF_Tc (ty_args', map instToId ex_dicts, arg_tys', result_ty,
- mkLIE stupid_dicts, mkLIE ex_dicts, ex_tvs')
+ extendLIEs stupid_dicts `thenM_`
+
+ returnM (ty_args', ex_dicts, arg_tys', result_ty, ex_tvs')
-newMethodFromName :: InstOrigin -> TcType -> Name -> NF_TcM Inst
+newMethodFromName :: InstOrigin -> TcType -> Name -> TcM TcId
newMethodFromName origin ty name
- = tcLookupId name `thenNF_Tc` \ id ->
+ = tcLookupId name `thenM` \ id ->
-- Use tcLookupId not tcLookupGlobalId; the method is almost
-- always a class op, but with -fno-implicit-prelude GHC is
-- meant to find whatever thing is in scope, and that may
-- be an ordinary function.
- newMethod origin id [ty]
+ newMethod origin id [ty] `thenM` \ inst ->
+ returnM (instToId inst)
newMethod :: InstOrigin
-> TcId
-> [TcType]
- -> NF_TcM Inst
+ -> TcM Inst
newMethod orig id tys
= -- Get the Id type and instantiate it at the specified types
let
newMethodWithGivenTy orig id tys [pred] tau
newMethodWithGivenTy orig id tys theta tau
- = tcGetInstLoc orig `thenNF_Tc` \ loc ->
- newMethodWith loc id tys theta tau
+ = getInstLoc orig `thenM` \ loc ->
+ newMethodWith loc id tys theta tau `thenM` \ inst ->
+ extendLIE inst `thenM_`
+ returnM inst
+
+--------------------------------------------
+-- newMethodWith and newMethodAtLoc do *not* drop the
+-- Inst into the LIE; they just returns the Inst
+-- This is important because they are used by TcSimplify
+-- to simplify Insts
newMethodWith inst_loc@(_,loc,_) id tys theta tau
- = tcGetUnique `thenNF_Tc` \ new_uniq ->
+ = newUnique `thenM` \ new_uniq ->
let
meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
+ inst = Method meth_id id tys theta tau inst_loc
in
- returnNF_Tc (Method meth_id id tys theta tau inst_loc)
+ returnM inst
newMethodAtLoc :: InstLoc
-> Id -> [TcType]
- -> NF_TcM (Inst, TcId)
+ -> TcM Inst
newMethodAtLoc inst_loc real_id tys
-- This actually builds the Inst
= -- Get the Id type and instantiate it at the specified types
substTy (mkTopTyVarSubst tyvars tys) rho
(theta, tau) = tcSplitPhiTy rho_ty
in
- newMethodWith inst_loc real_id tys theta tau `thenNF_Tc` \ meth_inst ->
- returnNF_Tc (meth_inst, instToId meth_inst)
+ newMethodWith inst_loc real_id tys theta tau
\end{code}
In newOverloadedLit we convert directly to an Int or Integer if we
newOverloadedLit :: InstOrigin
-> HsOverLit
-> TcType
- -> NF_TcM (TcExpr, LIE)
+ -> TcM TcExpr
newOverloadedLit orig lit@(HsIntegral i fi) expected_ty
| fi /= fromIntegerName -- Do not generate a LitInst for rebindable
-- syntax. Reason: tcSyntaxName does unification
-- which is very inconvenient in tcSimplify
- = tcSyntaxName orig expected_ty fromIntegerName fi `thenTc` \ (expr, lie, _) ->
- returnTc (HsApp expr (HsLit (HsInteger i)), lie)
+ = tcSyntaxName orig expected_ty fromIntegerName fi `thenM` \ (expr, _) ->
+ returnM (HsApp expr (HsLit (HsInteger i)))
| Just expr <- shortCutIntLit i expected_ty
- = returnNF_Tc (expr, emptyLIE)
+ = returnM expr
| otherwise
= newLitInst orig lit expected_ty
newOverloadedLit orig lit@(HsFractional r fr) expected_ty
| fr /= fromRationalName -- c.f. HsIntegral case
- = tcSyntaxName orig expected_ty fromRationalName fr `thenTc` \ (expr, lie, _) ->
- mkRatLit r `thenNF_Tc` \ rat_lit ->
- returnTc (HsApp expr rat_lit, lie)
+ = tcSyntaxName orig expected_ty fromRationalName fr `thenM` \ (expr, _) ->
+ mkRatLit r `thenM` \ rat_lit ->
+ returnM (HsApp expr rat_lit)
| Just expr <- shortCutFracLit r expected_ty
- = returnNF_Tc (expr, emptyLIE)
+ = returnM expr
| otherwise
= newLitInst orig lit expected_ty
newLitInst orig lit expected_ty
- = tcGetInstLoc orig `thenNF_Tc` \ loc ->
- tcGetUnique `thenNF_Tc` \ new_uniq ->
- zapToType expected_ty `thenNF_Tc_`
+ = getInstLoc orig `thenM` \ loc ->
+ newUnique `thenM` \ new_uniq ->
+ zapToType expected_ty `thenM_`
-- The expected type might be a 'hole' type variable,
-- in which case we must zap it to an ordinary type variable
let
lit_inst = LitInst lit_id lit expected_ty loc
lit_id = mkSysLocal FSLIT("lit") new_uniq expected_ty
in
- returnNF_Tc (HsVar (instToId lit_inst), unitLIE lit_inst)
+ extendLIE lit_inst `thenM_`
+ returnM (HsVar (instToId lit_inst))
shortCutIntLit :: Integer -> TcType -> Maybe TcExpr
shortCutIntLit i ty
= Just (mkHsConApp doubleDataCon [] [HsLit (HsDoublePrim f)])
| otherwise = Nothing
-mkRatLit :: Rational -> NF_TcM TcExpr
+mkRatLit :: Rational -> TcM TcExpr
mkRatLit r
- = tcLookupTyCon rationalTyConName `thenNF_Tc` \ rat_tc ->
+ = tcLookupTyCon rationalTyConName `thenM` \ rat_tc ->
let
rational_ty = mkGenTyConApp rat_tc []
in
- returnNF_Tc (HsLit (HsRat r rational_ty))
+ returnM (HsLit (HsRat r rational_ty))
\end{code}
need, and it's a lot of extra work.
\begin{code}
-zonkInst :: Inst -> NF_TcM Inst
+zonkInst :: Inst -> TcM Inst
zonkInst (Dict id pred loc)
- = zonkTcPredType pred `thenNF_Tc` \ new_pred ->
- returnNF_Tc (Dict id new_pred loc)
+ = zonkTcPredType pred `thenM` \ new_pred ->
+ returnM (Dict id new_pred loc)
zonkInst (Method m id tys theta tau loc)
- = zonkId id `thenNF_Tc` \ new_id ->
+ = zonkId id `thenM` \ 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 ->
- returnNF_Tc (Method m new_id new_tys new_theta new_tau loc)
+ zonkTcTypes tys `thenM` \ new_tys ->
+ zonkTcThetaType theta `thenM` \ new_theta ->
+ zonkTcType tau `thenM` \ new_tau ->
+ returnM (Method m new_id new_tys new_theta new_tau loc)
zonkInst (LitInst id lit ty loc)
- = zonkTcType ty `thenNF_Tc` \ new_ty ->
- returnNF_Tc (LitInst id lit new_ty loc)
+ = zonkTcType ty `thenM` \ new_ty ->
+ returnM (LitInst id lit new_ty loc)
-zonkInsts insts = mapNF_Tc zonkInst insts
+zonkInsts insts = mappM zonkInst insts
\end{code}
instance Outputable Inst where
ppr inst = pprInst inst
+pprInsts :: [Inst] -> SDoc
+pprInsts insts = parens (sep (punctuate comma (map pprInst insts)))
+
+pprInstsInFull insts
+ = vcat (map go insts)
+ where
+ go inst = quotes (ppr inst) <+> pprInstLoc (instLoc inst)
+
pprInst (LitInst u lit ty loc)
= hsep [ppr lit, ptext SLIT("at"), ppr ty, show_uniq u]
tidyInsts :: [Inst] -> (TidyEnv, [Inst])
tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
+
+showLIE :: String -> TcM () -- Debugging
+showLIE str
+ = do { lie_var <- getLIEVar ;
+ lie <- readMutVar lie_var ;
+ traceTc (text str <+> pprInstsInFull (lieToList lie)) }
\end{code}
| SimpleInst TcExpr -- Just a variable, type application, or literal
| GenInst [Inst] TcExpr -- The expression and its needed insts
-lookupInst :: Inst
- -> NF_TcM (LookupInstResult s)
+lookupInst :: Inst -> TcM (LookupInstResult s)
+-- It's important that lookupInst does not put any new stuff into
+-- the LIE. Instead, any Insts needed by the lookup are returned in
+-- the LookupInstResult, where they can be further processed by tcSimplify
--- Dictionaries
+-- Dictionaries
lookupInst dict@(Dict _ (ClassP clas tys) loc)
- = getDOptsTc `thenNF_Tc` \ dflags ->
- tcGetInstEnv `thenNF_Tc` \ inst_env ->
+ = getDOpts `thenM` \ dflags ->
+ tcGetInstEnv `thenM` \ inst_env ->
case lookupInstEnv dflags inst_env clas tys of
FoundInst tenv dfun_id
let
(tyvars, rho) = tcSplitForAllTys (idType dfun_id)
mk_ty_arg tv = case lookupSubstEnv tenv tv of
- Just (DoneTy ty) -> returnNF_Tc ty
- Nothing -> tcInstTyVar VanillaTv tv `thenNF_Tc` \ tc_tv ->
- returnTc (mkTyVarTy tc_tv)
+ Just (DoneTy ty) -> returnM ty
+ Nothing -> tcInstTyVar VanillaTv tv `thenM` \ tc_tv ->
+ returnM (mkTyVarTy tc_tv)
in
- mapNF_Tc mk_ty_arg tyvars `thenNF_Tc` \ ty_args ->
+ mappM mk_ty_arg tyvars `thenM` \ ty_args ->
let
dfun_rho = substTy (mkTyVarSubst tyvars ty_args) rho
(theta, _) = tcSplitPhiTy dfun_rho
ty_app = mkHsTyApp (HsVar dfun_id) ty_args
in
if null theta then
- returnNF_Tc (SimpleInst ty_app)
+ returnM (SimpleInst ty_app)
else
- newDictsAtLoc loc theta `thenNF_Tc` \ dicts ->
+ newDictsAtLoc loc theta `thenM` \ dicts ->
let
rhs = mkHsDictApp ty_app (map instToId dicts)
in
- returnNF_Tc (GenInst dicts rhs)
+ returnM (GenInst dicts rhs)
- other -> returnNF_Tc NoInstance
+ other -> returnM NoInstance
-lookupInst dict@(Dict _ _ loc) = returnNF_Tc NoInstance
+lookupInst (Dict _ _ _) = returnM NoInstance
-- Methods
lookupInst inst@(Method _ id tys theta _ loc)
- = newDictsAtLoc loc theta `thenNF_Tc` \ dicts ->
- returnNF_Tc (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) (map instToId dicts)))
+ = newDictsAtLoc loc theta `thenM` \ dicts ->
+ returnM (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) (map instToId dicts)))
-- Literals
-- [Same shortcut as in newOverloadedLit, but we
-- may have done some unification by now]
+
lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc)
| Just expr <- shortCutIntLit i ty
- = returnNF_Tc (GenInst [] expr) -- GenInst, not SimpleInst, because
+ = returnM (GenInst [] expr) -- GenInst, not SimpleInst, because
-- expr may be a constructor application
| otherwise
= ASSERT( from_integer_name == fromIntegerName ) -- A LitInst invariant
- tcLookupGlobalId fromIntegerName `thenNF_Tc` \ from_integer ->
- newMethodAtLoc loc from_integer [ty] `thenNF_Tc` \ (method_inst, method_id) ->
- returnNF_Tc (GenInst [method_inst]
- (HsApp (HsVar method_id) (HsLit (HsInteger i))))
+ tcLookupId fromIntegerName `thenM` \ from_integer ->
+ newMethodAtLoc loc from_integer [ty] `thenM` \ method_inst ->
+ returnM (GenInst [method_inst]
+ (HsApp (HsVar (instToId method_inst)) (HsLit (HsInteger i))))
lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc)
| Just expr <- shortCutFracLit f ty
- = returnNF_Tc (GenInst [] expr)
+ = returnM (GenInst [] expr)
| otherwise
= ASSERT( from_rat_name == fromRationalName ) -- A LitInst invariant
- tcLookupGlobalId fromRationalName `thenNF_Tc` \ from_rational ->
- newMethodAtLoc loc from_rational [ty] `thenNF_Tc` \ (method_inst, method_id) ->
- mkRatLit f `thenNF_Tc` \ rat_lit ->
- returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) rat_lit))
+ tcLookupId fromRationalName `thenM` \ from_rational ->
+ newMethodAtLoc loc from_rational [ty] `thenM` \ method_inst ->
+ mkRatLit f `thenM` \ rat_lit ->
+ returnM (GenInst [method_inst] (HsApp (HsVar (instToId method_inst)) rat_lit))
\end{code}
There is a second, simpler interface, when you want an instance of a
\begin{code}
lookupSimpleInst :: Class
-> [Type] -- Look up (c,t)
- -> NF_TcM (Maybe ThetaType) -- Here are the needed (c,t)s
+ -> TcM (Maybe ThetaType) -- Here are the needed (c,t)s
lookupSimpleInst clas tys
- = getDOptsTc `thenNF_Tc` \ dflags ->
- tcGetInstEnv `thenNF_Tc` \ inst_env ->
+ = getDOpts `thenM` \ dflags ->
+ tcGetInstEnv `thenM` \ inst_env ->
case lookupInstEnv dflags inst_env clas tys of
FoundInst tenv dfun
- -> returnNF_Tc (Just (substTheta (mkSubst emptyInScopeSet tenv) theta))
+ -> returnM (Just (substTheta (mkSubst emptyInScopeSet tenv) theta))
where
(_, rho) = tcSplitForAllTys (idType dfun)
(theta,_) = tcSplitPhiTy rho
- other -> returnNF_Tc Nothing
+ other -> returnM Nothing
\end{code}
\begin{code}
tcSyntaxName :: InstOrigin
- -> TcType -- Type to instantiate it at
- -> Name -> Name -- (Standard name, user name)
- -> TcM (TcExpr, LIE, TcType) -- Suitable expression with its type
+ -> TcType -- Type to instantiate it at
+ -> Name -> Name -- (Standard name, user name)
+ -> TcM (TcExpr, TcType) -- Suitable expression with its type
-- NB: tcSyntaxName calls tcExpr, and hence can do unification.
-- So we do not call it from lookupInst, which is called from tcSimplify
tcSyntaxName orig ty std_nm user_nm
| std_nm == user_nm
- = newMethodFromName orig ty std_nm `thenNF_Tc` \ inst ->
- let
- id = instToId inst
- in
- returnTc (HsVar id, unitLIE inst, idType id)
+ = newMethodFromName orig ty std_nm `thenM` \ id ->
+ returnM (HsVar id, idType id)
| otherwise
- = tcLookupGlobalId std_nm `thenNF_Tc` \ std_id ->
+ = tcLookupId std_nm `thenM` \ std_id ->
let
-- C.f. newMethodAtLoc
([tv], _, tau) = tcSplitSigmaTy (idType std_id)
tau1 = substTy (mkTopTyVarSubst [tv] [ty]) tau
in
- tcAddErrCtxtM (syntaxNameCtxt user_nm orig tau1) $
- tcExpr (HsVar user_nm) tau1 `thenTc` \ (user_fn, lie) ->
- returnTc (user_fn, lie, tau1)
+ addErrCtxtM (syntaxNameCtxt user_nm orig tau1) $
+ tcExpr (HsVar user_nm) tau1 `thenM` \ user_fn ->
+ returnM (user_fn, tau1)
syntaxNameCtxt name orig ty tidy_env
- = tcGetInstLoc orig `thenNF_Tc` \ inst_loc ->
+ = getInstLoc orig `thenM` \ inst_loc ->
let
msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+>
ptext SLIT("(needed by a syntactic construct)"),
nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)),
nest 2 (pprInstLoc inst_loc)]
in
- returnNF_Tc (tidy_env, msg)
+ returnM (tidy_env, msg)
\end{code}
import RnHsSyn ( RenamedHsBinds, RenamedSig, RenamedMonoBinds )
import TcHsSyn ( TcMonoBinds, TcId, zonkId, mkHsLet )
-import TcMonad
-import Inst ( LIE, emptyLIE, mkLIE, plusLIE, InstOrigin(..),
- newDicts, instToId
- )
+import TcRnMonad
+import Inst ( InstOrigin(..), newDicts, instToId )
import TcEnv ( tcExtendLocalValEnv, tcExtendLocalValEnv2, newLocalName )
import TcUnify ( unifyTauTyLists, checkSigTyVarsWrt, sigCtxt )
import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyRestricted, tcSimplifyToDicts )
import VarSet
import Bag
import Util ( isIn, equalLength )
-import BasicTypes ( TopLevelFlag(..), RecFlag(..), isNonRec, isNotTopLevel,
- isAlwaysActive )
+import BasicTypes ( TopLevelFlag(..), RecFlag(..), isNonRec, isRec,
+ isNotTopLevel, isAlwaysActive )
import FiniteMap ( listToFM, lookupFM )
import Outputable
\end{code}
dictionaries, which we resolve at the module level.
\begin{code}
-tcTopBinds :: RenamedHsBinds -> TcM ((TcMonoBinds, TcEnv), LIE)
+tcTopBinds :: RenamedHsBinds -> TcM (TcMonoBinds, TcLclEnv)
tcTopBinds binds
= tc_binds_and_then TopLevel glue binds $
- tcGetEnv `thenNF_Tc` \ env ->
- returnTc ((EmptyMonoBinds, env), emptyLIE)
+ getLclEnv `thenM` \ env ->
+ returnM (EmptyMonoBinds, env)
where
glue is_rec binds1 (binds2, thing) = (binds1 `AndMonoBinds` binds2, thing)
tcBindsAndThen
:: (RecFlag -> TcMonoBinds -> thing -> thing) -- Combinator
-> RenamedHsBinds
- -> TcM (thing, LIE)
- -> TcM (thing, LIE)
+ -> TcM thing
+ -> TcM thing
tcBindsAndThen = tc_binds_and_then NotTopLevel
tcAddScopedTyVars (collectSigTysFromMonoBinds bind) $
-- TYPECHECK THE SIGNATURES
- mapTc tcTySig [sig | sig@(Sig name _ _) <- sigs] `thenTc` \ tc_ty_sigs ->
+ mappM tcTySig [sig | sig@(Sig name _ _) <- sigs] `thenM` \ tc_ty_sigs ->
- tcBindWithSigs top_lvl bind tc_ty_sigs
- sigs is_rec `thenTc` \ (poly_binds, poly_lie, poly_ids) ->
+
+ getLIE (
+ tcBindWithSigs top_lvl bind tc_ty_sigs
+ sigs is_rec `thenM` \ (poly_binds, poly_ids) ->
-- Extend the environment to bind the new polymorphic Ids
- tcExtendLocalValEnv poly_ids $
+ tcExtendLocalValEnv poly_ids $
-- Build bindings and IdInfos corresponding to user pragmas
- tcSpecSigs sigs `thenTc` \ (prag_binds, prag_lie) ->
+ tcSpecSigs sigs `thenM` \ prag_binds ->
- -- Now do whatever happens next, in the augmented envt
- do_next `thenTc` \ (thing, thing_lie) ->
+ -- Now do whatever happens next, in the augmented envt
+ do_next `thenM` \ thing ->
- -- Create specialisations of functions bound here
- -- We want to keep non-recursive things non-recursive
- -- so that we desugar unlifted bindings correctly
- case (top_lvl, is_rec) of
+ returnM (poly_ids, poly_binds, prag_binds, thing)
+ ) `thenM` \ ((poly_ids, poly_binds, prag_binds, thing), lie) ->
+
+ case top_lvl of
-- For the top level don't bother will all this bindInstsOfLocalFuns stuff
-- All the top level things are rec'd together anyway, so it's fine to
-- leave them to the tcSimplifyTop, and quite a bit faster too
- (TopLevel, _)
- -> returnTc (combiner Recursive (poly_binds `andMonoBinds` prag_binds) thing,
- thing_lie `plusLIE` prag_lie `plusLIE` poly_lie)
-
- (NotTopLevel, NonRecursive)
- -> bindInstsOfLocalFuns
- (thing_lie `plusLIE` prag_lie)
- poly_ids `thenTc` \ (thing_lie', lie_binds) ->
-
- returnTc (
+ TopLevel
+ -> extendLIEs lie `thenM_`
+ returnM (combiner Recursive (poly_binds `andMonoBinds` prag_binds) thing)
+
+ NotTopLevel
+ -> bindInstsOfLocalFuns lie poly_ids `thenM` \ lie_binds ->
+ -- Create specialisations of functions bound here
+
+ -- We want to keep non-recursive things non-recursive
+ -- so that we desugar unlifted bindings correctly
+ if isRec is_rec then
+ returnM (
+ combiner Recursive (
+ poly_binds `andMonoBinds`
+ lie_binds `andMonoBinds`
+ prag_binds) thing
+ )
+ else
+ returnM (
combiner NonRecursive poly_binds $
combiner NonRecursive prag_binds $
combiner Recursive lie_binds $
-- NB: the binds returned by tcSimplify and bindInstsOfLocalFuns
-- aren't guaranteed in dependency order (though we could change
-- that); hence the Recursive marker.
- thing,
-
- thing_lie' `plusLIE` poly_lie
- )
-
- (NotTopLevel, Recursive)
- -> bindInstsOfLocalFuns
- (thing_lie `plusLIE` poly_lie `plusLIE` prag_lie)
- poly_ids `thenTc` \ (final_lie, lie_binds) ->
-
- returnTc (
- combiner Recursive (
- poly_binds `andMonoBinds`
- lie_binds `andMonoBinds`
- prag_binds) thing,
- final_lie
- )
+ thing)
\end{code}
-> [TcSigInfo]
-> [RenamedSig] -- Used solely to get INLINE, NOINLINE sigs
-> RecFlag
- -> TcM (TcMonoBinds, LIE, [TcId])
+ -> TcM (TcMonoBinds, [TcId])
tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec
- = recoverTc (
+ = recoverM (
-- If typechecking the binds fails, then return with each
-- signature-less binder given type (forall a.a), to minimise subsequent
-- error messages
- newTyVar liftedTypeKind `thenNF_Tc` \ alpha_tv ->
+ newTyVar liftedTypeKind `thenM` \ alpha_tv ->
let
forall_a_a = mkForAllTy alpha_tv (mkTyVarTy alpha_tv)
binder_names = collectMonoBinders mbind
Just sig -> tcSigPolyId sig -- Signature
Nothing -> mkLocalId name forall_a_a -- No signature
in
- returnTc (EmptyMonoBinds, emptyLIE, poly_ids)
+ returnM (EmptyMonoBinds, poly_ids)
) $
-- TYPECHECK THE BINDINGS
- tcMonoBinds mbind tc_ty_sigs is_rec `thenTc` \ (mbind', lie_req, binder_names, mono_ids) ->
+ getLIE (tcMonoBinds mbind tc_ty_sigs is_rec) `thenM` \ ((mbind', binder_names, mono_ids), lie_req) ->
let
tau_tvs = foldr (unionVarSet . tyVarsOfType . idType) emptyVarSet mono_ids
in
-- GENERALISE
- tcAddSrcLoc (minimum (map getSrcLoc binder_names)) $
- tcAddErrCtxt (genCtxt binder_names) $
- generalise binder_names mbind tau_tvs lie_req tc_ty_sigs
- `thenTc` \ (tc_tyvars_to_gen, lie_free, dict_binds, dict_ids) ->
+ -- (it seems a bit crude to have to do getLIE twice,
+ -- but I can't see a better way just now)
+ addSrcLoc (minimum (map getSrcLoc binder_names)) $
+ addErrCtxt (genCtxt binder_names) $
+ getLIE (generalise binder_names mbind tau_tvs lie_req tc_ty_sigs)
+ `thenM` \ ((tc_tyvars_to_gen, dict_binds, dict_ids), lie_free) ->
-- ZONK THE GENERALISED TYPE VARIABLES TO REAL TyVars
-- included in the forall types of the polymorphic Ids.
-- At calls of these Ids we'll instantiate fresh type variables from
-- them, and we use their boxity then.
- mapNF_Tc zonkTcTyVarToTyVar tc_tyvars_to_gen `thenNF_Tc` \ real_tyvars_to_gen ->
+ mappM zonkTcTyVarToTyVar tc_tyvars_to_gen `thenM` \ real_tyvars_to_gen ->
-- ZONK THE Ids
-- It's important that the dict Ids are zonked, including the boxity set
-- in the previous step, because they are later used to form the type of
-- the polymorphic thing, and forall-types must be zonked so far as
-- their bound variables are concerned
- mapNF_Tc zonkId dict_ids `thenNF_Tc` \ zonked_dict_ids ->
- mapNF_Tc zonkId mono_ids `thenNF_Tc` \ zonked_mono_ids ->
+ mappM zonkId dict_ids `thenM` \ zonked_dict_ids ->
+ mappM zonkId mono_ids `thenM` \ zonked_mono_ids ->
-- BUILD THE POLYMORPHIC RESULT IDs
let
in
traceTc (text "binding:" <+> ppr ((zonked_dict_ids, dict_binds),
- exports, map idType poly_ids)) `thenTc_`
+ exports, map idType poly_ids)) `thenM_`
-- Check for an unlifted, non-overloaded group
-- In that case we must make extra checks
if any (isUnLiftedType . idType) zonked_mono_ids && null zonked_dict_ids
then -- Some bindings are unlifted
- checkUnliftedBinds top_lvl is_rec real_tyvars_to_gen mbind `thenTc_`
+ checkUnliftedBinds top_lvl is_rec real_tyvars_to_gen mbind `thenM_`
- returnTc (
+ extendLIEs lie_req `thenM_`
+ returnM (
AbsBinds [] [] exports inlines mbind',
- lie_req, -- Do not generate even any x=y bindings
+ -- Do not generate even any x=y bindings
poly_ids
)
else -- The normal case
- returnTc (
+ extendLIEs lie_free `thenM_`
+ returnM (
AbsBinds real_tyvars_to_gen
zonked_dict_ids
exports
inlines
(dict_binds `andMonoBinds` mbind'),
- lie_free, poly_ids
+ poly_ids
)
attachInlinePhase inline_phases bndr
-- That's why we just use an ASSERT here.
checkTc (isNotTopLevel top_lvl)
- (unliftedBindErr "Top-level" mbind) `thenTc_`
+ (unliftedBindErr "Top-level" mbind) `thenM_`
checkTc (isNonRec is_rec)
- (unliftedBindErr "Recursive" mbind) `thenTc_`
+ (unliftedBindErr "Recursive" mbind) `thenM_`
checkTc (single_bind mbind)
- (unliftedBindErr "Multiple" mbind) `thenTc_`
+ (unliftedBindErr "Multiple" mbind) `thenM_`
checkTc (null real_tyvars_to_gen)
(unliftedBindErr "Polymorphic" mbind)
generalise binder_names mbind tau_tvs lie_req sigs =
-- check for -fno-monomorphism-restriction
- doptsTc Opt_NoMonomorphismRestriction `thenTc` \ no_MR ->
+ doptM Opt_NoMonomorphismRestriction `thenM` \ no_MR ->
let is_unrestricted | no_MR = True
| otherwise = isUnRestrictedGroup tysig_names mbind
in
if not is_unrestricted then -- RESTRICTED CASE
-- Check signature contexts are empty
checkTc (all is_mono_sig sigs)
- (restrictedBindCtxtErr binder_names) `thenTc_`
+ (restrictedBindCtxtErr binder_names) `thenM_`
-- Now simplify with exactly that set of tyvars
-- We have to squash those Methods
- tcSimplifyRestricted doc tau_tvs lie_req `thenTc` \ (qtvs, lie_free, binds) ->
+ tcSimplifyRestricted doc tau_tvs lie_req `thenM` \ (qtvs, binds) ->
-- Check that signature type variables are OK
- checkSigsTyVars qtvs sigs `thenTc` \ final_qtvs ->
+ checkSigsTyVars qtvs sigs `thenM` \ final_qtvs ->
- returnTc (final_qtvs, lie_free, binds, [])
+ returnM (final_qtvs, binds, [])
else if null sigs then -- UNRESTRICTED CASE, NO TYPE SIGS
tcSimplifyInfer doc tau_tvs lie_req
else -- UNRESTRICTED CASE, WITH TYPE SIGS
-- CHECKING CASE: Unrestricted group, there are type signatures
-- Check signature contexts are identical
- checkSigsCtxts sigs `thenTc` \ (sig_avails, sig_dicts) ->
+ checkSigsCtxts sigs `thenM` \ (sig_avails, sig_dicts) ->
-- Check that the needed dicts can be
-- expressed in terms of the signature ones
- tcSimplifyInferCheck doc tau_tvs sig_avails lie_req `thenTc` \ (forall_tvs, lie_free, dict_binds) ->
+ tcSimplifyInferCheck doc tau_tvs sig_avails lie_req `thenM` \ (forall_tvs, dict_binds) ->
-- Check that signature type variables are OK
- checkSigsTyVars forall_tvs sigs `thenTc` \ final_qtvs ->
+ checkSigsTyVars forall_tvs sigs `thenM` \ final_qtvs ->
- returnTc (final_qtvs, lie_free, dict_binds, sig_dicts)
+ returnM (final_qtvs, dict_binds, sig_dicts)
where
tysig_names = map (idName . tcSigPolyId) sigs
-- might not otherwise be related. This is a rather subtle issue.
-- ToDo: amplify
checkSigsCtxts sigs@(TySigInfo id1 sig_tvs theta1 _ _ _ src_loc : other_sigs)
- = tcAddSrcLoc src_loc $
- mapTc_ check_one other_sigs `thenTc_`
+ = addSrcLoc src_loc $
+ mappM_ check_one other_sigs `thenM_`
if null theta1 then
- returnTc ([], []) -- Non-overloaded type signatures
+ returnM ([], []) -- Non-overloaded type signatures
else
- newDicts SignatureOrigin theta1 `thenNF_Tc` \ sig_dicts ->
+ newDicts SignatureOrigin theta1 `thenM` \ sig_dicts ->
let
-- The "sig_avails" is the stuff available. We get that from
-- the context of the type signature, BUT ALSO the lie_avail
-- so that polymorphic recursion works right (see comments at end of fn)
sig_avails = sig_dicts ++ sig_meths
in
- returnTc (sig_avails, map instToId sig_dicts)
+ returnM (sig_avails, map instToId sig_dicts)
where
sig1_dict_tys = map mkPredTy theta1
sig_meths = concat [insts | TySigInfo _ _ _ _ _ insts _ <- sigs]
check_one sig@(TySigInfo id _ theta _ _ _ _)
- = tcAddErrCtxt (sigContextsCtxt id1 id) $
- checkTc (equalLength theta theta1) sigContextsErr `thenTc_`
+ = addErrCtxt (sigContextsCtxt id1 id) $
+ checkTc (equalLength theta theta1) sigContextsErr `thenM_`
unifyTauTyLists sig1_dict_tys (map mkPredTy theta)
checkSigsTyVars :: [TcTyVar] -> [TcSigInfo] -> TcM [TcTyVar]
checkSigsTyVars qtvs sigs
- = mapTc check_one sigs `thenTc` \ sig_tvs_s ->
+ = mappM check_one sigs `thenM` \ sig_tvs_s ->
let
-- Sigh. Make sure that all the tyvars in the type sigs
-- appear in the returned ty var list, which is what we are
sig_tvs = foldr (unionVarSet . mkVarSet) emptyVarSet sig_tvs_s
all_tvs = mkVarSet qtvs `unionVarSet` sig_tvs
in
- returnTc (varSetElems all_tvs)
+ returnM (varSetElems all_tvs)
where
check_one (TySigInfo id sig_tyvars sig_theta sig_tau _ _ src_loc)
- = tcAddSrcLoc src_loc $
- tcAddErrCtxt (ptext SLIT("When checking the type signature for")
+ = addSrcLoc src_loc $
+ addErrCtxt (ptext SLIT("When checking the type signature for")
<+> quotes (ppr id)) $
- tcAddErrCtxtM (sigCtxt id sig_tyvars sig_theta sig_tau) $
+ addErrCtxtM (sigCtxt id sig_tyvars sig_theta sig_tau) $
checkSigTyVarsWrt (idFreeTyVars id) sig_tyvars
\end{code}
-> [TcSigInfo]
-> RecFlag
-> TcM (TcMonoBinds,
- LIE, -- LIE required
[Name], -- Bound names
[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) ->
+ = tc_mb_pats mbinds `thenM` \ (complete_it, tvs, ids, lie_avail) ->
let
id_list = bagToList ids
(names, mono_ids) = unzip id_list
NonRecursive -> []
in
-- Don't know how to deal with pattern-bound existentials yet
- checkTc (isEmptyBag tvs && isEmptyBag lie_avail)
- (existentialExplode mbinds) `thenTc_`
+ checkTc (isEmptyBag tvs && null lie_avail)
+ (existentialExplode mbinds) `thenM_`
-- *Before* checking the RHSs, but *after* checking *all* the patterns,
-- extend the envt with bindings for all the bound ids;
-- 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) ->
+ complete_it extra_val_env `thenM` \ mbinds' ->
- returnTc (mbinds', lie_req_pat `plusLIE` lie_req_rhss, names, mono_ids)
+ returnM (mbinds', names, mono_ids)
where
mk_bind (name, mono_id) = case maybeSig tc_ty_sigs name of
poly_id = tcSigPolyId sig
tc_mb_pats EmptyMonoBinds
- = returnTc (\ xve -> returnTc (EmptyMonoBinds, emptyLIE), emptyLIE, emptyBag, emptyBag, emptyLIE)
+ = returnM (\ xve -> returnM EmptyMonoBinds, emptyBag, emptyBag, [])
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) ->
+ = tc_mb_pats mb1 `thenM` \ (complete_it1, tvs1, ids1, lie_avail1) ->
+ tc_mb_pats mb2 `thenM` \ (complete_it2, tvs2, ids2, lie_avail2) ->
let
- complete_it xve = complete_it1 xve `thenTc` \ (mb1', lie1) ->
- complete_it2 xve `thenTc` \ (mb2', lie2) ->
- returnTc (AndMonoBinds mb1' mb2', lie1 `plusLIE` lie2)
+ complete_it xve = complete_it1 xve `thenM` \ mb1' ->
+ complete_it2 xve `thenM` \ mb2' ->
+ returnM (AndMonoBinds mb1' mb2')
in
- returnTc (complete_it,
- lie_req1 `plusLIE` lie_req2,
+ returnM (complete_it,
tvs1 `unionBags` tvs2,
ids1 `unionBags` ids2,
- lie_avail1 `plusLIE` lie_avail2)
+ lie_avail1 ++ lie_avail2)
tc_mb_pats (FunMonoBind name inf matches locn)
= (case maybeSig tc_ty_sigs name of
- Just sig -> returnNF_Tc (tcSigMonoId sig)
- Nothing -> newLocalName name `thenNF_Tc` \ bndr_name ->
- newTyVarTy openTypeKind `thenNF_Tc` \ bndr_ty ->
+ Just sig -> returnM (tcSigMonoId sig)
+ Nothing -> newLocalName name `thenM` \ bndr_name ->
+ newTyVarTy openTypeKind `thenM` \ bndr_ty ->
-- NB: not a 'hole' tyvar; since there is no type
-- signature, we revert to ordinary H-M typechecking
-- which means the variable gets an inferred tau-type
- returnNF_Tc (mkLocalId bndr_name bndr_ty)
- ) `thenNF_Tc` \ bndr_id ->
+ returnM (mkLocalId bndr_name bndr_ty)
+ ) `thenM` \ bndr_id ->
let
bndr_ty = idType bndr_id
- complete_it xve = tcAddSrcLoc locn $
- tcMatchesFun xve name bndr_ty matches `thenTc` \ (matches', lie) ->
- returnTc (FunMonoBind bndr_id inf matches' locn, lie)
+ complete_it xve = addSrcLoc locn $
+ tcMatchesFun xve name bndr_ty matches `thenM` \ matches' ->
+ returnM (FunMonoBind bndr_id inf matches' locn)
in
- returnTc (complete_it, emptyLIE, emptyBag, unitBag (name, bndr_id), emptyLIE)
+ returnM (complete_it, emptyBag, unitBag (name, bndr_id), [])
tc_mb_pats bind@(PatMonoBind pat grhss locn)
- = tcAddSrcLoc locn $
- newHoleTyVarTy `thenNF_Tc` \ pat_ty ->
+ = addSrcLoc locn $
+ newHoleTyVarTy `thenM` \ pat_ty ->
-- Now typecheck the pattern
-- We do now support binding fresh (not-already-in-scope) scoped
-- The type variables are brought into scope in tc_binds_and_then,
-- so we don't have to do anything here.
- tcPat tc_pat_bndr pat pat_ty `thenTc` \ (pat', lie_req, tvs, ids, lie_avail) ->
- readHoleResult pat_ty `thenTc` \ pat_ty' ->
+ tcPat tc_pat_bndr pat pat_ty `thenM` \ (pat', tvs, ids, lie_avail) ->
+ readHoleResult pat_ty `thenM` \ pat_ty' ->
let
- complete_it xve = tcAddSrcLoc locn $
- tcAddErrCtxt (patMonoBindsCtxt bind) $
+ complete_it xve = addSrcLoc locn $
+ addErrCtxt (patMonoBindsCtxt bind) $
tcExtendLocalValEnv2 xve $
- tcGRHSs PatBindRhs grhss pat_ty' `thenTc` \ (grhss', lie) ->
- returnTc (PatMonoBind pat' grhss' locn, lie)
+ tcGRHSs PatBindRhs grhss pat_ty' `thenM` \ grhss' ->
+ returnM (PatMonoBind pat' grhss' locn)
in
- returnTc (complete_it, lie_req, tvs, ids, lie_avail)
+ returnM (complete_it, tvs, ids, lie_avail)
-- tc_pat_bndr is used when dealing with a LHS binder in a pattern.
-- If there was a type sig for that Id, we want to make it much
tc_pat_bndr name pat_ty
= case maybeSig tc_ty_sigs name of
Nothing
- -> newLocalName name `thenNF_Tc` \ bndr_name ->
+ -> newLocalName name `thenM` \ bndr_name ->
tcMonoPatBndr bndr_name pat_ty
- Just sig -> tcAddSrcLoc (getSrcLoc name) $
- tcSubPat (idType mono_id) pat_ty `thenTc` \ (co_fn, lie) ->
- returnTc (co_fn, lie, mono_id)
+ Just sig -> addSrcLoc (getSrcLoc name) $
+ tcSubPat (idType mono_id) pat_ty `thenM` \ co_fn ->
+ returnM (co_fn, mono_id)
where
mono_id = tcSigMonoId sig
\end{code}
{-# SPECIALISE (f::<type) = g #-}
\begin{code}
-tcSpecSigs :: [RenamedSig] -> TcM (TcMonoBinds, LIE)
+tcSpecSigs :: [RenamedSig] -> TcM TcMonoBinds
tcSpecSigs (SpecSig name poly_ty src_loc : sigs)
= -- SPECIALISE f :: forall b. theta => tau = g
- tcAddSrcLoc src_loc $
- tcAddErrCtxt (valSpecSigCtxt name poly_ty) $
+ addSrcLoc src_loc $
+ addErrCtxt (valSpecSigCtxt name poly_ty) $
-- Get and instantiate its alleged specialised type
- tcHsSigType (FunSigCtxt name) poly_ty `thenTc` \ sig_ty ->
+ tcHsSigType (FunSigCtxt name) poly_ty `thenM` \ sig_ty ->
-- Check that f has a more general type, and build a RHS for
-- the spec-pragma-id at the same time
- tcExpr (HsVar name) sig_ty `thenTc` \ (spec_expr, spec_lie) ->
+ getLIE (tcExpr (HsVar name) sig_ty) `thenM` \ (spec_expr, spec_lie) ->
-- Squeeze out any Methods (see comments with tcSimplifyToDicts)
- tcSimplifyToDicts spec_lie `thenTc` \ (spec_dicts, spec_binds) ->
+ tcSimplifyToDicts spec_lie `thenM` \ spec_binds ->
-- Just specialise "f" by building a SpecPragmaId binding
-- It is the thing that makes sure we don't prematurely
-- dead-code-eliminate the binding we are really interested in.
- newLocalName name `thenNF_Tc` \ spec_name ->
+ newLocalName name `thenM` \ spec_name ->
let
spec_bind = VarMonoBind (mkSpecPragmaId spec_name sig_ty)
(mkHsLet spec_binds spec_expr)
in
-- Do the rest and combine
- tcSpecSigs sigs `thenTc` \ (binds_rest, lie_rest) ->
- returnTc (binds_rest `andMonoBinds` spec_bind,
- lie_rest `plusLIE` mkLIE spec_dicts)
+ tcSpecSigs sigs `thenM` \ binds_rest ->
+ returnM (binds_rest `andMonoBinds` spec_bind)
tcSpecSigs (other_sig : sigs) = tcSpecSigs sigs
-tcSpecSigs [] = returnTc (EmptyMonoBinds, emptyLIE)
+tcSpecSigs [] = returnM EmptyMonoBinds
\end{code}
#include "HsVersions.h"
import HsSyn ( TyClDecl(..), Sig(..), MonoBinds(..),
- HsExpr(..), HsLit(..), InPat(WildPatIn),
+ HsExpr(..), HsLit(..), Pat(WildPat),
mkSimpleMatch, andMonoBinds, andMonoBindList,
isClassOpSig, isPragSig,
- getClassDeclSysNames, placeHolderType
+ placeHolderType
)
import BasicTypes ( RecFlag(..), StrictnessMark(..) )
import RnHsSyn ( RenamedTyClDecl, RenamedSig,
RenamedClassOpSig, RenamedMonoBinds,
maybeGenericMatch
)
+import RnEnv ( lookupSysName )
import TcHsSyn ( TcMonoBinds )
-import Inst ( Inst, InstOrigin(..), LIE, emptyLIE, plusLIE, plusLIEs,
- instToId, newDicts, newMethod )
+import Inst ( Inst, InstOrigin(..), instToId, newDicts, newMethodAtLoc )
import TcEnv ( TyThingDetails(..),
tcLookupClass, tcExtendTyVarEnv2,
tcExtendTyVarEnv
mkTyVarTys, mkPredTys, mkClassPred, tcSplitSigmaTy, tcSplitFunTys,
tcIsTyVarTy, tcSplitTyConApp_maybe
)
-import TcMonad
+import TcRnMonad
import Generics ( mkGenericRhs )
import PrelInfo ( nO_METHOD_BINDING_ERROR_ID )
import Class ( classTyVars, classBigSig, classTyCon,
import MkId ( mkDictSelId, mkDataConId, mkDataConWrapId, mkDefaultMethodId )
import DataCon ( mkDataCon )
import Id ( Id, idType, idName, setIdLocalExported, setInlinePragma )
-import Module ( Module )
import Name ( Name, NamedThing(..) )
import NameEnv ( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, plusNameEnv )
import NameSet ( emptyNameSet, unitNameSet )
+import OccName ( mkClassTyConOcc, mkClassDataConOcc, mkWorkerOcc, mkSuperDictSelOcc )
import Outputable
import Var ( TyVar )
import CmdLineOpts
tcClassDecl1 (ClassDecl {tcdCtxt = context, tcdName = class_name,
tcdTyVars = tyvar_names, tcdFDs = fundeps,
tcdSigs = class_sigs, tcdMeths = def_methods,
- tcdSysNames = sys_names, tcdLoc = src_loc})
+ tcdLoc = src_loc})
= -- LOOK THINGS UP IN THE ENVIRONMENT
- tcLookupClass class_name `thenTc` \ clas ->
+ tcLookupClass class_name `thenM` \ clas ->
let
- tyvars = classTyVars clas
- op_sigs = filter isClassOpSig class_sigs
- op_names = [n | ClassOpSig n _ _ _ <- op_sigs]
- (_, datacon_name, datacon_wkr_name, sc_sel_names) = getClassDeclSysNames sys_names
+ tyvars = classTyVars clas
+ op_sigs = filter isClassOpSig class_sigs
+ op_names = [n | ClassOpSig n _ _ _ <- op_sigs]
in
tcExtendTyVarEnv tyvars $
- checkDefaultBinds clas op_names def_methods `thenTc` \ mb_dm_env ->
+ checkDefaultBinds clas op_names def_methods `thenM` \ mb_dm_env ->
-- CHECK THE CONTEXT
-- The renamer has already checked that the context mentions
-- only the type variable of the class decl.
-- Context is already kind-checked
- ASSERT( equalLength context sc_sel_names )
- tcHsTheta context `thenTc` \ sc_theta ->
+ tcHsTheta context `thenM` \ sc_theta ->
-- CHECK THE CLASS SIGNATURES,
- mapTc (tcClassSig clas tyvars mb_dm_env) op_sigs `thenTc` \ sig_stuff ->
+ mappM (tcClassSig clas tyvars mb_dm_env) op_sigs `thenM` \ sig_stuff ->
-- MAKE THE CLASS DETAILS
+ lookupSysName class_name mkClassDataConOcc `thenM` \ datacon_name ->
+ lookupSysName datacon_name mkWorkerOcc `thenM` \ datacon_wkr_name ->
+ mapM (lookupSysName class_name . mkSuperDictSelOcc)
+ [1..length context] `thenM` \ sc_sel_names ->
+ -- We number off the superclass selectors, 1, 2, 3 etc so that we
+ -- can construct names for the selectors. Thus
+ -- class (C a, C b) => D a b where ...
+ -- gives superclass selectors
+ -- D_sc1, D_sc2
+ -- (We used to call them D_C, but now we can have two different
+ -- superclasses both called C!)
+ lookupSysName class_name mkClassTyConOcc `thenM` \ tycon_name ->
let
(op_tys, op_items) = unzip sig_stuff
sc_tys = mkPredTys sc_theta
dict_con_id = mkDataConId datacon_wkr_name dict_con
dict_wrap_id = mkDataConWrapId dict_con
in
- returnTc (class_name, ClassDetails sc_theta sc_sel_ids op_items dict_con)
+ returnM (class_name, ClassDetails sc_theta sc_sel_ids op_items dict_con tycon_name)
\end{code}
\begin{code}
-- But do all this only for source binds
checkDefaultBinds clas ops Nothing
- = returnTc Nothing
+ = returnM Nothing
checkDefaultBinds clas ops (Just mbs)
- = go mbs `thenTc` \ dm_env ->
- returnTc (Just dm_env)
+ = go mbs `thenM` \ dm_env ->
+ returnM (Just dm_env)
where
- go EmptyMonoBinds = returnTc emptyNameEnv
+ go EmptyMonoBinds = returnM emptyNameEnv
go (AndMonoBinds b1 b2)
- = go b1 `thenTc` \ dm_info1 ->
- go b2 `thenTc` \ dm_info2 ->
- returnTc (dm_info1 `plusNameEnv` dm_info2)
+ = go b1 `thenM` \ dm_info1 ->
+ go b2 `thenM` \ dm_info2 ->
+ returnM (dm_info1 `plusNameEnv` dm_info2)
go (FunMonoBind op _ matches loc)
- = tcAddSrcLoc loc $
+ = addSrcLoc loc $
-- Check that the op is from this class
- checkTc (op `elem` ops) (badMethodErr clas op) `thenTc_`
+ checkTc (op `elem` ops) (badMethodErr clas op) `thenM_`
-- Check that all the defns ar generic, or none are
- checkTc (all_generic || none_generic) (mixedGenericErr op) `thenTc_`
+ checkTc (all_generic || none_generic) (mixedGenericErr op) `thenM_`
- returnTc (unitNameEnv op all_generic)
+ returnM (unitNameEnv op all_generic)
where
n_generic = count (isJust . maybeGenericMatch) matches
none_generic = n_generic == 0
tcClassSig clas clas_tyvars maybe_dm_env
(ClassOpSig op_name sig_dm op_ty src_loc)
- = tcAddSrcLoc src_loc $
+ = addSrcLoc src_loc $
-- Check the type signature. NB that the envt *already has*
-- bindings for the type variables; see comments in TcTyAndClassDcls.
- tcHsType op_ty `thenTc` \ local_ty ->
+ tcHsType op_ty `thenM` \ local_ty ->
let
theta = [mkClassPred clas (mkTyVarTys clas_tyvars)]
Just True -> GenDefMeth
Just False -> DefMeth dm_name
in
- returnTc (local_ty, (sel_id, dm_info))
+ returnM (local_ty, (sel_id, dm_info))
\end{code}
each local class decl.
\begin{code}
-tcClassDecls2 :: Module -> [RenamedTyClDecl] -> NF_TcM (LIE, TcMonoBinds, [Id])
+tcClassDecls2 :: [RenamedTyClDecl] -> TcM (TcMonoBinds, [Id])
-tcClassDecls2 this_mod decls
+tcClassDecls2 decls
= foldr combine
- (returnNF_Tc (emptyLIE, EmptyMonoBinds, []))
+ (returnM (EmptyMonoBinds, []))
[tcClassDecl2 cls_decl | cls_decl@(ClassDecl {tcdMeths = Just _}) <- decls]
-- The 'Just' picks out source ClassDecls
where
- combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1, ids1) ->
- tc2 `thenNF_Tc` \ (lie2, binds2, ids2) ->
- returnNF_Tc (lie1 `plusLIE` lie2,
- binds1 `AndMonoBinds` binds2,
- ids1 ++ ids2)
+ combine tc1 tc2 = tc1 `thenM` \ (binds1, ids1) ->
+ tc2 `thenM` \ (binds2, ids2) ->
+ returnM (binds1 `AndMonoBinds` binds2,
+ ids1 ++ ids2)
\end{code}
@tcClassDecl2@ generates bindings for polymorphic default methods
\begin{code}
tcClassDecl2 :: RenamedTyClDecl -- The class declaration
- -> NF_TcM (LIE, TcMonoBinds, [Id])
+ -> TcM (TcMonoBinds, [Id])
tcClassDecl2 (ClassDecl {tcdName = class_name, tcdSigs = sigs,
tcdMeths = Just default_binds, tcdLoc = src_loc})
= -- The 'Just' picks out source ClassDecls
- recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds, [])) $
- tcAddSrcLoc src_loc $
- tcLookupClass class_name `thenNF_Tc` \ clas ->
+ recoverM (returnM (EmptyMonoBinds, [])) $
+ addSrcLoc src_loc $
+ tcLookupClass class_name `thenM` \ clas ->
-- We make a separate binding for each default method.
-- At one time I used a single AbsBinds for all of them, thus
prags = filter isPragSig sigs
tc_dm = tcDefMeth clas tyvars default_binds prags
in
- mapAndUnzip3Tc tc_dm op_items `thenTc` \ (defm_binds, const_lies, dm_ids_s) ->
+ mapAndUnzipM tc_dm op_items `thenM` \ (defm_binds, dm_ids_s) ->
- returnTc (plusLIEs const_lies, andMonoBindList defm_binds, concat dm_ids_s)
+ returnM (andMonoBindList defm_binds, concat dm_ids_s)
-tcDefMeth clas tyvars binds_in prags (_, NoDefMeth) = returnTc (EmptyMonoBinds, emptyLIE, [])
-tcDefMeth clas tyvars binds_in prags (_, GenDefMeth) = returnTc (EmptyMonoBinds, emptyLIE, [])
+tcDefMeth clas tyvars binds_in prags (_, NoDefMeth) = returnM (EmptyMonoBinds, [])
+tcDefMeth clas tyvars binds_in prags (_, GenDefMeth) = returnM (EmptyMonoBinds, [])
-- Generate code for polymorphic default methods only
-- (Generic default methods have turned into instance decls by now.)
-- This is incompatible with Hugs, which expects a polymorphic
-- (If necessary we can fix that, but we don't have a convenient Id to hand.)
tcDefMeth clas tyvars binds_in prags op_item@(sel_id, DefMeth dm_name)
- = tcInstTyVars ClsTv tyvars `thenNF_Tc` \ (clas_tyvars, inst_tys, _) ->
+ = tcInstTyVars ClsTv tyvars `thenM` \ (clas_tyvars, inst_tys, _) ->
let
dm_ty = idType sel_id -- Same as dict selector!
-- The default method's type should really come from the
-- Reason for setIdLocalExported: see notes with MkId.mkDictFunId
xtve = tyvars `zip` clas_tyvars
in
- newDicts origin theta `thenNF_Tc` \ [this_dict] ->
+ newDicts origin theta `thenM` \ [this_dict] ->
- mkMethodBind origin clas inst_tys binds_in op_item `thenTc` \ (dm_inst, meth_info) ->
- tcMethodBind xtve clas_tyvars theta
- [this_dict] prags meth_info `thenTc` \ (defm_bind, insts_needed) ->
+ mkMethodBind origin clas inst_tys binds_in op_item `thenM` \ (dm_inst, meth_info) ->
+ getLIE (tcMethodBind xtve clas_tyvars theta
+ [this_dict] prags meth_info) `thenM` \ (defm_bind, insts_needed) ->
- tcAddErrCtxt (defltMethCtxt clas) $
+ addErrCtxt (defltMethCtxt clas) $
-- Check the context
tcSimplifyCheck
(ptext SLIT("class") <+> ppr clas)
clas_tyvars
[this_dict]
- insts_needed `thenTc` \ (const_lie, dict_binds) ->
+ insts_needed `thenM` \ dict_binds ->
-- Simplification can do unification
- checkSigTyVars clas_tyvars `thenTc` \ clas_tyvars' ->
+ checkSigTyVars clas_tyvars `thenM` \ clas_tyvars' ->
let
full_bind = AbsBinds
emptyNameSet -- No inlines (yet)
(dict_binds `andMonoBinds` defm_bind)
in
- returnTc (full_bind, const_lie, [dm_id])
+ returnM (full_bind, [dm_id])
where
origin = ClassDeclOrigin
\end{code}
-- from the method body
-> [RenamedSig] -- Pragmas (e.g. inline pragmas)
-> (Id, TcSigInfo, RenamedMonoBinds) -- Details of this method
- -> TcM (TcMonoBinds, LIE)
+ -> TcM TcMonoBinds
tcMethodBind xtve inst_tyvars inst_theta avail_insts prags
(sel_id, meth_sig, meth_bind)
- =
- -- Check the bindings; first adding inst_tyvars to the envt
+ = -- Check the bindings; first adding inst_tyvars to the envt
-- so that we don't quantify over them in nested places
tcExtendTyVarEnv2 xtve (
- tcAddErrCtxt (methodCtxt sel_id) $
- tcMonoBinds meth_bind [meth_sig] NonRecursive
- ) `thenTc` \ (meth_bind, meth_lie, _, _) ->
+ addErrCtxt (methodCtxt sel_id) $
+ getLIE (tcMonoBinds meth_bind [meth_sig] NonRecursive)
+ ) `thenM` \ ((meth_bind, _, _), meth_lie) ->
-- Now do context reduction. We simplify wrt both the local tyvars
-- and the ones of the class/instance decl, so that there is
let
TySigInfo meth_id meth_tvs meth_theta _ local_meth_id _ _ = meth_sig
in
- tcAddErrCtxtM (sigCtxt sel_id inst_tyvars inst_theta (idType meth_id)) $
- newDicts SignatureOrigin meth_theta `thenNF_Tc` \ meth_dicts ->
+ addErrCtxtM (sigCtxt sel_id inst_tyvars inst_theta (idType meth_id)) $
+ newDicts SignatureOrigin meth_theta `thenM` \ meth_dicts ->
let
all_tyvars = meth_tvs ++ inst_tyvars
all_insts = avail_insts ++ meth_dicts
in
tcSimplifyCheck
(ptext SLIT("class or instance method") <+> quotes (ppr sel_id))
- all_tyvars all_insts meth_lie `thenTc` \ (lie, lie_binds) ->
+ all_tyvars all_insts meth_lie `thenM` \ lie_binds ->
- checkSigTyVars all_tyvars `thenTc` \ all_tyvars' ->
+ checkSigTyVars all_tyvars `thenM` \ all_tyvars' ->
let
-- Attach inline pragmas as appropriate
inlines
(lie_binds `andMonoBinds` meth_bind)
in
- returnTc (poly_meth_bind, lie)
+ returnM poly_meth_bind
mkMethodBind :: InstOrigin
RenamedMonoBinds)) -- Binding for the method
mkMethodBind origin clas inst_tys meth_binds (sel_id, dm_info)
- = tcGetSrcLoc `thenNF_Tc` \ loc ->
- newMethod origin sel_id inst_tys `thenNF_Tc` \ meth_inst ->
+ = getInstLoc origin `thenM` \ inst_loc ->
+ newMethodAtLoc inst_loc sel_id inst_tys `thenM` \ meth_inst ->
+ -- Do not dump anything into the LIE
let
meth_id = instToId meth_inst
meth_name = idName meth_id
in
-- Figure out what method binding to use
-- If the user suppplied one, use it, else construct a default one
+ getSrcLocM `thenM` \ loc ->
(case find_bind (idName sel_id) meth_name meth_binds of
- Just user_bind -> returnTc user_bind
- Nothing -> mkDefMethRhs origin clas inst_tys sel_id loc dm_info `thenTc` \ rhs ->
- returnTc (FunMonoBind meth_name False -- Not infix decl
+ Just user_bind -> returnM user_bind
+ Nothing -> mkDefMethRhs origin clas inst_tys sel_id loc dm_info `thenM` \ rhs ->
+ returnM (FunMonoBind meth_name False -- Not infix decl
[mkSimpleMatch [] rhs placeHolderType loc] loc)
- ) `thenTc` \ meth_bind ->
+ ) `thenM` \ meth_bind ->
- mkTcSig meth_id loc `thenNF_Tc` \ meth_sig ->
+ mkTcSig meth_id loc `thenM` \ meth_sig ->
- returnTc (meth_inst, (sel_id, meth_sig, meth_bind))
+ returnM (meth_inst, (sel_id, meth_sig, meth_bind))
-- The user didn't supply a method binding,
-- The RHS of a default method depends on the default-method info
mkDefMethRhs origin clas inst_tys sel_id loc (DefMeth dm_name)
= -- An polymorphic default method
- returnTc (HsVar dm_name)
+ traceRn (text "mkDefMeth" <+> ppr dm_name) `thenM_`
+ returnM (HsVar dm_name)
mkDefMethRhs origin clas inst_tys sel_id loc NoDefMeth
= -- No default method
-- Warn only if -fwarn-missing-methods
- doptsTc Opt_WarnMissingMethods `thenNF_Tc` \ warn ->
+ doptM Opt_WarnMissingMethods `thenM` \ warn ->
warnTc (isInstDecl origin && warn)
- (omittedMethodWarn sel_id) `thenNF_Tc_`
- returnTc error_rhs
+ (omittedMethodWarn sel_id) `thenM_`
+ returnM error_rhs
where
error_rhs = HsLam (mkSimpleMatch wild_pats simple_rhs placeHolderType loc)
simple_rhs = HsApp (HsVar (getName nO_METHOD_BINDING_ERROR_ID))
-- Need two splits because the selector can have a type like
-- forall a. Foo a => forall b. Eq b => ...
(arg_tys, _) = tcSplitFunTys tau2
- wild_pats = [WildPatIn | ty <- arg_tys]
+ wild_pats = [WildPat placeHolderType | ty <- arg_tys]
mkDefMethRhs origin clas inst_tys sel_id loc GenDefMeth
= -- A generic default method
ASSERT( isInstDecl origin ) -- We never get here from a class decl
checkTc (isJust maybe_tycon)
- (badGenericInstance sel_id (notSimple inst_tys)) `thenTc_`
+ (badGenericInstance sel_id (notSimple inst_tys)) `thenM_`
checkTc (isJust (tyConGenInfo tycon))
- (badGenericInstance sel_id (notGeneric tycon)) `thenTc_`
+ (badGenericInstance sel_id (notGeneric tycon)) `thenM_`
- ioToTc (dumpIfSet opt_PprStyle_Debug "Generic RHS" stuff) `thenNF_Tc_`
- returnTc rhs
+ ioToTcRn (dumpIfSet opt_PprStyle_Debug "Generic RHS" stuff) `thenM_`
+ returnM rhs
where
rhs = mkGenericRhs sel_id clas_tyvar tycon
\section[TcDefaults]{Typechecking \tr{default} declarations}
\begin{code}
-module TcDefaults ( tcDefaults, defaultDefaultTys ) where
+module TcDefaults ( tcDefaults ) where
#include "HsVersions.h"
import HsSyn ( HsDecl(..), DefaultDecl(..) )
import RnHsSyn ( RenamedHsDecl )
-import TcMonad
+import TcRnMonad
import TcEnv ( tcLookupGlobal_maybe )
import TcMonoType ( tcHsType )
import TcSimplify ( tcSimplifyDefault )
-
-import TysWiredIn ( integerTy, doubleTy )
import TcType ( Type, mkClassPred, isTauTy )
import PrelNames ( numClassName )
import Outputable
\end{code}
\begin{code}
-defaultDefaultTys = [integerTy, doubleTy]
-
tcDefaults :: [RenamedHsDecl]
-> TcM [Type] -- defaulting types to heave
-- into Tc monad for later use
-- in Disambig.
tcDefaults decls = tc_defaults [default_decl | DefD default_decl <- decls]
-tc_defaults [] = returnTc defaultDefaultTys
+tc_defaults [] = returnM defaultDefaultTys
tc_defaults [DefaultDecl [] locn]
- = returnTc [] -- no defaults
+ = returnM [] -- no defaults
tc_defaults [DefaultDecl mono_tys locn]
- = tcLookupGlobal_maybe numClassName `thenNF_Tc` \ maybe_num ->
+ = tcLookupGlobal_maybe numClassName `thenM` \ maybe_num ->
case maybe_num of
Just (AClass num_class) -> common_case num_class
- other -> returnTc []
+ other -> returnM []
-- In the Nothing case, Num has not been sucked in, so the
-- defaults will never be used; so simply discard the default decl.
-- This slightly benefits modules that don't use any
-- always sucking in Num
where
common_case num_class
- = tcAddSrcLoc locn $
- tcAddErrCtxt defaultDeclCtxt $
- mapTc tc_default_ty mono_tys `thenTc` \ tau_tys ->
+ = addSrcLoc locn $
+ addErrCtxt defaultDeclCtxt $
+ mappM tc_default_ty mono_tys `thenM` \ tau_tys ->
-- Check that all the types are instances of Num
-- We only care about whether it worked or not
- tcSimplifyDefault [mkClassPred num_class [ty] | ty <- tau_tys] `thenTc_`
+ tcSimplifyDefault [mkClassPred num_class [ty] | ty <- tau_tys] `thenM_`
- returnTc tau_tys
+ returnM tau_tys
tc_defaults decls@(DefaultDecl _ loc : _) =
- tcAddSrcLoc loc $
+ addSrcLoc loc $
failWithTc (dupDefaultDeclErr decls)
tc_default_ty hs_ty
- = tcHsType hs_ty `thenTc` \ ty ->
- checkTc (isTauTy ty) (polyDefErr hs_ty) `thenTc_`
- returnTc ty
+ = tcHsType hs_ty `thenM` \ ty ->
+ checkTc (isTauTy ty) (polyDefErr hs_ty) `thenM_`
+ returnM ty
defaultDeclCtxt = ptext SLIT("when checking that each type in a default declaration")
$$ ptext SLIT("is an instance of class Num")
#include "HsVersions.h"
import HsSyn ( HsBinds(..), MonoBinds(..), TyClDecl(..),
- collectLocatedMonoBinders )
+ collectMonoBinders )
import RdrHsSyn ( RdrNameMonoBinds )
import RnHsSyn ( RenamedHsBinds, RenamedMonoBinds, RenamedTyClDecl, RenamedHsPred )
import CmdLineOpts ( DynFlag(..) )
-import TcMonad
-import TcEnv ( tcSetInstEnv, newDFunName, InstInfo(..), pprInstInfo,
- tcLookupTyCon, tcExtendTyVarEnv
+import TcRnMonad
+import TcEnv ( tcGetInstEnv, tcSetInstEnv, newDFunName, InstInfo(..), pprInstInfo,
+ pprInstInfoDetails, tcLookupTyCon, tcExtendTyVarEnv
)
import TcGenDeriv -- Deriv stuff
import InstEnv ( InstEnv, simpleDFunClassTyCon, extendInstEnv )
import TcSimplify ( tcSimplifyDeriv )
import RnBinds ( rnMethodBinds, rnTopMonoBinds )
-import RnEnv ( bindLocatedLocalsRn )
-import RnMonad ( renameDerivedCode, thenRn, mapRn, returnRn )
-import HscTypes ( DFunId, PersistentRenamerState, FixityEnv )
+import RnEnv ( bindLocalsFVRn )
+import TcRnMonad ( thenM, returnM, mapAndUnzipM )
+import HscTypes ( DFunId )
import BasicTypes ( NewOrData(..) )
import Class ( className, classKey, classTyVars, Class )
import ErrUtils ( dumpIfSet_dyn )
import MkId ( mkDictFunId )
import DataCon ( dataConRepArgTys, isNullaryDataCon, isExistentialDataCon )
-import PrelInfo ( needsDataDeclCtxtClassKeys )
import Maybes ( maybeToBool, catMaybes )
-import Module ( Module )
import Name ( Name, getSrcLoc, nameUnique )
+import NameSet
import RdrName ( RdrName )
import TyCon ( tyConTyVars, tyConDataCons, tyConArity, newTyConRep,
%************************************************************************
\begin{code}
-tcDeriving :: PersistentRenamerState
- -> Module -- name of module under scrutiny
- -> InstEnv -- What we already know about instances
- -> FixityEnv -- used in deriving Show and Read
- -> [RenamedTyClDecl] -- All type constructors
+tcDeriving :: [RenamedTyClDecl] -- All type constructors
-> TcM ([InstInfo], -- The generated "instance decls".
- RenamedHsBinds) -- Extra generated bindings
+ RenamedHsBinds, -- Extra generated bindings
+ FreeVars) -- These are free in the generated bindings
-tcDeriving prs mod inst_env get_fixity tycl_decls
- = recoverTc (returnTc ([], EmptyBinds)) $
- getDOptsTc `thenNF_Tc` \ dflags ->
+tcDeriving tycl_decls
+ = recoverM (returnM ([], EmptyBinds, emptyFVs)) $
+ getDOpts `thenM` \ dflags ->
+ tcGetInstEnv `thenM` \ inst_env ->
-- Fish the "deriving"-related information out of the TcEnv
-- and make the necessary "equations".
- makeDerivEqns tycl_decls `thenTc` \ (ordinary_eqns, newtype_inst_info) ->
+ makeDerivEqns tycl_decls `thenM` \ (ordinary_eqns, newtype_inst_info) ->
let
-- Add the newtype-derived instances to the inst env
-- before tacking the "ordinary" ones
inst_env1 = extend_inst_env dflags inst_env
(map iDFunId newtype_inst_info)
in
- deriveOrdinaryStuff mod prs inst_env1 get_fixity
- ordinary_eqns `thenTc` \ (ordinary_inst_info, binds) ->
+ deriveOrdinaryStuff inst_env1 ordinary_eqns `thenM` \ (ordinary_inst_info, binds, fvs) ->
let
inst_info = newtype_inst_info ++ ordinary_inst_info
in
- ioToTc (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
- (ddump_deriving inst_info binds)) `thenTc_`
+ ioToTcRn (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
+ (ddump_deriving inst_info binds)) `thenM_`
- returnTc (inst_info, binds)
+ returnM (inst_info, binds, fvs)
where
ddump_deriving :: [InstInfo] -> RenamedHsBinds -> SDoc
= vcat (map ppr_info inst_infos) $$ ppr extra_binds
ppr_info inst_info = pprInstInfo inst_info $$
- nest 4 (ppr (iBinds inst_info))
+ nest 4 (pprInstInfoDetails inst_info)
-- pprInstInfo doesn't print much: only the type
-----------------------------------------
-deriveOrdinaryStuff mod prs inst_env_in get_fixity [] -- Short cut
- = returnTc ([], EmptyBinds)
+deriveOrdinaryStuff inst_env_in [] -- Short cut
+ = returnM ([], EmptyBinds, emptyFVs)
-deriveOrdinaryStuff mod prs inst_env_in get_fixity eqns
+deriveOrdinaryStuff inst_env_in eqns
= -- Take the equation list and solve it, to deliver a list of
-- solutions, a.k.a. the contexts for the instance decls
-- required for the corresponding equations.
- solveDerivEqns inst_env_in eqns `thenTc` \ new_dfuns ->
+ solveDerivEqns inst_env_in eqns `thenM` \ new_dfuns ->
-- Now augment the InstInfos, adding in the rather boring
-- actual-code-to-do-the-methods binds. We may also need to
-- generate extra not-one-inst-decl-specific binds, notably
-- "con2tag" and/or "tag2con" functions. We do these
-- separately.
- gen_taggery_Names new_dfuns `thenTc` \ nm_alist_etc ->
+ gen_taggery_Names new_dfuns `thenM` \ nm_alist_etc ->
- tcGetEnv `thenNF_Tc` \ env ->
- getDOptsTc `thenNF_Tc` \ dflags ->
let
extra_mbind_list = map gen_tag_n_con_monobind nm_alist_etc
extra_mbinds = foldr AndMonoBinds EmptyMonoBinds extra_mbind_list
- method_binds_s = map (gen_bind get_fixity) new_dfuns
- mbinders = collectLocatedMonoBinders extra_mbinds
+ mbinders = collectMonoBinders extra_mbinds
+ in
+ mappM gen_bind new_dfuns `thenM` \ method_binds_s ->
+ traceTc (text "tcDeriv" <+> ppr method_binds_s) `thenM_`
+ getModule `thenM` \ this_mod ->
+ initRn (InterfaceMode this_mod) (
-- Rename to get RenamedBinds.
- -- The only tricky bit is that the extra_binds must scope over the
- -- method bindings for the instances.
- (rn_method_binds_s, rn_extra_binds)
- = renameDerivedCode dflags mod prs (
- bindLocatedLocalsRn (ptext (SLIT("deriving"))) mbinders $ \ _ ->
- rnTopMonoBinds extra_mbinds [] `thenRn` \ (rn_extra_binds, _) ->
- mapRn rn_meths method_binds_s `thenRn` \ rn_method_binds_s ->
- returnRn (rn_method_binds_s, rn_extra_binds)
- )
+ -- The only tricky bit is that the extra_binds must scope
+ -- over the method bindings for the instances.
+ bindLocalsFVRn (ptext (SLIT("deriving"))) mbinders $ \ _ ->
+ rnTopMonoBinds extra_mbinds [] `thenM` \ (rn_extra_binds, fvs) ->
+ mapAndUnzipM rn_meths method_binds_s `thenM` \ (rn_method_binds_s, fvs_s) ->
+ returnM ((rn_method_binds_s, rn_extra_binds),
+ fvs `plusFV` plusFVs fvs_s)
+ ) `thenM` \ ((rn_method_binds_s, rn_extra_binds), fvs) ->
+ let
new_inst_infos = zipWith gen_inst_info new_dfuns rn_method_binds_s
in
- returnTc (new_inst_infos, rn_extra_binds)
+ returnM (new_inst_infos, rn_extra_binds, fvs)
where
-- Make a Real dfun instead of the dummy one we have so far
gen_inst_info dfun binds
= InstInfo { iDFunId = dfun, iBinds = binds, iPrags = [] }
- rn_meths (cls, meths) = rnMethodBinds cls [] meths `thenRn` \ (meths', _) ->
- returnRn meths' -- Ignore the free vars returned
+ rn_meths (cls, meths) = rnMethodBinds cls [] meths
\end{code}
[InstInfo]) -- Special newtype derivings
makeDerivEqns tycl_decls
- = mapAndUnzipTc mk_eqn derive_these `thenTc` \ (maybe_ordinaries, maybe_newtypes) ->
- returnTc (catMaybes maybe_ordinaries, catMaybes maybe_newtypes)
+ = mapAndUnzipM mk_eqn derive_these `thenM` \ (maybe_ordinaries, maybe_newtypes) ->
+ returnM (catMaybes maybe_ordinaries, catMaybes maybe_newtypes)
where
------------------------------------------------------------------
derive_these :: [(NewOrData, Name, RenamedHsPred)]
pred <- preds ]
------------------------------------------------------------------
- mk_eqn :: (NewOrData, Name, RenamedHsPred) -> NF_TcM (Maybe DerivEqn, Maybe InstInfo)
+ mk_eqn :: (NewOrData, Name, RenamedHsPred) -> TcM (Maybe DerivEqn, Maybe InstInfo)
-- We swizzle the tyvars and datacons out of the tycon
-- to make the rest of the equation
mk_eqn (new_or_data, tycon_name, pred)
- = tcLookupTyCon tycon_name `thenNF_Tc` \ tycon ->
- tcAddSrcLoc (getSrcLoc tycon) $
- tcAddErrCtxt (derivCtxt Nothing tycon) $
+ = tcLookupTyCon tycon_name `thenM` \ tycon ->
+ addSrcLoc (getSrcLoc tycon) $
+ addErrCtxt (derivCtxt Nothing tycon) $
tcExtendTyVarEnv (tyConTyVars tycon) $ -- Deriving preds may (now) mention
-- the type variables for the type constructor
- tcHsPred pred `thenTc` \ pred' ->
+ tcHsPred pred `thenM` \ pred' ->
case getClassPredTys_maybe pred' of
Nothing -> bale_out (malformedPredErr tycon pred)
Just (clas, tys) -> mk_eqn_help new_or_data tycon clas tys
| Just err <- chk_out clas tycon tys
= bale_out (derivingThingErr clas tys tycon tyvars err)
| otherwise
- = new_dfun_name clas tycon `thenNF_Tc` \ dfun_name ->
- returnNF_Tc (Just (dfun_name, clas, tycon, tyvars, constraints), Nothing)
+ = new_dfun_name clas tycon `thenM` \ dfun_name ->
+ returnM (Just (dfun_name, clas, tycon, tyvars, constraints), Nothing)
where
tyvars = tyConTyVars tycon
data_cons = tyConDataCons tycon
-- | offensive_class = tyConTheta tycon
-- | otherwise = []
- -- offensive_class = classKey clas `elem` needsDataDeclCtxtClassKeys
+ -- offensive_class = classKey clas `elem` PrelInfo.needsDataDeclCtxtClassKeys
mk_eqn_help NewType tycon clas tys
- = doptsTc Opt_GlasgowExts `thenTc` \ gla_exts ->
+ = doptM Opt_GlasgowExts `thenM` \ gla_exts ->
if can_derive_via_isomorphism && (gla_exts || standard_instance) then
-- Go ahead and use the isomorphism
- new_dfun_name clas tycon `thenNF_Tc` \ dfun_name ->
- returnTc (Nothing, Just (NewTypeDerived (mk_dfun dfun_name)))
+ new_dfun_name clas tycon `thenM` \ dfun_name ->
+ returnM (Nothing, Just (NewTypeDerived (mk_dfun dfun_name)))
else
if standard_instance then
mk_eqn_help DataType tycon clas [] -- Go via bale-out route
cant_derive_err = derivingThingErr clas tys tycon tyvars_to_keep
(ptext SLIT("too hard for cunning newtype deriving"))
- bale_out err = addErrTc err `thenNF_Tc_` returnNF_Tc (Nothing, Nothing)
+ bale_out err = addErrTc err `thenM_` returnM (Nothing, Nothing)
------------------------------------------------------------------
chk_out :: Class -> TyCon -> [TcType] -> Maybe SDoc
= pprPanic "solveDerivEqns: probable loop"
(vcat (map pprDerivEqn orig_eqns) $$ ppr current_solns)
| otherwise
- = getDOptsTc `thenNF_Tc` \ dflags ->
+ = getDOpts `thenM` \ dflags ->
let
dfuns = zipWithEqual "add_solns" mk_deriv_dfun orig_eqns current_solns
inst_env = extend_inst_env dflags inst_env_in dfuns
in
- checkNoErrsTc (
+ checkNoErrs (
-- Extend the inst info from the explicit instance decls
-- with the current set of solutions, and simplify each RHS
tcSetInstEnv inst_env $
- mapTc gen_soln orig_eqns
- ) `thenTc` \ new_solns ->
+ mappM gen_soln orig_eqns
+ ) `thenM` \ new_solns ->
if (current_solns == new_solns) then
- returnTc dfuns
+ returnM dfuns
else
iterateDeriv (n+1) new_solns
------------------------------------------------------------------
gen_soln (_, clas, tc,tyvars,deriv_rhs)
- = tcAddSrcLoc (getSrcLoc tc) $
- tcAddErrCtxt (derivCtxt (Just clas) tc) $
- tcSimplifyDeriv tyvars deriv_rhs `thenTc` \ theta ->
- returnTc (sortLt (<) theta) -- Canonicalise before returning the soluction
+ = addSrcLoc (getSrcLoc tc) $
+ addErrCtxt (derivCtxt (Just clas) tc) $
+ tcSimplifyDeriv tyvars deriv_rhs `thenM` \ theta ->
+ returnM (sortLt (<) theta) -- Canonicalise before returning the soluction
\end{code}
\begin{code}
-- Generate the method bindings for the required instance
-- (paired with class name, as we need that when renaming
-- the method binds)
-gen_bind :: FixityEnv -> DFunId -> (Name, RdrNameMonoBinds)
-gen_bind get_fixity dfun
- = (cls_nm, binds)
+gen_bind :: DFunId -> TcM (Name, RdrNameMonoBinds)
+gen_bind dfun
+ = getFixityEnv `thenM` \ fix_env ->
+ returnM (cls_nm, gen_binds_fn fix_env cls_nm tycon)
where
cls_nm = className clas
(clas, tycon) = simpleDFunClassTyCon dfun
- binds = assoc "gen_bind:bad derived class" gen_list
- (nameUnique cls_nm) tycon
-
+gen_binds_fn fix_env cls_nm
+ = assoc "gen_bind:bad derived class"
+ gen_list (nameUnique cls_nm)
+ where
gen_list = [(eqClassKey, gen_Eq_binds)
,(ordClassKey, gen_Ord_binds)
,(enumClassKey, gen_Enum_binds)
,(boundedClassKey, gen_Bounded_binds)
,(ixClassKey, gen_Ix_binds)
- ,(showClassKey, gen_Show_binds get_fixity)
- ,(readClassKey, gen_Read_binds get_fixity)
+ ,(showClassKey, gen_Show_binds fix_env)
+ ,(readClassKey, gen_Read_binds fix_env)
]
\end{code}
TagThingWanted)]
gen_taggery_Names dfuns
- = foldlTc do_con2tag [] tycons_of_interest `thenTc` \ names_so_far ->
- foldlTc do_tag2con names_so_far tycons_of_interest
+ = foldlM do_con2tag [] tycons_of_interest `thenM` \ names_so_far ->
+ foldlM do_tag2con names_so_far tycons_of_interest
where
all_CTs = map simpleDFunClassTyCon dfuns
all_tycons = map snd all_CTs
|| (we_are_deriving enumClassKey tycon)
|| (we_are_deriving ixClassKey tycon))
- = returnTc ((con2tag_RDR tycon, tycon, GenCon2Tag)
+ = returnM ((con2tag_RDR tycon, tycon, GenCon2Tag)
: acc_Names)
| otherwise
- = returnTc acc_Names
+ = returnM acc_Names
do_tag2con acc_Names tycon
| isDataTyCon tycon &&
(we_are_deriving enumClassKey tycon ||
we_are_deriving ixClassKey tycon
&& isEnumerationTyCon tycon)
- = returnTc ( (tag2con_RDR tycon, tycon, GenTag2Con)
+ = returnM ( (tag2con_RDR tycon, tycon, GenTag2Con)
: (maxtag_RDR tycon, tycon, GenMaxTag)
: acc_Names)
| otherwise
- = returnTc acc_Names
+ = returnM acc_Names
we_are_deriving clas_key tycon
= is_in_eqns clas_key tycon all_CTs
+++ /dev/null
-_interface_ TcEnv 1
-_exports_
-TcEnv TcEnv;
-_declarations_
-1 data TcEnv;
+++ /dev/null
-__interface TcEnv 1 0 where
-__export TcEnv TcEnv;
-1 data TcEnv ;
+++ /dev/null
-module TcEnv where
-
-data TcEnv
\begin{code}
module TcEnv(
- TcId, TcIdSet,
- TyThing(..), TyThingDetails(..), TcTyThing(..),
+ TyThing(..), TyThingDetails(..), TcTyThing(..), TcId,
- -- Getting stuff from the environment
- TcEnv, initTcEnv,
- tcEnvTyCons, tcEnvClasses, tcEnvIds, tcLEnvElts,
- getTcGEnv,
-
-- Instance environment, and InstInfo type
tcGetInstEnv, tcSetInstEnv,
- InstInfo(..), pprInstInfo,
+ InstInfo(..), pprInstInfo, pprInstInfoDetails,
simpleInstInfoTy, simpleInstInfoTyCon,
-- Global environment
- tcExtendGlobalEnv, tcExtendGlobalValEnv, tcExtendGlobalTypeEnv,
- tcLookupTyCon, tcLookupClass, tcLookupGlobalId, tcLookupDataCon,
- tcLookupGlobal_maybe, tcLookupGlobal,
+ tcExtendGlobalEnv,
+ tcExtendGlobalValEnv,
+ tcExtendGlobalTypeEnv,
+ tcLookupTyCon, tcLookupClass, tcLookupDataCon,
+ tcLookupGlobal_maybe, tcLookupGlobal, tcLookupGlobalId,
+ getInGlobalScope,
-- Local environment
- tcExtendKindEnv, tcInLocalScope,
+ tcExtendKindEnv,
tcExtendTyVarEnv, tcExtendTyVarEnv2,
tcExtendLocalValEnv, tcExtendLocalValEnv2,
- tcLookup, tcLookupLocalIds, tcLookup_maybe, tcLookupId,
+ tcLookup, tcLookupLocalIds, tcLookup_maybe,
+ tcLookupId, tcLookupIdLvl,
+ getLclEnvElts, getInLocalScope,
+
+ -- Instance environment
+ tcExtendLocalInstEnv, tcExtendInstEnv,
+
+ -- Rules
+ tcExtendRules,
-- Global type variables
tcGetGlobalTyVars,
-- Random useful things
- RecTcEnv, tcLookupRecId, tcLookupRecId_maybe,
+ RecTcGblEnv, tcLookupRecId_maybe,
+
+ -- Template Haskell stuff
+ wellStaged, spliceOK, bracketOK, tcMetaTy, metaLevel,
-- New Ids
newLocalName, newDFunName,
-- Misc
- isLocalThing, tcSetEnv
+ isLocalThing
) where
#include "HsVersions.h"
import RnHsSyn ( RenamedMonoBinds, RenamedSig )
-import TcMonad
+import HsSyn ( RuleDecl(..), ifaceRuleDeclName )
+import TcRnMonad
import TcMType ( zonkTcTyVarsAndFV )
import TcType ( Type, ThetaType, TcKind, TcTyVar, TcTyVarSet,
- tyVarsOfTypes, tcSplitDFunTy,
- getDFunTyKey, tcTyConAppTyCon
+ tyVarsOfTypes, tcSplitDFunTy, mkGenTyConApp,
+ getDFunTyKey, tcTyConAppTyCon,
)
+import Rules ( extendRuleBase )
import Id ( idName, isDataConWrapId_maybe )
import Var ( TyVar, Id, idType )
import VarSet
+import CoreSyn ( IdCoreRule )
import DataCon ( DataCon )
import TyCon ( TyCon, DataConDetails )
import Class ( Class, ClassOpItem )
import Name ( Name, NamedThing(..),
- getSrcLoc, mkInternalName, isInternalName, nameIsLocalOrFrom
+ getSrcLoc, mkInternalName, nameIsLocalOrFrom
)
-import NameEnv ( NameEnv, lookupNameEnv, nameEnvElts, elemNameEnv,
- extendNameEnvList, emptyNameEnv, plusNameEnv )
+import NameEnv
import OccName ( mkDFunOcc, occNameString )
-import HscTypes ( DFunId,
- PackageTypeEnv, TypeEnv,
- extendTypeEnvList, extendTypeEnvWithIds,
- typeEnvTyCons, typeEnvClasses, typeEnvIds,
- HomeSymbolTable
- )
+import HscTypes ( DFunId, TypeEnv, extendTypeEnvList,
+ TyThing(..), ExternalPackageState(..) )
+import Rules ( RuleBase )
+import BasicTypes ( EP )
import Module ( Module )
-import InstEnv ( InstEnv, emptyInstEnv )
-import HscTypes ( lookupType, TyThing(..) )
+import InstEnv ( InstEnv, extendInstEnv )
+import Maybes ( seqMaybe )
import SrcLoc ( SrcLoc )
import Outputable
-
-import DATA_IOREF ( newIORef )
+import Maybe ( isJust )
+import List ( partition )
\end{code}
+
%************************************************************************
%* *
-\subsection{TcEnv}
+ Meta level
%* *
%************************************************************************
\begin{code}
-type TcId = Id -- Type may be a TcType
-type TcIdSet = IdSet
-
-data TcEnv
- = TcEnv {
- tcGST :: Name -> Maybe TyThing, -- The type environment at the moment we began this compilation
-
- tcInsts :: InstEnv, -- All instances (both imported and in this module)
-
- tcGEnv :: TypeEnv, -- The global type environment we've accumulated while
- {- NameEnv TyThing-} -- compiling this module:
- -- types and classes (both imported and local)
- -- imported Ids
- -- (Ids defined in this module start in the local envt,
- -- though they move to the global envt during zonking)
-
- tcLEnv :: NameEnv TcTyThing, -- The local type environment: Ids and TyVars
- -- defined in this module
-
- tcTyVars :: TcRef TcTyVarSet -- The "global tyvars"
- -- Namely, the in-scope TyVars bound in tcLEnv, plus the tyvars
- -- mentioned in the types of Ids bound in tcLEnv
- -- Why mutable? see notes with tcGetGlobalTyVars
- }
-
+instance Outputable Stage where
+ ppr Comp = text "Comp"
+ ppr (Brack l _ _) = text "Brack" <+> int l
+ ppr (Splice l) = text "Splice" <+> int l
+
+
+metaLevel :: Stage -> Level
+metaLevel Comp = topLevel
+metaLevel (Splice l) = l
+metaLevel (Brack l _ _) = l
+
+wellStaged :: Level -- Binding level
+ -> Level -- Use level
+ -> Bool
+wellStaged bind_stage use_stage
+ = bind_stage <= use_stage
+
+-- Indicates the legal transitions on bracket( [| |] ).
+bracketOK :: Stage -> Maybe Level
+bracketOK (Brack _ _ _) = Nothing -- Bracket illegal inside a bracket
+bracketOK stage = (Just (metaLevel stage + 1))
+
+-- Indicates the legal transitions on splice($).
+spliceOK :: Stage -> Maybe Level
+spliceOK (Splice _) = Nothing -- Splice illegal inside splice
+spliceOK stage = Just (metaLevel stage - 1)
+
+tcMetaTy :: Name -> TcM Type
+-- Given the name of a Template Haskell data type,
+-- return the type
+-- E.g. given the name "Expr" return the type "Expr"
+tcMetaTy tc_name
+ = tcLookupTyCon tc_name `thenM` \ t ->
+ returnM (mkGenTyConApp t [])
+ -- Use mkGenTyConApp because it might be a synonym
\end{code}
-The Global-Env/Local-Env story
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-During type checking, we keep in the GlobalEnv
- * All types and classes
- * All Ids derived from types and classes (constructors, selectors)
- * Imported Ids
-
-At the end of type checking, we zonk the local bindings,
-and as we do so we add to the GlobalEnv
- * Locally defined top-level Ids
-
-Why? Because they are now Ids not TcIds. This final GlobalEnv is
-used thus:
- a) fed back (via the knot) to typechecking the
- unfoldings of interface signatures
-
- b) used to augment the GlobalSymbolTable
-
-
-\begin{code}
-initTcEnv :: HomeSymbolTable -> PackageTypeEnv -> IO TcEnv
-initTcEnv hst pte
- = do { gtv_var <- newIORef emptyVarSet ;
- return (TcEnv { tcGST = lookup,
- tcGEnv = emptyNameEnv,
- tcInsts = emptyInstEnv,
- tcLEnv = emptyNameEnv,
- tcTyVars = gtv_var
- })}
- where
- lookup name | isInternalName name = Nothing
- | otherwise = lookupType hst pte name
-
-tcEnvClasses env = typeEnvClasses (tcGEnv env)
-tcEnvTyCons env = typeEnvTyCons (tcGEnv env)
-tcEnvIds env = typeEnvIds (tcGEnv env)
-tcLEnvElts env = nameEnvElts (tcLEnv env)
-
-getTcGEnv (TcEnv { tcGEnv = genv }) = genv
-
-tcInLocalScope :: TcEnv -> Name -> Bool
-tcInLocalScope env v = v `elemNameEnv` (tcLEnv env)
-\end{code}
-
-\begin{code}
-data TcTyThing
- = AGlobal TyThing -- Used only in the return type of a lookup
- | ATcId TcId -- Ids defined in this module
- | ATyVar TyVar -- Type variables
- | AThing TcKind -- Used temporarily, during kind checking
--- Here's an example of how the AThing guy is used
--- Suppose we are checking (forall a. T a Int):
--- 1. We first bind (a -> AThink kv), where kv is a kind variable.
--- 2. Then we kind-check the (T a Int) part.
--- 3. Then we zonk the kind variable.
--- 4. Now we know the kind for 'a', and we add (a -> ATyVar a::K) to the environment
-
-\end{code}
+%************************************************************************
+%* *
+\subsection{TyThingDetails}
+%* *
+%************************************************************************
This data type is used to help tie the knot
when type checking type and class declarations
\begin{code}
-data TyThingDetails = SynTyDetails Type
- | DataTyDetails ThetaType (DataConDetails DataCon) [Id]
- | ClassDetails ThetaType [Id] [ClassOpItem] DataCon
+data TyThingDetails = SynTyDetails Type
+ | DataTyDetails ThetaType (DataConDetails DataCon) [Id] (Maybe (EP Id))
+ | ClassDetails ThetaType [Id] [ClassOpItem] DataCon Name
+ -- The Name is the Name of the implicit TyCon for the class
| ForeignTyDetails -- Nothing yet
\end{code}
+
%************************************************************************
%* *
\subsection{Basic lookups}
%************************************************************************
\begin{code}
-lookup_global :: TcEnv -> Name -> Maybe TyThing
- -- Try the global envt and then the global symbol table
-lookup_global env name
- = case lookupNameEnv (tcGEnv env) name of
- Just thing -> Just thing
- Nothing -> tcGST env name
-
-lookup_local :: TcEnv -> Name -> Maybe TcTyThing
- -- Try the local envt and then try the global
-lookup_local env name
- = case lookupNameEnv (tcLEnv env) name of
- Just thing -> Just thing
- Nothing -> case lookup_global env name of
- Just thing -> Just (AGlobal thing)
- Nothing -> Nothing
-\end{code}
-
-\begin{code}
-type RecTcEnv = TcEnv
+type RecTcGblEnv = TcGblEnv
-- This environment is used for getting the 'right' IdInfo
-- on imported things and for looking up Ids in unfoldings
-- The environment doesn't have any local Ids in it
-tcLookupRecId_maybe :: RecTcEnv -> Name -> Maybe Id
+tcLookupRecId_maybe :: RecTcGblEnv -> Name -> Maybe Id
tcLookupRecId_maybe env name = case lookup_global env name of
Just (AnId id) -> Just id
other -> Nothing
-
-tcLookupRecId :: RecTcEnv -> Name -> Id
-tcLookupRecId env name = case lookup_global env name of
- Just (AnId id) -> id
- Nothing -> pprPanic "tcLookupRecId" (ppr name)
\end{code}
%************************************************************************
Constructing new Ids
\begin{code}
-newLocalName :: Name -> NF_TcM Name
+newLocalName :: Name -> TcM Name
newLocalName name -- Make a clone
- = tcGetUnique `thenNF_Tc` \ uniq ->
- returnNF_Tc (mkInternalName uniq (getOccName name) (getSrcLoc name))
+ = newUnique `thenM` \ uniq ->
+ returnM (mkInternalName uniq (getOccName name) (getSrcLoc name))
\end{code}
Make a name for the dict fun for an instance decl.
will externalise it.
\begin{code}
-newDFunName :: Class -> [Type] -> SrcLoc -> NF_TcM Name
+newDFunName :: Class -> [Type] -> SrcLoc -> TcM Name
newDFunName clas (ty:_) loc
- = tcGetUnique `thenNF_Tc` \ uniq ->
- returnNF_Tc (mkInternalName uniq (mkDFunOcc dfun_string) loc)
+ = newUnique `thenM` \ uniq ->
+ returnM (mkInternalName uniq (mkDFunOcc dfun_string) loc)
where
-- Any string that is somewhat unique will do
dfun_string = occNameString (getOccName clas) ++ occNameString (getDFunTyKey ty)
\begin{code}
tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r
+ -- Given a mixture of Ids, TyCons, Classes, perhaps from the
+ -- module being compiled, perhaps from a package module,
+ -- extend the global environment, and update the EPS
tcExtendGlobalEnv things thing_inside
- = tcGetEnv `thenNF_Tc` \ env ->
- let
- ge' = extendTypeEnvList (tcGEnv env) things
- in
- tcSetEnv (env {tcGEnv = ge'}) thing_inside
+ = do { eps <- getEps
+ ; hpt <- getHpt
+ ; env <- getGblEnv
+ ; let mod = tcg_mod env
+ (lcl_things, pkg_things) = partition (isLocalThing mod) things
+ ge' = extendTypeEnvList (tcg_type_env env) lcl_things
+ eps' = eps { eps_PTE = extendTypeEnvList (eps_PTE eps) pkg_things }
+ ist' = mkImpTypeEnv eps' hpt
+ ; setEps eps'
+ ; setGblEnv (env {tcg_type_env = ge', tcg_ist = ist'}) thing_inside }
+tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
+ -- Same deal as tcExtendGlobalEnv, but for Ids
+tcExtendGlobalValEnv ids thing_inside
+ = tcExtendGlobalEnv [AnId id | id <- ids] thing_inside
tcExtendGlobalTypeEnv :: TypeEnv -> TcM r -> TcM r
+ -- Top-level things of the interactive context
+ -- No need to extend the package env
tcExtendGlobalTypeEnv extra_env thing_inside
- = tcGetEnv `thenNF_Tc` \ env ->
- let
- ge' = tcGEnv env `plusNameEnv` extra_env
- in
- tcSetEnv (env {tcGEnv = ge'}) thing_inside
-
-tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
-tcExtendGlobalValEnv ids thing_inside
- = tcGetEnv `thenNF_Tc` \ env ->
- let
- ge' = extendTypeEnvWithIds (tcGEnv env) ids
- in
- tcSetEnv (env {tcGEnv = ge'}) thing_inside
+ = do { env <- getGblEnv
+ ; let ge' = tcg_type_env env `plusNameEnv` extra_env
+ ; setGblEnv (env {tcg_type_env = ge'}) thing_inside }
\end{code}
\begin{code}
-tcLookupGlobal_maybe :: Name -> NF_TcM (Maybe TyThing)
+lookup_global :: TcGblEnv -> Name -> Maybe TyThing
+ -- Try the global envt and then the global symbol table
+lookup_global env name
+ = lookupNameEnv (tcg_type_env env) name
+ `seqMaybe`
+ tcg_ist env name
+
+tcLookupGlobal_maybe :: Name -> TcRn m (Maybe TyThing)
tcLookupGlobal_maybe name
- = tcGetEnv `thenNF_Tc` \ env ->
- returnNF_Tc (lookup_global env name)
+ = getGblEnv `thenM` \ env ->
+ returnM (lookup_global env name)
\end{code}
A variety of global lookups, when we know what we are looking for.
\begin{code}
-tcLookupGlobal :: Name -> NF_TcM TyThing
+tcLookupGlobal :: Name -> TcM TyThing
tcLookupGlobal name
- = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_thing ->
+ = tcLookupGlobal_maybe name `thenM` \ maybe_thing ->
case maybe_thing of
- Just thing -> returnNF_Tc thing
+ Just thing -> returnM thing
other -> notFound "tcLookupGlobal" name
-tcLookupGlobalId :: Name -> NF_TcM Id
+tcLookupGlobalId :: Name -> TcM Id
tcLookupGlobalId name
- = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_id ->
- case maybe_id of
- Just (AnId id) -> returnNF_Tc id
- other -> notFound "tcLookupGlobalId" name
-
+ = tcLookupGlobal_maybe name `thenM` \ maybe_thing ->
+ case maybe_thing of
+ Just (AnId id) -> returnM id
+ other -> notFound "tcLookupGlobal" name
+
tcLookupDataCon :: Name -> TcM DataCon
tcLookupDataCon con_name
- = tcLookupGlobalId con_name `thenNF_Tc` \ con_id ->
+ = tcLookupGlobalId con_name `thenM` \ con_id ->
case isDataConWrapId_maybe con_id of
- Just data_con -> returnTc data_con
+ Just data_con -> returnM data_con
Nothing -> failWithTc (badCon con_id)
-
-tcLookupClass :: Name -> NF_TcM Class
+tcLookupClass :: Name -> TcM Class
tcLookupClass name
- = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_clas ->
+ = tcLookupGlobal_maybe name `thenM` \ maybe_clas ->
case maybe_clas of
- Just (AClass clas) -> returnNF_Tc clas
+ Just (AClass clas) -> returnM clas
other -> notFound "tcLookupClass" name
-tcLookupTyCon :: Name -> NF_TcM TyCon
+tcLookupTyCon :: Name -> TcM TyCon
tcLookupTyCon name
- = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_tc ->
+ = tcLookupGlobal_maybe name `thenM` \ maybe_tc ->
case maybe_tc of
- Just (ATyCon tc) -> returnNF_Tc tc
+ Just (ATyCon tc) -> returnM tc
other -> notFound "tcLookupTyCon" name
-tcLookupId :: Name -> NF_TcM Id
-tcLookupId name
- = tcLookup name `thenNF_Tc` \ thing ->
- case thing of
- ATcId tc_id -> returnNF_Tc tc_id
- AGlobal (AnId id) -> returnNF_Tc id
- other -> pprPanic "tcLookupId" (ppr name)
-tcLookupLocalIds :: [Name] -> NF_TcM [TcId]
-tcLookupLocalIds ns
- = tcGetEnv `thenNF_Tc` \ env ->
- returnNF_Tc (map (lookup (tcLEnv env)) ns)
- where
- lookup lenv name = case lookupNameEnv lenv name of
- Just (ATcId id) -> id
- other -> pprPanic "tcLookupLocalIds" (ppr name)
+getInGlobalScope :: TcRn m (Name -> Bool)
+getInGlobalScope = do { gbl_env <- getGblEnv ;
+ return (\n -> isJust (lookup_global gbl_env n)) }
\end{code}
%************************************************************************
\begin{code}
-tcLookup_maybe :: Name -> NF_TcM (Maybe TcTyThing)
+tcLookup_maybe :: Name -> TcM (Maybe TcTyThing)
tcLookup_maybe name
- = tcGetEnv `thenNF_Tc` \ env ->
- returnNF_Tc (lookup_local env name)
-
-tcLookup :: Name -> NF_TcM TcTyThing
+ = getLclEnv `thenM` \ local_env ->
+ case lookupNameEnv (tcl_env local_env) name of
+ Just thing -> returnM (Just thing)
+ Nothing -> tcLookupGlobal_maybe name `thenM` \ mb_res ->
+ returnM (case mb_res of
+ Just thing -> Just (AGlobal thing)
+ Nothing -> Nothing)
+
+tcLookup :: Name -> TcM TcTyThing
tcLookup name
- = tcLookup_maybe name `thenNF_Tc` \ maybe_thing ->
+ = tcLookup_maybe name `thenM` \ maybe_thing ->
case maybe_thing of
- Just thing -> returnNF_Tc thing
+ Just thing -> returnM thing
other -> notFound "tcLookup" name
-- Extract the IdInfo from an IfaceSig imported from an interface file
-\end{code}
+tcLookupId :: Name -> TcM Id
+-- Used when we aren't interested in the binding level
+tcLookupId name
+ = tcLookup name `thenM` \ thing ->
+ case thing of
+ ATcId tc_id lvl -> returnM tc_id
+ AGlobal (AnId id) -> returnM id
+ other -> pprPanic "tcLookupId" (ppr name)
+
+tcLookupIdLvl :: Name -> TcM (Id, Level)
+tcLookupIdLvl name
+ = tcLookup name `thenM` \ thing ->
+ case thing of
+ ATcId tc_id lvl -> returnM (tc_id, lvl)
+ AGlobal (AnId id) -> returnM (id, impLevel)
+ other -> pprPanic "tcLookupIdLvl" (ppr name)
+
+tcLookupLocalIds :: [Name] -> TcM [TcId]
+-- We expect the variables to all be bound, and all at
+-- the same level as the lookup. Only used in one place...
+tcLookupLocalIds ns
+ = getLclEnv `thenM` \ env ->
+ returnM (map (lookup (tcl_env env) (metaLevel (tcl_level env))) ns)
+ where
+ lookup lenv lvl name
+ = case lookupNameEnv lenv name of
+ Just (ATcId id lvl1) -> ASSERT( lvl == lvl1 ) id
+ other -> pprPanic "tcLookupLocalIds" (ppr name)
+
+getLclEnvElts :: TcM [TcTyThing]
+getLclEnvElts = getLclEnv `thenM` \ env ->
+ return (nameEnvElts (tcl_env env))
+
+getInLocalScope :: TcM (Name -> Bool)
+ -- Ids only
+getInLocalScope = getLclEnv `thenM` \ env ->
+ let
+ lcl_env = tcl_env env
+ in
+ return (`elemNameEnv` lcl_env)
+\end{code}
\begin{code}
tcExtendKindEnv :: [(Name,TcKind)] -> TcM r -> TcM r
tcExtendKindEnv pairs thing_inside
- = tcGetEnv `thenNF_Tc` \ env ->
- let
- le' = extendNameEnvList (tcLEnv env) [(n, AThing k) | (n,k) <- pairs]
+ = updLclEnv upd thing_inside
+ where
+ upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) }
+ extend env = extendNameEnvList env [(n, AThing k) | (n,k) <- pairs]
-- No need to extend global tyvars for kind checking
- in
- tcSetEnv (env {tcLEnv = le'}) thing_inside
tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
tcExtendTyVarEnv tvs thing_inside
thing_inside
tc_extend_tv_env binds tyvars thing_inside
- = tcGetEnv `thenNF_Tc` \ env@(TcEnv {tcLEnv = le, tcTyVars = gtvs}) ->
+ = getLclEnv `thenM` \ env@(TcLclEnv {tcl_env = le, tcl_tyvars = gtvs}) ->
let
le' = extendNameEnvList le binds
new_tv_set = mkVarSet tyvars
-- 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 (env {tcLEnv = le', tcTyVars = gtvs'}) thing_inside
+ tc_extend_gtvs gtvs new_tv_set `thenM` \ gtvs' ->
+ setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs'}) thing_inside
\end{code}
\begin{code}
tcExtendLocalValEnv :: [TcId] -> TcM a -> TcM a
tcExtendLocalValEnv ids thing_inside
- = tcGetEnv `thenNF_Tc` \ env ->
+ = getLclEnv `thenM` \ env ->
let
extra_global_tyvars = tyVarsOfTypes [idType id | id <- ids]
- extra_env = [(idName id, ATcId id) | id <- ids]
- le' = extendNameEnvList (tcLEnv env) extra_env
+ lvl = metaLevel (tcl_level env)
+ extra_env = [(idName id, ATcId id lvl) | id <- ids]
+ le' = extendNameEnvList (tcl_env env) extra_env
in
- tc_extend_gtvs (tcTyVars env) extra_global_tyvars `thenNF_Tc` \ gtvs' ->
- tcSetEnv (env {tcLEnv = le', tcTyVars = gtvs'}) thing_inside
+ tc_extend_gtvs (tcl_tyvars env) extra_global_tyvars `thenM` \ gtvs' ->
+ setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs'}) thing_inside
tcExtendLocalValEnv2 :: [(Name,TcId)] -> TcM a -> TcM a
tcExtendLocalValEnv2 names_w_ids thing_inside
- = tcGetEnv `thenNF_Tc` \ env ->
+ = getLclEnv `thenM` \ env ->
let
extra_global_tyvars = tyVarsOfTypes [idType id | (name,id) <- names_w_ids]
- extra_env = [(name, ATcId id) | (name,id) <- names_w_ids]
- le' = extendNameEnvList (tcLEnv env) extra_env
+ lvl = metaLevel (tcl_level env)
+ extra_env = [(name, ATcId id lvl) | (name,id) <- names_w_ids]
+ le' = extendNameEnvList (tcl_env env) extra_env
in
- tc_extend_gtvs (tcTyVars env) extra_global_tyvars `thenNF_Tc` \ gtvs' ->
- tcSetEnv (env {tcLEnv = le', tcTyVars = gtvs'}) thing_inside
+ tc_extend_gtvs (tcl_tyvars env) extra_global_tyvars `thenM` \ gtvs' ->
+ setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs'}) thing_inside
\end{code}
\begin{code}
tc_extend_gtvs gtvs extra_global_tvs
- = tcReadMutVar gtvs `thenNF_Tc` \ global_tvs ->
- tcNewMutVar (global_tvs `unionVarSet` extra_global_tvs)
+ = readMutVar gtvs `thenM` \ global_tvs ->
+ newMutVar (global_tvs `unionVarSet` extra_global_tvs)
\end{code}
@tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
the environment.
\begin{code}
-tcGetGlobalTyVars :: NF_TcM TcTyVarSet
+tcGetGlobalTyVars :: TcM TcTyVarSet
tcGetGlobalTyVars
- = tcGetEnv `thenNF_Tc` \ (TcEnv {tcTyVars = gtv_var}) ->
- tcReadMutVar gtv_var `thenNF_Tc` \ gbl_tvs ->
- zonkTcTyVarsAndFV (varSetElems gbl_tvs) `thenNF_Tc` \ gbl_tvs' ->
- tcWriteMutVar gtv_var gbl_tvs' `thenNF_Tc_`
- returnNF_Tc gbl_tvs'
+ = getLclEnv `thenM` \ (TcLclEnv {tcl_tyvars = gtv_var}) ->
+ readMutVar gtv_var `thenM` \ gbl_tvs ->
+ zonkTcTyVarsAndFV (varSetElems gbl_tvs) `thenM` \ gbl_tvs' ->
+ writeMutVar gtv_var gbl_tvs' `thenM_`
+ returnM gbl_tvs'
\end{code}
%************************************************************************
\begin{code}
-tcGetInstEnv :: NF_TcM InstEnv
-tcGetInstEnv = tcGetEnv `thenNF_Tc` \ env ->
- returnNF_Tc (tcInsts env)
+tcGetInstEnv :: TcM InstEnv
+tcGetInstEnv = getGblEnv `thenM` \ env ->
+ returnM (tcg_inst_env env)
tcSetInstEnv :: InstEnv -> TcM a -> TcM a
tcSetInstEnv ie thing_inside
- = tcGetEnv `thenNF_Tc` \ env ->
- tcSetEnv (env {tcInsts = ie}) thing_inside
-\end{code}
+ = getGblEnv `thenM` \ env ->
+ setGblEnv (env {tcg_inst_env = ie}) thing_inside
+
+tcExtendInstEnv :: [DFunId] -> TcM a -> TcM a
+ -- Add instances from local or imported
+ -- instances, and refresh the instance-env cache
+tcExtendInstEnv dfuns thing_inside
+ = do { dflags <- getDOpts
+ ; eps <- getEps
+ ; env <- getGblEnv
+ ; let
+ -- Extend the total inst-env with the new dfuns
+ (inst_env', errs) = extendInstEnv dflags (tcg_inst_env env) dfuns
+
+ -- Sort the ones from this module from the others
+ (lcl_dfuns, pkg_dfuns) = partition (isLocalThing mod) dfuns
+ mod = tcg_mod env
+
+ -- And add the pieces to the right places
+ (eps_inst_env', _) = extendInstEnv dflags (eps_inst_env eps) pkg_dfuns
+ eps' = eps { eps_inst_env = eps_inst_env' }
+
+ env' = env { tcg_inst_env = inst_env',
+ tcg_insts = lcl_dfuns ++ tcg_insts env }
+
+ ; traceDFuns dfuns
+ ; addErrs errs
+ ; setEps eps'
+ ; setGblEnv env' thing_inside }
+
+tcExtendLocalInstEnv :: [InstInfo] -> TcM a -> TcM a
+ -- Special case for local instance decls
+tcExtendLocalInstEnv infos thing_inside
+ = do { dflags <- getDOpts
+ ; env <- getGblEnv
+ ; let
+ dfuns = map iDFunId infos
+ (inst_env', errs) = extendInstEnv dflags (tcg_inst_env env) dfuns
+ env' = env { tcg_inst_env = inst_env',
+ tcg_insts = dfuns ++ tcg_insts env }
+ ; traceDFuns dfuns
+ ; addErrs errs
+ ; setGblEnv env' thing_inside }
+
+traceDFuns dfuns
+ = traceTc (text "Adding instances:" <+> vcat (map pp dfuns))
+ where
+ pp dfun = ppr dfun <+> dcolon <+> ppr (idType dfun)
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Rules}
+%* *
+%************************************************************************
+
+\begin{code}
+tcExtendRules :: [RuleDecl Id] -> TcM a -> TcM a
+ -- Just pop the new rules into the EPS and envt resp
+ -- All the rules come from an interface file, not soruce
+ -- Nevertheless, some may be for this module, if we read
+ -- its interface instead of its source code
+tcExtendRules rules thing_inside
+ = do { eps <- getEps
+ ; env <- getGblEnv
+ ; let
+ (lcl_rules, pkg_rules) = partition is_local_rule rules
+ is_local_rule = isLocalThing mod . ifaceRuleDeclName
+ mod = tcg_mod env
+
+ core_rules = [(id,rule) | IfaceRuleOut id rule <- pkg_rules]
+ eps' = eps { eps_rule_base = addIfaceRules (eps_rule_base eps) core_rules }
+ -- All the rules from an interface are of the IfaceRuleOut form
+
+ env' = env { tcg_rules = lcl_rules ++ tcg_rules env }
+
+ ; setEps eps'
+ ; setGblEnv env' thing_inside }
+
+addIfaceRules :: RuleBase -> [IdCoreRule] -> RuleBase
+addIfaceRules rule_base rules
+ = foldl extendRuleBase rule_base rules
+\end{code}
%************************************************************************
}
pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info))]
+pprInstInfoDetails (InstInfo { iBinds = b }) = ppr b
+pprInstInfoDetails (NewTypeDerived _) = text "Derived from the represenation type"
simpleInstInfoTy :: InstInfo -> Type
simpleInstInfoTy info = case tcSplitDFunTy (idType (iDFunId info)) of
1 tcExpr _:_ _forall_ [s] =>
RnHsSyn.RenamedHsExpr
-> TcType.TcType
- -> TcMonad.TcM s (TcHsSyn.TcExpr, Inst.LIE) ;;
+ -> TcMonad.TcM s (TcHsSyn.TcExpr, TcMonad.LIE) ;;
1 tcMonoExpr _:_ _forall_ [s] =>
RnHsSyn.RenamedHsExpr
-> TcType.TcType
- -> TcMonad.TcM s (TcHsSyn.TcExpr, Inst.LIE) ;;
+ -> TcMonad.TcM s (TcHsSyn.TcExpr, TcMonad.LIE) ;;
1 tcExpr ::
RnHsSyn.RenamedHsExpr
-> TcType.TcType
- -> TcMonad.TcM (TcHsSyn.TcExpr, Inst.LIE) ;
+ -> TcRnTypes.TcM TcHsSyn.TcExpr ;
1 tcMonoExpr ::
RnHsSyn.RenamedHsExpr
-> TcType.TcType
- -> TcMonad.TcM (TcHsSyn.TcExpr, Inst.LIE) ;
+ -> TcRnTypes.TcM TcHsSyn.TcExpr ;
tcExpr ::
RnHsSyn.RenamedHsExpr
-> TcType.TcType
- -> TcMonad.TcM (TcHsSyn.TcExpr, Inst.LIE)
+ -> TcRnTypes.TcM TcHsSyn.TcExpr
tcMonoExpr ::
RnHsSyn.RenamedHsExpr
-> TcType.TcType
- -> TcMonad.TcM (TcHsSyn.TcExpr, Inst.LIE)
+ -> TcRnTypes.TcM TcHsSyn.TcExpr
\section[TcExpr]{Typecheck an expression}
\begin{code}
-module TcExpr ( tcExpr, tcMonoExpr, tcId ) where
+module TcExpr ( tcExpr, tcExpr_id, tcMonoExpr ) where
#include "HsVersions.h"
+#ifdef GHCI /* Only if bootstrapped */
+import {-# SOURCE #-} TcSplice( tcSpliceExpr )
+import TcEnv ( bracketOK, tcMetaTy )
+import TcSimplify ( tcSimplifyBracket )
+import PrelNames ( exprTyConName )
+import HsSyn ( HsBracket(..) )
+#endif
+
import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..),
- HsMatchContext(..), HsDoContext(..), MonoBinds(..),
- mkMonoBind, andMonoBindList
+ mkMonoBind, recBindFields
)
import RnHsSyn ( RenamedHsExpr, RenamedRecordBinds )
-import TcHsSyn ( TcExpr, TcRecordBinds, TypecheckedMonoBinds,
- simpleHsLitTy, mkHsDictApp, mkHsTyApp, mkHsLet )
-
-import TcMonad
+import TcHsSyn ( TcExpr, TcRecordBinds, hsLitType, mkHsDictApp, mkHsTyApp, mkHsLet )
+import TcRnMonad
import TcUnify ( tcSubExp, tcGen, (<$>),
unifyTauTy, unifyFunTy, unifyListTy, unifyPArrTy,
unifyTupleTy )
import BasicTypes ( RecFlag(..), isMarkedStrict )
import Inst ( InstOrigin(..),
- LIE, mkLIE, emptyLIE, unitLIE, plusLIE, plusLIEs,
newOverloadedLit, newMethodFromName, newIPDict,
- newDicts, newMethodWithGivenTy, tcSyntaxName,
+ newDicts, newMethodWithGivenTy,
instToId, tcInstCall, tcInstDataCon
)
import TcBinds ( tcBindsAndThen )
-import TcEnv ( tcLookupClass, tcLookupGlobalId, tcLookupGlobal_maybe,
- tcLookupTyCon, tcLookupDataCon, tcLookupId
+import TcEnv ( tcLookupClass, tcLookupGlobal_maybe, tcLookupIdLvl,
+ tcLookupTyCon, tcLookupDataCon, tcLookupId,
+ wellStaged, metaLevel
)
-import TcMatches ( tcMatchesCase, tcMatchLambda, tcStmts )
+import TcMatches ( tcMatchesCase, tcMatchLambda, tcDoStmts )
import TcMonoType ( tcHsSigType, UserTypeCtxt(..) )
import TcPat ( badFieldCon )
import TcSimplify ( tcSimplifyIPs )
newTyVarTy, newTyVarTys, zonkTcType, readHoleResult )
import TcType ( TcType, TcSigmaType, TcRhoType, TyVarDetails(VanillaTv),
tcSplitFunTys, tcSplitTyConApp, mkTyVarTys,
- isSigmaTy, mkFunTy, mkAppTy, mkFunTys,
+ isSigmaTy, isTauTy, mkFunTy, mkFunTys,
mkTyConApp, mkClassPred, tcFunArgTy,
tyVarsOfTypes, isLinearPred,
- liftedTypeKind, openTypeKind, mkArrowKind,
+ liftedTypeKind, openTypeKind,
tcSplitSigmaTy, tcTyConAppTyCon,
tidyOpenType
)
import FieldLabel ( FieldLabel, fieldLabelName, fieldLabelType, fieldLabelTyCon )
-import Id ( Id, idType, recordSelectorFieldLabel, isRecordSelector,
- isDataConWrapId_maybe, mkSysLocal )
+import Id ( Id, idType, recordSelectorFieldLabel, isRecordSelector, isDataConWrapId_maybe )
import DataCon ( dataConFieldLabels, dataConSig,
dataConStrictMarks
)
-import Name ( Name )
+import Name ( Name, isExternalName )
import TyCon ( TyCon, tyConTyVars, tyConTheta, isAlgTyCon, tyConDataCons )
import Subst ( mkTopTyVarSubst, substTheta, substTy )
import VarSet ( emptyVarSet, elemVarSet )
-import TysWiredIn ( boolTy, mkListTy, mkPArrTy )
+import TysWiredIn ( boolTy )
import PrelNames ( cCallableClassName, cReturnableClassName,
enumFromName, enumFromThenName,
enumFromToName, enumFromThenToName,
enumFromToPName, enumFromThenToPName,
- ioTyConName, monadNames
+ ioTyConName, liftName
)
import ListSetOps ( minusList )
import CmdLineOpts
\begin{code}
tcExpr :: RenamedHsExpr -- Expession to type check
-> TcSigmaType -- Expected type (could be a polytpye)
- -> TcM (TcExpr, LIE) -- Generalised expr with expected type, and LIE
+ -> TcM TcExpr -- Generalised expr with expected type
tcExpr expr expected_ty
- = traceTc (text "tcExpr" <+> (ppr expected_ty $$ ppr expr)) `thenNF_Tc_`
+ = traceTc (text "tcExpr" <+> (ppr expected_ty $$ ppr expr)) `thenM_`
tc_expr' expr expected_ty
tc_expr' expr expected_ty
| otherwise
= tcGen expected_ty emptyVarSet (
tcMonoExpr expr
- ) `thenTc` \ (gen_fn, expr', lie) ->
- returnTc (gen_fn <$> expr', lie)
+ ) `thenM` \ (gen_fn, expr') ->
+ returnM (gen_fn <$> expr')
\end{code}
-> TcRhoType -- Expected type (could be a type variable)
-- Definitely no foralls at the top
-- Can be a 'hole'.
- -> TcM (TcExpr, LIE)
+ -> TcM TcExpr
tcMonoExpr (HsVar name) res_ty
- = tcId name `thenNF_Tc` \ (expr', lie1, id_ty) ->
- tcSubExp res_ty id_ty `thenTc` \ (co_fn, lie2) ->
- returnTc (co_fn <$> expr', lie1 `plusLIE` lie2)
+ = tcId name `thenM` \ (expr', id_ty) ->
+ tcSubExp res_ty id_ty `thenM` \ co_fn ->
+ returnM (co_fn <$> expr')
tcMonoExpr (HsIPVar ip) res_ty
= -- Implicit parameters must have a *tau-type* not a
-- type scheme. We enforce this by creating a fresh
-- type variable as its type. (Because res_ty may not
-- be a tau-type.)
- newTyVarTy openTypeKind `thenNF_Tc` \ ip_ty ->
- newIPDict (IPOcc ip) ip ip_ty `thenNF_Tc` \ (ip', inst) ->
- tcSubExp res_ty ip_ty `thenTc` \ (co_fn, lie) ->
- returnNF_Tc (co_fn <$> HsIPVar ip', lie `plusLIE` unitLIE inst)
+ newTyVarTy openTypeKind `thenM` \ ip_ty ->
+ newIPDict (IPOcc ip) ip ip_ty `thenM` \ (ip', inst) ->
+ extendLIE inst `thenM_`
+ tcSubExp res_ty ip_ty `thenM` \ co_fn ->
+ returnM (co_fn <$> HsIPVar ip')
\end{code}
\begin{code}
tcMonoExpr in_expr@(ExprWithTySig expr poly_ty) res_ty
- = tcAddErrCtxt (exprSigCtxt in_expr) $
- tcHsSigType ExprSigCtxt poly_ty `thenTc` \ sig_tc_ty ->
- tcExpr expr sig_tc_ty `thenTc` \ (expr', lie1) ->
+ = addErrCtxt (exprSigCtxt in_expr) $
+ tcHsSigType ExprSigCtxt poly_ty `thenM` \ sig_tc_ty ->
+ tcExpr expr sig_tc_ty `thenM` \ expr' ->
-- Must instantiate the outer for-alls of sig_tc_ty
-- else we risk instantiating a ? res_ty to a forall-type
-- which breaks the invariant that tcMonoExpr only returns phi-types
- tcInstCall SignatureOrigin sig_tc_ty `thenNF_Tc` \ (inst_fn, lie2, inst_sig_ty) ->
- tcSubExp res_ty inst_sig_ty `thenTc` \ (co_fn, lie3) ->
+ tcInstCall SignatureOrigin sig_tc_ty `thenM` \ (inst_fn, inst_sig_ty) ->
+ tcSubExp res_ty inst_sig_ty `thenM` \ co_fn ->
- returnTc (co_fn <$> inst_fn expr', lie1 `plusLIE` lie2 `plusLIE` lie3)
+ returnM (co_fn <$> inst_fn expr')
tcMonoExpr (HsType ty) res_ty
= failWithTc (text "Can't handle type argument:" <+> ppr ty)
%************************************************************************
\begin{code}
-tcMonoExpr (HsLit lit) res_ty = tcLit lit res_ty
-tcMonoExpr (HsOverLit lit) res_ty = newOverloadedLit (LiteralOrigin lit) lit res_ty
-tcMonoExpr (HsPar expr) res_ty = tcMonoExpr expr res_ty
+tcMonoExpr (HsLit lit) res_ty = tcLit lit res_ty
+tcMonoExpr (HsOverLit lit) res_ty = newOverloadedLit (LiteralOrigin lit) lit res_ty
+tcMonoExpr (HsPar expr) res_ty = tcMonoExpr expr res_ty `thenM` \ expr' ->
+ returnM (HsPar expr')
+tcMonoExpr (HsSCC lbl expr) res_ty = tcMonoExpr expr res_ty `thenM` \ expr' ->
+ returnM (HsSCC lbl expr')
+
tcMonoExpr (NegApp expr neg_name) res_ty
= tcMonoExpr (HsApp (HsVar neg_name) expr) res_ty
-- ToDo: use tcSyntaxName
tcMonoExpr (HsLam match) res_ty
- = tcMatchLambda match res_ty `thenTc` \ (match',lie) ->
- returnTc (HsLam match', lie)
+ = tcMatchLambda match res_ty `thenM` \ match' ->
+ returnM (HsLam match')
tcMonoExpr (HsApp e1 e2) res_ty
= tcApp e1 [e2] res_ty
-- op e
tcMonoExpr in_expr@(SectionL arg1 op) res_ty
- = tcExpr_id op `thenTc` \ (op', lie1, op_ty) ->
- split_fun_ty op_ty 2 {- two args -} `thenTc` \ ([arg1_ty, arg2_ty], op_res_ty) ->
- tcArg op (arg1, arg1_ty, 1) `thenTc` \ (arg1',lie2) ->
- tcAddErrCtxt (exprCtxt in_expr) $
- tcSubExp res_ty (mkFunTy arg2_ty op_res_ty) `thenTc` \ (co_fn, lie3) ->
- returnTc (co_fn <$> SectionL arg1' op', lie1 `plusLIE` lie2 `plusLIE` lie3)
+ = tcExpr_id op `thenM` \ (op', op_ty) ->
+ split_fun_ty op_ty 2 {- two args -} `thenM` \ ([arg1_ty, arg2_ty], op_res_ty) ->
+ tcArg op (arg1, arg1_ty, 1) `thenM` \ arg1' ->
+ addErrCtxt (exprCtxt in_expr) $
+ tcSubExp res_ty (mkFunTy arg2_ty op_res_ty) `thenM` \ co_fn ->
+ returnM (co_fn <$> SectionL arg1' op')
-- Right sections, equivalent to \ x -> x op expr, or
-- \ x -> op x expr
tcMonoExpr in_expr@(SectionR op arg2) res_ty
- = tcExpr_id op `thenTc` \ (op', lie1, op_ty) ->
- split_fun_ty op_ty 2 {- two args -} `thenTc` \ ([arg1_ty, arg2_ty], op_res_ty) ->
- tcArg op (arg2, arg2_ty, 2) `thenTc` \ (arg2',lie2) ->
- tcAddErrCtxt (exprCtxt in_expr) $
- tcSubExp res_ty (mkFunTy arg1_ty op_res_ty) `thenTc` \ (co_fn, lie3) ->
- returnTc (co_fn <$> SectionR op' arg2', lie1 `plusLIE` lie2 `plusLIE` lie3)
+ = tcExpr_id op `thenM` \ (op', op_ty) ->
+ split_fun_ty op_ty 2 {- two args -} `thenM` \ ([arg1_ty, arg2_ty], op_res_ty) ->
+ tcArg op (arg2, arg2_ty, 2) `thenM` \ arg2' ->
+ addErrCtxt (exprCtxt in_expr) $
+ tcSubExp res_ty (mkFunTy arg1_ty op_res_ty) `thenM` \ co_fn ->
+ returnM (co_fn <$> SectionR op' arg2')
-- equivalent to (op e1) e2:
tcMonoExpr in_expr@(OpApp arg1 op fix arg2) res_ty
- = tcExpr_id op `thenTc` \ (op', lie1, op_ty) ->
- split_fun_ty op_ty 2 {- two args -} `thenTc` \ ([arg1_ty, arg2_ty], op_res_ty) ->
- tcArg op (arg1, arg1_ty, 1) `thenTc` \ (arg1',lie2a) ->
- tcArg op (arg2, arg2_ty, 2) `thenTc` \ (arg2',lie2b) ->
- tcAddErrCtxt (exprCtxt in_expr) $
- tcSubExp res_ty op_res_ty `thenTc` \ (co_fn, lie3) ->
- returnTc (OpApp arg1' op' fix arg2',
- lie1 `plusLIE` lie2a `plusLIE` lie2b `plusLIE` lie3)
+ = tcExpr_id op `thenM` \ (op', op_ty) ->
+ split_fun_ty op_ty 2 {- two args -} `thenM` \ ([arg1_ty, arg2_ty], op_res_ty) ->
+ tcArg op (arg1, arg1_ty, 1) `thenM` \ arg1' ->
+ tcArg op (arg2, arg2_ty, 2) `thenM` \ arg2' ->
+ addErrCtxt (exprCtxt in_expr) $
+ tcSubExp res_ty op_res_ty `thenM` \ co_fn ->
+ returnM (OpApp arg1' op' fix arg2')
\end{code}
-The interesting thing about @ccall@ is that it is just a template
-which we instantiate by filling in details about the types of its
-argument and result (ie minimal typechecking is performed). So, the
-basic story is that we allocate a load of type variables (to hold the
-arg/result types); unify them with the args/result; and store them for
-later use.
-
\begin{code}
-tcMonoExpr e0@(HsCCall lbl args may_gc is_casm ignored_fake_result_ty) res_ty
-
- = getDOptsTc `thenNF_Tc` \ dflags ->
-
- checkTc (not (is_casm && dopt_HscLang dflags /= HscC))
- (vcat [text "_casm_ is only supported when compiling via C (-fvia-C).",
- text "Either compile with -fvia-C, or, better, rewrite your code",
- text "to use the foreign function interface. _casm_s are deprecated",
- text "and support for them may one day disappear."])
- `thenTc_`
-
- -- Get the callable and returnable classes.
- tcLookupClass cCallableClassName `thenNF_Tc` \ cCallableClass ->
- tcLookupClass cReturnableClassName `thenNF_Tc` \ cReturnableClass ->
- tcLookupTyCon ioTyConName `thenNF_Tc` \ ioTyCon ->
- let
- new_arg_dict (arg, arg_ty)
- = newDicts (CCallOrigin (unpackFS lbl) (Just arg))
- [mkClassPred cCallableClass [arg_ty]] `thenNF_Tc` \ arg_dicts ->
- returnNF_Tc arg_dicts -- Actually a singleton bag
-
- result_origin = CCallOrigin (unpackFS lbl) Nothing {- Not an arg -}
- in
-
- -- Arguments
- let tv_idxs | null args = []
- | otherwise = [1..length args]
- in
- newTyVarTys (length tv_idxs) openTypeKind `thenNF_Tc` \ arg_tys ->
- tcMonoExprs args arg_tys `thenTc` \ (args', args_lie) ->
-
- -- The argument types can be unlifted or lifted; the result
- -- type must, however, be lifted since it's an argument to the IO
- -- type constructor.
- newTyVarTy liftedTypeKind `thenNF_Tc` \ result_ty ->
- let
- io_result_ty = mkTyConApp ioTyCon [result_ty]
- in
- unifyTauTy res_ty io_result_ty `thenTc_`
-
- -- Construct the extra insts, which encode the
- -- constraints on the argument and result types.
- mapNF_Tc new_arg_dict (zipEqual "tcMonoExpr:CCall" args arg_tys) `thenNF_Tc` \ ccarg_dicts_s ->
- newDicts result_origin [mkClassPred cReturnableClass [result_ty]] `thenNF_Tc` \ ccres_dict ->
- returnTc (HsCCall lbl args' may_gc is_casm io_result_ty,
- mkLIE (ccres_dict ++ concat ccarg_dicts_s) `plusLIE` args_lie)
-\end{code}
-
-\begin{code}
-tcMonoExpr (HsSCC lbl expr) res_ty
- = tcMonoExpr expr res_ty `thenTc` \ (expr', lie) ->
- returnTc (HsSCC lbl expr', lie)
-
tcMonoExpr (HsLet binds expr) res_ty
= tcBindsAndThen
combiner
binds -- Bindings to check
- tc_expr `thenTc` \ (expr', lie) ->
- returnTc (expr', lie)
+ (tcMonoExpr expr res_ty)
where
- tc_expr = tcMonoExpr expr res_ty `thenTc` \ (expr', lie) ->
- returnTc (expr', lie)
combiner is_rec bind expr = HsLet (mkMonoBind bind [] is_rec) expr
tcMonoExpr in_expr@(HsCase scrut matches src_loc) res_ty
- = tcAddSrcLoc src_loc $
- tcAddErrCtxt (caseCtxt in_expr) $
+ = addSrcLoc src_loc $
+ addErrCtxt (caseCtxt in_expr) $
-- Typecheck the case alternatives first.
-- The case patterns tend to give good type info to use
-- 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 matches res_ty `thenTc` \ (scrut_ty, matches', lie2) ->
+ tcMatchesCase matches res_ty `thenM` \ (scrut_ty, matches') ->
- tcAddErrCtxt (caseScrutCtxt scrut) (
+ addErrCtxt (caseScrutCtxt scrut) (
tcMonoExpr scrut scrut_ty
- ) `thenTc` \ (scrut',lie1) ->
+ ) `thenM` \ scrut' ->
- returnTc (HsCase scrut' matches' src_loc, plusLIE lie1 lie2)
+ returnM (HsCase scrut' matches' src_loc)
tcMonoExpr (HsIf pred b1 b2 src_loc) res_ty
- = tcAddSrcLoc src_loc $
- tcAddErrCtxt (predCtxt pred) (
- tcMonoExpr pred boolTy ) `thenTc` \ (pred',lie1) ->
+ = addSrcLoc src_loc $
+ addErrCtxt (predCtxt pred) (
+ tcMonoExpr pred boolTy ) `thenM` \ pred' ->
- zapToType res_ty `thenTc` \ res_ty' ->
+ zapToType res_ty `thenM` \ res_ty' ->
-- C.f. the call to zapToType in TcMatches.tcMatches
- tcMonoExpr b1 res_ty' `thenTc` \ (b1',lie2) ->
- tcMonoExpr b2 res_ty' `thenTc` \ (b2',lie3) ->
- returnTc (HsIf pred' b1' b2' src_loc, plusLIE lie1 (plusLIE lie2 lie3))
-\end{code}
+ tcMonoExpr b1 res_ty' `thenM` \ b1' ->
+ tcMonoExpr b2 res_ty' `thenM` \ b2' ->
+ returnM (HsIf pred' b1' b2' src_loc)
-\begin{code}
-tcMonoExpr expr@(HsDo do_or_lc stmts method_names _ src_loc) res_ty
- = tcAddSrcLoc src_loc (tcDoStmts do_or_lc stmts method_names src_loc res_ty)
-\end{code}
+tcMonoExpr (HsDo do_or_lc stmts method_names _ src_loc) res_ty
+ = addSrcLoc src_loc $
+ tcDoStmts do_or_lc stmts method_names res_ty `thenM` \ (binds, stmts', methods') ->
+ returnM (mkHsLet binds (HsDo do_or_lc stmts' methods' res_ty src_loc))
-\begin{code}
tcMonoExpr in_expr@(ExplicitList _ exprs) res_ty -- Non-empty list
- = unifyListTy res_ty `thenTc` \ elt_ty ->
- mapAndUnzipTc (tc_elt elt_ty) exprs `thenTc` \ (exprs', lies) ->
- returnTc (ExplicitList elt_ty exprs', plusLIEs lies)
+ = unifyListTy res_ty `thenM` \ elt_ty ->
+ mappM (tc_elt elt_ty) exprs `thenM` \ exprs' ->
+ returnM (ExplicitList elt_ty exprs')
where
tc_elt elt_ty expr
- = tcAddErrCtxt (listCtxt expr) $
+ = addErrCtxt (listCtxt expr) $
tcMonoExpr expr elt_ty
tcMonoExpr in_expr@(ExplicitPArr _ exprs) res_ty -- maybe empty
- = unifyPArrTy res_ty `thenTc` \ elt_ty ->
- mapAndUnzipTc (tc_elt elt_ty) exprs `thenTc` \ (exprs', lies) ->
- returnTc (ExplicitPArr elt_ty exprs', plusLIEs lies)
+ = unifyPArrTy res_ty `thenM` \ elt_ty ->
+ mappM (tc_elt elt_ty) exprs `thenM` \ exprs' ->
+ returnM (ExplicitPArr elt_ty exprs')
where
tc_elt elt_ty expr
- = tcAddErrCtxt (parrCtxt expr) $
+ = addErrCtxt (parrCtxt expr) $
tcMonoExpr expr elt_ty
tcMonoExpr (ExplicitTuple exprs boxity) res_ty
- = unifyTupleTy boxity (length exprs) res_ty `thenTc` \ arg_tys ->
- mapAndUnzipTc (\ (expr, arg_ty) -> tcMonoExpr expr arg_ty)
- (exprs `zip` arg_tys) -- we know they're of equal length.
- `thenTc` \ (exprs', lies) ->
- returnTc (ExplicitTuple exprs' boxity, plusLIEs lies)
+ = unifyTupleTy boxity (length exprs) res_ty `thenM` \ arg_tys ->
+ tcMonoExprs exprs arg_tys `thenM` \ exprs' ->
+ returnM (ExplicitTuple exprs' boxity)
+\end{code}
+
+
+%************************************************************************
+%* *
+ Foreign calls
+%* *
+%************************************************************************
+
+The interesting thing about @ccall@ is that it is just a template
+which we instantiate by filling in details about the types of its
+argument and result (ie minimal typechecking is performed). So, the
+basic story is that we allocate a load of type variables (to hold the
+arg/result types); unify them with the args/result; and store them for
+later use.
+
+\begin{code}
+tcMonoExpr e0@(HsCCall lbl args may_gc is_casm ignored_fake_result_ty) res_ty
+
+ = getDOpts `thenM` \ dflags ->
+ checkTc (not (is_casm && dopt_HscLang dflags /= HscC))
+ (vcat [text "_casm_ is only supported when compiling via C (-fvia-C).",
+ text "Either compile with -fvia-C, or, better, rewrite your code",
+ text "to use the foreign function interface. _casm_s are deprecated",
+ text "and support for them may one day disappear."])
+ `thenM_`
+
+ -- Get the callable and returnable classes.
+ tcLookupClass cCallableClassName `thenM` \ cCallableClass ->
+ tcLookupClass cReturnableClassName `thenM` \ cReturnableClass ->
+ tcLookupTyCon ioTyConName `thenM` \ ioTyCon ->
+ let
+ new_arg_dict (arg, arg_ty)
+ = newDicts (CCallOrigin (unpackFS lbl) (Just arg))
+ [mkClassPred cCallableClass [arg_ty]] `thenM` \ arg_dicts ->
+ returnM arg_dicts -- Actually a singleton bag
+
+ result_origin = CCallOrigin (unpackFS lbl) Nothing {- Not an arg -}
+ in
+
+ -- Arguments
+ let tv_idxs | null args = []
+ | otherwise = [1..length args]
+ in
+ newTyVarTys (length tv_idxs) openTypeKind `thenM` \ arg_tys ->
+ tcMonoExprs args arg_tys `thenM` \ args' ->
+
+ -- The argument types can be unlifted or lifted; the result
+ -- type must, however, be lifted since it's an argument to the IO
+ -- type constructor.
+ newTyVarTy liftedTypeKind `thenM` \ result_ty ->
+ let
+ io_result_ty = mkTyConApp ioTyCon [result_ty]
+ in
+ unifyTauTy res_ty io_result_ty `thenM_`
+
+ -- Construct the extra insts, which encode the
+ -- constraints on the argument and result types.
+ mappM new_arg_dict (zipEqual "tcMonoExpr:CCall" args arg_tys) `thenM` \ ccarg_dicts_s ->
+ newDicts result_origin [mkClassPred cReturnableClass [result_ty]] `thenM` \ ccres_dict ->
+ extendLIEs (ccres_dict ++ concat ccarg_dicts_s) `thenM_`
+ returnM (HsCCall lbl args' may_gc is_casm io_result_ty)
+\end{code}
+
+
+%************************************************************************
+%* *
+ Record construction and update
+%* *
+%************************************************************************
+
+\begin{code}
tcMonoExpr expr@(RecordCon con_name rbinds) res_ty
- = tcAddErrCtxt (recordConCtxt expr) $
- tcId con_name `thenNF_Tc` \ (con_expr, con_lie, con_tau) ->
+ = addErrCtxt (recordConCtxt expr) $
+ tcId con_name `thenM` \ (con_expr, con_tau) ->
let
(_, record_ty) = tcSplitFunTys con_tau
(tycon, ty_args) = tcSplitTyConApp record_ty
in
ASSERT( isAlgTyCon tycon )
- unifyTauTy res_ty record_ty `thenTc_`
+ unifyTauTy res_ty record_ty `thenM_`
-- Check that the record bindings match the constructor
-- con_name is syntactically constrained to be a data constructor
- tcLookupDataCon con_name `thenTc` \ data_con ->
+ tcLookupDataCon con_name `thenM` \ data_con ->
let
bad_fields = badFields rbinds data_con
in
if notNull bad_fields then
- mapNF_Tc (addErrTc . badFieldCon con_name) bad_fields `thenNF_Tc_`
- failTc -- Fail now, because tcRecordBinds will crash on a bad field
+ mappM (addErrTc . badFieldCon data_con) bad_fields `thenM_`
+ failM -- Fail now, because tcRecordBinds will crash on a bad field
else
-- Typecheck the record bindings
- tcRecordBinds tycon ty_args rbinds `thenTc` \ (rbinds', rbinds_lie) ->
+ tcRecordBinds tycon ty_args rbinds `thenM` \ rbinds' ->
let
(missing_s_fields, missing_fields) = missingFields rbinds data_con
in
- checkTcM (null missing_s_fields)
- (mapNF_Tc (addErrTc . missingStrictFieldCon con_name) missing_s_fields `thenNF_Tc_`
- returnNF_Tc ()) `thenNF_Tc_`
- doptsTc Opt_WarnMissingFields `thenNF_Tc` \ warn ->
- checkTcM (not (warn && notNull missing_fields))
- (mapNF_Tc ((warnTc True) . missingFieldCon con_name) missing_fields `thenNF_Tc_`
- returnNF_Tc ()) `thenNF_Tc_`
+ checkM (null missing_s_fields)
+ (mappM_ (addErrTc . missingStrictFieldCon con_name) missing_s_fields)
+ `thenM_`
+ doptM Opt_WarnMissingFields `thenM` \ warn ->
+ checkM (not (warn && notNull missing_fields))
+ (mappM_ ((warnTc True) . missingFieldCon con_name) missing_fields)
+ `thenM_`
- returnTc (RecordConOut data_con con_expr rbinds', con_lie `plusLIE` rbinds_lie)
+ returnM (RecordConOut data_con con_expr rbinds')
-- The main complication with RecordUpd is that we need to explicitly
-- handle the *non-updated* fields. Consider:
-- All this is done in STEP 4 below.
tcMonoExpr expr@(RecordUpd record_expr rbinds) res_ty
- = tcAddErrCtxt (recordUpdCtxt expr) $
+ = addErrCtxt (recordUpdCtxt expr) $
-- STEP 0
-- Check that the field names are really field names
ASSERT( notNull rbinds )
let
- field_names = [field_name | (field_name, _, _) <- rbinds]
+ field_names = recBindFields rbinds
in
- mapNF_Tc tcLookupGlobal_maybe field_names `thenNF_Tc` \ maybe_sel_ids ->
+ mappM tcLookupGlobal_maybe field_names `thenM` \ maybe_sel_ids ->
let
bad_guys = [ addErrTc (notSelector field_name)
| (field_name, maybe_sel_id) <- field_names `zip` maybe_sel_ids,
other -> True
]
in
- checkTcM (null bad_guys) (listNF_Tc bad_guys `thenNF_Tc_` failTc) `thenTc_`
+ checkM (null bad_guys) (sequenceM bad_guys `thenM_` failM) `thenM_`
-- STEP 1
-- Figure out the tycon and data cons from the first field name
data_cons = tyConDataCons tycon
tycon_tyvars = tyConTyVars tycon -- The data cons use the same type vars
in
- tcInstTyVars VanillaTv tycon_tyvars `thenNF_Tc` \ (_, result_inst_tys, inst_env) ->
+ tcInstTyVars VanillaTv tycon_tyvars `thenM` \ (_, result_inst_tys, inst_env) ->
-- STEP 2
-- Check that at least one constructor has all the named fields
-- i.e. has an empty set of bad fields returned by badFields
checkTc (any (null . badFields rbinds) data_cons)
- (badFieldsUpd rbinds) `thenTc_`
+ (badFieldsUpd rbinds) `thenM_`
-- STEP 3
-- Typecheck the update bindings.
let
result_record_ty = mkTyConApp tycon result_inst_tys
in
- unifyTauTy res_ty result_record_ty `thenTc_`
- tcRecordBinds tycon result_inst_tys rbinds `thenTc` \ (rbinds', rbinds_lie) ->
+ unifyTauTy res_ty result_record_ty `thenM_`
+ tcRecordBinds tycon result_inst_tys rbinds `thenM` \ rbinds' ->
-- STEP 4
-- Use the un-updated fields to find a vector of booleans saying
-- 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 | (sel_id, _, _) <- rbinds']
+ upd_field_lbls = map recordSelectorFieldLabel (recBindFields rbinds')
con_field_lbls_s = map dataConFieldLabels data_cons
-- A constructor is only relevant to this process if
common_tyvars = tyVarsOfTypes (map fieldLabelType non_upd_field_lbls)
mk_inst_ty (tyvar, result_inst_ty)
- | tyvar `elemVarSet` common_tyvars = returnNF_Tc result_inst_ty -- Same as result type
+ | tyvar `elemVarSet` common_tyvars = returnM result_inst_ty -- Same as result type
| otherwise = newTyVarTy liftedTypeKind -- Fresh type
in
- mapNF_Tc mk_inst_ty (zip tycon_tyvars result_inst_tys) `thenNF_Tc` \ inst_tys ->
+ mappM mk_inst_ty (zip tycon_tyvars result_inst_tys) `thenM` \ inst_tys ->
-- STEP 5
-- Typecheck the expression to be updated
let
record_ty = mkTyConApp tycon inst_tys
in
- tcMonoExpr record_expr record_ty `thenTc` \ (record_expr', record_lie) ->
+ tcMonoExpr record_expr record_ty `thenM` \ record_expr' ->
-- STEP 6
-- Figure out the LIE we need. We have to generate some
let
theta' = substTheta inst_env (tyConTheta tycon)
in
- newDicts RecordUpdOrigin theta' `thenNF_Tc` \ dicts ->
+ newDicts RecordUpdOrigin theta' `thenM` \ dicts ->
+ extendLIEs dicts `thenM_`
-- Phew!
- returnTc (RecordUpdOut record_expr' record_ty result_record_ty rbinds',
- mkLIE dicts `plusLIE` record_lie `plusLIE` rbinds_lie)
+ returnM (RecordUpdOut record_expr' record_ty result_record_ty rbinds')
+\end{code}
+
+
+%************************************************************************
+%* *
+ Arithmetic sequences e.g. [a,b..]
+ and their parallel-array counterparts e.g. [: a,b.. :]
+
+%* *
+%************************************************************************
+\begin{code}
tcMonoExpr (ArithSeqIn seq@(From expr)) res_ty
- = unifyListTy res_ty `thenTc` \ elt_ty ->
- tcMonoExpr expr elt_ty `thenTc` \ (expr', lie1) ->
+ = unifyListTy res_ty `thenM` \ elt_ty ->
+ tcMonoExpr expr elt_ty `thenM` \ expr' ->
newMethodFromName (ArithSeqOrigin seq)
- elt_ty enumFromName `thenNF_Tc` \ enum_from ->
+ elt_ty enumFromName `thenM` \ enum_from ->
- returnTc (ArithSeqOut (HsVar (instToId enum_from)) (From expr'),
- lie1 `plusLIE` unitLIE enum_from)
+ returnM (ArithSeqOut (HsVar enum_from) (From expr'))
tcMonoExpr in_expr@(ArithSeqIn seq@(FromThen expr1 expr2)) res_ty
- = tcAddErrCtxt (arithSeqCtxt in_expr) $
- unifyListTy res_ty `thenTc` \ elt_ty ->
- tcMonoExpr expr1 elt_ty `thenTc` \ (expr1',lie1) ->
- tcMonoExpr expr2 elt_ty `thenTc` \ (expr2',lie2) ->
+ = addErrCtxt (arithSeqCtxt in_expr) $
+ unifyListTy res_ty `thenM` \ elt_ty ->
+ tcMonoExpr expr1 elt_ty `thenM` \ expr1' ->
+ tcMonoExpr expr2 elt_ty `thenM` \ expr2' ->
newMethodFromName (ArithSeqOrigin seq)
- elt_ty enumFromThenName `thenNF_Tc` \ enum_from_then ->
+ elt_ty enumFromThenName `thenM` \ enum_from_then ->
+
+ returnM (ArithSeqOut (HsVar enum_from_then) (FromThen expr1' expr2'))
- returnTc (ArithSeqOut (HsVar (instToId enum_from_then))
- (FromThen expr1' expr2'),
- lie1 `plusLIE` lie2 `plusLIE` unitLIE enum_from_then)
tcMonoExpr in_expr@(ArithSeqIn seq@(FromTo expr1 expr2)) res_ty
- = tcAddErrCtxt (arithSeqCtxt in_expr) $
- unifyListTy res_ty `thenTc` \ elt_ty ->
- tcMonoExpr expr1 elt_ty `thenTc` \ (expr1',lie1) ->
- tcMonoExpr expr2 elt_ty `thenTc` \ (expr2',lie2) ->
+ = addErrCtxt (arithSeqCtxt in_expr) $
+ unifyListTy res_ty `thenM` \ elt_ty ->
+ tcMonoExpr expr1 elt_ty `thenM` \ expr1' ->
+ tcMonoExpr expr2 elt_ty `thenM` \ expr2' ->
newMethodFromName (ArithSeqOrigin seq)
- elt_ty enumFromToName `thenNF_Tc` \ enum_from_to ->
+ elt_ty enumFromToName `thenM` \ enum_from_to ->
- returnTc (ArithSeqOut (HsVar (instToId enum_from_to))
- (FromTo expr1' expr2'),
- lie1 `plusLIE` lie2 `plusLIE` unitLIE enum_from_to)
+ returnM (ArithSeqOut (HsVar enum_from_to) (FromTo expr1' expr2'))
tcMonoExpr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty
- = tcAddErrCtxt (arithSeqCtxt in_expr) $
- unifyListTy res_ty `thenTc` \ elt_ty ->
- tcMonoExpr expr1 elt_ty `thenTc` \ (expr1',lie1) ->
- tcMonoExpr expr2 elt_ty `thenTc` \ (expr2',lie2) ->
- tcMonoExpr expr3 elt_ty `thenTc` \ (expr3',lie3) ->
+ = addErrCtxt (arithSeqCtxt in_expr) $
+ unifyListTy res_ty `thenM` \ elt_ty ->
+ tcMonoExpr expr1 elt_ty `thenM` \ expr1' ->
+ tcMonoExpr expr2 elt_ty `thenM` \ expr2' ->
+ tcMonoExpr expr3 elt_ty `thenM` \ expr3' ->
newMethodFromName (ArithSeqOrigin seq)
- elt_ty enumFromThenToName `thenNF_Tc` \ eft ->
+ elt_ty enumFromThenToName `thenM` \ eft ->
- returnTc (ArithSeqOut (HsVar (instToId eft))
- (FromThenTo expr1' expr2' expr3'),
- lie1 `plusLIE` lie2 `plusLIE` lie3 `plusLIE` unitLIE eft)
+ returnM (ArithSeqOut (HsVar eft) (FromThenTo expr1' expr2' expr3'))
tcMonoExpr in_expr@(PArrSeqIn seq@(FromTo expr1 expr2)) res_ty
- = tcAddErrCtxt (parrSeqCtxt in_expr) $
- unifyPArrTy res_ty `thenTc` \ elt_ty ->
- tcMonoExpr expr1 elt_ty `thenTc` \ (expr1',lie1) ->
- tcMonoExpr expr2 elt_ty `thenTc` \ (expr2',lie2) ->
+ = addErrCtxt (parrSeqCtxt in_expr) $
+ unifyPArrTy res_ty `thenM` \ elt_ty ->
+ tcMonoExpr expr1 elt_ty `thenM` \ expr1' ->
+ tcMonoExpr expr2 elt_ty `thenM` \ expr2' ->
newMethodFromName (PArrSeqOrigin seq)
- elt_ty enumFromToPName `thenNF_Tc` \ enum_from_to ->
+ elt_ty enumFromToPName `thenM` \ enum_from_to ->
- returnTc (PArrSeqOut (HsVar (instToId enum_from_to))
- (FromTo expr1' expr2'),
- lie1 `plusLIE` lie2 `plusLIE` unitLIE enum_from_to)
+ returnM (PArrSeqOut (HsVar enum_from_to) (FromTo expr1' expr2'))
tcMonoExpr in_expr@(PArrSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty
- = tcAddErrCtxt (parrSeqCtxt in_expr) $
- unifyPArrTy res_ty `thenTc` \ elt_ty ->
- tcMonoExpr expr1 elt_ty `thenTc` \ (expr1',lie1) ->
- tcMonoExpr expr2 elt_ty `thenTc` \ (expr2',lie2) ->
- tcMonoExpr expr3 elt_ty `thenTc` \ (expr3',lie3) ->
+ = addErrCtxt (parrSeqCtxt in_expr) $
+ unifyPArrTy res_ty `thenM` \ elt_ty ->
+ tcMonoExpr expr1 elt_ty `thenM` \ expr1' ->
+ tcMonoExpr expr2 elt_ty `thenM` \ expr2' ->
+ tcMonoExpr expr3 elt_ty `thenM` \ expr3' ->
newMethodFromName (PArrSeqOrigin seq)
- elt_ty enumFromThenToPName `thenNF_Tc` \ eft ->
+ elt_ty enumFromThenToPName `thenM` \ eft ->
- returnTc (PArrSeqOut (HsVar (instToId eft))
- (FromThenTo expr1' expr2' expr3'),
- lie1 `plusLIE` lie2 `plusLIE` lie3 `plusLIE` unitLIE eft)
+ returnM (PArrSeqOut (HsVar eft) (FromThenTo expr1' expr2' expr3'))
tcMonoExpr (PArrSeqIn _) _
= panic "TcExpr.tcMonoExpr: Infinite parallel array!"
-- let it through
\end{code}
+
+%************************************************************************
+%* *
+ Template Haskell
+%* *
+%************************************************************************
+
+\begin{code}
+#ifdef GHCI /* Only if bootstrapped */
+ -- Rename excludes these cases otherwise
+
+tcMonoExpr (HsSplice n expr) res_ty = tcSpliceExpr n expr res_ty
+
+tcMonoExpr (HsBracket (ExpBr expr)) res_ty
+ = getStage `thenM` \ level ->
+ case bracketOK level of {
+ Nothing -> failWithTc (illegalBracket level) ;
+ Just next_level ->
+
+ -- Typecheck expr to make sure it is valid,
+ -- but throw away the results. We'll type check
+ -- it again when we actually use it.
+ newMutVar [] `thenM` \ pending_splices ->
+ getLIEVar `thenM` \ lie_var ->
+ newTyVarTy openTypeKind `thenM` \ any_ty ->
+
+ setStage (Brack next_level pending_splices lie_var) (
+ getLIE (tcMonoExpr expr any_ty)
+ ) `thenM` \ (expr', lie) ->
+ tcSimplifyBracket lie `thenM_`
+
+ tcMetaTy exprTyConName `thenM` \ meta_exp_ty ->
+ unifyTauTy res_ty meta_exp_ty `thenM_`
+
+ -- Return the original expression, not the type-decorated one
+ readMutVar pending_splices `thenM` \ pendings ->
+ returnM (HsBracketOut (ExpBr expr) pendings)
+ }
+#endif GHCI
+\end{code}
+
%************************************************************************
%* *
\subsection{Implicit Parameter bindings}
\begin{code}
tcMonoExpr (HsWith expr binds is_with) res_ty
- = tcMonoExpr expr res_ty `thenTc` \ (expr', expr_lie) ->
- mapAndUnzip3Tc tcIPBind binds `thenTc` \ (avail_ips, binds', bind_lies) ->
+ = getLIE (tcMonoExpr expr res_ty) `thenM` \ (expr', expr_lie) ->
+ mapAndUnzipM tc_ip_bind binds `thenM` \ (avail_ips, binds') ->
-- If the binding binds ?x = E, we must now
-- discharge any ?x constraints in expr_lie
- tcSimplifyIPs avail_ips expr_lie `thenTc` \ (expr_lie', dict_binds) ->
+ tcSimplifyIPs avail_ips expr_lie `thenM` \ dict_binds ->
let
expr'' = HsLet (mkMonoBind dict_binds [] Recursive) expr'
in
- returnTc (HsWith expr'' binds' is_with, expr_lie' `plusLIE` plusLIEs bind_lies)
-
-tcIPBind (ip, expr)
- = newTyVarTy openTypeKind `thenTc` \ ty ->
- tcGetSrcLoc `thenTc` \ loc ->
- newIPDict (IPBind ip) ip ty `thenNF_Tc` \ (ip', ip_inst) ->
- tcMonoExpr expr ty `thenTc` \ (expr', lie) ->
- returnTc (ip_inst, (ip', expr'), lie)
+ returnM (HsWith expr'' binds' is_with)
+ where
+ tc_ip_bind (ip, expr)
+ = newTyVarTy openTypeKind `thenM` \ ty ->
+ getSrcLocM `thenM` \ loc ->
+ newIPDict (IPBind ip) ip ty `thenM` \ (ip', ip_inst) ->
+ tcMonoExpr expr ty `thenM` \ expr' ->
+ returnM (ip_inst, (ip', expr'))
\end{code}
+
+%************************************************************************
+%* *
+ Catch-all
+%* *
+%************************************************************************
+
+\begin{code}
+tcMonoExpr other _ = pprPanic "tcMonoExpr" (ppr other)
+\end{code}
+
+
%************************************************************************
%* *
\subsection{@tcApp@ typchecks an application}
tcApp :: RenamedHsExpr -> [RenamedHsExpr] -- Function and args
-> TcType -- Expected result type of application
- -> TcM (TcExpr, LIE) -- Translated fun and args
+ -> TcM TcExpr -- Translated fun and args
tcApp (HsApp e1 e2) args res_ty
= tcApp e1 (e2:args) res_ty -- Accumulate the arguments
tcApp fun args res_ty
= -- First type-check the function
- tcExpr_id fun `thenTc` \ (fun', lie_fun, fun_ty) ->
+ tcExpr_id fun `thenM` \ (fun', fun_ty) ->
- tcAddErrCtxt (wrongArgsCtxt "too many" fun args) (
- traceTc (text "tcApp" <+> (ppr fun $$ ppr fun_ty)) `thenNF_Tc_`
+ addErrCtxt (wrongArgsCtxt "too many" fun args) (
+ traceTc (text "tcApp" <+> (ppr fun $$ ppr fun_ty)) `thenM_`
split_fun_ty fun_ty (length args)
- ) `thenTc` \ (expected_arg_tys, actual_result_ty) ->
+ ) `thenM` \ (expected_arg_tys, actual_result_ty) ->
-- Now typecheck the args
- mapAndUnzipTc (tcArg fun)
- (zip3 args expected_arg_tys [1..]) `thenTc` \ (args', lie_args_s) ->
+ mappM (tcArg fun)
+ (zip3 args expected_arg_tys [1..]) `thenM` \ args' ->
-- Unify with expected result after type-checking the args
-- so that the info from args percolates to actual_result_ty.
-- This is when we might detect a too-few args situation.
-- (One can think of cases when the opposite order would give
-- a better error message.)
- tcAddErrCtxtM (checkArgsCtxt fun args res_ty actual_result_ty)
- (tcSubExp res_ty actual_result_ty) `thenTc` \ (co_fn, lie_res) ->
+ addErrCtxtM (checkArgsCtxt fun args res_ty actual_result_ty)
+ (tcSubExp res_ty actual_result_ty) `thenM` \ co_fn ->
- returnTc (co_fn <$> foldl HsApp fun' args',
- lie_res `plusLIE` lie_fun `plusLIE` plusLIEs lie_args_s)
+ returnM (co_fn <$> foldl HsApp fun' args')
-- If an error happens we try to figure out whether the
-- function has been given too many or too few arguments,
-- and say so
checkArgsCtxt fun args expected_res_ty actual_res_ty tidy_env
- = zonkTcType expected_res_ty `thenNF_Tc` \ exp_ty' ->
- zonkTcType actual_res_ty `thenNF_Tc` \ act_ty' ->
+ = zonkTcType expected_res_ty `thenM` \ exp_ty' ->
+ zonkTcType actual_res_ty `thenM` \ act_ty' ->
let
(env1, exp_ty'') = tidyOpenType tidy_env exp_ty'
(env2, act_ty'') = tidyOpenType env1 act_ty'
| len_exp_args > len_act_args = wrongArgsCtxt "too many" fun args
| otherwise = appCtxt fun args
in
- returnNF_Tc (env2, message)
+ returnM (env2, message)
split_fun_ty :: TcType -- The type of the function
TcType) -- Function result types
split_fun_ty fun_ty 0
- = returnTc ([], fun_ty)
+ = returnM ([], fun_ty)
split_fun_ty fun_ty n
= -- Expect the function to have type A->B
- unifyFunTy fun_ty `thenTc` \ (arg_ty, res_ty) ->
- split_fun_ty res_ty (n-1) `thenTc` \ (arg_tys, final_res_ty) ->
- returnTc (arg_ty:arg_tys, final_res_ty)
+ unifyFunTy fun_ty `thenM` \ (arg_ty, res_ty) ->
+ split_fun_ty res_ty (n-1) `thenM` \ (arg_tys, final_res_ty) ->
+ returnM (arg_ty:arg_tys, final_res_ty)
\end{code}
\begin{code}
tcArg :: RenamedHsExpr -- The function (for error messages)
-> (RenamedHsExpr, TcSigmaType, Int) -- Actual argument and expected arg type
- -> TcM (TcExpr, LIE) -- Resulting argument and LIE
+ -> TcM TcExpr -- Resulting argument and LIE
tcArg the_fun (arg, expected_arg_ty, arg_no)
- = tcAddErrCtxt (funAppCtxt the_fun arg arg_no) $
+ = addErrCtxt (funAppCtxt the_fun arg arg_no) $
tcExpr arg expected_arg_ty
\end{code}
b) perhaps fewer separated lambdas
\begin{code}
-tcId :: Name -> NF_TcM (TcExpr, LIE, TcType)
+tcId :: Name -> TcM (TcExpr, TcType)
tcId name -- Look up the Id and instantiate its type
- = tcLookupId name `thenNF_Tc` \ id ->
- case isDataConWrapId_maybe id of
- Nothing -> loop (HsVar id) emptyLIE (idType id)
- Just data_con -> inst_data_con id data_con
+ = tcLookupIdLvl name `thenM` \ (id, bind_lvl) ->
+
+ -- Check for cross-stage lifting
+ getStage `thenM` \ use_stage ->
+ case use_stage of
+ Brack use_lvl ps_var lie_var
+ | use_lvl > bind_lvl && not (isExternalName name)
+ -> -- E.g. \x -> [| h x |]
+ -- We must behave as if the reference to x was
+ -- h $(lift x)
+ -- We use 'x' itself as the splice proxy, used by
+ -- the desugarer to stitch it all back together
+ -- NB: isExernalName is true of top level things,
+ -- and false of nested bindings
+
+ let
+ id_ty = idType id
+ in
+ checkTc (isTauTy id_ty) (polySpliceErr id) `thenM_`
+ -- If x is polymorphic, its occurrence sites might
+ -- have different instantiations, so we can't use plain
+ -- 'x' as the splice proxy name. I don't know how to
+ -- solve this, and it's probably unimportant, so I'm
+ -- just going to flag an error for now
+
+ setLIEVar lie_var (
+ newMethodFromName orig id_ty liftName `thenM` \ lift ->
+ -- Put the 'lift' constraint into the right LIE
+
+ -- Update the pending splices
+ readMutVar ps_var `thenM` \ ps ->
+ writeMutVar ps_var ((name, HsApp (HsVar lift) (HsVar id)) : ps) `thenM_`
+
+ returnM (HsVar id, id_ty))
+
+ other ->
+ let
+ use_lvl = metaLevel use_stage
+ in
+ checkTc (wellStaged bind_lvl use_lvl)
+ (badStageErr id bind_lvl use_lvl) `thenM_`
+
+ case isDataConWrapId_maybe id of
+ Nothing -> loop (HsVar id) (idType id)
+ Just data_con -> inst_data_con id data_con
+
where
orig = OccurrenceOf name
- loop (HsVar fun_id) lie fun_ty
+ loop (HsVar fun_id) fun_ty
| want_method_inst fun_ty
- = tcInstType VanillaTv fun_ty `thenNF_Tc` \ (tyvars, theta, tau) ->
+ = tcInstType VanillaTv fun_ty `thenM` \ (tyvars, theta, tau) ->
newMethodWithGivenTy orig fun_id
- (mkTyVarTys tyvars) theta tau `thenNF_Tc` \ meth ->
- loop (HsVar (instToId meth))
- (unitLIE meth `plusLIE` lie) tau
+ (mkTyVarTys tyvars) theta tau `thenM` \ meth ->
+ loop (HsVar (instToId meth)) tau
- loop fun lie fun_ty
+ loop fun fun_ty
| isSigmaTy fun_ty
- = tcInstCall orig fun_ty `thenNF_Tc` \ (inst_fn, inst_lie, tau) ->
- loop (inst_fn fun) (inst_lie `plusLIE` lie) tau
+ = tcInstCall orig fun_ty `thenM` \ (inst_fn, tau) ->
+ loop (inst_fn fun) tau
| otherwise
- = returnNF_Tc (fun, lie, fun_ty)
+ = returnM (fun, fun_ty)
want_method_inst fun_ty
| opt_NoMethodSharing = False
-- constraints for their silly theta, which no longer appears in
-- the type of dataConWrapId. It's dual to TcPat.tcConstructor
inst_data_con id data_con
- = tcInstDataCon orig data_con `thenNF_Tc` \ (ty_args, ex_dicts, arg_tys, result_ty, stupid_lie, ex_lie, _) ->
- returnNF_Tc (mkHsDictApp (mkHsTyApp (HsVar id) ty_args) ex_dicts,
- stupid_lie `plusLIE` ex_lie,
- mkFunTys arg_tys result_ty)
+ = tcInstDataCon orig data_con `thenM` \ (ty_args, ex_dicts, arg_tys, result_ty, _) ->
+ extendLIEs ex_dicts `thenM_`
+ returnM (mkHsDictApp (mkHsTyApp (HsVar id) ty_args) (map instToId ex_dicts),
+ mkFunTys arg_tys result_ty)
\end{code}
Typecheck expression which in most cases will be an Id.
so we must create a HoleTyVarTy to pass in as the expected tyvar.
\begin{code}
-tcExpr_id :: RenamedHsExpr -> TcM (TcExpr, LIE, TcType)
+tcExpr_id :: RenamedHsExpr -> TcM (TcExpr, TcType)
tcExpr_id (HsVar name) = tcId name
-tcExpr_id expr = newHoleTyVarTy `thenNF_Tc` \ id_ty ->
- tcMonoExpr expr id_ty `thenTc` \ (expr', lie_id) ->
- readHoleResult id_ty `thenTc` \ id_ty' ->
- returnTc (expr', lie_id, id_ty')
+tcExpr_id expr = newHoleTyVarTy `thenM` \ id_ty ->
+ tcMonoExpr expr id_ty `thenM` \ expr' ->
+ readHoleResult id_ty `thenM` \ id_ty' ->
+ returnM (expr', id_ty')
\end{code}
%************************************************************************
%* *
-\subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
-%* *
-%************************************************************************
-
-\begin{code}
-tcDoStmts PArrComp stmts method_names src_loc res_ty
- = unifyPArrTy res_ty `thenTc` \elt_ty ->
- tcStmts (DoCtxt PArrComp)
- (mkPArrTy, elt_ty) stmts `thenTc` \(stmts', stmts_lie) ->
- returnTc (HsDo PArrComp stmts'
- [] -- Unused
- res_ty src_loc,
- stmts_lie)
-
-tcDoStmts ListComp stmts method_names src_loc res_ty
- = unifyListTy res_ty `thenTc` \ elt_ty ->
- tcStmts (DoCtxt ListComp)
- (mkListTy, elt_ty) stmts `thenTc` \ (stmts', stmts_lie) ->
- returnTc (HsDo ListComp stmts'
- [] -- Unused
- res_ty src_loc,
- stmts_lie)
-
-tcDoStmts DoExpr stmts method_names src_loc res_ty
- = newTyVarTy (mkArrowKind liftedTypeKind liftedTypeKind) `thenNF_Tc` \ m_ty ->
- newTyVarTy liftedTypeKind `thenNF_Tc` \ elt_ty ->
- unifyTauTy res_ty (mkAppTy m_ty elt_ty) `thenTc_`
-
- tcStmts (DoCtxt DoExpr) (mkAppTy m_ty, elt_ty) stmts `thenTc` \ (stmts', stmts_lie) ->
-
- -- Build the then and zero methods in case we need them
- -- It's important that "then" and "return" appear just once in the final LIE,
- -- not only for typechecker efficiency, but also because otherwise during
- -- simplification we end up with silly stuff like
- -- then = case d of (t,r) -> t
- -- then = then
- -- where the second "then" sees that it already exists in the "available" stuff.
- --
- mapNF_Tc (tc_syn_name m_ty)
- (zipEqual "tcDoStmts" monadNames method_names) `thenNF_Tc` \ stuff ->
- let
- (binds, ids, lies) = unzip3 stuff
- in
-
- returnTc (mkHsLet (andMonoBindList binds) $
- HsDo DoExpr stmts' ids
- res_ty src_loc,
- stmts_lie `plusLIE` plusLIEs lies)
-
- where
- tc_syn_name :: TcType -> (Name,Name) -> TcM (TypecheckedMonoBinds, Id, LIE)
- tc_syn_name m_ty (std_nm, usr_nm)
- = tcSyntaxName DoOrigin m_ty std_nm usr_nm `thenTc` \ (expr, lie, expr_ty) ->
- case expr of
- HsVar v -> returnTc (EmptyMonoBinds, v, lie)
- other -> tcGetUnique `thenTc` \ uniq ->
- let
- id = mkSysLocal FSLIT("syn") uniq expr_ty
- in
- returnTc (VarMonoBind id expr, id, lie)
-\end{code}
-
-%************************************************************************
-%* *
\subsection{Record bindings}
%* *
%************************************************************************
:: TyCon -- Type constructor for the record
-> [TcType] -- Args of this type constructor
-> RenamedRecordBinds
- -> TcM (TcRecordBinds, LIE)
+ -> TcM TcRecordBinds
tcRecordBinds tycon ty_args rbinds
- = mapAndUnzipTc do_bind rbinds `thenTc` \ (rbinds', lies) ->
- returnTc (rbinds', plusLIEs lies)
+ = mappM do_bind rbinds
where
tenv = mkTopTyVarSubst (tyConTyVars tycon) ty_args
- do_bind (field_lbl_name, rhs, pun_flag)
- = tcLookupGlobalId field_lbl_name `thenNF_Tc` \ sel_id ->
+ do_bind (field_lbl_name, rhs)
+ = addErrCtxt (fieldCtxt field_lbl_name) $
+ tcLookupId field_lbl_name `thenM` \ sel_id ->
let
field_lbl = recordSelectorFieldLabel sel_id
field_ty = substTy tenv (fieldLabelType field_lbl)
-- The caller of tcRecordBinds has already checked
-- that all the fields come from the same type
- tcExpr rhs field_ty `thenTc` \ (rhs', lie) ->
+ tcExpr rhs field_ty `thenM` \ rhs' ->
- returnTc ((sel_id, rhs', pun_flag), lie)
+ returnM (sel_id, rhs')
badFields rbinds data_con
- = [field_name | (field_name, _, _) <- rbinds,
- not (field_name `elem` field_names)
- ]
+ = filter (not . (`elem` field_names)) (recBindFields rbinds)
where
field_names = map fieldLabelName (dataConFieldLabels data_con)
not (fieldLabelName fl `elem` field_names_used)
]
- field_names_used = [ field_name | (field_name, _, _) <- rbinds ]
+ field_names_used = recBindFields rbinds
field_labels = dataConFieldLabels data_con
field_info = zipEqual "missingFields"
%************************************************************************
\begin{code}
-tcMonoExprs :: [RenamedHsExpr] -> [TcType] -> TcM ([TcExpr], LIE)
+tcMonoExprs :: [RenamedHsExpr] -> [TcType] -> TcM [TcExpr]
-tcMonoExprs [] [] = returnTc ([], emptyLIE)
+tcMonoExprs [] [] = returnM []
tcMonoExprs (expr:exprs) (ty:tys)
- = tcMonoExpr expr ty `thenTc` \ (expr', lie1) ->
- tcMonoExprs exprs tys `thenTc` \ (exprs', lie2) ->
- returnTc (expr':exprs', lie1 `plusLIE` lie2)
+ = tcMonoExpr expr ty `thenM` \ expr' ->
+ tcMonoExprs exprs tys `thenM` \ exprs' ->
+ returnM (expr':exprs')
\end{code}
Overloaded literals.
\begin{code}
-tcLit :: HsLit -> TcType -> TcM (TcExpr, LIE)
+tcLit :: HsLit -> TcType -> TcM TcExpr
tcLit (HsLitLit s _) res_ty
- = tcLookupClass cCallableClassName `thenNF_Tc` \ cCallableClass ->
+ = tcLookupClass cCallableClassName `thenM` \ cCallableClass ->
newDicts (LitLitOrigin (unpackFS s))
- [mkClassPred cCallableClass [res_ty]] `thenNF_Tc` \ dicts ->
- returnTc (HsLit (HsLitLit s res_ty), mkLIE dicts)
+ [mkClassPred cCallableClass [res_ty]] `thenM` \ dicts ->
+ extendLIEs dicts `thenM_`
+ returnM (HsLit (HsLitLit s res_ty))
tcLit lit res_ty
- = unifyTauTy res_ty (simpleHsLitTy lit) `thenTc_`
- returnTc (HsLit lit, emptyLIE)
+ = unifyTauTy res_ty (hsLitType lit) `thenM_`
+ returnM (HsLit lit)
\end{code}
%* *
%************************************************************************
-Mini-utils:
-
Boring and alphabetical:
\begin{code}
arithSeqCtxt expr
= hang (ptext SLIT("In an arithmetic sequence:")) 4 (ppr expr)
+
+badStageErr id bind_lvl use_lvl
+ = ptext SLIT("Stage error:") <+> quotes (ppr id) <+>
+ hsep [ptext SLIT("is bound at stage") <+> ppr bind_lvl,
+ ptext SLIT("but used at stage") <+> ppr use_lvl]
+
parrSeqCtxt expr
= hang (ptext SLIT("In a parallel array sequence:")) 4 (ppr expr)
exprCtxt expr
= hang (ptext SLIT("In the expression:")) 4 (ppr expr)
+fieldCtxt field_name
+ = ptext SLIT("In the") <+> quotes (ppr field_name) <+> ptext SLIT("field of a record")
+
funAppCtxt fun arg arg_no
= hang (hsep [ ptext SLIT("In the"), speakNth arg_no, ptext SLIT("argument of"),
quotes (ppr fun) <> text ", namely"])
predCtxt expr
= hang (ptext SLIT("In the predicate expression:")) 4 (ppr expr)
-wrongArgsCtxt too_many_or_few fun args
- = hang (ptext SLIT("Probable cause:") <+> quotes (ppr fun)
- <+> ptext SLIT("is applied to") <+> text too_many_or_few
- <+> ptext SLIT("arguments in the call"))
- 4 (parens (ppr the_app))
- where
- the_app = foldl HsApp fun args -- Used in error messages
+illegalBracket level
+ = ptext SLIT("Illegal bracket at level") <+> ppr level
appCtxt fun args
= ptext SLIT("In the application") <+> quotes (ppr the_app)
badFieldsUpd rbinds
= hang (ptext SLIT("No constructor has all these fields:"))
- 4 (pprQuotedList fields)
- where
- fields = [field | (field, _, _) <- rbinds]
+ 4 (pprQuotedList (recBindFields rbinds))
recordUpdCtxt expr = ptext SLIT("In the record update:") <+> ppr expr
recordConCtxt expr = ptext SLIT("In the record construction:") <+> ppr expr
missingFieldCon con field
= hsep [ptext SLIT("Field") <+> quotes (ppr field),
ptext SLIT("is not initialised")]
+
+polySpliceErr :: Id -> SDoc
+polySpliceErr id
+ = ptext SLIT("Can't splice the polymorphic local variable") <+> quotes (ppr id)
+
+wrongArgsCtxt too_many_or_few fun args
+ = hang (ptext SLIT("Probable cause:") <+> quotes (ppr fun)
+ <+> ptext SLIT("is applied to") <+> text too_many_or_few
+ <+> ptext SLIT("arguments in the call"))
+ 4 (parens (ppr the_app))
+ where
+ the_app = foldl HsApp fun args -- Used in error messages
\end{code}
)
import RnHsSyn ( RenamedHsDecl, RenamedForeignDecl )
-import TcMonad
+import TcRnMonad
import TcMonoType ( tcHsSigType, UserTypeCtxt(..) )
-import TcHsSyn ( TcMonoBinds, TypecheckedForeignDecl, TcForeignExportDecl )
+import TcHsSyn ( TcMonoBinds, TypecheckedForeignDecl, TcForeignDecl )
import TcExpr ( tcExpr )
-import Inst ( emptyLIE, LIE, plusLIE )
import ErrUtils ( Message )
-import Id ( Id, mkLocalId, setIdLocalExported )
+import Id ( Id, mkLocalId, mkVanillaGlobal, setIdLocalExported )
+import IdInfo ( noCafIdInfo )
import PrimRep ( getPrimRepSize, isFloatingRep )
-import Module ( Module )
import Type ( typePrimRep )
import OccName ( mkForeignExportOcc )
import Name ( NamedThing(..), mkExternalName )
\begin{code}
tcForeignImports :: [RenamedHsDecl] -> TcM ([Id], [TypecheckedForeignDecl])
tcForeignImports decls =
- mapAndUnzipTc tcFImport
+ mapAndUnzipM tcFImport
[ foreign_decl | ForD foreign_decl <- decls, isForeignImport foreign_decl]
tcFImport :: RenamedForeignDecl -> TcM (Id, TypecheckedForeignDecl)
tcFImport fo@(ForeignImport nm hs_ty imp_decl isDeprec src_loc)
- = tcAddSrcLoc src_loc $
- tcAddErrCtxt (foreignDeclCtxt fo) $
- tcHsSigType (ForSigCtxt nm) hs_ty `thenTc` \ sig_ty ->
+ = addSrcLoc src_loc $
+ addErrCtxt (foreignDeclCtxt fo) $
+ tcHsSigType (ForSigCtxt nm) hs_ty `thenM` \ sig_ty ->
let
-- drop the foralls before inspecting the structure
-- of the foreign type.
(_, t_ty) = tcSplitForAllTys sig_ty
(arg_tys, res_ty) = tcSplitFunTys t_ty
- id = mkLocalId nm sig_ty
+ id = mkVanillaGlobal nm sig_ty noCafIdInfo
+ -- Foreign-imported things don't neeed zonking etc
+ -- They are rather like constructors; we make the final
+ -- Global Id right away.
in
- tcCheckFIType sig_ty arg_tys res_ty imp_decl `thenNF_Tc_`
+ tcCheckFIType sig_ty arg_tys res_ty imp_decl `thenM_`
-- can't use sig_ty here because it :: Type and we need HsType Id
-- hence the undefined
- returnTc (id, ForeignImport id undefined imp_decl isDeprec src_loc)
+ returnM (id, ForeignImport id undefined imp_decl isDeprec src_loc)
\end{code}
= checkCg checkDotNet
tcCheckFIType sig_ty arg_tys res_ty (CImport _ _ _ _ (CLabel _))
- = checkCg checkCOrAsm `thenNF_Tc_`
+ = checkCg checkCOrAsm `thenM_`
check (isFFILabelTy sig_ty) (illegalForeignTyErr empty sig_ty)
tcCheckFIType sig_ty arg_tys res_ty (CImport cconv _ _ _ CWrapper)
-- is DEPRECATED, though.
checkCg (if cconv == StdCallConv
then checkC
- else checkCOrAsmOrInterp) `thenNF_Tc_`
+ else checkCOrAsmOrInterp) `thenM_`
-- the native code gen can't handle foreign import stdcall "wrapper",
-- because it doesn't emit the '@n' suffix on the label of the
-- C stub function. Infrastructure changes are required to make this
-- happen; MachLabel will need to carry around information about
-- the arity of the foreign call.
case arg_tys of
- [arg1_ty] -> checkForeignArgs isFFIExternalTy arg1_tys `thenNF_Tc_`
- checkForeignRes nonIOok isFFIExportResultTy res1_ty `thenNF_Tc_`
- checkForeignRes mustBeIO isFFIDynResultTy res_ty `thenNF_Tc_`
+ [arg1_ty] -> checkForeignArgs isFFIExternalTy arg1_tys `thenM_`
+ checkForeignRes nonIOok isFFIExportResultTy res1_ty `thenM_`
+ checkForeignRes mustBeIO isFFIDynResultTy res_ty `thenM_`
checkFEDArgs arg1_tys
where
(arg1_tys, res1_ty) = tcSplitFunTys arg1_ty
tcCheckFIType sig_ty arg_tys res_ty (CImport _ safety _ _ (CFunction target))
| isDynamicTarget target -- Foreign import dynamic
- = checkCg checkCOrAsmOrInterp `thenNF_Tc_`
+ = checkCg checkCOrAsmOrInterp `thenM_`
case arg_tys of -- The first arg must be Ptr, FunPtr, or Addr
[] -> check False (illegalForeignTyErr empty sig_ty)
- (arg1_ty:arg_tys) -> getDOptsTc `thenNF_Tc` \ dflags ->
+ (arg1_ty:arg_tys) -> getDOpts `thenM` \ dflags ->
check (isFFIDynArgumentTy arg1_ty)
- (illegalForeignTyErr argument arg1_ty) `thenNF_Tc_`
- checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys `thenNF_Tc_`
+ (illegalForeignTyErr argument arg1_ty) `thenM_`
+ checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys `thenM_`
checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
| otherwise -- Normal foreign import
= checkCg (if isCasmTarget target
- then checkC else checkCOrAsmOrDotNetOrInterp) `thenNF_Tc_`
- checkCTarget target `thenNF_Tc_`
- getDOptsTc `thenNF_Tc` \ dflags ->
- checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys `thenNF_Tc_`
+ then checkC else checkCOrAsmOrDotNetOrInterp) `thenM_`
+ checkCTarget target `thenM_`
+ getDOpts `thenM` \ dflags ->
+ checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys `thenM_`
checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
-- This makes a convenient place to check
-- that the C identifier is valid for C
checkCTarget (StaticTarget str)
- = checkCg checkCOrAsmOrDotNetOrInterp `thenNF_Tc_`
+ = checkCg checkCOrAsmOrDotNetOrInterp `thenM_`
check (isCLabelString str) (badCName str)
checkCTarget (CasmTarget _)
map typePrimRep arg_tys)
err = ptext SLIT("On Alpha, I can only handle 4 non-floating-point arguments to foreign export dynamic")
#else
-checkFEDArgs arg_tys = returnNF_Tc ()
+checkFEDArgs arg_tys = returnM ()
#endif
\end{code}
%************************************************************************
\begin{code}
-tcForeignExports :: Module -> [RenamedHsDecl]
- -> TcM (LIE, TcMonoBinds, [TcForeignExportDecl])
-tcForeignExports mod decls =
- foldlTc combine (emptyLIE, EmptyMonoBinds, [])
+tcForeignExports :: [RenamedHsDecl]
+ -> TcM (TcMonoBinds, [TcForeignDecl])
+tcForeignExports decls =
+ foldlM combine (EmptyMonoBinds, [])
[foreign_decl | ForD foreign_decl <- decls, isForeignExport foreign_decl]
where
- combine (lie, binds, fs) fe =
- tcFExport mod fe `thenTc ` \ (a_lie, b, f) ->
- returnTc (lie `plusLIE` a_lie, b `AndMonoBinds` binds, f:fs)
+ combine (binds, fs) fe =
+ tcFExport fe `thenM ` \ (b, f) ->
+ returnM (b `AndMonoBinds` binds, f:fs)
-tcFExport :: Module -> RenamedForeignDecl -> TcM (LIE, TcMonoBinds, TcForeignExportDecl)
-tcFExport mod fo@(ForeignExport nm hs_ty spec isDeprec src_loc) =
- tcAddSrcLoc src_loc $
- tcAddErrCtxt (foreignDeclCtxt fo) $
+tcFExport :: RenamedForeignDecl -> TcM (TcMonoBinds, TcForeignDecl)
+tcFExport fo@(ForeignExport nm hs_ty spec isDeprec src_loc) =
+ addSrcLoc src_loc $
+ addErrCtxt (foreignDeclCtxt fo) $
- tcHsSigType (ForSigCtxt nm) hs_ty `thenTc` \ sig_ty ->
- tcExpr (HsVar nm) sig_ty `thenTc` \ (rhs, lie) ->
+ tcHsSigType (ForSigCtxt nm) hs_ty `thenM` \ sig_ty ->
+ tcExpr (HsVar nm) sig_ty `thenM` \ rhs ->
- tcCheckFEType sig_ty spec `thenTc_`
+ tcCheckFEType sig_ty spec `thenM_`
-- we're exporting a function, but at a type possibly more
-- constrained than its declared/inferred type. Hence the need
-- to create a local binding which will call the exported function
-- at a particular type (and, maybe, overloading).
- tcGetUnique `thenNF_Tc` \ uniq ->
+ newUnique `thenM` \ uniq ->
+ getModule `thenM` \ mod ->
let
gnm = mkExternalName uniq mod (mkForeignExportOcc (getOccName nm)) src_loc
id = setIdLocalExported (mkLocalId gnm sig_ty)
bind = VarMonoBind id rhs
in
- returnTc (lie, bind, ForeignExport id undefined spec isDeprec src_loc)
+ returnM (bind, ForeignExport id undefined spec isDeprec src_loc)
\end{code}
------------ Checking argument types for foreign export ----------------------
\begin{code}
tcCheckFEType sig_ty (CExport (CExportStatic str _))
- = check (isCLabelString str) (badCName str) `thenNF_Tc_`
- checkForeignArgs isFFIExternalTy arg_tys `thenNF_Tc_`
+ = check (isCLabelString str) (badCName str) `thenM_`
+ checkForeignArgs isFFIExternalTy arg_tys `thenM_`
checkForeignRes nonIOok isFFIExportResultTy res_ty
where
-- Drop the foralls before inspecting n
\begin{code}
------------ Checking argument types for foreign import ----------------------
-checkForeignArgs :: (Type -> Bool) -> [Type] -> NF_TcM ()
+checkForeignArgs :: (Type -> Bool) -> [Type] -> TcM ()
checkForeignArgs pred tys
- = mapNF_Tc go tys `thenNF_Tc_`
- returnNF_Tc ()
+ = mappM go tys `thenM_`
+ returnM ()
where
go ty = check (pred ty) (illegalForeignTyErr argument ty)
-- Check that the type has the form
-- (IO t) or (t) , and that t satisfies the given predicate.
--
-checkForeignRes :: Bool -> (Type -> Bool) -> Type -> NF_TcM ()
+checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM ()
nonIOok = True
mustBeIO = False
= case tcSplitTyConApp_maybe ty of
Just (io, [res_ty])
| io `hasKey` ioTyConKey && pred_res_ty res_ty
- -> returnNF_Tc ()
+ -> returnM ()
_
-> check (non_io_result_ok && pred_res_ty ty)
(illegalForeignTyErr result ty)
= Just (text "requires interpreted, C, native or .NET ILX code generation")
checkCg check
- = getDOptsTc `thenNF_Tc` \ dflags ->
+ = getDOpts `thenM` \ dflags ->
let hscLang = dopt_HscLang dflags in
case hscLang of
- HscNothing -> returnNF_Tc ()
+ HscNothing -> returnM ()
otherwise ->
case check hscLang of
- Nothing -> returnNF_Tc ()
+ Nothing -> returnM ()
Just err -> addErrTc (text "Illegal foreign declaration:" <+> err)
\end{code}
Warnings
\begin{code}
-check :: Bool -> Message -> NF_TcM ()
-check True _ = returnTc ()
+check :: Bool -> Message -> TcM ()
+check True _ = returnM ()
check _ the_err = addErrTc the_err
illegalForeignTyErr arg_or_res ty
#include "HsVersions.h"
-import HsSyn ( InPat(..), HsExpr(..), MonoBinds(..),
+import HsSyn ( Pat(..), HsConDetails(..), HsExpr(..), MonoBinds(..),
Match(..), GRHSs(..), Stmt(..), HsLit(..),
HsBinds(..), HsType(..), HsDoContext(..),
unguardedRHS, mkSimpleMatch, mkMonoBind, andMonoBindList, placeHolderType
)
-import RdrName ( RdrName, mkUnqual )
+import RdrName ( RdrName, mkUnqual, nameRdrName, getRdrName )
import RdrHsSyn ( mkHsOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat, mkHsDo )
import BasicTypes ( RecFlag(..), Fixity(..), FixityDirection(..)
, maxPrecedence
, Boxity(..)
)
-import FieldLabel ( FieldLabel, fieldLabelName )
+import FieldLabel ( fieldLabelName )
import DataCon ( isNullaryDataCon, dataConTag,
dataConOrigArgTys, dataConSourceArity, fIRST_TAG,
DataCon,
dataConFieldLabels )
import Name ( getOccString, getOccName, getSrcLoc, occNameString,
- occNameUserString, nameRdrName, varName,
+ occNameUserString, varName,
Name, NamedThing(..),
isDataSymOcc, isSymOcc
)
import HscTypes ( FixityEnv, lookupFixity )
-import PrelInfo -- Lots of RdrNames
+import PrelInfo -- Lots of Names
+import PrimOp -- Lots of Names
import SrcLoc ( generatedSrcLoc, SrcLoc )
import TyCon ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon,
maybeTyConSingleCon, tyConFamilySize
import TysPrim ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy,
floatPrimTy, doublePrimTy
)
-import Util ( mapAccumL, zipEqual, zipWithEqual, isSingleton,
- zipWith3Equal, nOfThem )
+import Util ( zipWithEqual, isSingleton,
+ zipWith3Equal, nOfThem, zipEqual )
import Panic ( panic, assertPanic )
import Maybes ( maybeToBool )
import Char ( ord, isAlpha )
import Constants
import List ( partition, intersperse )
import FastString
+import OccName
\end{code}
%************************************************************************
else -- calc. and compare the tags
[([a_Pat, b_Pat],
untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
- (genOpApp (HsVar ah_RDR) eqH_Int_RDR (HsVar bh_RDR)))]
+ (genOpApp (HsVar ah_RDR) eqInt_RDR (HsVar bh_RDR)))]
in
mk_FunMonoBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest)
`AndMonoBinds`
------------------------------------------------------------------
pats_etc data_con
= let
- con1_pat = ConPatIn data_con_RDR (map VarPatIn as_needed)
- con2_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
+ con1_pat = mkConPat data_con_RDR as_needed
+ con2_pat = mkConPat data_con_RDR bs_needed
- data_con_RDR = qual_orig_name data_con
+ data_con_RDR = getRdrName data_con
con_arity = length tys_needed
as_needed = take con_arity as_RDRs
bs_needed = take con_arity bs_RDRs
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
+ (cmp_tags_Expr eqInt_RDR ah_RDR bh_RDR
-- True case; they are equal
-- If an enumeration type we are done; else
-- recursively compare their components
)
-- False case; they aren't equal
-- So we need to do a less-than comparison on the tags
- (cmp_tags_Expr ltH_Int_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr)))
+ (cmp_tags_Expr ltInt_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr)))
tycon_data_cons = tyConDataCons tycon
(nullary_cons, nonnullary_cons)
-- about overlapping patterns from the desugarer.
let
data_con = head nullary_cons
- data_con_RDR = qual_orig_name data_con
- pat = ConPatIn data_con_RDR []
+ data_con_RDR = getRdrName data_con
+ pat = mkNullaryConPat data_con_RDR
in
[([pat,pat], eqTag_Expr)]
else
(if isSingleton tycon_data_cons then
[]
else
- [([WildPatIn, WildPatIn], default_rhs)]))
+ [([wildPat, wildPat], default_rhs)]))
where
pats_etc data_con
= ([con1_pat, con2_pat],
nested_compare_expr tys_needed as_needed bs_needed)
where
- con1_pat = ConPatIn data_con_RDR (map VarPatIn as_needed)
- con2_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
+ con1_pat = mkConPat data_con_RDR as_needed
+ con2_pat = mkConPat data_con_RDR bs_needed
- data_con_RDR = qual_orig_name data_con
+ data_con_RDR = getRdrName data_con
con_arity = length tys_needed
as_needed = take con_arity as_RDRs
bs_needed = take con_arity bs_RDRs
data_con_1 = head data_cons
data_con_N = last data_cons
- data_con_1_RDR = qual_orig_name data_con_1
- data_con_N_RDR = qual_orig_name data_con_N
+ data_con_1_RDR = getRdrName data_con_1
+ data_con_N_RDR = getRdrName data_con_N
----- single-constructor-flavored: -------------
arity = dataConSourceArity data_con_1
enum_range
= mk_easy_FunMonoBind tycon_loc range_RDR
- [TuplePatIn [a_Pat, b_Pat] Boxed] [] $
+ [TuplePat [a_Pat, b_Pat] Boxed] [] $
untag_Expr tycon [(a_RDR, ah_RDR)] $
untag_Expr tycon [(b_RDR, bh_RDR)] $
HsApp (mkHsVarApps map_RDR [tag2con_RDR tycon]) $
enum_index
= mk_easy_FunMonoBind tycon_loc index_RDR
- [AsPatIn c_RDR (TuplePatIn [a_Pat, wildPat] Boxed),
+ [AsPat c_RDR (TuplePat [a_Pat, wildPat] Boxed),
d_Pat] [] (
HsIf (HsPar (mkHsVarApps inRange_RDR [c_RDR, d_RDR])) (
untag_Expr tycon [(a_RDR, ah_RDR)] (
rhs = mkHsVarApps mkInt_RDR [c_RDR]
in
HsCase
- (genOpApp (HsVar dh_RDR) minusH_RDR (HsVar ah_RDR))
- [mkSimpleMatch [VarPatIn c_RDR] rhs placeHolderType tycon_loc]
+ (genOpApp (HsVar dh_RDR) minusInt_RDR (HsVar ah_RDR))
+ [mkSimpleMatch [VarPat c_RDR] rhs placeHolderType tycon_loc]
tycon_loc
))
) {-else-} (
enum_inRange
= mk_easy_FunMonoBind tycon_loc inRange_RDR
- [TuplePatIn [a_Pat, b_Pat] Boxed, c_Pat] [] (
+ [TuplePat [a_Pat, b_Pat] Boxed, c_Pat] [] (
untag_Expr tycon [(a_RDR, ah_RDR)] (
untag_Expr tycon [(b_RDR, bh_RDR)] (
untag_Expr tycon [(c_RDR, ch_RDR)] (
- HsIf (genOpApp (HsVar ch_RDR) geH_RDR (HsVar ah_RDR)) (
- (genOpApp (HsVar ch_RDR) leH_RDR (HsVar bh_RDR))
+ HsIf (genOpApp (HsVar ch_RDR) geInt_RDR (HsVar ah_RDR)) (
+ (genOpApp (HsVar ch_RDR) leInt_RDR (HsVar bh_RDR))
) {-else-} (
false_Expr
) tycon_loc))))
dc
con_arity = dataConSourceArity data_con
- data_con_RDR = qual_orig_name data_con
+ data_con_RDR = getRdrName data_con
as_needed = take con_arity as_RDRs
bs_needed = take con_arity bs_RDRs
cs_needed = take con_arity cs_RDRs
- con_pat xs = ConPatIn data_con_RDR (map VarPatIn xs)
+ con_pat xs = mkConPat data_con_RDR xs
con_expr = mkHsVarApps data_con_RDR cs_needed
--------------------------------------------------------------
single_con_range
= mk_easy_FunMonoBind tycon_loc range_RDR
- [TuplePatIn [con_pat as_needed, con_pat bs_needed] Boxed] [] $
+ [TuplePat [con_pat as_needed, con_pat bs_needed] Boxed] [] $
mkHsDo ListComp stmts tycon_loc
where
stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
++
[ResultStmt con_expr tycon_loc]
- mk_qual a b c = BindStmt (VarPatIn c)
+ mk_qual a b c = BindStmt (VarPat c)
(HsApp (HsVar range_RDR)
(ExplicitTuple [HsVar a, HsVar b] Boxed))
tycon_loc
----------------
single_con_index
= mk_easy_FunMonoBind tycon_loc index_RDR
- [TuplePatIn [con_pat as_needed, con_pat bs_needed] Boxed,
+ [TuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
con_pat cs_needed] [range_size] (
foldl mk_index (mkHsIntLit 0) (zip3 as_needed bs_needed cs_needed))
where
range_size
= mk_easy_FunMonoBind tycon_loc rangeSize_RDR
- [TuplePatIn [a_Pat, b_Pat] Boxed] [] (
+ [TuplePat [a_Pat, b_Pat] Boxed] [] (
genOpApp (
(mkHsApps index_RDR [ExplicitTuple [a_Expr, b_Expr] Boxed,
b_Expr])
------------------
single_con_inRange
= mk_easy_FunMonoBind tycon_loc inRange_RDR
- [TuplePatIn [con_pat as_needed, con_pat bs_needed] Boxed,
+ [TuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
con_pat cs_needed]
[] (
foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed))
(ExplicitList placeHolderType (map mk_pair nullary_cons))]
mk_pair con = ExplicitTuple [HsLit (data_con_str con),
- HsApp (HsVar returnM_RDR) (HsVar (qual_orig_name con))]
+ HsApp (HsVar returnM_RDR) (HsVar (getRdrName con))]
Boxed
read_non_nullary_con data_con
mk_alt e1 e2 = genOpApp e1 alt_RDR e2
bindLex pat = BindStmt pat (HsVar lexP_RDR) loc
result_stmt c as = ResultStmt (HsApp (HsVar returnM_RDR) (con_app c as)) loc
- con_app c as = mkHsVarApps (qual_orig_name c) as
+ con_app c as = mkHsVarApps (getRdrName c) as
- punc_pat s = ConPatIn punc_RDR [LitPatIn (mkHsString s)] -- Punc 'c'
- ident_pat s = ConPatIn ident_RDR [LitPatIn s] -- Ident "foo"
- symbol_pat s = ConPatIn symbol_RDR [LitPatIn s] -- Symbol ">>"
+ punc_pat s = ConPatIn punc_RDR (PrefixCon [LitPat (mkHsString s)]) -- Punc 'c'
+ ident_pat s = ConPatIn ident_RDR (PrefixCon [LitPat s]) -- Ident "foo"
+ symbol_pat s = ConPatIn symbol_RDR (PrefixCon [LitPat s]) -- Symbol ">>"
data_con_str con = mkHsString (occNameUserString (getOccName con))
read_punc c = bindLex (punc_pat c)
- read_arg a = BindStmt (VarPatIn a) (mkHsVarApps step_RDR [readPrec_RDR]) loc
+ read_arg a = BindStmt (VarPat a) (mkHsVarApps step_RDR [readPrec_RDR]) loc
read_field lbl a = read_lbl lbl ++
[read_punc "=",
- BindStmt (VarPatIn a) (mkHsVarApps reset_RDR [readPrec_RDR]) loc]
+ BindStmt (VarPat a) (mkHsVarApps reset_RDR [readPrec_RDR]) loc]
-- When reading field labels we might encounter
-- a = 3
showParen_Expr (HsPar (genOpApp a_Expr ge_RDR (HsLit (HsInt con_prec_plus_one))))
(HsPar (nested_compose_Expr show_thingies)))
where
- data_con_RDR = qual_orig_name data_con
+ data_con_RDR = getRdrName data_con
con_arity = dataConSourceArity data_con
bs_needed = take con_arity bs_RDRs
- con_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
+ con_pat = mkConPat data_con_RDR bs_needed
nullary_con = con_arity == 0
labels = dataConFieldLabels data_con
lab_fields = length labels
(show_arg1:show_arg2:_) = show_args
show_prefix_args = intersperse (HsVar showSpace_RDR) show_args
-
-- Assumption for record syntax: no of fields == no of labelled fields
-- (and in same order)
show_record_args = concat $
gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
| lots_of_constructors
= mk_FunMonoBind (getSrcLoc tycon) rdr_name
- [([VarPatIn a_RDR], HsApp getTag_Expr a_Expr)]
+ [([VarPat a_RDR], HsApp getTag_Expr a_Expr)]
| otherwise
= mk_FunMonoBind (getSrcLoc tycon) rdr_name (map mk_stuff (tyConDataCons tycon))
mk_stuff var
= ([pat], HsLit (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG))))
where
- pat = ConPatIn var_RDR (nOfThem (dataConSourceArity var) WildPatIn)
- var_RDR = qual_orig_name var
+ pat = ConPatIn var_RDR (PrefixCon (nOfThem (dataConSourceArity var) wildPat))
+ var_RDR = getRdrName var
gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
= mk_FunMonoBind (getSrcLoc tycon) rdr_name
- [([ConPatIn mkInt_RDR [VarPatIn a_RDR]],
+ [([mkConPat mkInt_RDR [a_RDR]],
ExprWithTySig (HsApp tagToEnum_Expr a_Expr)
- (HsTyVar (qual_orig_name tycon)))]
+ (HsTyVar (getRdrName tycon)))]
gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag)
= mk_easy_FunMonoBind (getSrcLoc tycon)
= Match (map paren pats) Nothing
(GRHSs (unguardedRHS expr loc) binds placeHolderType)
where
- paren p@(VarPatIn _) = p
- paren other_p = ParPatIn other_p
+ paren p@(VarPat _) = p
+ paren other_p = ParPat other_p
\end{code}
\begin{code}
mkHsIntLit n = HsLit (HsInt n)
mkHsString s = HsString (mkFastString s)
mkHsChar c = HsChar (ord c)
+
+mkConPat con vars = ConPatIn con (PrefixCon (map VarPat vars))
+mkNullaryConPat con = ConPatIn con (PrefixCon [])
\end{code}
ToDo: Better SrcLocs.
compare_gen_Case fun lt eq gt a b
= HsCase (HsPar (HsApp (HsApp (HsVar fun) a) b)) {-of-}
- [mkSimpleMatch [ConPatIn ltTag_RDR []] lt placeHolderType generatedSrcLoc,
- mkSimpleMatch [ConPatIn eqTag_RDR []] eq placeHolderType generatedSrcLoc,
- mkSimpleMatch [ConPatIn gtTag_RDR []] gt placeHolderType generatedSrcLoc]
+ [mkSimpleMatch [mkNullaryConPat ltTag_RDR] lt placeHolderType generatedSrcLoc,
+ mkSimpleMatch [mkNullaryConPat eqTag_RDR] eq placeHolderType generatedSrcLoc,
+ mkSimpleMatch [mkNullaryConPat gtTag_RDR] gt placeHolderType generatedSrcLoc]
generatedSrcLoc
careful_compare_Case ty lt eq gt a b
res = [id | (ty',id) <- tyids, ty `tcEqType` ty']
eq_op_tbl =
- [(charPrimTy, eqH_Char_RDR)
- ,(intPrimTy, eqH_Int_RDR)
- ,(wordPrimTy, eqH_Word_RDR)
- ,(addrPrimTy, eqH_Addr_RDR)
- ,(floatPrimTy, eqH_Float_RDR)
- ,(doublePrimTy, eqH_Double_RDR)
+ [(charPrimTy, eqChar_RDR)
+ ,(intPrimTy, eqInt_RDR)
+ ,(wordPrimTy, eqWord_RDR)
+ ,(addrPrimTy, eqAddr_RDR)
+ ,(floatPrimTy, eqFloat_RDR)
+ ,(doublePrimTy, eqDouble_RDR)
]
lt_op_tbl =
- [(charPrimTy, ltH_Char_RDR)
- ,(intPrimTy, ltH_Int_RDR)
- ,(wordPrimTy, ltH_Word_RDR)
- ,(addrPrimTy, ltH_Addr_RDR)
- ,(floatPrimTy, ltH_Float_RDR)
- ,(doublePrimTy, ltH_Double_RDR)
+ [(charPrimTy, ltChar_RDR)
+ ,(intPrimTy, ltInt_RDR)
+ ,(wordPrimTy, ltWord_RDR)
+ ,(addrPrimTy, ltAddr_RDR)
+ ,(floatPrimTy, ltFloat_RDR)
+ ,(doublePrimTy, ltDouble_RDR)
]
-----------------------------------------------------------------------
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-}
- [mkSimpleMatch [VarPatIn put_tag_here] (untag_Expr tycon more expr) placeHolderType generatedSrcLoc]
+ [mkSimpleMatch [VarPat put_tag_here] (untag_Expr tycon more expr) placeHolderType generatedSrcLoc]
generatedSrcLoc
cmp_tags_Expr :: RdrName -- Comparison op
\end{code}
\begin{code}
-qual_orig_name n = nameRdrName (getName n)
-varUnqual n = mkUnqual varName n
+varUnqual n = mkUnqual OccName.varName n
zz_a_RDR = varUnqual FSLIT("_a")
a_RDR = varUnqual FSLIT("a")
true_Expr = HsVar true_RDR
getTag_Expr = HsVar getTag_RDR
-tagToEnum_Expr = HsVar tagToEnumH_RDR
+tagToEnum_Expr = HsVar tagToEnum_RDR
con2tag_Expr tycon = HsVar (con2tag_RDR tycon)
-wildPat = WildPatIn
-zz_a_Pat = VarPatIn zz_a_RDR
-a_Pat = VarPatIn a_RDR
-b_Pat = VarPatIn b_RDR
-c_Pat = VarPatIn c_RDR
-d_Pat = VarPatIn d_RDR
+wildPat = WildPat placeHolderType
+zz_a_Pat = VarPat zz_a_RDR
+a_Pat = VarPat a_RDR
+b_Pat = VarPat b_RDR
+c_Pat = VarPat c_RDR
+d_Pat = VarPat d_RDR
con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
tag2con_RDR tycon = varUnqual (mkFastString ("tag2con_" ++ occNameString (getOccName tycon) ++ "#"))
maxtag_RDR tycon = varUnqual (mkFastString ("maxtag_" ++ occNameString (getOccName tycon) ++ "#"))
\end{code}
+
+RdrNames for PrimOps. Can't be done in PrelNames, because PrimOp imports
+PrelNames, so PrelNames can't import PrimOp.
+
+\begin{code}
+minusInt_RDR = nameRdrName minusIntName
+eqInt_RDR = nameRdrName eqIntName
+ltInt_RDR = nameRdrName ltIntName
+geInt_RDR = nameRdrName geIntName
+leInt_RDR = nameRdrName leIntName
+eqChar_RDR = nameRdrName eqCharName
+eqWord_RDR = nameRdrName eqWordName
+eqAddr_RDR = nameRdrName eqAddrName
+eqFloat_RDR = nameRdrName eqFloatName
+eqDouble_RDR = nameRdrName eqDoubleName
+ltChar_RDR = nameRdrName ltCharName
+ltWord_RDR = nameRdrName ltWordName
+ltAddr_RDR = nameRdrName ltAddrName
+ltFloat_RDR = nameRdrName ltFloatName
+ltDouble_RDR = nameRdrName ltDoubleName
+tagToEnum_RDR = nameRdrName tagToEnumName
+\end{code}
TcExpr, TcGRHSs, TcGRHS, TcMatch,
TcStmt, TcArithSeqInfo, TcRecordBinds,
TcHsModule, TcDictBinds,
- TcForeignExportDecl,
+ TcForeignDecl,
TypecheckedHsBinds, TypecheckedRuleDecl,
TypecheckedMonoBinds, TypecheckedPat,
mkHsTyApp, mkHsDictApp, mkHsConApp,
mkHsTyLam, mkHsDictLam, mkHsLet,
- simpleHsLitTy,
+ hsLitType, hsPatType,
- collectTypedPatBinders, outPatType,
+ -- re-exported from TcMonad
+ TcId, TcIdSet,
- -- re-exported from TcEnv
- TcId,
-
- zonkTopBinds, zonkId, zonkIdBndr, zonkIdOcc, zonkExpr,
- zonkForeignExports, zonkRules
+ zonkTopBinds, zonkTopDecls, zonkTopExpr,
+ zonkId, zonkIdBndr
) where
#include "HsVersions.h"
import HsSyn -- oodles of it
-- others:
-import Id ( idName, idType, setIdType, Id )
+import Id ( idType, setIdType, Id )
import DataCon ( dataConWrapId )
-import TcEnv ( tcLookupGlobal_maybe, tcExtendGlobalValEnv, TcEnv, TcId )
-import TcMonad
+import TcRnMonad
import Type ( Type )
import TcType ( TcType, tcGetTyVar )
import TcMType ( zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType, zonkTcTyVars )
)
import TysWiredIn ( charTy, stringTy, intTy, integerTy,
mkListTy, mkPArrTy, mkTupleTy, unitTy )
-import CoreSyn ( Expr(..), CoreExpr, CoreBind, Bind(..), CoreAlt, Note(..) )
-import Var ( isId )
-import BasicTypes ( RecFlag(..), Boxity(..), IPName(..), ipNameName )
+import CoreSyn ( CoreExpr )
+import Var ( isId, isLocalVar )
+import VarEnv
+import BasicTypes ( RecFlag(..), Boxity(..), IPName(..), ipNameName, mapIPName )
+import Maybes ( orElse )
import Bag
import Outputable
-import HscTypes ( TyThing(..) )
\end{code}
which have immutable type variables in them.
\begin{code}
-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 TcForeignExportDecl = ForeignDecl TcId
-type TcRuleDecl = RuleDecl TcId TcPat
+type TcHsBinds = HsBinds TcId
+type TcMonoBinds = MonoBinds TcId
+type TcDictBinds = TcMonoBinds
+type TcPat = OutPat TcId
+type TcExpr = HsExpr TcId
+type TcGRHSs = GRHSs TcId
+type TcGRHS = GRHS TcId
+type TcMatch = Match TcId
+type TcStmt = Stmt TcId
+type TcArithSeqInfo = ArithSeqInfo TcId
+type TcRecordBinds = HsRecordBinds TcId
+type TcHsModule = HsModule TcId
+type TcForeignDecl = ForeignDecl TcId
+type TcRuleDecl = RuleDecl TcId
type TypecheckedPat = OutPat Id
-type TypecheckedMonoBinds = MonoBinds Id TypecheckedPat
+type TypecheckedMonoBinds = MonoBinds Id
type TypecheckedDictBinds = TypecheckedMonoBinds
-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 TypecheckedHsBinds = HsBinds Id
+type TypecheckedHsExpr = HsExpr Id
+type TypecheckedArithSeqInfo = ArithSeqInfo Id
+type TypecheckedStmt = Stmt Id
+type TypecheckedMatch = Match Id
type TypecheckedMatchContext = HsMatchContext Id
-type TypecheckedGRHSs = GRHSs Id TypecheckedPat
-type TypecheckedGRHS = GRHS Id TypecheckedPat
-type TypecheckedRecordBinds = HsRecordBinds Id TypecheckedPat
-type TypecheckedHsModule = HsModule Id TypecheckedPat
-type TypecheckedForeignDecl = ForeignDecl Id
-type TypecheckedRuleDecl = RuleDecl Id TypecheckedPat
+type TypecheckedGRHSs = GRHSs Id
+type TypecheckedGRHS = GRHS Id
+type TypecheckedRecordBinds = HsRecordBinds Id
+type TypecheckedHsModule = HsModule Id
+type TypecheckedForeignDecl = ForeignDecl Id
+type TypecheckedRuleDecl = RuleDecl Id
type TypecheckedCoreBind = (Id, CoreExpr)
\end{code}
\end{code}
-------------------------------------------------------
-\begin{code}
-simpleHsLitTy :: HsLit -> TcType
-simpleHsLitTy (HsCharPrim c) = charPrimTy
-simpleHsLitTy (HsStringPrim s) = addrPrimTy
-simpleHsLitTy (HsInt i) = intTy
-simpleHsLitTy (HsInteger i) = integerTy
-simpleHsLitTy (HsIntPrim i) = intPrimTy
-simpleHsLitTy (HsFloatPrim f) = floatPrimTy
-simpleHsLitTy (HsDoublePrim d) = doublePrimTy
-simpleHsLitTy (HsChar c) = charTy
-simpleHsLitTy (HsString str) = stringTy
-\end{code}
-
-
%************************************************************************
%* *
\subsection[mkFailurePair]{Code for pattern-matching and other failures}
%* *
%************************************************************************
-Note: If @outPatType@ doesn't bear a strong resemblance to @exprType@,
+Note: If @hsPatType@ doesn't bear a strong resemblance to @exprType@,
then something is wrong.
\begin{code}
-outPatType :: TypecheckedPat -> Type
-
-outPatType (WildPat ty) = ty
-outPatType (VarPat var) = idType var
-outPatType (LazyPat pat) = outPatType pat
-outPatType (AsPat var pat) = idType var
-outPatType (ConPat _ ty _ _ _) = ty
-outPatType (ListPat ty _) = mkListTy ty
-outPatType (PArrPat ty _) = mkPArrTy ty
-outPatType (TuplePat pats box) = mkTupleTy box (length pats) (map outPatType pats)
-outPatType (RecPat _ ty _ _ _) = ty
-outPatType (SigPat _ ty _) = ty
-outPatType (LitPat lit ty) = ty
-outPatType (NPat lit ty _) = ty
-outPatType (NPlusKPat _ _ ty _ _) = ty
-outPatType (DictPat ds ms) = case (length ds_ms) of
- 0 -> unitTy
- 1 -> idType (head ds_ms)
- n -> mkTupleTy Boxed n (map idType ds_ms)
- where
- ds_ms = ds ++ ms
+hsPatType :: TypecheckedPat -> Type
+
+hsPatType (ParPat pat) = hsPatType pat
+hsPatType (WildPat ty) = ty
+hsPatType (VarPat var) = idType var
+hsPatType (LazyPat pat) = hsPatType pat
+hsPatType (LitPat lit) = hsLitType lit
+hsPatType (AsPat var pat) = idType var
+hsPatType (ListPat _ ty) = mkListTy ty
+hsPatType (PArrPat _ ty) = mkPArrTy ty
+hsPatType (TuplePat pats box) = mkTupleTy box (length pats) (map hsPatType pats)
+hsPatType (ConPatOut _ _ ty _ _) = ty
+hsPatType (SigPatOut _ ty _) = ty
+hsPatType (NPatOut lit ty _) = ty
+hsPatType (NPlusKPatOut id _ _ _) = idType id
+hsPatType (DictPat ds ms) = case (ds ++ ms) of
+ [] -> unitTy
+ [d] -> idType d
+ ds -> mkTupleTy Boxed (length ds) (map idType ds)
+
+
+hsLitType :: HsLit -> TcType
+hsLitType (HsChar c) = charTy
+hsLitType (HsCharPrim c) = charPrimTy
+hsLitType (HsString str) = stringTy
+hsLitType (HsStringPrim s) = addrPrimTy
+hsLitType (HsInt i) = intTy
+hsLitType (HsIntPrim i) = intPrimTy
+hsLitType (HsInteger i) = integerTy
+hsLitType (HsRat _ ty) = ty
+hsLitType (HsFloatPrim f) = floatPrimTy
+hsLitType (HsDoublePrim d) = doublePrimTy
+hsLitType (HsLitLit _ ty) = ty
\end{code}
-
-Nota bene: @DsBinds@ relies on the fact that at least for simple
-tuple patterns @collectTypedPatBinders@ returns the binders in
-the same order as they appear in the tuple.
-
-@collectTypedBinders@ and @collectedTypedPatBinders@ are the exportees.
-
\begin{code}
-collectTypedPatBinders :: TypecheckedPat -> [Id]
-collectTypedPatBinders (VarPat var) = [var]
-collectTypedPatBinders (LazyPat pat) = collectTypedPatBinders pat
-collectTypedPatBinders (AsPat a pat) = a : collectTypedPatBinders pat
-collectTypedPatBinders (SigPat pat _ _) = collectTypedPatBinders pat
-collectTypedPatBinders (ConPat _ _ _ _ pats) = concat (map collectTypedPatBinders pats)
-collectTypedPatBinders (ListPat t pats) = concat (map collectTypedPatBinders pats)
-collectTypedPatBinders (PArrPat t pats) = concat (map collectTypedPatBinders pats)
-collectTypedPatBinders (TuplePat pats _) = concat (map collectTypedPatBinders pats)
-collectTypedPatBinders (RecPat _ _ _ _ fields) = concat (map (\ (f,pat,_) -> collectTypedPatBinders pat)
- fields)
-collectTypedPatBinders (DictPat ds ms) = ds ++ ms
-collectTypedPatBinders (NPlusKPat var _ _ _ _) = [var]
-collectTypedPatBinders any_other_pat = [ {-no binders-} ]
+-- zonkId is used *during* typechecking just to zonk the Id's type
+zonkId :: TcId -> TcM TcId
+zonkId id
+ = zonkTcType (idType id) `thenM` \ ty' ->
+ returnM (setIdType id ty')
\end{code}
the environment manipulation is tiresome.
\begin{code}
--- zonkId is used *during* typechecking just to zonk the Id's type
-zonkId :: TcId -> NF_TcM TcId
-zonkId id
- = zonkTcType (idType id) `thenNF_Tc` \ ty' ->
- returnNF_Tc (setIdType id ty')
+type ZonkEnv = IdEnv Id
+ -- Maps an Id to its zonked version; both have the same Name
+ -- Is only consulted lazily; hence knot-tying
+
+emptyZonkEnv = emptyVarEnv
+
+extendZonkEnv :: ZonkEnv -> [Id] -> ZonkEnv
+extendZonkEnv env ids = extendVarEnvList env [(id,id) | id <- ids]
+
+mkZonkEnv :: [Id] -> ZonkEnv
+mkZonkEnv ids = extendZonkEnv emptyZonkEnv ids
+
+zonkIdOcc :: ZonkEnv -> TcId -> Id
+-- Ids defined in this module should be in the envt;
+-- ignore others. (Actually, data constructors are also
+-- not LocalVars, even when locally defined, but that is fine.)
+--
+-- Actually, Template Haskell works in 'chunks' of declarations, and
+-- an earlier chunk won't be in the 'env' that the zonking phase
+-- carries around. Instead it'll be in the tcg_gbl_env, already fully
+-- zonked. There's no point in looking it up there (except for error
+-- checking), and it's not conveniently to hand; hence the simple
+-- 'orElse' case in the LocalVar branch.
+--
+-- Even without template splices, in module Main, the checking of
+-- 'main' is done as a separte chunk.
+zonkIdOcc env id
+ | isLocalVar id = lookupVarEnv env id `orElse` id
+ | otherwise = id
+
+zonkIdOccs env ids = map (zonkIdOcc env) ids
-- zonkIdBndr is used *after* typechecking to get the Id's type
-- to its final form. The TyVarEnv give
-zonkIdBndr :: TcId -> NF_TcM Id
+zonkIdBndr :: TcId -> TcM Id
zonkIdBndr id
- = zonkTcTypeToType (idType id) `thenNF_Tc` \ ty' ->
- returnNF_Tc (setIdType id ty')
-
-zonkIdOcc :: TcId -> NF_TcM Id
-zonkIdOcc id
- = tcLookupGlobal_maybe (idName id) `thenNF_Tc` \ maybe_id' ->
- -- We're even look up up superclass selectors and constructors;
- -- even though zonking them is a no-op anyway, and the
- -- superclass selectors aren't in the environment anyway.
- -- But we don't want to call isLocalId to find out whether
- -- it's a superclass selector (for example) because that looks
- -- at the IdInfo field, which in turn be in a knot because of
- -- the big knot in typecheckModule
- let
- new_id = case maybe_id' of
- Just (AnId id') -> id'
- other -> id -- WARN( isLocalId id, ppr id ) id
- -- Oops: the warning can give a black hole
- -- because it looks at the idinfo
- in
- returnNF_Tc new_id
+ = zonkTcTypeToType (idType id) `thenM` \ ty' ->
+ returnM (setIdType id ty')
\end{code}
\begin{code}
-zonkTopBinds :: TcMonoBinds -> NF_TcM (TypecheckedMonoBinds, TcEnv)
-zonkTopBinds binds -- Top level is implicitly recursive
- = fixNF_Tc (\ ~(_, new_ids) ->
- tcExtendGlobalValEnv (bagToList new_ids) $
- zonkMonoBinds binds `thenNF_Tc` \ (binds', new_ids) ->
- tcGetEnv `thenNF_Tc` \ env ->
- returnNF_Tc ((binds', env), new_ids)
- ) `thenNF_Tc` \ (stuff, _) ->
- returnNF_Tc stuff
-
-zonkBinds :: TcHsBinds -> NF_TcM (TypecheckedHsBinds, TcEnv)
-
-zonkBinds binds
- = go binds (\ binds' -> tcGetEnv `thenNF_Tc` \ env ->
- returnNF_Tc (binds', env))
- where
- -- go :: TcHsBinds
- -- -> (TypecheckedHsBinds
- -- -> NF_TcM (TypecheckedHsBinds, TcEnv)
- -- )
- -- -> NF_TcM (TypecheckedHsBinds, TcEnv)
-
- go (ThenBinds b1 b2) thing_inside = go b1 $ \ b1' ->
- go b2 $ \ b2' ->
- thing_inside (b1' `ThenBinds` b2')
-
- go EmptyBinds thing_inside = thing_inside EmptyBinds
-
- go (MonoBind bind sigs is_rec) thing_inside
- = ASSERT( null sigs )
- fixNF_Tc (\ ~(_, new_ids) ->
- tcExtendGlobalValEnv (bagToList new_ids) $
- zonkMonoBinds bind `thenNF_Tc` \ (new_bind, new_ids) ->
- thing_inside (mkMonoBind new_bind [] is_rec) `thenNF_Tc` \ stuff ->
- returnNF_Tc (stuff, new_ids)
- ) `thenNF_Tc` \ (stuff, _) ->
- returnNF_Tc stuff
-\end{code}
-
-\begin{code}
--------------------------------------------------------------------------
-zonkMonoBinds :: TcMonoBinds
- -> NF_TcM (TypecheckedMonoBinds, Bag Id)
-
-zonkMonoBinds EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, emptyBag)
-
-zonkMonoBinds (AndMonoBinds mbinds1 mbinds2)
- = zonkMonoBinds mbinds1 `thenNF_Tc` \ (b1', ids1) ->
- zonkMonoBinds mbinds2 `thenNF_Tc` \ (b2', ids2) ->
- returnNF_Tc (b1' `AndMonoBinds` b2',
+zonkTopExpr :: TcExpr -> TcM TypecheckedHsExpr
+zonkTopExpr e = zonkExpr emptyZonkEnv e
+
+zonkTopDecls :: TcMonoBinds -> [TcRuleDecl] -> [TcForeignDecl]
+ -> TcM ([Id],
+ TypecheckedMonoBinds,
+ [TypecheckedForeignDecl],
+ [TypecheckedRuleDecl])
+zonkTopDecls binds rules fords -- Top level is implicitly recursive
+ = fixM (\ ~(new_ids, _, _, _) ->
+ let
+ zonk_env = mkZonkEnv new_ids
+ in
+ zonkMonoBinds zonk_env binds `thenM` \ (binds', new_ids) ->
+ zonkRules zonk_env rules `thenM` \ rules' ->
+ zonkForeignExports zonk_env fords `thenM` \ fords' ->
+
+ returnM (bagToList new_ids, binds', fords', rules')
+ )
+
+zonkTopBinds :: TcMonoBinds -> TcM ([Id], TypecheckedMonoBinds)
+zonkTopBinds binds
+ = fixM (\ ~(new_ids, _) ->
+ let
+ zonk_env = mkZonkEnv new_ids
+ in
+ zonkMonoBinds zonk_env binds `thenM` \ (binds', new_ids) ->
+ returnM (bagToList new_ids, binds')
+ )
+
+---------------------------------------------
+zonkBinds :: ZonkEnv -> TcHsBinds -> TcM (ZonkEnv, TypecheckedHsBinds)
+zonkBinds env EmptyBinds = returnM (env, EmptyBinds)
+
+zonkBinds env (ThenBinds b1 b2)
+ = zonkBinds env b1 `thenM` \ (env1, b1') ->
+ zonkBinds env1 b2 `thenM` \ (env2, b2') ->
+ returnM (env2, b1' `ThenBinds` b2')
+
+zonkBinds env (MonoBind bind sigs is_rec)
+ = ASSERT( null sigs )
+ fixM (\ ~(env1, _) ->
+ zonkMonoBinds env1 bind `thenM` \ (new_bind, new_ids) ->
+ let
+ env2 = extendZonkEnv env (bagToList new_ids)
+ in
+ returnM (env2, mkMonoBind new_bind [] is_rec)
+ )
+
+---------------------------------------------
+zonkMonoBinds :: ZonkEnv -> TcMonoBinds
+ -> TcM (TypecheckedMonoBinds, Bag Id)
+
+zonkMonoBinds env EmptyMonoBinds = returnM (EmptyMonoBinds, emptyBag)
+
+zonkMonoBinds env (AndMonoBinds mbinds1 mbinds2)
+ = zonkMonoBinds env mbinds1 `thenM` \ (b1', ids1) ->
+ zonkMonoBinds env mbinds2 `thenM` \ (b2', ids2) ->
+ returnM (b1' `AndMonoBinds` b2',
ids1 `unionBags` ids2)
-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 env (PatMonoBind pat grhss locn)
+ = zonkPat env pat `thenM` \ (new_pat, ids) ->
+ zonkGRHSs env grhss `thenM` \ new_grhss ->
+ returnM (PatMonoBind new_pat new_grhss locn, ids)
-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 env (VarMonoBind var expr)
+ = zonkIdBndr var `thenM` \ new_var ->
+ zonkExpr env expr `thenM` \ new_expr ->
+ returnM (VarMonoBind new_var new_expr, 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 env (CoreMonoBind var core_expr)
+ = zonkIdBndr var `thenM` \ new_var ->
+ returnM (CoreMonoBind new_var core_expr, 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 env (FunMonoBind var inf ms locn)
+ = zonkIdBndr var `thenM` \ new_var ->
+ mappM (zonkMatch env) ms `thenM` \ new_ms ->
+ returnM (FunMonoBind new_var inf new_ms locn, unitBag new_var)
-zonkMonoBinds (AbsBinds tyvars dicts exports inlines val_bind)
- = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
+zonkMonoBinds env (AbsBinds tyvars dicts exports inlines val_bind)
+ = mappM zonkTcTyVarToTyVar tyvars `thenM` \ new_tyvars ->
-- 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_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, _) ->
+ mappM zonkIdBndr dicts `thenM` \ new_dicts ->
+ fixM (\ ~(_, _, val_bind_ids) ->
+ let
+ env1 = extendZonkEnv (extendZonkEnv env new_dicts)
+ (bagToList val_bind_ids)
+ in
+ zonkMonoBinds env1 val_bind `thenM` \ (new_val_bind, val_bind_ids) ->
+ mappM (zonkExport env1) exports `thenM` \ new_exports ->
+ returnM (new_val_bind, new_exports, val_bind_ids)
+ ) `thenM ` \ (new_val_bind, new_exports, _) ->
let
- new_globals = listToBag [global | (_, global, local) <- new_exports]
+ new_globals = listToBag [global | (_, global, local) <- new_exports]
in
- returnNF_Tc (AbsBinds new_tyvars new_dicts new_exports inlines new_val_bind,
+ returnM (AbsBinds new_tyvars new_dicts new_exports inlines new_val_bind,
new_globals)
where
- zonkExport (tyvars, global, local)
- = zonkTcTyVars tyvars `thenNF_Tc` \ tys ->
+ zonkExport env (tyvars, global, local)
+ = zonkTcTyVars tyvars `thenM` \ tys ->
let
new_tyvars = map (tcGetTyVar "zonkExport") tys
-- This isn't the binding occurrence of these tyvars
-- but they should *be* tyvars. Hence tcGetTyVar.
in
- zonkIdBndr global `thenNF_Tc` \ new_global ->
- zonkIdOcc local `thenNF_Tc` \ new_local ->
- returnNF_Tc (new_tyvars, new_global, new_local)
+ zonkIdBndr global `thenM` \ new_global ->
+ returnM (new_tyvars, new_global, zonkIdOcc env local)
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-zonkMatch :: TcMatch -> NF_TcM TypecheckedMatch
+zonkMatch :: ZonkEnv -> TcMatch -> TcM TypecheckedMatch
-zonkMatch (Match pats _ grhss)
- = zonkPats pats `thenNF_Tc` \ (new_pats, new_ids) ->
- tcExtendGlobalValEnv (bagToList new_ids) $
- zonkGRHSs grhss `thenNF_Tc` \ new_grhss ->
- returnNF_Tc (Match new_pats Nothing new_grhss)
+zonkMatch env (Match pats _ grhss)
+ = zonkPats env pats `thenM` \ (new_pats, new_ids) ->
+ zonkGRHSs (extendZonkEnv env (bagToList new_ids)) grhss `thenM` \ new_grhss ->
+ returnM (Match new_pats Nothing new_grhss)
-------------------------------------------------------------------------
-zonkGRHSs :: TcGRHSs
- -> NF_TcM TypecheckedGRHSs
+zonkGRHSs :: ZonkEnv -> TcGRHSs -> TcM TypecheckedGRHSs
-zonkGRHSs (GRHSs grhss binds ty)
- = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
- tcSetEnv new_env $
+zonkGRHSs env (GRHSs grhss binds ty)
+ = zonkBinds env binds `thenM` \ (new_env, new_binds) ->
let
zonk_grhs (GRHS guarded locn)
- = zonkStmts guarded `thenNF_Tc` \ new_guarded ->
- returnNF_Tc (GRHS new_guarded locn)
+ = zonkStmts new_env guarded `thenM` \ new_guarded ->
+ returnM (GRHS new_guarded locn)
in
- mapNF_Tc zonk_grhs grhss `thenNF_Tc` \ new_grhss ->
- zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
- returnNF_Tc (GRHSs new_grhss new_binds new_ty)
+ mappM zonk_grhs grhss `thenM` \ new_grhss ->
+ zonkTcTypeToType ty `thenM` \ new_ty ->
+ returnM (GRHSs new_grhss new_binds new_ty)
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-zonkExpr :: TcExpr -> NF_TcM TypecheckedHsExpr
+zonkExpr :: ZonkEnv -> TcExpr -> TcM TypecheckedHsExpr
-zonkExpr (HsVar id)
- = zonkIdOcc id `thenNF_Tc` \ id' ->
- returnNF_Tc (HsVar id')
+zonkExpr env (HsVar id)
+ = returnM (HsVar (zonkIdOcc env id))
-zonkExpr (HsIPVar id)
- = mapIPNameTc zonkIdOcc id `thenNF_Tc` \ id' ->
- returnNF_Tc (HsIPVar id')
+zonkExpr env (HsIPVar id)
+ = returnM (HsIPVar (mapIPName (zonkIdOcc env) id))
-zonkExpr (HsLit (HsRat f ty))
- = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
- returnNF_Tc (HsLit (HsRat f new_ty))
+zonkExpr env (HsLit (HsRat f ty))
+ = zonkTcTypeToType ty `thenM` \ new_ty ->
+ returnM (HsLit (HsRat f new_ty))
-zonkExpr (HsLit (HsLitLit lit ty))
- = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
- returnNF_Tc (HsLit (HsLitLit lit new_ty))
+zonkExpr env (HsLit (HsLitLit lit ty))
+ = zonkTcTypeToType ty `thenM` \ new_ty ->
+ returnM (HsLit (HsLitLit lit new_ty))
-zonkExpr (HsLit lit)
- = returnNF_Tc (HsLit lit)
+zonkExpr env (HsLit lit)
+ = returnM (HsLit lit)
-- HsOverLit doesn't appear in typechecker output
-zonkExpr (HsLam match)
- = zonkMatch match `thenNF_Tc` \ new_match ->
- returnNF_Tc (HsLam new_match)
-
-zonkExpr (HsApp e1 e2)
- = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
- zonkExpr e2 `thenNF_Tc` \ new_e2 ->
- returnNF_Tc (HsApp new_e1 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 (NegApp _ _) = panic "zonkExpr: NegApp"
-zonkExpr (HsPar _) = panic "zonkExpr: HsPar"
-
-zonkExpr (SectionL expr op)
- = zonkExpr expr `thenNF_Tc` \ new_expr ->
- zonkExpr op `thenNF_Tc` \ new_op ->
- returnNF_Tc (SectionL new_expr new_op)
-
-zonkExpr (SectionR op expr)
- = zonkExpr op `thenNF_Tc` \ new_op ->
- zonkExpr expr `thenNF_Tc` \ new_expr ->
- returnNF_Tc (SectionR new_op new_expr)
-
-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 (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 (HsLet binds expr)
- = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
- tcSetEnv new_env $
- zonkExpr expr `thenNF_Tc` \ new_expr ->
- returnNF_Tc (HsLet new_binds new_expr)
-
-zonkExpr (HsWith expr binds is_with)
- = zonkIPBinds binds `thenNF_Tc` \ new_binds ->
- tcExtendGlobalValEnv (map (ipNameName . fst) new_binds) $
- zonkExpr expr `thenNF_Tc` \ new_expr ->
- returnNF_Tc (HsWith new_expr new_binds is_with)
+zonkExpr env (HsLam match)
+ = zonkMatch env match `thenM` \ new_match ->
+ returnM (HsLam new_match)
+
+zonkExpr env (HsApp e1 e2)
+ = zonkExpr env e1 `thenM` \ new_e1 ->
+ zonkExpr env e2 `thenM` \ new_e2 ->
+ returnM (HsApp new_e1 new_e2)
+
+zonkExpr env (HsBracketOut body bs)
+ = mappM zonk_b bs `thenM` \ bs' ->
+ returnM (HsBracketOut body bs')
+ where
+ zonk_b (n,e) = zonkExpr env e `thenM` \ e' ->
+ returnM (n,e')
+
+zonkExpr env (HsSplice n e) = WARN( True, ppr e ) -- Should not happen
+ returnM (HsSplice n e)
+
+zonkExpr env (OpApp e1 op fixity e2)
+ = zonkExpr env e1 `thenM` \ new_e1 ->
+ zonkExpr env op `thenM` \ new_op ->
+ zonkExpr env e2 `thenM` \ new_e2 ->
+ returnM (OpApp new_e1 new_op fixity new_e2)
+
+zonkExpr env (NegApp _ _) = panic "zonkExpr env: NegApp"
+
+zonkExpr env (HsPar e)
+ = zonkExpr env e `thenM` \new_e ->
+ returnM (HsPar new_e)
+
+zonkExpr env (SectionL expr op)
+ = zonkExpr env expr `thenM` \ new_expr ->
+ zonkExpr env op `thenM` \ new_op ->
+ returnM (SectionL new_expr new_op)
+
+zonkExpr env (SectionR op expr)
+ = zonkExpr env op `thenM` \ new_op ->
+ zonkExpr env expr `thenM` \ new_expr ->
+ returnM (SectionR new_op new_expr)
+
+zonkExpr env (HsCase expr ms src_loc)
+ = zonkExpr env expr `thenM` \ new_expr ->
+ mappM (zonkMatch env) ms `thenM` \ new_ms ->
+ returnM (HsCase new_expr new_ms src_loc)
+
+zonkExpr env (HsIf e1 e2 e3 src_loc)
+ = zonkExpr env e1 `thenM` \ new_e1 ->
+ zonkExpr env e2 `thenM` \ new_e2 ->
+ zonkExpr env e3 `thenM` \ new_e3 ->
+ returnM (HsIf new_e1 new_e2 new_e3 src_loc)
+
+zonkExpr env (HsLet binds expr)
+ = zonkBinds env binds `thenM` \ (new_env, new_binds) ->
+ zonkExpr new_env expr `thenM` \ new_expr ->
+ returnM (HsLet new_binds new_expr)
+
+zonkExpr env (HsWith expr binds is_with)
+ = mappM zonk_ip_bind binds `thenM` \ new_binds ->
+ let
+ env1 = extendZonkEnv env (map (ipNameName . fst) new_binds)
+ in
+ zonkExpr env1 expr `thenM` \ new_expr ->
+ returnM (HsWith new_expr new_binds is_with)
where
- zonkIPBinds = mapNF_Tc zonkIPBind
- zonkIPBind (n, e)
- = mapIPNameTc zonkIdBndr n `thenNF_Tc` \ n' ->
- zonkExpr e `thenNF_Tc` \ e' ->
- returnNF_Tc (n', e')
-
-zonkExpr (HsDo do_or_lc stmts ids ty src_loc)
- = zonkStmts stmts `thenNF_Tc` \ new_stmts ->
- zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
- mapNF_Tc zonkIdOcc ids `thenNF_Tc` \ new_ids ->
- returnNF_Tc (HsDo do_or_lc new_stmts new_ids new_ty src_loc)
-
-zonkExpr (ExplicitList ty exprs)
- = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
- mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs ->
- returnNF_Tc (ExplicitList new_ty new_exprs)
-
-zonkExpr (ExplicitPArr ty exprs)
- = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
- mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs ->
- returnNF_Tc (ExplicitPArr new_ty new_exprs)
-
-zonkExpr (ExplicitTuple exprs boxed)
- = mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs ->
- returnNF_Tc (ExplicitTuple new_exprs boxed)
-
-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 (RecordUpd _ _) = panic "zonkExpr:RecordUpd"
-
-zonkExpr (RecordUpdOut expr in_ty out_ty rbinds)
- = zonkExpr expr `thenNF_Tc` \ new_expr ->
- zonkTcTypeToType in_ty `thenNF_Tc` \ new_in_ty ->
- zonkTcTypeToType out_ty `thenNF_Tc` \ new_out_ty ->
- zonkRbinds rbinds `thenNF_Tc` \ new_rbinds ->
- returnNF_Tc (RecordUpdOut new_expr new_in_ty new_out_ty new_rbinds)
-
-zonkExpr (ExprWithTySig _ _) = panic "zonkExpr:ExprWithTySig"
-zonkExpr (ArithSeqIn _) = panic "zonkExpr:ArithSeqIn"
-zonkExpr (PArrSeqIn _) = panic "zonkExpr:PArrSeqIn"
-
-zonkExpr (ArithSeqOut expr info)
- = zonkExpr expr `thenNF_Tc` \ new_expr ->
- zonkArithSeq info `thenNF_Tc` \ new_info ->
- returnNF_Tc (ArithSeqOut new_expr new_info)
-
-zonkExpr (PArrSeqOut expr info)
- = zonkExpr expr `thenNF_Tc` \ new_expr ->
- zonkArithSeq info `thenNF_Tc` \ new_info ->
- returnNF_Tc (PArrSeqOut new_expr new_info)
-
-zonkExpr (HsCCall 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 (HsCCall fun new_args may_gc is_casm new_result_ty)
-
-zonkExpr (HsSCC lbl expr)
- = zonkExpr expr `thenNF_Tc` \ new_expr ->
- returnNF_Tc (HsSCC lbl new_expr)
-
-zonkExpr (TyLam tyvars expr)
- = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
+ zonk_ip_bind (n, e)
+ = mapIPNameTc zonkIdBndr n `thenM` \ n' ->
+ zonkExpr env e `thenM` \ e' ->
+ returnM (n', e')
+
+zonkExpr env (HsDo do_or_lc stmts ids ty src_loc)
+ = zonkStmts env stmts `thenM` \ new_stmts ->
+ zonkTcTypeToType ty `thenM` \ new_ty ->
+ returnM (HsDo do_or_lc new_stmts
+ (zonkIdOccs env ids)
+ new_ty src_loc)
+
+zonkExpr env (ExplicitList ty exprs)
+ = zonkTcTypeToType ty `thenM` \ new_ty ->
+ mappM (zonkExpr env) exprs `thenM` \ new_exprs ->
+ returnM (ExplicitList new_ty new_exprs)
+
+zonkExpr env (ExplicitPArr ty exprs)
+ = zonkTcTypeToType ty `thenM` \ new_ty ->
+ mappM (zonkExpr env) exprs `thenM` \ new_exprs ->
+ returnM (ExplicitPArr new_ty new_exprs)
+
+zonkExpr env (ExplicitTuple exprs boxed)
+ = mappM (zonkExpr env) exprs `thenM` \ new_exprs ->
+ returnM (ExplicitTuple new_exprs boxed)
+
+zonkExpr env (RecordConOut data_con con_expr rbinds)
+ = zonkExpr env con_expr `thenM` \ new_con_expr ->
+ zonkRbinds env rbinds `thenM` \ new_rbinds ->
+ returnM (RecordConOut data_con new_con_expr new_rbinds)
+
+zonkExpr env (RecordUpd _ _) = panic "zonkExpr env:RecordUpd"
+
+zonkExpr env (RecordUpdOut expr in_ty out_ty rbinds)
+ = zonkExpr env expr `thenM` \ new_expr ->
+ zonkTcTypeToType in_ty `thenM` \ new_in_ty ->
+ zonkTcTypeToType out_ty `thenM` \ new_out_ty ->
+ zonkRbinds env rbinds `thenM` \ new_rbinds ->
+ returnM (RecordUpdOut new_expr new_in_ty new_out_ty new_rbinds)
+
+zonkExpr env (ExprWithTySig _ _) = panic "zonkExpr env:ExprWithTySig"
+zonkExpr env (ArithSeqIn _) = panic "zonkExpr env:ArithSeqIn"
+zonkExpr env (PArrSeqIn _) = panic "zonkExpr env:PArrSeqIn"
+
+zonkExpr env (ArithSeqOut expr info)
+ = zonkExpr env expr `thenM` \ new_expr ->
+ zonkArithSeq env info `thenM` \ new_info ->
+ returnM (ArithSeqOut new_expr new_info)
+
+zonkExpr env (PArrSeqOut expr info)
+ = zonkExpr env expr `thenM` \ new_expr ->
+ zonkArithSeq env info `thenM` \ new_info ->
+ returnM (PArrSeqOut new_expr new_info)
+
+zonkExpr env (HsCCall fun args may_gc is_casm result_ty)
+ = mappM (zonkExpr env) args `thenM` \ new_args ->
+ zonkTcTypeToType result_ty `thenM` \ new_result_ty ->
+ returnM (HsCCall fun new_args may_gc is_casm new_result_ty)
+
+zonkExpr env (HsSCC lbl expr)
+ = zonkExpr env expr `thenM` \ new_expr ->
+ returnM (HsSCC lbl new_expr)
+
+zonkExpr env (TyLam tyvars expr)
+ = mappM zonkTcTyVarToTyVar tyvars `thenM` \ new_tyvars ->
-- No need to extend tyvar env; see AbsBinds
- zonkExpr expr `thenNF_Tc` \ new_expr ->
- returnNF_Tc (TyLam new_tyvars new_expr)
+ zonkExpr env expr `thenM` \ new_expr ->
+ returnM (TyLam new_tyvars new_expr)
-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 env (TyApp expr tys)
+ = zonkExpr env expr `thenM` \ new_expr ->
+ mappM zonkTcTypeToType tys `thenM` \ new_tys ->
+ returnM (TyApp new_expr new_tys)
-zonkExpr (DictLam dicts expr)
- = mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
- tcExtendGlobalValEnv new_dicts $
- zonkExpr expr `thenNF_Tc` \ new_expr ->
- returnNF_Tc (DictLam new_dicts new_expr)
+zonkExpr env (DictLam dicts expr)
+ = mappM zonkIdBndr dicts `thenM` \ new_dicts ->
+ let
+ env1 = extendZonkEnv env new_dicts
+ in
+ zonkExpr env1 expr `thenM` \ new_expr ->
+ returnM (DictLam new_dicts 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)
+zonkExpr env (DictApp expr dicts)
+ = zonkExpr env expr `thenM` \ new_expr ->
+ returnM (DictApp new_expr (zonkIdOccs env dicts))
-------------------------------------------------------------------------
-zonkArithSeq :: TcArithSeqInfo -> NF_TcM TypecheckedArithSeqInfo
+zonkArithSeq :: ZonkEnv -> TcArithSeqInfo -> TcM TypecheckedArithSeqInfo
-zonkArithSeq (From e)
- = zonkExpr e `thenNF_Tc` \ new_e ->
- returnNF_Tc (From new_e)
+zonkArithSeq env (From e)
+ = zonkExpr env e `thenM` \ new_e ->
+ returnM (From new_e)
-zonkArithSeq (FromThen e1 e2)
- = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
- zonkExpr e2 `thenNF_Tc` \ new_e2 ->
- returnNF_Tc (FromThen new_e1 new_e2)
+zonkArithSeq env (FromThen e1 e2)
+ = zonkExpr env e1 `thenM` \ new_e1 ->
+ zonkExpr env e2 `thenM` \ new_e2 ->
+ returnM (FromThen new_e1 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 env (FromTo e1 e2)
+ = zonkExpr env e1 `thenM` \ new_e1 ->
+ zonkExpr env e2 `thenM` \ new_e2 ->
+ returnM (FromTo new_e1 new_e2)
-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)
+zonkArithSeq env (FromThenTo e1 e2 e3)
+ = zonkExpr env e1 `thenM` \ new_e1 ->
+ zonkExpr env e2 `thenM` \ new_e2 ->
+ zonkExpr env e3 `thenM` \ new_e3 ->
+ returnM (FromThenTo new_e1 new_e2 new_e3)
-------------------------------------------------------------------------
-zonkStmts :: [TcStmt]
- -> NF_TcM [TypecheckedStmt]
-
-zonkStmts [] = returnNF_Tc []
-
-zonkStmts (ParStmtOut bndrstmtss : stmts)
- = mapNF_Tc (mapNF_Tc zonkId) bndrss `thenNF_Tc` \ new_bndrss ->
- let new_binders = concat new_bndrss in
- mapNF_Tc zonkStmts stmtss `thenNF_Tc` \ new_stmtss ->
- tcExtendGlobalValEnv new_binders $
- zonkStmts stmts `thenNF_Tc` \ new_stmts ->
- returnNF_Tc (ParStmtOut (zip new_bndrss new_stmtss) : new_stmts)
- where (bndrss, stmtss) = unzip bndrstmtss
-
-zonkStmts (ResultStmt expr locn : stmts)
- = zonkExpr expr `thenNF_Tc` \ new_expr ->
- zonkStmts stmts `thenNF_Tc` \ new_stmts ->
- returnNF_Tc (ResultStmt new_expr locn : new_stmts)
-
-zonkStmts (ExprStmt expr ty locn : stmts)
- = zonkExpr expr `thenNF_Tc` \ new_expr ->
- zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
- zonkStmts stmts `thenNF_Tc` \ new_stmts ->
- returnNF_Tc (ExprStmt new_expr new_ty locn : new_stmts)
-
-zonkStmts (LetStmt binds : stmts)
- = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
- tcSetEnv new_env $
- zonkStmts stmts `thenNF_Tc` \ new_stmts ->
- returnNF_Tc (LetStmt new_binds : new_stmts)
-
-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 stmts `thenNF_Tc` \ new_stmts ->
- returnNF_Tc (BindStmt new_pat new_expr locn : new_stmts)
+zonkStmts :: ZonkEnv -> [TcStmt] -> TcM [TypecheckedStmt]
+
+zonkStmts env [] = returnM []
+
+zonkStmts env (ParStmtOut bndrstmtss : stmts)
+ = mappM (mappM zonkId) bndrss `thenM` \ new_bndrss ->
+ mappM (zonkStmts env) stmtss `thenM` \ new_stmtss ->
+ let
+ new_binders = concat new_bndrss
+ env1 = extendZonkEnv env new_binders
+ in
+ zonkStmts env1 stmts `thenM` \ new_stmts ->
+ returnM (ParStmtOut (zip new_bndrss new_stmtss) : new_stmts)
+ where
+ (bndrss, stmtss) = unzip bndrstmtss
+
+zonkStmts env (ResultStmt expr locn : stmts)
+ = zonkExpr env expr `thenM` \ new_expr ->
+ zonkStmts env stmts `thenM` \ new_stmts ->
+ returnM (ResultStmt new_expr locn : new_stmts)
+
+zonkStmts env (ExprStmt expr ty locn : stmts)
+ = zonkExpr env expr `thenM` \ new_expr ->
+ zonkTcTypeToType ty `thenM` \ new_ty ->
+ zonkStmts env stmts `thenM` \ new_stmts ->
+ returnM (ExprStmt new_expr new_ty locn : new_stmts)
+
+zonkStmts env (LetStmt binds : stmts)
+ = zonkBinds env binds `thenM` \ (new_env, new_binds) ->
+ zonkStmts new_env stmts `thenM` \ new_stmts ->
+ returnM (LetStmt new_binds : new_stmts)
+
+zonkStmts env (BindStmt pat expr locn : stmts)
+ = zonkExpr env expr `thenM` \ new_expr ->
+ zonkPat env pat `thenM` \ (new_pat, new_ids) ->
+ let
+ env1 = extendZonkEnv env (bagToList new_ids)
+ in
+ zonkStmts env1 stmts `thenM` \ new_stmts ->
+ returnM (BindStmt new_pat new_expr locn : new_stmts)
-------------------------------------------------------------------------
-zonkRbinds :: TcRecordBinds -> NF_TcM TypecheckedRecordBinds
+zonkRbinds :: ZonkEnv -> TcRecordBinds -> TcM TypecheckedRecordBinds
-zonkRbinds rbinds
- = mapNF_Tc zonk_rbind rbinds
+zonkRbinds env rbinds
+ = mappM zonk_rbind rbinds
where
- zonk_rbind (field, expr, pun)
- = zonkExpr expr `thenNF_Tc` \ new_expr ->
- zonkIdOcc field `thenNF_Tc` \ new_field ->
- returnNF_Tc (new_field, new_expr, pun)
+ zonk_rbind (field, expr)
+ = zonkExpr env expr `thenM` \ new_expr ->
+ returnM (zonkIdOcc env field, new_expr)
-------------------------------------------------------------------------
-mapIPNameTc :: (a -> NF_TcM b) -> IPName a -> NF_TcM (IPName b)
-mapIPNameTc f (Dupable n) = f n `thenNF_Tc` \ r -> returnNF_Tc (Dupable r)
-mapIPNameTc f (Linear n) = f n `thenNF_Tc` \ r -> returnNF_Tc (Linear r)
+mapIPNameTc :: (a -> TcM b) -> IPName a -> TcM (IPName b)
+mapIPNameTc f (Dupable n) = f n `thenM` \ r -> returnM (Dupable r)
+mapIPNameTc f (Linear n) = f n `thenM` \ r -> returnM (Linear r)
\end{code}
%************************************************************************
\begin{code}
-zonkPat :: TcPat -> NF_TcM (TypecheckedPat, Bag Id)
-
-zonkPat (WildPat ty)
- = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
- returnNF_Tc (WildPat new_ty, emptyBag)
-
-zonkPat (VarPat v)
- = zonkIdBndr v `thenNF_Tc` \ new_v ->
- returnNF_Tc (VarPat new_v, unitBag new_v)
-
-zonkPat (LazyPat pat)
- = zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
- returnNF_Tc (LazyPat new_pat, 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 (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 (PArrPat ty pats)
- = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
- zonkPats pats `thenNF_Tc` \ (new_pats, ids) ->
- returnNF_Tc (PArrPat new_ty new_pats, ids)
-
-zonkPat (TuplePat pats boxed)
- = zonkPats pats `thenNF_Tc` \ (new_pats, ids) ->
- returnNF_Tc (TuplePat new_pats boxed, ids)
-
-zonkPat (ConPat n ty tvs dicts pats)
- = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
- mapNF_Tc zonkTcTyVarToTyVar tvs `thenNF_Tc` \ new_tvs ->
- mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
- tcExtendGlobalValEnv new_dicts $
- zonkPats pats `thenNF_Tc` \ (new_pats, ids) ->
- returnNF_Tc (ConPat n new_ty new_tvs new_dicts new_pats,
+zonkPat :: ZonkEnv -> TcPat -> TcM (TypecheckedPat, Bag Id)
+
+zonkPat env (ParPat p)
+ = zonkPat env p `thenM` \ (new_p, ids) ->
+ returnM (ParPat new_p, ids)
+
+zonkPat env (WildPat ty)
+ = zonkTcTypeToType ty `thenM` \ new_ty ->
+ returnM (WildPat new_ty, emptyBag)
+
+zonkPat env (VarPat v)
+ = zonkIdBndr v `thenM` \ new_v ->
+ returnM (VarPat new_v, unitBag new_v)
+
+zonkPat env (LazyPat pat)
+ = zonkPat env pat `thenM` \ (new_pat, ids) ->
+ returnM (LazyPat new_pat, ids)
+
+zonkPat env (AsPat n pat)
+ = zonkIdBndr n `thenM` \ new_n ->
+ zonkPat env pat `thenM` \ (new_pat, ids) ->
+ returnM (AsPat new_n new_pat, new_n `consBag` ids)
+
+zonkPat env (ListPat pats ty)
+ = zonkTcTypeToType ty `thenM` \ new_ty ->
+ zonkPats env pats `thenM` \ (new_pats, ids) ->
+ returnM (ListPat new_pats new_ty, ids)
+
+zonkPat env (PArrPat pats ty)
+ = zonkTcTypeToType ty `thenM` \ new_ty ->
+ zonkPats env pats `thenM` \ (new_pats, ids) ->
+ returnM (PArrPat new_pats new_ty, ids)
+
+zonkPat env (TuplePat pats boxed)
+ = zonkPats env pats `thenM` \ (new_pats, ids) ->
+ returnM (TuplePat new_pats boxed, ids)
+
+zonkPat env (ConPatOut n stuff ty tvs dicts)
+ = zonkTcTypeToType ty `thenM` \ new_ty ->
+ mappM zonkTcTyVarToTyVar tvs `thenM` \ new_tvs ->
+ mappM zonkIdBndr dicts `thenM` \ new_dicts ->
+ let
+ env1 = extendZonkEnv env new_dicts
+ in
+ zonkConStuff env stuff `thenM` \ (new_stuff, ids) ->
+ returnM (ConPatOut n new_stuff new_ty new_tvs new_dicts,
listToBag new_dicts `unionBags` ids)
-zonkPat (RecPat n ty tvs dicts rpats)
- = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
- mapNF_Tc zonkTcTyVarToTyVar tvs `thenNF_Tc` \ new_tvs ->
- 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_dicts `unionBags` unionManyBags ids_s)
- where
- 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 (SigPat pat ty expr)
- = zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
- zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
- zonkExpr expr `thenNF_Tc` \ new_expr ->
- returnNF_Tc (SigPat new_pat new_ty new_expr, ids)
-
-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,
+zonkPat env (LitPat lit) = returnM (LitPat lit, emptyBag)
+
+zonkPat env (SigPatOut pat ty expr)
+ = zonkPat env pat `thenM` \ (new_pat, ids) ->
+ zonkTcTypeToType ty `thenM` \ new_ty ->
+ zonkExpr env expr `thenM` \ new_expr ->
+ returnM (SigPatOut new_pat new_ty new_expr, ids)
+
+zonkPat env (NPatOut lit ty expr)
+ = zonkTcTypeToType ty `thenM` \ new_ty ->
+ zonkExpr env expr `thenM` \ new_expr ->
+ returnM (NPatOut lit new_ty new_expr, emptyBag)
+
+zonkPat env (NPlusKPatOut n k e1 e2)
+ = zonkIdBndr n `thenM` \ new_n ->
+ zonkExpr env e1 `thenM` \ new_e1 ->
+ zonkExpr env e2 `thenM` \ new_e2 ->
+ returnM (NPlusKPatOut new_n k new_e1 new_e2, unitBag new_n)
+
+zonkPat env (DictPat ds ms)
+ = mappM zonkIdBndr ds `thenM` \ new_ds ->
+ mappM zonkIdBndr ms `thenM` \ new_ms ->
+ returnM (DictPat new_ds new_ms,
listToBag new_ds `unionBags` listToBag new_ms)
+---------------------------
+zonkConStuff env (PrefixCon pats)
+ = zonkPats env pats `thenM` \ (new_pats, ids) ->
+ returnM (PrefixCon new_pats, ids)
-zonkPats []
- = returnNF_Tc ([], emptyBag)
+zonkConStuff env (InfixCon p1 p2)
+ = zonkPat env p1 `thenM` \ (new_p1, ids1) ->
+ zonkPat env p2 `thenM` \ (new_p2, ids2) ->
+ returnM (InfixCon new_p1 new_p2, 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)
+zonkConStuff env (RecCon rpats)
+ = mapAndUnzipM zonk_rpat rpats `thenM` \ (new_rpats, ids_s) ->
+ returnM (RecCon new_rpats, unionManyBags ids_s)
+ where
+ zonk_rpat (f, pat)
+ = zonkPat env pat `thenM` \ (new_pat, ids) ->
+ returnM ((f, new_pat), ids)
+
+---------------------------
+zonkPats env []
+ = returnM ([], emptyBag)
+
+zonkPats env (pat:pats)
+ = zonkPat env pat `thenM` \ (pat', ids1) ->
+ zonkPats env pats `thenM` \ (pats', ids2) ->
+ returnM (pat':pats', ids1 `unionBags` ids2)
\end{code}
%************************************************************************
\begin{code}
-zonkForeignExports :: [TcForeignExportDecl] -> NF_TcM [TypecheckedForeignDecl]
-zonkForeignExports ls = mapNF_Tc zonkForeignExport ls
+zonkForeignExports :: ZonkEnv -> [TcForeignDecl] -> TcM [TypecheckedForeignDecl]
+zonkForeignExports env ls = mappM (zonkForeignExport env) ls
-zonkForeignExport :: TcForeignExportDecl -> NF_TcM (TypecheckedForeignDecl)
-zonkForeignExport (ForeignExport i hs_ty spec isDeprec src_loc) =
- zonkIdOcc i `thenNF_Tc` \ i' ->
- returnNF_Tc (ForeignExport i' undefined spec isDeprec src_loc)
+zonkForeignExport :: ZonkEnv -> TcForeignDecl -> TcM (TypecheckedForeignDecl)
+zonkForeignExport env (ForeignExport i hs_ty spec isDeprec src_loc) =
+ returnM (ForeignExport (zonkIdOcc env i) undefined spec isDeprec src_loc)
\end{code}
\begin{code}
-zonkRules :: [TcRuleDecl] -> NF_TcM [TypecheckedRuleDecl]
-zonkRules rs = mapNF_Tc zonkRule rs
+zonkRules :: ZonkEnv -> [TcRuleDecl] -> TcM [TypecheckedRuleDecl]
+zonkRules env rs = mappM (zonkRule env) rs
-zonkRule (HsRule name act vars lhs rhs loc)
- = mapNF_Tc zonk_bndr vars `thenNF_Tc` \ new_bndrs ->
- tcExtendGlobalValEnv (filter isId new_bndrs) $
+zonkRule env (HsRule name act vars lhs rhs loc)
+ = mappM zonk_bndr vars `thenM` \ new_bndrs ->
+ let
+ env1 = extendZonkEnv env (filter isId new_bndrs)
-- Type variables don't need an envt
-- They are bound through the mutable mechanism
- zonkExpr lhs `thenNF_Tc` \ new_lhs ->
- zonkExpr rhs `thenNF_Tc` \ new_rhs ->
- returnNF_Tc (HsRule name act (map RuleBndr new_bndrs) new_lhs new_rhs loc)
+ in
+ zonkExpr env1 lhs `thenM` \ new_lhs ->
+ zonkExpr env1 rhs `thenM` \ new_rhs ->
+ returnM (HsRule name act (map RuleBndr new_bndrs) new_lhs new_rhs loc)
-- I hate this map RuleBndr stuff
where
zonk_bndr (RuleBndr v)
| isId v = zonkIdBndr v
| otherwise = zonkTcTyVarToTyVar v
-zonkRule (IfaceRuleOut fun rule)
- = zonkIdOcc fun `thenNF_Tc` \ fun' ->
- returnNF_Tc (IfaceRuleOut fun' rule)
+zonkRule env (IfaceRuleOut fun rule)
+ = returnM (IfaceRuleOut (zonkIdOcc env fun) rule)
\end{code}
\begin{code}
module TcIfaceSig ( tcInterfaceSigs,
- tcDelay,
tcVar,
tcCoreExpr,
tcCoreLamBndrs,
#include "HsVersions.h"
-import HsSyn ( TyClDecl(..), HsTupCon(..) )
+import HsSyn ( CoreDecl(..), TyClDecl(..), HsTupCon(..) )
import TcHsSyn ( TypecheckedCoreBind )
-import TcMonad
+import TcRnMonad
import TcMonoType ( tcIfaceType )
-import TcEnv ( RecTcEnv, tcExtendTyVarEnv,
- tcExtendGlobalValEnv, tcSetEnv, tcEnvIds,
+import TcEnv ( RecTcGblEnv, tcExtendTyVarEnv,
+ tcExtendGlobalValEnv,
tcLookupGlobal_maybe, tcLookupRecId_maybe
)
-import RnHsSyn ( RenamedTyClDecl )
+import RnHsSyn ( RenamedCoreDecl, RenamedTyClDecl )
import HsCore
import Literal ( Literal(..) )
import CoreSyn
import CoreLint ( lintUnfolding )
import WorkWrap ( mkWrapper )
-import Id ( Id, mkVanillaGlobal, mkLocalId, idName, isDataConWrapId_maybe )
-import Module ( Module )
+import Id ( Id, mkVanillaGlobal, mkLocalId, isDataConWrapId_maybe )
import MkId ( mkFCallId )
import IdInfo
import TyCon ( tyConDataCons, tyConTyVars )
import DataCon ( DataCon, dataConWorkId, dataConExistentialTyVars, dataConArgTys )
-import Type ( Type, mkTyVarTys, splitTyConApp )
+import Type ( mkTyVarTys, splitTyConApp )
import TysWiredIn ( tupleCon )
import Var ( mkTyVar, tyVarKind )
-import Name ( Name, nameIsLocalOrFrom )
-import ErrUtils ( pprBagOfErrors )
+import Name ( Name )
+import UniqSupply ( initUs_ )
import Outputable
import Util ( zipWithEqual, dropList, equalLength )
import HscTypes ( TyThing(..) )
signatures.
\begin{code}
-tcInterfaceSigs :: RecTcEnv -- Envt to use when checking unfoldings
- -> Module -- This module
+tcInterfaceSigs :: RecTcGblEnv -- Envt to use when checking unfoldings
-> [RenamedTyClDecl] -- Ignore non-sig-decls in these decls
-> TcM [Id]
-tcInterfaceSigs unf_env mod decls
- = listTc [ do_one name ty id_infos src_loc
- | IfaceSig {tcdName = name, tcdType = ty, tcdIdInfo = id_infos, tcdLoc =src_loc} <- decls]
+tcInterfaceSigs unf_env decls
+ = sequenceM [ do_one name ty id_infos src_loc
+ | IfaceSig {tcdName = name, tcdType = ty,
+ tcdIdInfo = id_infos, tcdLoc =src_loc} <- decls]
where
- in_scope_vars = filter (nameIsLocalOrFrom mod . idName) (tcEnvIds unf_env)
+ in_scope_vars = []
+-- in_scope_vars = filter (nameIsLocalOrFrom mod . idName) (tcEnvIds unf_env)
-- Oops: using isLocalId instead can give a black hole
-- because it looks at the idinfo
-- if -dcore-lint is on.
do_one name ty id_infos src_loc
- = tcAddSrcLoc src_loc $
- tcAddErrCtxt (ifaceSigCtxt name) $
- tcIfaceType ty `thenTc` \ sigma_ty ->
+ = addSrcLoc src_loc $
+ addErrCtxt (ifaceSigCtxt name) $
+ tcIfaceType ty `thenM` \ sigma_ty ->
tcIdInfo unf_env in_scope_vars name
- sigma_ty id_infos `thenTc` \ id_info ->
- returnTc (mkVanillaGlobal name sigma_ty id_info)
+ sigma_ty id_infos `thenM` \ id_info ->
+ returnM (mkVanillaGlobal name sigma_ty id_info)
\end{code}
\begin{code}
tcIdInfo unf_env in_scope_vars name ty info_ins
- = foldlTc tcPrag init_info info_ins
+ = foldlM tcPrag init_info info_ins
where
-- Set the CgInfo to something sensible but uninformative before
-- we start; default assumption is that it has CAFs
init_info = hasCafIdInfo
- tcPrag info (HsNoCafRefs) = returnTc (info `setCafInfo` NoCafRefs)
+ tcPrag info (HsNoCafRefs) = returnM (info `setCafInfo` NoCafRefs)
tcPrag info (HsArity arity) =
- returnTc (info `setArityInfo` arity)
+ returnM (info `setArityInfo` arity)
tcPrag info (HsUnfold inline_prag expr)
- = tcPragExpr unf_env name in_scope_vars expr `thenNF_Tc` \ maybe_expr' ->
+ = tcPragExpr unf_env name in_scope_vars expr `thenM` \ maybe_expr' ->
let
-- maybe_expr doesn't get looked at if the unfolding
-- is never inspected; so the typecheck doesn't even happen
info1 = info `setUnfoldingInfo` unfold_info
info2 = info1 `setInlinePragInfo` inline_prag
in
- returnTc info2
+ returnM info2
tcPrag info (HsStrictness strict_info)
- = returnTc (info `setAllStrictnessInfo` Just strict_info)
+ = returnM (info `setAllStrictnessInfo` Just strict_info)
tcPrag info (HsWorker nm arity)
= tcWorkerInfo unf_env ty info nm arity
\begin{code}
tcWorkerInfo unf_env ty info worker_name arity
- = uniqSMToTcM (mkWrapper ty strict_sig) `thenNF_Tc` \ wrap_fn ->
+ = newUniqueSupply `thenM` \ us ->
let
+ wrap_fn = initUs_ us (mkWrapper ty strict_sig)
+
-- Watch out! We can't pull on unf_env too eagerly!
info' = case tcLookupRecId_maybe unf_env worker_name of
Just worker_id ->
`setWorkerInfo` HasWorker worker_id arity
Nothing -> pprTrace "tcWorkerInfo failed:"
- (ppr worker_name) info
+ (ppr worker_name) info
in
- returnTc info'
+ returnM info'
where
-- We are relying here on strictness info always appearing
-- before worker info, fingers crossed ....
\begin{code}
tcPragExpr unf_env name in_scope_vars expr
- = tcDelay unf_env doc Nothing $
- tcCoreExpr expr `thenTc` \ core_expr' ->
+ = forkM doc $
+ setGblEnv unf_env $
+
+ tcCoreExpr expr `thenM` \ core_expr' ->
-- Check for type consistency in the unfolding
- tcGetSrcLoc `thenNF_Tc` \ src_loc ->
- getDOptsTc `thenNF_Tc` \ dflags ->
- case lintUnfolding dflags src_loc in_scope_vars core_expr' of
- (Nothing,_) -> returnTc (Just core_expr') -- ignore warnings
+ getSrcLocM `thenM` \ src_loc ->
+ getDOpts `thenM` \ dflags ->
+ case lintUnfolding dflags src_loc in_scope_vars core_expr' of
+ (Nothing,_) -> returnM core_expr' -- ignore warnings
(Just fail_msg,_) -> failWithTc ((doc <+> text "failed Lint") $$ fail_msg)
where
doc = text "unfolding of" <+> ppr name
-
-tcDelay :: RecTcEnv -> SDoc -> a -> TcM a -> NF_TcM a
-tcDelay unf_env doc bad_ans thing_inside
- = forkNF_Tc (
- recoverNF_Tc bad_value (
- tcSetEnv unf_env thing_inside
- ))
- where
- -- The trace tells what wasn't available, for the benefit of
- -- compiler hackers who want to improve it!
- bad_value = getErrsTc `thenNF_Tc` \ (warns,errs) ->
- returnNF_Tc (pprTrace "Failed:"
- (hang doc 4 (pprBagOfErrors errs))
- bad_ans)
\end{code}
\begin{code}
tcVar :: Name -> TcM Id
tcVar name
- = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_id ->
+ = tcLookupGlobal_maybe name `thenM` \ maybe_id ->
case maybe_id of {
- Just (AnId id) -> returnTc id ;
+ Just (AnId id) -> returnM id ;
Nothing -> failWithTc (noDecl name)
}
tcCoreExpr :: UfExpr Name -> TcM CoreExpr
tcCoreExpr (UfType ty)
- = tcIfaceType ty `thenTc` \ ty' ->
+ = tcIfaceType ty `thenM` \ ty' ->
-- It might not be of kind type
- returnTc (Type ty')
+ returnM (Type ty')
tcCoreExpr (UfVar name)
- = tcVar name `thenTc` \ id ->
- returnTc (Var id)
+ = tcVar name `thenM` \ id ->
+ returnM (Var id)
tcCoreExpr (UfLit lit)
- = returnTc (Lit lit)
+ = returnM (Lit lit)
-- The dreaded lit-lits are also similar, except here the type
-- is read in explicitly rather than being implicit
tcCoreExpr (UfLitLit lit ty)
- = tcIfaceType ty `thenTc` \ ty' ->
- returnTc (Lit (MachLitLit lit ty'))
+ = tcIfaceType ty `thenM` \ ty' ->
+ returnM (Lit (MachLitLit lit ty'))
tcCoreExpr (UfFCall cc ty)
- = tcIfaceType ty `thenTc` \ ty' ->
- tcGetUnique `thenNF_Tc` \ u ->
- returnTc (Var (mkFCallId u cc ty'))
+ = tcIfaceType ty `thenM` \ ty' ->
+ newUnique `thenM` \ u ->
+ returnM (Var (mkFCallId u cc ty'))
-tcCoreExpr (UfTuple (HsTupCon _ boxity arity) args)
- = mapTc tcCoreExpr args `thenTc` \ args' ->
+tcCoreExpr (UfTuple (HsTupCon boxity arity) args)
+ = mappM tcCoreExpr args `thenM` \ args' ->
let
-- Put the missing type arguments back in
con_args = map (Type . exprType) args' ++ args'
in
- returnTc (mkApps (Var con_id) con_args)
+ returnM (mkApps (Var con_id) con_args)
where
con_id = dataConWorkId (tupleCon boxity arity)
tcCoreExpr (UfLam bndr body)
= tcCoreLamBndr bndr $ \ bndr' ->
- tcCoreExpr body `thenTc` \ body' ->
- returnTc (Lam bndr' body')
+ tcCoreExpr body `thenM` \ body' ->
+ returnM (Lam bndr' body')
tcCoreExpr (UfApp fun arg)
- = tcCoreExpr fun `thenTc` \ fun' ->
- tcCoreExpr arg `thenTc` \ arg' ->
- returnTc (App fun' arg')
+ = tcCoreExpr fun `thenM` \ fun' ->
+ tcCoreExpr arg `thenM` \ arg' ->
+ returnM (App fun' arg')
tcCoreExpr (UfCase scrut case_bndr alts)
- = tcCoreExpr scrut `thenTc` \ scrut' ->
+ = tcCoreExpr scrut `thenM` \ scrut' ->
let
scrut_ty = exprType scrut'
case_bndr' = mkLocalId case_bndr scrut_ty
in
tcExtendGlobalValEnv [case_bndr'] $
- mapTc (tcCoreAlt scrut_ty) alts `thenTc` \ alts' ->
- returnTc (Case scrut' case_bndr' alts')
+ mappM (tcCoreAlt scrut_ty) alts `thenM` \ alts' ->
+ returnM (Case scrut' case_bndr' alts')
tcCoreExpr (UfLet (UfNonRec bndr rhs) body)
- = tcCoreExpr rhs `thenTc` \ rhs' ->
+ = tcCoreExpr rhs `thenM` \ rhs' ->
tcCoreValBndr bndr $ \ bndr' ->
- tcCoreExpr body `thenTc` \ body' ->
- returnTc (Let (NonRec bndr' rhs') body')
+ tcCoreExpr body `thenM` \ body' ->
+ returnM (Let (NonRec bndr' rhs') body')
tcCoreExpr (UfLet (UfRec pairs) body)
= tcCoreValBndrs bndrs $ \ bndrs' ->
- mapTc tcCoreExpr rhss `thenTc` \ rhss' ->
- tcCoreExpr body `thenTc` \ body' ->
- returnTc (Let (Rec (bndrs' `zip` rhss')) body')
+ mappM tcCoreExpr rhss `thenM` \ rhss' ->
+ tcCoreExpr body `thenM` \ body' ->
+ returnM (Let (Rec (bndrs' `zip` rhss')) body')
where
(bndrs, rhss) = unzip pairs
tcCoreExpr (UfNote note expr)
- = tcCoreExpr expr `thenTc` \ expr' ->
+ = tcCoreExpr expr `thenM` \ expr' ->
case note of
- UfCoerce to_ty -> tcIfaceType to_ty `thenTc` \ to_ty' ->
- returnTc (Note (Coerce to_ty'
+ UfCoerce to_ty -> tcIfaceType to_ty `thenM` \ to_ty' ->
+ returnM (Note (Coerce to_ty'
(exprType expr')) expr')
- UfInlineCall -> returnTc (Note InlineCall expr')
- UfInlineMe -> returnTc (Note InlineMe expr')
- UfSCC cc -> returnTc (Note (SCC cc) expr')
+ UfInlineCall -> returnM (Note InlineCall expr')
+ UfInlineMe -> returnM (Note InlineMe expr')
+ UfSCC cc -> returnM (Note (SCC cc) expr')
\end{code}
\begin{code}
tcCoreLamBndr (UfValBinder name ty) thing_inside
- = tcIfaceType ty `thenTc` \ ty' ->
+ = tcIfaceType ty `thenM` \ ty' ->
let
id = mkLocalId name ty'
in
thing_inside (b':bs')
tcCoreValBndr (UfValBinder name ty) thing_inside
- = tcIfaceType ty `thenTc` \ ty' ->
+ = tcIfaceType ty `thenM` \ ty' ->
let
id = mkLocalId name ty'
in
thing_inside id
tcCoreValBndrs bndrs thing_inside -- Expect them all to be ValBinders
- = mapTc tcIfaceType tys `thenTc` \ tys' ->
+ = mappM tcIfaceType tys `thenM` \ tys' ->
let
ids = zipWithEqual "tcCoreValBndr" mkLocalId names tys'
in
\begin{code}
tcCoreAlt scrut_ty (UfDefault, names, rhs)
= ASSERT( null names )
- tcCoreExpr rhs `thenTc` \ rhs' ->
- returnTc (DEFAULT, [], rhs')
+ tcCoreExpr rhs `thenM` \ rhs' ->
+ returnM (DEFAULT, [], rhs')
tcCoreAlt scrut_ty (UfLitAlt lit, names, rhs)
= ASSERT( null names )
- tcCoreExpr rhs `thenTc` \ rhs' ->
- returnTc (LitAlt lit, [], rhs')
+ tcCoreExpr rhs `thenM` \ rhs' ->
+ returnM (LitAlt lit, [], rhs')
tcCoreAlt scrut_ty (UfLitLitAlt str ty, names, rhs)
= ASSERT( null names )
- tcCoreExpr rhs `thenTc` \ rhs' ->
- tcIfaceType ty `thenTc` \ ty' ->
- returnTc (LitAlt (MachLitLit str ty'), [], rhs')
+ tcCoreExpr rhs `thenM` \ rhs' ->
+ tcIfaceType ty `thenM` \ ty' ->
+ returnM (LitAlt (MachLitLit str ty'), [], rhs')
-- A case alternative is made quite a bit more complicated
-- by the fact that we omit type annotations because we can
-- work them out. True enough, but its not that easy!
tcCoreAlt scrut_ty alt@(con, names, rhs)
- = tcConAlt con `thenTc` \ con ->
+ = tcConAlt con `thenM` \ con ->
let
ex_tyvars = dataConExistentialTyVars con
(tycon, inst_tys) = splitTyConApp scrut_ty -- NB: not tcSplitTyConApp
ASSERT( con `elem` tyConDataCons tycon && equalLength inst_tys main_tyvars )
tcExtendTyVarEnv ex_tyvars' $
tcExtendGlobalValEnv arg_ids $
- tcCoreExpr rhs `thenTc` \ rhs' ->
- returnTc (DataAlt con, ex_tyvars' ++ arg_ids, rhs')
+ tcCoreExpr rhs `thenM` \ rhs' ->
+ returnM (DataAlt con, ex_tyvars' ++ arg_ids, rhs')
tcConAlt :: UfConAlt Name -> TcM DataCon
-tcConAlt (UfTupleAlt (HsTupCon _ boxity arity))
- = returnTc (tupleCon boxity arity)
+tcConAlt (UfTupleAlt (HsTupCon boxity arity))
+ = returnM (tupleCon boxity arity)
tcConAlt (UfDataAlt con_name)
- = tcVar con_name `thenTc` \ con_id ->
- returnTc (case isDataConWrapId_maybe con_id of
+ = tcVar con_name `thenM` \ con_id ->
+ returnM (case isDataConWrapId_maybe con_id of
Just con -> con
Nothing -> pprPanic "tcCoreAlt" (ppr con_id))
\end{code}
\begin{code}
-tcCoreBinds :: [RenamedTyClDecl] -> TcM [TypecheckedCoreBind]
+tcCoreBinds :: [RenamedCoreDecl] -> TcM [TypecheckedCoreBind]
-- We don't assume the bindings are in dependency order
-- So first build the environment, then check the RHSs
-tcCoreBinds ls = mapTc tcCoreBinder ls `thenTc` \ bndrs ->
+tcCoreBinds ls = mappM tcCoreBinder ls `thenM` \ bndrs ->
tcExtendGlobalValEnv bndrs $
- mapTc tcCoreBind ls
+ mappM tcCoreBind ls
-tcCoreBinder (CoreDecl { tcdName = nm, tcdType = ty })
- = tcIfaceType ty `thenTc` \ ty' ->
- returnTc (mkLocalId nm ty')
+tcCoreBinder (CoreDecl nm ty _ _)
+ = tcIfaceType ty `thenM` \ ty' ->
+ returnM (mkLocalId nm ty')
-tcCoreBind (CoreDecl { tcdName = nm, tcdRhs = rhs })
- = tcVar nm `thenTc` \ id ->
- tcCoreExpr rhs `thenTc` \ rhs' ->
- returnTc (id, rhs')
+tcCoreBind (CoreDecl nm _ rhs _)
+ = tcVar nm `thenM` \ id ->
+ tcCoreExpr rhs `thenM` \ rhs' ->
+ returnM (id, rhs')
\end{code}
\section[TcInstDecls]{Typechecking instance declarations}
\begin{code}
-module TcInstDcls ( tcInstDecls1, tcIfaceInstDecls1, addInstDFuns,
- tcInstDecls2, initInstEnv, tcAddDeclCtxt ) where
+module TcInstDcls ( tcInstDecls1, tcIfaceInstDecls,
+ tcInstDecls2, tcAddDeclCtxt ) where
#include "HsVersions.h"
import HsSyn ( InstDecl(..), TyClDecl(..), HsType(..),
MonoBinds(..), HsExpr(..), HsLit(..), Sig(..), HsTyVarBndr(..),
andMonoBindList, collectMonoBinders,
- isClassDecl, toHsType
+ isClassDecl, isSourceInstDecl, toHsType
)
import RnHsSyn ( RenamedHsBinds, RenamedInstDecl,
RenamedMonoBinds, RenamedTyClDecl, RenamedHsType,
import TcHsSyn ( TcMonoBinds, mkHsConApp )
import TcBinds ( tcSpecSigs )
import TcClassDcl ( tcMethodBind, mkMethodBind, badMethodErr )
-import TcMonad
+import TcRnMonad
import TcMType ( tcInstType, checkValidTheta, checkValidInstHead, instTypeErr,
- UserTypeCtxt(..), SourceTyCtxt(..) )
-import TcType ( mkClassPred, mkTyVarTy, tcSplitForAllTys,
+ checkAmbiguity, UserTypeCtxt(..), SourceTyCtxt(..) )
+import TcType ( mkClassPred, mkTyVarTy, tcSplitForAllTys, tyVarsOfType,
tcSplitSigmaTy, getClassPredTys, tcSplitPredTy_maybe,
TyVarDetails(..)
)
-import Inst ( InstOrigin(..), newDicts, instToId,
- LIE, mkLIE, emptyLIE, plusLIE, plusLIEs )
+import Inst ( InstOrigin(..), newDicts, instToId, showLIE )
import TcDeriv ( tcDeriving )
import TcEnv ( tcExtendGlobalValEnv, tcExtendLocalValEnv2,
- tcLookupId, tcLookupClass, tcExtendTyVarEnv2,
+ tcLookupClass, tcExtendTyVarEnv2,
+ tcExtendInstEnv, tcExtendLocalInstEnv, tcLookupGlobalId,
InstInfo(..), pprInstInfo, simpleInstInfoTyCon,
simpleInstInfoTy, newDFunName
)
-import InstEnv ( InstEnv, extendInstEnv )
import PprType ( pprClassPred )
import TcMonoType ( tcSigPolyId, tcHsTyVars, kcHsSigType, tcHsType, tcHsSigType )
import TcUnify ( checkSigTyVars )
import TcSimplify ( tcSimplifyCheck, tcSimplifyTop )
-import HscTypes ( HomeSymbolTable, DFunId, FixityEnv,
- PersistentCompilerState(..), PersistentRenamerState,
- ModDetails(..)
- )
+import HscTypes ( DFunId )
import Subst ( mkTyVarSubst, substTheta )
import DataCon ( classDataCon )
import Class ( Class, classBigSig )
import Var ( idName, idType )
+import NameSet
import Id ( setIdLocalExported )
import MkId ( mkDictFunId, unsafeCoerceId, rUNTIME_ERROR_ID )
import FunDeps ( checkInstFDs )
import Generics ( validGenericInstanceType )
-import Module ( Module, foldModuleEnv )
import Name ( getSrcLoc )
import NameSet ( unitNameSet, emptyNameSet, nameSetToList )
import TyCon ( TyCon )
assocElts, extendAssoc_C, equivClassesByUniq, minusList
)
import Maybe ( catMaybes )
+import List ( partition )
import Outputable
import FastString
\end{code}
Gather up the instance declarations from their various sources
\begin{code}
-tcInstDecls1 -- Deal with source-code instance decls
- :: PersistentRenamerState
- -> InstEnv -- Imported instance envt
- -> FixityEnv -- for deriving Show and Read
- -> Module -- Module for deriving
- -> [RenamedTyClDecl] -- For deriving stuff
+tcInstDecls1 -- Deal with both source-code and imported instance decls
+ :: [RenamedTyClDecl] -- For deriving stuff
-> [RenamedInstDecl] -- Source code instance decls
- -> TcM (InstEnv, -- the full inst env
- [InstInfo], -- instance decls to process; contains all dfuns
- -- for this module
- RenamedHsBinds) -- derived instances
-
-tcInstDecls1 prs inst_env get_fixity this_mod
- tycl_decls inst_decls
--- The incoming inst_env includes all the imported instances already
- = checkNoErrsTc $
+ -> TcM (TcGblEnv, -- The full inst env
+ [InstInfo], -- Source-code instance decls to process;
+ -- contains all dfuns for this module
+ RenamedHsBinds, -- Supporting bindings for derived instances
+ FreeVars) -- And the free vars of the derived code
+
+tcInstDecls1 tycl_decls inst_decls
+ = checkNoErrs $
-- Stop if addInstInfos etc discovers any errors
-- (they recover, so that we get more than one error each round)
+ let
+ (src_inst_decls, iface_inst_decls) = partition isSourceInstDecl inst_decls
+ in
+
+ -- (0) Deal with the imported instance decls
+ tcIfaceInstDecls iface_inst_decls `thenM` \ imp_dfuns ->
+ tcExtendInstEnv imp_dfuns $
+
-- (1) Do the ordinary instance declarations
- mapNF_Tc tcLocalInstDecl1 inst_decls `thenNF_Tc` \ local_inst_infos ->
+ mappM tcLocalInstDecl1 src_inst_decls `thenM` \ local_inst_infos ->
let
local_inst_info = catMaybes local_inst_infos
clas_decls = filter isClassDecl tycl_decls
in
-- (2) Instances from generic class declarations
- getGenericInstances clas_decls `thenTc` \ generic_inst_info ->
+ getGenericInstances clas_decls `thenM` \ generic_inst_info ->
-- Next, construct the instance environment so far, consisting of
- -- a) imported instance decls (from this module) inst_env1
- -- b) local instance decls inst_env2
- -- c) generic instances final_inst_env
- addInstInfos inst_env local_inst_info `thenNF_Tc` \ inst_env1 ->
- addInstInfos inst_env1 generic_inst_info `thenNF_Tc` \ inst_env2 ->
+ -- a) imported instance decls (from this module)
+ -- b) local instance decls
+ -- c) generic instances
+ tcExtendLocalInstEnv local_inst_info $
+ tcExtendLocalInstEnv generic_inst_info $
-- (3) Compute instances from "deriving" clauses;
-- note that we only do derivings for things in this module;
-- we ignore deriving decls from interfaces!
-- This stuff computes a context for the derived instance decl, so it
-- needs to know about all the instances possible; hence inst_env4
- tcDeriving prs this_mod inst_env2
- get_fixity tycl_decls `thenTc` \ (deriv_inst_info, deriv_binds) ->
- addInstInfos inst_env2 deriv_inst_info `thenNF_Tc` \ final_inst_env ->
-
- returnTc (final_inst_env,
- generic_inst_info ++ deriv_inst_info ++ local_inst_info,
- deriv_binds)
-
-initInstEnv :: PersistentCompilerState -> HomeSymbolTable -> NF_TcM InstEnv
--- Initialise the instance environment from the
--- persistent compiler state and the home symbol table
-initInstEnv pcs hst
- = let
- pkg_inst_env = pcs_insts pcs
- hst_dfuns = foldModuleEnv ((++) . md_insts) [] hst
- in
- addInstDFuns pkg_inst_env hst_dfuns
-
-addInstInfos :: InstEnv -> [InstInfo] -> NF_TcM InstEnv
-addInstInfos inst_env infos = addInstDFuns inst_env (map iDFunId infos)
+ tcDeriving tycl_decls `thenM` \ (deriv_inst_info, deriv_binds, fvs) ->
+ tcExtendLocalInstEnv deriv_inst_info $
-addInstDFuns :: InstEnv -> [DFunId] -> NF_TcM InstEnv
-addInstDFuns inst_env dfuns
- = getDOptsTc `thenNF_Tc` \ dflags ->
- let
- (inst_env', errs) = extendInstEnv dflags inst_env dfuns
- in
- addErrsTc errs `thenNF_Tc_`
- traceTc (text "Adding instances:" <+> vcat (map pp dfuns)) `thenTc_`
- returnTc inst_env'
- where
- pp dfun = ppr dfun <+> dcolon <+> ppr (idType dfun)
+ getGblEnv `thenM` \ gbl_env ->
+ returnM (gbl_env,
+ generic_inst_info ++ deriv_inst_info ++ local_inst_info,
+ deriv_binds, fvs)
\end{code}
\begin{code}
-tcIfaceInstDecls1 :: [RenamedInstDecl] -> NF_TcM [DFunId]
-tcIfaceInstDecls1 decls = mapNF_Tc tcIfaceInstDecl1 decls
-
-tcIfaceInstDecl1 :: RenamedInstDecl -> NF_TcM DFunId
- -- An interface-file instance declaration
- -- Should be in scope by now, because we should
- -- have sucked in its interface-file definition
- -- So it will be replete with its unfolding etc
-tcIfaceInstDecl1 decl@(InstDecl poly_ty binds uprags (Just dfun_name) src_loc)
- = tcLookupId dfun_name
-
-
tcLocalInstDecl1 :: RenamedInstDecl
- -> NF_TcM (Maybe InstInfo) -- Nothing if there was an error
+ -> TcM (Maybe InstInfo) -- Nothing if there was an error
-- A source-file instance declaration
-- Type-check all the stuff before the "where"
--
-- instance CCallable [Char]
tcLocalInstDecl1 decl@(InstDecl poly_ty binds uprags Nothing src_loc)
= -- Prime error recovery, set source location
- recoverNF_Tc (returnNF_Tc Nothing) $
- tcAddSrcLoc src_loc $
- tcAddErrCtxt (instDeclCtxt poly_ty) $
+ recoverM (returnM Nothing) $
+ addSrcLoc src_loc $
+ addErrCtxt (instDeclCtxt poly_ty) $
-- Typecheck the instance type itself. We can't use
-- tcHsSigType, because it's not a valid user type.
- kcHsSigType poly_ty `thenTc_`
- tcHsType poly_ty `thenTc` \ poly_ty' ->
+ kcHsSigType poly_ty `thenM_`
+ tcHsType poly_ty `thenM` \ poly_ty' ->
let
(tyvars, theta, tau) = tcSplitSigmaTy poly_ty'
in
- checkValidTheta InstThetaCtxt theta `thenTc_`
- checkValidInstHead tau `thenTc` \ (clas,inst_tys) ->
+ checkValidTheta InstThetaCtxt theta `thenM_`
+ checkAmbiguity tyvars theta (tyVarsOfType tau) `thenM_`
+ checkValidInstHead tau `thenM` \ (clas,inst_tys) ->
checkTc (checkInstFDs theta clas inst_tys)
- (instTypeErr (pprClassPred clas inst_tys) msg) `thenTc_`
- newDFunName clas inst_tys src_loc `thenNF_Tc` \ dfun_name ->
- returnTc (Just (InstInfo { iDFunId = mkDictFunId dfun_name clas tyvars inst_tys theta,
+ (instTypeErr (pprClassPred clas inst_tys) msg) `thenM_`
+ newDFunName clas inst_tys src_loc `thenM` \ dfun_name ->
+ returnM (Just (InstInfo { iDFunId = mkDictFunId dfun_name clas tyvars inst_tys theta,
iBinds = binds, iPrags = uprags }))
where
msg = parens (ptext SLIT("the instance types do not agree with the functional dependencies of the class"))
\end{code}
+Imported instance declarations
+
+\begin{code}
+tcIfaceInstDecls :: [RenamedInstDecl] -> TcM [DFunId]
+-- Deal with the instance decls,
+tcIfaceInstDecls decls = mappM tcIfaceInstDecl decls
+
+tcIfaceInstDecl :: RenamedInstDecl -> TcM DFunId
+ -- An interface-file instance declaration
+ -- Should be in scope by now, because we should
+ -- have sucked in its interface-file definition
+ -- So it will be replete with its unfolding etc
+tcIfaceInstDecl decl@(InstDecl poly_ty binds uprags (Just dfun_name) src_loc)
+ = tcLookupGlobalId dfun_name
+\end{code}
+
%************************************************************************
%* *
\begin{code}
getGenericInstances :: [RenamedTyClDecl] -> TcM [InstInfo]
getGenericInstances class_decls
- = mapTc get_generics class_decls `thenTc` \ gen_inst_infos ->
+ = mappM get_generics class_decls `thenM` \ gen_inst_infos ->
let
gen_inst_info = concat gen_inst_infos
in
if null gen_inst_info then
- returnTc []
+ returnM []
else
- getDOptsTc `thenNF_Tc` \ dflags ->
- ioToTc (dumpIfSet_dyn dflags Opt_D_dump_deriv "Generic instances"
- (vcat (map pprInstInfo gen_inst_info)))
- `thenNF_Tc_`
- returnTc gen_inst_info
+ getDOpts `thenM` \ dflags ->
+ ioToTcRn (dumpIfSet_dyn dflags Opt_D_dump_deriv "Generic instances"
+ (vcat (map pprInstInfo gen_inst_info)))
+ `thenM_`
+ returnM gen_inst_info
get_generics decl@(ClassDecl {tcdMeths = Nothing})
- = returnTc [] -- Imported class decls
+ = returnM [] -- Imported class decls
get_generics decl@(ClassDecl {tcdName = class_name, tcdMeths = Just def_methods, tcdLoc = loc})
| null groups
- = returnTc [] -- The comon case: no generic default methods
+ = returnM [] -- The comon case: no generic default methods
| otherwise -- A source class decl with generic default methods
- = recoverNF_Tc (returnNF_Tc []) $
- tcAddDeclCtxt decl $
- tcLookupClass class_name `thenTc` \ clas ->
+ = recoverM (returnM []) $
+ tcAddDeclCtxt decl $
+ tcLookupClass class_name `thenM` \ clas ->
-- Make an InstInfo out of each group
- mapTc (mkGenericInstance clas loc) groups `thenTc` \ inst_infos ->
+ mappM (mkGenericInstance clas loc) groups `thenM` \ inst_infos ->
-- Check that there is only one InstInfo for each type constructor
-- The main way this can fail is if you write
group `lengthExceeds` 1]
get_uniq (tc,_) = getUnique tc
in
- mapTc (addErrTc . dupGenericInsts) bad_groups `thenTc_`
+ mappM (addErrTc . dupGenericInsts) bad_groups `thenM_`
-- Check that there is an InstInfo for each generic type constructor
let
missing = genericTyCons `minusList` [tc | (tc,_) <- tc_inst_infos]
in
- checkTc (null missing) (missingGenericInstances missing) `thenTc_`
+ checkTc (null missing) (missingGenericInstances missing) `thenM_`
- returnTc inst_infos
+ returnM inst_infos
where
-- Group the declarations by type pattern
tcHsTyVars sig_tvs (kcHsSigType hs_ty) $ \ tyvars ->
-- Type-check the instance type, and check its form
- tcHsSigType GenPatCtxt hs_ty `thenTc` \ inst_ty ->
+ tcHsSigType GenPatCtxt hs_ty `thenM` \ inst_ty ->
checkTc (validGenericInstanceType inst_ty)
- (badGenericInstanceType binds) `thenTc_`
+ (badGenericInstanceType binds) `thenM_`
-- Make the dictionary function.
- newDFunName clas [inst_ty] loc `thenNF_Tc` \ dfun_name ->
+ newDFunName clas [inst_ty] loc `thenM` \ dfun_name ->
let
inst_theta = [mkClassPred clas [mkTyVarTy tv] | tv <- tyvars]
dfun_id = mkDictFunId dfun_name clas tyvars [inst_ty] inst_theta
in
- returnTc (InstInfo { iDFunId = dfun_id, iBinds = binds, iPrags = [] })
+ returnM (InstInfo { iDFunId = dfun_id, iBinds = binds, iPrags = [] })
\end{code}
%************************************************************************
\begin{code}
-tcInstDecls2 :: [InstInfo]
- -> NF_TcM (LIE, TcMonoBinds)
-
+tcInstDecls2 :: [InstInfo] -> TcM TcMonoBinds
tcInstDecls2 inst_decls
--- = foldBag combine tcInstDecl2 (returnNF_Tc (emptyLIE, EmptyMonoBinds)) inst_decls
- = foldr combine (returnNF_Tc (emptyLIE, EmptyMonoBinds))
- (map tcInstDecl2 inst_decls)
- where
- combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) ->
- tc2 `thenNF_Tc` \ (lie2, binds2) ->
- returnNF_Tc (lie1 `plusLIE` lie2,
- binds1 `AndMonoBinds` binds2)
+ = mappM tcInstDecl2 inst_decls `thenM` \ binds_s ->
+ returnM (andMonoBindList binds_s)
\end{code}
======= New documentation starts here (Sept 92) ==============
\begin{code}
-tcInstDecl2 :: InstInfo -> TcM (LIE, TcMonoBinds)
+tcInstDecl2 :: InstInfo -> TcM TcMonoBinds
tcInstDecl2 (NewTypeDerived { iDFunId = dfun_id })
- = tcInstType InstTv (idType dfun_id) `thenNF_Tc` \ (inst_tyvars', dfun_theta', inst_head') ->
- newDicts InstanceDeclOrigin dfun_theta' `thenNF_Tc` \ rep_dicts ->
+ = tcInstType InstTv (idType dfun_id) `thenM` \ (inst_tyvars', dfun_theta', inst_head') ->
+ newDicts InstanceDeclOrigin dfun_theta' `thenM` \ rep_dicts ->
let
rep_dict_id = ASSERT( isSingleton rep_dicts )
instToId (head rep_dicts) -- Derived newtypes have just one dict arg
-- type equality mechanism isn't clever enough; see comments with Type.eqType.
-- So Lint complains if we don't have this.
in
- returnTc (emptyLIE, VarMonoBind dfun_id body)
+ returnM (VarMonoBind dfun_id body)
tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = monobinds, iPrags = uprags })
= -- Prime error recovery
- recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $
- tcAddSrcLoc (getSrcLoc dfun_id) $
- tcAddErrCtxt (instDeclCtxt (toHsType (idType dfun_id))) $
+ recoverM (returnM EmptyMonoBinds) $
+ addSrcLoc (getSrcLoc dfun_id) $
+ addErrCtxt (instDeclCtxt (toHsType (idType dfun_id))) $
let
inst_ty = idType dfun_id
(inst_tyvars, _) = tcSplitForAllTys inst_ty
in
-- Instantiate the instance decl with tc-style type variables
- tcInstType InstTv inst_ty `thenNF_Tc` \ (inst_tyvars', dfun_theta', inst_head') ->
+ tcInstType InstTv inst_ty `thenM` \ (inst_tyvars', dfun_theta', inst_head') ->
let
Just pred = tcSplitPredTy_maybe inst_head'
(clas, inst_tys') = getClassPredTys pred
origin = InstanceDeclOrigin
in
-- Create dictionary Ids from the specified instance contexts.
- newDicts origin sc_theta' `thenNF_Tc` \ sc_dicts ->
- newDicts origin dfun_theta' `thenNF_Tc` \ dfun_arg_dicts ->
- newDicts origin [pred] `thenNF_Tc` \ [this_dict] ->
+ newDicts origin sc_theta' `thenM` \ sc_dicts ->
+ newDicts origin dfun_theta' `thenM` \ dfun_arg_dicts ->
+ newDicts origin [pred] `thenM` \ [this_dict] ->
-- Default-method Ids may be mentioned in synthesised RHSs,
-- but they'll already be in the environment.
-- Check that all the method bindings come from this class
- mkMethodBinds clas inst_tys' op_items monobinds `thenTc` \ (meth_insts, meth_infos) ->
+ mkMethodBinds clas inst_tys' op_items monobinds `thenM` \ (meth_insts, meth_infos) ->
let -- These insts are in scope; quite a few, eh?
avail_insts = [this_dict] ++ dfun_arg_dicts ++
xtve = inst_tyvars `zip` inst_tyvars'
tc_meth = tcMethodBind xtve inst_tyvars' dfun_theta' avail_insts uprags
in
- mapAndUnzipTc tc_meth meth_infos `thenTc` \ (meth_binds_s, meth_lie_s) ->
+ mappM tc_meth meth_infos `thenM` \ meth_binds_s ->
-- Figure out bindings for the superclass context
tcSuperClasses inst_tyvars' dfun_arg_dicts sc_dicts
- `thenTc` \ (zonked_inst_tyvars, sc_binds_inner, sc_binds_outer) ->
+ `thenM` \ (zonked_inst_tyvars, sc_binds_inner, sc_binds_outer) ->
-- Deal with SPECIALISE instance pragmas by making them
-- look like SPECIALISE pragmas for the dfun
| (sel_id, sig, _) <- meth_infos] $
-- Map sel_id to the local method name we are using
tcSpecSigs spec_prags
- ) `thenTc` \ (prag_binds, prag_lie) ->
+ ) `thenM` \ prag_binds ->
-- Create the result bindings
let
[(inst_tyvars', local_dfun_id, this_dict_id)]
inlines all_binds
in
- returnTc (plusLIEs meth_lie_s `plusLIE` prag_lie,
- main_bind `AndMonoBinds` prag_binds `AndMonoBinds` sc_binds_outer)
+ showLIE "instance" `thenM_`
+ returnM (main_bind `AndMonoBinds` prag_binds `AndMonoBinds` sc_binds_outer)
\end{code}
Superclass loops
\begin{code}
tcSuperClasses inst_tyvars' dfun_arg_dicts sc_dicts
- = tcAddErrCtxt superClassCtxt $
- tcSimplifyCheck doc inst_tyvars'
- dfun_arg_dicts
- (mkLIE sc_dicts) `thenTc` \ (sc_lie, sc_binds1) ->
+ = addErrCtxt superClassCtxt $
+ getLIE (tcSimplifyCheck doc inst_tyvars'
+ dfun_arg_dicts
+ sc_dicts) `thenM` \ (sc_binds1, sc_lie) ->
-- It's possible that the superclass stuff might have done unification
- checkSigTyVars inst_tyvars' `thenTc` \ zonked_inst_tyvars ->
+ checkSigTyVars inst_tyvars' `thenM` \ zonked_inst_tyvars ->
-- We must simplify this all the way down
-- lest we build superclass loops
-- See notes about superclass loops above
- tcSimplifyTop sc_lie `thenTc` \ sc_binds2 ->
+ tcSimplifyTop sc_lie `thenM` \ sc_binds2 ->
- returnTc (zonked_inst_tyvars, sc_binds1, sc_binds2)
+ returnM (zonked_inst_tyvars, sc_binds1, sc_binds2)
where
doc = ptext SLIT("instance declaration superclass context")
\begin{code}
mkMethodBinds clas inst_tys' op_items monobinds
= -- Check that all the method bindings come from this class
- mapTc (addErrTc . badMethodErr clas) bad_bndrs `thenNF_Tc_`
+ mappM (addErrTc . badMethodErr clas) bad_bndrs `thenM_`
-- Make the method bindings
- mapAndUnzipTc mk_method_bind op_items
+ mapAndUnzipM mk_method_bind op_items
where
mk_method_bind op_item = mkMethodBind InstanceDeclOrigin clas
\begin{code}
tcAddDeclCtxt decl thing_inside
- = tcAddSrcLoc (tcdLoc decl) $
- tcAddErrCtxt ctxt $
+ = addSrcLoc (tcdLoc decl) $
+ addErrCtxt ctxt $
thing_inside
where
thing = case decl of
--------------------------------
-- Creating new mutable type variables
newTyVar,
- newTyVarTy, -- Kind -> NF_TcM TcType
- newTyVarTys, -- Int -> Kind -> NF_TcM [TcType]
+ newTyVarTy, -- Kind -> TcM TcType
+ newTyVarTys, -- Int -> Kind -> TcM [TcType]
newKindVar, newKindVars, newBoxityVar,
putTcTyVar, getTcTyVar,
+ newMutTyVar, readMutTyVar, writeMutTyVar,
newHoleTyVarTy, readHoleResult, zapToType,
SourceTyCtxt(..), checkValidTheta,
checkValidTyCon, checkValidClass,
checkValidInstHead, instTypeErr, checkAmbiguity,
+ arityErr,
--------------------------------
-- Zonking
import DataCon ( DataCon, dataConWrapId, dataConName, dataConSig, dataConFieldLabels )
import FieldLabel ( fieldLabelName, fieldLabelType )
import PrimRep ( PrimRep(VoidRep) )
-import Var ( TyVar, idType, idName, tyVarKind, tyVarName, isTyVar, mkTyVar, isMutTyVar )
+import Var ( TyVar, idType, idName, tyVarKind, tyVarName, isTyVar,
+ mkTyVar, mkMutTyVar, isMutTyVar, mutTyVarRef )
-- others:
import Generics ( validGenericMethodType )
-import TcMonad -- TcType, amongst others
+import TcRnMonad -- TcType, amongst others
import TysWiredIn ( voidTy, listTyCon, tupleTyCon )
import PrelNames ( cCallableClassKey, cReturnableClassKey, hasKey )
import ForeignCall ( Safety(..) )
%************************************************************************
\begin{code}
-newTyVar :: Kind -> NF_TcM TcTyVar
+newMutTyVar :: Name -> Kind -> TyVarDetails -> TcM TyVar
+newMutTyVar name kind details
+ = do { ref <- newMutVar Nothing ;
+ return (mkMutTyVar name kind details ref) }
+
+readMutTyVar :: TyVar -> TcM (Maybe Type)
+readMutTyVar tyvar = readMutVar (mutTyVarRef tyvar)
+
+writeMutTyVar :: TyVar -> Maybe Type -> TcM ()
+writeMutTyVar tyvar val = writeMutVar (mutTyVarRef tyvar) val
+
+newTyVar :: Kind -> TcM TcTyVar
newTyVar kind
- = tcGetUnique `thenNF_Tc` \ uniq ->
- tcNewMutTyVar (mkSystemTvNameEncoded uniq FSLIT("t")) kind VanillaTv
+ = newUnique `thenM` \ uniq ->
+ newMutTyVar (mkSystemTvNameEncoded uniq FSLIT("t")) kind VanillaTv
-newTyVarTy :: Kind -> NF_TcM TcType
+newTyVarTy :: Kind -> TcM TcType
newTyVarTy kind
- = newTyVar kind `thenNF_Tc` \ tc_tyvar ->
- returnNF_Tc (TyVarTy tc_tyvar)
+ = newTyVar kind `thenM` \ tc_tyvar ->
+ returnM (TyVarTy tc_tyvar)
-newTyVarTys :: Int -> Kind -> NF_TcM [TcType]
-newTyVarTys n kind = mapNF_Tc newTyVarTy (nOfThem n kind)
+newTyVarTys :: Int -> Kind -> TcM [TcType]
+newTyVarTys n kind = mappM newTyVarTy (nOfThem n kind)
-newKindVar :: NF_TcM TcKind
+newKindVar :: TcM TcKind
newKindVar
- = tcGetUnique `thenNF_Tc` \ uniq ->
- tcNewMutTyVar (mkSystemTvNameEncoded uniq FSLIT("k")) superKind VanillaTv `thenNF_Tc` \ kv ->
- returnNF_Tc (TyVarTy kv)
+ = newUnique `thenM` \ uniq ->
+ newMutTyVar (mkSystemTvNameEncoded uniq FSLIT("k")) superKind VanillaTv `thenM` \ kv ->
+ returnM (TyVarTy kv)
-newKindVars :: Int -> NF_TcM [TcKind]
-newKindVars n = mapNF_Tc (\ _ -> newKindVar) (nOfThem n ())
+newKindVars :: Int -> TcM [TcKind]
+newKindVars n = mappM (\ _ -> newKindVar) (nOfThem n ())
-newBoxityVar :: NF_TcM TcKind
+newBoxityVar :: TcM TcKind
newBoxityVar
- = tcGetUnique `thenNF_Tc` \ uniq ->
- tcNewMutTyVar (mkSystemTvNameEncoded uniq FSLIT("bx")) superBoxity VanillaTv `thenNF_Tc` \ kv ->
- returnNF_Tc (TyVarTy kv)
+ = newUnique `thenM` \ uniq ->
+ newMutTyVar (mkSystemTvNameEncoded uniq FSLIT("bx")) superBoxity VanillaTv `thenM` \ kv ->
+ returnM (TyVarTy kv)
\end{code}
%************************************************************************
\begin{code}
-newHoleTyVarTy :: NF_TcM TcType
- = tcGetUnique `thenNF_Tc` \ uniq ->
- tcNewMutTyVar (mkSystemTvNameEncoded uniq FSLIT("h")) openTypeKind HoleTv `thenNF_Tc` \ tv ->
- returnNF_Tc (TyVarTy tv)
+newHoleTyVarTy :: TcM TcType
+ = newUnique `thenM` \ uniq ->
+ newMutTyVar (mkSystemTvNameEncoded uniq FSLIT("h")) openTypeKind HoleTv `thenM` \ tv ->
+ returnM (TyVarTy tv)
-readHoleResult :: TcType -> NF_TcM TcType
+readHoleResult :: TcType -> TcM TcType
-- Read the answer out of a hole, constructed by newHoleTyVarTy
readHoleResult (TyVarTy tv)
= ASSERT( isHoleTyVar tv )
- getTcTyVar tv `thenNF_Tc` \ maybe_res ->
+ getTcTyVar tv `thenM` \ maybe_res ->
case maybe_res of
- Just ty -> returnNF_Tc ty
+ Just ty -> returnM ty
Nothing -> pprPanic "readHoleResult: empty" (ppr tv)
readHoleResult ty = pprPanic "readHoleResult: not hole" (ppr ty)
-zapToType :: TcType -> NF_TcM TcType
+zapToType :: TcType -> TcM TcType
zapToType (TyVarTy tv)
| isHoleTyVar tv
- = getTcTyVar tv `thenNF_Tc` \ maybe_res ->
+ = getTcTyVar tv `thenM` \ maybe_res ->
case maybe_res of
- Nothing -> newTyVarTy openTypeKind `thenNF_Tc` \ ty ->
- putTcTyVar tv ty `thenNF_Tc_`
- returnNF_Tc ty
- Just ty -> returnNF_Tc ty -- No need to loop; we never
+ Nothing -> newTyVarTy openTypeKind `thenM` \ ty ->
+ putTcTyVar tv ty `thenM_`
+ returnM ty
+ Just ty -> returnM ty -- No need to loop; we never
-- have chains of holes
-zapToType other_ty = returnNF_Tc other_ty
+zapToType other_ty = returnM other_ty
\end{code}
%************************************************************************
\begin{code}
tcInstTyVars :: TyVarDetails -> [TyVar]
- -> NF_TcM ([TcTyVar], [TcType], Subst)
+ -> TcM ([TcTyVar], [TcType], Subst)
tcInstTyVars tv_details tyvars
- = mapNF_Tc (tcInstTyVar tv_details) tyvars `thenNF_Tc` \ tc_tyvars ->
+ = mappM (tcInstTyVar tv_details) tyvars `thenM` \ tc_tyvars ->
let
tys = mkTyVarTys tc_tyvars
in
- returnNF_Tc (tc_tyvars, tys, mkTopTyVarSubst tyvars tys)
+ returnM (tc_tyvars, tys, mkTopTyVarSubst tyvars tys)
-- Since the tyvars are freshly made,
-- they cannot possibly be captured by
-- any existing for-alls. Hence mkTopTyVarSubst
tcInstTyVar tv_details tyvar
- = tcGetUnique `thenNF_Tc` \ uniq ->
+ = newUnique `thenM` \ uniq ->
let
name = setNameUnique (tyVarName tyvar) uniq
-- Note that we don't change the print-name
-- Better watch out for this. If worst comes to worst, just
-- use mkSystemName.
in
- tcNewMutTyVar name (tyVarKind tyvar) tv_details
+ newMutTyVar name (tyVarKind tyvar) tv_details
-tcInstType :: TyVarDetails -> TcType -> NF_TcM ([TcTyVar], TcThetaType, TcType)
+tcInstType :: TyVarDetails -> TcType -> TcM ([TcTyVar], TcThetaType, TcType)
-- tcInstType instantiates the outer-level for-alls of a TcType with
-- fresh (mutable) type variables, splits off the dictionary part,
-- and returns the pieces.
let
(theta, tau) = tcSplitPhiTy rho
in
- returnNF_Tc ([], theta, tau)
+ returnM ([], theta, tau)
- (tyvars, rho) -> tcInstTyVars tv_details tyvars `thenNF_Tc` \ (tyvars', _, tenv) ->
+ (tyvars, rho) -> tcInstTyVars tv_details tyvars `thenM` \ (tyvars', _, tenv) ->
let
(theta, tau) = tcSplitPhiTy (substTy tenv rho)
in
- returnNF_Tc (tyvars', theta, tau)
+ returnM (tyvars', theta, tau)
\end{code}
%************************************************************************
\begin{code}
-putTcTyVar :: TcTyVar -> TcType -> NF_TcM TcType
-getTcTyVar :: TcTyVar -> NF_TcM (Maybe TcType)
+putTcTyVar :: TcTyVar -> TcType -> TcM TcType
+getTcTyVar :: TcTyVar -> TcM (Maybe TcType)
\end{code}
Putting is easy:
putTcTyVar tyvar ty
| not (isMutTyVar tyvar)
= pprTrace "putTcTyVar" (ppr tyvar) $
- returnNF_Tc ty
+ returnM ty
| otherwise
= ASSERT( isMutTyVar tyvar )
- tcWriteMutTyVar tyvar (Just ty) `thenNF_Tc_`
- returnNF_Tc ty
+ writeMutTyVar tyvar (Just ty) `thenM_`
+ returnM ty
\end{code}
Getting is more interesting. The easy thing to do is just to read, thus:
\begin{verbatim}
-getTcTyVar tyvar = tcReadMutTyVar tyvar
+getTcTyVar tyvar = readMutTyVar tyvar
\end{verbatim}
But it's more fun to short out indirections on the way: If this
getTcTyVar tyvar
| not (isMutTyVar tyvar)
= pprTrace "getTcTyVar" (ppr tyvar) $
- returnNF_Tc (Just (mkTyVarTy tyvar))
+ returnM (Just (mkTyVarTy tyvar))
| otherwise
= ASSERT2( isMutTyVar tyvar, ppr tyvar )
- tcReadMutTyVar tyvar `thenNF_Tc` \ maybe_ty ->
+ readMutTyVar tyvar `thenM` \ maybe_ty ->
case maybe_ty of
- Just ty -> short_out ty `thenNF_Tc` \ ty' ->
- tcWriteMutTyVar tyvar (Just ty') `thenNF_Tc_`
- returnNF_Tc (Just ty')
+ Just ty -> short_out ty `thenM` \ ty' ->
+ writeMutTyVar tyvar (Just ty') `thenM_`
+ returnM (Just ty')
- Nothing -> returnNF_Tc Nothing
+ Nothing -> returnM Nothing
-short_out :: TcType -> NF_TcM TcType
+short_out :: TcType -> TcM TcType
short_out ty@(TyVarTy tyvar)
| not (isMutTyVar tyvar)
- = returnNF_Tc ty
+ = returnM ty
| otherwise
- = tcReadMutTyVar tyvar `thenNF_Tc` \ maybe_ty ->
+ = readMutTyVar tyvar `thenM` \ maybe_ty ->
case maybe_ty of
- Just ty' -> short_out ty' `thenNF_Tc` \ ty' ->
- tcWriteMutTyVar tyvar (Just ty') `thenNF_Tc_`
- returnNF_Tc ty'
+ Just ty' -> short_out ty' `thenM` \ ty' ->
+ writeMutTyVar tyvar (Just ty') `thenM_`
+ returnM ty'
- other -> returnNF_Tc ty
+ other -> returnM ty
-short_out other_ty = returnNF_Tc other_ty
+short_out other_ty = returnM other_ty
\end{code}
----------------- Type variables
\begin{code}
-zonkTcTyVars :: [TcTyVar] -> NF_TcM [TcType]
-zonkTcTyVars tyvars = mapNF_Tc zonkTcTyVar tyvars
+zonkTcTyVars :: [TcTyVar] -> TcM [TcType]
+zonkTcTyVars tyvars = mappM zonkTcTyVar tyvars
-zonkTcTyVarsAndFV :: [TcTyVar] -> NF_TcM TcTyVarSet
-zonkTcTyVarsAndFV tyvars = mapNF_Tc zonkTcTyVar tyvars `thenNF_Tc` \ tys ->
- returnNF_Tc (tyVarsOfTypes tys)
+zonkTcTyVarsAndFV :: [TcTyVar] -> TcM TcTyVarSet
+zonkTcTyVarsAndFV tyvars = mappM zonkTcTyVar tyvars `thenM` \ tys ->
+ returnM (tyVarsOfTypes tys)
-zonkTcTyVar :: TcTyVar -> NF_TcM TcType
-zonkTcTyVar tyvar = zonkTyVar (\ tv -> returnNF_Tc (TyVarTy tv)) tyvar
+zonkTcTyVar :: TcTyVar -> TcM TcType
+zonkTcTyVar tyvar = zonkTyVar (\ tv -> returnM (TyVarTy tv)) tyvar
\end{code}
----------------- Types
\begin{code}
-zonkTcType :: TcType -> NF_TcM TcType
-zonkTcType ty = zonkType (\ tv -> returnNF_Tc (TyVarTy tv)) ty
+zonkTcType :: TcType -> TcM TcType
+zonkTcType ty = zonkType (\ tv -> returnM (TyVarTy tv)) ty
-zonkTcTypes :: [TcType] -> NF_TcM [TcType]
-zonkTcTypes tys = mapNF_Tc zonkTcType tys
+zonkTcTypes :: [TcType] -> TcM [TcType]
+zonkTcTypes tys = mappM zonkTcType tys
-zonkTcClassConstraints cts = mapNF_Tc zonk cts
+zonkTcClassConstraints cts = mappM zonk cts
where zonk (clas, tys)
- = zonkTcTypes tys `thenNF_Tc` \ new_tys ->
- returnNF_Tc (clas, new_tys)
+ = zonkTcTypes tys `thenM` \ new_tys ->
+ returnM (clas, new_tys)
-zonkTcThetaType :: TcThetaType -> NF_TcM TcThetaType
-zonkTcThetaType theta = mapNF_Tc zonkTcPredType theta
+zonkTcThetaType :: TcThetaType -> TcM TcThetaType
+zonkTcThetaType theta = mappM zonkTcPredType theta
-zonkTcPredType :: TcPredType -> NF_TcM TcPredType
+zonkTcPredType :: TcPredType -> TcM TcPredType
zonkTcPredType (ClassP c ts)
- = zonkTcTypes ts `thenNF_Tc` \ new_ts ->
- returnNF_Tc (ClassP c new_ts)
+ = zonkTcTypes ts `thenM` \ new_ts ->
+ returnM (ClassP c new_ts)
zonkTcPredType (IParam n t)
- = zonkTcType t `thenNF_Tc` \ new_t ->
- returnNF_Tc (IParam n new_t)
+ = zonkTcType t `thenM` \ new_t ->
+ returnM (IParam n new_t)
\end{code}
------------------- These ...ToType, ...ToKind versions
are used at the end of type checking
\begin{code}
-zonkKindEnv :: [(Name, TcKind)] -> NF_TcM [(Name, Kind)]
+zonkKindEnv :: [(Name, TcKind)] -> TcM [(Name, Kind)]
zonkKindEnv pairs
- = mapNF_Tc zonk_it pairs
+ = mappM zonk_it pairs
where
- zonk_it (name, tc_kind) = zonkType zonk_unbound_kind_var tc_kind `thenNF_Tc` \ kind ->
- returnNF_Tc (name, kind)
+ zonk_it (name, tc_kind) = zonkType zonk_unbound_kind_var tc_kind `thenM` \ kind ->
+ returnM (name, kind)
-- When zonking a kind, we want to
-- zonk a *kind* variable to (Type *)
| tyVarKind kv `eqKind` superBoxity = putTcTyVar kv liftedBoxity
| otherwise = pprPanic "zonkKindEnv" (ppr kv)
-zonkTcTypeToType :: TcType -> NF_TcM Type
+zonkTcTypeToType :: TcType -> TcM Type
zonkTcTypeToType ty = zonkType zonk_unbound_tyvar ty
where
-- Zonk a mutable but unbound type variable to an arbitrary type
-- Now any bound occurences of the original type variable will get
-- zonked to the immutable version.
-zonkTcTyVarToTyVar :: TcTyVar -> NF_TcM TyVar
+zonkTcTyVarToTyVar :: TcTyVar -> TcM TyVar
zonkTcTyVarToTyVar tv
= let
-- Make an immutable version, defaulting
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 ->
+ zonkTyVar zap tv `thenM` \ ty2 ->
-- This warning shows up if the allegedly-unbound tyvar is
-- already bound to something. It can actually happen, and
-- it's only a warning
WARN( not (immut_tv_ty `tcEqType` ty2), ppr tv $$ ppr immut_tv $$ ppr ty2 )
- returnNF_Tc immut_tv
+ returnM immut_tv
\end{code}
[Silly Type Synonyms]
-- For tyvars bound at a for-all, zonkType zonks them to an immutable
-- type variable and zonks the kind too
-zonkType :: (TcTyVar -> NF_TcM Type) -- What to do with unbound mutable type variables
+zonkType :: (TcTyVar -> TcM Type) -- What to do with unbound mutable type variables
-- see zonkTcType, and zonkTcTypeToType
-> TcType
- -> NF_TcM Type
+ -> TcM Type
zonkType unbound_var_fn ty
= go ty
where
- go (TyConApp tycon tys) = mapNF_Tc go tys `thenNF_Tc` \ tys' ->
- returnNF_Tc (TyConApp tycon tys')
+ go (TyConApp tycon tys) = mappM go tys `thenM` \ tys' ->
+ returnM (TyConApp tycon tys')
- go (NoteTy (SynNote ty1) ty2) = go ty1 `thenNF_Tc` \ ty1' ->
- go ty2 `thenNF_Tc` \ ty2' ->
- returnNF_Tc (NoteTy (SynNote ty1') ty2')
+ go (NoteTy (SynNote ty1) ty2) = go ty1 `thenM` \ ty1' ->
+ go ty2 `thenM` \ ty2' ->
+ returnM (NoteTy (SynNote ty1') ty2')
go (NoteTy (FTVNote _) ty2) = go ty2 -- Discard free-tyvar annotations
- go (SourceTy p) = go_pred p `thenNF_Tc` \ p' ->
- returnNF_Tc (SourceTy p')
+ go (SourceTy p) = go_pred p `thenM` \ p' ->
+ returnM (SourceTy p')
- go (FunTy arg res) = go arg `thenNF_Tc` \ arg' ->
- go res `thenNF_Tc` \ res' ->
- returnNF_Tc (FunTy arg' res')
+ go (FunTy arg res) = go arg `thenM` \ arg' ->
+ go res `thenM` \ res' ->
+ returnM (FunTy arg' res')
- go (AppTy fun arg) = go fun `thenNF_Tc` \ fun' ->
- go arg `thenNF_Tc` \ arg' ->
- returnNF_Tc (mkAppTy fun' arg')
+ go (AppTy fun arg) = go fun `thenM` \ fun' ->
+ go arg `thenM` \ arg' ->
+ returnM (mkAppTy fun' arg')
-- NB the mkAppTy; we might have instantiated a
-- type variable to a type constructor, so we need
-- to pull the TyConApp to the top.
-- The two interesting cases!
go (TyVarTy tyvar) = zonkTyVar unbound_var_fn tyvar
- go (ForAllTy tyvar ty) = zonkTcTyVarToTyVar tyvar `thenNF_Tc` \ tyvar' ->
- go ty `thenNF_Tc` \ ty' ->
- returnNF_Tc (ForAllTy tyvar' ty')
+ go (ForAllTy tyvar ty) = zonkTcTyVarToTyVar tyvar `thenM` \ tyvar' ->
+ go ty `thenM` \ ty' ->
+ returnM (ForAllTy tyvar' ty')
- go_pred (ClassP c tys) = mapNF_Tc go tys `thenNF_Tc` \ tys' ->
- returnNF_Tc (ClassP c tys')
- go_pred (NType tc tys) = mapNF_Tc go tys `thenNF_Tc` \ tys' ->
- returnNF_Tc (NType tc tys')
- go_pred (IParam n ty) = go ty `thenNF_Tc` \ ty' ->
- returnNF_Tc (IParam n ty')
+ go_pred (ClassP c tys) = mappM go tys `thenM` \ tys' ->
+ returnM (ClassP c tys')
+ go_pred (NType tc tys) = mappM go tys `thenM` \ tys' ->
+ returnM (NType tc tys')
+ go_pred (IParam n ty) = go ty `thenM` \ ty' ->
+ returnM (IParam n ty')
-zonkTyVar :: (TcTyVar -> NF_TcM Type) -- What to do for an unbound mutable variable
- -> TcTyVar -> NF_TcM TcType
+zonkTyVar :: (TcTyVar -> TcM Type) -- What to do for an unbound mutable variable
+ -> TcTyVar -> TcM 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)
+ returnM (TyVarTy tyvar)
| otherwise
- = getTcTyVar tyvar `thenNF_Tc` \ maybe_ty ->
+ = getTcTyVar tyvar `thenM` \ maybe_ty ->
case maybe_ty of
Nothing -> unbound_var_fn tyvar -- Mutable and unbound
Just other_ty -> zonkType unbound_var_fn other_ty -- Bound
checkValidType :: UserTypeCtxt -> Type -> TcM ()
-- Checks that the type is valid for the given context
checkValidType ctxt ty
- = doptsTc Opt_GlasgowExts `thenNF_Tc` \ gla_exts ->
+ = doptM Opt_GlasgowExts `thenM` \ gla_exts ->
let
rank | gla_exts = Arbitrary
| otherwise
-- but for type synonyms we allow them even at
-- top level
in
- tcAddErrCtxt (checkTypeCtxt ctxt ty) $
+ addErrCtxt (checkTypeCtxt ctxt ty) $
-- Check that the thing has kind Type, and is lifted if necessary
- checkTc kind_ok (kindErr actual_kind) `thenTc_`
+ checkTc kind_ok (kindErr actual_kind) `thenM_`
-- Check the internal validity of the type itself
check_poly_type rank ubx_tup ty
= let
(tvs, theta, tau) = tcSplitSigmaTy ty
in
- check_valid_theta SigmaCtxt theta `thenTc_`
- check_tau_type (decRank rank) ubx_tup tau `thenTc_`
- checkFreeness tvs theta `thenTc_`
+ check_valid_theta SigmaCtxt theta `thenM_`
+ check_tau_type (decRank rank) ubx_tup tau `thenM_`
+ checkFreeness tvs theta `thenM_`
checkAmbiguity tvs theta (tyVarsOfType tau)
----------------------------------------
-- Anyway, they are dealt with by a special case in check_tau_type
check_arg_type ty
- = check_tau_type (Rank 0) UT_NotOk ty `thenTc_`
+ = check_tau_type (Rank 0) UT_NotOk ty `thenM_`
checkTc (not (isUnLiftedType ty)) (unliftedArgErr ty)
----------------------------------------
-- No foralls otherwise
check_tau_type rank ubx_tup ty@(ForAllTy _ _) = failWithTc (forAllTyErr ty)
-check_tau_type rank ubx_tup (SourceTy sty) = getDOptsTc `thenNF_Tc` \ dflags ->
+check_tau_type rank ubx_tup (SourceTy sty) = getDOpts `thenM` \ dflags ->
check_source_ty dflags TypeCtxt sty
-check_tau_type rank ubx_tup (TyVarTy _) = returnTc ()
+check_tau_type rank ubx_tup (TyVarTy _) = returnM ()
check_tau_type rank ubx_tup ty@(FunTy arg_ty res_ty)
- = check_poly_type rank UT_NotOk arg_ty `thenTc_`
+ = check_poly_type rank UT_NotOk arg_ty `thenM_`
check_tau_type rank UT_Ok res_ty
check_tau_type rank ubx_tup (AppTy ty1 ty2)
- = check_arg_type ty1 `thenTc_` check_arg_type ty2
+ = check_arg_type ty1 `thenM_` check_arg_type ty2
check_tau_type rank ubx_tup (NoteTy (SynNote syn) ty)
-- Synonym notes are built only when the synonym is
-- saturated (see Type.mkSynTy)
- = doptsTc Opt_GlasgowExts `thenNF_Tc` \ gla_exts ->
+ = doptM Opt_GlasgowExts `thenM` \ gla_exts ->
(if gla_exts then
-- If -fglasgow-exts then don't check the 'note' part.
-- This allows us to instantiate a synonym defn with a
-- But if you expand S first, then T we get just
-- f :: Int
-- which is fine.
- returnTc ()
+ returnM ()
else
-- For H98, do check the un-expanded part
check_tau_type rank ubx_tup syn
- ) `thenTc_`
+ ) `thenM_`
check_tau_type rank ubx_tup ty
= -- NB: Type.mkSynTy builds a TyConApp (not a NoteTy) for an unsaturated
-- synonym application, leaving it to checkValidType (i.e. right here)
-- to find the error
- checkTc syn_arity_ok arity_msg `thenTc_`
- mapTc_ check_arg_type tys
+ checkTc syn_arity_ok arity_msg `thenM_`
+ mappM_ check_arg_type tys
| isUnboxedTupleTyCon tc
- = doptsTc Opt_GlasgowExts `thenNF_Tc` \ gla_exts ->
- checkTc (ubx_tup_ok gla_exts) ubx_tup_msg `thenTc_`
- mapTc_ (check_tau_type (Rank 0) UT_Ok) tys
+ = doptM Opt_GlasgowExts `thenM` \ gla_exts ->
+ checkTc (ubx_tup_ok gla_exts) ubx_tup_msg `thenM_`
+ mappM_ (check_tau_type (Rank 0) UT_Ok) tys
-- Args are allowed to be unlifted, or
-- more unboxed tuples, so can't use check_arg_ty
| otherwise
- = mapTc_ check_arg_type tys
+ = mappM_ check_arg_type tys
where
ubx_tup_ok gla_exts = case ubx_tup of { UT_Ok -> gla_exts; other -> False }
kindErr kind = ptext SLIT("Expecting an ordinary type, but found a type of kind") <+> ppr kind
\end{code}
-Check for ambiguity
-~~~~~~~~~~~~~~~~~~~
- forall V. P => tau
-is ambiguous if P contains generic variables
-(i.e. one of the Vs) that are not mentioned in tau
-
-However, we need to take account of functional dependencies
-when we speak of 'mentioned in tau'. Example:
- class C a b | a -> b where ...
-Then the type
- forall x y. (C x y) => x
-is not ambiguous because x is mentioned and x determines y
-
-NB; the ambiguity check is only used for *user* types, not for types
-coming from inteface files. The latter can legitimately have
-ambiguous types. Example
-
- class S a where s :: a -> (Int,Int)
- instance S Char where s _ = (1,1)
- f:: S a => [a] -> Int -> (Int,Int)
- f (_::[a]) x = (a*x,b)
- where (a,b) = s (undefined::a)
-
-Here the worker for f gets the type
- fw :: forall a. S a => Int -> (# Int, Int #)
-
-If the list of tv_names is empty, we have a monotype, and then we
-don't need to check for ambiguity either, because the test can't fail
-(see is_ambig).
-
-\begin{code}
-checkAmbiguity :: [TyVar] -> ThetaType -> TyVarSet -> TcM ()
-checkAmbiguity forall_tyvars theta tau_tyvars
- = mapTc_ complain (filter is_ambig theta)
- where
- complain pred = addErrTc (ambigErr pred)
- extended_tau_vars = grow theta tau_tyvars
- is_ambig pred = any ambig_var (varSetElems (tyVarsOfPred pred))
-
- ambig_var ct_var = (ct_var `elem` forall_tyvars) &&
- not (ct_var `elemVarSet` extended_tau_vars)
-
- is_free ct_var = not (ct_var `elem` forall_tyvars)
-
-ambigErr pred
- = sep [ptext SLIT("Ambiguous constraint") <+> quotes (pprPred pred),
- nest 4 (ptext SLIT("At least one of the forall'd type variables mentioned by the constraint") $$
- ptext SLIT("must be reachable from the type after the '=>'"))]
-\end{code}
-
-In addition, GHC insists that at least one type variable
-in each constraint is in V. So we disallow a type like
- forall a. Eq b => b -> b
-even in a scope where b is in scope.
-
-\begin{code}
-checkFreeness forall_tyvars theta
- = mapTc_ complain (filter is_free theta)
- where
- is_free pred = not (isIPPred pred)
- && not (any bound_var (varSetElems (tyVarsOfPred pred)))
- bound_var ct_var = ct_var `elem` forall_tyvars
- complain pred = addErrTc (freeErr pred)
-
-freeErr pred
- = sep [ptext SLIT("All of the type variables in the constraint") <+> quotes (pprPred pred) <+>
- ptext SLIT("are already in scope"),
- nest 4 (ptext SLIT("(at least one must be universally quantified here)"))
- ]
-\end{code}
%************************************************************************
\begin{code}
checkValidTheta :: SourceTyCtxt -> ThetaType -> TcM ()
checkValidTheta ctxt theta
- = tcAddErrCtxt (checkThetaCtxt ctxt theta) (check_valid_theta ctxt theta)
+ = addErrCtxt (checkThetaCtxt ctxt theta) (check_valid_theta ctxt theta)
-------------------------
check_valid_theta ctxt []
- = returnTc ()
+ = returnM ()
check_valid_theta ctxt theta
- = getDOptsTc `thenNF_Tc` \ dflags ->
- warnTc (notNull dups) (dupPredWarn dups) `thenNF_Tc_`
+ = getDOpts `thenM` \ dflags ->
+ warnTc (notNull dups) (dupPredWarn dups) `thenM_`
-- Actually, in instance decls and type signatures,
-- duplicate constraints are eliminated by TcMonoType.hoistForAllTys,
-- so this error can only fire for the context of a class or
-- data type decl.
- mapTc_ (check_source_ty dflags ctxt) theta
+ mappM_ (check_source_ty dflags ctxt) theta
where
(_,dups) = removeDups tcCmpPred theta
-------------------------
check_source_ty dflags ctxt pred@(ClassP cls tys)
= -- Class predicates are valid in all contexts
- mapTc_ check_arg_type tys `thenTc_`
- checkTc (arity == n_tys) arity_err `thenTc_`
+ mappM_ check_arg_type tys `thenM_`
+ checkTc (arity == n_tys) arity_err `thenM_`
checkTc (check_class_pred_tys dflags ctxt tys)
(predTyVarErr pred $$ how_to_allow)
-- constraint Foo [Int] might come out of e,and applying the
-- instance decl would show up two uses of ?x.
-check_source_ty dflags TypeCtxt (NType tc tys) = mapTc_ check_arg_type tys
+check_source_ty dflags TypeCtxt (NType tc tys) = mappM_ check_arg_type tys
-- Catch-all
check_source_ty dflags ctxt sty = failWithTc (badSourceTyErr sty)
Nothing -> False
\end{code}
+Check for ambiguity
+~~~~~~~~~~~~~~~~~~~
+ forall V. P => tau
+is ambiguous if P contains generic variables
+(i.e. one of the Vs) that are not mentioned in tau
+
+However, we need to take account of functional dependencies
+when we speak of 'mentioned in tau'. Example:
+ class C a b | a -> b where ...
+Then the type
+ forall x y. (C x y) => x
+is not ambiguous because x is mentioned and x determines y
+
+NB; the ambiguity check is only used for *user* types, not for types
+coming from inteface files. The latter can legitimately have
+ambiguous types. Example
+
+ class S a where s :: a -> (Int,Int)
+ instance S Char where s _ = (1,1)
+ f:: S a => [a] -> Int -> (Int,Int)
+ f (_::[a]) x = (a*x,b)
+ where (a,b) = s (undefined::a)
+
+Here the worker for f gets the type
+ fw :: forall a. S a => Int -> (# Int, Int #)
+
+If the list of tv_names is empty, we have a monotype, and then we
+don't need to check for ambiguity either, because the test can't fail
+(see is_ambig).
+
\begin{code}
-badSourceTyErr sty = ptext SLIT("Illegal constraint") <+> pprSourceType sty
-predTyVarErr pred = ptext SLIT("Non-type variables in constraint:") <+> pprPred pred
-dupPredWarn dups = ptext SLIT("Duplicate constraint(s):") <+> pprWithCommas pprPred (map head dups)
+checkAmbiguity :: [TyVar] -> ThetaType -> TyVarSet -> TcM ()
+checkAmbiguity forall_tyvars theta tau_tyvars
+ = mappM_ complain (filter is_ambig theta)
+ where
+ complain pred = addErrTc (ambigErr pred)
+ extended_tau_vars = grow theta tau_tyvars
+ is_ambig pred = any ambig_var (varSetElems (tyVarsOfPred pred))
+ ambig_var ct_var = (ct_var `elem` forall_tyvars) &&
+ not (ct_var `elemVarSet` extended_tau_vars)
+
+ is_free ct_var = not (ct_var `elem` forall_tyvars)
+
+ambigErr pred
+ = sep [ptext SLIT("Ambiguous constraint") <+> quotes (pprPred pred),
+ nest 4 (ptext SLIT("At least one of the forall'd type variables mentioned by the constraint") $$
+ ptext SLIT("must be reachable from the type after the '=>'"))]
+\end{code}
+
+In addition, GHC insists that at least one type variable
+in each constraint is in V. So we disallow a type like
+ forall a. Eq b => b -> b
+even in a scope where b is in scope.
+
+\begin{code}
+checkFreeness forall_tyvars theta
+ = mappM_ complain (filter is_free theta)
+ where
+ is_free pred = not (isIPPred pred)
+ && not (any bound_var (varSetElems (tyVarsOfPred pred)))
+ bound_var ct_var = ct_var `elem` forall_tyvars
+ complain pred = addErrTc (freeErr pred)
+
+freeErr pred
+ = sep [ptext SLIT("All of the type variables in the constraint") <+> quotes (pprPred pred) <+>
+ ptext SLIT("are already in scope"),
+ nest 4 (ptext SLIT("(at least one must be universally quantified here)"))
+ ]
+\end{code}
+
+\begin{code}
checkThetaCtxt ctxt theta
= vcat [ptext SLIT("In the context:") <+> pprTheta theta,
ptext SLIT("While checking") <+> pprSourceTyCtxt ctxt ]
+
+badSourceTyErr sty = ptext SLIT("Illegal constraint") <+> pprSourceType sty
+predTyVarErr pred = ptext SLIT("Non-type variables in constraint:") <+> pprPred pred
+dupPredWarn dups = ptext SLIT("Duplicate constraint(s):") <+> pprWithCommas pprPred (map head dups)
+
+arityErr kind name n m
+ = hsep [ text kind, quotes (ppr name), ptext SLIT("should have"),
+ n_arguments <> comma, text "but has been given", int m]
+ where
+ n_arguments | n == 0 = ptext SLIT("no arguments")
+ | n == 1 = ptext SLIT("1 argument")
+ | True = hsep [int n, ptext SLIT("arguments")]
\end{code}
| isSynTyCon tc = checkValidType (TySynCtxt name) syn_rhs
| otherwise
= -- Check the context on the data decl
- checkValidTheta (DataTyCtxt name) (tyConTheta tc) `thenTc_`
+ checkValidTheta (DataTyCtxt name) (tyConTheta tc) `thenM_`
-- Check arg types of data constructors
- mapTc_ checkValidDataCon data_cons `thenTc_`
+ mappM_ checkValidDataCon data_cons `thenM_`
-- Check that fields with the same name share a type
- mapTc_ check_fields groups
+ mappM_ check_fields groups
where
name = tyConName tc
checkValidDataCon :: DataCon -> TcM ()
checkValidDataCon con
- = checkValidType ctxt (idType (dataConWrapId con)) `thenTc_`
+ = checkValidType ctxt (idType (dataConWrapId con)) `thenM_`
-- This checks the argument types and
-- ambiguity of the existential context (if any)
- tcAddErrCtxt (existentialCtxt con)
+ addErrCtxt (existentialCtxt con)
(checkFreeness ex_tvs ex_theta)
where
ctxt = ConArgCtxt (dataConName con)
checkValidClass :: Class -> TcM ()
checkValidClass cls
= -- CHECK ARITY 1 FOR HASKELL 1.4
- doptsTc Opt_GlasgowExts `thenTc` \ gla_exts ->
+ doptM Opt_GlasgowExts `thenM` \ gla_exts ->
-- Check that the class is unary, unless GlaExs
- checkTc (notNull tyvars) (nullaryClassErr cls) `thenTc_`
- checkTc (gla_exts || unary) (classArityErr cls) `thenTc_`
+ checkTc (notNull tyvars) (nullaryClassErr cls) `thenM_`
+ checkTc (gla_exts || unary) (classArityErr cls) `thenM_`
-- Check the super-classes
- checkValidTheta (ClassSCCtxt (className cls)) theta `thenTc_`
+ checkValidTheta (ClassSCCtxt (className cls)) theta `thenM_`
-- Check the class operations
- mapTc_ check_op op_stuff `thenTc_`
+ mappM_ check_op op_stuff `thenM_`
-- Check that if the class has generic methods, then the
-- class has only one parameter. We can't do generic
no_generics = null [() | (_, GenDefMeth) <- op_stuff]
check_op (sel_id, dm)
- = checkValidTheta SigmaCtxt (tail theta) `thenTc_`
+ = checkValidTheta SigmaCtxt (tail theta) `thenM_`
-- The 'tail' removes the initial (C a) from the
-- class itself, leaving just the method type
- checkValidType (FunSigCtxt op_name) tau `thenTc_`
+ checkValidType (FunSigCtxt op_name) tau `thenM_`
-- Check that for a generic method, the type of
-- the method is sufficiently simple
Nothing -> failWithTc (instTypeErr (pprPred pred) empty) ;
Just (clas,tys) ->
- getDOptsTc `thenNF_Tc` \ dflags ->
- mapTc_ check_arg_type tys `thenTc_`
- check_inst_head dflags clas tys `thenTc_`
- returnTc (clas, tys)
+ getDOpts `thenM` \ dflags ->
+ mappM_ check_arg_type tys `thenM_`
+ check_inst_head dflags clas tys `thenM_`
+ returnM (clas, tys)
}}
check_inst_head dflags clas tys
all tcIsTyVarTy arg_tys, -- Applied to type variables
equalLength (varSetElems (tyVarsOfTypes arg_tys)) arg_tys
-- This last condition checks that all the type variables are distinct
- = returnTc ()
+ = returnM ()
| otherwise
= failWithTc (instTypeErr (pprClassPred clas tys) head_shape_msg)
check_tyvars dflags clas tys
-- Check that at least one isn't a type variable
-- unless -fallow-undecideable-instances
- | dopt Opt_AllowUndecidableInstances dflags = returnTc ()
- | not (all tcIsTyVarTy tys) = returnTc ()
+ | dopt Opt_AllowUndecidableInstances dflags = returnM ()
+ | not (all tcIsTyVarTy tys) = returnM ()
| otherwise = failWithTc (instTypeErr (pprClassPred clas tys) msg)
where
msg = parens (ptext SLIT("There must be at least one non-type-variable in the instance head")
HsExpr.HsMatchContext Name.Name
-> RnHsSyn.RenamedGRHSs
-> TcType.TcType
- -> TcMonad.TcM s (TcHsSyn.TcGRHSs, Inst.LIE) ;;
+ -> TcMonad.TcM s (TcHsSyn.TcGRHSs, TcMonad.LIE) ;;
3 tcMatchesFun _:_ _forall_ [s] =>
[(Name.Name,Var.Id)]
-> Name.Name
-> TcType.TcType
-> [RnHsSyn.RenamedMatch]
- -> TcMonad.TcM s ([TcHsSyn.TcMatch], Inst.LIE) ;;
+ -> TcMonad.TcM s ([TcHsSyn.TcMatch], TcMonad.LIE) ;;
1 tcGRHSs :: HsExpr.HsMatchContext Name.Name
-> RnHsSyn.RenamedGRHSs
-> TcType.TcType
- -> TcMonad.TcM (TcHsSyn.TcGRHSs, Inst.LIE) ;
+ -> TcRnTypes.TcM TcHsSyn.TcGRHSs ;
1 tcMatchesFun ::
[(Name.Name,Var.Id)]
-> Name.Name
-> TcType.TcType
-> [RnHsSyn.RenamedMatch]
- -> TcMonad.TcM ([TcHsSyn.TcMatch], Inst.LIE) ;
+ -> TcRnTypes.TcM [TcHsSyn.TcMatch] ;
tcGRHSs :: HsExpr.HsMatchContext Name.Name
-> RnHsSyn.RenamedGRHSs
-> TcType.TcType
- -> TcMonad.TcM (TcHsSyn.TcGRHSs, Inst.LIE)
+ -> TcRnTypes.TcM TcHsSyn.TcGRHSs
tcMatchesFun ::
[(Name.Name,Var.Id)]
-> Name.Name
-> TcType.TcType
-> [RnHsSyn.RenamedMatch]
- -> TcMonad.TcM ([TcHsSyn.TcMatch], Inst.LIE)
+ -> TcRnTypes.TcM [TcHsSyn.TcMatch]
\begin{code}
module TcMatches ( tcMatchesFun, tcMatchesCase, tcMatchLambda,
- tcStmts, tcStmtsAndThen, tcGRHSs
+ tcDoStmts, tcStmtsAndThen, tcGRHSs
) where
#include "HsVersions.h"
import {-# SOURCE #-} TcExpr( tcMonoExpr )
-import HsSyn ( HsBinds(..), Match(..), GRHSs(..), GRHS(..),
+import HsSyn ( HsExpr(..), HsBinds(..), Match(..), GRHSs(..), GRHS(..),
MonoBinds(..), Stmt(..), HsMatchContext(..), HsDoContext(..),
pprMatch, getMatchLoc, pprMatchContext, isDoExpr,
- mkMonoBind, nullMonoBinds, collectSigTysFromPats
+ mkMonoBind, nullMonoBinds, collectSigTysFromPats, andMonoBindList
)
-import RnHsSyn ( RenamedMatch, RenamedGRHSs, RenamedStmt, RenamedPat, RenamedMatchContext )
-import TcHsSyn ( TcMatch, TcGRHSs, TcStmt, TcDictBinds, TypecheckedPat )
+import RnHsSyn ( RenamedMatch, RenamedGRHSs, RenamedStmt,
+ RenamedPat, RenamedMatchContext )
+import TcHsSyn ( TcMatch, TcGRHSs, TcStmt, TcDictBinds,
+ TcMonoBinds, TcPat, TcStmt )
-import TcMonad
+import TcRnMonad
import TcMonoType ( tcAddScopedTyVars, tcHsSigType, UserTypeCtxt(..) )
-import Inst ( LIE, isEmptyLIE, plusLIE, emptyLIE, plusLIEs, lieToList )
+import Inst ( tcSyntaxName )
import TcEnv ( TcId, tcLookupLocalIds, tcExtendLocalValEnv2 )
import TcPat ( tcPat, tcMonoPatBndr )
import TcMType ( newTyVarTy, zonkTcType, zapToType )
import TcType ( TcType, TcTyVar, tyVarsOfType, tidyOpenTypes, tidyOpenType,
- mkFunTy, isOverloadedTy, liftedTypeKind, openTypeKind )
+ mkFunTy, isOverloadedTy, liftedTypeKind, openTypeKind,
+ mkArrowKind, mkAppTy )
import TcBinds ( tcBindsAndThen )
-import TcUnify ( subFunTy, checkSigTyVarsWrt, tcSubExp, isIdCoercion, (<$>) )
+import TcUnify ( unifyPArrTy,subFunTy, unifyListTy, unifyTauTy,
+ checkSigTyVarsWrt, tcSubExp, isIdCoercion, (<$>) )
import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns )
import Name ( Name )
-import TysWiredIn ( boolTy )
-import Id ( idType )
+import PrelNames ( monadNames )
+import TysWiredIn ( boolTy, mkListTy, mkPArrTy )
+import Id ( idType, mkSysLocal )
import CoreFVs ( idFreeTyVars )
import BasicTypes ( RecFlag(..) )
import VarSet
import Var ( Id )
import Bag
-import Util ( isSingleton, lengthExceeds, notNull )
+import Util ( isSingleton, lengthExceeds, notNull, zipEqual )
import Outputable
import List ( nub )
-> Name
-> TcType -- Expected type
-> [RenamedMatch]
- -> TcM ([TcMatch], LIE)
+ -> TcM [TcMatch]
tcMatchesFun xve fun_name expected_ty matches@(first_match:_)
= -- Check that they all have the same no of arguments
-- 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) (
+ addSrcLoc (getMatchLoc first_match) (
checkTc (sameNoOfArgs matches)
(varyingArgsErr fun_name matches)
- ) `thenTc_`
+ ) `thenM_`
-- ToDo: Don't use "expected" stuff if there ain't a type signature
-- because inconsistency between branches
tcMatchesCase :: [RenamedMatch] -- The case alternatives
-> TcType -- Type of whole case expressions
-> TcM (TcType, -- Inferred type of the scrutinee
- [TcMatch], -- Translated alternatives
- LIE)
+ [TcMatch]) -- Translated alternatives
tcMatchesCase matches expr_ty
- = newTyVarTy openTypeKind `thenNF_Tc` \ scrut_ty ->
- tcMatches [] CaseAlt matches (mkFunTy scrut_ty expr_ty) `thenTc` \ (matches', lie) ->
- returnTc (scrut_ty, matches', lie)
+ = newTyVarTy openTypeKind `thenM` \ scrut_ty ->
+ tcMatches [] CaseAlt matches (mkFunTy scrut_ty expr_ty) `thenM` \ matches' ->
+ returnM (scrut_ty, matches')
-tcMatchLambda :: RenamedMatch -> TcType -> TcM (TcMatch, LIE)
+tcMatchLambda :: RenamedMatch -> TcType -> TcM TcMatch
tcMatchLambda match res_ty = tcMatch [] LambdaExpr match res_ty
\end{code}
-> RenamedMatchContext
-> [RenamedMatch]
-> TcType
- -> TcM ([TcMatch], LIE)
+ -> TcM [TcMatch]
tcMatches xve ctxt matches expected_ty
= -- If there is more than one branch, and expected_ty is a 'hole',
(if lengthExceeds matches 1 then
zapToType expected_ty
else
- returnNF_Tc expected_ty) `thenNF_Tc` \ expected_ty' ->
+ returnM expected_ty) `thenM` \ expected_ty' ->
- mapAndUnzipTc (tc_match expected_ty') matches `thenTc` \ (matches, lies) ->
- returnTc (matches, plusLIEs lies)
+ mappM (tc_match expected_ty') matches
where
tc_match expected_ty match = tcMatch xve ctxt match expected_ty
\end{code}
-- We regard the Match as having type
-- (ty1 -> ... -> tyn -> result_ty)
-- where there are n patterns.
- -> TcM (TcMatch, LIE)
+ -> TcM TcMatch
tcMatch xve1 ctxt match@(Match pats maybe_rhs_sig grhss) expected_ty
- = tcAddSrcLoc (getMatchLoc match) $ -- At one stage I removed this;
- tcAddErrCtxt (matchCtxt ctxt match) $ -- I'm not sure why, so I put it back
- tcMatchPats pats expected_ty tc_grhss `thenTc` \ (pats', grhss', lie, ex_binds) ->
- returnTc (Match pats' Nothing (glue_on Recursive ex_binds grhss'), lie)
+ = addSrcLoc (getMatchLoc match) $ -- At one stage I removed this;
+ addErrCtxt (matchCtxt ctxt match) $ -- I'm not sure why, so I put it back
+ tcMatchPats pats expected_ty tc_grhss `thenM` \ (pats', grhss', ex_binds) ->
+ returnM (Match pats' Nothing (glue_on Recursive ex_binds grhss'))
where
tc_grhss rhs_ty
Just sig -> tcAddScopedTyVars [sig] $
-- Bring into scope the type variables in the signature
- tcHsSigType ResSigCtxt sig `thenTc` \ sig_ty ->
- tcGRHSs ctxt grhss sig_ty `thenTc` \ (grhss', lie1) ->
- tcSubExp rhs_ty sig_ty `thenTc` \ (co_fn, lie2) ->
- returnTc (lift_grhss co_fn rhs_ty grhss',
- lie1 `plusLIE` lie2)
+ tcHsSigType ResSigCtxt sig `thenM` \ sig_ty ->
+ tcGRHSs ctxt grhss sig_ty `thenM` \ grhss' ->
+ tcSubExp rhs_ty sig_ty `thenM` \ co_fn ->
+ returnM (lift_grhss co_fn rhs_ty grhss')
-- lift_grhss pushes the coercion down to the right hand sides,
-- because there is no convenient place to hang it otherwise.
tcGRHSs :: RenamedMatchContext -> RenamedGRHSs
-> TcType
- -> TcM (TcGRHSs, LIE)
+ -> TcM TcGRHSs
tcGRHSs ctxt (GRHSs grhss binds _) expected_ty
= tcBindsAndThen glue_on binds (tc_grhss grhss)
where
tc_grhss grhss
- = mapAndUnzipTc tc_grhs grhss `thenTc` \ (grhss', lies) ->
- returnTc (GRHSs grhss' EmptyBinds expected_ty, plusLIEs lies)
+ = mappM tc_grhs grhss `thenM` \ grhss' ->
+ returnM (GRHSs grhss' EmptyBinds expected_ty)
tc_grhs (GRHS guarded locn)
- = tcAddSrcLoc locn $
- tcStmts ctxt (\ty -> ty, expected_ty) guarded `thenTc` \ (guarded', lie) ->
- returnTc (GRHS guarded' locn, lie)
+ = addSrcLoc locn $
+ tcStmts ctxt (\ty -> ty, expected_ty) guarded `thenM` \ guarded' ->
+ returnM (GRHS guarded' locn)
\end{code}
\begin{code}
tcMatchPats
:: [RenamedPat] -> TcType
- -> (TcType -> TcM (a, LIE))
- -> TcM ([TypecheckedPat], a, LIE, TcDictBinds)
+ -> (TcType -> TcM a)
+ -> TcM ([TcPat], a, TcDictBinds)
-- Typecheck the patterns, extend the environment to bind the variables,
-- do the thing inside, use any existentially-bound dictionaries to
-- discharge parts of the returning LIE, and deal with pattern type
-- STEP 2: Typecheck the patterns themselves, gathering all the stuff
-- then do the thing inside
- tc_match_pats pats expected_ty thing_inside
+ getLIE (tc_match_pats pats expected_ty thing_inside)
- ) `thenTc` \ (pats', lie_req, ex_tvs, ex_ids, ex_lie, result) ->
+ ) `thenM` \ ((pats', ex_tvs, ex_ids, ex_lie, result), lie_req) ->
-- STEP 4: Check for existentially bound type variables
-- Do this *outside* the scope of the tcAddScopedTyVars, else checkSigTyVars
-- I'm a bit concerned that lie_req1 from an 'inner' pattern in the list
-- might need (via lie_req2) something made available from an 'outer'
-- pattern. But it's inconvenient to deal with, and I can't find an example
- tcCheckExistentialPat ex_tvs ex_ids ex_lie lie_req expected_ty `thenTc` \ (lie_req', ex_binds) ->
+ tcCheckExistentialPat ex_tvs ex_ids ex_lie lie_req expected_ty `thenM` \ ex_binds ->
-- NB: we *must* pass "expected_ty" not "result_ty" to tcCheckExistentialPat
-- For example, we must reject this program:
-- data C = forall a. C (a -> Int)
-- f (C g) x = g x
-- Here, result_ty will be simply Int, but expected_ty is (a -> Int).
- returnTc (pats', result, lie_req', ex_binds)
+ returnM (pats', result, ex_binds)
tc_match_pats [] expected_ty thing_inside
- = thing_inside expected_ty `thenTc` \ (answer, lie) ->
- returnTc ([], lie, emptyBag, [], emptyLIE, answer)
+ = thing_inside expected_ty `thenM` \ answer ->
+ returnM ([], emptyBag, [], [], answer)
tc_match_pats (pat:pats) expected_ty thing_inside
= subFunTy expected_ty $ \ arg_ty rest_ty ->
-- This is the unique place we call subFunTy
-- The point is that if expected_y is a "hole", we want
-- to make arg_ty and rest_ty as "holes" too.
- tcPat tcMonoPatBndr pat arg_ty `thenTc` \ (pat', lie_req, ex_tvs, pat_bndrs, ex_lie) ->
+ tcPat tcMonoPatBndr pat arg_ty `thenM` \ (pat', ex_tvs, pat_bndrs, ex_lie) ->
let
xve = bagToList pat_bndrs
ex_ids = [id | (_, id) <- xve]
-- of the existential Ids used in checkExistentialPat
in
tcExtendLocalValEnv2 xve $
- tc_match_pats pats rest_ty thing_inside `thenTc` \ (pats', lie_reqs, exs_tvs, exs_ids, exs_lie, answer) ->
- returnTc ( pat':pats',
- lie_req `plusLIE` lie_reqs,
+ tc_match_pats pats rest_ty thing_inside `thenM` \ (pats', exs_tvs, exs_ids, exs_lie, answer) ->
+ returnM ( pat':pats',
ex_tvs `unionBags` exs_tvs,
ex_ids ++ exs_ids,
- ex_lie `plusLIE` exs_lie,
+ ex_lie ++ exs_lie,
answer
)
-> [TcId] -- Ids bound by this pattern; used
-- (a) by bindsInstsOfLocalFuns
-- (b) to generate helpful error messages
- -> LIE -- and context
- -> LIE -- Required context
+ -> [Inst] -- and context
+ -> [Inst] -- Required context
-> TcType -- and type of the Match; vars in here must not escape
- -> TcM (LIE, TcDictBinds) -- LIE to float out and dict bindings
+ -> TcM TcDictBinds -- LIE to float out and dict bindings
tcCheckExistentialPat ex_tvs ex_ids ex_lie lie_req match_ty
| isEmptyBag ex_tvs && all not_overloaded ex_ids
-- Short cut for case when there are no existentials
-- e.g. f :: (forall a. Ord a => a -> a) -> Int -> Int
-- f op x = ....
-- Here we must discharge op Methods
- = ASSERT( isEmptyLIE ex_lie )
- returnTc (lie_req, EmptyMonoBinds)
+ = ASSERT( null ex_lie )
+ extendLIEs lie_req `thenM_`
+ returnM EmptyMonoBinds
| otherwise
- = tcAddErrCtxtM (sigPatCtxt tv_list ex_ids match_ty) $
+ = addErrCtxtM (sigPatCtxt tv_list ex_ids match_ty) $
-- 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 ex_ids `thenTc` \ (lie1, inst_binds) ->
+ getLIE (bindInstsOfLocalFuns lie_req ex_ids) `thenM` \ (inst_binds, lie) ->
-- Deal with overloaded functions bound by the pattern
- tcSimplifyCheck doc tv_list (lieToList ex_lie) lie1 `thenTc` \ (lie2, dict_binds) ->
- checkSigTyVarsWrt (tyVarsOfType match_ty) tv_list `thenTc_`
+ tcSimplifyCheck doc tv_list ex_lie lie `thenM` \ dict_binds ->
+ checkSigTyVarsWrt (tyVarsOfType match_ty) tv_list `thenM_`
- returnTc (lie2, dict_binds `AndMonoBinds` inst_binds)
+ returnM (dict_binds `AndMonoBinds` inst_binds)
where
doc = text ("existential context of a data constructor")
tv_list = bagToList ex_tvs
%************************************************************************
%* *
+\subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
+%* *
+%************************************************************************
+
+\begin{code}
+tcDoStmts :: HsDoContext -> [RenamedStmt] -> [Name] -> TcType
+ -> TcM (TcMonoBinds, [TcStmt], [Id])
+tcDoStmts PArrComp stmts method_names res_ty
+ = unifyPArrTy res_ty `thenM` \elt_ty ->
+ tcStmts (DoCtxt PArrComp)
+ (mkPArrTy, elt_ty) stmts `thenM` \ stmts' ->
+ returnM (EmptyMonoBinds, stmts', [{- unused -}])
+
+tcDoStmts ListComp stmts method_names res_ty
+ = unifyListTy res_ty `thenM` \ elt_ty ->
+ tcStmts (DoCtxt ListComp)
+ (mkListTy, elt_ty) stmts `thenM` \ stmts' ->
+ returnM (EmptyMonoBinds, stmts', [{- unused -}])
+
+tcDoStmts DoExpr stmts method_names res_ty
+ = newTyVarTy (mkArrowKind liftedTypeKind liftedTypeKind) `thenM` \ m_ty ->
+ newTyVarTy liftedTypeKind `thenM` \ elt_ty ->
+ unifyTauTy res_ty (mkAppTy m_ty elt_ty) `thenM_`
+
+ tcStmts (DoCtxt DoExpr) (mkAppTy m_ty, elt_ty) stmts `thenM` \ stmts' ->
+
+ -- Build the then and zero methods in case we need them
+ -- It's important that "then" and "return" appear just once in the final LIE,
+ -- not only for typechecker efficiency, but also because otherwise during
+ -- simplification we end up with silly stuff like
+ -- then = case d of (t,r) -> t
+ -- then = then
+ -- where the second "then" sees that it already exists in the "available" stuff.
+ --
+ mapAndUnzipM (tc_syn_name m_ty)
+ (zipEqual "tcDoStmts" monadNames method_names) `thenM` \ (binds, ids) ->
+ returnM (andMonoBindList binds, stmts', ids)
+ where
+ tc_syn_name :: TcType -> (Name,Name) -> TcM (TcMonoBinds, Id)
+ tc_syn_name m_ty (std_nm, usr_nm)
+ = tcSyntaxName DoOrigin m_ty std_nm usr_nm `thenM` \ (expr, expr_ty) ->
+ case expr of
+ HsVar v -> returnM (EmptyMonoBinds, v)
+ other -> newUnique `thenM` \ uniq ->
+ let
+ id = mkSysLocal FSLIT("syn") uniq expr_ty
+ in
+ returnM (VarMonoBind id expr, id)
+\end{code}
+
+
+%************************************************************************
+%* *
\subsection{tcStmts}
%* *
%************************************************************************
\begin{code}
tcStmts do_or_lc m_ty stmts
= ASSERT( notNull stmts )
- tcStmtsAndThen (:) do_or_lc m_ty stmts (returnTc ([], emptyLIE))
+ tcStmtsAndThen (:) do_or_lc m_ty stmts (returnM [])
tcStmtsAndThen
:: (TcStmt -> thing -> thing) -- Combiner
-> (TcType -> TcType, TcType) -- m, the relationship type of pat and rhs in pat <- rhs
-- elt_ty, where type of the comprehension is (m elt_ty)
-> [RenamedStmt]
- -> TcM (thing, LIE)
- -> TcM (thing, LIE)
+ -> TcM thing
+ -> TcM thing
-- Base case
tcStmtsAndThen combine do_or_lc m_ty [] do_next
thing_inside
tcStmtAndThen combine do_or_lc m_ty@(m,elt_ty) stmt@(BindStmt pat exp src_loc) thing_inside
- = tcAddSrcLoc src_loc $
- tcAddErrCtxt (stmtCtxt do_or_lc stmt) $
- newTyVarTy liftedTypeKind `thenNF_Tc` \ pat_ty ->
- tcMonoExpr exp (m pat_ty) `thenTc` \ (exp', exp_lie) ->
+ = addSrcLoc src_loc $
+ addErrCtxt (stmtCtxt do_or_lc stmt) $
+ newTyVarTy liftedTypeKind `thenM` \ pat_ty ->
+ tcMonoExpr exp (m pat_ty) `thenM` \ exp' ->
tcMatchPats [pat] (mkFunTy pat_ty (m elt_ty)) (\ _ ->
- tcPopErrCtxt thing_inside
- ) `thenTc` \ ([pat'], thing, lie, dict_binds) ->
- returnTc (combine (BindStmt pat' exp' src_loc)
- (glue_binds combine Recursive dict_binds thing),
- lie `plusLIE` exp_lie)
-
+ popErrCtxt thing_inside
+ ) `thenM` \ ([pat'], thing, dict_binds) ->
+ returnM (combine (BindStmt pat' exp' src_loc)
+ (glue_binds combine Recursive dict_binds thing))
-- ParStmt
tcStmtAndThen combine do_or_lc m_ty (ParStmtOut bndr_stmts_s) thing_inside
- = loop bndr_stmts_s `thenTc` \ ((pairs', thing), lie) ->
- returnTc (combine (ParStmtOut pairs') thing, lie)
+ = loop bndr_stmts_s `thenM` \ (pairs', thing) ->
+ returnM (combine (ParStmtOut pairs') thing)
where
loop []
- = thing_inside `thenTc` \ (thing, stmts_lie) ->
- returnTc (([], thing), stmts_lie)
+ = thing_inside `thenM` \ thing ->
+ returnM ([], thing)
loop ((bndrs,stmts) : pairs)
= tcStmtsAndThen
combine_par (DoCtxt ListComp) m_ty stmts
-- Notice we pass on m_ty; the result type is used only
-- to get escaping type variables for checkExistentialPat
- (tcLookupLocalIds bndrs `thenNF_Tc` \ bndrs' ->
- loop pairs `thenTc` \ ((pairs', thing), lie) ->
- returnTc (([], (bndrs', pairs', thing)), lie)) `thenTc` \ ((stmts', (bndrs', pairs', thing)), lie) ->
+ (tcLookupLocalIds bndrs `thenM` \ bndrs' ->
+ loop pairs `thenM` \ (pairs', thing) ->
+ returnM ([], (bndrs', pairs', thing))) `thenM` \ (stmts', (bndrs', pairs', thing)) ->
- returnTc ( ((bndrs',stmts') : pairs', thing), lie)
+ returnM ((bndrs',stmts') : pairs', thing)
combine_par stmt (stmts, thing) = (stmt:stmts, thing)
-- ExprStmt
tcStmtAndThen combine do_or_lc m_ty@(m, res_elt_ty) stmt@(ExprStmt exp _ locn) thing_inside
- = tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
+ = setErrCtxt (stmtCtxt do_or_lc stmt) (
if isDoExpr do_or_lc then
- newTyVarTy openTypeKind `thenNF_Tc` \ any_ty ->
- tcMonoExpr exp (m any_ty) `thenNF_Tc` \ (exp', lie) ->
- returnTc (ExprStmt exp' any_ty locn, lie)
+ newTyVarTy openTypeKind `thenM` \ any_ty ->
+ tcMonoExpr exp (m any_ty) `thenM` \ exp' ->
+ returnM (ExprStmt exp' any_ty locn)
else
- tcMonoExpr exp boolTy `thenNF_Tc` \ (exp', lie) ->
- returnTc (ExprStmt exp' boolTy locn, lie)
- ) `thenTc` \ (stmt', stmt_lie) ->
-
- thing_inside `thenTc` \ (thing, stmts_lie) ->
+ tcMonoExpr exp boolTy `thenM` \ exp' ->
+ returnM (ExprStmt exp' boolTy locn)
+ ) `thenM` \ stmt' ->
- returnTc (combine stmt' thing, stmt_lie `plusLIE` stmts_lie)
+ thing_inside `thenM` \ thing ->
+ returnM (combine stmt' thing)
-- Result statements
tcStmtAndThen combine do_or_lc m_ty@(m, res_elt_ty) stmt@(ResultStmt exp locn) thing_inside
- = tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
+ = setErrCtxt (stmtCtxt do_or_lc stmt) (
if isDoExpr do_or_lc then
tcMonoExpr exp (m res_elt_ty)
else
tcMonoExpr exp res_elt_ty
- ) `thenTc` \ (exp', stmt_lie) ->
+ ) `thenM` \ exp' ->
- thing_inside `thenTc` \ (thing, stmts_lie) ->
+ thing_inside `thenM` \ thing ->
- returnTc (combine (ResultStmt exp' locn) thing,
- stmt_lie `plusLIE` stmts_lie)
+ returnM (combine (ResultStmt exp' locn) thing)
------------------------------
stmtCtxt do_or_lc stmt = hang (pprMatchContext do_or_lc <> colon) 4 (ppr stmt)
sigPatCtxt bound_tvs bound_ids match_ty tidy_env
- = zonkTcType match_ty `thenNF_Tc` \ match_ty' ->
+ = zonkTcType match_ty `thenM` \ match_ty' ->
let
(env1, tidy_tys) = tidyOpenTypes tidy_env (map idType show_ids)
(env2, tidy_mty) = tidyOpenType env1 match_ty'
in
- returnNF_Tc (env1,
+ returnM (env1,
sep [ptext SLIT("When checking an existential match that binds"),
nest 4 (vcat (zipWith ppr_id show_ids tidy_tys)),
ptext SLIT("and whose type is") <+> ppr tidy_mty])
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
-\section[TcModule]{Typechecking a whole module}
-
-\begin{code}
-module TcModule (
- typecheckModule, typecheckIface, typecheckStmt, typecheckExpr,
- typecheckExtraDecls, typecheckCoreModule,
- TcResults(..)
- ) where
-
-#include "HsVersions.h"
-
-import CmdLineOpts ( DynFlag(..), DynFlags, dopt )
-import HsSyn ( HsBinds(..), MonoBinds(..), HsDecl(..), HsExpr(..),
- Stmt(..), InPat(..), HsMatchContext(..), HsDoContext(..), RuleDecl(..),
- isSourceInstDecl, mkSimpleMatch, placeHolderType, isCoreDecl
- )
-import PrelNames ( ioTyConName, printName,
- returnIOName, bindIOName, failIOName, thenIOName, runIOName,
- dollarMainName, itName
- )
-import MkId ( unsafeCoerceId )
-import RnHsSyn ( RenamedHsDecl, RenamedStmt, RenamedHsExpr,
- RenamedRuleDecl, RenamedTyClDecl, RenamedInstDecl )
-import TcHsSyn ( TypecheckedMonoBinds, TypecheckedHsExpr,
- TypecheckedForeignDecl, TypecheckedRuleDecl,
- TypecheckedCoreBind,
- zonkTopBinds, zonkForeignExports, zonkRules, mkHsLet,
- zonkExpr, zonkIdBndr
- )
-
-import Rename ( RnResult(..) )
-import MkIface ( pprModDetails )
-import TcExpr ( tcMonoExpr )
-import TcMonad
-import TcMType ( newTyVarTy, zonkTcType )
-import TcType ( Type, liftedTypeKind, openTypeKind,
- tyVarsOfType, tcFunResultTy,
- mkForAllTys, mkFunTys, mkTyConApp, tcSplitForAllTys,
- tcSplitTyConApp_maybe, isUnitTy
- )
-import TcMatches ( tcStmtsAndThen )
-import Inst ( LIE, emptyLIE, plusLIE )
-import TcBinds ( tcTopBinds )
-import TcClassDcl ( tcClassDecls2 )
-import TcDefaults ( tcDefaults, defaultDefaultTys )
-import TcEnv ( TcEnv, RecTcEnv, InstInfo(iDFunId), tcExtendGlobalValEnv,
- isLocalThing, tcSetEnv, tcSetInstEnv, initTcEnv, getTcGEnv,
- tcExtendGlobalEnv, tcExtendGlobalTypeEnv,
- tcLookupGlobalId, tcLookupTyCon,
- TyThing(..), tcLookupId
- )
-import TcRules ( tcIfaceRules, tcSourceRules )
-import TcForeign ( tcForeignImports, tcForeignExports )
-import TcIfaceSig ( tcInterfaceSigs, tcCoreBinds )
-import TcInstDcls ( tcInstDecls1, tcIfaceInstDecls1, addInstDFuns, initInstEnv, tcInstDecls2 )
-import TcSimplify ( tcSimplifyTop, tcSimplifyInfer )
-import TcTyClsDecls ( tcTyAndClassDecls )
-import CoreUnfold ( unfoldingTemplate )
-import TysWiredIn ( mkListTy, unitTy )
-import ErrUtils ( printErrorsAndWarnings, errorsFound,
- dumpIfSet_dyn, dumpIfSet_dyn_or, showPass )
-import Rules ( extendRuleBase )
-import Id ( Id, mkLocalId, idType, idUnfolding, setIdLocalExported )
-import Module ( Module )
-import Name ( Name, getName, getSrcLoc )
-import TyCon ( tyConGenInfo )
-import BasicTypes ( EP(..), RecFlag(..) )
-import SrcLoc ( noSrcLoc )
-import Outputable
-import IO ( stdout )
-import HscTypes ( PersistentCompilerState(..), HomeSymbolTable,
- PackageTypeEnv, ModIface(..),
- ModDetails(..), DFunId,
- TypeEnv, extendTypeEnvList, typeEnvTyCons, typeEnvElts,
- mkTypeEnv
- )
-import List ( partition )
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{The stmt interface}
-%* *
-%************************************************************************
-
-\begin{code}
-typecheckStmt
- :: DynFlags
- -> PersistentCompilerState
- -> HomeSymbolTable
- -> TypeEnv -- The interactive context's type envt
- -> PrintUnqualified -- For error printing
- -> Module -- Is this really needed
- -> [Name] -- Names bound by the Stmt (empty for expressions)
- -> (RenamedStmt, -- The stmt itself
- [RenamedHsDecl]) -- Plus extra decls it sucked in from interface files
- -> IO (Maybe (PersistentCompilerState,
- TypecheckedHsExpr,
- [Id],
- Type))
- -- The returned [Id] is the same as the input except for
- -- ExprStmt, in which case the returned [Name] is [itName]
-
-typecheckStmt dflags pcs hst ic_type_env unqual this_mod names (stmt, iface_decls)
- = typecheck dflags pcs hst unqual $
-
- -- use the default default settings, i.e. [Integer, Double]
- tcSetDefaultTys defaultDefaultTys $
-
- -- Typecheck the extra declarations
- tcExtraDecls pcs hst this_mod iface_decls `thenTc` \ (new_pcs, env) ->
-
- tcSetEnv env $
- tcExtendGlobalTypeEnv ic_type_env $
-
- -- The real work is done here
- tcUserStmt names stmt `thenTc` \ (expr, bound_ids) ->
-
- traceTc (text "tcs 1") `thenNF_Tc_`
- zonkExpr expr `thenNF_Tc` \ zonked_expr ->
- mapNF_Tc zonkIdBndr bound_ids `thenNF_Tc` \ zonked_ids ->
-
- ioToTc (dumpIfSet_dyn dflags Opt_D_dump_tc "Bound Ids" (vcat (map ppr zonked_ids))) `thenNF_Tc_`
- ioToTc (dumpIfSet_dyn dflags Opt_D_dump_tc "Typechecked" (ppr zonked_expr)) `thenNF_Tc_`
-
- returnTc (new_pcs, zonked_expr, zonked_ids, error "typecheckStmt: no type")
-\end{code}
-
-Here is the grand plan, implemented in tcUserStmt
-
- What you type The IO [HValue] that hscStmt returns
- ------------- ------------------------------------
- let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...]
- bindings: [x,y,...]
-
- pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
- bindings: [x,y,...]
-
- expr (of IO type) ==> expr >>= \ v -> return [v]
- [NB: result not printed] bindings: [it]
-
-
- expr (of non-IO type,
- result showable) ==> let v = expr in print v >> return [v]
- bindings: [it]
-
- expr (of non-IO type,
- result not showable) ==> error
-
-
-\begin{code}
-tcUserStmt :: [Name] -> RenamedStmt -> TcM (TypecheckedHsExpr, [Id])
-
-tcUserStmt names (ExprStmt expr _ loc)
- = ASSERT( null names )
- tcGetUnique `thenNF_Tc` \ uniq ->
- let
- fresh_it = itName uniq
- the_bind = FunMonoBind fresh_it False
- [ mkSimpleMatch [] expr placeHolderType loc ] loc
- in
- tryTc_ (traceTc (text "tcs 1b") `thenNF_Tc_`
- tc_stmts [fresh_it] [
- LetStmt (MonoBind the_bind [] NonRecursive),
- ExprStmt (HsApp (HsVar printName) (HsVar fresh_it)) placeHolderType loc])
- ( traceTc (text "tcs 1a") `thenNF_Tc_`
- tc_stmts [fresh_it] [BindStmt (VarPatIn fresh_it) expr loc])
-
-tcUserStmt names stmt
- = tc_stmts names [stmt]
-
-
-tc_stmts names stmts
- = mapNF_Tc tcLookupGlobalId
- [returnIOName, failIOName, bindIOName, thenIOName] `thenNF_Tc` \ io_ids ->
- tcLookupTyCon ioTyConName `thenNF_Tc` \ ioTyCon ->
- newTyVarTy liftedTypeKind `thenNF_Tc` \ res_ty ->
- let
- return_id = head io_ids -- Rather gruesome
-
- io_ty = (\ ty -> mkTyConApp ioTyCon [ty], res_ty)
-
- -- mk_return builds the expression
- -- returnIO @ [()] [coerce () x, .., coerce () z]
- mk_return ids = HsApp (TyApp (HsVar return_id) [mkListTy unitTy])
- (ExplicitList unitTy (map mk_item ids))
-
- mk_item id = HsApp (TyApp (HsVar unsafeCoerceId) [idType id, unitTy])
- (HsVar id)
- in
-
- traceTc (text "tcs 2") `thenNF_Tc_`
- tcStmtsAndThen combine (DoCtxt DoExpr) io_ty stmts (
- -- Look up the names right in the middle,
- -- where they will all be in scope
- mapNF_Tc tcLookupId names `thenNF_Tc` \ ids ->
- returnTc ((ids, [ResultStmt (mk_return ids) noSrcLoc]), emptyLIE)
- ) `thenTc` \ ((ids, tc_stmts), lie) ->
-
- -- Simplify the context right here, so that we fail
- -- if there aren't enough instances. Notably, when we see
- -- e
- -- we use tryTc_ to try it <- e
- -- and then let it = e
- -- It's the simplify step that rejects the first.
-
- traceTc (text "tcs 3") `thenNF_Tc_`
- tcSimplifyTop lie `thenTc` \ const_binds ->
- traceTc (text "tcs 4") `thenNF_Tc_`
-
- returnTc (mkHsLet const_binds $
- HsDo DoExpr tc_stmts io_ids
- (mkTyConApp ioTyCon [mkListTy unitTy]) noSrcLoc,
- ids)
- where
- combine stmt (ids, stmts) = (ids, stmt:stmts)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Typechecking an expression}
-%* *
-%************************************************************************
-
-\begin{code}
-typecheckExpr :: DynFlags
- -> PersistentCompilerState
- -> HomeSymbolTable
- -> TypeEnv -- The interactive context's type envt
- -> PrintUnqualified -- For error printing
- -> Module
- -> (RenamedHsExpr, -- The expression itself
- [RenamedHsDecl]) -- Plus extra decls it sucked in from interface files
- -> IO (Maybe (PersistentCompilerState,
- TypecheckedHsExpr,
- [Id], -- always empty (matches typecheckStmt)
- Type))
-
-typecheckExpr dflags pcs hst ic_type_env unqual this_mod (expr, decls)
- = typecheck dflags pcs hst unqual $
-
- -- use the default default settings, i.e. [Integer, Double]
- tcSetDefaultTys defaultDefaultTys $
-
- -- Typecheck the extra declarations
- tcExtraDecls pcs hst this_mod decls `thenTc` \ (new_pcs, env) ->
-
- -- Now typecheck the expression
- tcSetEnv env $
- tcExtendGlobalTypeEnv ic_type_env $
-
- newTyVarTy openTypeKind `thenTc` \ ty ->
- tcMonoExpr expr ty `thenTc` \ (e', lie) ->
- tcSimplifyInfer smpl_doc (tyVarsOfType ty) lie
- `thenTc` \ (qtvs, lie_free, dict_binds, dict_ids) ->
- tcSimplifyTop lie_free `thenTc` \ const_binds ->
-
- let all_expr = mkHsLet const_binds $
- TyLam qtvs $
- DictLam dict_ids $
- mkHsLet dict_binds $
- e'
-
- all_expr_ty = mkForAllTys qtvs $
- mkFunTys (map idType dict_ids) $
- ty
- in
-
- zonkExpr all_expr `thenNF_Tc` \ zonked_expr ->
- zonkTcType all_expr_ty `thenNF_Tc` \ zonked_ty ->
- ioToTc (dumpIfSet_dyn dflags
- Opt_D_dump_tc "Typechecked" (ppr zonked_expr)) `thenNF_Tc_`
- returnTc (new_pcs, zonked_expr, [], zonked_ty)
-
- where
- smpl_doc = ptext SLIT("main expression")
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Typechecking extra declarations}
-%* *
-%************************************************************************
-
-\begin{code}
-typecheckExtraDecls
- :: DynFlags
- -> PersistentCompilerState
- -> HomeSymbolTable
- -> PrintUnqualified -- For error printing
- -> Module -- Is this really needed
- -> [RenamedHsDecl] -- extra decls sucked in from interface files
- -> IO (Maybe PersistentCompilerState)
-
-typecheckExtraDecls dflags pcs hst unqual this_mod decls
- = typecheck dflags pcs hst unqual $
- tcExtraDecls pcs hst this_mod decls `thenTc` \ (new_pcs, _) ->
- returnTc new_pcs
-
-tcExtraDecls :: PersistentCompilerState
- -> HomeSymbolTable
- -> Module
- -> [RenamedHsDecl]
- -> TcM (PersistentCompilerState, TcEnv)
- -- Returned environment includes instances
-
-tcExtraDecls pcs hst this_mod decls
- = tcIfaceImports this_mod decls `thenTc` \ (env, all_things, dfuns, rules) ->
- addInstDFuns (pcs_insts pcs) dfuns `thenNF_Tc` \ new_pcs_insts ->
- let
- new_pcs_pte = extendTypeEnvList (pcs_PTE pcs) all_things
- new_pcs_rules = addIfaceRules (pcs_rules pcs) rules
-
- new_pcs :: PersistentCompilerState
- new_pcs = pcs { pcs_PTE = new_pcs_pte,
- pcs_insts = new_pcs_insts,
- pcs_rules = new_pcs_rules
- }
- in
- -- Initialise the instance environment
- tcSetEnv env (
- initInstEnv new_pcs hst `thenNF_Tc` \ inst_env ->
- tcSetInstEnv inst_env tcGetEnv
- ) `thenNF_Tc` \ new_env ->
- returnTc (new_pcs, new_env)
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Typechecking a module}
-%* *
-%************************************************************************
-
-\begin{code}
-typecheckModule
- :: DynFlags
- -> PersistentCompilerState
- -> HomeSymbolTable
- -> PrintUnqualified -- For error printing
- -> RnResult
- -> IO (Maybe (PersistentCompilerState, TcResults))
- -- The new PCS is Augmented with imported information,
- -- (but not stuff from this module)
-
-data TcResults
- = TcResults {
- -- All these fields have info *just for this module*
- tc_env :: TypeEnv, -- The top level TypeEnv
- tc_insts :: [DFunId], -- Instances
- tc_rules :: [TypecheckedRuleDecl], -- Transformation rules
- tc_binds :: TypecheckedMonoBinds, -- Bindings
- tc_fords :: [TypecheckedForeignDecl] -- Foreign import & exports.
- }
-
-
-typecheckModule dflags pcs hst unqual rn_result
- = do { maybe_tc_result <- typecheck dflags pcs hst unqual $
- tcModule pcs hst rn_result
- ; printTcDump dflags unqual maybe_tc_result
- ; return maybe_tc_result }
-
-tcModule :: PersistentCompilerState
- -> HomeSymbolTable
- -> RnResult
- -> TcM (PersistentCompilerState, TcResults)
-
-tcModule pcs hst (RnResult { rr_decls = decls, rr_mod = this_mod,
- rr_fixities = fix_env, rr_main = maybe_main_name })
- = fixTc (\ ~(unf_env, _, _) ->
- -- Loop back the final environment, including the fully zonked
- -- versions of bindings from this module. In the presence of mutual
- -- recursion, interface type signatures may mention variables defined
- -- in this module, which is why the knot is so big
-
- -- Type-check the type and class decls, and all imported decls
- tcImports unf_env pcs hst this_mod
- tycl_decls iface_inst_decls iface_rule_decls `thenTc` \ (env1, new_pcs) ->
-
- tcSetEnv env1 $
-
- -- Do the source-language instances, including derivings
- initInstEnv new_pcs hst `thenNF_Tc` \ inst_env1 ->
- tcInstDecls1 (pcs_PRS new_pcs) inst_env1
- fix_env this_mod
- tycl_decls src_inst_decls `thenTc` \ (inst_env2, inst_info, deriv_binds) ->
- tcSetInstEnv inst_env2 $
-
- -- Foreign import declarations next
- traceTc (text "Tc4") `thenNF_Tc_`
- tcForeignImports decls `thenTc` \ (fo_ids, foi_decls) ->
- tcExtendGlobalValEnv fo_ids $
-
- -- Default declarations
- tcDefaults decls `thenTc` \ defaulting_tys ->
- tcSetDefaultTys defaulting_tys $
-
- -- Value declarations next.
- -- We also typecheck any extra binds that came out of the "deriving" process
- traceTc (text "Default types" <+> ppr defaulting_tys) `thenNF_Tc_`
- traceTc (text "Tc5") `thenNF_Tc_`
- tcTopBinds (val_binds `ThenBinds` deriv_binds) `thenTc` \ ((val_binds, env2), lie_valdecls) ->
-
- -- Second pass over class and instance declarations,
- -- plus rules and foreign exports, to generate bindings
- tcSetEnv env2 $
- traceTc (text "Tc6") `thenNF_Tc_`
- traceTc (ppr (getTcGEnv env2)) `thenNF_Tc_`
- tcClassDecls2 this_mod tycl_decls `thenNF_Tc` \ (lie_clasdecls, cls_dm_binds, dm_ids) ->
- tcExtendGlobalValEnv dm_ids $
- traceTc (text "Tc7") `thenNF_Tc_`
- tcInstDecls2 inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
- traceTc (text "Tc8") `thenNF_Tc_`
- tcForeignExports this_mod decls `thenTc` \ (lie_fodecls, foe_binds, foe_decls) ->
- traceTc (text "Tc9") `thenNF_Tc_`
- tcSourceRules src_rule_decls `thenNF_Tc` \ (lie_rules, src_rules) ->
-
- -- CHECK THAT main IS DEFINED WITH RIGHT TYPE, IF REQUIRED
- traceTc (text "Tc10") `thenNF_Tc_`
- tcCheckMain maybe_main_name `thenTc` \ (main_bind, lie_main) ->
-
- -- Deal with constant or ambiguous InstIds. How could
- -- there be ambiguous ones? They can only arise if a
- -- top-level decl falls under the monomorphism
- -- restriction, and no subsequent decl instantiates its
- -- type. (Usually, ambiguous type variables are resolved
- -- during the generalisation step.)
- --
- -- Note that we must do this *after* tcCheckMain, because of the
- -- following bizarre case:
- -- main = return ()
- -- Here, we infer main :: forall a. m a, where m is a free
- -- type variable. tcCheckMain will unify it with IO, and that
- -- must happen before tcSimplifyTop, since the latter will report
- -- m as ambiguous
- let
- lie_alldecls = lie_valdecls `plusLIE`
- lie_instdecls `plusLIE`
- lie_clasdecls `plusLIE`
- lie_fodecls `plusLIE`
- lie_rules `plusLIE`
- lie_main
- in
- tcSimplifyTop lie_alldecls `thenTc` \ const_inst_binds ->
- traceTc (text "endsimpltop") `thenTc_`
-
-
- -- Backsubstitution. This must be done last.
- -- Even tcSimplifyTop may do some unification.
- let
- all_binds = val_binds `AndMonoBinds`
- inst_binds `AndMonoBinds`
- cls_dm_binds `AndMonoBinds`
- const_inst_binds `AndMonoBinds`
- foe_binds `AndMonoBinds`
- main_bind
- in
- traceTc (text "Tc7") `thenNF_Tc_`
- zonkTopBinds all_binds `thenNF_Tc` \ (all_binds', final_env) ->
- tcSetEnv final_env $
- -- zonkTopBinds puts all the top-level Ids into the tcGEnv
- traceTc (text "Tc8") `thenNF_Tc_`
- zonkForeignExports foe_decls `thenNF_Tc` \ foe_decls' ->
- traceTc (text "Tc9") `thenNF_Tc_`
- zonkRules src_rules `thenNF_Tc` \ src_rules' ->
-
-
- let src_things = filter (isLocalThing this_mod) (typeEnvElts (getTcGEnv final_env))
- -- This is horribly crude; the env might be jolly big
- in
- traceTc (text "Tc10") `thenNF_Tc_`
- returnTc (final_env,
- new_pcs,
- TcResults { tc_env = mkTypeEnv src_things,
- tc_insts = map iDFunId inst_info,
- tc_binds = all_binds',
- tc_fords = foi_decls ++ foe_decls',
- tc_rules = src_rules'
- }
- )
- ) `thenTc` \ (_, pcs, tc_result) ->
- returnTc (pcs, tc_result)
- where
- tycl_decls = [d | TyClD d <- decls]
- rule_decls = [d | RuleD d <- decls]
- inst_decls = [d | InstD d <- decls]
- val_decls = [d | ValD d <- decls]
-
- core_binds = [d | d <- tycl_decls, isCoreDecl d]
-
- (src_inst_decls, iface_inst_decls) = partition isSourceInstDecl inst_decls
- (src_rule_decls, iface_rule_decls) = partition (isSourceRuleDecl this_mod) rule_decls
- val_binds = foldr ThenBinds EmptyBinds val_decls
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Typechecking interface decls}
-%* *
-%************************************************************************
-
-\begin{code}
-typecheckIface
- :: DynFlags
- -> PersistentCompilerState
- -> HomeSymbolTable
- -> ModIface -- Iface for this module (just module & fixities)
- -> [RenamedHsDecl]
- -> IO (Maybe (PersistentCompilerState, ModDetails))
- -- The new PCS is Augmented with imported information,
- -- (but not stuff from this module).
-
-typecheckIface dflags pcs hst mod_iface decls
- = do { maybe_tc_stuff <- typecheck dflags pcs hst alwaysQualify $
- tcIface pcs this_mod decls
- ; printIfaceDump dflags maybe_tc_stuff
- ; return maybe_tc_stuff }
- where
- this_mod = mi_module mod_iface
-
-tcIface pcs this_mod decls
--- The decls are coming from this_mod's interface file, together
--- with imported interface decls that belong in the "package" stuff.
--- (With GHCi, all the home modules have already been processed.)
--- That is why we need to do the partitioning below.
- = tcIfaceImports this_mod decls `thenTc` \ (_, all_things, dfuns, rules) ->
-
- let
- -- Do the partitioning (see notes above)
- (local_things, imported_things) = partition (isLocalThing this_mod) all_things
- (local_rules, imported_rules) = partition is_local_rule rules
- (local_dfuns, imported_dfuns) = partition (isLocalThing this_mod) dfuns
- is_local_rule (IfaceRuleOut n _) = isLocalThing this_mod n
- in
- addInstDFuns (pcs_insts pcs) imported_dfuns `thenNF_Tc` \ new_pcs_insts ->
- let
- new_pcs_pte :: PackageTypeEnv
- new_pcs_pte = extendTypeEnvList (pcs_PTE pcs) imported_things
- new_pcs_rules = addIfaceRules (pcs_rules pcs) imported_rules
-
- new_pcs :: PersistentCompilerState
- new_pcs = pcs { pcs_PTE = new_pcs_pte,
- pcs_insts = new_pcs_insts,
- pcs_rules = new_pcs_rules
- }
-
- mod_details = ModDetails { md_types = mkTypeEnv local_things,
- md_insts = local_dfuns,
- md_rules = [(id,rule) | IfaceRuleOut id rule <- local_rules],
- md_binds = [] }
- -- All the rules from an interface are of the IfaceRuleOut form
- in
- returnTc (new_pcs, mod_details)
-
-
-tcIfaceImports :: Module
- -> [RenamedHsDecl] -- All interface-file decls
- -> TcM (TcEnv, [TyThing], [DFunId], [TypecheckedRuleDecl])
-tcIfaceImports this_mod decls
--- The decls are all interface-file declarations
- = let
- inst_decls = [d | InstD d <- decls]
- tycl_decls = [d | TyClD d <- decls]
- rule_decls = [d | RuleD d <- decls]
- in
- fixTc (\ ~(unf_env, _, _, _) ->
- -- This fixTc follows the same general plan as tcImports,
- -- which is better commented (below)
- tcTyAndClassDecls this_mod tycl_decls `thenTc` \ tycl_things ->
- tcExtendGlobalEnv tycl_things $
- tcInterfaceSigs unf_env this_mod tycl_decls `thenTc` \ sig_ids ->
- tcExtendGlobalValEnv sig_ids $
- tcIfaceInstDecls1 inst_decls `thenTc` \ dfuns ->
- tcIfaceRules rule_decls `thenTc` \ rules ->
- tcGetEnv `thenTc` \ env ->
- let
- all_things = map AnId sig_ids ++ tycl_things
- in
- returnTc (env, all_things, dfuns, rules)
- )
-
-
-tcImports :: RecTcEnv
- -> PersistentCompilerState
- -> HomeSymbolTable
- -> Module
- -> [RenamedTyClDecl]
- -> [RenamedInstDecl]
- -> [RenamedRuleDecl]
- -> TcM (TcEnv, PersistentCompilerState)
-
--- tcImports is a slight mis-nomer.
--- It deals with everything that could be an import:
--- type and class decls (some source, some imported)
--- interface signatures (checked lazily)
--- instance decls (some source, some imported)
--- rule decls (all imported)
--- These can occur in source code too, of course
---
--- tcImports is only called when processing source code,
--- so that any interface-file declarations are for other modules, not this one
-
-tcImports unf_env pcs hst this_mod
- tycl_decls inst_decls rule_decls
- -- (unf_env :: RecTcEnv) is used for type-checking interface pragmas
- -- which is done lazily [ie failure just drops the pragma
- -- without having any global-failure effect].
- --
- -- unf_env is also used to get the pragama info
- -- for imported dfuns and default methods
-
- = checkNoErrsTc $
- -- tcImports recovers internally, but if anything gave rise to
- -- an error we'd better stop now, to avoid a cascade
-
- traceTc (text "Tc1") `thenNF_Tc_`
- tcTyAndClassDecls this_mod tycl_decls `thenTc` \ tycl_things ->
- tcExtendGlobalEnv tycl_things $
-
- -- Interface type signatures
- -- We tie a knot so that the Ids read out of interfaces are in scope
- -- when we read their pragmas.
- -- What we rely on is that pragmas are typechecked lazily; if
- -- any type errors are found (ie there's an inconsistency)
- -- we silently discard the pragma
- traceTc (text "Tc2") `thenNF_Tc_`
- tcInterfaceSigs unf_env this_mod tycl_decls `thenTc` \ sig_ids ->
- tcExtendGlobalValEnv sig_ids $
-
- -- Typecheck the instance decls, includes deriving
- -- Note that imported dictionary functions are already
- -- in scope from the preceding tcInterfaceSigs
- traceTc (text "Tc3") `thenNF_Tc_`
- tcIfaceInstDecls1 inst_decls `thenTc` \ dfuns ->
- tcIfaceRules rule_decls `thenNF_Tc` \ rules ->
-
- addInstDFuns (pcs_insts pcs) dfuns `thenNF_Tc` \ new_pcs_insts ->
- tcGetEnv `thenTc` \ unf_env ->
- let
- -- sometimes we're compiling in the context of a package module
- -- (on the GHCi command line, for example). In this case, we
- -- want to treat everything we pulled in as an imported thing.
- imported_things = map AnId sig_ids ++ -- All imported
- filter (not . isLocalThing this_mod) tycl_things
-
- new_pte :: PackageTypeEnv
- new_pte = extendTypeEnvList (pcs_PTE pcs) imported_things
-
- new_pcs_rules = addIfaceRules (pcs_rules pcs) rules
-
- new_pcs :: PersistentCompilerState
- new_pcs = pcs { pcs_PTE = new_pte,
- pcs_insts = new_pcs_insts,
- pcs_rules = new_pcs_rules
- }
- in
- returnTc (unf_env, new_pcs)
-
-isSourceRuleDecl :: Module -> RenamedRuleDecl -> Bool
--- This is a bit gruesome.
--- Usually, HsRules come only from source files; IfaceRules only from interface files
--- But built-in rules appear as an IfaceRuleOut... and when compiling
--- the source file for that built-in rule, we want to treat it as a source
--- rule, so it gets put with the other rules for that module.
-isSourceRuleDecl this_mod (HsRule _ _ _ _ _ _) = True
-isSourceRuleDecl this_mod (IfaceRule _ _ _ n _ _ _) = False
-isSourceRuleDecl this_mod (IfaceRuleOut name _) = isLocalThing this_mod name
-
-addIfaceRules rule_base rules
- = foldl add_rule rule_base rules
- where
- add_rule rule_base (IfaceRuleOut id rule) = extendRuleBase rule_base (id, rule)
-\end{code}
-
-\begin{code}
-typecheckCoreModule
- :: DynFlags
- -> PersistentCompilerState
- -> HomeSymbolTable
- -> ModIface -- Iface for this module (just module & fixities)
- -> [RenamedHsDecl]
- -> IO (Maybe (PersistentCompilerState, (TypeEnv, [TypecheckedCoreBind], [TypecheckedRuleDecl])))
-typecheckCoreModule dflags pcs hst mod_iface decls
- = do { maybe_tc_stuff <- typecheck dflags pcs hst alwaysQualify $
- tcCoreDecls this_mod decls
-
--- ; printIfaceDump dflags maybe_tc_stuff
-
- -- Q: Is it OK not to extend PCS here?
- -- (in the event that it needs to be, I'm returning the PCS passed in.)
- ; case maybe_tc_stuff of
- Nothing -> return Nothing
- Just result -> return (Just (pcs, result)) }
- where
- this_mod = mi_module mod_iface
- core_decls = [d | (TyClD d) <- decls, isCoreDecl d]
-
-
-tcCoreDecls :: Module
- -> [RenamedHsDecl] -- All interface-file decls
- -> TcM (TypeEnv, [TypecheckedCoreBind], [TypecheckedRuleDecl])
-tcCoreDecls this_mod decls
--- The decls are all TyClD declarations coming from External Core input.
- = let
- tycl_decls = [d | TyClD d <- decls]
- rule_decls = [d | RuleD d <- decls]
- core_decls = filter isCoreDecl tycl_decls
- in
- fixTc (\ ~(unf_env, _) ->
- -- This fixTc follows the same general plan as tcImports,
- -- which is better commented.
- -- [ Q: do we need to tie a knot for External Core? ]
- tcTyAndClassDecls this_mod tycl_decls `thenTc` \ tycl_things ->
- tcExtendGlobalEnv tycl_things $
-
- tcInterfaceSigs unf_env this_mod tycl_decls `thenTc` \ sig_ids ->
- tcExtendGlobalValEnv sig_ids $
-
- tcCoreBinds core_decls `thenTc` \ core_prs ->
- let
- local_ids = map fst core_prs
- in
- tcExtendGlobalValEnv local_ids $
-
- tcIfaceRules rule_decls `thenTc` \ rules ->
-
- let
- src_things = filter (isLocalThing this_mod) tycl_things
- ++ map AnId local_ids
- in
- tcGetEnv `thenNF_Tc` \ env ->
- returnTc (env, (mkTypeEnv src_things, core_prs, rules))
- ) `thenTc` \ (_, result) ->
- returnTc result
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Checking the type of main}
-%* *
-%************************************************************************
-
-We must check that in module Main,
- a) Main.main is in scope
- b) Main.main :: forall a1...an. IO t, for some type t
-
-Then we build
- $main = GHC.TopHandler.runIO Main.main
-
-The function
- GHC.TopHandler.runIO :: IO a -> IO a
-catches the top level exceptions.
-It accepts a Main.main of any type (IO a).
-
-\begin{code}
-tcCheckMain :: Maybe Name -> TcM (TypecheckedMonoBinds, LIE)
-tcCheckMain Nothing = returnTc (EmptyMonoBinds, emptyLIE)
-
-tcCheckMain (Just main_name)
- = tcLookupId main_name `thenNF_Tc` \ main_id ->
- -- If it is not Nothing, it should be in the env
- tcAddSrcLoc (getSrcLoc main_id) $
- tcAddErrCtxt mainCtxt $
- newTyVarTy liftedTypeKind `thenNF_Tc` \ ty ->
- tcMonoExpr rhs ty `thenTc` \ (main_expr, lie) ->
- zonkTcType ty `thenNF_Tc` \ ty ->
- ASSERT( is_io ty )
- let
- dollar_main_id = setIdLocalExported (mkLocalId dollarMainName ty)
- in
- returnTc (VarMonoBind dollar_main_id main_expr, lie)
- where
- rhs = HsApp (HsVar runIOName) (HsVar main_name)
-
-is_io :: Type -> Bool -- True for IO a
-is_io tau = case tcSplitTyConApp_maybe tau of
- Just (tc, [_]) -> getName tc == ioTyConName
- other -> False
-
-mainCtxt = ptext SLIT("When checking the type of 'main'")
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Interfacing the Tc monad to the IO monad}
-%* *
-%************************************************************************
-
-\begin{code}
-typecheck :: DynFlags
- -> PersistentCompilerState
- -> HomeSymbolTable
- -> PrintUnqualified -- For error printing
- -> TcM r
- -> IO (Maybe r)
-
-typecheck dflags pcs hst unqual thing_inside
- = do { showPass dflags "Typechecker";
- ; env <- initTcEnv hst (pcs_PTE pcs)
-
- ; (maybe_tc_result, errs) <- initTc dflags env thing_inside
-
- ; printErrorsAndWarnings unqual errs
-
- ; if errorsFound errs then
- return Nothing
- else
- return maybe_tc_result
- }
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Dumping output}
-%* *
-%************************************************************************
-
-\begin{code}
-printTcDump dflags unqual Nothing = return ()
-printTcDump dflags unqual (Just (_, results))
- = do if dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags then
- printForUser stdout unqual (dump_tc_iface dflags results)
- else return ()
-
- dumpIfSet_dyn dflags Opt_D_dump_tc
- -- foreign x-d's have undefined's in their types; hence can't show the tc_fords
- "Typechecked" (ppr (tc_binds results) {- $$ ppr (tc_fords results)-})
-
-
-printIfaceDump dflags Nothing = return ()
-printIfaceDump dflags (Just (_, details))
- = dumpIfSet_dyn_or dflags [Opt_D_dump_types, Opt_D_dump_tc]
- "Interface" (pprModDetails details)
-
-dump_tc_iface dflags results
- = vcat [pprModDetails (ModDetails {md_types = tc_env results,
- md_insts = tc_insts results,
- md_rules = [], md_binds = []}) ,
- ppr_rules (tc_rules results),
-
- if dopt Opt_Generics dflags then
- ppr_gen_tycons (typeEnvTyCons (tc_env results))
- else
- empty
- ]
-
-ppr_rules [] = empty
-ppr_rules rs = vcat [ptext SLIT("{-# RULES"),
- nest 4 (vcat (map ppr rs)),
- ptext SLIT("#-}")]
-
-ppr_gen_tycons tcs = vcat [ptext SLIT("{-# Generic type constructor details"),
- vcat (map ppr_gen_tycon tcs),
- ptext SLIT("#-}")
- ]
-
--- x&y are now Id's, not CoreExpr's
-ppr_gen_tycon tycon
- | Just ep <- tyConGenInfo tycon
- = (ppr tycon <> colon) $$ nest 4 (ppr_ep ep)
-
- | otherwise = ppr tycon <> colon <+> ptext SLIT("Not derivable")
-
-ppr_ep (EP from to)
- = vcat [ ptext SLIT("Rep type:") <+> ppr (tcFunResultTy from_tau),
- ptext SLIT("From:") <+> ppr (unfoldingTemplate (idUnfolding from)),
- ptext SLIT("To:") <+> ppr (unfoldingTemplate (idUnfolding to))
- ]
- where
- (_,from_tau) = tcSplitForAllTys (idType from)
-\end{code}
+++ /dev/null
-\begin{code}
-module TcMonad(
- TcM, NF_TcM, TcDown, TcEnv,
-
- initTc,
- returnTc, thenTc, thenTc_, mapTc, mapTc_, listTc,
- foldrTc, foldlTc, mapAndUnzipTc, mapAndUnzip3Tc,
- mapBagTc, fixTc, tryTc, tryTc_, getErrsTc,
- traceTc, ioToTc,
-
- uniqSMToTcM,
-
- returnNF_Tc, thenNF_Tc, thenNF_Tc_, mapNF_Tc,
- fixNF_Tc, forkNF_Tc, foldrNF_Tc, foldlNF_Tc,
-
- listNF_Tc, mapAndUnzipNF_Tc, mapBagNF_Tc,
-
- checkTc, checkTcM, checkMaybeTc, checkMaybeTcM,
- failTc, failWithTc, addErrTc, addErrsTc, warnTc,
- recoverTc, checkNoErrsTc, ifErrsTc, recoverNF_Tc, discardErrsTc,
- addErrTcM, addInstErrTcM, failWithTcM,
-
- tcGetEnv, tcSetEnv,
- tcGetDefaultTys, tcSetDefaultTys,
- tcGetUnique, tcGetUniques,
- doptsTc, getDOptsTc,
-
- tcAddSrcLoc, tcGetSrcLoc, tcGetInstLoc,
- tcAddErrCtxtM, tcSetErrCtxtM,
- tcAddErrCtxt, tcSetErrCtxt, tcPopErrCtxt,
-
- tcNewMutVar, tcReadMutVar, tcWriteMutVar, TcRef,
- tcNewMutTyVar, tcReadMutTyVar, tcWriteMutTyVar,
-
- InstOrigin(..), InstLoc, pprInstLoc,
-
- TcError, TcWarning, TidyEnv, emptyTidyEnv,
- arityErr
- ) where
-
-#include "HsVersions.h"
-
-import {-# SOURCE #-} TcEnv ( TcEnv )
-
-import HsLit ( HsOverLit )
-import RnHsSyn ( RenamedPat, RenamedArithSeqInfo, RenamedHsExpr )
-import TcType ( Type, Kind, TyVarDetails )
-import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, ErrMsg, Message, WarnMsg )
-
-import Bag ( Bag, emptyBag, isEmptyBag,
- foldBag, unitBag, unionBags, snocBag )
-import Class ( Class )
-import Name ( Name )
-import Var ( TyVar, newMutTyVar, readMutTyVar, writeMutTyVar )
-import VarEnv ( TidyEnv, emptyTidyEnv )
-import UniqSupply ( UniqSupply, uniqFromSupply, uniqsFromSupply,
- splitUniqSupply, mkSplitUniqSupply,
- UniqSM, initUs_ )
-import SrcLoc ( SrcLoc, noSrcLoc )
-import BasicTypes ( IPName )
-import UniqFM ( emptyUFM )
-import Unique ( Unique )
-import CmdLineOpts
-import Outputable
-
-import DATA_IOREF ( IORef, newIORef, readIORef, writeIORef )
-import UNSAFE_IO ( unsafeInterleaveIO )
-import FIX_IO ( fixIO )
-
-infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenNF_Tc_`
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{The main monads: TcM, NF_TcM}
-%* *
-%************************************************************************
-
-\begin{code}
-type NF_TcM r = TcDown -> TcEnv -> IO r -- Can't raise UserError
-type TcM r = TcDown -> TcEnv -> IO r -- Can raise UserError
-
-type Either_TcM 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}
-
-initTc :: DynFlags
- -> TcEnv
- -> TcM r
- -> IO (Maybe r, (Bag WarnMsg, Bag ErrMsg))
-
-initTc dflags tc_env do_this
- = do {
- us <- mkSplitUniqSupply 'a' ;
- us_var <- newIORef us ;
- errs_var <- newIORef (emptyBag,emptyBag) ;
- tvs_var <- newIORef emptyUFM ;
-
- let
- init_down = TcDown { tc_dflags = dflags, tc_def = [],
- tc_us = us_var, tc_loc = noSrcLoc,
- tc_ctxt = [], tc_errs = errs_var }
- ;
-
- maybe_res <- catch (do { res <- do_this init_down tc_env ;
- return (Just res)})
- (\_ -> return Nothing) ;
-
- (warns,errs) <- readIORef errs_var ;
- return (maybe_res, (warns, errs))
- }
-
--- Monadic operations
-
-returnNF_Tc :: a -> NF_TcM a
-returnTc :: a -> TcM a
-returnTc v down env = return v
-
-thenTc :: TcM a -> (a -> TcM b) -> TcM b
-thenNF_Tc :: NF_TcM a -> (a -> Either_TcM b) -> Either_TcM b
-thenTc m k down env = do { r <- m down env; k r down env }
-
-thenTc_ :: TcM a -> TcM b -> TcM b
-thenNF_Tc_ :: NF_TcM a -> Either_TcM b -> Either_TcM b
-thenTc_ m k down env = do { m down env; k down env }
-
-listTc :: [TcM a] -> TcM [a]
-listNF_Tc :: [NF_TcM a] -> NF_TcM [a]
-listTc [] = returnTc []
-listTc (x:xs) = x `thenTc` \ r ->
- listTc xs `thenTc` \ rs ->
- returnTc (r:rs)
-
-mapTc :: (a -> TcM b) -> [a] -> TcM [b]
-mapTc_ :: (a -> TcM b) -> [a] -> TcM ()
-mapNF_Tc :: (a -> NF_TcM b) -> [a] -> NF_TcM [b]
-mapTc f [] = returnTc []
-mapTc f (x:xs) = f x `thenTc` \ r ->
- mapTc f xs `thenTc` \ rs ->
- returnTc (r:rs)
-mapTc_ f xs = mapTc f xs `thenTc_` returnTc ()
-
-
-foldrTc :: (a -> b -> TcM b) -> b -> [a] -> TcM b
-foldrNF_Tc :: (a -> b -> NF_TcM b) -> b -> [a] -> NF_TcM b
-foldrTc k z [] = returnTc z
-foldrTc k z (x:xs) = foldrTc k z xs `thenTc` \r ->
- k x r
-
-foldlTc :: (a -> b -> TcM a) -> a -> [b] -> TcM a
-foldlNF_Tc :: (a -> b -> NF_TcM a) -> a -> [b] -> NF_TcM a
-foldlTc k z [] = returnTc z
-foldlTc k z (x:xs) = k z x `thenTc` \r ->
- foldlTc k r xs
-
-mapAndUnzipTc :: (a -> TcM (b,c)) -> [a] -> TcM ([b],[c])
-mapAndUnzipNF_Tc :: (a -> NF_TcM (b,c)) -> [a] -> NF_TcM ([b],[c])
-mapAndUnzipTc f [] = returnTc ([],[])
-mapAndUnzipTc f (x:xs) = f x `thenTc` \ (r1,r2) ->
- mapAndUnzipTc f xs `thenTc` \ (rs1,rs2) ->
- returnTc (r1:rs1, r2:rs2)
-
-mapAndUnzip3Tc :: (a -> TcM (b,c,d)) -> [a] -> TcM ([b],[c],[d])
-mapAndUnzip3Tc f [] = returnTc ([],[],[])
-mapAndUnzip3Tc f (x:xs) = f x `thenTc` \ (r1,r2,r3) ->
- mapAndUnzip3Tc f xs `thenTc` \ (rs1,rs2,rs3) ->
- returnTc (r1:rs1, r2:rs2, r3:rs3)
-
-mapBagTc :: (a -> TcM b) -> Bag a -> TcM (Bag b)
-mapBagNF_Tc :: (a -> NF_TcM b) -> Bag a -> NF_TcM (Bag b)
-mapBagTc f bag
- = foldBag (\ b1 b2 -> b1 `thenTc` \ r1 ->
- b2 `thenTc` \ r2 ->
- returnTc (unionBags r1 r2))
- (\ a -> f a `thenTc` \ r -> returnTc (unitBag r))
- (returnTc emptyBag)
- bag
-
-fixTc :: (a -> TcM a) -> TcM a
-fixNF_Tc :: (a -> NF_TcM a) -> NF_TcM a
-fixTc m env down = fixIO (\ loop -> m loop env down)
-{-# NOINLINE fixTc #-}
--- aargh! Not inlining fixTc alleviates a space leak problem.
--- Normally fixTc is used with a lazy tuple match: if the optimiser is
--- shown the definition of fixTc, it occasionally transforms the code
--- in such a way that the code generator doesn't spot the selector
--- thunks. Sigh.
-
-recoverTc :: TcM r -> TcM r -> TcM r
-recoverNF_Tc :: NF_TcM r -> TcM r -> NF_TcM 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 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.
-
-So we compromise and use unsafeInterleaveIO.
-
-We throw away any error messages!
-
-\begin{code}
-forkNF_Tc :: NF_TcM r -> NF_TcM r
-forkNF_Tc m down@(TcDown { tc_us = u_var }) env
- = do
- -- Get a fresh unique supply
- us <- readIORef u_var
- let (us1, us2) = splitUniqSupply us
- writeIORef u_var us1
-
- unsafeInterleaveIO (do {
- us_var' <- newIORef us2 ;
- err_var' <- newIORef (emptyBag,emptyBag) ;
- let { down' = down { tc_us = us_var', tc_errs = err_var' } };
- m down' env
- -- ToDo: optionally dump any error messages
- })
-\end{code}
-
-\begin{code}
-traceTc :: SDoc -> NF_TcM ()
-traceTc doc (TcDown { tc_dflags=dflags }) env
- | dopt Opt_D_dump_tc_trace dflags = printDump doc
- | otherwise = return ()
-
-ioToTc :: IO a -> NF_TcM a
-ioToTc io down env = io
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Error handling}
-%* *
-%************************************************************************
-
-\begin{code}
-getErrsTc :: NF_TcM (Bag WarnMsg, Bag ErrMsg)
-getErrsTc down env
- = readIORef (getTcErrs down)
-
-failTc :: TcM a
-failTc down env = give_up
-
-give_up :: IO a
-give_up = ioError (userError "Typecheck failed")
-
-failWithTc :: Message -> TcM a -- Add an error message and fail
-failWithTc err_msg = failWithTcM (emptyTidyEnv, err_msg)
-
-addErrTc :: Message -> NF_TcM ()
-addErrTc err_msg = addErrTcM (emptyTidyEnv, err_msg)
-
-addErrsTc :: [Message] -> NF_TcM ()
-addErrsTc [] = returnNF_Tc ()
-addErrsTc err_msgs = listNF_Tc (map addErrTc err_msgs) `thenNF_Tc_` returnNF_Tc ()
-
--- The 'M' variants do the TidyEnv bit
-failWithTcM :: (TidyEnv, Message) -> TcM a -- Add an error message and fail
-failWithTcM env_and_msg
- = addErrTcM env_and_msg `thenNF_Tc_`
- failTc
-
-checkTc :: Bool -> Message -> TcM () -- Check that the boolean is true
-checkTc True err = returnTc ()
-checkTc False err = failWithTc err
-
-checkTcM :: Bool -> TcM () -> TcM () -- Check that the boolean is true
-checkTcM True err = returnTc ()
-checkTcM False err = err
-
-checkMaybeTc :: Maybe val -> Message -> TcM val
-checkMaybeTc (Just val) err = returnTc val
-checkMaybeTc Nothing err = failWithTc err
-
-checkMaybeTcM :: Maybe val -> TcM val -> TcM val
-checkMaybeTcM (Just val) err = returnTc val
-checkMaybeTcM Nothing err = err
-
-addErrTcM :: (TidyEnv, Message) -> NF_TcM () -- Add an error message but don't fail
-addErrTcM (tidy_env, err_msg) down env
- = add_err_tcm tidy_env err_msg ctxt loc down env
- where
- ctxt = getErrCtxt down
- loc = getLoc down
-
-addInstErrTcM :: InstLoc -> (TidyEnv, Message) -> NF_TcM () -- Add an error message but don't fail
-addInstErrTcM inst_loc@(_, loc, ctxt) (tidy_env, err_msg) down env
- = add_err_tcm tidy_env err_msg full_ctxt loc down env
- where
- full_ctxt = (\env -> returnNF_Tc (env, pprInstLoc inst_loc)) : ctxt
-
-add_err_tcm tidy_env err_msg ctxt loc down env
- = 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
-
-do_ctxt tidy_env [] down env
- = return []
-do_ctxt tidy_env (c:cs) down env
- = 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 ()
-warnTc warn_if_true warn_msg down env
- | 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)
- writeIORef errs_var (warns `snocBag` warn, errs)
- | otherwise
- = return ()
- where
- errs_var = getTcErrs down
- ctxt = getErrCtxt down
- loc = getLoc down
-
--- (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 r) -- Recovery action
- -> TcM r -- Thing to try
- -> TcM 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
- errs_var = getTcErrs down
-
- 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
- -- No errors, so return normally, but don't lose the warnings
- if isEmptyBag m_warns then
- return result
- else
- do (warns, errs) <- readIORef errs_var
- writeIORef errs_var (warns `unionBags` m_warns, errs)
- return result
- else
- give_up -- This triggers the catch
-
-
--- (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.
-checkNoErrsTc :: TcM r -> TcM r
-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
-
-
-ifErrsTc :: TcM r -> TcM r -> TcM r
--- ifErrsTc bale_out main
--- does 'bale_out' if there are errors in errors collection
--- and does 'main' otherwise
--- Useful to avoid error cascades
-
-ifErrsTc bale_out main
- = getErrsTc `thenNF_Tc` \ (warns, errs) ->
- if isEmptyBag errs then
- main
- else
- bale_out
-
--- (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 r -> TcM r -> TcM r
-tryTc_ recover main
- = tryTc my_recover main
- where
- my_recover warns_and_errs = recover
-
--- (discardErrsTc m) runs m, but throw away all its error messages.
-discardErrsTc :: Either_TcM r -> Either_TcM r
-discardErrsTc main down env
- = do new_errs_var <- newIORef (emptyBag,emptyBag)
- main (setTcErrs down new_errs_var) env
-\end{code}
-
-
-
-%************************************************************************
-%* *
-\subsection{Mutable variables}
-%* *
-%************************************************************************
-
-\begin{code}
-tcNewMutVar :: a -> NF_TcM (TcRef a)
-tcNewMutVar val down env = newIORef val
-
-tcWriteMutVar :: TcRef a -> a -> NF_TcM ()
-tcWriteMutVar var val down env = writeIORef var val
-
-tcReadMutVar :: TcRef a -> NF_TcM a
-tcReadMutVar var down env = readIORef var
-
-tcNewMutTyVar :: Name -> Kind -> TyVarDetails -> NF_TcM TyVar
-tcNewMutTyVar name kind details down env = newMutTyVar name kind details
-
-tcReadMutTyVar :: TyVar -> NF_TcM (Maybe Type)
-tcReadMutTyVar tyvar down env = readMutTyVar tyvar
-
-tcWriteMutTyVar :: TyVar -> Maybe Type -> NF_TcM ()
-tcWriteMutTyVar tyvar val down env = writeMutTyVar tyvar val
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{The environment}
-%* *
-%************************************************************************
-
-\begin{code}
-tcGetEnv :: NF_TcM TcEnv
-tcGetEnv down env = return env
-
-tcSetEnv :: TcEnv -> Either_TcM a -> Either_TcM a
-tcSetEnv new_env m down old_env = m down new_env
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Source location}
-%* *
-%************************************************************************
-
-\begin{code}
-tcGetDefaultTys :: NF_TcM [Type]
-tcGetDefaultTys down env = return (getDefaultTys down)
-
-tcSetDefaultTys :: [Type] -> TcM r -> TcM r
-tcSetDefaultTys tys m down env = m (setDefaultTys down tys) env
-
-tcAddSrcLoc :: SrcLoc -> Either_TcM a -> Either_TcM a
-tcAddSrcLoc loc m down env = m (setLoc down loc) env
-
-tcGetSrcLoc :: NF_TcM SrcLoc
-tcGetSrcLoc down env = return (getLoc down)
-
-tcGetInstLoc :: InstOrigin -> NF_TcM InstLoc
-tcGetInstLoc origin TcDown{tc_loc=loc, tc_ctxt=ctxt} env
- = return (origin, loc, ctxt)
-
-tcSetErrCtxtM, tcAddErrCtxtM :: (TidyEnv -> NF_TcM (TidyEnv, Message))
- -> TcM a -> TcM a
-tcSetErrCtxtM msg m down env = m (setErrCtxt down msg) env
-tcAddErrCtxtM msg m down env = m (addErrCtxt down msg) env
-
-tcSetErrCtxt, tcAddErrCtxt :: Message -> Either_TcM r -> Either_TcM 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
-
-tcPopErrCtxt :: Either_TcM r -> Either_TcM r
-tcPopErrCtxt m down env = m (popErrCtxt down) env
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Unique supply}
-%* *
-%************************************************************************
-
-\begin{code}
-tcGetUnique :: NF_TcM Unique
-tcGetUnique down env
- = 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 :: NF_TcM [Unique]
-tcGetUniques down env
- = do uniq_supply <- readIORef u_var
- let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
- uniqs = uniqsFromSupply uniq_s
- writeIORef u_var new_uniq_supply
- return uniqs
- where
- u_var = getUniqSupplyVar down
-
-uniqSMToTcM :: UniqSM a -> NF_TcM a
-uniqSMToTcM m down env
- = 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}
-
-
-
-%************************************************************************
-%* *
-\subsection{TcDown}
-%* *
-%************************************************************************
-
-\begin{code}
-data TcDown
- = TcDown {
- tc_dflags :: DynFlags,
- tc_def :: [Type], -- Types used for defaulting
- tc_us :: (TcRef UniqSupply), -- Unique supply
- tc_loc :: SrcLoc, -- Source location
- tc_ctxt :: ErrCtxt, -- Error context
- tc_errs :: (TcRef (Bag WarnMsg, Bag ErrMsg))
- }
-
-type ErrCtxt = [TidyEnv -> NF_TcM (TidyEnv, Message)]
- -- Innermost first. Monadic so that we have a chance
- -- to deal with bound type variables just before error
- -- message construction
-\end{code}
-
--- These selectors are *local* to TcMonad.lhs
-
-\begin{code}
-getTcErrs (TcDown{tc_errs=errs}) = errs
-setTcErrs down errs = down{tc_errs=errs}
-
-getDefaultTys (TcDown{tc_def=def}) = def
-setDefaultTys down def = down{tc_def=def}
-
-getLoc (TcDown{tc_loc=loc}) = loc
-setLoc down loc = down{tc_loc=loc}
-
-getUniqSupplyVar (TcDown{tc_us=us}) = us
-
-getErrCtxt (TcDown{tc_ctxt=ctxt}) = ctxt
-setErrCtxt down msg = down{tc_ctxt=[msg]}
-addErrCtxt down msg = down{tc_ctxt = msg : tc_ctxt down}
-
-popErrCtxt down = case tc_ctxt down of
- [] -> down
- m : ms -> down{tc_ctxt = ms}
-
-doptsTc :: DynFlag -> NF_TcM Bool
-doptsTc dflag (TcDown{tc_dflags=dflags}) env_down
- = return (dopt dflag dflags)
-
-getDOptsTc :: NF_TcM DynFlags
-getDOptsTc (TcDown{tc_dflags=dflags}) env_down
- = return dflags
-\end{code}
-
-
-
-
-%************************************************************************
-%* *
-\subsection{TypeChecking Errors}
-%* *
-%************************************************************************
-
-\begin{code}
-type TcError = Message
-type TcWarning = Message
-
-ctxt_to_use ctxt | opt_PprStyle_Debug = ctxt
- | otherwise = take 3 ctxt
-
-arityErr kind name n m
- = hsep [ text kind, quotes (ppr name), ptext SLIT("should have"),
- n_arguments <> comma, text "but has been given", int m]
- where
- n_arguments | n == 0 = ptext SLIT("no arguments")
- | n == 1 = ptext SLIT("1 argument")
- | True = hsep [int n, ptext SLIT("arguments")]
-\end{code}
-
-
-
-%************************************************************************
-%* *
-\subsection[Inst-origin]{The @InstOrigin@ type}
-%* *
-%************************************************************************
-
-The @InstOrigin@ type gives information about where a dictionary came from.
-This is important for decent error message reporting because dictionaries
-don't appear in the original source code. Doubtless this type will evolve...
-
-It appears in TcMonad because there are a couple of error-message-generation
-functions that deal with it.
-
-\begin{code}
-type InstLoc = (InstOrigin, SrcLoc, ErrCtxt)
-
-data InstOrigin
- = OccurrenceOf Name -- Occurrence of an overloaded identifier
-
- | IPOcc (IPName Name) -- Occurrence of an implicit parameter
- | IPBind (IPName Name) -- Binding site of an implicit parameter
-
- | RecordUpdOrigin
-
- | DataDeclOrigin -- Typechecking a data declaration
-
- | InstanceDeclOrigin -- Typechecking an instance decl
-
- | LiteralOrigin HsOverLit -- Occurrence of a literal
-
- | PatOrigin RenamedPat
-
- | ArithSeqOrigin RenamedArithSeqInfo -- [x..], [x..y] etc
- | PArrSeqOrigin RenamedArithSeqInfo -- [:x..y:] and [:x,y..z:]
-
- | SignatureOrigin -- A dict created from a type signature
- | Rank2Origin -- A dict created when typechecking the argument
- -- of a rank-2 typed function
-
- | DoOrigin -- The monad for a do expression
-
- | ClassDeclOrigin -- Manufactured during a class decl
-
- | InstanceSpecOrigin Class -- in a SPECIALIZE instance pragma
- Type
-
- -- When specialising instances the instance info attached to
- -- each class is not yet ready, so we record it inside the
- -- origin information. This is a bit of a hack, but it works
- -- fine. (Patrick is to blame [WDP].)
-
- | ValSpecOrigin Name -- in a SPECIALIZE pragma for a value
-
- -- Argument or result of a ccall
- -- Dictionaries with this origin aren't actually mentioned in the
- -- translated term, and so need not be bound. Nor should they
- -- be abstracted over.
-
- | CCallOrigin String -- CCall label
- (Maybe RenamedHsExpr) -- Nothing if it's the result
- -- Just arg, for an argument
-
- | LitLitOrigin String -- the litlit
-
- | UnknownOrigin -- Help! I give up...
-\end{code}
-
-\begin{code}
-pprInstLoc :: InstLoc -> SDoc
-pprInstLoc (orig, locn, ctxt)
- = hsep [text "arising from", pp_orig orig, text "at", ppr locn]
- where
- pp_orig (OccurrenceOf name)
- = hsep [ptext SLIT("use of"), quotes (ppr name)]
- pp_orig (IPOcc name)
- = hsep [ptext SLIT("use of implicit parameter"), quotes (ppr name)]
- pp_orig (IPBind name)
- = hsep [ptext SLIT("binding for implicit parameter"), quotes (ppr name)]
- pp_orig RecordUpdOrigin
- = ptext SLIT("a record update")
- pp_orig DataDeclOrigin
- = ptext SLIT("the data type declaration")
- pp_orig InstanceDeclOrigin
- = ptext SLIT("the instance declaration")
- pp_orig (LiteralOrigin lit)
- = hsep [ptext SLIT("the literal"), quotes (ppr lit)]
- pp_orig (PatOrigin pat)
- = hsep [ptext SLIT("the pattern"), quotes (ppr pat)]
- pp_orig (ArithSeqOrigin seq)
- = hsep [ptext SLIT("the arithmetic sequence"), quotes (ppr seq)]
- pp_orig (PArrSeqOrigin seq)
- = hsep [ptext SLIT("the parallel array sequence"), quotes (ppr seq)]
- pp_orig (SignatureOrigin)
- = ptext SLIT("a type signature")
- pp_orig (Rank2Origin)
- = ptext SLIT("a function with an overloaded argument type")
- pp_orig (DoOrigin)
- = ptext SLIT("a do statement")
- pp_orig (ClassDeclOrigin)
- = ptext SLIT("a class declaration")
- pp_orig (InstanceSpecOrigin clas ty)
- = hsep [text "a SPECIALIZE instance pragma; class",
- quotes (ppr clas), text "type:", ppr ty]
- pp_orig (ValSpecOrigin name)
- = hsep [ptext SLIT("a SPECIALIZE user-pragma for"), quotes (ppr name)]
- pp_orig (CCallOrigin clabel Nothing{-ccall result-})
- = hsep [ptext SLIT("the result of the _ccall_ to"), quotes (text clabel)]
- pp_orig (CCallOrigin clabel (Just arg_expr))
- = hsep [ptext SLIT("an argument in the _ccall_ to"), quotes (text clabel) <> comma,
- text "namely", quotes (ppr arg_expr)]
- pp_orig (LitLitOrigin s)
- = hsep [ptext SLIT("the ``literal-literal''"), quotes (text s)]
- pp_orig (UnknownOrigin)
- = ptext SLIT("...oops -- I don't know where the overloading came from!")
-\end{code}
import RnHsSyn ( RenamedHsType, RenamedHsPred, RenamedContext, RenamedSig, extractHsTyVars )
import TcHsSyn ( TcId )
-import TcMonad
+import TcRnMonad
import TcEnv ( tcExtendTyVarEnv, tcLookup, tcLookupGlobal,
- tcInLocalScope,
- TyThing(..), TcTyThing(..), tcExtendKindEnv
+ TyThing(..), TcTyThing(..), tcExtendKindEnv,
+ getInLocalScope
)
-import TcMType ( newKindVar, zonkKindEnv, tcInstType,
+import TcMType ( newMutTyVar, newKindVar, zonkKindEnv, tcInstType,
checkValidType, UserTypeCtxt(..), pprUserTypeCtxt
)
import TcUnify ( unifyKind, unifyOpenTypeKind )
liftedTypeKind, unliftedTypeKind, mkArrowKind,
mkArrowKinds, tcSplitFunTy_maybe, tcSplitForAllTys
)
-import Inst ( Inst, InstOrigin(..), newMethodWithGivenTy, instToId )
+import Inst ( Inst, InstOrigin(..), newMethodWith, instToId )
import Id ( mkLocalId, idName, idType )
import Var ( TyVar, mkTyVar, tyVarKind )
\begin{code}
tcHsSigType :: UserTypeCtxt -> RenamedHsType -> TcM Type
-- Do kind checking, and hoist for-alls to the top
-tcHsSigType ctxt ty = tcAddErrCtxt (checkTypeCtxt ctxt ty) (
- kcTypeType ty `thenTc_`
+tcHsSigType ctxt ty = addErrCtxt (checkTypeCtxt ctxt ty) (
+ kcTypeType ty `thenM_`
tcHsType ty
- ) `thenTc` \ ty' ->
- checkValidType ctxt ty' `thenTc_`
- returnTc ty'
+ ) `thenM` \ ty' ->
+ checkValidType ctxt ty' `thenM_`
+ returnM ty'
checkTypeCtxt ctxt ty
= vcat [ptext SLIT("In the type:") <+> ppr ty,
-- This is used in type and class decls, where kinding is
-- done in advance, and validity checking is done later
-- [Validity checking done later because of knot-tying issues.]
-tcHsType ty = tc_type ty `thenTc` \ ty' ->
- returnTc (hoistForAllTys ty')
+tcHsType ty = tc_type ty `thenM` \ ty' ->
+ returnM (hoistForAllTys ty')
tcHsTheta :: RenamedContext -> TcM ThetaType
-- Used when we are expecting a ClassContext (i.e. no implicit params)
-- Does not do validity checking, like tcHsType
-tcHsTheta hs_theta = mapTc tc_pred hs_theta
+tcHsTheta hs_theta = mappM tc_pred hs_theta
-- In interface files the type is already kinded,
-- and we definitely don't want to hoist for-alls.
-- A useful short cut for a common case!
tcHsTyVars tv_names kind_check thing_inside
- = kcHsTyVars tv_names `thenNF_Tc` \ tv_names_w_kinds ->
- tcExtendKindEnv tv_names_w_kinds kind_check `thenTc_`
- zonkKindEnv tv_names_w_kinds `thenNF_Tc` \ tvs_w_kinds ->
+ = kcHsTyVars tv_names `thenM` \ tv_names_w_kinds ->
+ tcExtendKindEnv tv_names_w_kinds kind_check `thenM_`
+ zonkKindEnv tv_names_w_kinds `thenM` \ tvs_w_kinds ->
let
tyvars = mkImmutTyVars tvs_w_kinds
in
= thing_inside -- Quick get-out for the empty case
tcAddScopedTyVars sig_tys thing_inside
- = tcGetEnv `thenNF_Tc` \ env ->
+ = getInLocalScope `thenM` \ in_scope ->
let
all_sig_tvs = foldr (unionNameSets . extractHsTyVars) emptyNameSet sig_tys
- sig_tvs = filter not_in_scope (nameSetToList all_sig_tvs)
- not_in_scope tv = not (tcInLocalScope env tv)
+ sig_tvs = filter (not . in_scope) (nameSetToList all_sig_tvs)
in
- mapNF_Tc newNamedKindVar sig_tvs `thenTc` \ kind_env ->
- tcExtendKindEnv kind_env (kcHsSigTypes sig_tys) `thenTc_`
- zonkKindEnv kind_env `thenNF_Tc` \ tvs_w_kinds ->
- listTc [ tcNewMutTyVar name kind PatSigTv
- | (name, kind) <- tvs_w_kinds] `thenNF_Tc` \ tyvars ->
+ mappM newNamedKindVar sig_tvs `thenM` \ kind_env ->
+ tcExtendKindEnv kind_env (kcHsSigTypes sig_tys) `thenM_`
+ zonkKindEnv kind_env `thenM` \ tvs_w_kinds ->
+ sequenceM [ newMutTyVar name kind PatSigTv
+ | (name, kind) <- tvs_w_kinds] `thenM` \ tyvars ->
tcExtendTyVarEnv tyvars thing_inside
\end{code}
\begin{code}
-kcHsTyVar :: HsTyVarBndr name -> NF_TcM (name, TcKind)
-kcHsTyVars :: [HsTyVarBndr name] -> NF_TcM [(name, TcKind)]
+kcHsTyVar :: HsTyVarBndr name -> TcM (name, TcKind)
+kcHsTyVars :: [HsTyVarBndr name] -> TcM [(name, TcKind)]
kcHsTyVar (UserTyVar name) = newNamedKindVar name
-kcHsTyVar (IfaceTyVar name kind) = returnNF_Tc (name, kind)
+kcHsTyVar (IfaceTyVar name kind) = returnM (name, kind)
-kcHsTyVars tvs = mapNF_Tc kcHsTyVar tvs
+kcHsTyVars tvs = mappM kcHsTyVar tvs
-newNamedKindVar name = newKindVar `thenNF_Tc` \ kind ->
- returnNF_Tc (name, kind)
+newNamedKindVar name = newKindVar `thenM` \ kind ->
+ returnM (name, kind)
---------------------------
kcLiftedType :: RenamedHsType -> TcM ()
-- The type ty must be a *lifted* *type*
kcLiftedType ty
- = kcHsType ty `thenTc` \ kind ->
- tcAddErrCtxt (typeKindCtxt ty) $
+ = kcHsType ty `thenM` \ kind ->
+ addErrCtxt (typeKindCtxt ty) $
unifyKind liftedTypeKind kind
---------------------------
kcTypeType :: RenamedHsType -> TcM ()
-- The type ty must be a *type*, but it can be lifted or unlifted.
kcTypeType ty
- = kcHsType ty `thenTc` \ kind ->
- tcAddErrCtxt (typeKindCtxt ty) $
+ = kcHsType ty `thenM` \ kind ->
+ addErrCtxt (typeKindCtxt ty) $
unifyOpenTypeKind kind
---------------------------
kcHsSigType, kcHsLiftedSigType :: RenamedHsType -> TcM ()
-- Used for type signatures
kcHsSigType = kcTypeType
-kcHsSigTypes tys = mapTc_ kcHsSigType tys
+kcHsSigTypes tys = mappM_ kcHsSigType tys
kcHsLiftedSigType = kcLiftedType
---------------------------
kcHsType (HsTyVar name) = kcTyVar name
kcHsType (HsKindSig ty k)
- = kcHsType ty `thenTc` \ k' ->
- unifyKind k k' `thenTc_`
- returnTc k
+ = kcHsType ty `thenM` \ k' ->
+ unifyKind k k' `thenM_`
+ returnM k
kcHsType (HsListTy ty)
- = kcLiftedType ty `thenTc` \ tau_ty ->
- returnTc liftedTypeKind
+ = kcLiftedType ty `thenM` \ tau_ty ->
+ returnM liftedTypeKind
kcHsType (HsPArrTy ty)
- = kcLiftedType ty `thenTc` \ tau_ty ->
- returnTc liftedTypeKind
+ = kcLiftedType ty `thenM` \ tau_ty ->
+ returnM liftedTypeKind
-kcHsType (HsTupleTy (HsTupCon _ boxity _) tys)
- = mapTc kcTypeType tys `thenTc_`
- returnTc (case boxity of
+kcHsType (HsTupleTy (HsTupCon boxity _) tys)
+ = mappM kcTypeType tys `thenM_`
+ returnM (case boxity of
Boxed -> liftedTypeKind
Unboxed -> unliftedTypeKind)
kcHsType (HsFunTy ty1 ty2)
- = kcTypeType ty1 `thenTc_`
- kcTypeType ty2 `thenTc_`
- returnTc liftedTypeKind
+ = kcTypeType ty1 `thenM_`
+ kcTypeType ty2 `thenM_`
+ returnM liftedTypeKind
kcHsType (HsOpTy ty1 HsArrow ty2)
- = kcTypeType ty1 `thenTc_`
- kcTypeType ty2 `thenTc_`
- returnTc liftedTypeKind
+ = kcTypeType ty1 `thenM_`
+ kcTypeType ty2 `thenM_`
+ returnM liftedTypeKind
kcHsType ty@(HsOpTy ty1 (HsTyOp op) ty2)
- = kcTyVar op `thenTc` \ op_kind ->
- kcHsType ty1 `thenTc` \ ty1_kind ->
- kcHsType ty2 `thenTc` \ ty2_kind ->
- tcAddErrCtxt (appKindCtxt (ppr ty)) $
- kcAppKind op_kind ty1_kind `thenTc` \ op_kind' ->
+ = kcTyVar op `thenM` \ op_kind ->
+ kcHsType ty1 `thenM` \ ty1_kind ->
+ kcHsType ty2 `thenM` \ ty2_kind ->
+ addErrCtxt (appKindCtxt (ppr ty)) $
+ kcAppKind op_kind ty1_kind `thenM` \ op_kind' ->
kcAppKind op_kind' ty2_kind
kcHsType (HsParTy ty) -- Skip parentheses markers
= kcHsType ty
kcHsType (HsNumTy _) -- The unit type for generics
- = returnTc liftedTypeKind
+ = returnM liftedTypeKind
kcHsType (HsPredTy pred)
- = kcHsPred pred `thenTc_`
- returnTc liftedTypeKind
+ = kcHsPred pred `thenM_`
+ returnM liftedTypeKind
kcHsType ty@(HsAppTy ty1 ty2)
- = kcHsType ty1 `thenTc` \ tc_kind ->
- kcHsType ty2 `thenTc` \ arg_kind ->
- tcAddErrCtxt (appKindCtxt (ppr ty)) $
+ = kcHsType ty1 `thenM` \ tc_kind ->
+ kcHsType ty2 `thenM` \ arg_kind ->
+ addErrCtxt (appKindCtxt (ppr ty)) $
kcAppKind tc_kind arg_kind
kcHsType (HsForAllTy (Just tv_names) context ty)
- = kcHsTyVars tv_names `thenNF_Tc` \ kind_env ->
+ = kcHsTyVars tv_names `thenM` \ kind_env ->
tcExtendKindEnv kind_env $
- kcHsContext context `thenTc_`
- kcLiftedType ty `thenTc_`
+ kcHsContext context `thenM_`
+ kcLiftedType ty `thenM_`
-- The body of a forall must be of kind *
-- In principle, I suppose, we could allow unlifted types,
-- but it seems simpler to stick to lifted types for now.
- returnTc liftedTypeKind
+ returnM liftedTypeKind
---------------------------
kcAppKind fun_kind arg_kind
= case tcSplitFunTy_maybe fun_kind of
Just (arg_kind', res_kind)
- -> unifyKind arg_kind arg_kind' `thenTc_`
- returnTc res_kind
+ -> unifyKind arg_kind arg_kind' `thenM_`
+ returnM res_kind
- Nothing -> newKindVar `thenNF_Tc` \ res_kind ->
- unifyKind fun_kind (mkArrowKind arg_kind res_kind) `thenTc_`
- returnTc res_kind
+ Nothing -> newKindVar `thenM` \ res_kind ->
+ unifyKind fun_kind (mkArrowKind arg_kind res_kind) `thenM_`
+ returnM res_kind
---------------------------
= kcHsType ty
kc_pred pred@(HsClassP cls tys)
- = kcClass cls `thenTc` \ kind ->
- mapTc kcHsType tys `thenTc` \ arg_kinds ->
- newKindVar `thenNF_Tc` \ kv ->
- unifyKind kind (mkArrowKinds arg_kinds kv) `thenTc_`
- returnTc kv
+ = kcClass cls `thenM` \ kind ->
+ mappM kcHsType tys `thenM` \ arg_kinds ->
+ newKindVar `thenM` \ kv ->
+ unifyKind kind (mkArrowKinds arg_kinds kv) `thenM_`
+ returnM kv
---------------------------
-kcHsContext ctxt = mapTc_ kcHsPred ctxt
+kcHsContext ctxt = mappM_ kcHsPred ctxt
kcHsPred pred -- Checks that the result is of kind liftedType
- = tcAddErrCtxt (appKindCtxt (ppr pred)) $
- kc_pred pred `thenTc` \ kind ->
- unifyKind liftedTypeKind kind `thenTc_`
- returnTc ()
+ = addErrCtxt (appKindCtxt (ppr pred)) $
+ kc_pred pred `thenM` \ kind ->
+ unifyKind liftedTypeKind kind `thenM_`
+ returnM ()
---------------------------
kcTyVar name -- Could be a tyvar or a tycon
- = tcLookup name `thenTc` \ thing ->
+ = tcLookup name `thenM` \ thing ->
case thing of
- AThing kind -> returnTc kind
- ATyVar tv -> returnTc (tyVarKind tv)
- AGlobal (ATyCon tc) -> returnTc (tyConKind tc)
+ AThing kind -> returnM kind
+ ATyVar tv -> returnM (tyVarKind tv)
+ AGlobal (ATyCon tc) -> returnM (tyConKind tc)
other -> failWithTc (wrongThingErr "type" thing name)
kcClass cls -- Must be a class
- = tcLookup cls `thenNF_Tc` \ thing ->
+ = tcLookup cls `thenM` \ thing ->
case thing of
- AThing kind -> returnTc kind
- AGlobal (AClass cls) -> returnTc (tyConKind (classTyCon cls))
+ AThing kind -> returnM kind
+ AGlobal (AClass cls) -> returnM (tyConKind (classTyCon cls))
other -> failWithTc (wrongThingErr "class" thing cls)
\end{code}
= tc_type ty -- Kind checking done already
tc_type (HsListTy ty)
- = tc_type ty `thenTc` \ tau_ty ->
- returnTc (mkListTy tau_ty)
+ = tc_type ty `thenM` \ tau_ty ->
+ returnM (mkListTy tau_ty)
tc_type (HsPArrTy ty)
- = tc_type ty `thenTc` \ tau_ty ->
- returnTc (mkPArrTy tau_ty)
+ = tc_type ty `thenM` \ tau_ty ->
+ returnM (mkPArrTy tau_ty)
-tc_type (HsTupleTy (HsTupCon _ boxity arity) tys)
+tc_type (HsTupleTy (HsTupCon boxity arity) tys)
= ASSERT( tys `lengthIs` arity )
- tc_types tys `thenTc` \ tau_tys ->
- returnTc (mkTupleTy boxity arity tau_tys)
+ tc_types tys `thenM` \ tau_tys ->
+ returnM (mkTupleTy boxity arity tau_tys)
tc_type (HsFunTy ty1 ty2)
- = tc_type ty1 `thenTc` \ tau_ty1 ->
- tc_type ty2 `thenTc` \ tau_ty2 ->
- returnTc (mkFunTy tau_ty1 tau_ty2)
+ = tc_type ty1 `thenM` \ tau_ty1 ->
+ tc_type ty2 `thenM` \ tau_ty2 ->
+ returnM (mkFunTy tau_ty1 tau_ty2)
tc_type (HsOpTy ty1 HsArrow ty2)
- = tc_type ty1 `thenTc` \ tau_ty1 ->
- tc_type ty2 `thenTc` \ tau_ty2 ->
- returnTc (mkFunTy tau_ty1 tau_ty2)
+ = tc_type ty1 `thenM` \ tau_ty1 ->
+ tc_type ty2 `thenM` \ tau_ty2 ->
+ returnM (mkFunTy tau_ty1 tau_ty2)
tc_type (HsOpTy ty1 (HsTyOp op) ty2)
- = tc_type ty1 `thenTc` \ tau_ty1 ->
- tc_type ty2 `thenTc` \ tau_ty2 ->
+ = tc_type ty1 `thenM` \ tau_ty1 ->
+ tc_type ty2 `thenM` \ tau_ty2 ->
tc_fun_type op [tau_ty1,tau_ty2]
tc_type (HsParTy ty) -- Remove the parentheses markers
tc_type (HsNumTy n)
= ASSERT(n== 1)
- returnTc (mkTyConApp genUnitTyCon [])
+ returnM (mkTyConApp genUnitTyCon [])
tc_type (HsAppTy ty1 ty2) = tc_app ty1 [ty2]
tc_type (HsPredTy pred)
- = tc_pred pred `thenTc` \ pred' ->
- returnTc (mkPredTy pred')
+ = tc_pred pred `thenM` \ pred' ->
+ returnM (mkPredTy pred')
tc_type full_ty@(HsForAllTy (Just tv_names) ctxt ty)
= let
- kind_check = kcHsContext ctxt `thenTc_` kcHsType ty
+ kind_check = kcHsContext ctxt `thenM_` kcHsType ty
in
tcHsTyVars tv_names kind_check $ \ tyvars ->
- mapTc tc_pred ctxt `thenTc` \ theta ->
- tc_type ty `thenTc` \ tau ->
- returnTc (mkSigmaTy tyvars theta tau)
+ mappM tc_pred ctxt `thenM` \ theta ->
+ tc_type ty `thenM` \ tau ->
+ returnM (mkSigmaTy tyvars theta tau)
-tc_types arg_tys = mapTc tc_type arg_tys
+tc_types arg_tys = mappM tc_type arg_tys
\end{code}
Help functions for type applications
= tc_app ty1 (ty2:tys)
tc_app ty tys
- = tcAddErrCtxt (appKindCtxt pp_app) $
- tc_types tys `thenTc` \ arg_tys ->
+ = addErrCtxt (appKindCtxt pp_app) $
+ tc_types tys `thenM` \ arg_tys ->
case ty of
HsTyVar fun -> tc_fun_type fun arg_tys
- other -> tc_type ty `thenTc` \ fun_ty ->
- returnNF_Tc (mkAppTys fun_ty arg_tys)
+ other -> tc_type ty `thenM` \ fun_ty ->
+ returnM (mkAppTys fun_ty arg_tys)
where
pp_app = ppr ty <+> sep (map pprParendHsType tys)
-- hence the rather strange functionality.
tc_fun_type name arg_tys
- = tcLookup name `thenTc` \ thing ->
+ = tcLookup name `thenM` \ thing ->
case thing of
- ATyVar tv -> returnTc (mkAppTys (mkTyVarTy tv) arg_tys)
+ ATyVar tv -> returnM (mkAppTys (mkTyVarTy tv) arg_tys)
- AGlobal (ATyCon tc) -> returnTc (mkGenTyConApp tc arg_tys)
+ AGlobal (ATyCon tc) -> returnM (mkGenTyConApp tc arg_tys)
other -> failWithTc (wrongThingErr "type constructor" thing name)
\end{code}
Contexts
~~~~~~~~
\begin{code}
-tcHsPred pred = kc_pred pred `thenTc_` tc_pred pred
+tcHsPred pred = kc_pred pred `thenM_` tc_pred pred
-- Is happy with a partial application, e.g. (ST s)
-- Used from TcDeriv
tc_pred assn@(HsClassP class_name tys)
- = tcAddErrCtxt (appKindCtxt (ppr assn)) $
- tc_types tys `thenTc` \ arg_tys ->
- tcLookupGlobal class_name `thenTc` \ thing ->
+ = addErrCtxt (appKindCtxt (ppr assn)) $
+ tc_types tys `thenM` \ arg_tys ->
+ tcLookupGlobal class_name `thenM` \ thing ->
case thing of
- AClass clas -> returnTc (ClassP clas arg_tys)
+ AClass clas -> returnM (ClassP clas arg_tys)
other -> failWithTc (wrongThingErr "class" (AGlobal thing) class_name)
tc_pred assn@(HsIParam name ty)
- = tcAddErrCtxt (appKindCtxt (ppr assn)) $
- tc_type ty `thenTc` \ arg_ty ->
- returnTc (IParam name arg_ty)
+ = addErrCtxt (appKindCtxt (ppr assn)) $
+ tc_type ty `thenM` \ arg_ty ->
+ returnM (IParam name arg_ty)
\end{code}
tcTySig :: RenamedSig -> TcM TcSigInfo
tcTySig (Sig v ty src_loc)
- = tcAddSrcLoc src_loc $
- tcHsSigType (FunSigCtxt v) ty `thenTc` \ sigma_tc_ty ->
- mkTcSig (mkLocalId v sigma_tc_ty) src_loc `thenNF_Tc` \ sig ->
- returnTc sig
+ = addSrcLoc src_loc $
+ tcHsSigType (FunSigCtxt v) ty `thenM` \ sigma_tc_ty ->
+ mkTcSig (mkLocalId v sigma_tc_ty) src_loc `thenM` \ sig ->
+ returnM sig
-mkTcSig :: TcId -> SrcLoc -> NF_TcM TcSigInfo
+mkTcSig :: TcId -> SrcLoc -> TcM TcSigInfo
mkTcSig poly_id src_loc
= -- Instantiate this type
-- It's important to do this even though in the error-free case
-- the tyvars *do* get unified with something, we want to carry on
-- typechecking the rest of the program with the function bound
-- to a pristine type, namely sigma_tc_ty
- tcInstType SigTv (idType poly_id) `thenNF_Tc` \ (tyvars', theta', tau') ->
+ tcInstType SigTv (idType poly_id) `thenM` \ (tyvars', theta', tau') ->
- newMethodWithGivenTy SignatureOrigin
- poly_id
- (mkTyVarTys tyvars')
- theta' tau' `thenNF_Tc` \ inst ->
+ getInstLoc SignatureOrigin `thenM` \ inst_loc ->
+ newMethodWith inst_loc poly_id
+ (mkTyVarTys tyvars')
+ theta' tau' `thenM` \ inst ->
-- We make a Method even if it's not overloaded; no harm
+ -- But do not extend the LIE! We're just making an Id.
- returnNF_Tc (TySigInfo poly_id tyvars' theta' tau'
+ returnM (TySigInfo poly_id tyvars' theta' tau'
(instToId inst) [inst] src_loc)
\end{code}
pp_thing (AGlobal (AClass _)) = ptext SLIT("Class")
pp_thing (AGlobal (AnId _)) = ptext SLIT("Identifier")
pp_thing (ATyVar _) = ptext SLIT("Type variable")
- pp_thing (ATcId _) = ptext SLIT("Local identifier")
+ pp_thing (ATcId _ _) = ptext SLIT("Local identifier")
pp_thing (AThing _) = ptext SLIT("Utterly bogus")
\end{code}
#include "HsVersions.h"
-import HsSyn ( InPat(..), OutPat(..), HsLit(..), HsOverLit(..), HsExpr(..) )
+import HsSyn ( Pat(..), HsConDetails(..), HsLit(..), HsOverLit(..), HsExpr(..) )
import RnHsSyn ( RenamedPat )
-import TcHsSyn ( TcPat, TcId, simpleHsLitTy )
+import TcHsSyn ( TcPat, TcId, hsLitType )
-import TcMonad
+import TcRnMonad
import Inst ( InstOrigin(..),
- emptyLIE, plusLIE, LIE, mkLIE, unitLIE, instToId, isEmptyLIE,
- newMethod, newMethodFromName, newOverloadedLit, newDicts,
- tcInstDataCon, tcSyntaxName
+ newMethodFromName, newOverloadedLit, newDicts,
+ instToId, tcInstDataCon, tcSyntaxName
)
import Id ( mkLocalId, mkSysLocal )
import Name ( Name )
import FieldLabel ( fieldLabelName )
-import TcEnv ( tcLookupClass, tcLookupDataCon, tcLookupGlobalId, tcLookupId )
-import TcMType ( newTyVarTy, zapToType )
+import TcEnv ( tcLookupClass, tcLookupDataCon, tcLookupId )
+import TcMType ( newTyVarTy, zapToType, arityErr )
import TcType ( TcType, TcTyVar, TcSigmaType,
mkClassPred, liftedTypeKind )
import TcUnify ( tcSubOff, TcHoleType,
import TysWiredIn ( stringTy )
import CmdLineOpts ( opt_IrrefutableTuples )
-import DataCon ( dataConFieldLabels, dataConSourceArity )
+import DataCon ( DataCon, dataConFieldLabels, dataConSourceArity )
import PrelNames ( eqStringName, eqName, geName, negateName, minusName, cCallableClassName )
import BasicTypes ( isBoxed )
import Bag
%************************************************************************
\begin{code}
-type BinderChecker = Name -> TcSigmaType -> TcM (PatCoFn, LIE, TcId)
+type BinderChecker = Name -> TcSigmaType -> TcM (PatCoFn, TcId)
-- How to construct a suitable (monomorphic)
-- Id for variables found in the pattern
-- The TcSigmaType is the expected type
-- so there's no polymorphic guy to worry about
tcMonoPatBndr binder_name pat_ty
- = zapToType pat_ty `thenNF_Tc` \ pat_ty' ->
+ = zapToType pat_ty `thenM` \ pat_ty' ->
-- If there are *no constraints* on the pattern type, we
-- revert to good old H-M typechecking, making
-- the type of the binder into an *ordinary*
-- a type that is a 'hole'. The only place holes should
-- appear is as an argument to tcPat and tcExpr/tcMonoExpr.
- returnTc (idCoercion, emptyLIE, mkLocalId binder_name pat_ty')
+ returnM (idCoercion, mkLocalId binder_name pat_ty')
\end{code}
-- this type might be a forall type.
-> TcM (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
-- which it occurs in the pattern
-- The two aren't the same because we conjure up a new
-- local name for each variable.
- LIE) -- Dicts or methods [see below] bound by the pattern
+ [Inst]) -- Dicts or methods [see below] bound by the pattern
-- from existential constructor patterns
\end{code}
%************************************************************************
\begin{code}
-tcPat tc_bndr pat@(TypePatIn ty) pat_ty
+tcPat tc_bndr pat@(TypePat ty) pat_ty
= failWithTc (badTypePat pat)
-tcPat tc_bndr (VarPatIn name) pat_ty
- = tc_bndr name pat_ty `thenTc` \ (co_fn, lie_req, bndr_id) ->
- returnTc (co_fn <$> VarPat bndr_id, lie_req,
- emptyBag, unitBag (name, bndr_id), emptyLIE)
+tcPat tc_bndr (VarPat name) pat_ty
+ = tc_bndr name pat_ty `thenM` \ (co_fn, bndr_id) ->
+ returnM (co_fn <$> VarPat bndr_id,
+ emptyBag, unitBag (name, bndr_id), [])
-tcPat tc_bndr (LazyPatIn pat) pat_ty
- = tcPat tc_bndr pat pat_ty `thenTc` \ (pat', lie_req, tvs, ids, lie_avail) ->
- returnTc (LazyPat pat', lie_req, tvs, ids, lie_avail)
+tcPat tc_bndr (LazyPat pat) pat_ty
+ = tcPat tc_bndr pat pat_ty `thenM` \ (pat', tvs, ids, lie_avail) ->
+ returnM (LazyPat pat', tvs, ids, lie_avail)
-tcPat tc_bndr pat_in@(AsPatIn name pat) pat_ty
- = tc_bndr name pat_ty `thenTc` \ (co_fn, lie_req1, bndr_id) ->
- tcPat tc_bndr pat pat_ty `thenTc` \ (pat', lie_req2, tvs, ids, lie_avail) ->
- returnTc (co_fn <$> (AsPat bndr_id pat'), lie_req1 `plusLIE` lie_req2,
+tcPat tc_bndr pat_in@(AsPat name pat) pat_ty
+ = tc_bndr name pat_ty `thenM` \ (co_fn, bndr_id) ->
+ tcPat tc_bndr pat pat_ty `thenM` \ (pat', tvs, ids, lie_avail) ->
+ returnM (co_fn <$> (AsPat bndr_id pat'),
tvs, (name, bndr_id) `consBag` ids, lie_avail)
-tcPat tc_bndr WildPatIn pat_ty
- = zapToType pat_ty `thenNF_Tc` \ pat_ty' ->
+tcPat tc_bndr (WildPat _) pat_ty
+ = zapToType pat_ty `thenM` \ pat_ty' ->
-- We might have an incoming 'hole' type variable; no annotation
-- so zap it to a type. Rather like tcMonoPatBndr.
- returnTc (WildPat pat_ty', emptyLIE, emptyBag, emptyBag, emptyLIE)
+ returnM (WildPat pat_ty', emptyBag, emptyBag, [])
-tcPat tc_bndr (ParPatIn parend_pat) pat_ty
- = tcPat tc_bndr parend_pat pat_ty
+tcPat tc_bndr (ParPat parend_pat) pat_ty
+-- Leave the parens in, so that warnings from the
+-- desugarer have parens in them
+ = tcPat tc_bndr parend_pat pat_ty `thenM` \ (pat', tvs, ids, lie_avail) ->
+ returnM (ParPat pat', tvs, ids, lie_avail)
tcPat tc_bndr pat_in@(SigPatIn pat sig) pat_ty
- = tcAddErrCtxt (patCtxt pat_in) $
- tcHsSigType PatSigCtxt sig `thenTc` \ sig_ty ->
- tcSubPat sig_ty pat_ty `thenTc` \ (co_fn, lie_sig) ->
- tcPat tc_bndr pat sig_ty `thenTc` \ (pat', lie_req, tvs, ids, lie_avail) ->
- returnTc (co_fn <$> pat', lie_req `plusLIE` lie_sig, tvs, ids, lie_avail)
+ = addErrCtxt (patCtxt pat_in) $
+ tcHsSigType PatSigCtxt sig `thenM` \ sig_ty ->
+ tcSubPat sig_ty pat_ty `thenM` \ co_fn ->
+ tcPat tc_bndr pat sig_ty `thenM` \ (pat', tvs, ids, lie_avail) ->
+ returnM (co_fn <$> pat', tvs, ids, lie_avail)
\end{code}
%************************************************************************
\begin{code}
-tcPat tc_bndr pat_in@(ListPatIn pats) pat_ty
- = tcAddErrCtxt (patCtxt pat_in) $
- unifyListTy pat_ty `thenTc` \ elem_ty ->
- tcPats tc_bndr pats (repeat elem_ty) `thenTc` \ (pats', lie_req, tvs, ids, lie_avail) ->
- returnTc (ListPat elem_ty pats', lie_req, tvs, ids, lie_avail)
+tcPat tc_bndr pat_in@(ListPat pats _) pat_ty
+ = addErrCtxt (patCtxt pat_in) $
+ unifyListTy pat_ty `thenM` \ elem_ty ->
+ tcPats tc_bndr pats (repeat elem_ty) `thenM` \ (pats', tvs, ids, lie_avail) ->
+ returnM (ListPat pats' elem_ty, tvs, ids, lie_avail)
-tcPat tc_bndr pat_in@(PArrPatIn pats) pat_ty
- = tcAddErrCtxt (patCtxt pat_in) $
- unifyPArrTy pat_ty `thenTc` \ elem_ty ->
- tcPats tc_bndr pats (repeat elem_ty) `thenTc` \ (pats', lie_req, tvs, ids, lie_avail) ->
- returnTc (PArrPat elem_ty pats', lie_req, tvs, ids, lie_avail)
+tcPat tc_bndr pat_in@(PArrPat pats _) pat_ty
+ = addErrCtxt (patCtxt pat_in) $
+ unifyPArrTy pat_ty `thenM` \ elem_ty ->
+ tcPats tc_bndr pats (repeat elem_ty) `thenM` \ (pats', tvs, ids, lie_avail) ->
+ returnM (PArrPat pats' elem_ty, tvs, ids, lie_avail)
-tcPat tc_bndr pat_in@(TuplePatIn pats boxity) pat_ty
- = tcAddErrCtxt (patCtxt pat_in) $
+tcPat tc_bndr pat_in@(TuplePat pats boxity) pat_ty
+ = addErrCtxt (patCtxt pat_in) $
- unifyTupleTy boxity arity pat_ty `thenTc` \ arg_tys ->
- tcPats tc_bndr pats arg_tys `thenTc` \ (pats', lie_req, tvs, ids, lie_avail) ->
+ unifyTupleTy boxity arity pat_ty `thenM` \ arg_tys ->
+ tcPats tc_bndr pats arg_tys `thenM` \ (pats', tvs, ids, lie_avail) ->
-- possibly do the "make all tuple-pats irrefutable" test:
let
| opt_IrrefutableTuples && isBoxed boxity = LazyPat unmangled_result
| otherwise = unmangled_result
in
- returnTc (possibly_mangled_result, lie_req, tvs, ids, lie_avail)
+ returnM (possibly_mangled_result, tvs, ids, lie_avail)
where
arity = length pats
\end{code}
%************************************************************************
\begin{code}
-tcPat tc_bndr pat@(ConPatIn name arg_pats) pat_ty
- = tcConPat tc_bndr pat name arg_pats pat_ty
+tcPat tc_bndr pat_in@(ConPatIn con_name arg_pats) pat_ty
+ = addErrCtxt (patCtxt pat_in) $
-tcPat tc_bndr pat@(ConOpPatIn pat1 op _ pat2) pat_ty
- = tcConPat tc_bndr pat op [pat1, pat2] pat_ty
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Records}
-%* *
-%************************************************************************
-
-\begin{code}
-tcPat tc_bndr pat@(RecPatIn name rpats) pat_ty
- = tcAddErrCtxt (patCtxt pat) $
-
- -- Check the constructor itself
- tcConstructor pat name `thenTc` \ (data_con, lie_req1, ex_tvs, ex_dicts, lie_avail1, arg_tys, con_res_ty) ->
-
- -- Check overall type matches (c.f. tcConPat)
- tcSubPat con_res_ty pat_ty `thenTc` \ (co_fn, lie_req2) ->
- let
- -- Don't use zipEqual! If the constructor isn't really a record, then
- -- dataConFieldLabels will be empty (and each field in the pattern
- -- will generate an error below).
- field_tys = zip (map fieldLabelName (dataConFieldLabels data_con))
- arg_tys
- in
-
- -- Check the fields
- tc_fields field_tys rpats `thenTc` \ (rpats', lie_req3, tvs, ids, lie_avail2) ->
-
- returnTc (co_fn <$> RecPat data_con con_res_ty ex_tvs ex_dicts rpats',
- lie_req1 `plusLIE` lie_req2 `plusLIE` lie_req3,
- listToBag ex_tvs `unionBags` tvs,
- ids,
- lie_avail1 `plusLIE` lie_avail2)
-
- where
- tc_fields field_tys []
- = returnTc ([], emptyLIE, emptyBag, emptyBag, emptyLIE)
-
- tc_fields field_tys ((field_label, rhs_pat, pun_flag) : rpats)
- = tc_fields field_tys rpats `thenTc` \ (rpats', lie_req1, tvs1, ids1, lie_avail1) ->
+ -- Check that it's a constructor, and instantiate it
+ tcLookupDataCon con_name `thenM` \ data_con ->
+ tcInstDataCon (PatOrigin pat_in) data_con `thenM` \ (_, ex_dicts1, arg_tys, con_res_ty, ex_tvs) ->
- (case [ty | (f,ty) <- field_tys, f == field_label] of
-
- -- No matching field; chances are this field label comes from some
- -- other record type (or maybe none). As well as reporting an
- -- error we still want to typecheck the pattern, principally to
- -- make sure that all the variables it binds are put into the
- -- environment, else the type checker crashes later:
- -- f (R { foo = (a,b) }) = a+b
- -- If foo isn't one of R's fields, we don't want to crash when
- -- typechecking the "a+b".
- [] -> addErrTc (badFieldCon name field_label) `thenNF_Tc_`
- newTyVarTy liftedTypeKind `thenNF_Tc_`
- returnTc (error "Bogus selector Id", pat_ty)
-
- -- The normal case, when the field comes from the right constructor
- (pat_ty : extras) ->
- ASSERT( null extras )
- tcLookupGlobalId field_label `thenNF_Tc` \ sel_id ->
- returnTc (sel_id, pat_ty)
- ) `thenTc` \ (sel_id, pat_ty) ->
+ -- Check overall type matches.
+ -- The pat_ty might be a for-all type, in which
+ -- case we must instantiate to match
+ tcSubPat con_res_ty pat_ty `thenM` \ co_fn ->
- tcPat tc_bndr rhs_pat pat_ty `thenTc` \ (rhs_pat', lie_req2, tvs2, ids2, lie_avail2) ->
+ -- Check the argument patterns
+ tcConStuff tc_bndr data_con arg_pats arg_tys `thenM` \ (arg_pats', arg_tvs, arg_ids, ex_dicts2) ->
- returnTc ((sel_id, rhs_pat', pun_flag) : rpats',
- lie_req1 `plusLIE` lie_req2,
- tvs1 `unionBags` tvs2,
- ids1 `unionBags` ids2,
- lie_avail1 `plusLIE` lie_avail2)
+ returnM (co_fn <$> ConPatOut data_con arg_pats' con_res_ty ex_tvs (map instToId ex_dicts1),
+ listToBag ex_tvs `unionBags` arg_tvs,
+ arg_ids,
+ ex_dicts1 ++ ex_dicts2)
\end{code}
+
%************************************************************************
%* *
\subsection{Literals}
%************************************************************************
\begin{code}
-tcPat tc_bndr (LitPatIn lit@(HsLitLit s _)) pat_ty
+tcPat tc_bndr (LitPat lit@(HsLitLit s _)) pat_ty
-- cf tcExpr on LitLits
- = tcLookupClass cCallableClassName `thenNF_Tc` \ cCallableClass ->
+ = tcLookupClass cCallableClassName `thenM` \ cCallableClass ->
newDicts (LitLitOrigin (unpackFS s))
- [mkClassPred cCallableClass [pat_ty]] `thenNF_Tc` \ dicts ->
- returnTc (LitPat (HsLitLit s pat_ty) pat_ty, mkLIE dicts, emptyBag, emptyBag, emptyLIE)
+ [mkClassPred cCallableClass [pat_ty]] `thenM` \ dicts ->
+ extendLIEs dicts `thenM_`
+ returnM (LitPat (HsLitLit s pat_ty), emptyBag, emptyBag, [])
-tcPat tc_bndr pat@(LitPatIn lit@(HsString _)) pat_ty
- = unifyTauTy pat_ty stringTy `thenTc_`
- tcLookupGlobalId eqStringName `thenNF_Tc` \ eq_id ->
- returnTc (NPat lit stringTy (HsVar eq_id `HsApp` HsLit lit),
- emptyLIE, emptyBag, emptyBag, emptyLIE)
+tcPat tc_bndr pat@(LitPat lit@(HsString _)) pat_ty
+ = unifyTauTy pat_ty stringTy `thenM_`
+ tcLookupId eqStringName `thenM` \ eq_id ->
+ returnM (NPatOut lit stringTy (HsVar eq_id `HsApp` HsLit lit),
+ emptyBag, emptyBag, [])
-tcPat tc_bndr (LitPatIn simple_lit) pat_ty
- = unifyTauTy pat_ty (simpleHsLitTy simple_lit) `thenTc_`
- returnTc (LitPat simple_lit pat_ty, emptyLIE, emptyBag, emptyBag, emptyLIE)
+tcPat tc_bndr (LitPat simple_lit) pat_ty
+ = unifyTauTy pat_ty (hsLitType simple_lit) `thenM_`
+ returnM (LitPat simple_lit, emptyBag, emptyBag, [])
tcPat tc_bndr pat@(NPatIn over_lit mb_neg) pat_ty
- = newOverloadedLit origin over_lit pat_ty `thenNF_Tc` \ (pos_lit_expr, lie1) ->
- newMethodFromName origin pat_ty eqName `thenNF_Tc` \ eq ->
+ = newOverloadedLit origin over_lit pat_ty `thenM` \ pos_lit_expr ->
+ newMethodFromName origin pat_ty eqName `thenM` \ eq ->
(case mb_neg of
- Nothing -> returnNF_Tc (pos_lit_expr, emptyLIE) -- Positive literal
+ Nothing -> returnM pos_lit_expr -- Positive literal
Just neg -> -- Negative literal
-- The 'negate' is re-mappable syntax
- tcSyntaxName origin pat_ty negateName neg `thenTc` \ (neg_expr, neg_lie, _) ->
- returnNF_Tc (HsApp neg_expr pos_lit_expr, neg_lie)
- ) `thenNF_Tc` \ (lit_expr, lie2) ->
+ tcSyntaxName origin pat_ty negateName neg `thenM` \ (neg_expr, _) ->
+ returnM (HsApp neg_expr pos_lit_expr)
+ ) `thenM` \ lit_expr ->
- returnTc (NPat lit' pat_ty (HsApp (HsVar (instToId eq)) lit_expr),
- lie1 `plusLIE` lie2 `plusLIE` unitLIE eq,
- emptyBag, emptyBag, emptyLIE)
+ returnM (NPatOut lit' pat_ty (HsApp (HsVar eq) lit_expr),
+ emptyBag, emptyBag, [])
where
origin = PatOrigin pat
\begin{code}
tcPat tc_bndr pat@(NPlusKPatIn name lit@(HsIntegral i _) minus_name) pat_ty
- = tc_bndr name pat_ty `thenTc` \ (co_fn, lie1, bndr_id) ->
- newOverloadedLit origin lit pat_ty `thenNF_Tc` \ (over_lit_expr, lie2) ->
- newMethodFromName origin pat_ty geName `thenNF_Tc` \ ge ->
+ = tc_bndr name pat_ty `thenM` \ (co_fn, bndr_id) ->
+ newOverloadedLit origin lit pat_ty `thenM` \ over_lit_expr ->
+ newMethodFromName origin pat_ty geName `thenM` \ ge ->
-- The '-' part is re-mappable syntax
- tcSyntaxName origin pat_ty minusName minus_name `thenTc` \ (minus_expr, minus_lie, _) ->
+ tcSyntaxName origin pat_ty minusName minus_name `thenM` \ (minus_expr, _) ->
- returnTc (NPlusKPat bndr_id i pat_ty
- (SectionR (HsVar (instToId ge)) over_lit_expr)
- (SectionR minus_expr over_lit_expr),
- lie1 `plusLIE` lie2 `plusLIE` minus_lie `plusLIE` unitLIE ge,
- emptyBag, unitBag (name, bndr_id), emptyLIE)
+ returnM (NPlusKPatOut bndr_id i
+ (SectionR (HsVar ge) over_lit_expr)
+ (SectionR minus_expr over_lit_expr),
+ emptyBag, unitBag (name, bndr_id), [])
where
origin = PatOrigin pat
\end{code}
Helper functions
\begin{code}
-tcPats :: BinderChecker -- How to deal with variables
- -> [RenamedPat] -> [TcType] -- Excess 'expected types' discarded
+tcPats :: BinderChecker -- How to deal with variables
+ -> [RenamedPat] -> [TcType] -- Excess 'expected types' discarded
-> TcM ([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
+ [Inst]) -- Dicts bound by the pattern
-tcPats tc_bndr [] tys = returnTc ([], emptyLIE, emptyBag, emptyBag, emptyLIE)
+tcPats tc_bndr [] tys = returnM ([], emptyBag, emptyBag, [])
tcPats tc_bndr (ty:tys) (pat:pats)
- = tcPat tc_bndr ty pat `thenTc` \ (pat', lie_req1, tvs1, ids1, lie_avail1) ->
- tcPats tc_bndr tys pats `thenTc` \ (pats', lie_req2, tvs2, ids2, lie_avail2) ->
+ = tcPat tc_bndr ty pat `thenM` \ (pat', tvs1, ids1, lie_avail1) ->
+ tcPats tc_bndr tys pats `thenM` \ (pats', tvs2, ids2, lie_avail2) ->
- returnTc (pat':pats', lie_req1 `plusLIE` lie_req2,
+ returnM (pat':pats',
tvs1 `unionBags` tvs2, ids1 `unionBags` ids2,
- lie_avail1 `plusLIE` lie_avail2)
+ lie_avail1 ++ lie_avail2)
\end{code}
-------------------------------------------------------
-\begin{code}
-tcConstructor pat con_name
- = -- Check that it's a constructor
- tcLookupDataCon con_name `thenNF_Tc` \ data_con ->
-
- -- Instantiate it
- tcInstDataCon (PatOrigin pat) data_con `thenNF_Tc` \ (_, ex_dicts, arg_tys, result_ty, lie_req, ex_lie, ex_tvs) ->
- returnTc (data_con, lie_req, ex_tvs, ex_dicts, ex_lie, arg_tys, result_ty)
-\end{code}
+%************************************************************************
+%* *
+\subsection{Constructor arguments}
+%* *
+%************************************************************************
-------------------------------------------------------
\begin{code}
-tcConPat tc_bndr pat con_name arg_pats pat_ty
- = tcAddErrCtxt (patCtxt pat) $
+tcConStuff tc_bndr data_con (PrefixCon arg_pats) arg_tys
+ = -- Check correct arity
+ checkTc (con_arity == no_of_args)
+ (arityErr "Constructor" data_con con_arity no_of_args) `thenM_`
- -- Check the constructor itself
- tcConstructor pat con_name `thenTc` \ (data_con, lie_req1, ex_tvs, ex_dicts, lie_avail1, arg_tys, con_res_ty) ->
+ -- Check arguments
+ tcPats tc_bndr arg_pats arg_tys `thenM` \ (arg_pats', tvs, ids, lie_avail) ->
- -- Check overall type matches.
- -- The pat_ty might be a for-all type, in which
- -- case we must instantiate to match
- tcSubPat con_res_ty pat_ty `thenTc` \ (co_fn, lie_req2) ->
+ returnM (PrefixCon arg_pats', tvs, ids, lie_avail)
+ where
+ con_arity = dataConSourceArity data_con
+ no_of_args = length arg_pats
- -- Check correct arity
- let
- con_arity = dataConSourceArity data_con
- no_of_args = length arg_pats
- in
- checkTc (con_arity == no_of_args)
- (arityErr "Constructor" data_con con_arity no_of_args) `thenTc_`
+tcConStuff tc_bndr data_con (InfixCon p1 p2) arg_tys
+ = -- Check correct arity
+ checkTc (con_arity == 2)
+ (arityErr "Constructor" data_con con_arity 2) `thenM_`
-- Check arguments
- tcPats tc_bndr arg_pats arg_tys `thenTc` \ (arg_pats', lie_req3, tvs, ids, lie_avail2) ->
+ tcPat tc_bndr p1 ty1 `thenM` \ (p1', tvs1, ids1, lie_avail1) ->
+ tcPat tc_bndr p2 ty2 `thenM` \ (p2', tvs2, ids2, lie_avail2) ->
+
+ returnM (InfixCon p1' p2',
+ tvs1 `unionBags` tvs2, ids1 `unionBags` ids2,
+ lie_avail1 ++ lie_avail2)
+ where
+ con_arity = dataConSourceArity data_con
+ [ty1, ty2] = arg_tys
+
+tcConStuff tc_bndr data_con (RecCon rpats) arg_tys
+ = -- Check the fields
+ tc_fields field_tys rpats `thenM` \ (rpats', tvs, ids, lie_avail) ->
+ returnM (RecCon rpats', tvs, ids, lie_avail)
+
+ where
+ field_tys = zip (map fieldLabelName (dataConFieldLabels data_con)) arg_tys
+ -- Don't use zipEqual! If the constructor isn't really a record, then
+ -- dataConFieldLabels will be empty (and each field in the pattern
+ -- will generate an error below).
- returnTc (co_fn <$> ConPat data_con con_res_ty ex_tvs ex_dicts arg_pats',
- lie_req1 `plusLIE` lie_req2 `plusLIE` lie_req3,
- listToBag ex_tvs `unionBags` tvs,
- ids,
- lie_avail1 `plusLIE` lie_avail2)
+ tc_fields field_tys []
+ = returnM ([], emptyBag, emptyBag, [])
+
+ tc_fields field_tys ((field_label, rhs_pat) : rpats)
+ = tc_fields field_tys rpats `thenM` \ (rpats', tvs1, ids1, lie_avail1) ->
+
+ (case [ty | (f,ty) <- field_tys, f == field_label] of
+
+ -- No matching field; chances are this field label comes from some
+ -- other record type (or maybe none). As well as reporting an
+ -- error we still want to typecheck the pattern, principally to
+ -- make sure that all the variables it binds are put into the
+ -- environment, else the type checker crashes later:
+ -- f (R { foo = (a,b) }) = a+b
+ -- If foo isn't one of R's fields, we don't want to crash when
+ -- typechecking the "a+b".
+ [] -> addErrTc (badFieldCon data_con field_label) `thenM_`
+ newTyVarTy liftedTypeKind `thenM` \ bogus_ty ->
+ returnM (error "Bogus selector Id", bogus_ty)
+
+ -- The normal case, when the field comes from the right constructor
+ (pat_ty : extras) ->
+ ASSERT( null extras )
+ tcLookupId field_label `thenM` \ sel_id ->
+ returnM (sel_id, pat_ty)
+ ) `thenM` \ (sel_id, pat_ty) ->
+
+ tcPat tc_bndr rhs_pat pat_ty `thenM` \ (rhs_pat', tvs2, ids2, lie_avail2) ->
+
+ returnM ((sel_id, rhs_pat') : rpats',
+ tvs1 `unionBags` tvs2,
+ ids1 `unionBags` ids2,
+ lie_avail1 ++ lie_avail2)
\end{code}
(forall a. a->a in the example)
\begin{code}
-tcSubPat :: TcSigmaType -> TcHoleType -> TcM (PatCoFn, LIE)
+tcSubPat :: TcSigmaType -> TcHoleType -> TcM PatCoFn
tcSubPat sig_ty exp_ty
- = tcSubOff sig_ty exp_ty `thenTc` \ (co_fn, lie) ->
+ = tcSubOff sig_ty exp_ty `thenM` \ co_fn ->
-- co_fn is a coercion on *expressions*, and we
-- need to make a coercion on *patterns*
if isIdCoercion co_fn then
- ASSERT( isEmptyLIE lie )
- returnNF_Tc (idCoercion, emptyLIE)
+ returnM idCoercion
else
- tcGetUnique `thenNF_Tc` \ uniq ->
+ newUnique `thenM` \ uniq ->
let
arg_id = mkSysLocal FSLIT("sub") uniq exp_ty
the_fn = DictLam [arg_id] (co_fn <$> HsVar arg_id)
- pat_co_fn p = SigPat p exp_ty the_fn
+ pat_co_fn p = SigPatOut p exp_ty the_fn
in
- returnNF_Tc (mkCoercion pat_co_fn, lie)
+ returnM (mkCoercion pat_co_fn)
\end{code}
patCtxt pat = hang (ptext SLIT("When checking the pattern:"))
4 (ppr pat)
-badFieldCon :: Name -> Name -> SDoc
+badFieldCon :: DataCon -> Name -> SDoc
badFieldCon con field
= hsep [ptext SLIT("Constructor") <+> quotes (ppr con),
ptext SLIT("does not have field"), quotes (ppr field)]
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section[TcModule]{Typechecking a whole module}
+
+\begin{code}
+module TcRnDriver (
+#ifdef GHCI
+ mkGlobalContext, getModuleContents,
+#endif
+ tcRnModule, checkOldIface, importSupportingDecls,
+ tcRnIface, tcRnExtCore, tcRnStmt, tcRnExpr, tcRnThing
+ ) where
+
+#include "HsVersions.h"
+
+import CmdLineOpts ( DynFlag(..), opt_PprStyle_Debug, dopt )
+import HsSyn ( HsModule(..), HsBinds(..), MonoBinds(..), HsDecl(..), HsExpr(..),
+ Stmt(..), Pat(VarPat), HsMatchContext(..), HsDoContext(..), RuleDecl(..),
+ mkSimpleMatch, placeHolderType, toHsType, andMonoBinds,
+ isSrcRule
+ )
+import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameStmt, RdrNameHsExpr )
+
+import PrelNames ( iNTERACTIVE, ioTyConName, printName,
+ returnIOName, bindIOName, failIOName, thenIOName, runIOName,
+ dollarMainName, itName, mAIN_Name
+ )
+import MkId ( unsafeCoerceId )
+import RdrName ( RdrName, getRdrName, mkUnqual, mkRdrUnqual,
+ lookupRdrEnv, elemRdrEnv )
+
+import RnHsSyn ( RenamedHsDecl, RenamedStmt, RenamedTyClDecl,
+ ruleDeclFVs, instDeclFVs, tyClDeclFVs )
+import TcHsSyn ( TypecheckedHsExpr, TypecheckedRuleDecl,
+ zonkTopBinds, zonkTopDecls, mkHsLet,
+ zonkTopExpr, zonkIdBndr
+ )
+
+import TcExpr ( tcExpr_id )
+import TcRnMonad
+import TcMType ( newTyVarTy, zonkTcType )
+import TcType ( Type, liftedTypeKind,
+ tyVarsOfType, tcFunResultTy,
+ mkForAllTys, mkFunTys, mkTyConApp, tcSplitForAllTys
+ )
+import TcMatches ( tcStmtsAndThen )
+import Inst ( showLIE )
+import TcBinds ( tcTopBinds )
+import TcClassDcl ( tcClassDecls2 )
+import TcDefaults ( tcDefaults )
+import TcEnv ( RecTcGblEnv,
+ tcExtendGlobalValEnv,
+ tcExtendGlobalEnv,
+ tcExtendInstEnv, tcExtendRules,
+ tcLookupTyCon, tcLookupGlobal,
+ tcLookupId
+ )
+import TcRules ( tcRules )
+import TcForeign ( tcForeignImports, tcForeignExports )
+import TcIfaceSig ( tcInterfaceSigs, tcCoreBinds )
+import TcInstDcls ( tcInstDecls1, tcIfaceInstDecls, tcInstDecls2 )
+import TcSimplify ( tcSimplifyTop, tcSimplifyInfer )
+import TcTyClsDecls ( tcTyAndClassDecls )
+
+import RnNames ( rnImports, exportsFromAvail, reportUnusedNames )
+import RnIfaces ( slurpImpDecls, checkVersions, RecompileRequired, outOfDate )
+import RnHiFiles ( readIface, loadOldIface )
+import RnEnv ( lookupSrcName, lookupOccRn,
+ ubiquitousNames, implicitModuleFVs, implicitStmtFVs, dataTcOccs )
+import RnExpr ( rnStmts, rnExpr )
+import RnSource ( rnSrcDecls, rnExtCoreDecls, checkModDeprec, rnStats )
+
+import OccName ( varName )
+import CoreUnfold ( unfoldingTemplate )
+import CoreSyn ( IdCoreRule, Bind(..) )
+import PprCore ( pprIdRules, pprCoreBindings )
+import TysWiredIn ( mkListTy, unitTy )
+import ErrUtils ( mkDumpDoc, showPass )
+import Id ( Id, mkLocalId, isLocalId, idName, idType, idUnfolding, setIdLocalExported )
+import IdInfo ( GlobalIdDetails(..) )
+import Var ( Var, setGlobalIdDetails )
+import Module ( Module, moduleName, moduleUserString )
+import Name ( Name, isExternalName, getSrcLoc, nameOccName )
+import NameEnv ( delListFromNameEnv )
+import NameSet
+import TyCon ( tyConGenInfo )
+import BasicTypes ( EP(..), RecFlag(..) )
+import SrcLoc ( noSrcLoc )
+import Outputable
+import HscTypes ( PersistentCompilerState(..), InteractiveContext(..),
+ ModIface, ModDetails(..), ModGuts(..),
+ HscEnv(..),
+ ModIface(..), ModDetails(..), IfaceDecls(..),
+ GhciMode(..),
+ Deprecations(..), plusDeprecs,
+ emptyGlobalRdrEnv,
+ GenAvailInfo(Avail), availsToNameSet,
+ ForeignStubs(..),
+ TypeEnv, TyThing, typeEnvTyCons,
+ extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons,
+ extendLocalRdrEnv, emptyFixityEnv
+ )
+#ifdef GHCI
+import RdrName ( rdrEnvElts )
+import RnHiFiles ( loadInterface )
+import RnEnv ( mkGlobalRdrEnv, plusGlobalRdrEnv )
+import HscTypes ( GlobalRdrElt(..), GlobalRdrEnv, ImportReason(..), Provenance(..),
+ isLocalGRE )
+#endif
+
+import Maybe ( catMaybes )
+import Panic ( showException )
+import List ( partition )
+import Util ( sortLt )
+\end{code}
+
+
+
+%************************************************************************
+%* *
+ Typecheck and rename a module
+%* *
+%************************************************************************
+
+
+\begin{code}
+tcRnModule :: HscEnv -> PersistentCompilerState
+ -> RdrNameHsModule
+ -> IO (PersistentCompilerState, Maybe TcGblEnv)
+
+tcRnModule hsc_env pcs
+ (HsModule this_mod _ exports import_decls local_decls mod_deprec loc)
+ = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
+
+ initTc hsc_env pcs this_mod $ addSrcLoc loc $
+ do { -- Deal with imports; sets tcg_rdr_env, tcg_imports
+ (rdr_env, imports) <- rnImports import_decls ;
+ updGblEnv ( \ gbl -> gbl { tcg_rdr_env = rdr_env,
+ tcg_imports = imports })
+ $ do {
+ traceRn (text "rn1") ;
+ -- Fail if there are any errors so far
+ -- The error printing (if needed) takes advantage
+ -- of the tcg_env we have now set
+ failIfErrsM ;
+
+ traceRn (text "rn1a") ;
+ -- Rename and type check the declarations
+ (tcg_env, src_fvs) <- tcRnSrcDecls local_decls ;
+ setGblEnv tcg_env $ do {
+ traceRn (text "rn2") ;
+
+ -- Check for 'main'
+ (tcg_env, main_fvs) <- checkMain ;
+ setGblEnv tcg_env $ do {
+
+ traceRn (text "rn3") ;
+ -- Check whether the entire module is deprecated
+ -- This happens only once per module
+ -- Returns the full new deprecations; a module deprecation
+ -- over-rides the earlier ones
+ let { mod_deprecs = checkModDeprec mod_deprec } ;
+ updGblEnv (\gbl -> gbl { tcg_deprecs = tcg_deprecs gbl `plusDeprecs` mod_deprecs })
+ $ do {
+
+ traceRn (text "rn4") ;
+ -- Process the export list
+ export_avails <- exportsFromAvail exports ;
+ updGblEnv (\gbl -> gbl { tcg_exports = export_avails })
+ $ do {
+
+ -- Get the supporting decls for the exports
+ -- This is important *only* to gether usage information
+ -- (see comments with MkIface.mkImportInfo for why)
+ -- For OneShot compilation we could just throw away the decls
+ -- but for Batch or Interactive we must put them in the type
+ -- envt because they've been removed from the holding pen
+ let { export_fvs = availsToNameSet export_avails } ;
+ tcg_env <- importSupportingDecls export_fvs ;
+ setGblEnv tcg_env $ do {
+
+ -- Report unused names
+ let { used_fvs = src_fvs `plusFV` main_fvs `plusFV` export_fvs } ;
+ reportUnusedNames tcg_env used_fvs ;
+
+ -- Dump output and return
+ tcDump tcg_env ;
+ return tcg_env
+ }}}}}}}}
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Closing up the interface decls}
+%* *
+%*********************************************************
+
+Suppose we discover we don't need to recompile. Then we start from the
+IfaceDecls in the ModIface, and fluff them up by sucking in all the decls they need.
+
+\begin{code}
+tcRnIface :: HscEnv
+ -> PersistentCompilerState
+ -> ModIface -- Get the decls from here
+ -> IO (PersistentCompilerState, Maybe ModDetails)
+ -- Nothing <=> errors happened
+tcRnIface hsc_env pcs
+ (ModIface {mi_module = mod, mi_decls = iface_decls})
+ = initTc hsc_env pcs mod $ do {
+
+ -- Get the supporting decls, and typecheck them all together
+ -- so that any mutually recursive types are done right
+ extra_decls <- slurpImpDecls needed ;
+ env <- typecheckIfaceDecls (decls ++ extra_decls) ;
+
+ returnM (ModDetails { md_types = tcg_type_env env,
+ md_insts = tcg_insts env,
+ md_rules = hsCoreRules (tcg_rules env)
+ -- All the rules from an interface are of the IfaceRuleOut form
+ }) }
+ where
+ rule_decls = dcl_rules iface_decls
+ inst_decls = dcl_insts iface_decls
+ tycl_decls = dcl_tycl iface_decls
+ decls = map RuleD rule_decls ++
+ map InstD inst_decls ++
+ map TyClD tycl_decls
+ needed = unionManyNameSets (map ruleDeclFVs rule_decls) `unionNameSets`
+ unionManyNameSets (map instDeclFVs inst_decls) `unionNameSets`
+ unionManyNameSets (map tyClDeclFVs tycl_decls) `unionNameSets`
+ ubiquitousNames
+ -- Data type decls with record selectors,
+ -- which may appear in the decls, need unpackCString
+ -- and friends. It's easier to just grab them right now.
+
+hsCoreRules :: [TypecheckedRuleDecl] -> [IdCoreRule]
+-- All post-typechecking Iface rules have the form IfaceRuleOut
+hsCoreRules rules = [(id,rule) | IfaceRuleOut id rule <- rules]
+\end{code}
+
+
+%************************************************************************
+%* *
+ The interactive interface
+%* *
+%************************************************************************
+
+\begin{code}
+tcRnStmt :: HscEnv -> PersistentCompilerState
+ -> InteractiveContext
+ -> RdrNameStmt
+ -> IO (PersistentCompilerState,
+ Maybe (InteractiveContext, [Name], TypecheckedHsExpr))
+ -- The returned [Id] is the same as the input except for
+ -- ExprStmt, in which case the returned [Name] is [itName]
+
+tcRnStmt hsc_env pcs ictxt rdr_stmt
+ = initTc hsc_env pcs iNTERACTIVE $
+ setInteractiveContext ictxt $ do {
+
+ -- Rename; use CmdLineMode because tcRnStmt is only used interactively
+ ((bound_names, [rn_stmt]), fvs) <- initRnInteractive ictxt
+ (rnStmts [rdr_stmt]) ;
+ traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ;
+ failIfErrsM ;
+
+ -- Suck in the supporting declarations and typecheck them
+ tcg_env <- importSupportingDecls (fvs `plusFV` implicitStmtFVs fvs) ;
+ -- NB: an earlier version deleted (rdrEnvElts local_env) from
+ -- the fvs. But (a) that isn't necessary, because previously
+ -- bound things in the local_env will be in the TypeEnv, and
+ -- the renamer doesn't re-slurp such things, and
+ -- (b) it's WRONG to delete them. Consider in GHCi:
+ -- Mod> let x = e :: T
+ -- Mod> let y = x + 3
+ -- We need to pass 'x' among the fvs to slurpImpDecls, so that
+ -- the latter can see that T is a gate, and hence import the Num T
+ -- instance decl. (See the InTypEnv case in RnIfaces.slurpSourceRefs.)
+ setGblEnv tcg_env $ do {
+
+ -- The real work is done here
+ ((bound_ids, tc_expr), lie) <- getLIE (tcUserStmt bound_names rn_stmt) ;
+
+ traceTc (text "tcs 1") ;
+ let { -- Make all the bound ids "global" ids, now that
+ -- they're notionally top-level bindings. This is
+ -- important: otherwise when we come to compile an expression
+ -- using these ids later, the byte code generator will consider
+ -- the occurrences to be free rather than global.
+ global_ids = map globaliseId bound_ids ;
+ globaliseId id = setGlobalIdDetails id VanillaGlobal ;
+
+ -- Update the interactive context
+ rn_env = ic_rn_local_env ictxt ;
+ type_env = ic_type_env ictxt ;
+
+ bound_names = map idName global_ids ;
+ new_rn_env = extendLocalRdrEnv rn_env bound_names ;
+
+ -- Remove any shadowed bindings from the type_env;
+ -- they are inaccessible but might, I suppose, cause
+ -- a space leak if we leave them there
+ shadowed = [ n | name <- bound_names,
+ let rdr_name = mkRdrUnqual (nameOccName name),
+ Just n <- [lookupRdrEnv rn_env rdr_name] ] ;
+
+ filtered_type_env = delListFromNameEnv type_env shadowed ;
+ new_type_env = extendTypeEnvWithIds filtered_type_env global_ids ;
+
+ new_ic = ictxt { ic_rn_local_env = new_rn_env,
+ ic_type_env = new_type_env }
+ } ;
+
+ dumpOptTcRn Opt_D_dump_tc
+ (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,
+ text "Typechecked expr" <+> ppr tc_expr]) ;
+
+ returnM (new_ic, bound_names, tc_expr)
+ }}
+\end{code}
+
+
+Here is the grand plan, implemented in tcUserStmt
+
+ What you type The IO [HValue] that hscStmt returns
+ ------------- ------------------------------------
+ let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...]
+ bindings: [x,y,...]
+
+ pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
+ bindings: [x,y,...]
+
+ expr (of IO type) ==> expr >>= \ v -> return [coerce HVal v]
+ [NB: result not printed] bindings: [it]
+
+ expr (of non-IO type, ==> let v = expr in print v >> return [coerce HVal v]
+ result showable) bindings: [it]
+
+ expr (of non-IO type,
+ result not showable) ==> error
+
+
+\begin{code}
+---------------------------
+tcUserStmt :: [Name] -> RenamedStmt -> TcM ([Id], TypecheckedHsExpr)
+tcUserStmt names (ExprStmt expr _ loc)
+ = ASSERT( null names )
+ newUnique `thenM` \ uniq ->
+ let
+ fresh_it = itName uniq
+ the_bind = FunMonoBind fresh_it False
+ [ mkSimpleMatch [] expr placeHolderType loc ] loc
+ in
+ tryTc_ (do { -- Try this if the other fails
+ traceTc (text "tcs 1b") ;
+ tc_stmts [fresh_it] [
+ LetStmt (MonoBind the_bind [] NonRecursive),
+ ExprStmt (HsApp (HsVar printName) (HsVar fresh_it))
+ placeHolderType loc] })
+ (do { -- Try this first
+ traceTc (text "tcs 1a") ;
+ tc_stmts [fresh_it] [BindStmt (VarPat fresh_it) expr loc] })
+
+tcUserStmt names stmt
+ = tc_stmts names [stmt]
+
+---------------------------
+tc_stmts names stmts
+ = do { io_ids <- mappM tcLookupId
+ [returnIOName, failIOName, bindIOName, thenIOName] ;
+ ioTyCon <- tcLookupTyCon ioTyConName ;
+ res_ty <- newTyVarTy liftedTypeKind ;
+ let {
+ return_id = head io_ids ; -- Rather gruesome
+
+ io_ty = (\ ty -> mkTyConApp ioTyCon [ty], res_ty) ;
+
+ -- mk_return builds the expression
+ -- returnIO @ [()] [coerce () x, .., coerce () z]
+ mk_return ids = HsApp (TyApp (HsVar return_id) [mkListTy unitTy])
+ (ExplicitList unitTy (map mk_item ids)) ;
+
+ mk_item id = HsApp (TyApp (HsVar unsafeCoerceId) [idType id, unitTy])
+ (HsVar id) } ;
+
+ -- OK, we're ready to typecheck the stmts
+ traceTc (text "tcs 2") ;
+ ((ids, tc_stmts), lie) <-
+ getLIE $ tcStmtsAndThen combine (DoCtxt DoExpr) io_ty stmts $
+ do {
+ -- Look up the names right in the middle,
+ -- where they will all be in scope
+ ids <- mappM tcLookupId names ;
+ return (ids, [ResultStmt (mk_return ids) noSrcLoc])
+ } ;
+
+ -- Simplify the context right here, so that we fail
+ -- if there aren't enough instances. Notably, when we see
+ -- e
+ -- we use tryTc_ to try it <- e
+ -- and then let it = e
+ -- It's the simplify step that rejects the first.
+ traceTc (text "tcs 3") ;
+ const_binds <- tcSimplifyTop lie ;
+
+ -- Build result expression and zonk it
+ let { expr = mkHsLet const_binds $
+ HsDo DoExpr tc_stmts io_ids
+ (mkTyConApp ioTyCon [mkListTy unitTy]) noSrcLoc } ;
+ zonked_expr <- zonkTopExpr expr ;
+ zonked_ids <- mappM zonkIdBndr ids ;
+
+ return (zonked_ids, zonked_expr)
+ }
+ where
+ combine stmt (ids, stmts) = (ids, stmt:stmts)
+\end{code}
+
+
+tcRnExpr just finds the type of an expression
+
+\begin{code}
+tcRnExpr :: HscEnv -> PersistentCompilerState
+ -> InteractiveContext
+ -> RdrNameHsExpr
+ -> IO (PersistentCompilerState, Maybe Type)
+tcRnExpr hsc_env pcs ictxt rdr_expr
+ = initTc hsc_env pcs iNTERACTIVE $
+ setInteractiveContext ictxt $ do {
+
+ (rn_expr, fvs) <- initRnInteractive ictxt (rnExpr rdr_expr) ;
+ failIfErrsM ;
+
+ -- Suck in the supporting declarations and typecheck them
+ tcg_env <- importSupportingDecls (fvs `plusFV` ubiquitousNames) ;
+ setGblEnv tcg_env $ do {
+
+ -- Now typecheck the expression;
+ -- it might have a rank-2 type (e.g. :t runST)
+ -- Hence the hole type (c.f. TcExpr.tcExpr_id)
+ ((tc_expr, res_ty), lie) <- getLIE (tcExpr_id rn_expr) ;
+ ((qtvs, _, dict_ids), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie) ;
+ tcSimplifyTop lie_top ;
+
+ let { all_expr_ty = mkForAllTys qtvs $
+ mkFunTys (map idType dict_ids) $
+ res_ty } ;
+ zonkTcType all_expr_ty
+ }}
+ where
+ smpl_doc = ptext SLIT("main expression")
+\end{code}
+
+
+\begin{code}
+tcRnThing :: HscEnv -> PersistentCompilerState
+ -> InteractiveContext
+ -> RdrName
+ -> IO (PersistentCompilerState, Maybe [TyThing])
+-- Look up a RdrName and return all the TyThings it might be
+-- We treat a capitalised RdrName as both a data constructor
+-- and as a type or class constructor; hence we return up to two results
+tcRnThing hsc_env pcs ictxt rdr_name
+ = initTc hsc_env pcs iNTERACTIVE $
+ setInteractiveContext ictxt $ do {
+
+ -- If the identifier is a constructor (begins with an
+ -- upper-case letter), then we need to consider both
+ -- constructor and type class identifiers.
+ let { rdr_names = dataTcOccs rdr_name } ;
+
+ (msgs_s, mb_names) <- initRnInteractive ictxt
+ (mapAndUnzipM (tryM . lookupOccRn) rdr_names) ;
+ let { names = catMaybes mb_names } ;
+
+ if null names then
+ do { addMessages (head msgs_s) ; failM }
+ else do {
+
+ mapM_ addMessages msgs_s ; -- Add deprecation warnings
+ mapM tcLookupGlobal names -- and lookup up the entities
+ }}
+\end{code}
+
+
+\begin{code}
+setInteractiveContext :: InteractiveContext -> TcRn m a -> TcRn m a
+setInteractiveContext icxt thing_inside
+ = traceTc (text "setIC" <+> ppr (ic_type_env icxt)) `thenM_`
+ updGblEnv (\ env -> env { tcg_rdr_env = ic_rn_gbl_env icxt,
+ tcg_type_env = ic_type_env icxt })
+ thing_inside
+
+initRnInteractive :: InteractiveContext -> RnM a -> TcM a
+-- Set the local RdrEnv from the interactive context
+initRnInteractive ictxt rn_thing
+ = initRn CmdLineMode $
+ setLocalRdrEnv (ic_rn_local_env ictxt) $
+ rn_thing
+\end{code}
+
+%************************************************************************
+%* *
+ Type-checking external-core modules
+%* *
+%************************************************************************
+
+\begin{code}
+tcRnExtCore :: HscEnv -> PersistentCompilerState
+ -> RdrNameHsModule
+ -> IO (PersistentCompilerState, Maybe ModGuts)
+ -- Nothing => some error occurred
+
+tcRnExtCore hsc_env pcs
+ (HsModule this_mod _ _ _ local_decls _ loc)
+ -- Rename the (Core) module. It's a bit like an interface
+ -- file: all names are original names
+ = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
+
+ initTc hsc_env pcs this_mod $ addSrcLoc loc $ do {
+
+ -- Rename the source, only in interface mode.
+ -- rnSrcDecls handles fixity decls etc too, which won't occur
+ -- but that doesn't matter
+ (rn_local_decls, fvs) <- initRn (InterfaceMode this_mod)
+ (rnExtCoreDecls local_decls) ;
+ failIfErrsM ;
+
+ -- Get the supporting decls, and typecheck them all together
+ -- so that any mutually recursive types are done right
+ extra_decls <- slurpImpDecls fvs ;
+ tcg_env <- typecheckIfaceDecls (rn_local_decls ++ extra_decls) ;
+ setGblEnv tcg_env $ do {
+
+ -- Now the core bindings
+ core_prs <- tcCoreBinds [d | CoreD d <- rn_local_decls] ;
+ tcExtendGlobalValEnv (map fst core_prs) $ do {
+
+ -- Wrap up
+ let {
+ bndrs = map fst core_prs ;
+ my_exports = map (Avail . idName) bndrs ;
+ -- ToDo: export the data types also?
+
+ final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ;
+
+ mod_guts = ModGuts { mg_module = this_mod,
+ mg_usages = [], -- ToDo: compute usage
+ mg_dir_imps = [], -- ??
+ mg_exports = my_exports,
+ mg_types = final_type_env,
+ mg_insts = tcg_insts tcg_env,
+ mg_rules = hsCoreRules (tcg_rules tcg_env),
+ mg_binds = [Rec core_prs],
+
+ -- Stubs
+ mg_rdr_env = emptyGlobalRdrEnv,
+ mg_fix_env = emptyFixityEnv,
+ mg_deprecs = NoDeprecs,
+ mg_foreign = NoStubs
+ } } ;
+
+ tcCoreDump mod_guts ;
+
+ return mod_guts
+ }}}}
+\end{code}
+
+
+%************************************************************************
+%* *
+ Type-checking the top level of a module
+%* *
+%************************************************************************
+
+tcRnSrcDecls :: [RdrNameHsDecl] -> TcM (TcGblEnv, FreeVars)
+ -- Returns the variables free in the decls
+tcRnSrcDecls [] = getGblEnv
+tcRnSrcDecls ds
+ = do { let { (first_group, group_tail) = findSplice ds } ;
+
+ tcg_env <- tcRnGroup first_group ;
+
+ case group_tail of
+ Nothing -> return gbl_env
+ Just (splice_expr, rest_ds) -> do {
+
+ setGblEnv tcg_env $ do {
+
+ -- Rename the splice expression, and get its supporting decls
+ (rn_splice_expr, fvs) <- initRn SourceMode (rnExpr splice_expr) ;
+ tcg_env <- importSupportingDecls fvs ;
+ setGblEnv tcg_env $ do {
+
+ -- Execute the splice
+ spliced_decls <- tcSpliceDecls rn_splice_expr ;
+
+ -- Glue them on the front of the remaining decls and loop
+ tcRnSrcDeclsDecls (splice_decls ++ rest_ds)
+ }}}}
+
+findSplice :: [HsDecl a] -> ([HsDecl a], Maybe (HsExpr a, [HsDecl a]))
+findSplice [] = ([], Nothing)
+findSplice (SpliceD e : ds) = ([], Just (e, ds))
+findSplice (d : ds) = (d:gs, rest)
+ where
+ (gs, rest) = findSplice ds
+
+
+%************************************************************************
+%* *
+ Type-checking the top level of a module
+%* *
+%************************************************************************
+
+tcRnSrcDecls takes a bunch of top-level source-code declarations, and
+ * renames them
+ * gets supporting declarations from interface files
+ * typechecks them
+ * zonks them
+ * and augments the TcGblEnv with the results
+
+In Template Haskell it may be called repeatedly for each group of
+declarations. It expects there to be an incoming TcGblEnv in the
+monad; it augments it and returns the new TcGblEnv.
+
+\begin{code}
+tcRnSrcDecls :: [RdrNameHsDecl] -> TcM (TcGblEnv, FreeVars)
+ -- Returns the variables free in the decls
+tcRnSrcDecls decls
+ = do { -- Rename the declarations
+ (tcg_env, rn_decls, src_fvs) <- rnTopSrcDecls decls ;
+ setGblEnv tcg_env $ do {
+
+ -- Typecheck the declarations
+ tcg_env <- tcTopSrcDecls rn_decls ;
+ return (tcg_env, src_fvs)
+ }}
+
+------------------------------------------------
+rnTopSrcDecls :: [RdrNameHsDecl] -> TcM (TcGblEnv, [RenamedHsDecl], FreeVars)
+rnTopSrcDecls decls
+ = do { (tcg_env, rn_src_decls, src_fvs) <- initRn SourceMode (rnSrcDecls decls) ;
+ setGblEnv tcg_env $ do {
+
+ failIfErrsM ;
+
+ -- Import consquential imports
+ rn_imp_decls <- slurpImpDecls (src_fvs `plusFV` implicitModuleFVs src_fvs) ;
+ let { rn_decls = rn_src_decls ++ rn_imp_decls } ;
+
+ -- Dump trace of renaming part
+ rnDump (vcat (map ppr rn_decls)) ;
+ rnStats rn_imp_decls ;
+
+ return (tcg_env, rn_decls, src_fvs)
+ }}
+
+------------------------------------------------
+tcTopSrcDecls :: [RenamedHsDecl] -> TcM TcGblEnv
+tcTopSrcDecls rn_decls
+ = fixM (\ unf_env -> do {
+ -- Loop back the final environment, including the fully zonked
+ -- versions of bindings from this module. In the presence of mutual
+ -- recursion, interface type signatures may mention variables defined
+ -- in this module, which is why the knot is so big
+
+ -- Do the main work
+ ((tcg_env, binds, rules, fords), lie) <- getLIE (
+ tc_src_decls unf_env rn_decls
+ ) ;
+
+ -- tcSimplifyTop deals with constant or ambiguous InstIds.
+ -- How could there be ambiguous ones? They can only arise if a
+ -- top-level decl falls under the monomorphism
+ -- restriction, and no subsequent decl instantiates its
+ -- type. (Usually, ambiguous type variables are resolved
+ -- during the generalisation step.)
+ traceTc (text "Tc8") ;
+ inst_binds <- setGblEnv tcg_env (tcSimplifyTop lie) ;
+ -- The setGblEnv exposes the instances to tcSimplifyTop
+
+ -- Backsubstitution. This must be done last.
+ -- Even tcSimplifyTop may do some unification.
+ traceTc (text "Tc9") ;
+ (ids, binds', fords', rules') <- zonkTopDecls (binds `andMonoBinds` inst_binds)
+ rules fords ;
+
+ let { tcg_env' = tcg_env { tcg_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) ids,
+ tcg_binds = tcg_binds tcg_env `andMonoBinds` binds',
+ tcg_rules = tcg_rules tcg_env ++ rules',
+ tcg_fords = tcg_fords tcg_env ++ fords' } } ;
+
+ return tcg_env'
+ })
+
+tc_src_decls unf_env decls
+ = do { -- Type-check the type and class decls, and all imported decls
+ traceTc (text "Tc2") ;
+ tcg_env <- tcTyClDecls unf_env tycl_decls ;
+ setGblEnv tcg_env $ do {
+
+ -- Source-language instances, including derivings,
+ -- and import the supporting declarations
+ traceTc (text "Tc3") ;
+ (tcg_env, inst_infos, deriv_binds, fvs) <- tcInstDecls1 tycl_decls inst_decls ;
+ setGblEnv tcg_env $ do {
+ tcg_env <- importSupportingDecls fvs ;
+ setGblEnv tcg_env $ do {
+
+ -- Foreign import declarations next. No zonking necessary
+ -- here; we can tuck them straight into the global environment.
+ traceTc (text "Tc4") ;
+ (fi_ids, fi_decls) <- tcForeignImports decls ;
+ tcExtendGlobalValEnv fi_ids $
+ updGblEnv (\gbl -> gbl { tcg_fords = tcg_fords gbl ++ fi_decls })
+ $ do {
+
+ -- Default declarations
+ traceTc (text "Tc4a") ;
+ default_tys <- tcDefaults decls ;
+ updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
+
+ -- Value declarations next
+ -- We also typecheck any extra binds that came out
+ -- of the "deriving" process
+ traceTc (text "Tc5") ;
+ (tc_val_binds, lcl_env) <- tcTopBinds (val_binds `ThenBinds` deriv_binds) ;
+ setLclTypeEnv lcl_env $ do {
+
+ -- Second pass over class and instance declarations,
+ -- plus rules and foreign exports, to generate bindings
+ traceTc (text "Tc6") ;
+ (cls_dm_binds, dm_ids) <- tcClassDecls2 tycl_decls ;
+ tcExtendGlobalValEnv dm_ids $ do {
+ inst_binds <- tcInstDecls2 inst_infos ;
+ showLIE "after instDecls2" ;
+
+ -- Foreign exports
+ -- They need to be zonked, so we return them
+ traceTc (text "Tc7") ;
+ (foe_binds, foe_decls) <- tcForeignExports decls ;
+
+ -- Rules
+ -- Need to partition them because the source rules
+ -- must be zonked before adding them to tcg_rules
+ -- NB: built-in rules come in as IfaceRuleOut's, and
+ -- get added to tcg_rules right here by tcExtendRules
+ rules <- tcRules rule_decls ;
+ let { (src_rules, iface_rules) = partition isSrcRule rules } ;
+ tcExtendRules iface_rules $ do {
+
+ -- Wrap up
+ tcg_env <- getGblEnv ;
+ let { all_binds = tc_val_binds `AndMonoBinds`
+ inst_binds `AndMonoBinds`
+ cls_dm_binds `AndMonoBinds`
+ foe_binds } ;
+
+ return (tcg_env, all_binds, src_rules, foe_decls)
+ }}}}}}}}}
+ where
+ tycl_decls = [d | TyClD d <- decls]
+ rule_decls = [d | RuleD d <- decls]
+ inst_decls = [d | InstD d <- decls]
+ val_decls = [d | ValD d <- decls]
+ val_binds = foldr ThenBinds EmptyBinds val_decls
+\end{code}
+
+\begin{code}
+tcTyClDecls :: RecTcGblEnv
+ -> [RenamedTyClDecl]
+ -> TcM TcGblEnv
+
+-- tcTyClDecls deals with
+-- type and class decls (some source, some imported)
+-- interface signatures (checked lazily)
+--
+-- It returns the TcGblEnv for this module, and side-effects the
+-- persistent compiler state to reflect the things imported from
+-- other modules
+
+tcTyClDecls unf_env tycl_decls
+ -- (unf_env :: RecTcGblEnv) is used for type-checking interface pragmas
+ -- which is done lazily [ie failure just drops the pragma
+ -- without having any global-failure effect].
+
+ = checkNoErrs $
+ -- tcTyAndClassDecls recovers internally, but if anything gave rise to
+ -- an error we'd better stop now, to avoid a cascade
+
+ traceTc (text "TyCl1") `thenM_`
+ tcTyAndClassDecls tycl_decls `thenM` \ tycl_things ->
+ tcExtendGlobalEnv tycl_things $
+
+ -- Interface type signatures
+ -- We tie a knot so that the Ids read out of interfaces are in scope
+ -- when we read their pragmas.
+ -- What we rely on is that pragmas are typechecked lazily; if
+ -- any type errors are found (ie there's an inconsistency)
+ -- we silently discard the pragma
+ traceTc (text "TyCl2") `thenM_`
+ tcInterfaceSigs unf_env tycl_decls `thenM` \ sig_ids ->
+ tcExtendGlobalValEnv sig_ids $
+
+ getGblEnv -- Return the TcLocals environment
+\end{code}
+
+
+
+%************************************************************************
+%* *
+ Load the old interface file for this module (unless
+ we have it aleady), and check whether it is up to date
+
+%* *
+%************************************************************************
+
+\begin{code}
+checkOldIface :: HscEnv
+ -> PersistentCompilerState
+ -> Module
+ -> FilePath -- Where the interface file is
+ -> Bool -- Source unchanged
+ -> Maybe ModIface -- Old interface from compilation manager, if any
+ -> IO (PersistentCompilerState, Maybe (RecompileRequired, Maybe ModIface))
+ -- Nothing <=> errors happened
+
+checkOldIface hsc_env pcs mod iface_path source_unchanged maybe_iface
+ = do { showPass (hsc_dflags hsc_env)
+ ("Checking old interface for " ++ moduleUserString mod) ;
+
+ initTc hsc_env pcs mod
+ (check_old_iface iface_path source_unchanged maybe_iface)
+ }
+
+check_old_iface iface_path source_unchanged maybe_iface
+ = -- CHECK WHETHER THE SOURCE HAS CHANGED
+ ifM (not source_unchanged)
+ (traceHiDiffs (nest 4 (text "Source file changed or recompilation check turned off")))
+ `thenM_`
+
+ -- If the source has changed and we're in interactive mode, avoid reading
+ -- an interface; just return the one we might have been supplied with.
+ getGhciMode `thenM` \ ghci_mode ->
+ if (ghci_mode == Interactive) && not source_unchanged then
+ returnM (outOfDate, maybe_iface)
+ else
+
+ case maybe_iface of
+ Just old_iface -> -- Use the one we already have
+ checkVersions source_unchanged old_iface `thenM` \ recomp ->
+ returnM (recomp, Just old_iface)
+
+ Nothing -- Try and read it from a file
+ -> getModule `thenM` \ this_mod ->
+ readIface this_mod iface_path False `thenM` \ read_result ->
+ case read_result of
+ Left err -> -- Old interface file not found, or garbled; give up
+ traceHiDiffs (
+ text "Cannot read old interface file:"
+ $$ nest 4 (text (showException err))) `thenM_`
+ returnM (outOfDate, Nothing)
+
+ Right parsed_iface ->
+ initRn (InterfaceMode this_mod)
+ (loadOldIface parsed_iface) `thenM` \ m_iface ->
+ checkVersions source_unchanged m_iface `thenM` \ recomp ->
+ returnM (recomp, Just m_iface)
+\end{code}
+
+
+%************************************************************************
+%* *
+ Type-check and rename supporting declarations
+ This is used to deal with the free vars of a splice,
+ or derived code: slurp in the necessary declarations,
+ typecheck them, and add them to the EPS
+%* *
+%************************************************************************
+
+\begin{code}
+importSupportingDecls :: FreeVars -> TcM TcGblEnv
+-- Completely deal with the supporting imports needed
+-- by the specified free-var set
+importSupportingDecls fvs
+ = do { traceRn (text "Import supporting decls for" <+> ppr (nameSetToList fvs)) ;
+ decls <- slurpImpDecls fvs ;
+ traceRn (text "...namely:" <+> vcat (map ppr decls)) ;
+ typecheckIfaceDecls decls }
+
+typecheckIfaceDecls :: [RenamedHsDecl] -> TcM TcGblEnv
+ -- The decls are all interface-file declarations
+ -- Usually they are all from other modules, but when we are reading
+ -- this module's interface from a file, it's possible that some of
+ -- them are for the module being compiled.
+ -- That is why the tcExtendX functions need to do partitioning.
+ --
+ -- If all the decls are from other modules, the returned TcGblEnv
+ -- will have an empty tc_genv, but its tc_inst_env and tc_ist
+ -- caches may have been augmented.
+typecheckIfaceDecls decls
+ = do { let { tycl_decls = [d | TyClD d <- decls] ;
+ inst_decls = [d | InstD d <- decls] ;
+ rule_decls = [d | RuleD d <- decls] } ;
+
+ -- Typecheck the type, class, and interface-sig decls
+ tcg_env <- fixM (\ unf_env -> tcTyClDecls unf_env tycl_decls) ;
+ setGblEnv tcg_env $ do {
+
+ -- Typecheck the instance decls, and rules
+ -- Note that imported dictionary functions are already
+ -- in scope from the preceding tcTyClDecls
+ tcIfaceInstDecls inst_decls `thenM` \ dfuns ->
+ tcExtendInstEnv dfuns $
+ tcRules rule_decls `thenM` \ rules ->
+ tcExtendRules rules $
+
+ getGblEnv -- Return the environment
+ }}
+\end{code}
+
+
+
+%*********************************************************
+%* *
+ mkGlobalContext: make up an interactive context
+
+ Used for initialising the lexical environment
+ of the interactive read-eval-print loop
+%* *
+%*********************************************************
+
+\begin{code}
+#ifdef GHCI
+mkGlobalContext
+ :: HscEnv -> PersistentCompilerState
+ -> [Module] -- Expose these modules' top-level scope
+ -> [Module] -- Expose these modules' exports only
+ -> IO (PersistentCompilerState, Maybe GlobalRdrEnv)
+
+mkGlobalContext hsc_env pcs toplevs exports
+ = initTc hsc_env pcs iNTERACTIVE $ do {
+
+ toplev_envs <- mappM getTopLevScope toplevs ;
+ export_envs <- mappM getModuleExports exports ;
+ returnM (foldr plusGlobalRdrEnv emptyGlobalRdrEnv
+ (toplev_envs ++ export_envs))
+ }
+
+getTopLevScope :: Module -> TcRn m GlobalRdrEnv
+getTopLevScope mod
+ = do { iface <- loadInterface contextDoc (moduleName mod) (ImportByUser False) ;
+ case mi_globals iface of
+ Nothing -> panic "getTopLevScope"
+ Just env -> returnM env }
+
+getModuleExports :: Module -> TcRn m GlobalRdrEnv
+getModuleExports mod
+ = do { iface <- loadInterface contextDoc (moduleName mod) (ImportByUser False) ;
+ returnM (foldl add emptyGlobalRdrEnv (mi_exports iface)) }
+ where
+ prov_fn n = NonLocalDef ImplicitImport
+ add env (mod,avails)
+ = plusGlobalRdrEnv env (mkGlobalRdrEnv mod True prov_fn avails NoDeprecs)
+
+contextDoc = text "context for compiling statements"
+\end{code}
+
+\begin{code}
+getModuleContents
+ :: HscEnv
+ -> PersistentCompilerState -- IN: persistent compiler state
+ -> Module -- module to inspect
+ -> Bool -- grab just the exports, or the whole toplev
+ -> IO (PersistentCompilerState, Maybe [TyThing])
+
+getModuleContents hsc_env pcs mod exports_only
+ = initTc hsc_env pcs iNTERACTIVE $ do {
+
+ -- Load the interface if necessary (a home module will certainly
+ -- alraedy be loaded, but a package module might not be)
+ iface <- loadInterface contextDoc (moduleName mod) (ImportByUser False) ;
+
+ let { export_names = availsToNameSet export_avails ;
+ export_avails = [ avail | (mn, avails) <- mi_exports iface,
+ avail <- avails ] } ;
+
+ all_names <- if exports_only then
+ return export_names
+ else case mi_globals iface of {
+ Just rdr_env ->
+ return (get_locals rdr_env) ;
+
+ Nothing -> do { addErr (noRdrEnvErr mod) ;
+ return export_names } } ;
+ -- Invariant; we only have (not exports_only)
+ -- for a home module so it must already be in the HIT
+ -- So the Nothing case is a bug
+
+ env <- importSupportingDecls all_names ;
+ setGblEnv env (mappM tcLookupGlobal (nameSetToList all_names))
+ }
+ where
+ -- Grab all the things from the global env that are locally def'd
+ get_locals rdr_env = mkNameSet [ gre_name gre
+ | elts <- rdrEnvElts rdr_env,
+ gre <- elts,
+ isLocalGRE gre ]
+ -- Make a set because a name is often in the envt in
+ -- both qualified and unqualified forms
+
+noRdrEnvErr mod = ptext SLIT("No top-level environment available for module")
+ <+> quotes (ppr mod)
+#endif
+\end{code}
+
+%************************************************************************
+%* *
+ Checking for 'main'
+%* *
+%************************************************************************
+
+\begin{code}
+checkMain
+ = do { ghci_mode <- getGhciMode ;
+ tcg_env <- getGblEnv ;
+ check_main ghci_mode tcg_env
+ }
+
+check_main ghci_mode tcg_env
+ -- If we are in module Main, check that 'main' is defined.
+ -- It may be imported from another module, in which case
+ -- we have to drag in its.
+ --
+ -- Also form the definition
+ -- $main = runIO main
+ -- so we need to slurp in runIO too.
+ --
+ -- ToDo: We have to return the main_name separately, because it's a
+ -- bona fide 'use', and should be recorded as such, but the others
+ -- aren't
+ --
+ -- Blimey: a whole page of code to do this...
+
+ | mod_name /= mAIN_Name
+ = return (tcg_env, emptyFVs)
+
+ | not (main_RDR_Unqual `elemRdrEnv` rdr_env)
+ = do { complain_no_main; return (tcg_env, emptyFVs) }
+
+ | otherwise
+ = do { -- Check that 'main' is in scope
+ -- It might be imported from another module!
+ main_name <- lookupSrcName main_RDR_Unqual ;
+ failIfErrsM ;
+
+ tcg_env <- importSupportingDecls (unitFV runIOName) ;
+ setGblEnv tcg_env $ do {
+
+ -- $main :: IO () = runIO main
+ let { rhs = HsApp (HsVar runIOName) (HsVar main_name) } ;
+
+ (main_bind, top_lie) <- getLIE (
+ addSrcLoc (getSrcLoc main_name) $
+ addErrCtxt mainCtxt $ do {
+ (main_expr, ty) <- tcExpr_id rhs ;
+ let { dollar_main_id = setIdLocalExported (mkLocalId dollarMainName ty) } ;
+ return (VarMonoBind dollar_main_id main_expr)
+ }) ;
+
+ inst_binds <- tcSimplifyTop top_lie ;
+
+ (ids, binds') <- zonkTopBinds (main_bind `andMonoBinds` inst_binds) ;
+
+ let { tcg_env' = tcg_env {
+ tcg_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) ids,
+ tcg_binds = tcg_binds tcg_env `andMonoBinds` binds' } } ;
+
+ return (tcg_env', unitFV main_name)
+ }}
+ where
+ mod_name = moduleName (tcg_mod tcg_env)
+ rdr_env = tcg_rdr_env tcg_env
+
+ main_RDR_Unqual :: RdrName
+ main_RDR_Unqual = mkUnqual varName FSLIT("main")
+ -- Don't get a RdrName from PrelNames.mainName, because
+ -- nameRdrNamegets an Orig RdrName, and we want a Qual or Unqual one.
+ -- An Unqual one will do just fine
+
+ complain_no_main | ghci_mode == Interactive = return ()
+ | otherwise = addErr noMainMsg
+ -- In interactive mode, don't worry about the absence of 'main'
+
+ mainCtxt = ptext SLIT("When checking the type of 'main'")
+ noMainMsg = ptext SLIT("No 'main' defined in module Main")
+\end{code}
+
+
+%************************************************************************
+%* *
+ Degugging output
+%* *
+%************************************************************************
+
+\begin{code}
+rnDump :: SDoc -> TcRn m ()
+-- Dump, with a banner, if -ddump-rn
+rnDump doc = dumpOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" doc)
+
+tcDump :: TcGblEnv -> TcRn m ()
+tcDump env
+ = do { dflags <- getDOpts ;
+
+ -- Dump short output if -ddump-types or -ddump-tc
+ ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
+ (dumpTcRn short_dump) ;
+
+ -- Dump bindings if -ddump-tc
+ dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump)
+ }
+ where
+ short_dump = pprTcGblEnv env
+ full_dump = ppr (tcg_binds env)
+ -- NB: foreign x-d's have undefined's in their types;
+ -- hence can't show the tc_fords
+
+tcCoreDump mod_guts
+ = do { dflags <- getDOpts ;
+ ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
+ (dumpTcRn (pprModGuts mod_guts)) ;
+
+ -- Dump bindings if -ddump-tc
+ dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) }
+ where
+ full_dump = pprCoreBindings (mg_binds mod_guts)
+
+-- It's unpleasant having both pprModGuts and pprModDetails here
+pprTcGblEnv :: TcGblEnv -> SDoc
+pprTcGblEnv (TcGblEnv { tcg_type_env = type_env,
+ tcg_insts = dfun_ids,
+ tcg_rules = rules })
+ = vcat [ ppr_types dfun_ids type_env
+ , ppr_insts dfun_ids
+ , vcat (map ppr rules)
+ , ppr_gen_tycons (typeEnvTyCons type_env)]
+
+pprModGuts :: ModGuts -> SDoc
+pprModGuts (ModGuts { mg_types = type_env,
+ mg_rules = rules })
+ = vcat [ ppr_types [] type_env,
+ ppr_rules rules ]
+
+
+ppr_types :: [Var] -> TypeEnv -> SDoc
+ppr_types dfun_ids type_env
+ = text "TYPE SIGNATURES" $$ nest 4 (ppr_sigs ids)
+ where
+ ids = [id | id <- typeEnvIds type_env, want_sig id]
+ want_sig id | opt_PprStyle_Debug = True
+ | otherwise = isLocalId id &&
+ isExternalName (idName id) &&
+ not (id `elem` dfun_ids)
+ -- isLocalId ignores data constructors, records selectors etc.
+ -- The isExternalName ignores local dictionary and method bindings
+ -- that the type checker has invented. Top-level user-defined things
+ -- have External names.
+
+ppr_insts :: [Var] -> SDoc
+ppr_insts [] = empty
+ppr_insts dfun_ids = text "INSTANCES" $$ nest 4 (ppr_sigs dfun_ids)
+
+ppr_sigs :: [Var] -> SDoc
+ppr_sigs ids
+ -- Print type signatures
+ -- Convert to HsType so that we get source-language style printing
+ -- And sort by RdrName
+ = vcat $ map ppr_sig $ sortLt lt_sig $
+ [ (getRdrName id, toHsType (idType id))
+ | id <- ids ]
+ where
+ lt_sig (n1,_) (n2,_) = n1 < n2
+ ppr_sig (n,t) = ppr n <+> dcolon <+> ppr t
+
+
+ppr_rules :: [IdCoreRule] -> SDoc
+ppr_rules [] = empty
+ppr_rules rs = vcat [ptext SLIT("{-# RULES"),
+ nest 4 (pprIdRules rs),
+ ptext SLIT("#-}")]
+
+ppr_gen_tycons [] = empty
+ppr_gen_tycons tcs = vcat [ptext SLIT("{-# Generic type constructor details"),
+ vcat (map ppr_gen_tycon tcs),
+ ptext SLIT("#-}")
+ ]
+
+-- x&y are now Id's, not CoreExpr's
+ppr_gen_tycon tycon
+ | Just ep <- tyConGenInfo tycon
+ = (ppr tycon <> colon) $$ nest 4 (ppr_ep ep)
+
+ | otherwise = ppr tycon <> colon <+> ptext SLIT("Not derivable")
+
+ppr_ep (EP from to)
+ = vcat [ ptext SLIT("Rep type:") <+> ppr (tcFunResultTy from_tau),
+ ptext SLIT("From:") <+> ppr (unfoldingTemplate (idUnfolding from)),
+ ptext SLIT("To:") <+> ppr (unfoldingTemplate (idUnfolding to))
+ ]
+ where
+ (_,from_tau) = tcSplitForAllTys (idType from)
+\end{code}
--- /dev/null
+\begin{code}
+module TcRnMonad(
+ module TcRnMonad,
+ module TcRnTypes
+ ) where
+
+#include "HsVersions.h"
+
+import HsSyn ( MonoBinds(..) )
+import HscTypes ( HscEnv(..), PersistentCompilerState(..),
+ emptyFixityEnv, emptyGlobalRdrEnv, TyThing,
+ ExternalPackageState(..), HomePackageTable,
+ ModDetails(..), HomeModInfo(..), Deprecations(..),
+ GlobalRdrEnv, LocalRdrEnv, NameCache, FixityEnv,
+ GhciMode, lookupType, unQualInScope )
+import TcRnTypes
+import Module ( Module, foldModuleEnv )
+import Name ( Name, isInternalName )
+import Type ( Type )
+import NameEnv ( extendNameEnvList )
+import InstEnv ( InstEnv, extendInstEnv )
+import TysWiredIn ( integerTy, doubleTy )
+
+import VarSet ( emptyVarSet )
+import VarEnv ( TidyEnv, emptyTidyEnv )
+import RdrName ( emptyRdrEnv )
+import ErrUtils ( Message, Messages, emptyMessages, errorsFound,
+ addShortErrLocLine, addShortWarnLocLine, printErrorsAndWarnings )
+import SrcLoc ( SrcLoc, noSrcLoc )
+import NameEnv ( emptyNameEnv )
+import Bag ( emptyBag )
+import Outputable
+import UniqSupply ( UniqSupply, mkSplitUniqSupply, uniqFromSupply, splitUniqSupply )
+import Unique ( Unique )
+import CmdLineOpts ( DynFlags, DynFlag(..), dopt, opt_PprStyle_Debug )
+import BasicTypes ( FixitySig )
+import Bag ( snocBag, unionBags )
+
+import Maybe ( isJust )
+import IO ( stderr )
+import DATA_IOREF ( newIORef, readIORef )
+\end{code}
+
+%************************************************************************
+%* *
+ Standard combinators, but specialised for this monad
+ (for efficiency)
+%* *
+6%************************************************************************
+
+\begin{code}
+mappM :: (a -> TcRn m b) -> [a] -> TcRn m [b]
+mappM_ :: (a -> TcRn m b) -> [a] -> TcRn m ()
+ -- Funny names to avoid clash with Prelude
+sequenceM :: [TcRn m a] -> TcRn m [a]
+foldlM :: (a -> b -> TcRn m a) -> a -> [b] -> TcRn m a
+mapAndUnzipM :: (a -> TcRn m (b,c)) -> [a] -> TcRn m ([b],[c])
+mapAndUnzip3M :: (a -> TcRn m (b,c,d)) -> [a] -> TcRn m ([b],[c],[d])
+checkM :: Bool -> TcRn m () -> TcRn m () -- Perform arg if bool is False
+ifM :: Bool -> TcRn m () -> TcRn m () -- Perform arg if bool is True
+
+mappM f [] = return []
+mappM f (x:xs) = do { r <- f x; rs <- mappM f xs; return (r:rs) }
+
+mappM_ f [] = return ()
+mappM_ f (x:xs) = f x >> mappM_ f xs
+
+sequenceM [] = return []
+sequenceM (x:xs) = do { r <- x; rs <- sequenceM xs; return (r:rs) }
+
+foldlM k z [] = return z
+foldlM k z (x:xs) = do { r <- k z x; foldlM k r xs }
+
+mapAndUnzipM f [] = return ([],[])
+mapAndUnzipM f (x:xs) = do { (r,s) <- f x;
+ (rs,ss) <- mapAndUnzipM f xs;
+ return (r:rs, s:ss) }
+
+mapAndUnzip3M f [] = return ([],[], [])
+mapAndUnzip3M f (x:xs) = do { (r,s,t) <- f x;
+ (rs,ss,ts) <- mapAndUnzip3M f xs;
+ return (r:rs, s:ss, t:ts) }
+
+checkM True err = return ()
+checkM False err = err
+
+ifM True do_it = do_it
+ifM False do_it = return ()
+\end{code}
+
+
+%************************************************************************
+%* *
+ initTc
+%* *
+%************************************************************************
+
+\begin{code}
+initTc :: HscEnv -> PersistentCompilerState
+ -> Module
+ -> TcM r
+ -> IO (PersistentCompilerState, Maybe r)
+ -- Nothing => error thrown by the thing inside
+ -- (error messages should have been printed already)
+
+initTc (HscEnv { hsc_mode = ghci_mode,
+ hsc_HPT = hpt,
+ hsc_dflags = dflags })
+ pcs mod do_this
+ = do { us <- mkSplitUniqSupply 'a' ;
+ us_var <- newIORef us ;
+ errs_var <- newIORef (emptyBag, emptyBag) ;
+ tvs_var <- newIORef emptyVarSet ;
+ usg_var <- newIORef emptyUsages ;
+ nc_var <- newIORef (pcs_nc pcs) ;
+ eps_var <- newIORef eps ;
+
+ let {
+ env = Env { env_top = top_env,
+ env_gbl = gbl_env,
+ env_lcl = lcl_env,
+ env_loc = noSrcLoc } ;
+
+ top_env = TopEnv {
+ top_mode = ghci_mode,
+ top_dflags = dflags,
+ top_eps = eps_var,
+ top_hpt = hpt,
+ top_nc = nc_var,
+ top_us = us_var,
+ top_errs = errs_var } ;
+
+ gbl_env = TcGblEnv {
+ tcg_mod = mod,
+ tcg_usages = usg_var,
+ tcg_rdr_env = emptyGlobalRdrEnv,
+ tcg_fix_env = emptyFixityEnv,
+ tcg_default = defaultDefaultTys,
+ tcg_type_env = emptyNameEnv,
+ tcg_ist = mkImpTypeEnv eps hpt,
+ tcg_inst_env = mkImpInstEnv dflags eps hpt,
+ tcg_exports = [],
+ tcg_imports = emptyImportAvails,
+ tcg_binds = EmptyMonoBinds,
+ tcg_deprecs = NoDeprecs,
+ tcg_insts = [],
+ tcg_rules = [],
+ tcg_fords = [] } ;
+
+ lcl_env = TcLclEnv {
+ tcl_ctxt = [],
+ tcl_level = topStage,
+ tcl_env = emptyNameEnv,
+ tcl_tyvars = tvs_var,
+ tcl_lie = panic "initTc:LIE" } ;
+ -- LIE only valid inside a getLIE
+ } ;
+
+ -- OK, here's the business end!
+ maybe_res <- catch (do { res <- runTcRn env do_this ;
+ return (Just res) })
+ (\_ -> return Nothing) ;
+
+ -- Print any error messages
+ msgs <- readIORef errs_var ;
+ printErrorsAndWarnings msgs ;
+
+ -- Get final PCS and return
+ eps' <- readIORef eps_var ;
+ nc' <- readIORef nc_var ;
+ let { pcs' = PCS { pcs_EPS = eps', pcs_nc = nc' } ;
+ final_res | errorsFound msgs = Nothing
+ | otherwise = maybe_res } ;
+
+ return (pcs', final_res)
+ }
+ where
+ eps = pcs_EPS pcs
+
+defaultDefaultTys :: [Type]
+defaultDefaultTys = [integerTy, doubleTy]
+
+mkImpInstEnv :: DynFlags -> ExternalPackageState -> HomePackageTable -> InstEnv
+mkImpInstEnv dflags eps hpt
+ = foldModuleEnv (add . md_insts . hm_details)
+ (eps_inst_env eps)
+ hpt
+ where
+ -- We shouldn't get instance conflict errors from
+ -- the package and home type envs
+ add dfuns inst_env = WARN( not (null errs), vcat errs ) inst_env'
+ where
+ (inst_env', errs) = extendInstEnv dflags inst_env dfuns
+
+-- mkImpTypeEnv makes the imported symbol table
+mkImpTypeEnv :: ExternalPackageState -> HomePackageTable
+ -> Name -> Maybe TyThing
+mkImpTypeEnv pcs hpt = lookup
+ where
+ pte = eps_PTE pcs
+ lookup name | isInternalName name = Nothing
+ | otherwise = lookupType hpt pte name
+\end{code}
+
+
+%************************************************************************
+%* *
+ Simple accessors
+%* *
+%************************************************************************
+
+\begin{code}
+getTopEnv :: TcRn m TopEnv
+getTopEnv = do { env <- getEnv; return (env_top env) }
+
+getGblEnv :: TcRn m TcGblEnv
+getGblEnv = do { env <- getEnv; return (env_gbl env) }
+
+updGblEnv :: (TcGblEnv -> TcGblEnv) -> TcRn m a -> TcRn m a
+updGblEnv upd = updEnv (\ env@(Env { env_gbl = gbl }) ->
+ env { env_gbl = upd gbl })
+
+setGblEnv :: TcGblEnv -> TcRn m a -> TcRn m a
+setGblEnv gbl_env = updEnv (\ env -> env { env_gbl = gbl_env })
+
+getLclEnv :: TcRn m m
+getLclEnv = do { env <- getEnv; return (env_lcl env) }
+
+updLclEnv :: (m -> m) -> TcRn m a -> TcRn m a
+updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) ->
+ env { env_lcl = upd lcl })
+
+setLclEnv :: m -> TcRn m a -> TcRn n a
+setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env })
+\end{code}
+
+Command-line flags
+
+\begin{code}
+getDOpts :: TcRn m DynFlags
+getDOpts = do { env <- getTopEnv; return (top_dflags env) }
+
+doptM :: DynFlag -> TcRn m Bool
+doptM flag = do { dflags <- getDOpts; return (dopt flag dflags) }
+
+ifOptM :: DynFlag -> TcRn m () -> TcRn m () -- Do it flag is true
+ifOptM flag thing_inside = do { b <- doptM flag;
+ if b then thing_inside else return () }
+
+getGhciMode :: TcRn m GhciMode
+getGhciMode = do { env <- getTopEnv; return (top_mode env) }
+\end{code}
+
+\begin{code}
+getSrcLocM :: TcRn m SrcLoc
+ -- Avoid clash with Name.getSrcLoc
+getSrcLocM = do { env <- getEnv; return (env_loc env) }
+
+addSrcLoc :: SrcLoc -> TcRn m a -> TcRn m a
+addSrcLoc loc = updEnv (\env -> env { env_loc = loc })
+\end{code}
+
+\begin{code}
+getEps :: TcRn m ExternalPackageState
+getEps = do { env <- getTopEnv; readMutVar (top_eps env) }
+
+setEps :: ExternalPackageState -> TcRn m ()
+setEps eps = do { env <- getTopEnv; writeMutVar (top_eps env) eps }
+
+getHpt :: TcRn m HomePackageTable
+getHpt = do { env <- getTopEnv; return (top_hpt env) }
+
+getModule :: TcRn m Module
+getModule = do { env <- getGblEnv; return (tcg_mod env) }
+
+getGlobalRdrEnv :: TcRn m GlobalRdrEnv
+getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) }
+
+getFixityEnv :: TcRn m FixityEnv
+getFixityEnv = do { env <- getGblEnv; return (tcg_fix_env env) }
+
+extendFixityEnv :: [(Name,FixitySig Name)] -> RnM a -> RnM a
+extendFixityEnv new_bit
+ = updGblEnv (\env@(TcGblEnv { tcg_fix_env = old_fix_env }) ->
+ env {tcg_fix_env = extendNameEnvList old_fix_env new_bit})
+
+getDefaultTys :: TcRn m [Type]
+getDefaultTys = do { env <- getGblEnv; return (tcg_default env) }
+\end{code}
+
+\begin{code}
+getUsageVar :: TcRn m (TcRef Usages)
+getUsageVar = do { env <- getGblEnv; return (tcg_usages env) }
+
+getUsages :: TcRn m Usages
+getUsages = do { usg_var <- getUsageVar; readMutVar usg_var }
+
+updUsages :: (Usages -> Usages) -> TcRn m ()
+updUsages upd = do { usg_var <- getUsageVar ;
+ usg <- readMutVar usg_var ;
+ writeMutVar usg_var (upd usg) }
+\end{code}
+
+
+%************************************************************************
+%* *
+ Error management
+%* *
+%************************************************************************
+
+\begin{code}
+getErrsVar :: TcRn m (TcRef Messages)
+getErrsVar = do { env <- getTopEnv; return (top_errs env) }
+
+setErrsVar :: TcRef Messages -> TcRn m a -> TcRn m a
+setErrsVar v = updEnv (\ env@(Env { env_top = top_env }) ->
+ env { env_top = top_env { top_errs = v }})
+
+addErr :: Message -> TcRn m ()
+addErr msg = do { loc <- getSrcLocM ; add_err loc msg }
+
+add_err :: SrcLoc -> Message -> TcRn m ()
+add_err loc msg
+ = do { errs_var <- getErrsVar ;
+ rdr_env <- getGlobalRdrEnv ;
+ let { err = addShortErrLocLine loc (unQualInScope rdr_env) msg } ;
+ (warns, errs) <- readMutVar errs_var ;
+ writeMutVar errs_var (warns, errs `snocBag` err) }
+
+addErrs :: [Message] -> TcRn m ()
+addErrs msgs = mappM_ addErr msgs
+
+addWarn :: Message -> TcRn m ()
+addWarn msg
+ = do { errs_var <- getErrsVar ;
+ loc <- getSrcLocM ;
+ rdr_env <- getGlobalRdrEnv ;
+ let { warn = addShortWarnLocLine loc (unQualInScope rdr_env) msg } ;
+ (warns, errs) <- readMutVar errs_var ;
+ writeMutVar errs_var (warns `snocBag` warn, errs) }
+
+checkErr :: Bool -> Message -> TcRn m ()
+-- Add the error if the bool is False
+checkErr ok msg = checkM ok (addErr msg)
+
+warnIf :: Bool -> Message -> TcRn m ()
+warnIf True msg = addWarn msg
+warnIf False msg = return ()
+
+addMessages :: Messages -> TcRn m ()
+addMessages (m_warns, m_errs)
+ = do { errs_var <- getErrsVar ;
+ (warns, errs) <- readMutVar errs_var ;
+ writeMutVar errs_var (warns `unionBags` m_warns,
+ errs `unionBags` m_errs) }
+
+checkGHCI :: Message -> TcRn m () -- Check that GHCI is on
+ -- otherwise add the error message
+#ifdef GHCI
+checkGHCI m = returnM ()
+#else
+checkGHCI m = addErr m
+#endif
+\end{code}
+
+
+\begin{code}
+tryM :: TcRn m a -> TcRn m (Messages, Maybe a)
+ -- (try m) executes m, and returns
+ -- Just r, if m succeeds (returning r) and caused no errors
+ -- Nothing, if m fails, or caused errors
+ -- It also returns all the errors accumulated by m
+ -- (even in the Just case, there might be warnings)
+ --
+ -- It always succeeds (never raises an exception)
+tryM m
+ = do { errs_var <- newMutVar emptyMessages ;
+
+ mb_r <- recoverM (return Nothing)
+ (do { r <- setErrsVar errs_var m ;
+ return (Just r) }) ;
+
+ new_errs <- readMutVar errs_var ;
+
+ return (new_errs,
+ case mb_r of
+ Nothing -> Nothing
+ Just r | errorsFound new_errs -> Nothing
+ | otherwise -> Just r)
+ }
+
+tryTc :: TcM a -> TcM (Messages, Maybe a)
+-- Just like tryM, except that it ensures that the LIE
+-- for the thing is propagated only if there are no errors
+-- Hence it's restricted to the type-check monad
+tryTc thing_inside
+ = do { ((errs, mb_r), lie) <- getLIE (tryM thing_inside) ;
+ ifM (isJust mb_r) (extendLIEs lie) ;
+ return (errs, mb_r) }
+
+tryTc_ :: TcM r -> TcM r -> TcM r
+-- (tryM_ 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_ recover main
+ = do { (_msgs, mb_res) <- tryTc main ;
+ case mb_res of
+ Just res -> return res
+ Nothing -> recover }
+
+checkNoErrs :: TcM r -> TcM r
+-- (checkNoErrs 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.
+checkNoErrs main
+ = do { (msgs, mb_res) <- tryTc main ;
+ addMessages msgs ;
+ case mb_res of
+ Just r -> return r
+ Nothing -> failM
+ }
+
+ifErrsM :: TcRn m r -> TcRn m r -> TcRn m r
+-- ifErrsM bale_out main
+-- does 'bale_out' if there are errors in errors collection
+-- otherwise does 'main'
+ifErrsM bale_out normal
+ = do { errs_var <- getErrsVar ;
+ msgs <- readMutVar errs_var ;
+ if errorsFound msgs then
+ bale_out
+ else
+ normal }
+
+failIfErrsM :: TcRn m ()
+-- Useful to avoid error cascades
+failIfErrsM = ifErrsM failM (return ())
+\end{code}
+
+\begin{code}
+forkM :: SDoc -> TcM a -> TcM (Maybe a)
+-- Run thing_inside in an interleaved thread. It gets a separate
+-- * errs_var, and
+-- * unique supply,
+-- but everything else is shared, so this is DANGEROUS.
+--
+-- It returns Nothing if the computation fails
+--
+-- It's used for lazily type-checking interface
+-- signatures, which is pretty benign
+
+forkM doc thing_inside
+ = do { us <- newUniqueSupply ;
+ unsafeInterleaveM $
+ do { us_var <- newMutVar us ;
+ (msgs, mb_res) <- tryTc (setUsVar us_var thing_inside) ;
+ case mb_res of
+ Just r -> return (Just r)
+ Nothing -> do {
+ -- Bleat about errors in the forked thread
+ ioToTcRn (do { printErrs (hdr_doc defaultErrStyle) ;
+ printErrorsAndWarnings msgs }) ;
+ return Nothing }
+ }}
+ where
+ hdr_doc = text "forkM failed:" <+> doc
+\end{code}
+
+
+%************************************************************************
+%* *
+ Unique supply
+%* *
+%************************************************************************
+
+\begin{code}
+getUsVar :: TcRn m (TcRef UniqSupply)
+getUsVar = do { env <- getTopEnv; return (top_us env) }
+
+setUsVar :: TcRef UniqSupply -> TcRn m a -> TcRn m a
+setUsVar v = updEnv (\ env@(Env { env_top = top_env }) ->
+ env { env_top = top_env { top_us = v }})
+
+newUnique :: TcRn m Unique
+newUnique = do { us <- newUniqueSupply ;
+ return (uniqFromSupply us) }
+
+newUniqueSupply :: TcRn m UniqSupply
+newUniqueSupply
+ = do { u_var <- getUsVar ;
+ us <- readMutVar u_var ;
+ let { (us1, us2) = splitUniqSupply us } ;
+ writeMutVar u_var us1 ;
+ return us2 }
+\end{code}
+
+
+\begin{code}
+getNameCache :: TcRn m NameCache
+getNameCache = do { TopEnv { top_nc = nc_var } <- getTopEnv;
+ readMutVar nc_var }
+
+setNameCache :: NameCache -> TcRn m ()
+setNameCache nc = do { TopEnv { top_nc = nc_var } <- getTopEnv;
+ writeMutVar nc_var nc }
+\end{code}
+
+
+%************************************************************************
+%* *
+ Debugging
+%* *
+%************************************************************************
+
+\begin{code}
+traceTc, traceRn :: SDoc -> TcRn a ()
+traceRn = dumpOptTcRn Opt_D_dump_rn_trace
+traceTc = dumpOptTcRn Opt_D_dump_tc_trace
+traceHiDiffs = dumpOptTcRn Opt_D_dump_hi_diffs
+
+dumpOptTcRn :: DynFlag -> SDoc -> TcRn a ()
+dumpOptTcRn flag doc = ifOptM flag (dumpTcRn doc)
+
+dumpTcRn :: SDoc -> TcRn a ()
+dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv ;
+ ioToTcRn (printForUser stderr (unQualInScope rdr_env) doc) }
+\end{code}
+
+
+%************************************************************************
+%* *
+ Context management and error message generation
+ for the type checker
+%* *
+%************************************************************************
+
+\begin{code}
+setErrCtxtM, addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, Message)) -> TcM a -> TcM a
+setErrCtxtM msg = updCtxt (\ msgs -> [msg])
+addErrCtxtM msg = updCtxt (\ msgs -> msg : msgs)
+
+setErrCtxt, addErrCtxt :: Message -> TcM a -> TcM a
+setErrCtxt msg = setErrCtxtM (\env -> returnM (env, msg))
+addErrCtxt msg = addErrCtxtM (\env -> returnM (env, msg))
+
+popErrCtxt :: TcM a -> TcM a
+popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (m:ms) -> ms })
+
+getErrCtxt :: TcM ErrCtxt
+getErrCtxt = do { env <- getLclEnv ; return (tcl_ctxt env) }
+
+-- Helper function for the above
+updCtxt :: (ErrCtxt -> ErrCtxt) -> TcM a -> TcM a
+updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) ->
+ env { tcl_ctxt = upd ctxt })
+
+getInstLoc :: InstOrigin -> TcM InstLoc
+getInstLoc origin
+ = do { loc <- getSrcLocM ; env <- getLclEnv ;
+ return (origin, loc, (tcl_ctxt env)) }
+\end{code}
+
+ The addErr functions add an error message, but do not cause failure.
+ The 'M' variants pass a TidyEnv that has already been used to
+ tidy up the message; we then use it to tidy the context messages
+
+\begin{code}
+addErrTc :: Message -> TcM ()
+addErrTc err_msg = addErrTcM (emptyTidyEnv, err_msg)
+
+addErrsTc :: [Message] -> TcM ()
+addErrsTc err_msgs = mappM_ addErrTc err_msgs
+
+addErrTcM :: (TidyEnv, Message) -> TcM ()
+addErrTcM (tidy_env, err_msg)
+ = do { ctxt <- getErrCtxt ;
+ loc <- getSrcLocM ;
+ add_err_tcm tidy_env err_msg loc ctxt }
+
+addInstErrTcM :: InstLoc -> (TidyEnv, Message) -> TcM ()
+addInstErrTcM inst_loc@(_, loc, ctxt) (tidy_env, err_msg)
+ = add_err_tcm tidy_env err_msg loc full_ctxt
+ where
+ full_ctxt = (\env -> returnM (env, pprInstLoc inst_loc)) : ctxt
+\end{code}
+
+The failWith functions add an error message and cause failure
+
+\begin{code}
+failWithTc :: Message -> TcM a -- Add an error message and fail
+failWithTc err_msg
+ = addErrTc err_msg >> failM
+
+failWithTcM :: (TidyEnv, Message) -> TcM a -- Add an error message and fail
+failWithTcM local_and_msg
+ = addErrTcM local_and_msg >> failM
+
+checkTc :: Bool -> Message -> TcM () -- Check that the boolean is true
+checkTc True err = returnM ()
+checkTc False err = failWithTc err
+\end{code}
+
+ Warnings have no 'M' variant, nor failure
+
+\begin{code}
+addWarnTc :: Message -> TcM ()
+addWarnTc msg
+ = do { ctxt <- getErrCtxt ;
+ ctxt_msgs <- do_ctxt emptyTidyEnv ctxt ;
+ addWarn (vcat (msg : ctxt_to_use ctxt_msgs)) }
+
+warnTc :: Bool -> Message -> TcM ()
+warnTc warn_if_true warn_msg
+ | warn_if_true = addWarnTc warn_msg
+ | otherwise = return ()
+\end{code}
+
+ Helper functions
+
+\begin{code}
+add_err_tcm tidy_env err_msg loc ctxt
+ = do { ctxt_msgs <- do_ctxt tidy_env ctxt ;
+ add_err loc (vcat (err_msg : ctxt_to_use ctxt_msgs)) }
+
+do_ctxt tidy_env []
+ = return []
+do_ctxt tidy_env (c:cs)
+ = do { (tidy_env', m) <- c tidy_env ;
+ ms <- do_ctxt tidy_env' cs ;
+ return (m:ms) }
+
+ctxt_to_use ctxt | opt_PprStyle_Debug = ctxt
+ | otherwise = take 3 ctxt
+\end{code}
+
+%************************************************************************
+%* *
+ Other stuff specific to type checker
+%* *
+%************************************************************************
+
+\begin{code}
+getLIEVar :: TcM (TcRef LIE)
+getLIEVar = do { env <- getLclEnv; return (tcl_lie env) }
+
+setLIEVar :: TcRef LIE -> TcM a -> TcM a
+setLIEVar lie_var = updLclEnv (\ env -> env { tcl_lie = lie_var })
+
+getLIE :: TcM a -> TcM (a, [Inst])
+-- (getLIE m) runs m, and returns the type constraints it generates
+getLIE thing_inside
+ = do { lie_var <- newMutVar emptyLIE ;
+ res <- updLclEnv (\ env -> env { tcl_lie = lie_var })
+ thing_inside ;
+ lie <- readMutVar lie_var ;
+ return (res, lieToList lie) }
+
+extendLIE :: Inst -> TcM ()
+extendLIE inst
+ = do { lie_var <- getLIEVar ;
+ lie <- readMutVar lie_var ;
+ writeMutVar lie_var (inst `consLIE` lie) }
+
+extendLIEs :: [Inst] -> TcM ()
+extendLIEs []
+ = returnM ()
+extendLIEs insts
+ = do { lie_var <- getLIEVar ;
+ lie <- readMutVar lie_var ;
+ writeMutVar lie_var (mkLIE insts `plusLIE` lie) }
+\end{code}
+
+
+\begin{code}
+getStage :: TcM Stage
+getStage = do { env <- getLclEnv; return (tcl_level env) }
+
+setStage :: Stage -> TcM a -> TcM a
+setStage s = updLclEnv (\ env -> env { tcl_level = s })
+
+setLclTypeEnv :: TcLclEnv -> TcM a -> TcM a
+-- Set the local type envt, but do *not* disturb other fields,
+-- notably the lie_var
+setLclTypeEnv lcl_env thing_inside
+ = updLclEnv upd thing_inside
+ where
+ upd env = env { tcl_env = tcl_env lcl_env,
+ tcl_tyvars = tcl_tyvars lcl_env }
+\end{code}
+
+
+%************************************************************************
+%* *
+ Stuff for the renamer's local env
+%* *
+%************************************************************************
+
+\begin{code}
+initRn :: RnMode -> RnM a -> TcRn m a
+initRn mode thing_inside
+ = do { env <- getGblEnv ;
+ let { lcl_env = RnLclEnv {
+ rn_mode = mode,
+ rn_lenv = emptyRdrEnv }} ;
+ setLclEnv lcl_env thing_inside }
+\end{code}
+
+\begin{code}
+getLocalRdrEnv :: RnM LocalRdrEnv
+getLocalRdrEnv = do { env <- getLclEnv; return (rn_lenv env) }
+
+setLocalRdrEnv :: LocalRdrEnv -> RnM a -> RnM a
+setLocalRdrEnv rdr_env thing_inside
+ = updLclEnv (\env -> env {rn_lenv = rdr_env}) thing_inside
+
+getModeRn :: RnM RnMode
+getModeRn = do { env <- getLclEnv; return (rn_mode env) }
+\end{code}
+
--- /dev/null
+%
+% (c) The GRASP Project, Glasgow University, 1992-2002
+%
+\begin{code}
+module TcRnTypes(
+ TcRn, TcM, RnM, -- The monad is opaque outside this module
+
+ -- Standard monadic operations
+ thenM, thenM_, returnM, failM,
+
+ -- Non-standard operations
+ runTcRn, fixM, recoverM, ioToTcRn, ioToTcRn_no_fail,
+ newMutVar, readMutVar, writeMutVar,
+ getEnv, setEnv, updEnv, unsafeInterleaveM,
+
+ -- The environment types
+ Env(..), TopEnv(..), TcGblEnv(..),
+ TcLclEnv(..), RnLclEnv(..),
+
+ -- Ranamer types
+ RnMode(..), isInterfaceMode, isCmdLineMode,
+ Usages(..), emptyUsages, ErrCtxt,
+ ImportAvails(..), emptyImportAvails, plusImportAvails, mkImportAvails,
+ plusAvail, pruneAvails,
+ AvailEnv, emptyAvailEnv, unitAvailEnv, plusAvailEnv, lookupAvailEnv, availEnvElts, addAvail,
+ WhereFrom(..),
+
+ -- Typechecker types
+ TcTyThing(..),
+
+ -- Template Haskell
+ Stage(..), topStage, topSpliceStage,
+ Level, impLevel, topLevel,
+
+ -- Insts
+ Inst(..), InstOrigin(..), InstLoc, pprInstLoc,
+ LIE, emptyLIE, unitLIE, plusLIE, consLIE,
+ plusLIEs, mkLIE, isEmptyLIE, lieToList, listToLIE,
+
+ -- Misc other types
+ TcRef, TcId, TcIdSet
+ ) where
+
+#include "HsVersions.h"
+
+import HsSyn ( PendingSplice, HsOverLit, MonoBinds, RuleDecl, ForeignDecl )
+import RnHsSyn ( RenamedHsExpr, RenamedPat, RenamedArithSeqInfo )
+import HscTypes ( GhciMode, ExternalPackageState, HomePackageTable, NameCache,
+ GlobalRdrEnv, LocalRdrEnv, FixityEnv, TypeEnv, TyThing,
+ Avails, GenAvailInfo(..), AvailInfo, availName,
+ IsBootInterface, Deprecations, unQualInScope )
+import TcType ( TcTyVarSet, TcType, TcTauType, TcThetaType, TcPredType, TcKind,
+ tcCmpPred, tcCmpType, tcCmpTypes )
+import InstEnv ( DFunId, InstEnv )
+import Name ( Name )
+import NameEnv
+import NameSet ( NameSet, emptyNameSet )
+import Type ( Type )
+import Class ( Class )
+import Var ( Id, TyVar )
+import VarEnv ( TidyEnv )
+import Module
+import SrcLoc ( SrcLoc )
+import VarSet ( IdSet )
+import ErrUtils ( Messages, Message )
+import CmdLineOpts ( DynFlags )
+import UniqSupply ( UniqSupply )
+import BasicTypes ( IPName )
+import Util ( thenCmp )
+import Bag
+import Outputable
+import DATA_IOREF ( IORef, newIORef, readIORef, writeIORef )
+import UNSAFE_IO ( unsafeInterleaveIO )
+import FIX_IO ( fixIO )
+import Maybe ( mapMaybe )
+import List ( nub )
+\end{code}
+
+
+\begin{code}
+type TcRef a = IORef a
+type TcId = Id -- Type may be a TcType
+type TcIdSet = IdSet
+\end{code}
+
+%************************************************************************
+%* *
+ Standard monad definition for TcRn
+ All the combinators for the monad can be found in TcRnMonad
+%* *
+%************************************************************************
+
+The monad itself has to be defined here,
+because it is mentioned by ErrCtxt
+
+\begin{code}
+newtype TcRn m a = TcRn (Env m -> IO a)
+unTcRn (TcRn f) = f
+
+type TcM a = TcRn TcLclEnv a
+type RnM a = TcRn RnLclEnv a
+
+returnM :: a -> TcRn m a
+returnM a = TcRn (\ env -> return a)
+
+thenM :: TcRn m a -> (a -> TcRn m b) -> TcRn m b
+thenM (TcRn m) f = TcRn (\ env -> do { r <- m env ;
+ unTcRn (f r) env })
+
+thenM_ :: TcRn m a -> TcRn m b -> TcRn m b
+thenM_ (TcRn m) f = TcRn (\ env -> do { m env ; unTcRn f env })
+
+failM :: TcRn m a
+failM = TcRn (\ env -> ioError (userError "TcRn failure"))
+
+instance Monad (TcRn m) where
+ (>>=) = thenM
+ (>>) = thenM_
+ return = returnM
+ fail s = failM -- Ignore the string
+\end{code}
+
+
+%************************************************************************
+%* *
+ Fundmantal combinators specific to the monad
+%* *
+%************************************************************************
+
+Running it
+
+\begin{code}
+runTcRn :: Env m -> TcRn m a -> IO a
+runTcRn env (TcRn m) = m env
+\end{code}
+
+The fixpoint combinator
+
+\begin{code}
+{-# NOINLINE fixM #-}
+ -- Aargh! Not inlining fixTc alleviates a space leak problem.
+ -- Normally fixTc is used with a lazy tuple match: if the optimiser is
+ -- shown the definition of fixTc, it occasionally transforms the code
+ -- in such a way that the code generator doesn't spot the selector
+ -- thunks. Sigh.
+
+fixM :: (a -> TcRn m a) -> TcRn m a
+fixM f = TcRn (\ env -> fixIO (\ r -> unTcRn (f r) env))
+\end{code}
+
+Error recovery
+
+\begin{code}
+recoverM :: TcRn m r -- Recovery action; do this if the main one fails
+ -> TcRn m r -- Main action: do this first
+ -> TcRn m r
+recoverM (TcRn recover) (TcRn m)
+ = TcRn (\ env -> catch (m env) (\ _ -> recover env))
+\end{code}
+
+Lazy interleave
+
+\begin{code}
+unsafeInterleaveM :: TcRn m a -> TcRn m a
+unsafeInterleaveM (TcRn m) = TcRn (\ env -> unsafeInterleaveIO (m env))
+\end{code}
+
+\end{code}
+
+Performing arbitrary I/O, plus the read/write var (for efficiency)
+
+\begin{code}
+ioToTcRn :: IO a -> TcRn m a
+ioToTcRn io = TcRn (\ env -> io)
+
+ioToTcRn_no_fail :: IO a -> TcRn m (Either IOError a)
+-- Catch any IO error and embody it in the result
+ioToTcRn_no_fail io = TcRn (\ env -> catch (io >>= \r -> return (Right r))
+ (\ exn -> return (Left exn)))
+
+newMutVar :: a -> TcRn m (TcRef a)
+newMutVar val = TcRn (\ env -> newIORef val)
+
+writeMutVar :: TcRef a -> a -> TcRn m ()
+writeMutVar var val = TcRn (\ env -> writeIORef var val)
+
+readMutVar :: TcRef a -> TcRn m a
+readMutVar var = TcRn (\ env -> readIORef var)
+\end{code}
+
+Getting the environment
+
+\begin{code}
+getEnv :: TcRn m (Env m)
+{-# INLINE getEnv #-}
+getEnv = TcRn (\ env -> return env)
+
+setEnv :: Env n -> TcRn n a -> TcRn m a
+{-# INLINE setEnv #-}
+setEnv new_env (TcRn m) = TcRn (\ env -> m new_env)
+
+updEnv :: (Env m -> Env n) -> TcRn n a -> TcRn m a
+{-# INLINE updEnv #-}
+updEnv upd (TcRn m) = TcRn (\ env -> m (upd env))
+\end{code}
+
+
+%************************************************************************
+%* *
+ The main environment types
+%* *
+%************************************************************************
+
+\begin{code}
+data Env a -- Changes as we move into an expression
+ = Env {
+ env_top :: TopEnv, -- Top-level stuff that never changes
+ -- Mainly a bunch of updatable refs
+ -- Includes all info about imported things
+ env_gbl :: TcGblEnv, -- Info about things defined at the top leve
+ -- of the module being compiled
+
+ env_lcl :: a, -- Different for the type checker
+ -- and the renamer
+
+ env_loc :: SrcLoc -- Source location
+ }
+
+data TopEnv -- Built once at top level then does not change
+ -- Concerns imported stuff
+ -- Exceptions: error recovery points, meta computation points
+ = TopEnv {
+ top_mode :: GhciMode,
+ top_dflags :: DynFlags,
+
+ -- Stuff about imports
+ top_eps :: TcRef ExternalPackageState,
+ -- PIT, ImportedModuleInfo
+ -- DeclsMap, IfaceRules, IfaceInsts, InstGates
+ -- TypeEnv, InstEnv, RuleBase
+
+ top_hpt :: HomePackageTable,
+ -- The home package table that we've accumulated while
+ -- compiling the home package,
+ -- *excluding* the module we are compiling right now.
+ -- (In one-shot mode the current module is the only
+ -- home-package module, so tc_hpt is empty. All other
+ -- modules count as "external-package" modules.)
+ -- tc_hpt is not mutable because we only demand-load
+ -- external packages; the home package is eagerly
+ -- loaded by the compilation manager.
+
+ -- The global name supply
+ top_nc :: TcRef NameCache, -- Maps original names to Names
+ top_us :: TcRef UniqSupply, -- Unique supply for this module
+ top_errs :: TcRef Messages
+ }
+
+-- TcGblEnv describes the top-level of the module at the
+-- point at which the typechecker is finished work.
+-- It is this structure that is handed on to the desugarer
+
+data TcGblEnv
+ = TcGblEnv {
+ tcg_mod :: Module, -- Module being compiled
+ tcg_usages :: TcRef Usages, -- What version of what entities
+ -- have been used from other modules
+ -- (whether home or ext-package modules)
+ tcg_rdr_env :: GlobalRdrEnv, -- Top level envt; used during renaming
+ tcg_fix_env :: FixityEnv, -- Ditto
+ tcg_default :: [Type], -- Types used for defaulting
+
+ tcg_type_env :: TypeEnv, -- Global type env for the module we are compiling now
+ -- All TyCons and Classes (for this module) end up in here right away,
+ -- along with their derived constructors, selectors.
+ --
+ -- (Ids defined in this module start in the local envt,
+ -- though they move to the global envt during zonking)
+
+ -- Cached things
+ tcg_ist :: Name -> Maybe TyThing, -- Imported symbol table
+ -- Global type env: a combination of tcg_eps, tcg_hpt
+ -- (but *not* tcg_type_env; no deep reason)
+ -- When the PCS changes this must be refreshed,
+ -- notably after running some compile-time code
+
+ tcg_inst_env :: InstEnv, -- Global instance env: a combination of
+ -- tc_pcs, tc_hpt, *and* tc_insts
+
+ -- Now a bunch of things about this module that are simply
+ -- accumulated, but never consulted until the end.
+ -- Nevertheless, it's convenient to accumulate them along
+ -- with the rest of the info from this module.
+ tcg_exports :: Avails, -- What is exported
+ tcg_imports :: ImportAvails, -- Information about what was imported
+ -- from where, including things bound
+ -- in this module
+ -- The next fields are always fully zonked
+ tcg_binds :: MonoBinds Id, -- Value bindings in this module
+ tcg_deprecs :: Deprecations, -- ...Deprecations
+ tcg_insts :: [DFunId], -- ...Instances
+ tcg_rules :: [RuleDecl Id], -- ...Rules
+ tcg_fords :: [ForeignDecl Id] -- ...Foreign import & exports
+ }
+\end{code}
+
+
+%************************************************************************
+%* *
+ The local typechecker environment
+%* *
+%************************************************************************
+
+The Global-Env/Local-Env story
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+During type checking, we keep in the tcg_type_env
+ * All types and classes
+ * All Ids derived from types and classes (constructors, selectors)
+
+At the end of type checking, we zonk the local bindings,
+and as we do so we add to the tcg_type_env
+ * Locally defined top-level Ids
+
+Why? Because they are now Ids not TcIds. This final GlobalEnv is
+ a) fed back (via the knot) to typechecking the
+ unfoldings of interface signatures
+ b) used in the ModDetails of this module
+
+\begin{code}
+data TcLclEnv
+ = TcLclEnv {
+ tcl_ctxt :: ErrCtxt, -- Error context
+
+ tcl_level :: Stage, -- Template Haskell context
+
+ tcl_env :: NameEnv TcTyThing, -- The local type environment: Ids and TyVars
+ -- defined in this module
+
+ tcl_tyvars :: TcRef TcTyVarSet, -- The "global tyvars"
+ -- Namely, the in-scope TyVars bound in tcl_lenv,
+ -- plus the tyvars mentioned in the types of
+ -- Ids bound in tcl_lenv
+ -- Why mutable? see notes with tcGetGlobalTyVars
+
+ tcl_lie :: TcRef LIE -- Place to accumulate type constraints
+ }
+
+type Level = Int
+
+data Stage
+ = Comp -- Ordinary compiling, at level topLevel
+ | Splice Level -- Inside a splice
+ | Brack Level -- Inside brackets;
+ (TcRef [PendingSplice]) -- accumulate pending splices here
+ (TcRef LIE) -- and type constraints here
+topStage, topSpliceStage :: Stage
+topStage = Comp
+topSpliceStage = Splice (topLevel - 1) -- Stage for the body of a top-level splice
+
+
+impLevel, topLevel :: Level
+topLevel = 1 -- Things dedined at top level of this module
+impLevel = 0 -- Imported things; they can be used inside a top level splice
+--
+-- For example:
+-- f = ...
+-- g1 = $(map ...) is OK
+-- g2 = $(f ...) is not OK; because we havn't compiled f yet
+
+data TcTyThing
+ = AGlobal TyThing -- Used only in the return type of a lookup
+ | ATcId TcId Level -- Ids defined in this module; may not be fully zonked
+ | ATyVar TyVar -- Type variables
+ | AThing TcKind -- Used temporarily, during kind checking
+-- Here's an example of how the AThing guy is used
+-- Suppose we are checking (forall a. T a Int):
+-- 1. We first bind (a -> AThink kv), where kv is a kind variable.
+-- 2. Then we kind-check the (T a Int) part.
+-- 3. Then we zonk the kind variable.
+-- 4. Now we know the kind for 'a', and we add (a -> ATyVar a::K) to the environment
+\end{code}
+
+\begin{code}
+type ErrCtxt = [TidyEnv -> TcM (TidyEnv, Message)]
+ -- Innermost first. Monadic so that we have a chance
+ -- to deal with bound type variables just before error
+ -- message construction
+\end{code}
+
+
+%************************************************************************
+%* *
+ The local renamer environment
+%* *
+%************************************************************************
+
+\begin{code}
+data RnLclEnv
+ = RnLclEnv {
+ rn_mode :: RnMode,
+ rn_lenv :: LocalRdrEnv -- Local name envt
+ -- Does *not* include 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
+ }
+
+data RnMode = SourceMode -- Renaming source code
+ | InterfaceMode Module -- Renaming interface declarations from M
+ | CmdLineMode -- Renaming a command-line expression
+
+isInterfaceMode (InterfaceMode _) = True
+isInterfaceMode _ = False
+
+isCmdLineMode CmdLineMode = True
+isCmdLineMode _ = False
+\end{code}
+
+
+%************************************************************************
+%* *
+ Usages
+%* *
+%************************************************************************
+
+Usages tells what things are actually need in order to compile this
+module. It is used
+ * for generating the usages field of the ModIface
+ * for reporting unused things in scope
+
+\begin{code}
+data Usages
+ = Usages {
+ usg_ext :: ModuleSet,
+ -- The non-home-package modules from which we have
+ -- slurped at least one name.
+
+ usg_home :: NameSet
+ -- The Names are all the (a) home-package
+ -- (b) "big" (i.e. no data cons, class ops)
+ -- (c) non-locally-defined
+ -- (d) non-wired-in
+ -- names that have been slurped in so far.
+ -- This is used to generate the "usage" information for this module.
+ }
+
+emptyUsages :: Usages
+emptyUsages = Usages { usg_ext = emptyModuleSet,
+ usg_home = emptyNameSet }
+\end{code}
+
+
+%************************************************************************
+%* *
+ Operations over ImportAvails
+%* *
+%************************************************************************
+
+ImportAvails summarises what was imported from where, irrespective
+of whether the imported htings are actually used or not
+It is used * when porcessing the export list
+ * when constructing usage info for the inteface file
+ * to identify the list of directly imported modules
+ for initialisation purposes
+
+\begin{code}
+data ImportAvails
+ = ImportAvails {
+ imp_env :: AvailEnv,
+ -- All the things that are available from the import
+ -- Its domain is all the "main" things;
+ -- i.e. *excluding* class ops and constructors
+ -- (which appear inside their parent AvailTC)
+
+ imp_unqual :: ModuleEnv Avails,
+ -- Used to figure out "module M" export specifiers
+ -- Domain is only modules with *unqualified* imports
+ -- (see 1.4 Report Section 5.1.1)
+
+ imp_mods :: ModuleEnv (Module, Bool)
+ -- Domain is all directly-imported modules
+ -- Bool is True if there was an unrestricted import
+ -- (i.e. not a selective list)
+ -- We need the Module in the range because we can't get
+ -- the keys of a ModuleEnv
+ -- Used
+ -- (a) to help construct the usage information in
+ -- the interface file; if we import everything we
+ -- need to recompile if the module version changes
+ -- (b) to specify what child modules to initialise
+ }
+
+emptyImportAvails :: ImportAvails
+emptyImportAvails = ImportAvails { imp_env = emptyAvailEnv,
+ imp_unqual = emptyModuleEnv,
+ imp_mods = emptyModuleEnv }
+
+plusImportAvails :: ImportAvails -> ImportAvails -> ImportAvails
+plusImportAvails
+ (ImportAvails { imp_env = env1, imp_unqual = unqual1, imp_mods = mods1 })
+ (ImportAvails { imp_env = env2, imp_unqual = unqual2, imp_mods = mods2 })
+ = ImportAvails { imp_env = env1 `plusAvailEnv` env2,
+ imp_unqual = unqual1 `plusModuleEnv` unqual2,
+ imp_mods = mods1 `plusModuleEnv` mods2 }
+
+mkImportAvails :: ModuleName -> Bool
+ -> GlobalRdrEnv -> [AvailInfo] -> ImportAvails
+mkImportAvails mod_name unqual_imp gbl_env avails
+ = ImportAvails { imp_unqual = mod_avail_env,
+ imp_env = entity_avail_env,
+ imp_mods = emptyModuleEnv }-- Stays empty for module being compiled;
+ -- gets updated for imported modules
+ where
+ mod_avail_env = unitModuleEnvByName mod_name unqual_avails
+
+ -- unqual_avails is the Avails that are visible in *unqualified* form
+ -- We need to know this so we know what to export when we see
+ -- module M ( module P ) where ...
+ -- Then we must export whatever came from P unqualified.
+
+ unqual_avails | not unqual_imp = [] -- Short cut when no unqualified imports
+ | otherwise = pruneAvails (unQualInScope gbl_env) avails
+
+ entity_avail_env = foldl insert emptyAvailEnv avails
+ insert env avail = extendNameEnv_C plusAvail env (availName avail) avail
+ -- 'avails' may have several items with the same availName
+ -- E.g import Ix( Ix(..), index )
+ -- will give Ix(Ix,index,range) and Ix(index)
+ -- We want to combine these
+\end{code}
+
+%************************************************************************
+%* *
+ Avails, AvailEnv, etc
+%* *
+v%************************************************************************
+
+\begin{code}
+plusAvail (Avail n1) (Avail n2) = Avail n1
+plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n2 (nub (ns1 ++ ns2))
+-- Added SOF 4/97
+#ifdef DEBUG
+plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [ppr a1,ppr a2])
+#endif
+
+-------------------------
+pruneAvails :: (Name -> Bool) -- Keep if this is True
+ -> [AvailInfo]
+ -> [AvailInfo]
+pruneAvails keep avails
+ = mapMaybe del avails
+ where
+ del :: AvailInfo -> Maybe AvailInfo -- Nothing => nothing left!
+ del (Avail n) | keep n = Just (Avail n)
+ | otherwise = Nothing
+ del (AvailTC n ns) | null ns' = Nothing
+ | otherwise = Just (AvailTC n ns')
+ where
+ ns' = filter keep ns
+\end{code}
+
+---------------------------------------
+ AvailEnv and friends
+---------------------------------------
+
+\begin{code}
+type AvailEnv = NameEnv AvailInfo -- Maps a Name to the AvailInfo that contains it
+
+emptyAvailEnv :: AvailEnv
+emptyAvailEnv = emptyNameEnv
+
+unitAvailEnv :: AvailInfo -> AvailEnv
+unitAvailEnv a = unitNameEnv (availName a) a
+
+plusAvailEnv :: AvailEnv -> AvailEnv -> AvailEnv
+plusAvailEnv = plusNameEnv_C plusAvail
+
+lookupAvailEnv = lookupNameEnv
+
+availEnvElts = nameEnvElts
+
+addAvail :: AvailEnv -> AvailInfo -> AvailEnv
+addAvail avails avail = extendNameEnv_C plusAvail avails (availName avail) avail
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Where from}
+%* *
+%************************************************************************
+
+The @WhereFrom@ type controls where the renamer looks for an interface file
+
+\begin{code}
+data WhereFrom
+ = ImportByUser IsBootInterface -- Ordinary user import (perhaps {-# SOURCE #-})
+
+ | ImportForUsage IsBootInterface -- Import when chasing usage info from an interaface file
+ -- Failure in this case is not an error
+
+ | ImportBySystem -- Non user import. Use eps_mod_info to decide whether
+ -- the module this module depends on, or is a system-ish module;
+ -- M.hi-boot otherwise
+
+instance Outputable WhereFrom where
+ ppr (ImportByUser is_boot) | is_boot = ptext SLIT("{- SOURCE -}")
+ | otherwise = empty
+ ppr (ImportForUsage is_boot) | is_boot = ptext SLIT("{- USAGE SOURCE -}")
+ | otherwise = ptext SLIT("{- USAGE -}")
+ ppr ImportBySystem = ptext SLIT("{- SYSTEM -}")
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection[Inst-types]{@Inst@ types}
+%* *
+v%************************************************************************
+
+An @Inst@ is either a dictionary, an instance of an overloaded
+literal, or an instance of an overloaded value. We call the latter a
+``method'' even though it may not correspond to a class operation.
+For example, we might have an instance of the @double@ function at
+type Int, represented by
+
+ Method 34 doubleId [Int] origin
+
+\begin{code}
+data Inst
+ = Dict
+ Id
+ TcPredType
+ InstLoc
+
+ | Method
+ Id
+
+ 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] -- The types to which its polymorphic tyvars
+ -- should be instantiated.
+ -- These types must saturate the Id's foralls.
+
+ TcThetaType -- The (types of the) dictionaries to which the function
+ -- must be applied to get the method
+
+ TcTauType -- The type of the method
+
+ InstLoc
+
+ -- INVARIANT: in (Method u f tys theta tau loc)
+ -- type of (f tys dicts(from theta)) = tau
+
+ | LitInst
+ Id
+ HsOverLit -- The literal from the occurrence site
+ -- INVARIANT: never a rebindable-syntax literal
+ -- Reason: tcSyntaxName does unification, and we
+ -- don't want to deal with that during tcSimplify
+ TcType -- The type at which the literal is used
+ InstLoc
+\end{code}
+
+@Insts@ are ordered by their class/type info, rather than by their
+unique. This allows the context-reduction mechanism to use standard finite
+maps to do their stuff.
+
+\begin{code}
+instance Ord Inst where
+ compare = cmpInst
+
+instance Eq Inst where
+ (==) i1 i2 = case i1 `cmpInst` i2 of
+ EQ -> True
+ other -> False
+
+cmpInst (Dict _ pred1 _) (Dict _ pred2 _) = pred1 `tcCmpPred` pred2
+cmpInst (Dict _ _ _) other = LT
+
+cmpInst (Method _ _ _ _ _ _) (Dict _ _ _) = GT
+cmpInst (Method _ id1 tys1 _ _ _) (Method _ id2 tys2 _ _ _) = (id1 `compare` id2) `thenCmp` (tys1 `tcCmpTypes` tys2)
+cmpInst (Method _ _ _ _ _ _) other = LT
+
+cmpInst (LitInst _ _ _ _) (Dict _ _ _) = GT
+cmpInst (LitInst _ _ _ _) (Method _ _ _ _ _ _) = GT
+cmpInst (LitInst _ lit1 ty1 _) (LitInst _ lit2 ty2 _) = (lit1 `compare` lit2) `thenCmp` (ty1 `tcCmpType` ty2)
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection[Inst-collections]{LIE: a collection of Insts}
+%* *
+%************************************************************************
+
+\begin{code}
+type LIE = Bag Inst
+
+isEmptyLIE = isEmptyBag
+emptyLIE = emptyBag
+unitLIE inst = unitBag inst
+mkLIE insts = listToBag insts
+plusLIE lie1 lie2 = lie1 `unionBags` lie2
+consLIE inst lie = inst `consBag` lie
+plusLIEs lies = unionManyBags lies
+lieToList = bagToList
+listToLIE = listToBag
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection[Inst-origin]{The @InstOrigin@ type}
+%* *
+%************************************************************************
+
+The @InstOrigin@ type gives information about where a dictionary came from.
+This is important for decent error message reporting because dictionaries
+don't appear in the original source code. Doubtless this type will evolve...
+
+It appears in TcMonad because there are a couple of error-message-generation
+functions that deal with it.
+
+\begin{code}
+type InstLoc = (InstOrigin, SrcLoc, ErrCtxt)
+
+data InstOrigin
+ = OccurrenceOf Name -- Occurrence of an overloaded identifier
+
+ | IPOcc (IPName Name) -- Occurrence of an implicit parameter
+ | IPBind (IPName Name) -- Binding site of an implicit parameter
+
+ | RecordUpdOrigin
+
+ | DataDeclOrigin -- Typechecking a data declaration
+
+ | InstanceDeclOrigin -- Typechecking an instance decl
+
+ | LiteralOrigin HsOverLit -- Occurrence of a literal
+
+ | PatOrigin RenamedPat
+
+ | ArithSeqOrigin RenamedArithSeqInfo -- [x..], [x..y] etc
+ | PArrSeqOrigin RenamedArithSeqInfo -- [:x..y:] and [:x,y..z:]
+
+ | SignatureOrigin -- A dict created from a type signature
+ | Rank2Origin -- A dict created when typechecking the argument
+ -- of a rank-2 typed function
+
+ | DoOrigin -- The monad for a do expression
+
+ | ClassDeclOrigin -- Manufactured during a class decl
+
+ | InstanceSpecOrigin Class -- in a SPECIALIZE instance pragma
+ Type
+
+ -- When specialising instances the instance info attached to
+ -- each class is not yet ready, so we record it inside the
+ -- origin information. This is a bit of a hack, but it works
+ -- fine. (Patrick is to blame [WDP].)
+
+ | ValSpecOrigin Name -- in a SPECIALIZE pragma for a value
+
+ -- Argument or result of a ccall
+ -- Dictionaries with this origin aren't actually mentioned in the
+ -- translated term, and so need not be bound. Nor should they
+ -- be abstracted over.
+
+ | CCallOrigin String -- CCall label
+ (Maybe RenamedHsExpr) -- Nothing if it's the result
+ -- Just arg, for an argument
+
+ | LitLitOrigin String -- the litlit
+
+ | UnknownOrigin -- Help! I give up...
+\end{code}
+
+\begin{code}
+pprInstLoc :: InstLoc -> SDoc
+pprInstLoc (orig, locn, ctxt)
+ = hsep [text "arising from", pp_orig orig, text "at", ppr locn]
+ where
+ pp_orig (OccurrenceOf name)
+ = hsep [ptext SLIT("use of"), quotes (ppr name)]
+ pp_orig (IPOcc name)
+ = hsep [ptext SLIT("use of implicit parameter"), quotes (ppr name)]
+ pp_orig (IPBind name)
+ = hsep [ptext SLIT("binding for implicit parameter"), quotes (ppr name)]
+ pp_orig RecordUpdOrigin
+ = ptext SLIT("a record update")
+ pp_orig DataDeclOrigin
+ = ptext SLIT("the data type declaration")
+ pp_orig InstanceDeclOrigin
+ = ptext SLIT("the instance declaration")
+ pp_orig (LiteralOrigin lit)
+ = hsep [ptext SLIT("the literal"), quotes (ppr lit)]
+ pp_orig (PatOrigin pat)
+ = hsep [ptext SLIT("the pattern"), quotes (ppr pat)]
+ pp_orig (ArithSeqOrigin seq)
+ = hsep [ptext SLIT("the arithmetic sequence"), quotes (ppr seq)]
+ pp_orig (PArrSeqOrigin seq)
+ = hsep [ptext SLIT("the parallel array sequence"), quotes (ppr seq)]
+ pp_orig (SignatureOrigin)
+ = ptext SLIT("a type signature")
+ pp_orig (Rank2Origin)
+ = ptext SLIT("a function with an overloaded argument type")
+ pp_orig (DoOrigin)
+ = ptext SLIT("a do statement")
+ pp_orig (ClassDeclOrigin)
+ = ptext SLIT("a class declaration")
+ pp_orig (InstanceSpecOrigin clas ty)
+ = hsep [text "a SPECIALIZE instance pragma; class",
+ quotes (ppr clas), text "type:", ppr ty]
+ pp_orig (ValSpecOrigin name)
+ = hsep [ptext SLIT("a SPECIALIZE user-pragma for"), quotes (ppr name)]
+ pp_orig (CCallOrigin clabel Nothing{-ccall result-})
+ = hsep [ptext SLIT("the result of the _ccall_ to"), quotes (text clabel)]
+ pp_orig (CCallOrigin clabel (Just arg_expr))
+ = hsep [ptext SLIT("an argument in the _ccall_ to"), quotes (text clabel) <> comma,
+ text "namely", quotes (ppr arg_expr)]
+ pp_orig (LitLitOrigin s)
+ = hsep [ptext SLIT("the ``literal-literal''"), quotes (text s)]
+ pp_orig (UnknownOrigin)
+ = ptext SLIT("...oops -- I don't know where the overloading came from!")
+\end{code}
\section[TcRules]{Typechecking transformation rules}
\begin{code}
-module TcRules ( tcIfaceRules, tcSourceRules ) where
+module TcRules ( tcRules ) where
#include "HsVersions.h"
import CoreSyn ( CoreRule(..) )
import RnHsSyn ( RenamedRuleDecl )
import TcHsSyn ( TypecheckedRuleDecl, mkHsLet )
-import TcMonad
+import TcRnMonad
import TcSimplify ( tcSimplifyToDicts, tcSimplifyInferCheck )
import TcMType ( newTyVarTy )
import TcType ( tyVarsOfTypes, openTypeKind )
import TcIfaceSig ( tcCoreExpr, tcCoreLamBndrs, tcVar )
import TcMonoType ( tcHsSigType, UserTypeCtxt(..), tcAddScopedTyVars )
import TcExpr ( tcMonoExpr )
-import TcEnv ( tcExtendLocalValEnv, tcLookupId )
-import Inst ( LIE, plusLIEs, emptyLIE, instToId )
+import TcEnv ( tcExtendLocalValEnv )
+import Inst ( instToId )
import Id ( idType, mkLocalId )
import Outputable
\end{code}
\begin{code}
-tcIfaceRules :: [RenamedRuleDecl] -> TcM [TypecheckedRuleDecl]
-tcIfaceRules decls = mapTc tcIfaceRule decls
-
-tcIfaceRule :: RenamedRuleDecl -> TcM TypecheckedRuleDecl
- -- No zonking necessary!
-tcIfaceRule (IfaceRule name act vars fun args rhs src_loc)
- = tcAddSrcLoc src_loc $
- tcAddErrCtxt (ruleCtxt name) $
- tcVar fun `thenTc` \ fun' ->
+tcRules :: [RenamedRuleDecl] -> TcM [TypecheckedRuleDecl]
+tcRules decls = mappM tcRule decls
+
+tcRule :: RenamedRuleDecl -> TcM TypecheckedRuleDecl
+tcRule (IfaceRule name act vars fun args rhs src_loc)
+ = addSrcLoc src_loc $
+ addErrCtxt (ruleCtxt name) $
+ tcVar fun `thenM` \ fun' ->
tcCoreLamBndrs vars $ \ vars' ->
- mapTc tcCoreExpr args `thenTc` \ args' ->
- tcCoreExpr rhs `thenTc` \ rhs' ->
- returnTc (IfaceRuleOut fun' (Rule name act vars' args' rhs'))
+ mappM tcCoreExpr args `thenM` \ args' ->
+ tcCoreExpr rhs `thenM` \ rhs' ->
+ returnM (IfaceRuleOut fun' (Rule name act vars' args' rhs'))
-tcIfaceRule (IfaceRuleOut fun rule) -- Built-in rules come this way
- = tcVar fun `thenTc` \ fun' ->
- returnTc (IfaceRuleOut fun' rule)
+tcRule (IfaceRuleOut fun rule) -- Built-in rules come this way
+ = tcVar fun `thenM` \ fun' ->
+ returnM (IfaceRuleOut fun' rule)
-tcSourceRules :: [RenamedRuleDecl] -> TcM (LIE, [TypecheckedRuleDecl])
-tcSourceRules decls
- = mapAndUnzipTc tcSourceRule decls `thenTc` \ (lies, decls') ->
- returnTc (plusLIEs lies, decls')
-
-tcSourceRule (IfaceRuleOut fun rule) -- Built-in rules come this way
- -- if they are from the module being compiled
- = tcLookupId fun `thenTc` \ fun' ->
- returnTc (emptyLIE, IfaceRuleOut fun' rule)
-
-tcSourceRule (HsRule name act vars lhs rhs src_loc)
- = tcAddSrcLoc src_loc $
- tcAddErrCtxt (ruleCtxt name) $
- newTyVarTy openTypeKind `thenNF_Tc` \ rule_ty ->
+tcRule (HsRule name act vars lhs rhs src_loc)
+ = addSrcLoc src_loc $
+ addErrCtxt (ruleCtxt name) $
+ newTyVarTy openTypeKind `thenM` \ rule_ty ->
-- Deal with the tyvars mentioned in signatures
tcAddScopedTyVars (collectRuleBndrSigTys vars) (
-- Ditto forall'd variables
- mapNF_Tc new_id vars `thenNF_Tc` \ ids ->
- tcExtendLocalValEnv ids $
+ mappM new_id vars `thenM` \ ids ->
+ tcExtendLocalValEnv ids $
-- Now LHS and RHS
- tcMonoExpr lhs rule_ty `thenTc` \ (lhs', lhs_lie) ->
- tcMonoExpr rhs rule_ty `thenTc` \ (rhs', rhs_lie) ->
+ getLIE (tcMonoExpr lhs rule_ty) `thenM` \ (lhs', lhs_lie) ->
+ getLIE (tcMonoExpr rhs rule_ty) `thenM` \ (rhs', rhs_lie) ->
- returnTc (ids, lhs', rhs', lhs_lie, rhs_lie)
- ) `thenTc` \ (ids, lhs', rhs', lhs_lie, rhs_lie) ->
+ returnM (ids, lhs', rhs', lhs_lie, rhs_lie)
+ ) `thenM` \ (ids, lhs', rhs', lhs_lie, rhs_lie) ->
-- Check that LHS has no overloading at all
- tcSimplifyToDicts lhs_lie `thenTc` \ (lhs_dicts, lhs_binds) ->
+ getLIE (tcSimplifyToDicts lhs_lie) `thenM` \ (lhs_binds, lhs_dicts) ->
-- Gather the template variables and tyvars
let
--
tcSimplifyInferCheck (text "tcRule")
forall_tvs
- lhs_dicts rhs_lie `thenTc` \ (forall_tvs1, lie', rhs_binds) ->
+ lhs_dicts rhs_lie `thenM` \ (forall_tvs1, rhs_binds) ->
- returnTc (lie', HsRule name act
- (map RuleBndr (forall_tvs1 ++ tpl_ids)) -- yuk
- (mkHsLet lhs_binds lhs')
- (mkHsLet rhs_binds rhs')
- src_loc)
+ returnM (HsRule name act
+ (map RuleBndr (forall_tvs1 ++ tpl_ids)) -- yuk
+ (mkHsLet lhs_binds lhs')
+ (mkHsLet rhs_binds rhs')
+ src_loc)
where
- new_id (RuleBndr var) = newTyVarTy openTypeKind `thenNF_Tc` \ ty ->
- returnNF_Tc (mkLocalId var ty)
- new_id (RuleBndrSig var rn_ty) = tcHsSigType (RuleSigCtxt var) rn_ty `thenTc` \ ty ->
- returnNF_Tc (mkLocalId var ty)
+ new_id (RuleBndr var) = newTyVarTy openTypeKind `thenM` \ ty ->
+ returnM (mkLocalId var ty)
+ new_id (RuleBndrSig var rn_ty) = tcHsSigType (RuleSigCtxt var) rn_ty `thenM` \ ty ->
+ returnM (mkLocalId var ty)
ruleCtxt name = ptext SLIT("When checking the transformation rule") <+>
doubleQuotes (ftext name)
tcSimplifyInfer, tcSimplifyInferCheck,
tcSimplifyCheck, tcSimplifyRestricted,
tcSimplifyToDicts, tcSimplifyIPs, tcSimplifyTop,
+ tcSimplifyBracket,
tcSimplifyDeriv, tcSimplifyDefault,
bindInstsOfLocalFuns
TcMonoBinds, TcDictBinds
)
-import TcMonad
+import TcRnMonad
import Inst ( lookupInst, LookupInstResult(..),
- tyVarsOfInst, predsOfInsts, predsOfInst, newDicts,
+ tyVarsOfInst, fdPredsOfInsts, fdPredsOfInst, newDicts,
isDict, isClassDict, isLinearInst, linearInstType,
isStdClassTyVarDict, isMethodFor, isMethod,
instToId, tyVarsOfInsts, cloneDict,
newDictsFromOld, newMethodAtLoc,
getDictClassTys, isTyVarDict,
instLoc, pprInst, zonkInst, tidyInsts, tidyMoreInsts,
- Inst, LIE, pprInsts, pprInstsInFull,
- mkLIE, lieToList
+ Inst, pprInsts, pprInstsInFull,
+ isIPDict, isInheritableInst
)
-import TcEnv ( tcGetGlobalTyVars, tcGetInstEnv, tcLookupGlobalId )
+import TcEnv ( tcGetGlobalTyVars, tcGetInstEnv, tcLookupId )
import InstEnv ( lookupInstEnv, classInstEnv, InstLookupResult(..) )
import TcMType ( zonkTcTyVarsAndFV, tcInstTyVars, checkAmbiguity )
import TcType ( TcTyVar, TcTyVarSet, ThetaType, TyVarDetails(VanillaTv),
mkClassPred, isOverloadedTy, mkTyConApp,
mkTyVarTy, tcGetTyVar, isTyVarClassPred, mkTyVarTys,
- tyVarsOfPred, isIPPred, isInheritablePred, predHasFDs )
+ tyVarsOfPred )
import Id ( idType, mkUserLocal )
import Var ( TyVar )
import Name ( getOccName, getSrcLoc )
tcSimplifyInfer
:: SDoc
-> TcTyVarSet -- fv(T); type vars
- -> LIE -- Wanted
+ -> [Inst] -- Wanted
-> TcM ([TcTyVar], -- Tyvars to quantify (zonked)
- LIE, -- Free
TcDictBinds, -- Bindings
[TcId]) -- Dict Ids that must be bound here (zonked)
+ -- Any free (escaping) Insts are tossed into the environment
\end{code}
\begin{code}
tcSimplifyInfer doc tau_tvs wanted_lie
= inferLoop doc (varSetElems tau_tvs)
- (lieToList wanted_lie) `thenTc` \ (qtvs, frees, binds, irreds) ->
+ wanted_lie `thenM` \ (qtvs, frees, binds, irreds) ->
-- Check for non-generalisable insts
- mapTc_ addCantGenErr (filter (not . instCanBeGeneralised) irreds) `thenTc_`
+ mappM_ addCantGenErr (filter (not . instCanBeGeneralised) irreds) `thenM_`
- returnTc (qtvs, mkLIE frees, binds, map instToId irreds)
+ extendLIEs frees `thenM_`
+ returnM (qtvs, binds, map instToId irreds)
inferLoop doc tau_tvs wanteds
= -- Step 1
- zonkTcTyVarsAndFV tau_tvs `thenNF_Tc` \ tau_tvs' ->
- mapNF_Tc zonkInst wanteds `thenNF_Tc` \ wanteds' ->
- tcGetGlobalTyVars `thenNF_Tc` \ gbl_tvs ->
+ zonkTcTyVarsAndFV tau_tvs `thenM` \ tau_tvs' ->
+ mappM zonkInst wanteds `thenM` \ wanteds' ->
+ tcGetGlobalTyVars `thenM` \ gbl_tvs ->
let
- preds = predsOfInsts wanteds'
+ preds = fdPredsOfInsts wanteds'
qtvs = grow preds tau_tvs' `minusVarSet` oclose preds gbl_tvs
try_me inst
| otherwise = ReduceMe -- Lits and Methods
in
-- Step 2
- reduceContext doc try_me [] wanteds' `thenTc` \ (no_improvement, frees, binds, irreds) ->
+ reduceContext doc try_me [] wanteds' `thenM` \ (no_improvement, frees, binds, irreds) ->
-- Step 3
if no_improvement then
- returnTc (varSetElems qtvs, frees, binds, irreds)
+ returnM (varSetElems qtvs, frees, binds, irreds)
else
-- If improvement did some unification, we go round again. There
-- are two subtleties:
-- However, NOTICE that when we are done, we might have some bindings, but
-- the final qtvs might be empty. See [NO TYVARS] below.
- inferLoop doc tau_tvs (irreds ++ frees) `thenTc` \ (qtvs1, frees1, binds1, irreds1) ->
- returnTc (qtvs1, frees1, binds `AndMonoBinds` binds1, irreds1)
+ inferLoop doc tau_tvs (irreds ++ frees) `thenM` \ (qtvs1, frees1, binds1, irreds1) ->
+ returnM (qtvs1, frees1, binds `AndMonoBinds` binds1, irreds1)
\end{code}
Example [LOOP]
\begin{code}
isFreeWhenInferring :: TyVarSet -> Inst -> Bool
isFreeWhenInferring qtvs inst
- = isFreeWrtTyVars qtvs inst -- Constrains no quantified vars
- && all isInheritablePred (predsOfInst inst) -- And no implicit parameter involved
- -- (see "Notes on implicit parameters")
+ = isFreeWrtTyVars qtvs inst -- Constrains no quantified vars
+ && isInheritableInst inst -- And no implicit parameter involved
+ -- (see "Notes on implicit parameters")
isFreeWhenChecking :: TyVarSet -- Quantified tyvars
-> NameSet -- Quantified implicit parameters
:: SDoc
-> [TcTyVar] -- Quantify over these
-> [Inst] -- Given
- -> LIE -- Wanted
- -> TcM (LIE, -- Free
- TcDictBinds) -- Bindings
+ -> [Inst] -- Wanted
+ -> TcM TcDictBinds -- Bindings
-- tcSimplifyCheck is used when checking expression type signatures,
-- class decls, instance decls etc.
-- need to worry about setting them before calling tcSimplifyCheck
tcSimplifyCheck doc qtvs givens wanted_lie
= tcSimplCheck doc get_qtvs
- givens wanted_lie `thenTc` \ (qtvs', frees, binds) ->
- returnTc (frees, binds)
+ givens wanted_lie `thenM` \ (qtvs', binds) ->
+ returnM binds
where
get_qtvs = zonkTcTyVarsAndFV qtvs
:: SDoc
-> TcTyVarSet -- fv(T)
-> [Inst] -- Given
- -> LIE -- Wanted
+ -> [Inst] -- Wanted
-> TcM ([TcTyVar], -- Variables over which to quantify
- LIE, -- Free
TcDictBinds) -- Bindings
tcSimplifyInferCheck doc tau_tvs givens wanted_lie
-- f isn't quantified over b.
all_tvs = varSetElems (tau_tvs `unionVarSet` tyVarsOfInsts givens)
- get_qtvs = zonkTcTyVarsAndFV all_tvs `thenNF_Tc` \ all_tvs' ->
- tcGetGlobalTyVars `thenNF_Tc` \ gbl_tvs ->
+ get_qtvs = zonkTcTyVarsAndFV all_tvs `thenM` \ all_tvs' ->
+ tcGetGlobalTyVars `thenM` \ gbl_tvs ->
let
qtvs = all_tvs' `minusVarSet` gbl_tvs
-- We could close gbl_tvs, but its not necessary for
-- soundness, and it'll only affect which tyvars, not which
-- dictionaries, we quantify over
in
- returnNF_Tc qtvs
+ returnM qtvs
\end{code}
Here is the workhorse function for all three wrappers.
\begin{code}
tcSimplCheck doc get_qtvs givens wanted_lie
- = check_loop givens (lieToList wanted_lie) `thenTc` \ (qtvs, frees, binds, irreds) ->
+ = check_loop givens wanted_lie `thenM` \ (qtvs, frees, binds, irreds) ->
-- Complain about any irreducible ones
- complainCheck doc givens irreds `thenNF_Tc_`
+ complainCheck doc givens irreds `thenM_`
-- Done
- returnTc (qtvs, mkLIE frees, binds)
+ extendLIEs frees `thenM_`
+ returnM (qtvs, binds)
where
ip_set = mkNameSet (ipNamesOfInsts givens)
check_loop givens wanteds
= -- Step 1
- mapNF_Tc zonkInst givens `thenNF_Tc` \ givens' ->
- mapNF_Tc zonkInst wanteds `thenNF_Tc` \ wanteds' ->
- get_qtvs `thenNF_Tc` \ qtvs' ->
+ mappM zonkInst givens `thenM` \ givens' ->
+ mappM zonkInst wanteds `thenM` \ wanteds' ->
+ get_qtvs `thenM` \ qtvs' ->
-- Step 2
let
try_me inst | isFreeWhenChecking qtvs' ip_set inst = Free
| otherwise = ReduceMe
in
- reduceContext doc try_me givens' wanteds' `thenTc` \ (no_improvement, frees, binds, irreds) ->
+ reduceContext doc try_me givens' wanteds' `thenM` \ (no_improvement, frees, binds, irreds) ->
-- Step 3
if no_improvement then
- returnTc (varSetElems qtvs', frees, binds, irreds)
+ returnM (varSetElems qtvs', frees, binds, irreds)
else
- check_loop givens' (irreds ++ frees) `thenTc` \ (qtvs', frees1, binds1, irreds1) ->
- returnTc (qtvs', frees1, binds `AndMonoBinds` binds1, irreds1)
+ check_loop givens' (irreds ++ frees) `thenM` \ (qtvs', frees1, binds1, irreds1) ->
+ returnM (qtvs', frees1, binds `AndMonoBinds` binds1, irreds1)
\end{code}
-- i.e. ones subject to the monomorphism restriction
:: SDoc
-> TcTyVarSet -- Free in the type of the RHSs
- -> LIE -- Free in the RHSs
+ -> [Inst] -- Free in the RHSs
-> TcM ([TcTyVar], -- Tyvars to quantify (zonked)
- LIE, -- Free
TcDictBinds) -- Bindings
-tcSimplifyRestricted doc tau_tvs wanted_lie
+tcSimplifyRestricted doc tau_tvs wanteds
= -- First squash out all methods, to find the constrained tyvars
-- We can't just take the free vars of wanted_lie because that'll
-- have methods that may incidentally mention entirely unconstrained variables
-- We want to infer the polymorphic type
-- foo :: forall b. b -> b
let
- wanteds = lieToList wanted_lie
try_me inst = ReduceMe -- Reduce as far as we can. Don't stop at
-- dicts; the idea is to get rid of as many type
-- variables as possible, and we don't want to stop
-- at (say) Monad (ST s), because that reduces
-- immediately, with no constraint on s.
in
- simpleReduceLoop doc try_me wanteds `thenTc` \ (_, _, constrained_dicts) ->
+ simpleReduceLoop doc try_me wanteds `thenM` \ (_, _, constrained_dicts) ->
-- Next, figure out the tyvars we will quantify over
- zonkTcTyVarsAndFV (varSetElems tau_tvs) `thenNF_Tc` \ tau_tvs' ->
- tcGetGlobalTyVars `thenNF_Tc` \ gbl_tvs ->
+ zonkTcTyVarsAndFV (varSetElems tau_tvs) `thenM` \ tau_tvs' ->
+ tcGetGlobalTyVars `thenM` \ gbl_tvs ->
let
constrained_tvs = tyVarsOfInsts constrained_dicts
- qtvs = (tau_tvs' `minusVarSet` oclose (predsOfInsts constrained_dicts) gbl_tvs)
+ qtvs = (tau_tvs' `minusVarSet` oclose (fdPredsOfInsts constrained_dicts) gbl_tvs)
`minusVarSet` constrained_tvs
in
-- Remember that we may need to do *some* simplification, to
-- (for example) squash {Monad (ST s)} into {}. It's not enough
-- just to float all constraints
- mapNF_Tc zonkInst (lieToList wanted_lie) `thenNF_Tc` \ wanteds' ->
+ mappM zonkInst wanteds `thenM` \ wanteds' ->
let
try_me inst | isFreeWrtTyVars qtvs inst = Free
| otherwise = ReduceMe
in
- reduceContext doc try_me [] wanteds' `thenTc` \ (no_improvement, frees, binds, irreds) ->
+ reduceContext doc try_me [] wanteds' `thenM` \ (no_improvement, frees, binds, irreds) ->
ASSERT( no_improvement )
ASSERT( null irreds )
-- No need to loop because simpleReduceLoop will have
-- already done any improvement necessary
- returnTc (varSetElems qtvs, mkLIE frees, binds)
+ extendLIEs frees `thenM_`
+ returnM (varSetElems qtvs, binds)
\end{code}
Hence "DontReduce NoSCs"
\begin{code}
-tcSimplifyToDicts :: LIE -> TcM ([Inst], TcDictBinds)
-tcSimplifyToDicts wanted_lie
- = simpleReduceLoop doc try_me wanteds `thenTc` \ (frees, binds, irreds) ->
+tcSimplifyToDicts :: [Inst] -> TcM (TcDictBinds)
+tcSimplifyToDicts wanteds
+ = simpleReduceLoop doc try_me wanteds `thenM` \ (frees, binds, irreds) ->
-- Since try_me doesn't look at types, we don't need to
-- do any zonking, so it's safe to call reduceContext directly
ASSERT( null frees )
- returnTc (irreds, binds)
+ extendLIEs irreds `thenM_`
+ returnM binds
where
doc = text "tcSimplifyToDicts"
- wanteds = lieToList wanted_lie
-- Reduce methods and lits only; stop as soon as we get a dictionary
try_me inst | isDict inst = DontReduce NoSCs
\end{code}
+
+tcSimplifyBracket is used when simplifying the constraints arising from
+a Template Haskell bracket [| ... |]. We want to check that there aren't
+any constraints that can't be satisfied (e.g. Show Foo, where Foo has no
+Show instance), but we aren't otherwise interested in the results.
+Nor do we care about ambiguous dictionaries etc. We will type check
+this bracket again at its usage site.
+
+\begin{code}
+tcSimplifyBracket :: [Inst] -> TcM ()
+tcSimplifyBracket wanteds
+ = simpleReduceLoop doc try_me wanteds `thenM_`
+ returnM ()
+
+ where
+ doc = text "tcSimplifyBracket"
+ try_me inst = ReduceMe
+\end{code}
+
+
%************************************************************************
%* *
\subsection{Filtering at a dynamic binding}
\begin{code}
tcSimplifyIPs :: [Inst] -- The implicit parameters bound here
- -> LIE
- -> TcM (LIE, TcDictBinds)
-tcSimplifyIPs given_ips wanted_lie
- = simpl_loop given_ips wanteds `thenTc` \ (frees, binds) ->
- returnTc (mkLIE frees, binds)
+ -> [Inst] -- Wanted
+ -> TcM TcDictBinds
+tcSimplifyIPs given_ips wanteds
+ = simpl_loop given_ips wanteds `thenM` \ (frees, binds) ->
+ extendLIEs frees `thenM_`
+ returnM binds
where
doc = text "tcSimplifyIPs" <+> ppr given_ips
- wanteds = lieToList wanted_lie
ip_set = mkNameSet (ipNamesOfInsts given_ips)
-- Simplify any methods that mention the implicit parameter
| otherwise = ReduceMe
simpl_loop givens wanteds
- = mapNF_Tc zonkInst givens `thenNF_Tc` \ givens' ->
- mapNF_Tc zonkInst wanteds `thenNF_Tc` \ wanteds' ->
+ = mappM zonkInst givens `thenM` \ givens' ->
+ mappM zonkInst wanteds `thenM` \ wanteds' ->
- reduceContext doc try_me givens' wanteds' `thenTc` \ (no_improvement, frees, binds, irreds) ->
+ reduceContext doc try_me givens' wanteds' `thenM` \ (no_improvement, frees, binds, irreds) ->
if no_improvement then
ASSERT( null irreds )
- returnTc (frees, binds)
+ returnM (frees, binds)
else
- simpl_loop givens' (irreds ++ frees) `thenTc` \ (frees1, binds1) ->
- returnTc (frees1, binds `AndMonoBinds` binds1)
+ simpl_loop givens' (irreds ++ frees) `thenM` \ (frees1, binds1) ->
+ returnM (frees1, binds `AndMonoBinds` binds1)
\end{code}
@LIE@), as well as the @HsBinds@ generated.
\begin{code}
-bindInstsOfLocalFuns :: LIE -> [TcId] -> TcM (LIE, TcMonoBinds)
+bindInstsOfLocalFuns :: [Inst] -> [TcId] -> TcM TcMonoBinds
-bindInstsOfLocalFuns init_lie local_ids
+bindInstsOfLocalFuns wanteds local_ids
| null overloaded_ids
-- Common case
- = returnTc (init_lie, EmptyMonoBinds)
+ = extendLIEs wanteds `thenM_`
+ returnM EmptyMonoBinds
| otherwise
- = simpleReduceLoop doc try_me wanteds `thenTc` \ (frees, binds, irreds) ->
+ = simpleReduceLoop doc try_me wanteds `thenM` \ (frees, binds, irreds) ->
ASSERT( null irreds )
- returnTc (mkLIE frees, binds)
+ extendLIEs frees `thenM_`
+ returnM binds
where
doc = text "bindInsts" <+> ppr local_ids
- wanteds = lieToList init_lie
overloaded_ids = filter is_overloaded local_ids
is_overloaded id = isOverloadedTy (idType id)
\begin{code}
extractResults :: Avails
-> [Inst] -- Wanted
- -> NF_TcM (TcDictBinds, -- Bindings
+ -> TcM (TcDictBinds, -- Bindings
[Inst], -- Irreducible ones
[Inst]) -- Free ones
= go avails EmptyMonoBinds [] [] wanteds
where
go avails binds irreds frees []
- = returnNF_Tc (binds, irreds, frees)
+ = returnM (binds, irreds, frees)
go avails binds irreds frees (w:ws)
= case lookupFM avails w of
new_binds = addBind binds w rhs
Just (Linear n split_inst avail) -- Transform Linear --> LinRhss
- -> get_root irreds frees avail w `thenNF_Tc` \ (irreds', frees', root_id) ->
- split n (instToId split_inst) root_id w `thenNF_Tc` \ (binds', rhss) ->
+ -> get_root irreds frees avail w `thenM` \ (irreds', frees', root_id) ->
+ split n (instToId split_inst) root_id w `thenM` \ (binds', rhss) ->
go (addToFM avails w (LinRhss rhss))
(binds `AndMonoBinds` binds')
irreds' frees' (split_inst : w : ws)
new_binds = addBind binds w rhs
new_avails = addToFM avails w (LinRhss rhss)
- get_root irreds frees (Given id _) w = returnNF_Tc (irreds, frees, id)
- get_root irreds frees Irred w = cloneDict w `thenNF_Tc` \ w' ->
- returnNF_Tc (w':irreds, frees, instToId w')
- get_root irreds frees IsFree w = cloneDict w `thenNF_Tc` \ w' ->
- returnNF_Tc (irreds, w':frees, instToId w')
+ get_root irreds frees (Given id _) w = returnM (irreds, frees, id)
+ get_root irreds frees Irred w = cloneDict w `thenM` \ w' ->
+ returnM (w':irreds, frees, instToId w')
+ get_root irreds frees IsFree w = cloneDict w `thenM` \ w' ->
+ returnM (irreds, w':frees, instToId w')
add_given avails w
| instBindingRequired w = addToFM avails w (Given (instToId w) True)
split :: Int -> TcId -> TcId -> Inst
- -> NF_TcM (TcDictBinds, [TcExpr])
+ -> TcM (TcDictBinds, [TcExpr])
-- (split n split_id root_id wanted) returns
-- * a list of 'n' expressions, all of which witness 'avail'
-- * a bunch of auxiliary bindings to support these expressions
occ = getOccName id
loc = getSrcLoc id
- go 1 = returnNF_Tc (EmptyMonoBinds, [HsVar root_id])
+ go 1 = returnM (EmptyMonoBinds, [HsVar root_id])
- go n = go ((n+1) `div` 2) `thenNF_Tc` \ (binds1, rhss) ->
- expand n rhss `thenNF_Tc` \ (binds2, rhss') ->
- returnNF_Tc (binds1 `AndMonoBinds` binds2, rhss')
+ go n = go ((n+1) `div` 2) `thenM` \ (binds1, rhss) ->
+ expand n rhss `thenM` \ (binds2, rhss') ->
+ returnM (binds1 `AndMonoBinds` binds2, rhss')
-- (expand n rhss)
-- Given ((n+1)/2) rhss, make n rhss, using auxiliary bindings
-- [fst x, snd x, rhs2] )
expand n rhss
| n `rem` 2 == 0 = go rhss -- n is even
- | otherwise = go (tail rhss) `thenNF_Tc` \ (binds', rhss') ->
- returnNF_Tc (binds', head rhss : rhss')
+ | otherwise = go (tail rhss) `thenM` \ (binds', rhss') ->
+ returnM (binds', head rhss : rhss')
where
- go rhss = mapAndUnzipNF_Tc do_one rhss `thenNF_Tc` \ (binds', rhss') ->
- returnNF_Tc (andMonoBindList binds', concat rhss')
+ go rhss = mapAndUnzipM do_one rhss `thenM` \ (binds', rhss') ->
+ returnM (andMonoBindList binds', concat rhss')
- do_one rhs = tcGetUnique `thenNF_Tc` \ uniq ->
- tcLookupGlobalId fstName `thenNF_Tc` \ fst_id ->
- tcLookupGlobalId sndName `thenNF_Tc` \ snd_id ->
+ do_one rhs = newUnique `thenM` \ uniq ->
+ tcLookupId fstName `thenM` \ fst_id ->
+ tcLookupId sndName `thenM` \ snd_id ->
let
x = mkUserLocal occ uniq pair_ty loc
in
- returnNF_Tc (VarMonoBind x (mk_app split_id rhs),
+ returnM (VarMonoBind x (mk_app split_id rhs),
[mk_fs_app fst_id ty x, mk_fs_app snd_id ty x])
mk_fs_app id ty var = HsVar id `TyApp` [ty,ty] `HsApp` HsVar var
[Inst]) -- Irreducible
simpleReduceLoop doc try_me wanteds
- = mapNF_Tc zonkInst wanteds `thenNF_Tc` \ wanteds' ->
- reduceContext doc try_me [] wanteds' `thenTc` \ (no_improvement, frees, binds, irreds) ->
+ = mappM zonkInst wanteds `thenM` \ wanteds' ->
+ reduceContext doc try_me [] wanteds' `thenM` \ (no_improvement, frees, binds, irreds) ->
if no_improvement then
- returnTc (frees, binds, irreds)
+ returnM (frees, binds, irreds)
else
- simpleReduceLoop doc try_me (irreds ++ frees) `thenTc` \ (frees1, binds1, irreds1) ->
- returnTc (frees1, binds `AndMonoBinds` binds1, irreds1)
+ simpleReduceLoop doc try_me (irreds ++ frees) `thenM` \ (frees1, binds1, irreds1) ->
+ returnM (frees1, binds `AndMonoBinds` binds1, irreds1)
\end{code}
-> (Inst -> WhatToDo)
-> [Inst] -- Given
-> [Inst] -- Wanted
- -> NF_TcM (Bool, -- True <=> improve step did no unification
+ -> TcM (Bool, -- True <=> improve step did no unification
[Inst], -- Free
TcDictBinds, -- Dictionary bindings
[Inst]) -- Irreducible
text "given" <+> ppr givens,
text "wanted" <+> ppr wanteds,
text "----------------------"
- ])) `thenNF_Tc_`
+ ])) `thenM_`
-- Build the Avail mapping from "givens"
- foldlNF_Tc addGiven emptyFM givens `thenNF_Tc` \ init_state ->
+ foldlM addGiven emptyFM givens `thenM` \ init_state ->
-- Do the real work
- reduceList (0,[]) try_me wanteds init_state `thenNF_Tc` \ avails ->
+ reduceList (0,[]) try_me wanteds init_state `thenM` \ avails ->
-- Do improvement, using everything in avails
-- In particular, avails includes all superclasses of everything
- tcImprove avails `thenTc` \ no_improvement ->
+ tcImprove avails `thenM` \ no_improvement ->
- extractResults avails wanteds `thenNF_Tc` \ (binds, irreds, frees) ->
+ extractResults avails wanteds `thenM` \ (binds, irreds, frees) ->
traceTc (text "reduceContext end" <+> (vcat [
text "----------------------",
text "frees" <+> ppr frees,
text "no_improvement =" <+> ppr no_improvement,
text "----------------------"
- ])) `thenNF_Tc_`
+ ])) `thenM_`
- returnTc (no_improvement, frees, binds, irreds)
+ returnM (no_improvement, frees, binds, irreds)
tcImprove avails
- = tcGetInstEnv `thenTc` \ inst_env ->
+ = tcGetInstEnv `thenM` \ inst_env ->
let
preds = [ (pred, pp_loc)
| inst <- keysFM avails,
let pp_loc = pprInstLoc (instLoc inst),
- pred <- predsOfInst inst,
- predHasFDs pred
+ pred <- fdPredsOfInst inst
]
-- Avails has all the superclasses etc (good)
-- It also has all the intermediates of the deduction (good)
eqns = improve (classInstEnv inst_env) preds
in
if null eqns then
- returnTc True
+ returnM True
else
- traceTc (ptext SLIT("Improve:") <+> vcat (map pprEquationDoc eqns)) `thenNF_Tc_`
- mapTc_ unify eqns `thenTc_`
- returnTc False
+ traceTc (ptext SLIT("Improve:") <+> vcat (map pprEquationDoc eqns)) `thenM_`
+ mappM_ unify eqns `thenM_`
+ returnM False
where
unify ((qtvs, t1, t2), doc)
- = tcAddErrCtxt doc $
- tcInstTyVars VanillaTv (varSetElems qtvs) `thenNF_Tc` \ (_, _, tenv) ->
+ = addErrCtxt doc $
+ tcInstTyVars VanillaTv (varSetElems qtvs) `thenM` \ (_, _, tenv) ->
unifyTauTy (substTy tenv t1) (substTy tenv t2)
\end{code}
#endif
go wanteds state
where
- go [] state = returnTc state
- go (w:ws) state = reduce (n+1, w:stack) try_me w state `thenTc` \ state' ->
+ go [] state = returnM state
+ go (w:ws) state = reduce (n+1, w:stack) try_me w state `thenM` \ state' ->
go ws state'
-- Base case: we're done!
-- It's the same as an existing inst, or a superclass thereof
| Just avail <- isAvailable state wanted
= if isLinearInst wanted then
- addLinearAvailable state avail wanted `thenNF_Tc` \ (state', wanteds') ->
+ addLinearAvailable state avail wanted `thenM` \ (state', wanteds') ->
reduceList stack try_me wanteds' state'
else
- returnTc state -- No op for non-linear things
+ returnM state -- No op for non-linear things
| otherwise
= case try_me wanted of {
try_simple addFree
; ReduceMe -> -- It should be reduced
- lookupInst wanted `thenNF_Tc` \ lookup_result ->
+ lookupInst wanted `thenM` \ lookup_result ->
case lookup_result of
- GenInst wanteds' rhs -> reduceList stack try_me wanteds' state `thenTc` \ state' ->
+ GenInst wanteds' rhs -> reduceList stack try_me wanteds' state `thenM` \ state' ->
addWanted state' wanted rhs wanteds'
SimpleInst rhs -> addWanted state wanted rhs []
}
where
try_simple do_this_otherwise
- = lookupInst wanted `thenNF_Tc` \ lookup_result ->
+ = lookupInst wanted `thenM` \ lookup_result ->
case lookup_result of
SimpleInst rhs -> addWanted state wanted rhs []
other -> do_this_otherwise state wanted
-- *not* by unique. So
-- d1::C Int == d2::C Int
-addLinearAvailable :: Avails -> Avail -> Inst -> NF_TcM (Avails, [Inst])
+addLinearAvailable :: Avails -> Avail -> Inst -> TcM (Avails, [Inst])
addLinearAvailable avails avail wanted
-- avails currently maps [wanted -> avail]
-- Extend avails to reflect a neeed for an extra copy of avail
| Just avail' <- split_avail avail
- = returnNF_Tc (addToFM avails wanted avail', [])
+ = returnM (addToFM avails wanted avail', [])
| otherwise
- = tcLookupGlobalId splitName `thenNF_Tc` \ split_id ->
+ = tcLookupId splitName `thenM` \ split_id ->
newMethodAtLoc (instLoc wanted) split_id
- [linearInstType wanted] `thenNF_Tc` \ (split_inst,_) ->
- returnNF_Tc (addToFM avails wanted (Linear 2 split_inst avail), [split_inst])
+ [linearInstType wanted] `thenM` \ split_inst ->
+ returnM (addToFM avails wanted (Linear 2 split_inst avail), [split_inst])
where
split_avail :: Avail -> Maybe Avail
split_avail other = pprPanic "addLinearAvailable" (ppr avail $$ ppr wanted $$ ppr avails)
-------------------------
-addFree :: Avails -> Inst -> NF_TcM Avails
+addFree :: Avails -> Inst -> TcM Avails
-- 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. This is really just
-- but a is not bound here, then we *don't* want to derive
-- dn from df here lest we lose sharing.
--
-addFree avails free = returnNF_Tc (addToFM avails free IsFree)
+addFree avails free = returnM (addToFM avails free IsFree)
-addWanted :: Avails -> Inst -> TcExpr -> [Inst] -> NF_TcM Avails
+addWanted :: Avails -> Inst -> TcExpr -> [Inst] -> TcM Avails
addWanted avails wanted rhs_expr wanteds
= ASSERT2( not (wanted `elemFM` avails), ppr wanted $$ ppr avails )
addAvailAndSCs avails wanted avail
avail | instBindingRequired wanted = Rhs rhs_expr wanteds
| otherwise = ASSERT( null wanteds ) NoRhs
-addGiven :: Avails -> Inst -> NF_TcM Avails
+addGiven :: Avails -> Inst -> TcM Avails
addGiven state given = addAvailAndSCs state given (Given (instToId given) False)
-- No ASSERT( not (given `elemFM` avails) ) because in an instance
-- decl for Ord t we can add both Ord t and Eq t as 'givens',
-- so the assert isn't true
-addIrred :: WantSCs -> Avails -> Inst -> NF_TcM Avails
-addIrred NoSCs avails irred = returnNF_Tc (addToFM avails irred Irred)
+addIrred :: WantSCs -> Avails -> Inst -> TcM Avails
+addIrred NoSCs avails irred = returnM (addToFM avails irred Irred)
addIrred AddSCs avails irred = ASSERT2( not (irred `elemFM` avails), ppr irred $$ ppr avails )
addAvailAndSCs avails irred Irred
-addAvailAndSCs :: Avails -> Inst -> Avail -> NF_TcM Avails
+addAvailAndSCs :: Avails -> Inst -> Avail -> TcM Avails
addAvailAndSCs avails inst avail
- | not (isClassDict inst) = returnNF_Tc avails1
+ | not (isClassDict inst) = returnM avails1
| otherwise = addSCs is_loop avails1 inst
where
avails1 = addToFM avails inst avail
Just avail -> findAllDeps avails avail
Nothing -> []
-addSCs :: (Inst -> Bool) -> Avails -> Inst -> NF_TcM Avails
+addSCs :: (Inst -> Bool) -> Avails -> Inst -> TcM Avails
-- Add all the superclasses of the Inst to Avails
-- The first param says "dont do this because the original thing
-- depends on this one, so you'd build a loop"
-- Invariant: the Inst is already in Avails.
addSCs is_loop avails dict
- = newDictsFromOld dict sc_theta' `thenNF_Tc` \ sc_dicts ->
- foldlNF_Tc add_sc avails (zipEqual "add_scs" sc_dicts sc_sels)
+ = newDictsFromOld dict sc_theta' `thenM` \ sc_dicts ->
+ foldlM add_sc avails (zipEqual "add_scs" sc_dicts sc_sels)
where
(clas, tys) = getDictClassTys dict
(tyvars, sc_theta, sc_sels, _) = classBigSig clas
add_sc avails (sc_dict, sc_sel) -- Add it, and its superclasses
= case lookupFM avails sc_dict of
- Just (Given _ _) -> returnNF_Tc avails -- Given is cheaper than
+ Just (Given _ _) -> returnM avails -- Given is cheaper than
-- a superclass selection
- Just other | is_loop sc_dict -> returnNF_Tc avails -- See Note [SUPERCLASS-LOOP]
- | otherwise -> returnNF_Tc avails' -- SCs already added
+ Just other | is_loop sc_dict -> returnM avails -- See Note [SUPERCLASS-LOOP]
+ | otherwise -> returnM avails' -- SCs already added
Nothing -> addSCs is_loop avails' sc_dict
where
\begin{code}
-tcSimplifyTop :: LIE -> TcM TcDictBinds
-tcSimplifyTop wanted_lie
- = simpleReduceLoop (text "tcSimplTop") reduceMe wanteds `thenTc` \ (frees, binds, irreds) ->
+tcSimplifyTop :: [Inst] -> TcM TcDictBinds
+tcSimplifyTop wanteds
+ = simpleReduceLoop (text "tcSimplTop") reduceMe wanteds `thenM` \ (frees, binds, irreds) ->
ASSERT( null frees )
let
-- Collect together all the bad guys
bad_guys = non_stds ++ concat std_bads
(tidy_env, tidy_dicts) = tidyInsts bad_guys
- (bad_ips, non_ips) = partition is_ip tidy_dicts
+ (bad_ips, non_ips) = partition isIPDict tidy_dicts
(no_insts, ambigs) = partition no_inst non_ips
- is_ip d = any isIPPred (predsOfInst d)
no_inst d = not (isTyVarDict d) || tyVarsOfInst d `subVarSet` fixed_tvs
- fixed_tvs = oclose (predsOfInsts tidy_dicts) emptyVarSet
+ fixed_tvs = oclose (fdPredsOfInsts tidy_dicts) emptyVarSet
in
-- Report definite errors
- mapNF_Tc (addTopInstanceErrs tidy_env) (groupInsts no_insts) `thenNF_Tc_`
- mapNF_Tc (addTopIPErrs tidy_env) (groupInsts bad_ips) `thenNF_Tc_`
+ mappM (addTopInstanceErrs tidy_env) (groupInsts no_insts) `thenM_`
+ mappM (addTopIPErrs tidy_env) (groupInsts bad_ips) `thenM_`
-- Deal with ambiguity errors, but only if
-- if there has not been an error so far; errors often
-- give rise to spurious ambiguous Insts
- ifErrsTc (returnTc []) (
+ ifErrsM (returnM []) (
-- Complain about the ones that don't fall under
-- the Haskell rules for disambiguation
-- e.g. Num (IO a) and Eq (Int -> Int)
-- and ambiguous dictionaries
-- e.g. Num a
- mapNF_Tc (addAmbigErr tidy_env) ambigs `thenNF_Tc_`
+ mappM (addAmbigErr tidy_env) ambigs `thenM_`
-- Disambiguate the ones that look feasible
- mapTc disambigGroup std_oks
- ) `thenTc` \ binds_ambig ->
+ mappM disambigGroup std_oks
+ ) `thenM` \ binds_ambig ->
- returnTc (binds `andMonoBinds` andMonoBindList binds_ambig)
- where
- wanteds = lieToList wanted_lie
+ returnM (binds `andMonoBinds` andMonoBindList binds_ambig)
----------------------------------
d1 `cmp_by_tyvar` d2 = get_tv d1 `compare` get_tv d2
-- default list which can satisfy all the ambiguous classes.
-- For example, if Real a is reqd, but the only type in the
-- default list is Int.
- tcGetDefaultTys `thenNF_Tc` \ default_tys ->
+ getDefaultTys `thenM` \ default_tys ->
let
try_default [] -- No defaults work, so fail
- = failTc
+ = failM
try_default (default_ty : default_tys)
= tryTc_ (try_default default_tys) $ -- If default_ty fails, we try
-- default_tys instead
- tcSimplifyDefault theta `thenTc` \ _ ->
- returnTc default_ty
+ tcSimplifyDefault theta `thenM` \ _ ->
+ returnM default_ty
where
theta = [mkClassPred clas [default_ty] | clas <- classes]
in
-- See if any default works, and if so bind the type variable to it
-- If not, add an AmbigErr
- recoverTc (addAmbigErrs dicts `thenNF_Tc_`
- returnTc EmptyMonoBinds) $
+ recoverM (addAmbigErrs dicts `thenM_`
+ returnM EmptyMonoBinds) $
- try_default default_tys `thenTc` \ chosen_default_ty ->
+ try_default default_tys `thenM` \ chosen_default_ty ->
-- Bind the type variable and reduce the context, for real this time
- unifyTauTy chosen_default_ty (mkTyVarTy tyvar) `thenTc_`
+ unifyTauTy chosen_default_ty (mkTyVarTy tyvar) `thenM_`
simpleReduceLoop (text "disambig" <+> ppr dicts)
- reduceMe dicts `thenTc` \ (frees, binds, ambigs) ->
+ reduceMe dicts `thenM` \ (frees, binds, ambigs) ->
WARN( not (null frees && null ambigs), ppr frees $$ ppr ambigs )
- warnDefault dicts chosen_default_ty `thenTc_`
- returnTc binds
+ warnDefault dicts chosen_default_ty `thenM_`
+ returnM binds
| all isCreturnableClass classes
= -- Default CCall stuff to (); we don't even both to check that () is an
-- instance of CReturnable, because we know it is.
- unifyTauTy (mkTyVarTy tyvar) unitTy `thenTc_`
- returnTc EmptyMonoBinds
+ unifyTauTy (mkTyVarTy tyvar) unitTy `thenM_`
+ returnM EmptyMonoBinds
| otherwise -- No defaults
- = addAmbigErrs dicts `thenNF_Tc_`
- returnTc EmptyMonoBinds
+ = addAmbigErrs dicts `thenM_`
+ returnM EmptyMonoBinds
where
tyvar = get_tv (head dicts) -- Should be non-empty
-> TcM ThetaType -- Needed
tcSimplifyDeriv tyvars theta
- = tcInstTyVars VanillaTv tyvars `thenNF_Tc` \ (tvs, _, tenv) ->
+ = tcInstTyVars VanillaTv tyvars `thenM` \ (tvs, _, tenv) ->
-- The main loop may do unification, and that may crash if
-- it doesn't see a TcTyVar, so we have to instantiate. Sigh
-- ToDo: what if two of them do get unified?
- newDicts DataDeclOrigin (substTheta tenv theta) `thenNF_Tc` \ wanteds ->
- simpleReduceLoop doc reduceMe wanteds `thenTc` \ (frees, _, irreds) ->
+ newDicts DataDeclOrigin (substTheta tenv theta) `thenM` \ wanteds ->
+ simpleReduceLoop doc reduceMe wanteds `thenM` \ (frees, _, irreds) ->
ASSERT( null frees ) -- reduceMe never returns Free
- doptsTc Opt_AllowUndecidableInstances `thenNF_Tc` \ undecidable_ok ->
+ doptM Opt_AllowUndecidableInstances `thenM` \ undecidable_ok ->
let
tv_set = mkVarSet tvs
simpl_theta = map dictPred irreds -- reduceMe squashes all non-dicts
= addErrTc (badDerivedPred pred)
| otherwise
- = returnNF_Tc ()
+ = returnM ()
where
pred_tyvars = tyVarsOfPred pred
-- but the result should mention TyVars not TcTyVars
in
- mapNF_Tc check_pred simpl_theta `thenNF_Tc_`
- checkAmbiguity tvs simpl_theta tv_set `thenTc_`
- returnTc (substTheta rev_env simpl_theta)
+ mappM check_pred simpl_theta `thenM_`
+ checkAmbiguity tvs simpl_theta tv_set `thenM_`
+ returnM (substTheta rev_env simpl_theta)
where
doc = ptext SLIT("deriving classes for a data type")
\end{code}
-> TcM ()
tcSimplifyDefault theta
- = newDicts DataDeclOrigin theta `thenNF_Tc` \ wanteds ->
- simpleReduceLoop doc reduceMe wanteds `thenTc` \ (frees, _, irreds) ->
+ = newDicts DataDeclOrigin theta `thenM` \ wanteds ->
+ simpleReduceLoop doc reduceMe wanteds `thenM` \ (frees, _, irreds) ->
ASSERT( null frees ) -- try_me never returns Free
- mapNF_Tc (addErrTc . noInstErr) irreds `thenNF_Tc_`
+ mappM (addErrTc . noInstErr) irreds `thenM_`
if null irreds then
- returnTc ()
+ returnM ()
else
- failTc
+ failM
where
doc = ptext SLIT("default declaration")
\end{code}
ptext SLIT("for") <+> pprInsts tidy_dicts)
addAmbigErrs dicts
- = mapNF_Tc (addAmbigErr tidy_env) tidy_dicts
+ = mappM (addAmbigErr tidy_env) tidy_dicts
where
(tidy_env, tidy_dicts) = tidyInsts dicts
ambig_tvs = varSetElems (tyVarsOfInst tidy_dict)
warnDefault dicts default_ty
- = doptsTc Opt_WarnTypeDefaults `thenTc` \ warn_flag ->
- tcAddSrcLoc (get_loc (head dicts)) (warnTc warn_flag warn_msg)
+ = doptM Opt_WarnTypeDefaults `thenM` \ warn_flag ->
+ addSrcLoc (get_loc (head dicts)) (warnTc warn_flag warn_msg)
where
-- Tidy them first
(_, tidy_dicts) = tidyInsts dicts
pprInstsInFull tidy_dicts]
complainCheck doc givens irreds
- = mapNF_Tc zonkInst given_dicts_and_ips `thenNF_Tc` \ givens' ->
- mapNF_Tc (addNoInstanceErrs doc givens') (groupInsts irreds) `thenNF_Tc_`
- returnNF_Tc ()
+ = mappM zonkInst given_dicts_and_ips `thenM` \ givens' ->
+ mappM (addNoInstanceErrs doc givens') (groupInsts irreds) `thenM_`
+ returnM ()
where
given_dicts_and_ips = filter (not . isMethod) givens
-- Filter out methods, which are only added to
-- the given set as an optimisation
addNoInstanceErrs what_doc givens dicts
- = getDOptsTc `thenNF_Tc` \ dflags ->
- tcGetInstEnv `thenNF_Tc` \ inst_env ->
+ = getDOpts `thenM` \ dflags ->
+ tcGetInstEnv `thenM` \ inst_env ->
let
(tidy_env1, tidy_givens) = tidyInsts givens
(tidy_env2, tidy_dicts) = tidyMoreInsts tidy_env1 dicts
--- /dev/null
+module TcSplice where
+
+tcSpliceExpr :: Name.Name
+ -> RnHsSyn.RenamedHsExpr
+ -> TcType.TcType
+ -> TcRnTypes.TcM TcHsSyn.TcExpr
+
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section[TcSplice]{Template Haskell splices}
+
+\begin{code}
+module TcSplice( tcSpliceExpr, tcSpliceDecls ) where
+
+#include "HsVersions.h"
+
+import HscMain ( compileExpr )
+import TcRnDriver ( importSupportingDecls )
+ -- These imports are the reason that TcSplice
+ -- is very high up the module hierarchy
+
+import CompManager ( sandboxIO )
+ -- Ditto, but this one could be defined muchlower down
+
+import qualified Language.Haskell.THSyntax as Meta
+
+import HscTypes ( HscEnv(..), GhciMode(..), PersistentCompilerState(..), unQualInScope )
+import Convert ( convertToHsExpr, convertToHsDecls )
+import RnExpr ( rnExpr )
+import RdrHsSyn ( RdrNameHsExpr, RdrNameHsDecl )
+import RnHsSyn ( RenamedHsExpr )
+import TcExpr ( tcMonoExpr )
+import TcHsSyn ( TcExpr, TypecheckedHsExpr, mkHsLet, zonkTopExpr )
+import TcSimplify ( tcSimplifyTop )
+import TcType ( TcType )
+import TcEnv ( spliceOK, tcMetaTy )
+import TcRnTypes ( TopEnv(..) )
+import Name ( Name )
+import TcRnMonad
+
+import TysWiredIn ( mkListTy )
+import PrelNames ( exprTyConName, declTyConName )
+import Outputable
+import GHC.Base ( unsafeCoerce# ) -- Should have a better home in the module hierarchy
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Main interface + stubs for the non-GHCI case
+%* *
+%************************************************************************
+
+\begin{code}
+tcSpliceDecls :: RenamedHsExpr -> TcM [RdrNameHsDecl]
+
+tcSpliceExpr :: Name
+ -> RenamedHsExpr
+ -> TcType
+ -> TcM TcExpr
+
+#ifndef GHCI
+tcSpliceExpr n e ty = pprPanic "Cant do tcSpliceExpr without GHCi" (ppr e)
+tcSpliceDecls e = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr e)
+#else
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Splicing an expression}
+%* *
+%************************************************************************
+
+\begin{code}
+tcSpliceExpr name expr res_ty
+ = getStage `thenM` \ level ->
+ case spliceOK level of {
+ Nothing -> failWithTc (illegalSplice level) ;
+ Just next_level ->
+
+ case level of {
+ Comp -> tcTopSplice expr res_ty ;
+ Brack _ ps_var lie_var ->
+
+ -- A splice inside brackets
+ -- NB: ignore res_ty
+ -- e.g. [| reverse $(h 4) |]
+ -- Here (h 4) :: Q Exp
+ -- but $(h 4) :: forall a.a i.e. anything!
+
+ tcMetaTy exprTyConName `thenM` \ meta_exp_ty ->
+ setStage (Splice next_level) (
+ setLIEVar lie_var $
+ tcMonoExpr expr meta_exp_ty
+ ) `thenM` \ expr' ->
+
+ -- Write the pending splice into the bucket
+ readMutVar ps_var `thenM` \ ps ->
+ writeMutVar ps_var ((name,expr') : ps) `thenM_`
+
+ returnM (panic "tcSpliceExpr") -- The returned expression is ignored
+ }}
+
+-- tcTopSplice used to have this:
+-- Note that we do not decrement the level (to -1) before
+-- typechecking the expression. For example:
+-- f x = $( ...$(g 3) ... )
+-- The recursive call to tcMonoExpr will simply expand the
+-- inner escape before dealing with the outer one
+
+tcTopSplice expr res_ty
+ = tcMetaTy exprTyConName `thenM` \ meta_exp_ty ->
+ setStage topSpliceStage (
+ getLIE (tcMonoExpr expr meta_exp_ty)
+ ) `thenM` \ (expr', lie) ->
+
+ -- Solve the constraints
+ tcSimplifyTop lie `thenM` \ const_binds ->
+ let
+ q_expr = mkHsLet const_binds expr'
+ in
+ zonkTopExpr q_expr `thenM` \ zonked_q_expr ->
+
+ -- Run the expression
+ traceTc (text "About to run" <+> ppr zonked_q_expr) `thenM_`
+ runMetaE zonked_q_expr `thenM` \ simple_expr ->
+
+ let
+ -- simple_expr :: Meta.Exp
+
+ expr2 :: RdrNameHsExpr
+ expr2 = convertToHsExpr simple_expr
+ in
+ traceTc (text "Got result" <+> ppr expr2) `thenM_`
+ initRn SourceMode (rnExpr expr2) `thenM` \ (exp3, fvs) ->
+ importSupportingDecls fvs `thenM` \ env ->
+
+ setGblEnv env (tcMonoExpr exp3 res_ty)
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Splicing an expression}
+%* *
+%************************************************************************
+
+\begin{code}
+-- Always at top level
+tcSpliceDecls expr
+ = tcMetaTy declTyConName `thenM` \ meta_dec_ty ->
+ setStage topSpliceStage (
+ getLIE (tcMonoExpr expr (mkListTy meta_dec_ty))
+ ) `thenM` \ (expr', lie) ->
+ -- Solve the constraints
+ tcSimplifyTop lie `thenM` \ const_binds ->
+ let
+ q_expr = mkHsLet const_binds expr'
+ in
+ zonkTopExpr q_expr `thenM` \ zonked_q_expr ->
+
+ -- Run the expression
+ traceTc (text "About to run" <+> ppr zonked_q_expr) `thenM_`
+ runMetaD zonked_q_expr `thenM` \ simple_expr ->
+ let
+ -- simple_expr :: [Meta.Dec]
+ decls :: [RdrNameHsDecl]
+ decls = convertToHsDecls simple_expr
+ in
+ returnM decls
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Running an expression}
+%* *
+%************************************************************************
+
+\begin{code}
+runMetaE :: TypecheckedHsExpr -- Of type (Q Exp)
+ -> TcM Meta.Exp -- Of type Exp
+runMetaE e = runMeta e
+
+runMetaD :: TypecheckedHsExpr -- Of type (Q [Dec]
+ -> TcM [Meta.Dec] -- Of type [Dec]
+runMetaD e = runMeta e
+
+runMeta :: TypecheckedHsExpr -- Of type (Q t)
+ -> TcM t -- Of type t
+runMeta expr :: TcM t
+ = getTopEnv `thenM` \ top_env ->
+ getEps `thenM` \ eps ->
+ getNameCache `thenM` \ name_cache ->
+ getModule `thenM` \ this_mod ->
+ getGlobalRdrEnv `thenM` \ rdr_env ->
+ let
+ ghci_mode = top_mode top_env
+
+ hsc_env = HscEnv { hsc_mode = ghci_mode, hsc_HPT = top_hpt top_env,
+ hsc_dflags = top_dflags top_env }
+
+ pcs = PCS { pcs_nc = name_cache, pcs_EPS = eps }
+
+ print_unqual = unQualInScope rdr_env
+ in
+ if (ghci_mode == OneShot) then
+ failWithTc (ptext SLIT("You must use --make or --interactive to run splice expressions"))
+ -- The reason for this is that the demand-linker doesn't have
+ -- enough information available to link all the things that
+ -- are needed when you try to run a splice
+ else
+ ioToTcRn (do {
+ -- Warning: if Q is anything other than IO, we may need to wrap
+ -- the expression 'expr' in a runQ before compiling it
+ hval <- HscMain.compileExpr hsc_env pcs this_mod print_unqual expr
+
+ -- hval :: HValue
+ -- Need to coerce it to IO t
+ ; sandboxIO (unsafeCoerce# hval :: IO t) }) `thenM` \ either_tval ->
+
+ case either_tval of
+ Left err -> failWithTc (vcat [text "Exception when running compiled-time code:",
+ nest 4 (text (show err))])
+ Right v -> returnM v
+\end{code}
+
+
+
+-----------------------------------
+ Random comments
+
+
+ module Foo where
+ import Lib( g :: Int -> M Exp )
+ h x = not x
+ f x y = [| \z -> (x, $(g y), z, map, h) |]
+
+ h p = $( (\q r -> if q then [| \s -> (p,r,s) |]
+ else ... ) True 3) )
+
+==> core
+
+ f :: Liftable a => a -> Int -> M Exp
+ f = /\a -> \d::Liftable a ->
+ \ x y -> genSym "z" `bindM` \ z::String ->
+ g y `bindM` \ vv::Exp ->
+ Lam z (Tup [lift d x, v, Var z,
+ Glob "Prelude" "map",
+ Glob "Foo" "h"])
+
+
+ h :: Tree Int -> M Exp
+ h = \p -> \s' -> (p,3,s')
+
+
+ Bound Used
+
+ map: C0 C1 (top-level/imp)
+ x: C0 C1 (lam/case)
+ y: C0 C0
+ z: C1 C1
+
+ p: C0 S1
+ r: S0 S1
+ q: S0 S0
+ s: S1 S1
+
+-------
+
+ f x y = lam "z" (tup [lift x, g y, var "z",
+ [| map |], [| h |] ])
+==> core
+
+ f = \x y -> lam "z" (tup [lift d x, g y, var "z",
+ return (Glob "Prelude" "map"),
+ return (Glob "Foo" "h")])
+
+
+
+
+
+
+
+ h :: M Exp -> M Exp
+ h v = [| \x -> map $v x |]
+
+ g :: Tree Int -> M Exp
+ g x = $(h [| x |])
+==>
+ g x = \x' -> map x x'
+
+*** Simon claims x does not have to be liftable! **
+
+Level 0 compile time
+Level 1 run time
+Level 2 code returned by run time (generation time)
+
+Non-top-level variables
+ x occurs at level 1
+ inside brackets
+ bound at level 0 --> x
+ bound at level 1 --> var "x"
+
+ not inside brackets --> x
+
+ x at level 2
+ inside brackets
+ bound at level 0 --> x
+ bound at level 1 --> var "x"
+
+ f x = x
+
+Two successive brackets aren't allowed
+
+
+%************************************************************************
+%* *
+\subsection{Errors and contexts}
+%* *
+%************************************************************************
+
+\begin{code}
+illegalSplice level
+ = ptext SLIT("Illegal splice at level") <+> ppr level
+
+#endif /* GHCI */
+\end{code}
#include "HsVersions.h"
-import CmdLineOpts ( DynFlags, DynFlag(..), dopt )
import HsSyn ( TyClDecl(..),
ConDecl(..), Sig(..), HsPred(..),
tyClDeclName, hsTyVarNames, tyClDeclTyVars,
isTypeOrClassDecl, isClassDecl, isSynDecl, isClassOpSig
)
import RnHsSyn ( RenamedTyClDecl, tyClDeclFVs )
-import BasicTypes ( RecFlag(..), NewOrData(..) )
+import BasicTypes ( RecFlag(..), isNonRec, NewOrData(..) )
import HscTypes ( implicitTyThingIds )
-import Module ( Module )
-import TcMonad
-import TcEnv ( TcEnv, TcTyThing(..), TyThing(..), TyThingDetails(..),
- tcExtendKindEnv, tcLookup, tcExtendGlobalEnv,
+import TcRnMonad
+import TcEnv ( TcTyThing(..), TyThing(..), TyThingDetails(..),
+ tcExtendKindEnv, tcLookup, tcLookupGlobal, tcExtendGlobalEnv,
isLocalThing )
import TcTyDecls ( tcTyDecl, kcConDetails )
import TcClassDcl ( tcClassDecl1 )
import Class ( Class, mkClass, classTyCon )
import TyCon ( TyCon, ArgVrcs, AlgTyConFlavour(..), DataConDetails(..), visibleDataCons,
tyConKind, tyConTyVars, tyConDataCons, isNewTyCon,
- mkSynTyCon, mkAlgTyCon, mkClassTyCon, mkForeignTyCon,
+ mkSynTyCon, mkAlgTyCon, mkClassTyCon, mkForeignTyCon
)
import TysWiredIn ( unitTy )
import Subst ( substTyWith )
import Var ( varName )
import FiniteMap
import Digraph ( stronglyConnComp, SCC(..) )
-import Name ( Name, getSrcLoc, isTyVarName )
+import Name ( Name, getSrcLoc )
import NameEnv
import NameSet
import Outputable
import Maybes ( mapMaybe )
import ErrUtils ( Message )
-import HsDecls ( getClassDeclSysNames )
-import Generics ( mkTyConGenInfo )
\end{code}
The main function
~~~~~~~~~~~~~~~~~
\begin{code}
-tcTyAndClassDecls :: Module -- Current module
- -> [RenamedTyClDecl]
+tcTyAndClassDecls :: [RenamedTyClDecl]
-> TcM [TyThing] -- Returns newly defined things:
-- types, classes and implicit Ids
-tcTyAndClassDecls this_mod decls
- = sortByDependency decls `thenTc` \ groups ->
- tcGroups this_mod groups
+tcTyAndClassDecls decls
+ = tcGroups (stronglyConnComp edges)
+ where
+ edges = map mkEdges (filter isTypeOrClassDecl decls)
-tcGroups this_mod []
- = returnTc []
+tcGroups []
+ = returnM []
-tcGroups this_mod (group:groups)
- = tcGroup this_mod group `thenTc` \ (env, new_things1) ->
- tcSetEnv env $
- tcGroups this_mod groups `thenTc` \ new_things2 ->
- returnTc (new_things1 ++ new_things2)
+tcGroups (group:groups)
+ = tcGroup group `thenM` \ (env, new_things1) ->
+ setGblEnv env $
+ tcGroups groups `thenM` \ new_things2 ->
+ returnM (new_things1 ++ new_things2)
\end{code}
Dealing with a group
@TyThing@s. @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s.
\begin{code}
-tcGroup :: Module -> SCC RenamedTyClDecl
- -> TcM (TcEnv, -- Input env extended by types and classes only
+tcGroup :: SCC RenamedTyClDecl
+ -> TcM (TcGblEnv, -- Input env extended by types and classes only
[TyThing]) -- Things defined by this group
-tcGroup this_mod scc
- = getDOptsTc `thenNF_Tc` \ dflags ->
- -- Step 1
- mapNF_Tc getInitialKind decls `thenNF_Tc` \ initial_kinds ->
+tcGroup scc
+ = -- Step 1
+ mappM getInitialKind decls `thenM` \ initial_kinds ->
-- Step 2
- tcExtendKindEnv initial_kinds (mapTc kcTyClDecl decls) `thenTc_`
+ tcExtendKindEnv initial_kinds (mappM kcTyClDecl decls) `thenM_`
-- Step 3
- zonkKindEnv initial_kinds `thenNF_Tc` \ final_kinds ->
+ zonkKindEnv initial_kinds `thenM` \ final_kinds ->
+
+ -- Check for loops
+ checkLoops is_rec decls `thenM` \ is_rec_tycon ->
-- Tie the knot
- traceTc (text "starting" <+> ppr final_kinds) `thenTc_`
- fixTc ( \ ~(rec_details_list, _, _) ->
+ traceTc (text "starting" <+> ppr final_kinds) `thenM_`
+ fixM ( \ ~(rec_details_list, _, rec_all_tyclss) ->
-- Step 4
let
kind_env = mkNameEnv final_kinds
rec_details = mkNameEnv rec_details_list
- tyclss, all_tyclss :: [TyThing]
- tyclss = map (buildTyConOrClass dflags is_rec kind_env
- rec_vrcs rec_details) decls
+ -- Calculate variances, and feed into buildTyConOrClass
+ rec_vrcs = calcTyConArgVrcs [tc | ATyCon tc <- rec_all_tyclss]
- -- Add the tycons that come from the classes
- -- We want them in the environment because
- -- they are mentioned in interface files
- all_tyclss = [ATyCon (classTyCon clas) | AClass clas <- tyclss]
- ++ tyclss
+ build_one = buildTyConOrClass is_rec_tycon kind_env
+ rec_vrcs rec_details
+ tyclss = map build_one decls
- -- Calculate variances, and (yes!) feed back into buildTyConOrClass.
- rec_vrcs = calcTyConArgVrcs [tc | ATyCon tc <- all_tyclss]
in
-- Step 5
-- Extend the environment with the final
-- TyCons/Classes and check the decls
- tcExtendGlobalEnv all_tyclss $
- mapTc tcTyClDecl1 decls `thenTc` \ tycls_details ->
+ tcExtendGlobalEnv tyclss $
+ mappM tcTyClDecl1 decls `thenM` \ tycls_details ->
-- Return results
- tcGetEnv `thenNF_Tc` \ env ->
- returnTc (tycls_details, env, all_tyclss)
- ) `thenTc` \ (_, env, all_tyclss) ->
+ getGblEnv `thenM` \ env ->
+ returnM (tycls_details, env, tyclss)
+ ) `thenM` \ (_, env, tyclss) ->
-- Step 7: Check validity
- traceTc (text "ready for validity check") `thenTc_`
- tcSetEnv env (
- mapTc_ (checkValidTyCl this_mod) decls
- ) `thenTc_`
- traceTc (text "done") `thenTc_`
+ traceTc (text "ready for validity check") `thenM_`
+ getModule `thenM` \ mod ->
+ setGblEnv env (
+ mappM_ (checkValidTyCl mod) decls
+ ) `thenM_`
+ traceTc (text "done") `thenM_`
- let
- implicit_things = [AnId id | id <- implicitTyThingIds all_tyclss]
- new_things = all_tyclss ++ implicit_things
+ let -- Add the tycons that come from the classes
+ -- We want them in the environment because
+ -- they are mentioned in interface files
+ implicit_tycons, implicit_ids, all_tyclss :: [TyThing]
+ implicit_tycons = [ATyCon (classTyCon clas) | AClass clas <- tyclss]
+ all_tyclss = implicit_tycons ++ tyclss
+ implicit_ids = [AnId id | id <- implicitTyThingIds all_tyclss]
+ new_things = implicit_ids ++ all_tyclss
in
- returnTc (env, new_things)
+ returnM (env, new_things)
where
is_rec = case scc of
-- We do the validity check over declarations, rather than TyThings
-- only so that we can add a nice context with tcAddDeclCtxt
checkValidTyCl this_mod decl
- = tcLookup (tcdName decl) `thenNF_Tc` \ (AGlobal thing) ->
+ = tcLookupGlobal (tcdName decl) `thenM` \ thing ->
if not (isLocalThing this_mod thing) then
-- Don't bother to check validity for non-local things
- returnTc ()
+ returnM ()
else
tcAddDeclCtxt decl $
case thing of
%************************************************************************
\begin{code}
-getInitialKind :: RenamedTyClDecl -> NF_TcM (Name, TcKind)
+getInitialKind :: RenamedTyClDecl -> TcM (Name, TcKind)
getInitialKind decl
- = kcHsTyVars (tyClDeclTyVars decl) `thenNF_Tc` \ arg_kinds ->
- newKindVar `thenNF_Tc` \ result_kind ->
- returnNF_Tc (tcdName decl, mk_kind arg_kinds result_kind)
+ = kcHsTyVars (tyClDeclTyVars decl) `thenM` \ arg_kinds ->
+ newKindVar `thenM` \ result_kind ->
+ returnM (tcdName decl, mk_kind arg_kinds result_kind)
mk_kind tvs_w_kinds res_kind = foldr (mkArrowKind . snd) res_kind tvs_w_kinds
\end{code}
kcTyClDecl decl@(TySynonym {tcdSynRhs = rhs})
= kcTyClDeclBody decl $ \ result_kind ->
- kcHsType rhs `thenTc` \ rhs_kind ->
+ kcHsType rhs `thenM` \ rhs_kind ->
unifyKind result_kind rhs_kind
-kcTyClDecl (ForeignType {}) = returnTc ()
+kcTyClDecl (ForeignType {}) = returnM ()
kcTyClDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = context, tcdCons = con_decls})
= kcTyClDeclBody decl $ \ result_kind ->
- kcHsContext context `thenTc_`
- mapTc_ kc_con_decl (visibleDataCons con_decls)
+ kcHsContext context `thenM_`
+ mappM_ kc_con_decl (visibleDataCons con_decls)
where
- kc_con_decl (ConDecl _ _ ex_tvs ex_ctxt details loc)
- = kcHsTyVars ex_tvs `thenNF_Tc` \ kind_env ->
+ kc_con_decl (ConDecl _ ex_tvs ex_ctxt details loc)
+ = kcHsTyVars ex_tvs `thenM` \ kind_env ->
tcExtendKindEnv kind_env $
kcConDetails new_or_data ex_ctxt details
kcTyClDecl decl@(ClassDecl {tcdCtxt = context, tcdSigs = class_sigs})
= kcTyClDeclBody decl $ \ result_kind ->
- kcHsContext context `thenTc_`
- mapTc_ kc_sig (filter isClassOpSig class_sigs)
+ kcHsContext context `thenM_`
+ mappM_ kc_sig (filter isClassOpSig class_sigs)
where
kc_sig (ClassOpSig _ _ op_ty loc) = kcHsLiftedSigType op_ty
-- check the result kind matches
kcTyClDeclBody decl thing_inside
= tcAddDeclCtxt decl $
- tcLookup (tcdName decl) `thenNF_Tc` \ thing ->
+ tcLookup (tcdName decl) `thenM` \ thing ->
let
kind = case thing of
AGlobal (ATyCon tc) -> tyConKind tc
\begin{code}
buildTyConOrClass
- :: DynFlags
- -> RecFlag -> NameEnv Kind
+ :: (Name -> AlgTyConFlavour -> RecFlag) -- Whether it's recursive
+ -> NameEnv Kind
-> FiniteMap TyCon ArgVrcs -> NameEnv TyThingDetails
-> RenamedTyClDecl -> TyThing
-buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
- (TySynonym {tcdName = tycon_name, tcdTyVars = tyvar_names})
+buildTyConOrClass rec_tycon kenv rec_vrcs rec_details
+ (TySynonym {tcdName = tycon_name, tcdTyVars = tyvar_names})
= ATyCon tycon
where
tycon = mkSynTyCon tycon_name tycon_kind arity tyvars rhs_ty argvrcs
SynTyDetails rhs_ty = lookupNameEnv_NF rec_details tycon_name
argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
-buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
- (TyData {tcdND = data_or_new, tcdName = tycon_name,
- tcdTyVars = tyvar_names, tcdSysNames = sys_names})
+buildTyConOrClass rec_tycon kenv rec_vrcs rec_details
+ (TyData {tcdND = data_or_new, tcdName = tycon_name,
+ tcdTyVars = tyvar_names})
= ATyCon tycon
where
tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt argvrcs
- data_cons sel_ids
- flavour is_rec gen_info
- -- It's not strictly necesary to mark newtypes as
- -- recursive if the loop is broken via a data type.
- -- But I'm not sure it's worth the hassle of discovering that.
-
- gen_info | not (dopt Opt_Generics dflags) = Nothing
- | otherwise = mkTyConGenInfo tycon sys_names
+ data_cons sel_ids flavour
+ (rec_tycon tycon_name flavour) gen_info
- DataTyDetails ctxt data_cons sel_ids = lookupNameEnv_NF rec_details tycon_name
+ DataTyDetails ctxt data_cons sel_ids gen_info = lookupNameEnv_NF rec_details tycon_name
tycon_kind = lookupNameEnv_NF kenv tycon_name
tyvars = mkTyClTyVars tycon_kind tyvar_names
-- depends on whether it's a data type or a newtype --- so
-- in the recursive case we can get a loop. This version is simple!
-buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
- (ForeignType {tcdName = tycon_name, tcdExtName = tycon_ext_name})
+buildTyConOrClass rec_tycon kenv rec_vrcs rec_details
+ (ForeignType {tcdName = tycon_name, tcdExtName = tycon_ext_name})
= ATyCon (mkForeignTyCon tycon_name tycon_ext_name liftedTypeKind 0 [])
-buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
- (ClassDecl {tcdName = class_name, tcdTyVars = tyvar_names,
- tcdFDs = fundeps, tcdSysNames = name_list} )
+buildTyConOrClass rec_tycon kenv rec_vrcs rec_details
+ (ClassDecl {tcdName = class_name, tcdTyVars = tyvar_names, tcdFDs = fundeps} )
= AClass clas
where
- (tycon_name, _, _, _) = getClassDeclSysNames name_list
clas = mkClass class_name tyvars fds
sc_theta sc_sel_ids op_items
tycon
argvrcs dict_con
clas -- Yes! It's a dictionary
flavour
- is_rec
+ (rec_tycon class_name flavour)
-- A class can be recursive, and in the case of newtypes
-- this matters. For example
-- class C a where { op :: C b => a -> b -> Int }
-- [If we don't make it a recursive newtype, we'll expand the
-- newtype like a synonym, but that will lead toan inifinite type
- ClassDetails sc_theta sc_sel_ids op_items dict_con = lookupNameEnv_NF rec_details class_name
+ ClassDetails sc_theta sc_sel_ids op_items dict_con tycon_name
+ = lookupNameEnv_NF rec_details class_name
class_kind = lookupNameEnv_NF kenv class_name
tyvars = mkTyClTyVars class_kind tyvar_names
Dependency analysis
~~~~~~~~~~~~~~~~~~~
\begin{code}
-sortByDependency :: [RenamedTyClDecl] -> TcM [SCC RenamedTyClDecl]
-sortByDependency decls
+checkLoops :: RecFlag -> [RenamedTyClDecl]
+ -> TcM (Name -> AlgTyConFlavour -> RecFlag)
+-- Check for illegal loops,
+-- a) type synonyms
+-- b) superclass hierarchy
+--
+-- Also return a function that says which tycons are recursive.
+-- Remember:
+-- a newtype is recursive if it is part of a recursive
+-- group consisting only of newtype and synonyms
+
+checkLoops is_rec decls
+ | isNonRec is_rec
+ = returnM (\ _ _ -> NonRecursive)
+
+ | otherwise -- Recursive group
= let -- CHECK FOR CLASS CYCLES
- cls_sccs = stronglyConnComp (mapMaybe mkClassEdges tycl_decls)
- cls_cycles = [ decls | CyclicSCC decls <- cls_sccs]
+ cls_edges = mapMaybe mkClassEdges decls
+ cls_cycles = findCycles cls_edges
in
- checkTc (null cls_cycles) (classCycleErr cls_cycles) `thenTc_`
+ checkTc (null cls_cycles) (classCycleErr cls_cycles) `thenM_`
let -- CHECK FOR SYNONYM CYCLES
- syn_sccs = stronglyConnComp (filter is_syn_decl edges)
- syn_cycles = [ decls | CyclicSCC decls <- syn_sccs]
-
+ syn_edges = map mkEdges (filter isSynDecl decls)
+ syn_cycles = findCycles syn_edges
in
- checkTc (null syn_cycles) (typeCycleErr syn_cycles) `thenTc_`
+ checkTc (null syn_cycles) (typeCycleErr syn_cycles) `thenM_`
- -- DO THE MAIN DEPENDENCY ANALYSIS
- let
- decl_sccs = stronglyConnComp edges
+ let -- CHECK FOR NEWTYPE CYCLES
+ newtype_edges = map mkEdges (filter is_nt_cycle_decl decls)
+ newtype_cycles = findCycles newtype_edges
+ rec_newtypes = mkNameSet [tcdName d | ds <- newtype_cycles, d <- ds]
+
+ rec_tycon name (NewTyCon _)
+ | name `elemNameSet` rec_newtypes = Recursive
+ | otherwise = NonRecursive
+ rec_tycon name other_flavour = Recursive
in
- returnTc decl_sccs
- where
- tycl_decls = filter isTypeOrClassDecl decls
- edges = map mkEdges tycl_decls
-
- is_syn_decl (d, _, _) = isSynDecl d
-\end{code}
+ returnM rec_tycon
-Edges in Type/Class decls
-~~~~~~~~~~~~~~~~~~~~~~~~~
+----------------------------------------------------
+-- A class with one op and no superclasses, or vice versa,
+-- is treated just like a newtype.
+-- It's a bit unclean that this test is repeated in buildTyConOrClass
+is_nt_cycle_decl (TySynonym {}) = True
+is_nt_cycle_decl (TyData {tcdND = NewType}) = True
+is_nt_cycle_decl (ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs}) = length ctxt + length sigs == 1
+is_nt_cycle_decl other = False
-\begin{code}
-tyClDeclFTVs :: RenamedTyClDecl -> [Name]
- -- Find the free non-tyvar vars
-tyClDeclFTVs d = foldNameSet add [] (tyClDeclFVs d)
- where
- add n fvs | isTyVarName n = fvs
- | otherwise = n : fvs
+----------------------------------------------------
+findCycles edges = [ ds | CyclicSCC ds <- stronglyConnComp edges]
+
+----------------------------------------------------
+mkEdges :: RenamedTyClDecl -> (RenamedTyClDecl, Name, [Name])
+mkEdges decl = (decl, tyClDeclName decl, nameSetToList (tyClDeclFVs decl))
----------------------------------------------------
-- mk_cls_edges looks only at the context of class decls
-- superclass hierarchy
mkClassEdges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Name, [Name])
-
mkClassEdges decl@(ClassDecl {tcdCtxt = ctxt, tcdName = name}) = Just (decl, name, [c | HsClassP c _ <- ctxt])
mkClassEdges other_decl = Nothing
-
-mkEdges :: RenamedTyClDecl -> (RenamedTyClDecl, Name, [Name])
-mkEdges decl = (decl, tyClDeclName decl, tyClDeclFTVs decl)
\end{code}
#include "HsVersions.h"
-import HsSyn ( TyClDecl(..), ConDecl(..), ConDetails(..),
+import HsSyn ( TyClDecl(..), ConDecl(..), HsConDetails(..), BangType,
getBangType, getBangStrictness, conDetailsTys
)
import RnHsSyn ( RenamedTyClDecl, RenamedConDecl, RenamedContext )
import TcMonoType ( tcHsTyVars, tcHsTheta, tcHsType,
kcHsContext, kcHsSigType, kcHsLiftedSigType
)
-import TcEnv ( tcExtendTyVarEnv,
- tcLookupTyCon, tcLookupRecId,
- TyThingDetails(..), RecTcEnv
- )
+import TcEnv ( tcExtendTyVarEnv, tcLookupTyCon, TyThingDetails(..) )
import TcType ( tyVarsOfTypes, tyVarsOfPred, ThetaType )
-import TcMonad
+import RnEnv ( lookupSysName )
+import TcRnMonad
import DataCon ( DataCon, mkDataCon, dataConFieldLabels )
import FieldLabel ( fieldLabelName, fieldLabelType, allFieldLabelTags, mkFieldLabel )
import MkId ( mkDataConId, mkDataConWrapId, mkRecordSelId )
import Var ( TyVar )
-import Name ( Name, NamedThing(..) )
+import Name ( Name )
+import OccName ( mkWorkerOcc, mkGenOcc1, mkGenOcc2 )
import Outputable
import TyCon ( TyCon, DataConDetails(..), visibleDataCons,
- tyConTyVars )
+ tyConTyVars, tyConName )
import VarSet ( intersectVarSet, isEmptyVarSet )
-import PrelNames ( unpackCStringName, unpackCStringUtf8Name )
+import Generics ( mkTyConGenInfo )
+import CmdLineOpts ( DynFlag(..) )
import List ( nubBy )
\end{code}
\begin{code}
tcTyDecl :: RenamedTyClDecl -> TcM (Name, TyThingDetails)
tcTyDecl (TySynonym {tcdName = tycon_name, tcdSynRhs = rhs})
- = tcLookupTyCon tycon_name `thenNF_Tc` \ tycon ->
+ = tcLookupTyCon tycon_name `thenM` \ tycon ->
tcExtendTyVarEnv (tyConTyVars tycon) $
- tcHsType rhs `thenTc` \ rhs_ty ->
- returnTc (tycon_name, SynTyDetails rhs_ty)
+ tcHsType rhs `thenM` \ rhs_ty ->
+ returnM (tycon_name, SynTyDetails rhs_ty)
tcTyDecl (TyData {tcdND = new_or_data, tcdCtxt = context,
- tcdName = tycon_name, tcdCons = con_decls})
- = tcLookupTyCon tycon_name `thenNF_Tc` \ tycon ->
+ tcdName = tycon_name, tcdCons = con_decls,
+ tcdGeneric = generic})
+ = tcLookupTyCon tycon_name `thenM` \ tycon ->
let
tyvars = tyConTyVars tycon
in
tcExtendTyVarEnv tyvars $
- tcHsTheta context `thenTc` \ ctxt ->
- tcConDecls new_or_data tycon tyvars ctxt con_decls `thenTc` \ data_cons ->
+ tcHsTheta context `thenM` \ ctxt ->
+ tcConDecls new_or_data tycon tyvars ctxt con_decls `thenM` \ data_cons ->
let
sel_ids = mkRecordSelectors tycon data_cons
in
- returnTc (tycon_name, DataTyDetails ctxt data_cons sel_ids)
+ tcGenericInfo tycon generic `thenM` \ gen_info ->
+ returnM (tycon_name, DataTyDetails ctxt data_cons sel_ids gen_info)
tcTyDecl (ForeignType {tcdName = tycon_name})
- = returnTc (tycon_name, ForeignTyDetails)
+ = returnM (tycon_name, ForeignTyDetails)
+
+tcGenericInfo tycon generics -- Source code decl: consult the flag
+ = do_we_want generics `thenM` \ want_generics ->
+ if want_generics then
+ mapM (lookupSysName (tyConName tycon))
+ [mkGenOcc1, mkGenOcc2] `thenM` \ gen_sys_names ->
+ returnM (mkTyConGenInfo tycon gen_sys_names)
+ else
+ returnM Nothing
+ where
+ do_we_want (Just g) = returnM g -- Interface file decl
+ -- so look at decl
+ do_we_want Nothing = doptM Opt_Generics -- Source code decl
+ -- so look at flag
mkRecordSelectors tycon data_cons
= -- We'll check later that fields with the same name
%************************************************************************
\begin{code}
-kcConDetails :: NewOrData -> RenamedContext -> ConDetails Name -> TcM ()
+kcConDetails :: NewOrData -> RenamedContext
+ -> HsConDetails Name (BangType Name) -> TcM ()
kcConDetails new_or_data ex_ctxt details
- = kcHsContext ex_ctxt `thenTc_`
- mapTc_ kc_sig_type (conDetailsTys details)
+ = kcHsContext ex_ctxt `thenM_`
+ mappM_ kc_sig_type (conDetailsTys details)
where
kc_sig_type = case new_or_data of
DataType -> kcHsSigType
tcConDecls new_or_data tycon tyvars ctxt con_decls
= case con_decls of
- Unknown -> returnTc Unknown
- HasCons n -> returnTc (HasCons n)
- DataCons cs -> mapTc tc_con_decl cs `thenTc` \ data_cons ->
- returnTc (DataCons data_cons)
+ Unknown -> returnM Unknown
+ HasCons n -> returnM (HasCons n)
+ DataCons cs -> mappM tc_con_decl cs `thenM` \ data_cons ->
+ returnM (DataCons data_cons)
where
- tc_con_decl (ConDecl name wkr_name ex_tvs ex_ctxt details src_loc)
- = tcAddSrcLoc src_loc $
+ tc_con_decl (ConDecl name ex_tvs ex_ctxt details src_loc)
+ = addSrcLoc src_loc $
tcHsTyVars ex_tvs (kcConDetails new_or_data ex_ctxt details) $ \ ex_tyvars ->
- tcHsTheta ex_ctxt `thenTc` \ ex_theta ->
+ tcHsTheta ex_ctxt `thenM` \ ex_theta ->
case details of
- VanillaCon btys -> tc_datacon ex_tyvars ex_theta btys
+ PrefixCon btys -> tc_datacon ex_tyvars ex_theta btys
InfixCon bty1 bty2 -> tc_datacon ex_tyvars ex_theta [bty1,bty2]
RecCon fields -> tc_rec_con ex_tyvars ex_theta fields
where
tc_datacon ex_tyvars ex_theta btys
- = mapTc tcHsType (map getBangType btys) `thenTc` \ arg_tys ->
+ = mappM tcHsType (map getBangType btys) `thenM` \ arg_tys ->
mk_data_con ex_tyvars ex_theta (map getBangStrictness btys) arg_tys []
tc_rec_con ex_tyvars ex_theta fields
- = checkTc (null ex_tyvars) (exRecConErr name) `thenTc_`
- mapTc tc_field (fields `zip` allFieldLabelTags) `thenTc` \ field_labels_s ->
+ = checkTc (null ex_tyvars) (exRecConErr name) `thenM_`
+ mappM tc_field (fields `zip` allFieldLabelTags) `thenM` \ field_labels ->
let
- field_labels = concat field_labels_s
- arg_stricts = [str | (ns, bty) <- fields,
- let str = getBangStrictness bty,
- n <- ns -- One for each. E.g x,y,z :: !Int
+ arg_stricts = [str | (n, bty) <- fields,
+ let str = getBangStrictness bty
]
in
mk_data_con ex_tyvars ex_theta arg_stricts
(map fieldLabelType field_labels) field_labels
- tc_field ((field_label_names, bty), tag)
- = tcHsType (getBangType bty) `thenTc` \ field_ty ->
- returnTc [mkFieldLabel (getName name) tycon field_ty tag | name <- field_label_names]
+ tc_field ((field_label_name, bty), tag)
+ = tcHsType (getBangType bty) `thenM` \ field_ty ->
+ returnM (mkFieldLabel field_label_name tycon field_ty tag)
mk_data_con ex_tyvars ex_theta arg_stricts arg_tys fields
- = let
+ = lookupSysName name mkWorkerOcc `thenM` \ wkr_name ->
+ let
data_con = mkDataCon name arg_stricts fields
tyvars (thinContext arg_tys ctxt)
ex_tyvars ex_theta
data_con_id = mkDataConId wkr_name data_con
data_con_wrap_id = mkDataConWrapId data_con
in
- returnNF_Tc data_con
+ returnM data_con
-- The context for a data constructor should be limited to
-- the type variables mentioned in the arg_tys
---------------------------------
-- Misc type manipulators
- deNoteType,
- namesOfType, namesOfDFunHead,
+ deNoteType, classNamesOfTheta,
+ tyClsNamesOfType, tyClsNamesOfDFunHead,
getDFunTyKey,
---------------------------------
-- Predicate types
- PredType, getClassPredTys_maybe, getClassPredTys,
+ getClassPredTys_maybe, getClassPredTys,
isPredTy, isClassPred, isTyVarClassPred, predHasFDs,
- mkDictTy, tcSplitPredTy_maybe, predTyUnique,
+ mkDictTy, tcSplitPredTy_maybe,
isDictTy, tcSplitDFunTy, predTyUnique,
mkClassPred, isInheritablePred, isLinearPred, isIPPred, mkPredName,
import {-# SOURCE #-} PprType( pprType )
+-- PprType imports TcType so that it can print intelligently
-- friends:
import TypeRep ( Type(..), TyNote(..), funTyCon ) -- friend
deNoteSourceType (NType tc tys) = NType tc (map deNoteType tys)
\end{code}
-Find the free names of a type, including the type constructors and classes it mentions
-This is used in the front end of the compiler
+Find the free tycons and classes of a type. This is used in the front
+end of the compiler.
\begin{code}
-namesOfType :: Type -> NameSet
-namesOfType (TyVarTy tv) = unitNameSet (getName tv)
-namesOfType (TyConApp tycon tys) = unitNameSet (getName tycon) `unionNameSets` namesOfTypes tys
-namesOfType (NoteTy (SynNote ty1) ty2) = namesOfType ty1
-namesOfType (NoteTy other_note ty2) = namesOfType ty2
-namesOfType (SourceTy (IParam n ty)) = namesOfType ty
-namesOfType (SourceTy (ClassP cl tys)) = unitNameSet (getName cl) `unionNameSets` namesOfTypes tys
-namesOfType (SourceTy (NType tc tys)) = unitNameSet (getName tc) `unionNameSets` namesOfTypes tys
-namesOfType (FunTy arg res) = namesOfType arg `unionNameSets` namesOfType res
-namesOfType (AppTy fun arg) = namesOfType fun `unionNameSets` namesOfType arg
-namesOfType (ForAllTy tyvar ty) = namesOfType ty `delFromNameSet` getName tyvar
-
-namesOfTypes tys = foldr (unionNameSets . namesOfType) emptyNameSet tys
-
-namesOfDFunHead :: Type -> NameSet
+tyClsNamesOfType :: Type -> NameSet
+tyClsNamesOfType (TyVarTy tv) = emptyNameSet
+tyClsNamesOfType (TyConApp tycon tys) = unitNameSet (getName tycon) `unionNameSets` tyClsNamesOfTypes tys
+tyClsNamesOfType (NoteTy (SynNote ty1) ty2) = tyClsNamesOfType ty1
+tyClsNamesOfType (NoteTy other_note ty2) = tyClsNamesOfType ty2
+tyClsNamesOfType (SourceTy (IParam n ty)) = tyClsNamesOfType ty
+tyClsNamesOfType (SourceTy (ClassP cl tys)) = unitNameSet (getName cl) `unionNameSets` tyClsNamesOfTypes tys
+tyClsNamesOfType (SourceTy (NType tc tys)) = unitNameSet (getName tc) `unionNameSets` tyClsNamesOfTypes tys
+tyClsNamesOfType (FunTy arg res) = tyClsNamesOfType arg `unionNameSets` tyClsNamesOfType res
+tyClsNamesOfType (AppTy fun arg) = tyClsNamesOfType fun `unionNameSets` tyClsNamesOfType arg
+tyClsNamesOfType (ForAllTy tyvar ty) = tyClsNamesOfType ty
+
+tyClsNamesOfTypes tys = foldr (unionNameSets . tyClsNamesOfType) emptyNameSet tys
+
+tyClsNamesOfDFunHead :: Type -> NameSet
-- Find the free type constructors and classes
-- of the head of the dfun instance type
-- The 'dfun_head_type' is because of
-- instance Foo a => Baz T where ...
-- The decl is an orphan if Baz and T are both not locally defined,
-- even if Foo *is* locally defined
-namesOfDFunHead dfun_ty = case tcSplitSigmaTy dfun_ty of
- (tvs,_,head_ty) -> delListFromNameSet (namesOfType head_ty)
- (map getName tvs)
+tyClsNamesOfDFunHead dfun_ty
+ = case tcSplitSigmaTy dfun_ty of
+ (tvs,_,head_ty) -> tyClsNamesOfType head_ty
+
+classNamesOfTheta :: ThetaType -> [Name]
+-- Looks just for ClassP things; maybe it should check
+classNamesOfTheta preds = [ getName c | ClassP c _ <- preds ]
\end{code}
_exports_
TcUnify unifyTauTy;
_declarations_
-1 unifyTauTy _:_ TcType.TcTauType -> TcType.TcTauType -> TcMonad.TcM () ;;
+1 unifyTauTy _:_ TcType.TcTauType -> TcType.TcTauType -> TcRnTypes.TcM () ;;
__interface TcUnify 1 0 where
__export TcUnify unifyTauTy ;
-1 unifyTauTy :: TcType.TcTauType -> TcType.TcTauType -> TcMonad.TcM PrelBase.Z0T ;
+1 unifyTauTy :: TcType.TcTauType -> TcType.TcTauType -> TcRnTypes.TcM PrelBase.Z0T ;
-- This boot file exists only to tie the knot between
-- TcUnify and TcSimplify
-unifyTauTy :: TcType.TcTauType -> TcType.TcTauType -> TcMonad.TcM GHC.Base.()
+unifyTauTy :: TcType.TcTauType -> TcType.TcTauType -> TcRnTypes.TcM GHC.Base.()
import TypeRep ( Type(..), SourceType(..), TyNote(..),
openKindCon, typeCon )
-import TcMonad -- TcType, amongst others
+import TcRnMonad -- TcType, amongst others
import TcType ( TcKind, TcType, TcSigmaType, TcRhoType, TcTyVar, TcTauType,
TcTyVarSet, TcThetaType, TyVarDetails(SigTv),
isTauTy, isSigmaTy,
hasMoreBoxityInfo, tyVarBindingInfo, allDistinctTyVars
)
import qualified Type ( getTyVar_maybe )
-import Inst ( LIE, emptyLIE, plusLIE,
- newDicts, instToId, tcInstCall
- )
+import Inst ( newDicts, instToId, tcInstCall )
import TcMType ( getTcTyVar, putTcTyVar, tcInstType, readHoleResult,
newTyVarTy, newTyVarTys, newBoxityVar, newHoleTyVarTy,
zonkTcType, zonkTcTyVars, zonkTcTyVarsAndFV, zonkTcTyVar )
import TcSimplify ( tcSimplifyCheck )
import TysWiredIn ( listTyCon, parrTyCon, mkListTy, mkPArrTy, mkTupleTy )
-import TcEnv ( TcTyThing(..), tcGetGlobalTyVars, tcLEnvElts )
+import TcEnv ( TcTyThing(..), tcGetGlobalTyVars, getLclEnvElts )
import TyCon ( tyConArity, isTupleTyCon, tupleTyConBoxity )
import PprType ( pprType )
import Id ( Id, mkSysLocal, idType )
type TcHoleType = TcSigmaType -- Either a TcSigmaType,
-- or else a hole
-tcSubExp :: TcHoleType -> TcSigmaType -> TcM (ExprCoFn, LIE)
-tcSubOff :: TcSigmaType -> TcHoleType -> TcM (ExprCoFn, LIE)
-tcSub :: TcSigmaType -> TcSigmaType -> TcM (ExprCoFn, LIE)
+tcSubExp :: TcHoleType -> TcSigmaType -> TcM ExprCoFn
+tcSubOff :: TcSigmaType -> TcHoleType -> TcM ExprCoFn
+tcSub :: TcSigmaType -> TcSigmaType -> TcM ExprCoFn
\end{code}
These two check for holes
checkHole (TyVarTy tv) other_ty thing_inside
| isHoleTyVar tv
- = getTcTyVar tv `thenNF_Tc` \ maybe_ty ->
+ = getTcTyVar tv `thenM` \ maybe_ty ->
case maybe_ty of
Just ty -> thing_inside ty other_ty
- Nothing -> putTcTyVar tv other_ty `thenNF_Tc_`
- returnTc (idCoercion, emptyLIE)
+ Nothing -> putTcTyVar tv other_ty `thenM_`
+ returnM idCoercion
checkHole ty other_ty thing_inside
= thing_inside ty other_ty
\begin{code}
tcSub expected_ty actual_ty
- = traceTc (text "tcSub" <+> details) `thenNF_Tc_`
- tcAddErrCtxtM (unifyCtxt "type" expected_ty actual_ty)
+ = traceTc (text "tcSub" <+> details) `thenM_`
+ addErrCtxtM (unifyCtxt "type" expected_ty actual_ty)
(tc_sub expected_ty expected_ty actual_ty actual_ty)
where
details = vcat [text "Expected:" <+> ppr expected_ty,
-> TcSigmaType -- ..and after
-> TcSigmaType -- actual_ty, before
-> TcSigmaType -- ..and after
- -> TcM (ExprCoFn, LIE)
+ -> TcM ExprCoFn
-----------------------------------
-- Expand synonyms
-- It's really important to check for escape wrt the free vars of
-- both expected_ty *and* actual_ty
\ body_exp_ty -> tc_sub body_exp_ty body_exp_ty act_sty actual_ty
- ) `thenTc` \ (gen_fn, co_fn, lie) ->
- returnTc (gen_fn <.> co_fn, lie)
+ ) `thenM` \ (gen_fn, co_fn) ->
+ returnM (gen_fn <.> co_fn)
-----------------------------------
-- Specialisation case:
tc_sub exp_sty expected_ty act_sty actual_ty
| isSigmaTy actual_ty
- = tcInstCall Rank2Origin actual_ty `thenNF_Tc` \ (inst_fn, lie1, body_ty) ->
- tc_sub exp_sty expected_ty body_ty body_ty `thenTc` \ (co_fn, lie2) ->
- returnTc (co_fn <.> mkCoercion inst_fn, lie1 `plusLIE` lie2)
+ = tcInstCall Rank2Origin actual_ty `thenM` \ (inst_fn, body_ty) ->
+ tc_sub exp_sty expected_ty body_ty body_ty `thenM` \ co_fn ->
+ returnM (co_fn <.> mkCoercion inst_fn)
-----------------------------------
-- Function case
tc_sub exp_sty exp_ty@(FunTy exp_arg exp_res) _ (TyVarTy tv)
= ASSERT( not (isHoleTyVar tv) )
- getTcTyVar tv `thenNF_Tc` \ maybe_ty ->
+ getTcTyVar tv `thenM` \ maybe_ty ->
case maybe_ty of
Just ty -> tc_sub exp_sty exp_ty ty ty
- Nothing -> imitateFun tv exp_sty `thenNF_Tc` \ (act_arg, act_res) ->
+ Nothing -> imitateFun tv exp_sty `thenM` \ (act_arg, act_res) ->
tcSub_fun exp_arg exp_res act_arg act_res
tc_sub _ (TyVarTy tv) act_sty act_ty@(FunTy act_arg act_res)
= ASSERT( not (isHoleTyVar tv) )
- getTcTyVar tv `thenNF_Tc` \ maybe_ty ->
+ getTcTyVar tv `thenM` \ maybe_ty ->
case maybe_ty of
Just ty -> tc_sub ty ty act_sty act_ty
- Nothing -> imitateFun tv act_sty `thenNF_Tc` \ (exp_arg, exp_res) ->
+ Nothing -> imitateFun tv act_sty `thenM` \ (exp_arg, exp_res) ->
tcSub_fun exp_arg exp_res act_arg act_res
-----------------------------------
-- Unification case
-- If none of the above match, we revert to the plain unifier
tc_sub exp_sty expected_ty act_sty actual_ty
- = uTys exp_sty expected_ty act_sty actual_ty `thenTc_`
- returnTc (idCoercion, emptyLIE)
+ = uTys exp_sty expected_ty act_sty actual_ty `thenM_`
+ returnM idCoercion
\end{code}
%************************************************************************
\begin{code}
tcSub_fun exp_arg exp_res act_arg act_res
- = tc_sub act_arg act_arg exp_arg exp_arg `thenTc` \ (co_fn_arg, lie1) ->
- tc_sub exp_res exp_res act_res act_res `thenTc` \ (co_fn_res, lie2) ->
- tcGetUnique `thenNF_Tc` \ uniq ->
+ = tc_sub act_arg act_arg exp_arg exp_arg `thenM` \ co_fn_arg ->
+ tc_sub exp_res exp_res act_res act_res `thenM` \ co_fn_res ->
+ newUnique `thenM` \ uniq ->
let
-- co_fn_arg :: HsExpr exp_arg -> HsExpr act_arg
-- co_fn_res :: HsExpr act_res -> HsExpr exp_res
-- HsApp e $it :: HsExpr act_res
-- co_fn_res $it :: HsExpr exp_res
in
- returnTc (coercion, lie1 `plusLIE` lie2)
+ returnM coercion
-imitateFun :: TcTyVar -> TcType -> NF_TcM (TcType, TcType)
+imitateFun :: TcTyVar -> TcType -> TcM (TcType, TcType)
imitateFun tv ty
= ASSERT( not (isHoleTyVar tv) )
-- NB: tv is an *ordinary* tyvar and so are the new ones
-- Check that tv isn't a type-signature type variable
-- (This would be found later in checkSigTyVars, but
-- we get a better error message if we do it here.)
- checkTcM (not (isSkolemTyVar tv))
- (failWithTcM (unifyWithSigErr tv ty)) `thenTc_`
+ checkM (not (isSkolemTyVar tv))
+ (failWithTcM (unifyWithSigErr tv ty)) `thenM_`
- newTyVarTy openTypeKind `thenNF_Tc` \ arg ->
- newTyVarTy openTypeKind `thenNF_Tc` \ res ->
- putTcTyVar tv (mkFunTy arg res) `thenNF_Tc_`
- returnNF_Tc (arg,res)
+ newTyVarTy openTypeKind `thenM` \ arg ->
+ newTyVarTy openTypeKind `thenM` \ res ->
+ putTcTyVar tv (mkFunTy arg res) `thenM_`
+ returnM (arg,res)
\end{code}
-> TcTyVarSet -- Extra tyvars that the universally
-- quantified tyvars of expected_ty
-- must not be unified
- -> (TcRhoType -> TcM (result, LIE)) -- spec_ty
- -> TcM (ExprCoFn, result, LIE)
+ -> (TcRhoType -> TcM result) -- spec_ty
+ -> TcM (ExprCoFn, result)
-- The expression has type: spec_ty -> expected_ty
tcGen expected_ty extra_tvs thing_inside -- We expect expected_ty to be a forall-type
-- If not, the call is a no-op
- = tcInstType SigTv expected_ty `thenNF_Tc` \ (forall_tvs, theta, phi_ty) ->
+ = tcInstType SigTv expected_ty `thenM` \ (forall_tvs, theta, phi_ty) ->
-- Type-check the arg and unify with poly type
- thing_inside phi_ty `thenTc` \ (result, lie) ->
+ getLIE (thing_inside phi_ty) `thenM` \ (result, lie) ->
-- Check that the "forall_tvs" havn't been constrained
-- The interesting bit here is that we must include the free variables
-- Conclusion: include the free vars of the expected_ty in the
-- list of "free vars" for the signature check.
- newDicts SignatureOrigin theta `thenNF_Tc` \ dicts ->
- tcSimplifyCheck sig_msg forall_tvs dicts lie `thenTc` \ (free_lie, inst_binds) ->
+ newDicts SignatureOrigin theta `thenM` \ dicts ->
+ tcSimplifyCheck sig_msg forall_tvs dicts lie `thenM` \ inst_binds ->
#ifdef DEBUG
- zonkTcTyVars forall_tvs `thenNF_Tc` \ forall_tys ->
+ zonkTcTyVars forall_tvs `thenM` \ forall_tys ->
traceTc (text "tcGen" <+> vcat [text "extra_tvs" <+> ppr extra_tvs,
text "expected_ty" <+> ppr expected_ty,
text "inst ty" <+> ppr forall_tvs <+> ppr theta <+> ppr phi_ty,
text "free_tvs" <+> ppr free_tvs,
- text "forall_tys" <+> ppr forall_tys]) `thenNF_Tc_`
+ text "forall_tys" <+> ppr forall_tys]) `thenM_`
#endif
- checkSigTyVarsWrt free_tvs forall_tvs `thenTc` \ zonked_tvs ->
+ checkSigTyVarsWrt free_tvs forall_tvs `thenM` \ zonked_tvs ->
- traceTc (text "tcGen:done") `thenNF_Tc_`
+ traceTc (text "tcGen:done") `thenM_`
let
-- This HsLet binds any Insts which came out of the simplification.
dict_ids = map instToId dicts
co_fn e = TyLam zonked_tvs (DictLam dict_ids (mkHsLet inst_binds e))
in
- returnTc (mkCoercion co_fn, result, free_lie)
+ returnM (mkCoercion co_fn, result)
where
free_tvs = tyVarsOfType expected_ty `unionVarSet` extra_tvs
sig_msg = ptext SLIT("type of an expression")
-- (no quantification whatsoever)
ASSERT2( isTauTy ty1, ppr ty1 )
ASSERT2( isTauTy ty2, ppr ty2 )
- tcAddErrCtxtM (unifyCtxt "type" ty1 ty2) $
+ addErrCtxtM (unifyCtxt "type" ty1 ty2) $
uTys ty1 ty1 ty2 ty2
\end{code}
\begin{code}
unifyTauTyLists :: [TcTauType] -> [TcTauType] -> TcM ()
-unifyTauTyLists [] [] = returnTc ()
-unifyTauTyLists (ty1:tys1) (ty2:tys2) = uTys ty1 ty1 ty2 ty2 `thenTc_`
+unifyTauTyLists [] [] = returnM ()
+unifyTauTyLists (ty1:tys1) (ty2:tys2) = uTys ty1 ty1 ty2 ty2 `thenM_`
unifyTauTyLists tys1 tys2
unifyTauTyLists ty1s ty2s = panic "Unify.unifyTauTyLists: mismatched type lists!"
\end{code}
\begin{code}
unifyTauTyList :: [TcTauType] -> TcM ()
-unifyTauTyList [] = returnTc ()
-unifyTauTyList [ty] = returnTc ()
-unifyTauTyList (ty1:tys@(ty2:_)) = unifyTauTy ty1 ty2 `thenTc_`
+unifyTauTyList [] = returnM ()
+unifyTauTyList [ty] = returnM ()
+unifyTauTyList (ty1:tys@(ty2:_)) = unifyTauTy ty1 ty2 `thenM_`
unifyTauTyList tys
\end{code}
-- Functions; just check the two parts
uTys _ (FunTy fun1 arg1) _ (FunTy fun2 arg2)
- = uTys fun1 fun1 fun2 fun2 `thenTc_` uTys arg1 arg1 arg2 arg2
+ = uTys fun1 fun1 fun2 fun2 `thenM_` uTys arg1 arg1 arg2 arg2
-- Type constructors must match
uTys ps_ty1 (TyConApp con1 tys1) ps_ty2 (TyConApp con2 tys2)
-- so if one type is an App the other one jolly well better be too
uTys ps_ty1 (AppTy s1 t1) ps_ty2 ty2
= case tcSplitAppTy_maybe ty2 of
- Just (s2,t2) -> uTys s1 s1 s2 s2 `thenTc_` uTys t1 t1 t2 t2
+ Just (s2,t2) -> uTys s1 s1 s2 s2 `thenM_` uTys t1 t1 t2 t2
Nothing -> unifyMisMatch ps_ty1 ps_ty2
-- Now the same, but the other way round
-- Don't swap the types, because the error messages get worse
uTys ps_ty1 ty1 ps_ty2 (AppTy s2 t2)
= case tcSplitAppTy_maybe ty1 of
- Just (s1,t1) -> uTys s1 s1 s2 s2 `thenTc_` uTys t1 t1 t2 t2
+ Just (s1,t1) -> uTys s1 s1 s2 s2 `thenM_` uTys t1 t1 t2 t2
Nothing -> unifyMisMatch ps_ty1 ps_ty2
-- Not expecting for-alls in unification
-> TcM ()
uVar swapped tv1 ps_ty2 ty2
- = traceTc (text "uVar" <+> ppr swapped <+> ppr tv1 <+> (ppr ps_ty2 $$ ppr ty2)) `thenNF_Tc_`
- getTcTyVar tv1 `thenNF_Tc` \ maybe_ty1 ->
+ = traceTc (text "uVar" <+> ppr swapped <+> ppr tv1 <+> (ppr ps_ty2 $$ ppr ty2)) `thenM_`
+ getTcTyVar tv1 `thenM` \ maybe_ty1 ->
case maybe_ty1 of
Just ty1 | swapped -> uTys ps_ty2 ty2 ty1 ty1 -- Swap back
| otherwise -> uTys ty1 ty1 ps_ty2 ty2 -- Same order
-- Same type variable => no-op
| tv1 == tv2
- = returnTc ()
+ = returnM ()
-- Distinct type variables
-- ASSERT maybe_ty1 /= Just
| otherwise
- = getTcTyVar tv2 `thenNF_Tc` \ maybe_ty2 ->
+ = getTcTyVar tv2 `thenM` \ maybe_ty2 ->
case maybe_ty2 of
Just ty2' -> uUnboundVar swapped tv1 maybe_ty1 ty2' ty2'
Nothing | update_tv2
-> WARN( not (k1 `hasMoreBoxityInfo` k2), (ppr tv1 <+> ppr k1) $$ (ppr tv2 <+> ppr k2) )
- putTcTyVar tv2 (TyVarTy tv1) `thenNF_Tc_`
- returnTc ()
+ putTcTyVar tv2 (TyVarTy tv1) `thenM_`
+ returnM ()
| otherwise
-> WARN( not (k2 `hasMoreBoxityInfo` k1), (ppr tv2 <+> ppr k2) $$ (ppr tv1 <+> ppr k1) )
- putTcTyVar tv1 ps_ty2 `thenNF_Tc_`
- returnTc ()
+ putTcTyVar tv1 ps_ty2 `thenM_`
+ returnM ()
where
k1 = tyVarKind tv1
k2 = tyVarKind tv2
-- Second one isn't a type variable
uUnboundVar swapped tv1 maybe_ty1 ps_ty2 non_var_ty2
= -- Check that tv1 isn't a type-signature type variable
- checkTcM (not (isSkolemTyVar tv1))
- (failWithTcM (unifyWithSigErr tv1 ps_ty2)) `thenTc_`
+ checkM (not (isSkolemTyVar tv1))
+ (failWithTcM (unifyWithSigErr tv1 ps_ty2)) `thenM_`
-- Do the occurs check, and check that we are not
-- unifying a type variable with a polytype
-- Returns a zonked type ready for the update
- checkValue tv1 ps_ty2 non_var_ty2 `thenTc` \ ty2 ->
+ checkValue tv1 ps_ty2 non_var_ty2 `thenM` \ ty2 ->
-- Check that the kinds match
- checkKinds swapped tv1 ty2 `thenTc_`
+ checkKinds swapped tv1 ty2 `thenM_`
-- Perform the update
- putTcTyVar tv1 ty2 `thenNF_Tc_`
- returnTc ()
+ putTcTyVar tv1 ty2 `thenM_`
+ returnM ()
\end{code}
\begin{code}
-- We're about to unify a type variable tv1 with a non-tyvar-type ty2.
-- ty2 has been zonked at this stage, which ensures that
-- its kind has as much boxity information visible as possible.
- | tk2 `hasMoreBoxityInfo` tk1 = returnTc ()
+ | tk2 `hasMoreBoxityInfo` tk1 = returnM ()
| otherwise
-- Either the kinds aren't compatible
-- (can happen if we unify (a b) with (c d))
-- or we are unifying a lifted type variable with an
-- unlifted type: e.g. (id 3#) is illegal
- = tcAddErrCtxtM (unifyKindCtxt swapped tv1 ty2) $
+ = addErrCtxtM (unifyKindCtxt swapped tv1 ty2) $
unifyMisMatch k1 k2
where
-- Rather, we should bind t to () (= non_var_ty2).
--
-- That's why we have this two-state occurs-check
- = zonkTcType ps_ty2 `thenNF_Tc` \ ps_ty2' ->
+ = zonkTcType ps_ty2 `thenM` \ ps_ty2' ->
case okToUnifyWith tv1 ps_ty2' of {
- Nothing -> returnTc ps_ty2' ; -- Success
+ Nothing -> returnM ps_ty2' ; -- Success
other ->
- zonkTcType non_var_ty2 `thenNF_Tc` \ non_var_ty2' ->
+ zonkTcType non_var_ty2 `thenM` \ non_var_ty2' ->
case okToUnifyWith tv1 non_var_ty2' of
Nothing -> -- This branch rarely succeeds, except in strange cases
-- like that in the example above
- returnTc non_var_ty2'
+ returnM non_var_ty2'
Just problem -> failWithTcM (unifyCheck problem tv1 ps_ty2')
}
subFunTy ty@(TyVarTy tyvar) thing_inside
| isHoleTyVar tyvar
= -- This is the interesting case
- getTcTyVar tyvar `thenNF_Tc` \ maybe_ty ->
+ getTcTyVar tyvar `thenM` \ maybe_ty ->
case maybe_ty of {
Just ty' -> subFunTy ty' thing_inside ;
Nothing ->
- newHoleTyVarTy `thenNF_Tc` \ arg_ty ->
- newHoleTyVarTy `thenNF_Tc` \ res_ty ->
+ newHoleTyVarTy `thenM` \ arg_ty ->
+ newHoleTyVarTy `thenM` \ res_ty ->
-- Do the business
- thing_inside arg_ty res_ty `thenTc` \ answer ->
+ thing_inside arg_ty res_ty `thenM` \ answer ->
-- Extract the answers
- readHoleResult arg_ty `thenNF_Tc` \ arg_ty' ->
- readHoleResult res_ty `thenNF_Tc` \ res_ty' ->
+ readHoleResult arg_ty `thenM` \ arg_ty' ->
+ readHoleResult res_ty `thenM` \ res_ty' ->
-- Write the answer into the incoming hole
- putTcTyVar tyvar (mkFunTy arg_ty' res_ty') `thenNF_Tc_`
+ putTcTyVar tyvar (mkFunTy arg_ty' res_ty') `thenM_`
-- And return the answer
- returnTc answer }
+ returnM answer }
subFunTy ty thing_inside
- = unifyFunTy ty `thenTc` \ (arg,res) ->
+ = unifyFunTy ty `thenM` \ (arg,res) ->
thing_inside arg res
unifyFunTy ty@(TyVarTy tyvar)
= ASSERT( not (isHoleTyVar tyvar) )
- getTcTyVar tyvar `thenNF_Tc` \ maybe_ty ->
+ getTcTyVar tyvar `thenM` \ maybe_ty ->
case maybe_ty of
Just ty' -> unifyFunTy ty'
Nothing -> unify_fun_ty_help ty
unifyFunTy ty
= case tcSplitFunTy_maybe ty of
- Just arg_and_res -> returnTc arg_and_res
+ Just arg_and_res -> returnM arg_and_res
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 ->
- unifyTauTy ty (mkFunTy arg res) `thenTc_`
- returnTc (arg,res)
+ = newTyVarTy openTypeKind `thenM` \ arg ->
+ newTyVarTy openTypeKind `thenM` \ res ->
+ unifyTauTy ty (mkFunTy arg res) `thenM_`
+ returnM (arg,res)
\end{code}
\begin{code}
-> TcM TcType -- list element type
unifyListTy ty@(TyVarTy tyvar)
- = getTcTyVar tyvar `thenNF_Tc` \ maybe_ty ->
+ = getTcTyVar tyvar `thenM` \ maybe_ty ->
case maybe_ty of
Just ty' -> unifyListTy ty'
other -> unify_list_ty_help ty
unifyListTy ty
= case tcSplitTyConApp_maybe ty of
- Just (tycon, [arg_ty]) | tycon == listTyCon -> returnTc arg_ty
+ Just (tycon, [arg_ty]) | tycon == listTyCon -> returnM arg_ty
other -> unify_list_ty_help ty
unify_list_ty_help ty -- Revert to ordinary unification
- = newTyVarTy liftedTypeKind `thenNF_Tc` \ elt_ty ->
- unifyTauTy ty (mkListTy elt_ty) `thenTc_`
- returnTc elt_ty
+ = newTyVarTy liftedTypeKind `thenM` \ elt_ty ->
+ unifyTauTy ty (mkListTy elt_ty) `thenM_`
+ returnM elt_ty
-- variant for parallel arrays
--
-> TcM TcType -- list element type
unifyPArrTy ty@(TyVarTy tyvar)
- = getTcTyVar tyvar `thenNF_Tc` \ maybe_ty ->
+ = getTcTyVar tyvar `thenM` \ maybe_ty ->
case maybe_ty of
Just ty' -> unifyPArrTy ty'
_ -> unify_parr_ty_help ty
unifyPArrTy ty
= case tcSplitTyConApp_maybe ty of
- Just (tycon, [arg_ty]) | tycon == parrTyCon -> returnTc arg_ty
+ Just (tycon, [arg_ty]) | tycon == parrTyCon -> returnM arg_ty
_ -> unify_parr_ty_help ty
unify_parr_ty_help ty -- Revert to ordinary unification
- = newTyVarTy liftedTypeKind `thenNF_Tc` \ elt_ty ->
- unifyTauTy ty (mkPArrTy elt_ty) `thenTc_`
- returnTc elt_ty
+ = newTyVarTy liftedTypeKind `thenM` \ elt_ty ->
+ unifyTauTy ty (mkPArrTy elt_ty) `thenM_`
+ returnM elt_ty
\end{code}
\begin{code}
unifyTupleTy :: Boxity -> Arity -> TcType -> TcM [TcType]
unifyTupleTy boxity arity ty@(TyVarTy tyvar)
- = getTcTyVar tyvar `thenNF_Tc` \ maybe_ty ->
+ = getTcTyVar tyvar `thenM` \ maybe_ty ->
case maybe_ty of
Just ty' -> unifyTupleTy boxity arity ty'
other -> unify_tuple_ty_help boxity arity ty
| isTupleTyCon tycon
&& tyConArity tycon == arity
&& tupleTyConBoxity tycon == boxity
- -> returnTc arg_tys
+ -> returnM arg_tys
other -> unify_tuple_ty_help boxity arity ty
unify_tuple_ty_help boxity arity ty
- = newTyVarTys arity kind `thenNF_Tc` \ arg_tys ->
- unifyTauTy ty (mkTupleTy boxity arity arg_tys) `thenTc_`
- returnTc arg_tys
+ = newTyVarTys arity kind `thenM` \ arg_tys ->
+ unifyTauTy ty (mkTupleTy boxity arity arg_tys) `thenM_`
+ returnM arg_tys
where
kind | isBoxed boxity = liftedTypeKind
| otherwise = openTypeKind
-> TcKind -- Actual
-> TcM ()
unifyKind k1 k2
- = tcAddErrCtxtM (unifyCtxt "kind" k1 k2) $
+ = addErrCtxtM (unifyCtxt "kind" k1 k2) $
uTys k1 k1 k2 k2
unifyKinds :: [TcKind] -> [TcKind] -> TcM ()
-unifyKinds [] [] = returnTc ()
-unifyKinds (k1:ks1) (k2:ks2) = unifyKind k1 k2 `thenTc_`
+unifyKinds [] [] = returnM ()
+unifyKinds (k1:ks1) (k2:ks2) = unifyKind k1 k2 `thenM_`
unifyKinds ks1 ks2
unifyKinds _ _ = panic "unifyKinds: length mis-match"
\end{code}
-- for some boxity bx
unifyOpenTypeKind ty@(TyVarTy tyvar)
- = getTcTyVar tyvar `thenNF_Tc` \ maybe_ty ->
+ = getTcTyVar tyvar `thenM` \ maybe_ty ->
case maybe_ty of
Just ty' -> unifyOpenTypeKind ty'
other -> unify_open_kind_help ty
unifyOpenTypeKind ty
- | isTypeKind ty = returnTc ()
+ | isTypeKind ty = returnM ()
| otherwise = unify_open_kind_help ty
unify_open_kind_help ty -- Revert to ordinary unification
- = newBoxityVar `thenNF_Tc` \ boxity ->
+ = newBoxityVar `thenM` \ boxity ->
unifyKind ty (mkTyConApp typeCon [boxity])
\end{code}
\begin{code}
unifyCtxt s ty1 ty2 tidy_env -- ty1 expected, ty2 inferred
- = zonkTcType ty1 `thenNF_Tc` \ ty1' ->
- zonkTcType ty2 `thenNF_Tc` \ ty2' ->
- returnNF_Tc (err ty1' ty2')
+ = zonkTcType ty1 `thenM` \ ty1' ->
+ zonkTcType ty2 `thenM` \ ty2' ->
+ returnM (err ty1' ty2')
where
err ty1 ty2 = (env1,
nest 4
unifyKindCtxt swapped tv1 ty2 tidy_env -- not swapped => tv1 expected, ty2 inferred
-- tv1 is zonked already
- = zonkTcType ty2 `thenNF_Tc` \ ty2' ->
- returnNF_Tc (err ty2')
+ = zonkTcType ty2 `thenM` \ ty2' ->
+ returnM (err ty2')
where
err ty2 = (env2, ptext SLIT("When matching types") <+>
sep [quotes pp_expected, ptext SLIT("and"), quotes pp_actual])
pp2 = ppr ty2'
unifyMisMatch ty1 ty2
- = zonkTcType ty1 `thenNF_Tc` \ ty1' ->
- zonkTcType ty2 `thenNF_Tc` \ ty2' ->
+ = zonkTcType ty1 `thenM` \ ty1' ->
+ zonkTcType ty2 `thenM` \ ty2' ->
let
(env, [tidy_ty1, tidy_ty2]) = tidyOpenTypes emptyTidyEnv [ty1',ty2']
msg = hang (ptext SLIT("Couldn't match"))
checkSigTyVarsWrt :: TcTyVarSet -> [TcTyVar] -> TcM [TcTyVar]
checkSigTyVarsWrt extra_tvs sig_tvs
- = zonkTcTyVarsAndFV (varSetElems extra_tvs) `thenNF_Tc` \ extra_tvs' ->
+ = zonkTcTyVarsAndFV (varSetElems extra_tvs) `thenM` \ extra_tvs' ->
check_sig_tyvars extra_tvs' sig_tvs
check_sig_tyvars
-> TcM [TcTyVar] -- Zonked signature type variables
check_sig_tyvars extra_tvs []
- = returnTc []
+ = returnM []
check_sig_tyvars extra_tvs sig_tvs
- = zonkTcTyVars sig_tvs `thenNF_Tc` \ sig_tys ->
- tcGetGlobalTyVars `thenNF_Tc` \ gbl_tvs ->
+ = zonkTcTyVars sig_tvs `thenM` \ sig_tys ->
+ tcGetGlobalTyVars `thenM` \ gbl_tvs ->
let
env_tvs = gbl_tvs `unionVarSet` extra_tvs
in
traceTc (text "check_sig_tyvars" <+> (vcat [text "sig_tys" <+> ppr sig_tys,
text "gbl_tvs" <+> ppr gbl_tvs,
- text "extra_tvs" <+> ppr extra_tvs])) `thenNF_Tc_`
+ text "extra_tvs" <+> ppr extra_tvs])) `thenM_`
- checkTcM (allDistinctTyVars sig_tys env_tvs)
- (complain sig_tys env_tvs) `thenTc_`
+ checkM (allDistinctTyVars sig_tys env_tvs)
+ (complain sig_tys env_tvs) `thenM_`
- returnTc (map (tcGetTyVar "checkSigTyVars") sig_tys)
+ returnM (map (tcGetTyVar "checkSigTyVars") sig_tys)
where
complain sig_tys globals
= -- "check" checks each sig tyvar in turn
- foldlNF_Tc check
- (env2, emptyVarEnv, [])
- (tidy_tvs `zip` tidy_tys) `thenNF_Tc` \ (env3, _, msgs) ->
+ foldlM check
+ (env2, emptyVarEnv, [])
+ (tidy_tvs `zip` tidy_tys) `thenM` \ (env3, _, msgs) ->
failWithTcM (env3, main_msg $$ nest 4 (vcat msgs))
where
-- acc maps a zonked type variable back to a signature type variable
= case tcGetTyVar_maybe ty of {
Nothing -> -- Error (a)!
- returnNF_Tc (tidy_env, acc, unify_msg sig_tyvar (quotes (ppr ty)) : msgs) ;
+ returnM (tidy_env, acc, unify_msg sig_tyvar (quotes (ppr ty)) : msgs) ;
Just tv ->
case lookupVarEnv acc tv of {
Just sig_tyvar' -> -- Error (b)!
- returnNF_Tc (tidy_env, acc, unify_msg sig_tyvar thing : msgs)
+ returnM (tidy_env, acc, unify_msg sig_tyvar thing : msgs)
where
thing = ptext SLIT("another quantified type variable") <+> quotes (ppr sig_tyvar')
-- Game plan:
-- get the local TcIds and TyVars from the environment,
-- and pass them to find_globals (they might have tv free)
- then tcGetEnv `thenNF_Tc` \ ve ->
- find_globals tv tidy_env (tcLEnvElts ve) `thenNF_Tc` \ (tidy_env1, globs) ->
- returnNF_Tc (tidy_env1, acc, escape_msg sig_tyvar tv globs : msgs)
+ then getLclEnvElts `thenM` \ ve ->
+ find_globals tv tidy_env ve `thenM` \ (tidy_env1, globs) ->
+ returnM (tidy_env1, acc, escape_msg sig_tyvar tv globs : msgs)
else -- All OK
- returnNF_Tc (tidy_env, extendVarEnv acc tv sig_tyvar, msgs)
+ returnM (tidy_env, extendVarEnv acc tv sig_tyvar, msgs)
}}
\end{code}
find_globals :: Var
-> TidyEnv
-> [TcTyThing]
- -> NF_TcM (TidyEnv, [SDoc])
+ -> TcM (TidyEnv, [SDoc])
find_globals tv tidy_env things
= go tidy_env [] things
where
- go tidy_env acc [] = returnNF_Tc (tidy_env, acc)
+ go tidy_env acc [] = returnM (tidy_env, acc)
go tidy_env acc (thing : things)
- = find_thing ignore_it tidy_env thing `thenNF_Tc` \ (tidy_env1, maybe_doc) ->
+ = find_thing ignore_it tidy_env thing `thenM` \ (tidy_env1, maybe_doc) ->
case maybe_doc of
Just d -> go tidy_env1 (d:acc) things
Nothing -> go tidy_env1 acc things
ignore_it ty = not (tv `elemVarSet` tyVarsOfType ty)
-----------------------
-find_thing ignore_it tidy_env (ATcId id)
- = zonkTcType (idType id) `thenNF_Tc` \ id_ty ->
+find_thing ignore_it tidy_env (ATcId id _)
+ = zonkTcType (idType id) `thenM` \ id_ty ->
if ignore_it id_ty then
- returnNF_Tc (tidy_env, Nothing)
+ returnM (tidy_env, Nothing)
else let
(tidy_env', tidy_ty) = tidyOpenType tidy_env id_ty
msg = sep [ppr id <+> dcolon <+> ppr tidy_ty,
nest 2 (parens (ptext SLIT("bound at") <+>
ppr (getSrcLoc id)))]
in
- returnNF_Tc (tidy_env', Just msg)
+ returnM (tidy_env', Just msg)
find_thing ignore_it tidy_env (ATyVar tv)
- = zonkTcTyVar tv `thenNF_Tc` \ tv_ty ->
+ = zonkTcTyVar tv `thenM` \ tv_ty ->
if ignore_it tv_ty then
- returnNF_Tc (tidy_env, Nothing)
+ returnM (tidy_env, Nothing)
else let
(tidy_env1, tv1) = tidyOpenTyVar tidy_env tv
(tidy_env2, tidy_ty) = tidyOpenType tidy_env1 tv_ty
bound_at = tyVarBindingInfo tv
in
- returnNF_Tc (tidy_env2, Just msg)
+ returnM (tidy_env2, Just msg)
-----------------------
escape_msg sig_tv tv globs
\begin{code}
sigCtxt :: Id -> [TcTyVar] -> TcThetaType -> TcTauType
- -> TidyEnv -> NF_TcM (TidyEnv, Message)
+ -> TidyEnv -> TcM (TidyEnv, Message)
sigCtxt id sig_tvs sig_theta sig_tau tidy_env
- = zonkTcType sig_tau `thenNF_Tc` \ actual_tau ->
+ = zonkTcType sig_tau `thenM` \ actual_tau ->
let
(env1, tidy_sig_tvs) = tidyOpenTyVars tidy_env sig_tvs
(env2, tidy_sig_rho) = tidyOpenType env1 (mkPhiTy sig_theta sig_tau)
msg = vcat [ptext SLIT("When trying to generalise the type inferred for") <+> quotes (ppr id),
nest 4 sub_msg]
in
- returnNF_Tc (env3, msg)
+ returnM (env3, msg)
\end{code}
\begin{code}
grow :: [PredType] -> TyVarSet -> TyVarSet
grow preds fixed_tvs
- | null pred_sets = fixed_tvs
- | otherwise = loop fixed_tvs
+ | null preds = fixed_tvs
+ | otherwise = loop fixed_tvs
where
loop fixed_tvs
| new_fixed_tvs `subVarSet` fixed_tvs = fixed_tvs
import RnHsSyn ( RenamedHsExpr )
-import HsSyn ( HsExpr(..), InPat(..), mkSimpleMatch, placeHolderType )
+import HsSyn ( HsExpr(..), Pat(..), mkSimpleMatch, placeHolderType )
import Type ( Type, isUnLiftedType, tyVarsOfType, tyVarsOfTypes,
mkTyVarTys, mkForAllTys, mkTyConApp,
import CoreUnfold ( mkTopUnfolding )
import Maybe ( isNothing )
-import SrcLoc ( builtinSrcLoc )
+import SrcLoc ( noSrcLoc )
import Unique ( Unique, builtinUniques, mkBuiltinUnique )
import Util ( takeList, dropList )
import Outputable
-------------------
-- bimapArrow :: [EP a a', EP b b'] -> EP (a->b) (a'->b')
bimapArrow [ep1, ep2]
- = EP { fromEP = mk_hs_lam [VarPatIn g1, VarPatIn g2] from_body,
- toEP = mk_hs_lam [VarPatIn g1, VarPatIn g2] to_body }
+ = EP { fromEP = mk_hs_lam [VarPat g1, VarPat g2] from_body,
+ toEP = mk_hs_lam [VarPat g1, VarPat g2] to_body }
where
from_body = fromEP ep2 `HsApp` (HsPar $ HsVar g1 `HsApp` (HsPar $ toEP ep1 `HsApp` HsVar g2))
to_body = toEP ep2 `HsApp` (HsPar $ HsVar g1 `HsApp` (HsPar $ fromEP ep1 `HsApp` HsVar g2))
toEP = mk_hs_lam [tuple_pat] to_body }
where
names = takeList eps genericNames
- tuple_pat = TuplePatIn (map VarPatIn names) Boxed
+ tuple_pat = TuplePat (map VarPat names) Boxed
eps_w_names = eps `zip` names
to_body = ExplicitTuple [toEP ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed
from_body = ExplicitTuple [fromEP ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed
genericNames = [mkSystemName (mkBuiltinUnique i) (mkFastString ('g' : show i)) | i <- [1..]]
(g1:g2:g3:_) = genericNames
-mk_hs_lam pats body = HsPar (HsLam (mkSimpleMatch pats body placeHolderType builtinSrcLoc))
+mk_hs_lam pats body = HsPar (HsLam (mkSimpleMatch pats body placeHolderType noSrcLoc))
idEP :: EP RenamedHsExpr
idEP = EP idexpr idexpr
where
- idexpr = mk_hs_lam [VarPatIn g3] (HsVar g3)
+ idexpr = mk_hs_lam [VarPat g3] (HsVar g3)
\end{code}
import VarSet
import VarEnv
import Maybes ( MaybeErr(..), returnMaB, failMaB, thenMaB, maybeToBool )
-import Name ( getSrcLoc )
+import Name ( getSrcLoc, nameModule )
+import SrcLoc ( isGoodSrcLoc )
import TcType ( Type, tcTyConAppTyCon, mkTyVarTy,
tcSplitDFunTy, tyVarsOfTypes,
matchTys, unifyTyListsX, allDistinctTyVars
import TyCon ( TyCon )
import Outputable
import UniqFM ( UniqFM, lookupWithDefaultUFM, addToUFM, emptyUFM, eltsUFM )
-import Id ( idType )
+import Id ( idType, idName )
import ErrUtils ( Message )
import CmdLineOpts
import Util ( notNull )
addInstErr what dfun1 dfun2
= hang what 2 (ppr_dfun dfun1 $$ ppr_dfun dfun2)
where
- ppr_dfun dfun = ppr (getSrcLoc dfun) <> colon <+> pprClassPred clas tys
- where
- (_,_,clas,tys) = tcSplitDFunTy (idType dfun)
+ ppr_dfun dfun = pp_loc <> colon <+> pprClassPred clas tys
+ where
+ (_,_,clas,tys) = tcSplitDFunTy (idType dfun)
+ loc = getSrcLoc dfun
+ mod = nameModule (idName dfun)
+
+ -- Worth trying to print a good location... imported dfuns
+ -- don't have a useful SrcLoc but we can say which module they come from
+ pp_loc | isGoodSrcLoc loc = ppr loc
+ | otherwise = ptext SLIT("In module") <+> ppr mod
\end{code}
instance Outputable name => Outputable (IPName name) where
ppr (Dupable n) = char '?' <> ppr n -- Ordinary implicit parameters
ppr (Linear n) = char '%' <> ppr n -- Splittable implicit parameters
+
+instance Outputable name => OutputableBndr (IPName name) where
+ pprBndr _ n = ppr n -- Simple for now
\end{code}
addFreeTyVars ty = NoteTy (FTVNote (tyVarsOfType ty)) ty
\end{code}
-
-
%************************************************************************
%* *
\subsection{TidyType}
) where
+#include "HsVersions.h"
#include "MachDeps.h"
import {-# SOURCE #-} Module
import FastMutInt
#if __GLASGOW_HASKELL__ < 503
-import IOExts
-import Bits
-import Int
-import Word
+import DATA_IOREF
+import DATA_BITS
+import DATA_INT
+import DATA_WORD
import Char
import Monad
import Exception
\begin{code}
module Outputable (
- Outputable(..), -- Class
+ Outputable(..), OutputableBndr(..), -- Class
+
+ BindingSite(..),
PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify,
getPprStyle, withPprStyle, withPprStyleDoc, pprDeeper,
codeStyle, userStyle, debugStyle, asmStyle,
- ifPprDebug, unqualStyle,
+ ifPprDebug, unqualStyle,
+ mkErrStyle, defaultErrStyle,
SDoc, -- Abstract
docToSDoc,
defaultUserStyle = mkUserStyle alwaysQualify AllTheWay
+mkErrStyle :: PrintUnqualified -> PprStyle
+-- Style for printing error messages
+mkErrStyle print_unqual = mkUserStyle print_unqual (PartWay opt_PprUserLength)
+
+defaultErrStyle :: PprStyle
+-- Default style for error messages
+-- It's a bit of a hack because it doesn't take into account what's in scope
+-- Only used for desugarer warnings, and typechecker errors in interface sigs
+defaultErrStyle
+ | opt_PprStyle_Debug = mkUserStyle alwaysQualify AllTheWay
+ | otherwise = mkUserStyle neverQualify (PartWay opt_PprUserLength)
+
mkUserStyle unqual depth | opt_PprStyle_Debug = PprDebug
| otherwise = PprUser unqual depth
\end{code}
-- I'm not sure whether the direct-IO approach of Pretty.printDoc
-- above is better or worse than the put-big-string approach here
-printErrs :: PrintUnqualified -> SDoc -> IO ()
-printErrs unqual doc = do
- Pretty.printDoc PageMode stderr (doc style)
- hFlush stderr
- where
- style = mkUserStyle unqual (PartWay opt_PprUserLength)
+printErrs :: Doc -> IO ()
+printErrs doc = do Pretty.printDoc PageMode stderr doc
+ hFlush stderr
printDump :: SDoc -> IO ()
printDump doc = do
instance Outputable FastString where
ppr fs = text (unpackFS fs) -- Prints an unadorned string,
-- no double quotes or anything
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{The @OutputableBndr@ class}
+%* *
+%************************************************************************
+
+When we print a binder, we often want to print its type too.
+The @OutputableBndr@ class encapsulates this idea.
+
+@BindingSite@ is used to tell the thing that prints binder what
+language construct is binding the identifier. This can be used
+to decide how much info to print.
+\begin{code}
+data BindingSite = LambdaBind | CaseBind | LetBind
+
+class Outputable a => OutputableBndr a where
+ pprBndr :: BindingSite -> a -> SDoc
+ pprBndr b x = ppr x
+\end{code}
+
+
+
+%************************************************************************
+%* *
+\subsection{Random printing helpers}
+%* *
+%************************************************************************
+
+\begin{code}
#if __GLASGOW_HASKELL__ < 410
-- Assume we have only 8-bit Chars.
(
GhcException(..), ghcError, progName,
panic, panic#, assertPanic, trace,
- showGhcException
+ showException, showGhcException, throwDyn
) where
#include "HsVersions.h"
short_usage = "Usage: For basic information, try the `--help' option."
+showException :: Exception -> String
+-- Show expected dynamic exceptions specially
+showException (DynException d) | Just e <- fromDynamic d
+ = show (e::GhcException)
+showException other_exn = show other_exn
+
instance Show GhcException where
showsPrec _ e@(ProgramError _) = showGhcException e
showsPrec _ e = showString progName . showString ": " . showGhcException e
printDoc :: Mode -> Handle -> Doc -> IO ()
printDoc mode hdl doc
- = fullRender mode pprCols 1.5 put done doc
+ = do { fullRender mode pprCols 1.5 put done doc ;
+ hFlush hdl }
where
put (Chr c) next = hPutChar hdl c >> next
put (Str s) next = hPutStr hdl s >> next
lexemeIndex, -- :: StringBuffer -> Int#
-- moving the end point of the current lexeme.
- setCurrentPos#, -- :: StringBuffer -> Int# -> StringBuffer
- incLexeme, -- :: StringBuffer -> StringBuffer
- decLexeme, -- :: StringBuffer -> StringBuffer
+ addToCurrentPos, -- :: StringBuffer -> Int# -> StringBuffer
+ incCurrentPos, -- :: StringBuffer -> StringBuffer
+ decCurrentPos, -- :: StringBuffer -> StringBuffer
-- move the start and end lexeme pointer on by x units.
stepOn, -- :: StringBuffer -> StringBuffer
import Foreign
#if __GLASGOW_HASKELL__ >= 502
-import CForeign
+import CString ( newCString )
#endif
import IO ( openFile, isEOFError )
\begin{code}
-- moving the end point of the current lexeme.
-setCurrentPos# :: StringBuffer -> Int# -> StringBuffer
-setCurrentPos# (StringBuffer fo l# s# c#) i# =
+addToCurrentPos :: StringBuffer -> Int# -> StringBuffer
+addToCurrentPos (StringBuffer fo l# s# c#) i# =
StringBuffer fo l# s# (c# +# i#)
-- augmenting the current lexeme by one.
-incLexeme :: StringBuffer -> StringBuffer
-incLexeme (StringBuffer fo l# s# c#) = StringBuffer fo l# s# (c# +# 1#)
+incCurrentPos :: StringBuffer -> StringBuffer
+incCurrentPos (StringBuffer fo l# s# c#) = StringBuffer fo l# s# (c# +# 1#)
-decLexeme :: StringBuffer -> StringBuffer
-decLexeme (StringBuffer fo l# s# c#) = StringBuffer fo l# s# (c# -# 1#)
+decCurrentPos :: StringBuffer -> StringBuffer
+decCurrentPos (StringBuffer fo l# s# c#) = StringBuffer fo l# s# (c# -# 1#)
\end{code}
min = let ?cmp = (<=) in least
</programlisting>
<para>
-Note the following additional constraints:
+Note the following points:
<itemizedlist>
+<listitem><para>
+You may not mix implicit-parameter bindings with ordinary bindings in a
+single <literal>let</literal>
+expression; use two nested <literal>let</literal>s instead.
+</para></listitem>
+
+<listitem><para>
+You may put multiple implicit-parameter bindings in a
+single <literal>let</literal> expression; they are <emphasis>not</emphasis> treated
+as a mutually recursive group (as ordinary <literal>let</literal> bindings are).
+Instead they are treated as a non-recursive group, each scoping over the bindings that
+follow. For example, consider:
+<programlisting>
+ f y = let { ?x = y; ?x = ?x+1 } in ?x
+</programlisting>
+This function adds one to its argument.
+</para></listitem>
+
+<listitem><para>
+You may not have an implicit-parameter binding in a <literal>where</literal> clause,
+only in a <literal>let</literal> binding.
+</para></listitem>
+
<listitem>
<para> You can't have an implicit parameter in the context of a class or instance
declaration. For example, both these declarations are illegal:
/* -----------------------------------------------------------------------------
- * $Id: Linker.c,v 1.102 2002/09/05 08:58:56 simonmar Exp $
+ * $Id: Linker.c,v 1.103 2002/09/13 15:02:50 simonpj Exp $
*
* (c) The GHC Team, 2000, 2001
*
/* -----------------------------------------------------------------------------
* initialize the object linker
*/
+
+
+static int linker_init_done = 0 ;
+
#if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
static void *dl_prog_handle;
#endif
{
RtsSymbolVal *sym;
+ /* Make initLinker idempotent, so we can call it
+ before evey relevant operation; that means we
+ don't need to initialise the linker separately */
+ if (linker_init_done == 1) { return; } else {
+ linker_init_done = 1;
+ }
+
symhash = allocStrHashTable();
/* populate the symbol table with stuff from the RTS */
}
/* -----------------------------------------------------------------------------
+ * Loading DLL or .so dynamic libraries
+ * -----------------------------------------------------------------------------
+ *
* Add a DLL from which symbols may be found. In the ELF case, just
* do RTLD_GLOBAL-style add, so no further messing around needs to
* happen in order that symbols in the loaded .so are findable --
*
* In the PEi386 case, open the DLLs and put handles to them in a
* linked list. When looking for a symbol, try all handles in the
- * list.
+ * list. This means that we need to load even DLLs that are guaranteed
+ * to be in the ghc.exe image already, just so we can get a handle
+ * to give to loadSymbol, so that we can find the symbols. For such
+ * libraries, the LoadLibrary call should be a no-op except for returning
+ * the handle.
+ *
*/
#if defined(OBJFORMAT_PEi386)
static OpenedDLL* opened_dlls = NULL;
#endif
-
-
char *
addDLL( char *dll_name )
{
# if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)
+ /* ------------------- ELF DLL loader ------------------- */
void *hdl;
char *errmsg;
+ initLinker();
+
hdl= dlopen(dll_name, RTLD_NOW | RTLD_GLOBAL);
if (hdl == NULL) {
/* dlopen failed; return a ptr to the error msg. */
/*NOTREACHED*/
# elif defined(OBJFORMAT_PEi386)
+ /* ------------------- Win32 DLL loader ------------------- */
- /* Add this DLL to the list of DLLs in which to search for symbols.
- The path argument is ignored. */
char* buf;
OpenedDLL* o_dll;
HINSTANCE instance;
- /* fprintf(stderr, "\naddDLL; path=`%s', dll_name = `%s'\n", path, dll_name); */
+ initLinker();
+
+ /* fprintf(stderr, "\naddDLL; dll_name = `%s'\n", dll_name); */
/* See if we've already got it, and ignore if so. */
for (o_dll = opened_dlls; o_dll != NULL; o_dll = o_dll->next) {
return NULL;
}
+ /* The file name has no suffix (yet) so that we can try
+ both foo.dll and foo.drv
+
+ The documentation for LoadLibrary says:
+ If no file name extension is specified in the lpFileName
+ parameter, the default library extension .dll is
+ appended. However, the file name string can include a trailing
+ point character (.) to indicate that the module name has no
+ extension. */
+
buf = stgMallocBytes(strlen(dll_name) + 10, "addDLL");
sprintf(buf, "%s.DLL", dll_name);
instance = LoadLibrary(buf);
if (instance == NULL) {
- sprintf(buf, "%s.DRV", dll_name); // KAA: allow loading of drivers (like winspool.drv)
+ sprintf(buf, "%s.DRV", dll_name); // KAA: allow loading of drivers (like winspool.drv)
instance = LoadLibrary(buf);
if (instance == NULL) {
free(buf);
}
free(buf);
+ /* Add this DLL to the list of DLLs in which to search for symbols. */
o_dll = stgMallocBytes( sizeof(OpenedDLL), "addDLL" );
o_dll->name = stgMallocBytes(1+strlen(dll_name), "addDLL");
strcpy(o_dll->name, dll_name);
lookupSymbol( char *lbl )
{
void *val;
+ initLinker() ;
ASSERT(symhash != NULL);
val = lookupStrHashTable(symhash, lbl);
lookupLocalSymbol( ObjectCode* oc, char *lbl )
{
void *val;
+ initLinker() ;
val = lookupStrHashTable(oc->lochash, lbl);
if (val == NULL) {
char* a;
const int DELTA = 64;
ObjectCode* oc;
+
+ initLinker();
+
for (oc = objects; oc; oc = oc->next) {
for (i = 0; i < oc->n_symbols; i++) {
sym = oc->symbols[i];
FILE *f;
#endif
+ initLinker();
+
/* fprintf(stderr, "loadObj %s\n", path ); */
/* Check that we haven't already loaded this object. Don't give up
ObjectCode *oc;
int r;
+ initLinker();
+
for (oc = objects; oc; oc = oc->next) {
if (oc->status != OBJECT_RESOLVED) {
# if defined(OBJFORMAT_ELF)
ASSERT(symhash != NULL);
ASSERT(objects != NULL);
+ initLinker();
+
prev = NULL;
for (oc = objects; oc; prev = oc, oc = oc->next) {
if (!strcmp(oc->fileName,path)) {
if ((void*)S != NULL) goto foundit;
(void*)S = lookupSymbol( symbol );
if ((void*)S != NULL) goto foundit;
- belch("%s: unknown symbol `%s'", oc->fileName, symbol);
+ /* Newline first because the interactive linker has printed "linking..." */
+ belch("\n%s: unknown symbol `%s'", oc->fileName, symbol);
return 0;
foundit:
}
projects / ghc-hetmet.git / commitdiff