link,
unload,
PersistentLinkerState{-abstractly!-}, emptyPLS,
+#ifdef GHCI
linkExpr
+#endif
) where
\begin{code}
module CompManager ( cmInit, cmLoadModule,
+#ifdef GHCI
cmGetExpr, cmRunExpr,
+#endif
CmState, emptyCmState -- abstract
)
where
import CmLink
import CmTypes
import HscTypes
-import HscMain ( hscExpr )
-import Interpreter ( HValue )
import Module ( ModuleName, moduleName,
isModuleInThisPackage, moduleEnvElts,
moduleNameUserString )
import HscTypes ( HomeSymbolTable, HomeIfaceTable,
PersistentCompilerState, ModDetails(..) )
import Name ( lookupNameEnv )
-import RdrName
import Module
import PrelNames ( mainName )
import HscMain ( initPersistentCompilerState )
import Unique ( Uniquable )
import Digraph ( SCC(..), stronglyConnComp )
import DriverUtil ( BarfKind(..), splitFilename3 )
-import CmdLineOpts ( DynFlags )
import Util
import Outputable
import Panic ( panic )
+#ifdef GHCI
+import CmdLineOpts ( DynFlags )
+import Interpreter ( HValue )
+import HscMain ( hscExpr )
+import RdrName
+import PrelGHC ( unsafeCoerce# )
+#endif
+
-- lang
import Exception ( throwDyn )
import IO
import List ( nub )
import Maybe ( catMaybes, fromMaybe, isJust )
-import PrelGHC ( unsafeCoerce# )
\end{code}
cmInit raw_package_info gmode
= emptyCmState raw_package_info gmode
+#ifdef GHCI
cmGetExpr :: CmState
-> DynFlags
-> ModuleName
cmRunExpr hval
= do unsafeCoerce# hval :: IO ()
-- putStrLn "done."
+#endif
-- Persistent state just for CM, excluding link & compile subsystems
data PersistentCMState
#include "HsVersions.h"
import CoreSyn
-import Id ( Id, idName, idType, isLocalId, hasNoBinding, idSpecialisation )
+import Id ( Id, idType, isLocalId, hasNoBinding, idSpecialisation )
import VarSet
import Var ( Var, isId )
import Type ( tyVarsOfType )
IdFlavour(..),
megaSeqIdInfo )
import Demand ( appIsBottom )
-import Type ( Type, mkFunTy, mkForAllTy,
- splitFunTy_maybe, tyVarsOfType, tyVarsOfTypes,
- applyTys, isUnLiftedType, seqType,
- mkUTy
+import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe,
+ applyTys, isUnLiftedType, seqType, mkUTy
)
import TysWiredIn ( boolTy, trueDataCon, falseDataCon )
import CostCentre ( CostCentre )
arityInfo, ppArityInfo, ppFlavourInfo, flavourInfo,
specInfo, cprInfo, ppCprInfo,
strictnessInfo, ppStrictnessInfo, cafInfo, ppCafInfo,
- cprInfo, ppCprInfo, lbvarInfo,
+ cprInfo, ppCprInfo,
workerInfo, ppWorkerInfo,
tyGenInfo, ppTyGenInfo
)
(==) _ _ = False -- default case
-
eq_hsFD env (ns1,ms1) (ns2,ms2)
= eqListBy (eq_hsVar env) ns1 ns2 && eqListBy (eq_hsVar env) ms1 ms2
#include "HsVersions.h"
-import Maybe ( isJust )
-import IO ( hPutStrLn, stderr )
+#ifdef GHCI
+import RdrHsSyn ( RdrNameHsExpr )
+import CoreToStg ( coreToStgExpr )
+import StringBuffer ( stringToStringBuffer, freeStringBuffer )
+#endif
+
import HsSyn
-import StringBuffer ( hGetStringBuffer,
- stringToStringBuffer, freeStringBuffer )
+import StringBuffer ( hGetStringBuffer )
import Parser
-import RdrHsSyn ( RdrNameHsExpr )
import Lex ( PState(..), ParseResult(..) )
import SrcLoc ( mkSrcLoc )
-
import Rename
import Rules ( emptyRuleBase )
import PrelInfo ( wiredInThingEnv, wiredInThings )
import OccurAnal ( occurAnalyseBinds )
import CoreUtils ( coreBindsSize )
import CoreTidy ( tidyCorePgm )
-import CoreToStg ( topCoreBindsToStg, coreToStgExpr )
+import CoreToStg ( topCoreBindsToStg )
import StgSyn ( collectFinalStgBinders )
import SimplStg ( stg2stg )
import CodeGen ( codeGen )
import Bag ( emptyBag )
import Outputable
-import Interpreter
+import Interpreter ( stgBindsToInterpSyn, UnlinkedIExpr, UnlinkedIBind, ItblEnv )
import CmStaticInfo ( GhciMode(..) )
import HscStats ( ppSourceStats )
import HscTypes ( ModDetails, ModIface(..), PersistentCompilerState(..),
import Module ( Module, lookupModuleEnvByName )
import Monad ( when )
+import Maybe ( isJust )
+import IO ( hPutStrLn, stderr )
\end{code}
| otherwise
= do {
hPutStrLn stderr "COMPILATION NOT REQUIRED";
- let this_mod = mi_module old_iface
;
-- CLOSURE
(pcs_cl, closure_errs, cl_hs_decls)
-> String -- The expression
-> IO ( PersistentCompilerState, Maybe UnlinkedIExpr )
+#ifndef GHCI
+hscExpr dflags hst hit pcs this_module expr
+ = panic "hscExpr: non-interactive build"
+#else
+
hscExpr dflags hst hit pcs0 this_module expr
= do { -- Parse it
maybe_parsed <- hscParseExpr dflags expr;
Just (print_unqual, rn_expr) -> do {
-- Typecheck it
- maybe_tc_expr <- typecheckExpr dflags pcs1 hst print_unqual rn_expr;
+ maybe_tc_expr <- typecheckExpr dflags pcs1 hst print_unqual this_module rn_expr;
case maybe_tc_expr of
Nothing -> return (pcs1, Nothing)
Just tc_expr -> do {
return (Just rdr_expr)
}}
+#endif
\end{code}
%************************************************************************
VersionInfo(..), initialVersionInfo,
- TyThing(..), isTyClThing,
+ TyThing(..), isTyClThing, implicitTyThingIds,
TypeEnv, lookupType, mkTypeEnv, extendTypeEnvList,
typeEnvClasses, typeEnvTyCons,
import InstEnv ( InstEnv, ClsInstEnv, DFunId )
import Rules ( RuleBase )
import Id ( Id )
-import Class ( Class )
-import TyCon ( TyCon )
+import Class ( Class, classSelIds )
+import TyCon ( TyCon, tyConGenIds, tyConSelIds, tyConDataConsIfAvailable )
+import DataCon ( dataConId, dataConWrapId )
import BasicTypes ( Version, initialVersion, Fixity )
typeEnvClasses env = [cl | AClass cl <- nameEnvElts env]
typeEnvTyCons env = [tc | ATyCon tc <- nameEnvElts env]
+implicitTyThingIds :: [TyThing] -> [Id]
+-- Add the implicit data cons and selectors etc
+implicitTyThingIds things
+ = concat (map go things)
+ where
+ go (AnId f) = []
+ go (AClass cl) = classSelIds cl
+ go (ATyCon tc) = tyConGenIds tc ++
+ tyConSelIds tc ++
+ [ n | dc <- tyConDataConsIfAvailable tc,
+ n <- [dataConId dc, dataConWrapId dc] ]
+ -- Synonyms return empty list of constructors and selectors
\end{code}
-----------------------------------------------------------------------------
--- $Id: Interpreter.hs,v 1.6 2000/11/20 14:26:27 simonmar Exp $
+-- $Id: Interpreter.hs,v 1.7 2000/11/20 14:48:54 simonpj Exp $
--
-- Interpreter subsystem wrapper
--
ClosureEnv, emptyClosureEnv,
ItblEnv, emptyItblEnv,
linkIModules,
- stgToInterpSyn,
+ stgToInterpSyn, stgBindsToInterpSyn,
HValue,
UnlinkedIBind, UnlinkedIExpr,
loadObjs, resolveObjs,
instance Outputable UnlinkedIBind where
ppr x = text "Can't output UnlinkedIBind"
-linkIModules = error "linkIModules"
-stgToInterpSyn = error "linkIModules"
-loadObjs = error "loadObjs"
-resolveObjs = error "loadObjs"
-interactiveUI = error "interactiveUI"
+linkIModules = error "linkIModules"
+stgToInterpSyn = error "stgToInterpSyn"
+stgBindsToInterpSyn = error "stgBindsToInterpSyn"
+loadObjs = error "loadObjs"
+resolveObjs = error "loadObjs"
+interactiveUI = error "interactiveUI"
#endif
import PrelNames -- Prelude module names
import PrimOp ( PrimOp(..), allThePrimOps, primOpRdrName )
-import DataCon ( DataCon, dataConId, dataConWrapId )
+import DataCon ( DataCon )
import MkId ( mkPrimOpId, wiredInIds )
import MkId -- All of it, for re-export
import TysPrim ( primTyCons )
import TysWiredIn ( wiredInTyCons )
-import HscTypes ( TyThing(..), TypeEnv, mkTypeEnv )
+import HscTypes ( TyThing(..), implicitTyThingIds, TypeEnv, mkTypeEnv )
-- others:
-import TyCon ( tyConDataConsIfAvailable, tyConGenIds, TyCon )
import Class ( Class, classKey )
import Type ( funTyCon )
import Util ( isIn )
wiredInThings :: [TyThing]
wiredInThings
= concat
- [ -- Wired in TyCons
- concat (map wiredInTyConThings ([funTyCon] ++ primTyCons ++ wiredInTyCons))
+ [ -- Wired in TyCons and their implicit Ids
+ tycon_things
+ , map AnId (implicitTyThingIds tycon_things)
-- Wired in Ids
, map AnId wiredInIds
-- PrimOps
, map (AnId . mkPrimOpId) allThePrimOps
]
-
-wiredInTyConThings :: TyCon -> [TyThing]
--- This is a bit of a cheat (c.f. TcTyDecls.mkImplicitDataBinds
--- It assumes that wired in tycons have no record selectors
-wiredInTyConThings tc
- = [ATyCon tc]
- ++ [ AnId i | i <- tyConGenIds tc ]
- ++ [ AnId n | dc <- tyConDataConsIfAvailable tc,
- n <- [dataConId dc, dataConWrapId dc] ]
- -- Synonyms return empty list of constructors
+ where
+ tycon_things = map ATyCon ([funTyCon] ++ primTyCons ++ wiredInTyCons)
wiredInThingEnv :: TypeEnv
wiredInThingEnv = mkTypeEnv wiredInThings
[] -- No context
argvrcs
cons
- (length cons)
+ (length cons)
+ [] -- No record selectors
new_or_data
is_rec
gen_info
-> HomeIfaceTable -> HomeSymbolTable
-> PersistentCompilerState
-> Module -> RdrNameHsExpr
- -> IO (PersistentCompilerState, Maybe (PrintUnqualified, RenamedHsExpr))
+ -> IO (PersistentCompilerState, Maybe (PrintUnqualified, (RenamedHsExpr, [RenamedHsDecl])))
renameExpr dflags hit hst pcs this_module expr
| Just iface <- lookupModuleEnv hit this_module
; let print_unqual = unQualInScope rdr_env
; renameSource dflags hit hst pcs this_module $
- initRnMS rdr_env emptyLocalFixityEnv SourceMode $
- ( rnExpr expr `thenRn` \ (e,_) ->
-
- doptRn Opt_D_dump_rn `thenRn` \ dump_rn ->
- ioToRnM (dumpIfSet dump_rn "Renamer:" (ppr e)) `thenRn_`
-
- returnRn (Just (print_unqual, e)))
+ initRnMS rdr_env emptyLocalFixityEnv SourceMode (rnExpr expr) `thenRn` \ (e,fvs) ->
+ closeDecls [] fvs `thenRn` \ decls ->
+ doptRn Opt_D_dump_rn `thenRn` \ dump_rn ->
+ ioToRnM (dumpIfSet dump_rn "Renamer:" (ppr e)) `thenRn_`
+ returnRn (Just (print_unqual, (e, decls)))
}
| otherwise
\section[TcClassDcl]{Typechecking class declarations}
\begin{code}
-module TcClassDcl ( tcClassDecl1, tcClassDecls2, mkImplicitClassBinds,
+module TcClassDcl ( tcClassDecl1, tcClassDecls2,
tcMethodBind, badMethodErr
) where
#include "HsVersions.h"
-import HsSyn ( HsDecl(..), TyClDecl(..), Sig(..), MonoBinds(..),
+import HsSyn ( TyClDecl(..), Sig(..), MonoBinds(..),
HsExpr(..), HsLit(..), HsType(..), HsPred(..),
mkSimpleMatch, andMonoBinds, andMonoBindList,
isClassDecl, isClassOpSig, isPragSig,
import BasicTypes ( TopLevelFlag(..), RecFlag(..) )
import RnHsSyn ( RenamedTyClDecl,
RenamedClassOpSig, RenamedMonoBinds,
- RenamedContext, RenamedHsDecl, RenamedSig,
+ RenamedContext, RenamedSig,
maybeGenericMatch
)
-import TcHsSyn ( TcMonoBinds, idsToMonoBinds )
+import TcHsSyn ( TcMonoBinds )
import Inst ( InstOrigin(..), LIE, emptyLIE, plusLIE, plusLIEs,
newDicts, newMethod )
import TcMonad
import Generics ( mkGenericRhs, validGenericMethodType )
import PrelInfo ( nO_METHOD_BINDING_ERROR_ID )
-import Class ( classTyVars, classBigSig, classSelIds, classTyCon,
+import Class ( classTyVars, classBigSig, classTyCon,
Class, ClassOpItem, DefMeth (..) )
import MkId ( mkDictSelId, mkDataConId, mkDataConWrapId, mkDefaultMethodId )
import DataCon ( mkDataCon, notMarkedStrict )
%************************************************************************
%* *
-\subsection[ClassDcl-pass2]{Class decls pass 2: default methods}
-%* *
-%************************************************************************
-
-@mkImplicitClassBinds@ produces a binding for the selector function for each method
-and superclass dictionary.
-
-\begin{code}
-mkImplicitClassBinds :: Module -> [Class] -> NF_TcM ([Id], TcMonoBinds)
-mkImplicitClassBinds this_mod classes
- = returnNF_Tc (concat cls_ids_s, andMonoBindList binds_s)
- -- The selector binds are already in the selector Id's unfoldings
- -- We don't return the data constructor etc from the class,
- -- because that's done via the class's TyCon
- where
- (cls_ids_s, binds_s) = unzip (map mk_implicit classes)
-
- mk_implicit clas = (sel_ids, binds)
- where
- sel_ids = classSelIds clas
- binds | isFrom this_mod clas = idsToMonoBinds sel_ids
- | otherwise = EmptyMonoBinds
-\end{code}
-
-
-
-%************************************************************************
-%* *
\subsection[Default methods]{Default methods}
%* *
%************************************************************************
each local class decl.
\begin{code}
-tcClassDecls2 :: Module -> [RenamedHsDecl] -> NF_TcM (LIE, TcMonoBinds)
+tcClassDecls2 :: Module -> [RenamedTyClDecl] -> NF_TcM (LIE, TcMonoBinds)
tcClassDecls2 this_mod decls
= foldr combine
(returnNF_Tc (emptyLIE, EmptyMonoBinds))
- [tcClassDecl2 cls_decl | TyClD cls_decl <- decls,
+ [tcClassDecl2 cls_decl | cls_decl <- decls,
isClassDecl cls_decl,
isFrom this_mod (tyClDeclName cls_decl)]
where
tcGetGlobalTyVars, tcExtendGlobalTyVars,
-- Random useful things
- RecTcEnv, tcAddImportedIdInfo, tcLookupRecId, tcInstId,
+ RecTcEnv, tcAddImportedIdInfo, tcLookupRecId, tcLookupRecId_maybe, tcInstId,
-- New Ids
newLocalId, newSpecPragmaId,
-- This data type is used to help tie the knot
-- when type checking type and class declarations
data TyThingDetails = SynTyDetails Type
- | DataTyDetails ClassContext [DataCon]
+ | DataTyDetails ClassContext [DataCon] [Id]
| ClassDetails ClassContext [Id] [ClassOpItem] DataCon
\end{code}
= id `lazySetIdInfo` new_info
-- The Id must be returned without a data dependency on maybe_id
where
- new_info = case tcLookupRecId env (idName id) of
+ new_info = case tcLookupRecId_maybe env (idName id) of
Nothing -> constantIdInfo
Just imported_id -> idInfo imported_id
-- ToDo: could check that types are the same
-tcLookupRecId :: RecTcEnv -> Name -> Maybe Id
-tcLookupRecId env name = case lookup_global env name of
- Just (AnId id) -> Just id
- other -> Nothing
+tcLookupRecId_maybe :: RecTcEnv -> 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}
%************************************************************************
%************************************************************************
\begin{code}
-tcExtendGlobalEnv :: [(Name, TyThing)] -> TcM r -> TcM r
-tcExtendGlobalEnv bindings thing_inside
+tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r
+tcExtendGlobalEnv things thing_inside
= tcGetEnv `thenNF_Tc` \ env ->
let
- ge' = extendNameEnvList (tcGEnv env) bindings
+ ge' = extendNameEnvList (tcGEnv env) [(getName thing, thing) | thing <- things]
in
tcSetEnv (env {tcGEnv = ge'}) thing_inside
tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
tcExtendGlobalValEnv ids thing_inside
- = tcExtendGlobalEnv [(getName id, AnId id) | id <- ids] thing_inside
+ = tcGetEnv `thenNF_Tc` \ env ->
+ let
+ ge' = extendNameEnvList (tcGEnv env) [(getName id, AnId id) | id <- ids]
+ in
+ tcSetEnv (env {tcGEnv = ge'}) thing_inside
\end{code}
mkHsTyApp, mkHsDictApp, mkHsConApp,
mkHsTyLam, mkHsDictLam, mkHsLet,
- idsToMonoBinds,
-- re-exported from TcEnv
TcId, tcInstId,
import HsSyn -- oodles of it
-- others:
-import Id ( idName, idType, isLocalId, idUnfolding, setIdType, isIP, Id )
+import Id ( idName, idType, isLocalId, setIdType, isIP, Id )
import DataCon ( dataConWrapId )
import TcEnv ( tcLookupGlobal_maybe, tcExtendGlobalValEnv,
TcEnv, TcId, tcInstId
import TcType ( zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType, zonkTcSigTyVars
)
import CoreSyn ( Expr )
-import CoreUnfold( unfoldingTemplate )
import BasicTypes ( RecFlag(..) )
import Bag
import Outputable
mkHsLet mbinds expr = HsLet (MonoBind mbinds [] Recursive) expr
mkHsConApp data_con tys args = foldl HsApp (HsVar (dataConWrapId data_con) `mkHsTyApp` tys) args
-
-idsToMonoBinds :: [Id] -> TcMonoBinds
-idsToMonoBinds ids
- = andMonoBindList [ CoreMonoBind id (unfoldingTemplate (idUnfolding id))
- | id <- ids
- ]
\end{code}
%************************************************************************
#include "HsVersions.h"
-import HsSyn ( HsDecl(..), TyClDecl(..), HsTupCon(..) )
+import HsSyn ( TyClDecl(..), HsTupCon(..) )
import TcMonad
import TcMonoType ( tcHsType )
-- NB: all the tyars in interface files are kinded,
import TcEnv ( TcEnv, RecTcEnv, tcExtendTyVarEnv,
tcExtendGlobalValEnv, tcSetEnv,
- tcLookupGlobal_maybe, tcLookupRecId
+ tcLookupGlobal_maybe, tcLookupRecId_maybe
)
-import RnHsSyn ( RenamedHsDecl )
+import RnHsSyn ( RenamedTyClDecl )
import HsCore
import Literal ( Literal(..) )
import CoreSyn
\begin{code}
tcInterfaceSigs :: RecTcEnv -- Envt to use when checking unfoldings
- -> [RenamedHsDecl] -- Ignore non-sig-decls in these decls
+ -> [RenamedTyClDecl] -- Ignore non-sig-decls in these decls
-> TcM [Id]
tcInterfaceSigs unf_env decls
= listTc [ do_one name ty id_infos src_loc
- | TyClD (IfaceSig name ty id_infos src_loc) <- decls]
+ | IfaceSig name ty id_infos src_loc <- decls]
where
in_scope_vars = [] -- I think this will be OK
= uniqSMToTcM (mkWrapper ty arity demands res_bot cpr_info) `thenNF_Tc` \ wrap_fn ->
let
-- Watch out! We can't pull on unf_env too eagerly!
- info' = case tcLookupRecId unf_env worker_name of
+ info' = case tcLookupRecId_maybe unf_env worker_name of
Just worker_id -> info `setUnfoldingInfo` mkTopUnfolding (wrap_fn worker_id)
`setWorkerInfo` HasWorker worker_id arity
-> TcEnv -- Contains IdInfo for dfun ids
-> (Name -> Maybe Fixity) -- for deriving Show and Read
-> Module -- Module for deriving
- -> [TyCon]
-> [RenamedHsDecl]
-> TcM (PackageInstEnv, InstEnv, [InstInfo], RenamedHsBinds)
-tcInstDecls1 inst_env0 prs hst unf_env get_fixity mod tycons decls
+tcInstDecls1 inst_env0 prs hst unf_env get_fixity mod decls
= let
inst_decls = [inst_decl | InstD inst_decl <- decls]
tycl_decls = [decl | TyClD decl <- decls]
#include "HsVersions.h"
import CmdLineOpts ( DynFlag(..), DynFlags, opt_PprStyle_Debug )
-import HsSyn ( HsBinds(..), MonoBinds(..), HsDecl(..) )
+import HsSyn ( HsBinds(..), MonoBinds(..), HsDecl(..),
+ isIfaceRuleDecl, nullBinds, andMonoBindList
+ )
import HsTypes ( toHsType )
-import RnHsSyn ( RenamedHsDecl, RenamedHsExpr )
+import RnHsSyn ( RenamedHsBinds, RenamedHsDecl, RenamedHsExpr )
import TcHsSyn ( TypecheckedMonoBinds, TypecheckedHsExpr,
TypecheckedForeignDecl, TypecheckedRuleDecl,
zonkTopBinds, zonkForeignExports, zonkRules, mkHsLet
import TcType ( newTyVarTy )
import Inst ( plusLIE )
import TcBinds ( tcTopBinds )
-import TcClassDcl ( tcClassDecls2, mkImplicitClassBinds )
+import TcClassDcl ( tcClassDecls2 )
import TcDefaults ( tcDefaults )
import TcExpr ( tcMonoExpr )
import TcEnv ( TcEnv, InstInfo(iDFunId), tcExtendGlobalValEnv,
- tcEnvTyCons, tcEnvClasses, isLocalThing,
- tcSetEnv, tcSetInstEnv, initTcEnv, getTcGEnv
+ isLocalThing, tcSetEnv, tcSetInstEnv, initTcEnv, getTcGEnv
)
-import TcRules ( tcRules )
+import TcRules ( tcIfaceRules, tcSourceRules )
import TcForeign ( tcForeignImports, tcForeignExports )
import TcIfaceSig ( tcInterfaceSigs )
import TcInstDcls ( tcInstDecls1, tcInstDecls2 )
import TcSimplify ( tcSimplifyTop )
import TcTyClsDecls ( tcTyAndClassDecls )
-import TcTyDecls ( mkImplicitDataBinds )
-import CoreUnfold ( unfoldingTemplate )
+import CoreUnfold ( unfoldingTemplate, hasUnfolding )
import Type ( funResultTy, splitForAllTys, openTypeKind )
import Bag ( isEmptyBag )
import ErrUtils ( printErrorsAndWarnings, dumpIfSet_dyn, showPass )
import HscTypes ( PersistentCompilerState(..), HomeSymbolTable,
PackageTypeEnv, DFunId, ModIface(..),
TypeEnv, extendTypeEnvList,
- TyThing(..), mkTypeEnv )
-import List ( partition )
+ TyThing(..), implicitTyThingIds,
+ mkTypeEnv
+ )
\end{code}
Outside-world interface:
-> PersistentCompilerState
-> HomeSymbolTable
-> PrintUnqualified -- For error printing
- -> RenamedHsExpr
- -> IO (Maybe TypecheckedHsExpr)
+ -> Module
+ -> (RenamedHsExpr, -- The expression itself
+ [RenamedHsDecl]) -- Plus extra decls it sucked in from interface files
+ -> IO (Maybe (PersistentCompilerState, TypecheckedHsExpr))
-typecheckExpr dflags pcs hst unqual expr
+typecheckExpr dflags pcs hst unqual this_mod (expr, decls)
= typecheck dflags pcs hst unqual $
+
+ tcImports pcs hst get_fixity this_mod decls `thenTc` \ (env, new_pcs, local_inst_info, deriv_binds, local_rules) ->
+ ASSERT( null local_inst_info && nullBinds deriv_binds && null local_rules )
+
+ tcSetEnv env $
newTyVarTy openTypeKind `thenTc` \ ty ->
tcMonoExpr expr ty `thenTc` \ (expr', lie) ->
tcSimplifyTop lie `thenTc` \ binds ->
- returnTc (mkHsLet binds expr')
+ returnTc (new_pcs, mkHsLet binds expr')
+ where
+ get_fixity :: Name -> Maybe Fixity
+ get_fixity n = pprPanic "typecheckExpr" (ppr n)
---------------
typecheck :: DynFlags
-> TcM (PersistentCompilerState, TcResults)
tcModule pcs hst get_fixity this_mod decls
- = -- Type-check the type and class decls
- fixTc (\ ~(unf_env, _, _, _, _) ->
- -- (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
-
--- traceTc (text "Tc1") `thenNF_Tc_`
- tcTyAndClassDecls unf_env decls `thenTc` \ env ->
- tcSetEnv env $
- let
- classes = tcEnvClasses env
- tycons = tcEnvTyCons env -- INCLUDES tycons derived from classes
- in
-
- -- Typecheck the instance decls, includes deriving
--- traceTc (text "Tc2") `thenNF_Tc_`
- tcInstDecls1 (pcs_insts pcs) (pcs_PRS pcs)
- hst unf_env get_fixity this_mod
- tycons decls `thenTc` \ (new_pcs_insts, inst_env, local_inst_info, deriv_binds) ->
- tcSetInstEnv inst_env $
-
- -- Interface type signatures
- -- We tie a knot so that the Ids read out of interfaces are in scope
- -- when we read their pragmas.
- -- What we rely on is that pragmas are typechecked lazily; if
- -- any type errors are found (ie there's an inconsistency)
- -- we silently discard the pragma
- -- We must do this before mkImplicitDataBinds (which comes next), since
- -- the latter looks up unpackCStringId, for example, which is usually
- -- imported
--- traceTc (text "Tc3") `thenNF_Tc_`
- tcInterfaceSigs unf_env decls `thenTc` \ sig_ids ->
- tcExtendGlobalValEnv sig_ids $
-
- -- Create any necessary record selector Ids and their bindings
- -- "Necessary" includes data and newtype declarations
- -- We don't create bindings for dictionary constructors;
- -- they are always fully applied, and the bindings are just there
- -- to support partial applications
- mkImplicitDataBinds this_mod tycons `thenTc` \ (data_ids, imp_data_binds) ->
- mkImplicitClassBinds this_mod classes `thenNF_Tc` \ (cls_ids, imp_cls_binds) ->
-
- -- Extend the global value environment with
- -- (a) constructors
- -- (b) record selectors
- -- (c) class op selectors
- -- (d) default-method ids... where? I can't see where these are
- -- put into the envt, and I'm worried that the zonking phase
- -- will find they aren't there and complain.
- tcExtendGlobalValEnv data_ids $
- tcExtendGlobalValEnv cls_ids $
- tcGetEnv `thenTc` \ unf_env ->
- returnTc (unf_env, new_pcs_insts, local_inst_info, deriv_binds,
- imp_data_binds `AndMonoBinds` imp_cls_binds)
- ) `thenTc` \ (env, new_pcs_insts, local_inst_info, deriv_binds, data_cls_binds) ->
-
+ = -- Type-check the type and class decls, and all imported decls
+ tcImports pcs hst get_fixity this_mod decls `thenTc` \ (env, new_pcs, local_inst_info, deriv_binds, local_rules) ->
+
tcSetEnv env $
-- Foreign import declarations next
-- Value declarations next.
-- We also typecheck any extra binds that came out of the "deriving" process
--- traceTc (text "Tc5") `thenNF_Tc_`
- tcTopBinds (get_binds decls `ThenBinds` deriv_binds) `thenTc` \ ((val_binds, env), lie_valdecls) ->
+-- traceTc (text "Tc5") `thenNF_Tc_`
+ tcTopBinds (val_binds `ThenBinds` deriv_binds) `thenTc` \ ((val_binds, env), lie_valdecls) ->
tcSetEnv env $
-- Foreign export declarations next
-- Second pass over class and instance declarations,
-- to compile the bindings themselves.
--- traceTc (text "Tc7") `thenNF_Tc_`
tcInstDecls2 local_inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
--- traceTc (text "Tc8") `thenNF_Tc_`
- tcClassDecls2 this_mod decls `thenNF_Tc` \ (lie_clasdecls, cls_dm_binds) ->
- tcRules (pcs_rules pcs) this_mod decls `thenNF_Tc` \ (new_pcs_rules, lie_rules, local_rules) ->
+ tcClassDecls2 this_mod tycl_decls `thenNF_Tc` \ (lie_clasdecls, cls_dm_binds) ->
+ tcSourceRules source_rules `thenNF_Tc` \ (lie_rules, more_local_rules) ->
-- Deal with constant or ambiguous InstIds. How could
-- there be ambiguous ones? They can only arise if a
-- during the generalisation step.)
let
lie_alldecls = lie_valdecls `plusLIE`
- lie_instdecls `plusLIE`
- lie_clasdecls `plusLIE`
- lie_fodecls `plusLIE`
- lie_rules
+ lie_instdecls `plusLIE`
+ lie_clasdecls `plusLIE`
+ lie_fodecls `plusLIE`
+ lie_rules
in
tcSimplifyTop lie_alldecls `thenTc` \ const_inst_binds ->
-- Backsubstitution. This must be done last.
-- Even tcSimplifyTop may do some unification.
let
- all_binds = data_cls_binds `AndMonoBinds`
- val_binds `AndMonoBinds`
+ all_binds = val_binds `AndMonoBinds`
inst_binds `AndMonoBinds`
cls_dm_binds `AndMonoBinds`
const_inst_binds `AndMonoBinds`
tcSetEnv final_env $
-- zonkTopBinds puts all the top-level Ids into the tcGEnv
zonkForeignExports foe_decls `thenNF_Tc` \ foe_decls' ->
- zonkRules local_rules `thenNF_Tc` \ local_rules' ->
+ zonkRules more_local_rules `thenNF_Tc` \ more_local_rules' ->
- let (local_things, imported_things) = partition (isLocalThing this_mod)
- (nameEnvElts (getTcGEnv final_env))
-
- local_type_env :: TypeEnv
- local_type_env = mkTypeEnv local_things
-
- new_pte :: PackageTypeEnv
- new_pte = extendTypeEnvList (pcs_PTE pcs) imported_things
-
- final_pcs :: PersistentCompilerState
- final_pcs = pcs { pcs_PTE = new_pte,
- pcs_insts = new_pcs_insts,
- pcs_rules = new_pcs_rules
- }
+ let local_things = filter (isLocalThing this_mod) (nameEnvElts (getTcGEnv final_env))
+
+ -- Create any necessary "implicit" bindings (data constructors etc)
+ -- Should we create bindings for dictionary constructors?
+ -- They are always fully applied, and the bindings are just there
+ -- to support partial applications. But it's easier to let them through.
+ implicit_binds = andMonoBindList [ CoreMonoBind id (unfoldingTemplate unf)
+ | id <- implicitTyThingIds local_things
+ , let unf = idUnfolding id
+ , hasUnfolding unf
+ ]
+
+ local_type_env :: TypeEnv
+ local_type_env = mkTypeEnv local_things
+
+ all_local_rules = local_rules ++ more_local_rules'
in
-- traceTc (text "Tc10") `thenNF_Tc_`
- returnTc (final_pcs,
+ returnTc (new_pcs,
TcResults { tc_env = local_type_env,
- tc_binds = all_binds',
+ tc_binds = implicit_binds `AndMonoBinds` all_binds',
tc_insts = map iDFunId local_inst_info,
tc_fords = foi_decls ++ foe_decls',
- tc_rules = local_rules'
+ tc_rules = all_local_rules
}
)
-
-get_binds decls = foldr ThenBinds EmptyBinds [binds | ValD binds <- decls]
+ where
+ tycl_decls = [d | TyClD d <- decls]
+ val_binds = foldr ThenBinds EmptyBinds [binds | ValD binds <- decls]
+ source_rules = [d | RuleD d <- decls, not (isIfaceRuleDecl d)]
\end{code}
+\begin{code}
+tcImports :: PersistentCompilerState
+ -> HomeSymbolTable
+ -> (Name -> Maybe Fixity)
+ -> Module
+ -> [RenamedHsDecl]
+ -> TcM (TcEnv, PersistentCompilerState,
+ [InstInfo], RenamedHsBinds, [TypecheckedRuleDecl])
+
+-- tcImports is a slight mis-nomer.
+-- It deals with everythign that could be an import:
+-- type and class decls
+-- interface signatures
+-- instance decls
+-- rule decls
+-- These can occur in source code too, of course
+
+tcImports pcs hst get_fixity this_mod decls
+ = fixTc (\ ~(unf_env, _, _, _, _) ->
+ -- (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
+
+-- traceTc (text "Tc1") `thenNF_Tc_`
+ tcTyAndClassDecls unf_env tycl_decls `thenTc` \ env ->
+ tcSetEnv env $
+
+ -- Typecheck the instance decls, includes deriving
+-- traceTc (text "Tc2") `thenNF_Tc_`
+ tcInstDecls1 (pcs_insts pcs) (pcs_PRS pcs)
+ hst unf_env get_fixity this_mod
+ decls `thenTc` \ (new_pcs_insts, inst_env, local_inst_info, deriv_binds) ->
+ tcSetInstEnv inst_env $
+
+ -- 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 "Tc3") `thenNF_Tc_`
+ tcInterfaceSigs unf_env tycl_decls `thenTc` \ sig_ids ->
+ tcExtendGlobalValEnv sig_ids $
+
+
+ tcIfaceRules (pcs_rules pcs) this_mod iface_rules `thenNF_Tc` \ (new_pcs_rules, local_rules) ->
+
+ tcGetEnv `thenTc` \ unf_env ->
+ let
+ imported_things = filter (not . isLocalThing this_mod) (nameEnvElts (getTcGEnv unf_env))
+
+ new_pte :: PackageTypeEnv
+ new_pte = extendTypeEnvList (pcs_PTE pcs) imported_things
+
+ 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, local_inst_info, deriv_binds, local_rules)
+ )
+ where
+ tycl_decls = [d | TyClD d <- decls]
+ iface_rules = [d | RuleD d <- decls, isIfaceRuleDecl d]
+\end{code}
%************************************************************************
%* *
\section[TcRules]{Typechecking transformation rules}
\begin{code}
-module TcRules ( tcRules ) where
+module TcRules ( tcIfaceRules, tcSourceRules ) where
#include "HsVersions.h"
-import HsSyn ( HsDecl(..), RuleDecl(..), RuleBndr(..) )
+import HsSyn ( RuleDecl(..), RuleBndr(..) )
import CoreSyn ( CoreRule(..) )
-import RnHsSyn ( RenamedHsDecl, RenamedRuleDecl )
+import RnHsSyn ( RenamedRuleDecl )
import HscTypes ( PackageRuleBase )
import TcHsSyn ( TypecheckedRuleDecl, mkHsLet )
import TcMonad
import TcExpr ( tcExpr )
import TcEnv ( tcExtendLocalValEnv, tcExtendTyVarEnv, isLocalThing )
import Rules ( extendRuleBase )
-import Inst ( LIE, emptyLIE, plusLIEs, instToId )
+import Inst ( LIE, plusLIEs, instToId )
import Id ( idType, idName, mkVanillaId )
import Module ( Module )
import VarSet
\end{code}
\begin{code}
-tcRules :: PackageRuleBase -> Module -> [RenamedHsDecl]
- -> TcM (PackageRuleBase, LIE, [TypecheckedRuleDecl])
-tcRules pkg_rule_base mod decls
- = mapAndUnzipTc tcRule [rule | RuleD rule <- decls] `thenTc` \ (lies, new_rules) ->
+tcIfaceRules :: PackageRuleBase -> Module -> [RenamedRuleDecl]
+ -> TcM (PackageRuleBase, [TypecheckedRuleDecl])
+tcIfaceRules pkg_rule_base mod decls
+ = mapTc tcIfaceRule decls `thenTc` \ new_rules ->
let
(local_rules, imported_rules) = partition is_local new_rules
new_rule_base = foldl add pkg_rule_base imported_rules
in
- returnTc (new_rule_base, plusLIEs lies, local_rules)
+ returnTc (new_rule_base, local_rules)
where
add rule_base (IfaceRuleOut id rule) = extendRuleBase rule_base (id, rule)
is_local (IfaceRuleOut n _) = isLocalThing mod n
is_local other = True
-tcRule :: RenamedRuleDecl -> TcM (LIE, TypecheckedRuleDecl)
+tcIfaceRule :: RenamedRuleDecl -> TcM TypecheckedRuleDecl
-- No zonking necessary!
-tcRule (IfaceRule name vars fun args rhs src_loc)
+tcIfaceRule (IfaceRule name vars fun args rhs src_loc)
= tcAddSrcLoc src_loc $
tcAddErrCtxt (ruleCtxt name) $
tcVar fun `thenTc` \ fun' ->
tcCoreLamBndrs vars $ \ vars' ->
mapTc tcCoreExpr args `thenTc` \ args' ->
tcCoreExpr rhs `thenTc` \ rhs' ->
- returnTc (emptyLIE, IfaceRuleOut fun' (Rule name vars' args' rhs'))
+ returnTc (IfaceRuleOut fun' (Rule name vars' args' rhs'))
-tcRule (HsRule name sig_tvs vars lhs rhs src_loc)
+
+tcSourceRules :: [RenamedRuleDecl] -> TcM (LIE, [TypecheckedRuleDecl])
+tcSourceRules decls
+ = mapAndUnzipTc tcSourceRule decls `thenTc` \ (lies, decls') ->
+ returnTc (plusLIEs lies, decls')
+
+tcSourceRule (HsRule name sig_tvs vars lhs rhs src_loc)
= tcAddSrcLoc src_loc $
tcAddErrCtxt (ruleCtxt name) $
newTyVarTy openTypeKind `thenNF_Tc` \ rule_ty ->
#include "HsVersions.h"
import CmdLineOpts ( DynFlags, DynFlag(..), dopt )
-import HsSyn ( HsDecl(..), TyClDecl(..),
- HsTyVarBndr,
- ConDecl(..),
- Sig(..), HsPred(..),
+import HsSyn ( TyClDecl(..), HsTyVarBndr,
+ ConDecl(..), Sig(..), HsPred(..),
tyClDeclName, hsTyVarNames,
isIfaceSigDecl, isClassDecl, isSynDecl, isClassOpSig
)
-import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, tyClDeclFVs )
+import RnHsSyn ( RenamedTyClDecl, tyClDeclFVs )
import BasicTypes ( RecFlag(..), NewOrData(..), isRec )
+import HscTypes ( implicitTyThingIds )
import TcMonad
import TcEnv ( TcEnv, RecTcEnv, TcTyThing(..), TyThing(..), TyThingDetails(..),
- tcExtendKindEnv, tcLookup, tcExtendGlobalEnv )
+ tcExtendKindEnv, tcLookup, tcExtendGlobalEnv, tcExtendGlobalValEnv )
import TcTyDecls ( tcTyDecl1, kcConDetails, mkNewTyConRep )
import TcClassDcl ( tcClassDecl1 )
import TcMonoType ( kcHsTyVars, kcHsType, kcHsBoxedSigType, kcHsContext, mkTyClTyVars )
import Var ( varName )
import FiniteMap
import Digraph ( stronglyConnComp, SCC(..) )
-import Name ( Name, NamedThing(..), getSrcLoc, isTyVarName )
+import Name ( Name, getSrcLoc, isTyVarName )
import Name ( NameEnv, mkNameEnv, lookupNameEnv_NF )
import NameSet
import Outputable
~~~~~~~~~~~~~~~~~
\begin{code}
tcTyAndClassDecls :: RecTcEnv -- Knot tying stuff
- -> [RenamedHsDecl]
+ -> [RenamedTyClDecl]
-> TcM TcEnv
tcTyAndClassDecls unf_env decls
like whether a function argument is an unboxed tuple, looking
through type synonyms properly. We can't do that in Step 5.
+Step 7: Extend environment
+ We extend the type environment with bindings not only for the TyCons and Classes,
+ but also for their "implicit Ids" like data constructors and class selectors
+
The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to
@TyThing@s. @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s.
zonkKindEnv initial_kinds `thenNF_Tc` \ final_kinds ->
-- Tie the knot
- fixTc ( \ ~(rec_details_list, _) ->
+ fixTc ( \ ~(rec_details_list, _, _) ->
-- Step 4
let
kind_env = mkNameEnv final_kinds
rec_details = mkNameEnv rec_details_list
- tyclss, all_tyclss :: [(Name, TyThing)]
+ tyclss, all_tyclss :: [TyThing]
tyclss = map (buildTyConOrClass dflags is_rec kind_env
rec_vrcs rec_details) decls
-- Add the tycons that come from the classes
-- We want them in the environment because
-- they are mentioned in interface files
- all_tyclss = [ (getName tycon, ATyCon tycon) | (_, AClass clas) <- tyclss,
- let tycon = classTyCon clas
- ] ++ tyclss
+ all_tyclss = [ ATyCon (classTyCon clas) | AClass clas <- tyclss]
+ ++ tyclss
-- Calculate variances, and (yes!) feed back into buildTyConOrClass.
- rec_vrcs = calcTyConArgVrcs [tc | (_, ATyCon tc) <- all_tyclss]
+ rec_vrcs = calcTyConArgVrcs [tc | ATyCon tc <- all_tyclss]
in
-- Step 5
tcExtendGlobalEnv all_tyclss $
mapTc (tcTyClDecl1 is_rec unf_env) decls `thenTc` \ tycls_details ->
-- Return results
- tcGetEnv `thenNF_Tc` \ env ->
- returnTc (tycls_details, env)
- ) `thenTc` \ (_, env) ->
+ tcGetEnv `thenNF_Tc` \ env ->
+ returnTc (tycls_details, all_tyclss, env)
+ ) `thenTc` \ (_, all_tyclss, env) ->
+
+ tcSetEnv env $
-- Step 6
-- For a recursive group, check all the types again,
-- this time with the wimp flag off
(if isRec is_rec then
- tcSetEnv env (mapTc_ (tcTyClDecl1 NonRecursive unf_env) decls)
+ mapTc_ (tcTyClDecl1 NonRecursive unf_env) decls
else
returnTc ()
) `thenTc_`
- returnTc env
+ -- Step 7
+ -- Extend the environment with the final TyCons/Classes
+ -- and their implicit Ids
+ tcExtendGlobalValEnv (implicitTyThingIds all_tyclss) tcGetEnv
+
where
is_rec = case scc of
AcyclicSCC _ -> NonRecursive
tcTyClDecl1 is_rec unf_env decl
| isClassDecl decl = tcAddDeclCtxt decl (tcClassDecl1 is_rec unf_env decl)
- | otherwise = tcAddDeclCtxt decl (tcTyDecl1 is_rec decl)
+ | otherwise = tcAddDeclCtxt decl (tcTyDecl1 is_rec unf_env decl)
\end{code}
:: DynFlags
-> RecFlag -> NameEnv Kind
-> FiniteMap TyCon ArgVrcs -> NameEnv TyThingDetails
- -> RenamedTyClDecl -> (Name, TyThing)
- -- Can't fail; the only reason it's in the monad
- -- is so it can zonk the kinds
+ -> RenamedTyClDecl -> TyThing
buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
(TySynonym tycon_name tyvar_names rhs src_loc)
- = (tycon_name, ATyCon tycon)
+ = ATyCon tycon
where
tycon = mkSynTyCon tycon_name tycon_kind arity tyvars rhs_ty argvrcs
tycon_kind = lookupNameEnv_NF kenv tycon_name
buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
(TyData data_or_new context tycon_name tyvar_names _ nconstrs _ src_loc name1 name2)
- = (tycon_name, ATyCon tycon)
+ = ATyCon tycon
where
tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt argvrcs
- data_cons nconstrs
+ data_cons nconstrs sel_ids
flavour is_rec gen_info
gen_info | not (dopt Opt_Generics dflags) = Nothing
| otherwise = mkTyConGenInfo tycon name1 name2
- DataTyDetails ctxt data_cons = lookupNameEnv_NF rec_details tycon_name
+ DataTyDetails ctxt data_cons sel_ids = lookupNameEnv_NF rec_details tycon_name
tycon_kind = lookupNameEnv_NF kenv tycon_name
tyvars = mkTyClTyVars tycon_kind tyvar_names
(ClassDecl context class_name
tyvar_names fundeps class_sigs def_methods
name_list src_loc)
- = (class_name, AClass clas)
+ = AClass clas
where
(tycon_name, _, _, _) = getClassDeclSysNames name_list
clas = mkClass class_name tyvars fds
Dependency analysis
~~~~~~~~~~~~~~~~~~~
\begin{code}
-sortByDependency :: [RenamedHsDecl] -> TcM [SCC RenamedTyClDecl]
+sortByDependency :: [RenamedTyClDecl] -> TcM [SCC RenamedTyClDecl]
sortByDependency decls
= let -- CHECK FOR CLASS CYCLES
cls_sccs = stronglyConnComp (mapMaybe mkClassEdges tycl_decls)
in
returnTc decl_sccs
where
- tycl_decls = [d | TyClD d <- decls, not (isIfaceSigDecl d)]
+ tycl_decls = filter (not . isIfaceSigDecl) decls
edges = map mkEdges tycl_decls
is_syn_decl (d, _, _) = isSynDecl d
\begin{code}
module TcTyDecls (
- tcTyDecl1,
- kcConDetails,
- mkImplicitDataBinds, mkNewTyConRep
+ tcTyDecl1, kcConDetails, mkNewTyConRep
) where
#include "HsVersions.h"
-import HsSyn ( MonoBinds(..),
- TyClDecl(..), ConDecl(..), ConDetails(..), BangType(..),
+import HsSyn ( TyClDecl(..), ConDecl(..), ConDetails(..), BangType(..),
getBangType, conDetailsTys
)
import RnHsSyn ( RenamedTyClDecl, RenamedConDecl, RenamedContext )
-import TcHsSyn ( TcMonoBinds, idsToMonoBinds )
-import BasicTypes ( NewOrData(..), RecFlag )
+import BasicTypes ( NewOrData(..), RecFlag, isRec )
import TcMonoType ( tcHsRecType, tcHsTyVars, tcRecClassContext,
kcHsContext, kcHsSigType, kcHsBoxedSigType
)
import TcEnv ( tcExtendTyVarEnv,
- tcLookupTyCon, tcLookupGlobalId,
- TyThingDetails(..)
+ tcLookupTyCon, tcLookupRecId,
+ TyThingDetails(..), RecTcEnv
)
import TcMonad
import Class ( ClassContext )
-import DataCon ( DataCon, mkDataCon,
- dataConFieldLabels, dataConId, dataConWrapId,
- markedStrict, notMarkedStrict, markedUnboxed, dataConRepType
+import DataCon ( DataCon, mkDataCon, dataConFieldLabels, markedStrict,
+ notMarkedStrict, markedUnboxed, dataConRepType
)
import MkId ( mkDataConId, mkDataConWrapId, mkRecordSelId )
import FieldLabel
-import Var ( Id, TyVar )
-import Module ( Module )
-import Name ( Name, NamedThing(..), isFrom )
+import Var ( TyVar )
+import Name ( Name, NamedThing(..) )
import Outputable
-import TyCon ( TyCon, isSynTyCon, isNewTyCon,
- tyConDataConsIfAvailable, tyConTyVars, tyConGenIds
- )
+import TyCon ( TyCon, isNewTyCon, tyConTyVars )
import Type ( tyVarsOfTypes, splitFunTy, applyTys,
mkTyConApp, mkTyVarTys, mkForAllTys,
splitAlgTyConApp_maybe, Type
%************************************************************************
\begin{code}
-tcTyDecl1 :: RecFlag -> RenamedTyClDecl -> TcM (Name, TyThingDetails)
-tcTyDecl1 is_rec (TySynonym tycon_name tyvar_names rhs src_loc)
+tcTyDecl1 :: RecFlag -> RecTcEnv -> RenamedTyClDecl -> TcM (Name, TyThingDetails)
+tcTyDecl1 is_rec unf_env (TySynonym tycon_name tyvar_names rhs src_loc)
= tcLookupTyCon tycon_name `thenNF_Tc` \ tycon ->
tcExtendTyVarEnv (tyConTyVars tycon) $
tcHsRecType is_rec rhs `thenTc` \ rhs_ty ->
returnTc (tycon_name, SynTyDetails rhs_ty)
-tcTyDecl1 is_rec (TyData new_or_data context tycon_name _ con_decls _ derivings src_loc name1 name2)
+tcTyDecl1 is_rec unf_env (TyData new_or_data context tycon_name _ con_decls _ derivings src_loc name1 name2)
= tcLookupTyCon tycon_name `thenNF_Tc` \ tycon ->
let
tyvars = tyConTyVars tycon
-- Typecheck the pieces
tcRecClassContext is_rec context `thenTc` \ ctxt ->
mapTc (tcConDecl is_rec new_or_data tycon tyvars ctxt) con_decls `thenTc` \ data_cons ->
- returnTc (tycon_name, DataTyDetails ctxt data_cons)
+ tcRecordSelectors is_rec unf_env tycon data_cons `thenTc` \ sel_ids ->
+ returnTc (tycon_name, DataTyDetails ctxt data_cons sel_ids)
\end{code}
\begin{code}
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
+ let str = getBangStrictness bty,
+ n <- ns -- One for each. E.g x,y,z :: !Int
]
in
mk_data_con ex_tyvars ex_theta arg_stricts
\end{code}
-
%************************************************************************
%* *
-\subsection{Generating constructor/selector bindings for data declarations}
+\subsection{Record selectors}
%* *
%************************************************************************
\begin{code}
-mkImplicitDataBinds :: Module -> [TyCon] -> TcM ([Id], TcMonoBinds)
-mkImplicitDataBinds this_mod [] = returnTc ([], EmptyMonoBinds)
-mkImplicitDataBinds this_mod (tycon : tycons)
- | isSynTyCon tycon = mkImplicitDataBinds this_mod tycons
- | otherwise = mkImplicitDataBinds_one this_mod tycon `thenTc` \ (ids1, b1) ->
- mkImplicitDataBinds this_mod tycons `thenTc` \ (ids2, b2) ->
- returnTc (ids1++ids2, b1 `AndMonoBinds` b2)
-
-mkImplicitDataBinds_one this_mod tycon
- = mapTc (mkRecordSelector tycon) groups `thenTc` \ sel_ids ->
- let
- unf_ids = sel_ids ++ data_con_wrapper_ids ++ gen_ids
- all_ids = map dataConId data_cons ++ unf_ids
-
- -- For the locally-defined things
- -- we need to turn the unfoldings inside the selector Ids into bindings,
- -- and build bindigns for the constructor wrappers
- binds | isFrom this_mod tycon = idsToMonoBinds unf_ids
- | otherwise = EmptyMonoBinds
- in
- returnTc (all_ids, binds)
+tcRecordSelectors is_rec unf_env tycon data_cons
+ = mapTc tc_group groups
where
- data_cons = tyConDataConsIfAvailable tycon
- -- Abstract types mean we don't bring the
- -- data cons into scope, which should be fine
- gen_ids = tyConGenIds tycon
- data_con_wrapper_ids = map dataConWrapId data_cons
-
fields = [ (con, field) | con <- data_cons,
- field <- dataConFieldLabels con
- ]
+ field <- dataConFieldLabels con ]
-- groups is list of fields that share a common name
groups = equivClasses cmp_name fields
cmp_name (_, field1) (_, field2)
= fieldLabelName field1 `compare` fieldLabelName field2
-\end{code}
-\begin{code}
-mkRecordSelector tycon fields@((first_con, first_field_label) : other_fields)
- -- These fields all have the same name, but are from
- -- different constructors in the data type
- -- Check that all the fields in the group have the same type
- -- This check assumes that all the constructors of a given
- -- data type use the same type variables
- = checkTc (all (== field_ty) other_tys)
- (fieldTypeMisMatch field_name) `thenTc_`
- tcLookupGlobalId unpackCStringName `thenTc` \ unpack_id ->
- tcLookupGlobalId unpackCStringUtf8Name `thenTc` \ unpackUtf8_id ->
- returnTc (mkRecordSelId tycon first_field_label unpack_id unpackUtf8_id)
- where
- field_ty = fieldLabelType first_field_label
- field_name = fieldLabelName first_field_label
- other_tys = [fieldLabelType fl | (_, fl) <- other_fields]
+ tc_group fields@((first_con, first_field_label) : other_fields)
+ -- These fields all have the same name, but are from
+ -- different constructors in the data type
+ = -- Check that all the fields in the group have the same type
+ -- Wimp out (omit check) if the group is recursive;
+ -- TcTyClsDecls.tcGroup will repeat with NonRecursive once we
+ -- have tied the knot
+ -- NB: this check assumes that all the constructors of a given
+ -- data type use the same type variables
+ checkTc (not (isRec is_rec) && all (== field_ty) other_tys)
+ (fieldTypeMisMatch field_name) `thenTc_`
+ returnTc (mkRecordSelId tycon first_field_label unpack_id unpackUtf8_id)
+ where
+ field_ty = fieldLabelType first_field_label
+ field_name = fieldLabelName first_field_label
+ other_tys = [fieldLabelType fl | (_, fl) <- other_fields]
+
+ unpack_id = tcLookupRecId unf_env unpackCStringName
+ unpackUtf8_id = tcLookupRecId unf_env unpackCStringUtf8Name
\end{code}
-Errors and contexts
-~~~~~~~~~~~~~~~~~~~
+
+%************************************************************************
+%* *
+\subsection{Errors and contexts}
+%* *
+%************************************************************************
+
+
\begin{code}
fieldTypeMisMatch field_name
= sep [ptext SLIT("Declared types differ for field"), quotes (ppr field_name)]
tyConUnique,
tyConTyVars,
tyConArgVrcs_maybe,
- tyConDataCons, tyConDataConsIfAvailable,
- tyConFamilySize,
+ tyConDataCons, tyConDataConsIfAvailable, tyConFamilySize,
+ tyConSelIds,
tyConTheta,
tyConPrimRep,
tyConArity,
-- (b) in a quest for fast compilation we don't import
-- the constructors
+ selIds :: [Id], -- Its record selectors (if any)
+
noOfDataCons :: Int, -- Number of data constructors
-- Usually this is the same as the length of the
-- dataCons field, but the latter may be empty if
-- This is the making of a TyCon. Just the same as the old mkAlgTyCon,
-- but now you also have to pass in the generic information about the type
-- constructor - you can get hold of it easily (see Generics module)
-mkAlgTyCon name kind tyvars theta argvrcs cons ncons flavour rec
+mkAlgTyCon name kind tyvars theta argvrcs cons ncons sels flavour rec
gen_info
= AlgTyCon {
tyConName = name,
tyConArgVrcs = argvrcs,
algTyConTheta = theta,
dataCons = cons,
+ selIds = sels,
noOfDataCons = ncons,
algTyConClass = False,
algTyConFlavour = flavour,
tyConArgVrcs = argvrcs,
algTyConTheta = [],
dataCons = [con],
+ selIds = [],
noOfDataCons = 1,
algTyConClass = True,
algTyConFlavour = flavour,
tyConFamilySize other = pprPanic "tyConFamilySize:" (ppr other)
#endif
+tyConSelIds :: TyCon -> [Id]
+tyConSelIds (AlgTyCon {selIds = sels}) = sels
+tyConSelIds other_tycon = []
+\end{code}
+
+\begin{code}
tyConPrimRep :: TyCon -> PrimRep
tyConPrimRep (PrimTyCon {primTyConRep = rep}) = rep
tyConPrimRep _ = PtrRep
import VarEnv
import VarSet
-import Name ( Name, mkGlobalName, mkKindOccFS, tcName )
-import OccName ( tcName )
+import Name ( Name, tcName )
import TyCon ( TyCon, KindCon, mkFunTyCon, mkKindCon, mkSuperKindCon )
import Class ( Class )
-- others
-import SrcLoc ( builtinSrcLoc )
-import PrelNames ( pREL_GHC, superKindName, superBoxityName, boxedConName,
+import PrelNames ( superKindName, superBoxityName, boxedConName,
unboxedConName, typeConName, openKindConName, funTyConName,
usageKindConName, usOnceTyConName, usManyTyConName
)
present in an inferred type.
-\begin{code}
-mk_kind_name key str = mkGlobalName key pREL_GHC (mkKindOccFS tcName str) builtinSrcLoc
- -- mk_kind_name is a bit of a hack
- -- The LocalDef means that we print the name without
- -- a qualifier, which is what we want for these kinds.
- -- It's used for both Kinds and Boxities
-\end{code}
-
------------------------------------------
Define KX, the type of a kind
BX, the type of a boxity
Usage tycons @.@ and @!@
The usage tycons are of kind usageTypeKind (`$'). The types contain
-no values, and are used purely for usage annotation. mk_kind_name is
-used (hackishly) to avoid z-encoding of the names.
+no values, and are used purely for usage annotation.
\begin{code}
usOnceTyCon = mkKindCon usOnceTyConName usageTypeKind
-- creation/destruction
hGetStringBuffer, -- :: FilePath -> IO StringBuffer
+#ifdef GHCI
stringToStringBuffer, -- :: String -> IO StringBuffer
freeStringBuffer, -- :: StringBuffer -> IO ()
+#endif
-- Lookup
currentChar, -- :: StringBuffer -> Char
-- Turn a String into a StringBuffer
\begin{code}
+#ifdef GHCI
stringToStringBuffer :: String -> IO StringBuffer
stringToStringBuffer str =
do let sz@(I# sz#) = length str + 1
freeStringBuffer :: StringBuffer -> IO ()
freeStringBuffer (StringBuffer a# _ _ _) = Foreign.free (Ptr (A# a#))
+#endif
\end{code}
-----------------------------------------------------------------------------
projects / ghc-hetmet.git / commitdiff