1. Make the new version machinery work.
I think it does now!
2. Consequence of (1): Move the generation of
default method names to one place (namely
in RdrHsSyn.mkClassOpSigDM
3. Major clean up on HsDecls.TyClDecl
These big constructors should have been records
ages ago, and they are now. At last.
externallyVisibleId,
isIP,
isSpecPragmaId, isRecordSelector,
- isPrimOpId, isPrimOpId_maybe,
- isDataConId, isDataConId_maybe, isDataConWrapId,
- isDataConWrapId_maybe,
+ isPrimOpId, isPrimOpId_maybe, isDictFunId,
+ isDataConId, isDataConId_maybe,
+ isDataConWrapId, isDataConWrapId_maybe,
isBottomingId,
isExportedId, isLocalId,
hasNoBinding,
-- binding, even though it is defined in this module. Notably,
-- the constructors of a dictionary are in this situation.
+isDictFunId id = case idFlavour id of
+ DictFunId -> True
+ other -> False
+
-- Don't drop a binding for an exported Id,
-- if it otherwise looks dead.
-- Perhaps a better name would be isDiscardableId
-- The dfun id must *not* be omitted, because it carries version info for
-- the instance decl
- other -> False -- Don't omit!
+ ConstantId -> False -- Ordinary Ids
+ DictFunId -> False
+
+ ExportedId -> False -- I don't think these happen
+ VanillaId -> False -- ditto
+ SpecPragmaId -> False -- ditto
\end{code}
\begin{code}
| ExportedId -- Locally defined, exported
| SpecPragmaId -- Locally defined, RHS holds specialised call
- | ConstantId -- Imported from elsewhere, or a dictionary function,
- -- default method Id.
+ | ConstantId -- Imported from elsewhere, or a default method Id.
+
+ | DictFunId -- We flag dictionary functions so that we can
+ -- conveniently extract the DictFuns from a set of
+ -- bindings when building a module's interface
| DataConId DataCon -- The Id for a data constructor *worker*
| DataConWrapId DataCon -- The Id for a data constructor *wrapper*
ppFlavourInfo ExportedId = ptext SLIT("[Exported]")
ppFlavourInfo SpecPragmaId = ptext SLIT("[SpecPrag]")
ppFlavourInfo ConstantId = ptext SLIT("[Constant]")
+ppFlavourInfo DictFunId = ptext SLIT("[DictFun]")
ppFlavourInfo (DataConId _) = ptext SLIT("[DataCon]")
ppFlavourInfo (DataConWrapId _) = ptext SLIT("[DataConWrapper]")
ppFlavourInfo (PrimOpId _) = ptext SLIT("[PrimOp]")
= mkId dfun_name dfun_ty info
where
dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys)
- info = constantIdInfo `setTyGenInfo` TyGenNever
+ info = mkIdInfo DictFunId `setTyGenInfo` TyGenNever
-- type is wired-in (see comment at TcClassDcl.tcClassSig), so
-- do not generalise it
import OccName -- All of it
import Module ( Module, moduleName, mkVanillaModule, isHomeModule )
import RdrName ( RdrName, mkRdrOrig, mkRdrUnqual, rdrNameOcc, rdrNameModule )
-import CmdLineOpts ( opt_Static, opt_OmitInterfacePragmas, opt_EnsureSplittableC )
+import CmdLineOpts ( opt_Static )
import SrcLoc ( builtinSrcLoc, noSrcLoc, SrcLoc )
import Unique ( Unique, Uniquable(..), u2i, pprUnique, pprUnique10 )
import FastTypes
\begin{code}
mkDFunOcc :: EncodedString -- Typically the class and type glommed together e.g. "OrdMaybe"
- -> Int -- Unique to distinguish dfuns which share the previous two
- -- eg 3
- -- The requirement is that the (string,index) pair be unique in this module
+ -> OccName -- "$fOrdMaybe"
- -> OccName -- "$fOrdMaybe3"
-
-mkDFunOcc string index
- = mk_deriv VarName "$f" (show_index ++ string)
- where
- show_index | index == 0 = ""
- | otherwise = show index
+mkDFunOcc string = mk_deriv VarName "$f" string
\end{code}
We used to add a '$m' to indicate a method, but that gives rise to bad
import VarSet
import Var ( Id, Var )
import Id ( idType, idInfo, idName, isExportedId,
- mkVanillaId, mkId, isLocalId,
+ mkVanillaId, mkId, isLocalId, omitIfaceSigForId,
setIdStrictness, setIdDemandInfo,
)
import IdInfo ( constantIdInfo,
tidyTopBinder :: Module -> IdEnv Bool
-> TopTidyEnv -> CoreExpr
-> TopTidyEnv -> Id -> (TopTidyEnv, Id)
-tidyTopBinder mod ext_ids env_idinfo rhs (orig_env, occ_env, subst_env) id
+tidyTopBinder mod ext_ids env_idinfo rhs env@(orig_env, occ_env, subst_env) id
+ | omitIfaceSigForId id -- Don't mess with constructors,
+ = (env, id) -- record selectors, and the like
+
+ | otherwise
-- This function is the heart of Step 2
-- The second env is the one to use for the IdInfo
-- It's necessary because when we are dealing with a recursive
| otherwise = noUnfolding
tidyIdInfo (_, occ_env, subst_env) is_external unfold_info id
-
| opt_OmitInterfacePragmas || not is_external
-- No IdInfo if the Id isn't
= constantIdInfo
-#! /usr/local/bin/perl
+#! /usr/bin/perl
#
%DirCount = ();
%ModCount = ();
foreach $f ( @ARGV ) {
if ( $f =~ /\.lhs$/ ) {
- open(INF, "unlit $f - |") || die "Couldn't unlit $f!\n";
+ open(INF, "/home/simonpj/builds/slpj/ghc/utils/unlit/unlit $f - |") || die "Couldn't unlit $f!\n";
} else {
open(INF, "< $f") || die "Couldn't open $f!\n";
}
(HsType name)
SrcLoc
- | ClassOpSig name -- Selector name
- (Maybe (DefMeth name)) -- Nothing for source-file class signatures
- -- Gives DefMeth info for interface files sigs
+ | ClassOpSig name -- Selector name
+ (DefMeth name) -- (Just dm_name) for source-file class signatures
+ -- The name may not be used, if there isn't a
+ -- generic default method, but it's there if we
+ -- need it
+ -- Gives DefMeth info for interface files sigs
(HsType name)
SrcLoc
= sep [ppr var <+> pp_dm <+> dcolon, nest 4 (ppr ty)]
where
pp_dm = case dm of
- Just (DefMeth _) -> equals -- Default method indicator
- Just GenDefMeth -> semi -- Generic method indicator
- Just NoDefMeth -> empty -- No Method at all
- -- Not convinced this is right...
- -- Not used in interface file output hopefully
- -- but needed for ddump-rn ??
- other -> dot
- -- empty -- No method at all
-
+ DefMeth _ -> equals -- Default method indicator
+ GenDefMeth -> semi -- Generic method indicator
+ NoDefMeth -> empty -- No Method at all
ppr_sig (SpecSig var ty _)
= sep [ hsep [text "{-# SPECIALIZE", ppr var, dcolon],
\begin{code}
data TyClDecl name pat
- = IfaceSig name -- It may seem odd to classify an interface-file signature
- (HsType name) -- as a 'TyClDecl', but it's very convenient. These three
- [HsIdInfo name] -- are the kind that appear in interface files.
- SrcLoc
-
- | TyData NewOrData
- (HsContext name) -- context
- name -- type constructor
- [HsTyVarBndr name] -- type variables
- [ConDecl name] -- data constructors (empty if abstract)
- Int -- Number of data constructors (valid even if type is abstract)
- (Maybe [name]) -- derivings; Nothing => not specified
+ = IfaceSig { tcdName :: name, -- It may seem odd to classify an interface-file signature
+ tcdType :: HsType name, -- as a 'TyClDecl', but it's very convenient. These three
+ tcdIdInfo :: [HsIdInfo name], -- are the kind that appear in interface files.
+ tcdLoc :: SrcLoc
+ }
+
+ | TyData { tcdND :: NewOrData,
+ tcdCtxt :: HsContext name, -- context
+ tcdName :: name, -- type constructor
+ tcdTyVars :: [HsTyVarBndr name], -- type variables
+ tcdCons :: [ConDecl name], -- data constructors (empty if abstract)
+ tcdNCons :: Int, -- Number of data constructors (valid even if type is abstract)
+ tcdDerivs :: Maybe [name], -- derivings; Nothing => not specified
-- (i.e., derive default); Just [] => derive
-- *nothing*; Just <list> => as you would
-- expect...
- SrcLoc
- name -- generic converter functions
- name -- generic converter functions
-
- | TySynonym name -- type constructor
- [HsTyVarBndr name] -- type variables
- (HsType name) -- synonym expansion
- SrcLoc
-
- | ClassDecl (HsContext name) -- context...
- name -- name of the class
- [HsTyVarBndr name] -- the class type variables
- [FunDep name] -- functional dependencies
- [Sig name] -- methods' signatures
- (MonoBinds name pat) -- default methods
- (ClassDeclSysNames name)
- SrcLoc
+ tcdSysNames :: DataSysNames name, -- Generic converter functions
+ tcdLoc :: SrcLoc
+ }
+
+ | TySynonym { tcdName :: name, -- type constructor
+ tcdTyVars :: [HsTyVarBndr name], -- type variables
+ tcdSynRhs :: HsType name, -- synonym expansion
+ tcdLoc :: SrcLoc
+ }
+
+ | ClassDecl { tcdCtxt :: HsContext name, -- Context...
+ tcdName :: name, -- Name of the class
+ 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,
+ tcdLoc :: SrcLoc
+ }
\end{code}
Simple classifiers
\begin{code}
isIfaceSigDecl, isDataDecl, isSynDecl, isClassDecl :: TyClDecl name pat -> Bool
-isIfaceSigDecl (IfaceSig _ _ _ _) = True
-isIfaceSigDecl other = False
+isIfaceSigDecl (IfaceSig {}) = True
+isIfaceSigDecl other = False
-isSynDecl (TySynonym _ _ _ _) = True
-isSynDecl other = False
+isSynDecl (TySynonym {}) = True
+isSynDecl other = False
-isDataDecl (TyData _ _ _ _ _ _ _ _ _ _) = True
-isDataDecl other = False
+isDataDecl (TyData {}) = True
+isDataDecl other = False
-isClassDecl (ClassDecl _ _ _ _ _ _ _ _ ) = True
-isClassDecl other = False
+isClassDecl (ClassDecl {}) = True
+isClassDecl other = False
\end{code}
Dealing with names
\begin{code}
--------------------------------
tyClDeclName :: TyClDecl name pat -> name
-tyClDeclName (IfaceSig name _ _ _) = name
-tyClDeclName (TyData _ _ name _ _ _ _ _ _ _) = name
-tyClDeclName (TySynonym name _ _ _) = name
-tyClDeclName (ClassDecl _ name _ _ _ _ _ _) = name
-
+tyClDeclName tycl_decl = tcdName tycl_decl
--------------------------------
tyClDeclNames :: Eq name => TyClDecl name pat -> [(name, SrcLoc)]
-- For record fields, the first one counts as the SrcLoc
-- We use the equality to filter out duplicate field names
-tyClDeclNames (TySynonym name _ _ loc)
- = [(name,loc)]
+tyClDeclNames (TySynonym {tcdName = name, tcdLoc = loc}) = [(name,loc)]
+tyClDeclNames (IfaceSig {tcdName = name, tcdLoc = loc}) = [(name,loc)]
-tyClDeclNames (ClassDecl _ cls_name _ _ sigs _ _ loc)
+tyClDeclNames (ClassDecl {tcdName = cls_name, tcdSigs = sigs, tcdLoc = loc})
= (cls_name,loc) : [(n,loc) | ClassOpSig n _ _ loc <- sigs]
-tyClDeclNames (TyData _ _ tc_name _ cons _ _ loc _ _)
+tyClDeclNames (TyData {tcdName = tc_name, tcdCons = cons, tcdLoc = loc})
= (tc_name,loc) : conDeclsNames cons
-tyClDeclNames (IfaceSig name _ _ loc) = [(name,loc)]
--------------------------------
+-- The "system names" are extra implicit names.
+-- 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 _ _ _ _ _ _ names loc) = [(n,loc) | n <- names]
-tyClDeclSysNames (TyData _ _ _ _ cons _ _ _ _ _) = [(wkr_name,loc) | ConDecl _ wkr_name _ _ _ loc <- cons]
-tyClDeclSysNames decl = []
-
+tyClDeclSysNames (ClassDecl {tcdSysNames = names, tcdLoc = loc})
+ = [(n,loc) | n <- names]
+tyClDeclSysNames (TyData {tcdCons = cons, tcdSysNames = names, tcdLoc = loc})
+ = [(n,loc) | n <- names] ++
+ [(wkr_name,loc) | ConDecl _ wkr_name _ _ _ loc <- cons]
+tyClDeclSysNames decl = []
---------------------------------
-type ClassDeclSysNames name = [name]
- -- [tycon, datacon wrapper, datacon worker,
- -- superclass selector 1, ..., superclass selector n]
- -- They are kept in a list rather than a tuple to make the
- -- renamer easier.
mkClassDeclSysNames :: (name, name, name, [name]) -> [name]
getClassDeclSysNames :: [name] -> (name, name, name, [name])
\begin{code}
instance (NamedThing name, Ord name) => Eq (TyClDecl name pat) where
-- Used only when building interface files
- (==) (IfaceSig n1 t1 i1 _)
- (IfaceSig n2 t2 i2 _) = n1==n2 && t1==t2 && i1==i2
-
- (==) (TyData nd1 cxt1 n1 tvs1 cons1 _ _ _ _ _)
- (TyData nd2 cxt2 n2 tvs2 cons2 _ _ _ _ _)
- = n1 == n2 &&
- nd1 == nd2 &&
- eqWithHsTyVars tvs1 tvs2 (\ env ->
- eq_hsContext env cxt1 cxt2 &&
- eqListBy (eq_ConDecl env) cons1 cons2
- )
-
- (==) (TySynonym n1 tvs1 ty1 _)
- (TySynonym n2 tvs2 ty2 _)
- = n1 == n2 &&
- eqWithHsTyVars tvs1 tvs2 (\ env -> eq_hsType env ty1 ty2)
-
- (==) (ClassDecl cxt1 n1 tvs1 fds1 sigs1 _ _ _ )
- (ClassDecl cxt2 n2 tvs2 fds2 sigs2 _ _ _ )
- = n1 == n2 &&
- eqWithHsTyVars tvs1 tvs2 (\ env ->
- eq_hsContext env cxt1 cxt2 &&
- eqListBy (eq_hsFD env) fds1 fds2 &&
- eqListBy (eq_cls_sig env) sigs1 sigs2
+ (==) d1@(IfaceSig {}) d2@(IfaceSig {})
+ = tcdName d1 == tcdName d2 &&
+ tcdType d1 == tcdType d2 &&
+ tcdIdInfo d1 == tcdIdInfo d2
+
+ (==) d1@(TyData {}) d2@(TyData {})
+ = tcdName d1 == tcdName d2 &&
+ tcdND d1 == tcdND d2 &&
+ eqWithHsTyVars (tcdTyVars d1) (tcdTyVars d2) (\ env ->
+ eq_hsContext env (tcdCtxt d1) (tcdCtxt d2) &&
+ eqListBy (eq_ConDecl env) (tcdCons d1) (tcdCons d2)
+ )
+
+ (==) d1@(TySynonym {}) d2@(TySynonym {})
+ = tcdName d1 == tcdName d2 &&
+ eqWithHsTyVars (tcdTyVars d1) (tcdTyVars d2) (\ env ->
+ eq_hsType env (tcdSynRhs d1) (tcdSynRhs d2)
+ )
+
+ (==) d1@(ClassDecl {}) d2@(ClassDecl {})
+ = tcdName d1 == tcdName d2 &&
+ eqWithHsTyVars (tcdTyVars d1) (tcdTyVars d2) (\ env ->
+ eq_hsContext env (tcdCtxt d1) (tcdCtxt d2) &&
+ eqListBy (eq_hsFD env) (tcdFDs d1) (tcdFDs d2) &&
+ eqListBy (eq_cls_sig env) (tcdSigs d1) (tcdSigs d2)
)
(==) _ _ = False -- default case
-- This is used for comparing declarations before putting
-- them into interface files, and the name of the default
-- method isn't relevant
- Nothing `eq_dm` Nothing = True
- (Just NoDefMeth) `eq_dm` (Just NoDefMeth) = True
- (Just GenDefMeth) `eq_dm` (Just GenDefMeth) = True
- (Just (DefMeth _)) `eq_dm` (Just (DefMeth _)) = True
- dm1 `eq_dm` dm2 = False
+ NoDefMeth `eq_dm` NoDefMeth = True
+ GenDefMeth `eq_dm` GenDefMeth = True
+ DefMeth _ `eq_dm` DefMeth _ = True
+ dm1 `eq_dm` dm2 = False
\end{code}
countTyClDecls :: [TyClDecl name pat] -> (Int, Int, Int, Int, Int)
-- class, data, newtype, synonym decls
countTyClDecls decls
- = (length [() | ClassDecl _ _ _ _ _ _ _ _ <- decls],
- length [() | TyData DataType _ _ _ _ _ _ _ _ _ <- decls],
- length [() | TyData NewType _ _ _ _ _ _ _ _ _ <- decls],
- length [() | TySynonym _ _ _ _ <- decls],
- length [() | IfaceSig _ _ _ _ <- decls])
+ = (length [() | ClassDecl {} <- decls],
+ length [() | TySynonym {} <- decls],
+ length [() | IfaceSig {} <- decls],
+ length [() | TyData {tcdND = DataType} <- decls],
+ length [() | TyData {tcdND = NewType} <- decls])
\end{code}
\begin{code}
instance (NamedThing name, Outputable name, Outputable pat)
=> Outputable (TyClDecl name pat) where
- ppr (IfaceSig var ty info _) = hsep [ppr var, dcolon, ppr ty, pprHsIdInfo info]
+ ppr (IfaceSig {tcdName = var, tcdType = ty, tcdIdInfo = info})
+ = hsep [ppr var, dcolon, ppr ty, pprHsIdInfo info]
- ppr (TySynonym tycon tyvars mono_ty src_loc)
+ ppr (TySynonym {tcdName = tycon, tcdTyVars = tyvars, tcdSynRhs = mono_ty})
= hang (ptext SLIT("type") <+> pp_decl_head [] tycon tyvars <+> equals)
4 (ppr mono_ty)
- ppr (TyData new_or_data context tycon tyvars condecls ncons
- derivings src_loc gen_conv1 gen_conv2) -- The generic names are not printed out ATM
- = pp_tydecl
- (ptext keyword <+> pp_decl_head context tycon tyvars <+> equals)
+ ppr (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon,
+ tcdTyVars = tyvars, tcdCons = condecls, tcdNCons = ncons,
+ tcdDerivs = derivings})
+ = pp_tydecl (ptext keyword <+> pp_decl_head context tycon tyvars <+> equals)
(pp_condecls condecls ncons)
derivings
where
NewType -> SLIT("newtype")
DataType -> SLIT("data")
- ppr (ClassDecl context clas tyvars fds sigs methods _ src_loc)
+ ppr (ClassDecl {tcdCtxt = context, tcdName = clas, tcdTyVars = tyvars, tcdFDs = fds,
+ tcdSigs = sigs, tcdMeths = methods})
| null sigs -- No "where" part
= top_matter
import RdrHsSyn ( RdrNameHsExpr )
import CoreToStg ( coreToStgExpr )
import StringBuffer ( stringToStringBuffer, freeStringBuffer )
+import Unique ( Uniquable(..) )
+import Type ( splitTyConApp_maybe )
+import PrelNames ( ioTyConKey )
#endif
import HsSyn
writeIface, pprIface )
import TcModule
import Type
-import TcHsSyn
import InstEnv ( emptyInstEnv )
import Desugar
import SimplCore
import CmdLineOpts
import ErrUtils ( dumpIfSet_dyn, showPass )
import Util ( unJust )
-import Unique ( Uniquable(..) )
-import PrelNames ( ioTyConKey )
import UniqSupply ( mkSplitUniqSupply )
import Bag ( emptyBag )
HomeSymbolTable,
OrigNameEnv(..), PackageRuleBase, HomeIfaceTable,
typeEnvClasses, typeEnvTyCons, emptyIfaceTable )
-import Type ( splitTyConApp_maybe )
import FiniteMap ( FiniteMap, plusFM, emptyFM, addToFM )
import OccName ( OccName )
import Name ( Name, nameModule, nameOccName, getName )
Just (pcs_tc, tc_result) -> do {
let env_tc = tc_env tc_result
- local_insts = tc_insts tc_result
local_rules = tc_rules tc_result
;
-- create a new details from the closed, typechecked, old iface
- let new_details = mkModDetailsFromIface env_tc local_insts local_rules
+ let new_details = mkModDetailsFromIface env_tc local_rules
;
return (HscNoRecomp pcs_tc new_details old_iface)
}}}}
Nothing -> return (HscFail pcs_rn);
Just (pcs_tc, tc_result) -> do {
- ; let env_tc = tc_env tc_result
- local_insts = tc_insts tc_result
+ ; let env_tc = tc_env tc_result
-------------------
-- DESUGAR, SIMPLIFY, TIDY-CORE
-------------------
-- BUILD THE NEW ModDetails AND ModIface
-------------------
- ; let new_details = mkModDetails env_tc local_insts tidy_binds
+ ; let new_details = mkModDetails env_tc tidy_binds
top_level_ids orphan_rules
; final_iface <- mkFinalIface ghci_mode dflags location
maybe_checked_iface new_iface new_details
myCoreToStg dflags this_mod tidy_binds
= do
- () <- coreBindsSize occ_anal_tidy_binds `seq` return ()
+ () <- coreBindsSize tidy_binds `seq` return ()
-- TEMP: the above call zaps some space usage allocated by the
-- simplifier, which for reasons I don't understand, persists
-- thoroughout code generation
-- _scc_ "Core2Stg"
- stg_binds <- topCoreBindsToStg dflags occ_anal_tidy_binds
+ stg_binds <- topCoreBindsToStg dflags this_mod tidy_binds
-- _scc_ "Stg2Stg"
- (stg_binds2, cost_centre_info) <- stg2stg dflags this_mod st_uniqs stg_binds
+ (stg_binds2, cost_centre_info) <- stg2stg dflags this_mod stg_binds
let final_ids = collectFinalStgBinders (map fst stg_binds2)
return (stg_binds2, cost_centre_info, final_ids)
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)
+
count_sigs sigs = foldr add4 (0,0,0,0) (map sig_info sigs)
sig_info (Sig _ _ _) = (1,0,0,0)
spec_info (Just (False, _)) = (0,0,0,0,1,0)
spec_info (Just (True, _)) = (0,0,0,0,0,1)
- data_info (TyData _ _ _ _ _ nconstrs derivs _ _ _)
+ data_info (TyData {tcdNCons = nconstrs, tcdDerivs = derivs})
= (nconstrs, case derivs of {Nothing -> 0; Just ds -> length ds})
data_info other = (0,0)
- class_info (ClassDecl _ _ _ _ meth_sigs def_meths _ _ )
- = case count_sigs meth_sigs of
+ class_info decl@(ClassDecl {})
+ = case count_sigs (tcdSigs decl) of
(_,classops,_,_) ->
- (classops, addpr (count_monobinds def_meths))
+ (classops, addpr (count_mb_monobinds (tcdMeths decl)))
class_info other = (0,0)
inst_info (InstDecl _ inst_meths inst_sigs _ _)
{-# OPTIONS -W -fno-warn-incomplete-patterns #-}
-----------------------------------------------------------------------------
--- $Id: Main.hs,v 1.33 2000/11/24 09:51:39 simonpj Exp $
+-- $Id: Main.hs,v 1.34 2000/11/24 17:02:02 simonpj Exp $
--
-- GHC Driver program
--
#ifdef GHCI
import Interpreter
import InteractiveUI
+#endif
+
+#ifndef mingw32_TARGET_OS
import Dynamic
+import Posix
#endif
import CompManager
import Concurrent
-#ifndef mingw32_TARGET_OS
-import Posix
-#endif
import Directory
import IOExts
import Exception
import TcHsSyn ( TypecheckedRuleDecl )
import HscTypes ( VersionInfo(..), ModIface(..), ModDetails(..),
IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts,
- TyThing(..), DFunId, TypeEnv, isTyClThing, Avails,
+ TyThing(..), DFunId, TypeEnv, Avails,
WhatsImported(..), GenAvailInfo(..),
ImportVersion, AvailInfo, Deprecations(..),
extendTypeEnvList
)
import CmdLineOpts
-import Id ( Id, idType, idInfo, omitIfaceSigForId,
- idSpecialisation, setIdInfo, isLocalId
+import Id ( Id, idType, idInfo, omitIfaceSigForId, isDictFunId,
+ idSpecialisation, setIdInfo, isLocalId, idName, hasNoBinding
)
import Var ( isId )
import VarSet
isBuiltinRule, rulesRules,
bindersOf, bindersOfBinds
)
-import CoreFVs ( ruleSomeLhsFreeVars, ruleSomeFreeVars )
+import CoreFVs ( ruleSomeLhsFreeVars )
import CoreUnfold ( neverUnfold, unfoldingTemplate )
import Name ( getName, nameModule, Name, NamedThing(..) )
import Name -- Env
%************************************************************************
\begin{code}
-mkModDetails :: TypeEnv -> [DFunId] -- From typechecker
- -> [CoreBind] -> [Id] -- Final bindings, plus the top-level Ids from the
- -- code generator; they have authoritative arity info
- -> [IdCoreRule] -- Tidy orphan rules
+mkModDetails :: TypeEnv -- From typechecker
+ -> [CoreBind] -- Final bindings
+ -> [Id] -- Top-level Ids from the code generator;
+ -- they have authoritative arity info
+ -> [IdCoreRule] -- Tidy orphan rules
-> ModDetails
-mkModDetails type_env dfun_ids tidy_binds stg_ids orphan_rules
+mkModDetails type_env tidy_binds stg_ids orphan_rules
= ModDetails { md_types = new_type_env,
md_rules = rule_dcls,
- md_insts = dfun_ids }
+ md_insts = filter isDictFunId final_ids }
where
-- The competed type environment is gotten from
-- a) keeping the types and classes
-- b) removing all Ids,
-- c) adding Ids with correct IdInfo, including unfoldings,
-- gotten from the bindings
- -- From (c) we keep only those Ids with Global names, plus Ids
- -- accessible from them (notably via unfoldings)
+ -- From (c) we keep only those Ids with Global names;
+ -- the CoreTidy pass makes sure these are all and only
+ -- the externally-accessible ones
-- This truncates the type environment to include only the
-- exported Ids and things needed from them, which saves space
--
-- However, we do keep things like constructors, which should not appear
-- in interface files, because they are needed by importing modules when
-- using the compilation manager
- new_type_env = extendTypeEnvList (filterNameEnv isTyClThing type_env)
+ new_type_env = extendTypeEnvList (filterNameEnv keep_it type_env)
(map AnId final_ids)
+ -- We keep constructor workers, because they won't appear
+ -- in the bindings from which final_ids are derived!
+ keep_it (AnId id) = hasNoBinding id
+ keep_it other = True
+
stg_id_set = mkVarSet stg_ids
final_ids = [addStgInfo stg_id_set id | bind <- tidy_binds
, id <- bindersOf bind
, isGlobalName (idName id)]
-
-- The complete rules are gotten by combining
-- a) the orphan rules
-- b) rules embedded in the top-level Ids
-- This version is used when we are re-linking a module
-- so we've only run the type checker on its previous interface
-mkModDetailsFromIface :: TypeEnv -> [DFunId] -- From typechecker
+mkModDetailsFromIface :: TypeEnv
-> [TypecheckedRuleDecl]
-> ModDetails
-mkModDetailsFromIface type_env dfun_ids rules
+mkModDetailsFromIface type_env rules
= ModDetails { md_types = type_env,
md_rules = rule_dcls,
md_insts = dfun_ids }
where
+ dfun_ids = [dfun_id | AnId dfun_id <- nameEnvElts type_env, isDictFunId dfun_id]
rule_dcls = [(id,rule) | IfaceRuleOut id rule <- rules]
-- All the rules from an interface are of the IfaceRuleOut form
\end{code}
ifaceTyCls (AClass clas) so_far
= cls_decl : so_far
where
- cls_decl = ClassDecl (toHsContext sc_theta)
- (getName clas)
- (toHsTyVars clas_tyvars)
- (toHsFDs clas_fds)
- (map toClassOpSig op_stuff)
- EmptyMonoBinds
- [] noSrcLoc
+ cls_decl = ClassDecl { tcdCtxt = toHsContext sc_theta,
+ tcdName = getName clas,
+ tcdTyVars = toHsTyVars clas_tyvars,
+ tcdFDs = toHsFDs clas_fds,
+ tcdSigs = map toClassOpSig op_stuff,
+ tcdMeths = Nothing,
+ tcdSysNames = bogus_sysnames,
+ tcdLoc = noSrcLoc }
(clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas
toClassOpSig (sel_id, def_meth)
= ASSERT(sel_tyvars == clas_tyvars)
- ClassOpSig (getName sel_id) (Just def_meth') (toHsType op_ty) noSrcLoc
+ ClassOpSig (getName sel_id) def_meth' (toHsType op_ty) noSrcLoc
where
(sel_tyvars, _, op_ty) = splitSigmaTy (idType sel_id)
def_meth' = case def_meth of
| otherwise = ty_decl : so_far
where
ty_decl | isSynTyCon tycon
- = TySynonym (getName tycon)(toHsTyVars tyvars)
- (toHsType syn_ty) noSrcLoc
+ = TySynonym { tcdName = getName tycon,
+ tcdTyVars = toHsTyVars tyvars,
+ tcdSynRhs = toHsType syn_ty,
+ tcdLoc = noSrcLoc }
| isAlgTyCon tycon
- = TyData new_or_data (toHsContext (tyConTheta tycon))
- (getName tycon)
- (toHsTyVars tyvars)
- (map ifaceConDecl (tyConDataCons tycon))
- (tyConFamilySize tycon)
- Nothing noSrcLoc (panic "gen1") (panic "gen2")
+ = TyData { tcdND = new_or_data,
+ tcdCtxt = toHsContext (tyConTheta tycon),
+ tcdName = getName tycon,
+ tcdTyVars = toHsTyVars tyvars,
+ tcdCons = map ifaceConDecl (tyConDataCons tycon),
+ tcdNCons = tyConFamilySize tycon,
+ tcdDerivs = Nothing,
+ tcdSysNames = bogus_sysnames,
+ tcdLoc = noSrcLoc }
| otherwise = pprPanic "ifaceTyCls" (ppr tycon)
| omitIfaceSigForId id = so_far
| otherwise = iface_sig : so_far
where
- iface_sig = IfaceSig (getName id) (toHsType id_type) hs_idinfo noSrcLoc
+ iface_sig = IfaceSig { tcdName = getName id,
+ tcdType = toHsType id_type,
+ tcdIdInfo = hs_idinfo,
+ tcdLoc = noSrcLoc }
id_type = idType id
id_info = idInfo id
= IfaceRule name (map toUfBndr bndrs) (getName id)
(map toUfExpr args) (toUfExpr rhs) noSrcLoc
+bogus_sysnames = panic "Bogus sys names"
+
bogusIfaceRule id
= IfaceRule SLIT("bogus") [] (getName id) [] (UfVar (getName id)) noSrcLoc
\end{code}
-- mi_globals field set to anything reasonable.
| otherwise -- Add updated version numbers
- = (final_iface, Just pp_tc_diffs)
+ = pprTrace "completeIface" (ppr (dcl_tycl old_decls))
+ (final_iface, Just pp_tc_diffs)
where
final_iface = new_iface { mi_version = new_version }
same_fixity n = lookupNameEnv old_fixities n == lookupNameEnv new_fixities n
diff ok_so_far pp new_vers [] [] = (ok_so_far, pp, new_vers)
- diff ok_so_far pp new_vers old [] = (False, pp, new_vers)
+ diff ok_so_far pp new_vers (od:ods) [] = diff False (pp $$ only_old od) new_vers ods []
diff ok_so_far pp new_vers [] (nd:nds) = diff False (pp $$ only_new nd) new_vers [] nds
diff ok_so_far pp new_vers (od:ods) (nd:nds)
= case od_name `compare` nd_name of
od_name = tyClDeclName od
nd_name = tyClDeclName nd
new_vers' = extendNameEnv new_vers nd_name
- (bumpVersion True (lookupNameEnv_NF old_vers od_name))
+ (bumpVersion False (lookupNameEnv_NF old_vers od_name))
only_old d = ptext SLIT("Only in old iface:") <+> ppr d
only_new d = ptext SLIT("Only in new iface:") <+> ppr d
{-
-----------------------------------------------------------------------------
-$Id: Parser.y,v 1.48 2000/11/16 11:39:37 simonmar Exp $
+$Id: Parser.y,v 1.49 2000/11/24 17:02:03 simonpj Exp $
Haskell grammar.
(binds,sigs) = cvMonoBindsAndSigs cvClassOpSig (groupBindings $5)
in
returnP (RdrHsDecl (TyClD
- (mkClassDecl cs c ts $4 sigs binds $1))) }
+ (mkClassDecl cs c ts $4 sigs (Just binds) $1))) }
| srcloc 'instance' inst_type where
{ let (binds,sigs)
extractRuleBndrsTyVars,
extractHsCtxtRdrTyVars, extractGenericPatTyVars,
- mkHsOpApp, mkClassDecl, mkClassOpSig, mkConDecl,
+ mkHsOpApp, mkClassDecl, mkClassOpSigDM, mkConDecl,
mkHsNegApp,
cvBinds,
\begin{code}
mkClassDecl cxt cname tyvars fds sigs mbinds loc
- = ClassDecl cxt cname tyvars fds sigs mbinds new_names 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
= let t_occ = rdrNameOcc tname
name1 = mkRdrUnqual (mkGenOcc1 t_occ)
name2 = mkRdrUnqual (mkGenOcc2 t_occ)
- in TyData new_or_data context
- tname list_var list_con i maybe src name1 name2
+ in TyData { tcdND = new_or_data, tcdCtxt = context, tcdName = tname,
+ tcdTyVars = list_var, tcdCons = list_con, tcdNCons = i,
+ tcdDerivs = maybe, tcdLoc = src, tcdSysNames = [name1, name2] }
-mkClassOpSig (DefMeth x) op ty loc
- = ClassOpSig op (Just (DefMeth dm_rn)) ty loc
+mkClassOpSigDM op ty loc
+ = ClassOpSig op (DefMeth dm_rn) ty loc
where
dm_rn = mkRdrUnqual (mkDefaultMethodOcc (rdrNameOcc op))
-mkClassOpSig x op ty loc =
- ClassOpSig op (Just x) ty loc
mkConDecl cname ex_vars cxt details loc
= ConDecl cname wkr_name ex_vars cxt details loc
cvInstDeclSig sig = sig
-cvClassOpSig (Sig var poly_ty src_loc) = ClassOpSig var Nothing poly_ty src_loc
+cvClassOpSig (Sig var poly_ty src_loc) = mkClassOpSigDM var poly_ty src_loc
cvClassOpSig sig = sig
\end{code}
-- the TyCon unique. So each Prelude tycon needs 3 slots, one
-- for itself and two more for the generic Ids.
mk_tc_gen_info mod tc_uniq tc_name tycon
- = mkTyConGenInfo tycon name1 name2
+ = mkTyConGenInfo tycon [name1, name2]
where
tc_occ_name = nameOccName tc_name
occ_name1 = mkGenOcc1 tc_occ_name
| csig ';' csigs1 { $1 : $3 }
csig :: { RdrNameSig }
-csig : src_loc qvar_name '::' type { mkClassOpSig NoDefMeth $2 $4 $1 }
- | src_loc qvar_name '=' '::' type { mkClassOpSig (DefMeth (error "DefMeth") )
- $2 $5 $1 }
- | src_loc qvar_name ';' '::' type { mkClassOpSig GenDefMeth $2 $5 $1 }
+csig : src_loc qvar_name '::' type { ClassOpSig $2 NoDefMeth $4 $1 }
+ | src_loc qvar_name ';' '::' type { ClassOpSig $2 GenDefMeth $5 $1 }
+ | src_loc qvar_name '=' '::' type { mkClassOpSigDM $2 $5 $1 }
--------------------------------------------------------------------------
| src_loc 'newtype' opt_decl_context qtc_name tv_bndrs newtype_constr
{ mkTyData NewType $3 $4 $5 $6 1 Nothing $1 }
| src_loc 'class' opt_decl_context qtc_name tv_bndrs fds csigs
- { mkClassDecl $3 $4 $5 $6 $7 EmptyMonoBinds $1 }
+ { mkClassDecl $3 $4 $5 $6 $7 Nothing $1 }
maybe_idinfo :: { RdrName -> [HsIdInfo RdrName] }
maybe_idinfo : {- empty -} { \_ -> [] }
implicit_occs = string_occs ++ foldr ((++) . get) implicit_main decls
- get (TyClD (TyData _ _ _ _ _ _ (Just deriv_classes) _ _ _))
- = concat (map get_deriv deriv_classes)
- get other = []
+ get (TyClD (TyData {tcdDerivs = Just deriv_classes})) = concat (map get_deriv deriv_classes)
+ get other = []
get_deriv cls = case lookupUFM derivingOccurrences cls of
Nothing -> []
getFixities acc (FixD fix)
= fix_decl acc fix
- getFixities acc (TyClD (ClassDecl _ _ _ _ sigs _ _ _ ))
+ getFixities acc (TyClD (ClassDecl { tcdSigs = sigs}))
= foldlRn fix_decl acc [sig | FixSig sig <- sigs]
-- Get fixities from class decl sigs too.
getFixities acc other_decl
new_cache = addToFM cache key new_name
in
setNameSupplyRn (us, new_cache, ipcache) `thenRn_`
- -- traceRn (text "newTopBinder: overwrite" <+> ppr new_name) `thenRn_`
+ traceRn (text "newTopBinder: overwrite" <+> ppr new_name) `thenRn_`
returnRn new_name
-- Miss in the cache!
new_cache = addToFM cache key new_name
in
setNameSupplyRn (us', new_cache, ipcache) `thenRn_`
- -- traceRn (text "newTopBinder: new" <+> ppr new_name) `thenRn_`
+ traceRn (text "newTopBinder: new" <+> ppr new_name) `thenRn_`
returnRn new_name
returnRn (vers, (decls_map', n_slurped))
loadDecl mod (version_map, decls_map) (version, decl)
- = getIfaceDeclBinders mod decl `thenRn` \ full_avail ->
+ = getTyClDeclBinders mod decl `thenRn` \ (avail, sys_names) ->
let
+ full_avail = case avail of
+ Avail n -> avail
+ AvailTC n ns -> AvailTC n (sys_names ++ ns)
main_name = availName full_avail
new_decls_map = extendNameEnvList decls_map stuff
stuff = [ (name, (full_avail, name==main_name, (mod, decl)))
are handled by the sourc-code specific stuff in @RnNames@.
\begin{code}
-getIfaceDeclBinders, getTyClDeclBinders
+getTyClDeclBinders
:: Module
-> RdrNameTyClDecl
- -> RnM d AvailInfo
+ -> RnM d (AvailInfo, [Name]) -- The [Name] are the system names
-----------------
-getTyClDeclBinders mod (IfaceSig var ty prags src_loc)
+getTyClDeclBinders mod (IfaceSig {tcdName = var, tcdLoc = src_loc})
= newTopBinder mod var src_loc `thenRn` \ var_name ->
- returnRn (Avail var_name)
+ returnRn (Avail var_name, [])
getTyClDeclBinders mod tycl_decl
- = new_top_bndrs mod (tyClDeclNames tycl_decl) `thenRn` \ (main_name:sub_names) ->
- returnRn (AvailTC main_name (main_name : sub_names))
-
------------------
-getIfaceDeclBinders mod (IfaceSig var ty prags src_loc)
- = newTopBinder mod var src_loc `thenRn` \ var_name ->
- returnRn (Avail var_name)
-
-getIfaceDeclBinders mod tycl_decl
- = new_top_bndrs mod (tyClDeclNames tycl_decl) `thenRn` \ (main_name:sub_names) ->
+ = 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 (main_name : (sys_names ++ sub_names)))
+ returnRn (AvailTC main_name names, sys_names)
-----------------
new_top_bndrs mod names_w_locs
\begin{code}
tyClDeclFVs :: RenamedTyClDecl -> NameSet
-tyClDeclFVs (IfaceSig name ty id_infos loc)
+tyClDeclFVs (IfaceSig {tcdType = ty, tcdIdInfo = id_infos})
= extractHsTyNames ty `plusFV`
plusFVs (map hsIdInfoFVs id_infos)
-tyClDeclFVs (TyData _ context _ tyvars condecls _ derivings _ _ _)
+tyClDeclFVs (TyData {tcdCtxt = context, tcdTyVars = tyvars, tcdCons = condecls, tcdDerivs = derivings})
= delFVs (map hsTyVarName tyvars) $
extractHsCtxtTyNames context `plusFV`
plusFVs (map conDeclFVs condecls) `plusFV`
mkNameSet (derivings `orElse` [])
-tyClDeclFVs (TySynonym _ tyvars ty _)
+tyClDeclFVs (TySynonym {tcdTyVars = tyvars, tcdSynRhs = ty})
= delFVs (map hsTyVarName tyvars) (extractHsTyNames ty)
-tyClDeclFVs (ClassDecl context _ tyvars fds sigs _ _ src_loc)
+tyClDeclFVs (ClassDecl {tcdCtxt = context, tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs})
= delFVs (map hsTyVarName tyvars) $
extractHsCtxtTyNames context `plusFV`
plusFVs (map extractFunDepNames fds) `plusFV`
hsSigFVs (NoInlineSig v p _) = unitFV v
hsSigFVs (ClassOpSig v dm ty _) = dmFVs dm `plusFV` extractHsTyNames ty `addOneFV` v
-dmFVs (Just (DefMeth v)) = unitFV v
-dmFVs other = emptyFVs
+dmFVs (DefMeth v) = unitFV v
+dmFVs other = emptyFVs
----------------
instDeclFVs (InstDecl inst_ty _ _ maybe_dfun _)
getGates source_fvs decl
= get_gates (\n -> n `elemNameSet` source_fvs) decl
-get_gates is_used (IfaceSig _ ty _ _)
- = extractHsTyNames ty
+get_gates is_used (IfaceSig {tcdType = ty}) = extractHsTyNames ty
-get_gates is_used (ClassDecl ctxt cls tvs _ sigs _ _ _ )
+get_gates is_used (ClassDecl { tcdCtxt = ctxt, tcdName = cls, tcdTyVars = tvs, tcdSigs = sigs})
= (delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) sigs)
(hsTyVarNames tvs)
`addOneToNameSet` cls)
| otherwise
= emptyFVs
-get_gates is_used (TySynonym tycon tvs ty _)
+get_gates is_used (TySynonym {tcdTyVars = tvs, tcdSynRhs = ty})
= delListFromNameSet (extractHsTyNames ty) (hsTyVarNames tvs)
-- A type synonym type constructor isn't a "gate" for instance decls
-get_gates is_used (TyData _ ctxt tycon tvs cons _ _ _ _ _)
+get_gates is_used (TyData {tcdCtxt = ctxt, tcdName = tycon, tcdTyVars = tvs, tcdCons = cons})
= delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) cons)
(hsTyVarNames tvs)
`addOneToNameSet` tycon
\begin{code}
importsFromLocalDecls this_mod decls
= mapRn (getLocalDeclBinders this_mod) decls `thenRn` \ avails_s ->
-
+ -- The avails that are returned don't include the "system" names
let
avails = concat avails_s
-- Check for duplicate definitions
mapRn_ (addErrRn . dupDeclErr) dups `thenRn_`
+
-- Record that locally-defined things are available
recordLocalSlurps (availsToNameSet avails) `thenRn_`
-
let
mod_name = moduleName this_mod
unqual_imp = True -- Want unqualified names
returnRn (gbl_env, exports)
---------------------------
-getLocalDeclBinders :: Module
- -> RdrNameHsDecl -> RnMG Avails
+getLocalDeclBinders :: Module -> RdrNameHsDecl -> RnMG [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 ->
+ getTyClDeclBinders mod tycl_decl `thenRn` \ (avail, sys_names) ->
+
+ -- Record that the system names are available
+ recordLocalSlurps (mkNameSet sys_names) `thenRn_`
returnRn [avail]
getLocalDeclBinders mod (ValD binds)
- = mapRn new (bagToList (collectTopBinders binds))
+ = mapRn new (bagToList (collectTopBinders binds)) `thenRn` \ avails ->
+ returnRn avails
where
new (rdr_name, loc) = newTopBinder mod rdr_name loc `thenRn` \ name ->
returnRn (Avail name)
However, we can also do some scoping checks at the same time.
\begin{code}
-rnTyClDecl (IfaceSig name ty id_infos loc)
+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 name' ty' id_infos' loc)
+ returnRn (IfaceSig {tcdName = name', tcdType = ty', tcdIdInfo = id_infos', tcdLoc = loc})
where
doc_str = text "the interface signature for" <+> quotes (ppr name)
-rnTyClDecl (TyData new_or_data context tycon tyvars condecls nconstrs derivings src_loc gen_name1 gen_name2)
+rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon,
+ tcdTyVars = tyvars, tcdCons = condecls, tcdNCons = nconstrs,
+ tcdDerivs = derivings, tcdLoc = src_loc, tcdSysNames = sys_names})
= pushSrcLocRn src_loc $
lookupTopBndrRn tycon `thenRn` \ tycon' ->
bindTyVarsRn data_doc tyvars $ \ tyvars' ->
rnContext data_doc context `thenRn` \ context' ->
checkDupOrQualNames data_doc con_names `thenRn_`
mapRn rnConDecl condecls `thenRn` \ condecls' ->
- lookupSysBinder gen_name1 `thenRn` \ name1' ->
- lookupSysBinder gen_name2 `thenRn` \ name2' ->
+ mapRn lookupSysBinder sys_names `thenRn` \ sys_names' ->
rnDerivs derivings `thenRn` \ derivings' ->
- returnRn (TyData new_or_data context' tycon' tyvars' condecls' nconstrs
- derivings' src_loc name1' name2')
+ returnRn (TyData {tcdND = new_or_data, tcdCtxt = context', tcdName = tycon',
+ tcdTyVars = tyvars', tcdCons = condecls', tcdNCons = nconstrs,
+ tcdDerivs = derivings', tcdLoc = src_loc, tcdSysNames = sys_names'})
where
data_doc = text "the data type declaration for" <+> quotes (ppr tycon)
con_names = map conDeclName condecls
-rnTyClDecl (TySynonym name tyvars ty src_loc)
+rnTyClDecl (TySynonym {tcdName = name, tcdTyVars = tyvars, tcdSynRhs = ty, tcdLoc = src_loc})
= pushSrcLocRn src_loc $
doptRn Opt_GlasgowExts `thenRn` \ glaExts ->
lookupTopBndrRn name `thenRn` \ name' ->
bindTyVarsRn syn_doc tyvars $ \ tyvars' ->
rnHsType syn_doc (unquantify glaExts ty) `thenRn` \ ty' ->
- returnRn (TySynonym name' tyvars' ty' src_loc)
+ returnRn (TySynonym {tcdName = name', tcdTyVars = tyvars', tcdSynRhs = ty', tcdLoc = src_loc})
where
syn_doc = text "the declaration for type synonym" <+> quotes (ppr name)
unquantify glaExts (HsForAllTy Nothing ctxt ty) | glaExts = ty
unquantify glaExys ty = ty
-rnTyClDecl (ClassDecl context cname tyvars fds sigs mbinds names src_loc)
+rnTyClDecl (ClassDecl {tcdCtxt = context, tcdName = cname,
+ tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
+ tcdSysNames = names, tcdLoc = src_loc})
= pushSrcLocRn src_loc $
lookupTopBndrRn cname `thenRn` \ cname' ->
-- The renamer *could* check this for class decls, but can't
-- for instance decls.
- returnRn (ClassDecl context' cname' tyvars' fds' (non_ops' ++ sigs') EmptyMonoBinds names' src_loc)
+ returnRn (ClassDecl { tcdCtxt = context', tcdName = cname', tcdTyVars = tyvars',
+ tcdFDs = fds', tcdSigs = non_ops' ++ sigs', tcdMeths = Nothing,
+ tcdSysNames = names', tcdLoc = src_loc})
where
cls_doc = text "the declaration for class" <+> ppr cname
sig_doc = text "the signatures for class" <+> ppr cname
-rnClassOp clas clas_tyvars clas_fds sig@(ClassOpSig op maybe_dm_stuff ty locn)
+rnClassOp clas clas_tyvars clas_fds sig@(ClassOpSig op dm_stuff ty locn)
= pushSrcLocRn locn $
lookupTopBndrRn op `thenRn` \ op_name ->
rnHsSigType (quotes (ppr op)) ty `thenRn` \ new_ty ->
-- Make the default-method name
- (case maybe_dm_stuff of
- Nothing -> returnRn Nothing -- Source-file class decl
-
- Just (DefMeth dm_rdr_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 (Just (DefMeth dm_name))
+ returnRn (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
- Just GenDefMeth -> returnRn (Just GenDefMeth)
- Just NoDefMeth -> returnRn (Just NoDefMeth)
- ) `thenRn` \ maybe_dm_stuff' ->
+ GenDefMeth -> returnRn GenDefMeth
+ NoDefMeth -> returnRn NoDefMeth
+ ) `thenRn` \ dm_stuff' ->
- returnRn (ClassOpSig op_name maybe_dm_stuff' new_ty locn)
+ returnRn (ClassOpSig op_name dm_stuff' new_ty locn)
rnClassBinds :: RdrNameTyClDecl -> RenamedTyClDecl -> RnMS (RenamedTyClDecl, FreeVars)
-- Rename the mbinds only; the rest is done already
-rnClassBinds (ClassDecl _ _ _ _ _ mbinds _ _ ) -- Get mbinds from here
- (ClassDecl context cname tyvars fds sigs _ names src_loc) -- Everything else is here
+rnClassBinds (ClassDecl {tcdMeths = Nothing}) rn_cls_decl
+ = returnRn (rn_cls_decl, emptyFVs) -- No meth binds; decl came from interface file
+
+rnClassBinds (ClassDecl {tcdMeths = Just mbinds}) -- Get mbinds from here
+ rn_cls_decl@(ClassDecl {tcdTyVars = tyvars, tcdLoc = src_loc}) -- Everything else is here
= -- The newLocals call is tiresome: given a generic class decl
-- class C a where
-- op :: a -> a
checkDupOrQualNames meth_doc meth_rdr_names_w_locs `thenRn_`
newLocalsRn gen_rdr_tyvars_w_locs `thenRn` \ gen_tyvars ->
rnMethodBinds gen_tyvars mbinds `thenRn` \ (mbinds', meth_fvs) ->
- returnRn (ClassDecl context cname tyvars fds sigs mbinds' names src_loc, meth_fvs)
+ returnRn (rn_cls_decl {tcdMeths = Just mbinds'}, meth_fvs)
where
- meth_doc = text "the default-methods for class" <+> ppr cname
+ meth_doc = text "the default-methods for class" <+> ppr (tcdName rn_cls_decl)
rnClassBinds _ tycl_decl = returnRn (tycl_decl, emptyFVs)
-- Not a class declaration
\begin{code}
stg2stg :: DynFlags -- includes spec of what stg-to-stg passes to do
-> Module -- module name (profiling only)
- -> UniqSupply -- a name supply
-> [StgBinding] -- input...
-> IO
([(StgBinding,[Id])], -- output program...
[CostCentre], -- "extern" cost-centres
[CostCentreStack])) -- pre-defined "singleton" cost centre stacks
-stg2stg dflags module_name us binds
+stg2stg dflags module_name binds
= do { showPass dflags "Stg2Stg"
; us <- mkSplitUniqSupply 'g'
mkVanillaId, idName, idDemandInfo, idArity, setIdType,
idFlavour
)
+import Module ( Module )
import IdInfo ( StrictnessInfo(..), IdFlavour(..) )
import DataCon ( dataConWrapId, dataConTyCon )
import TyCon ( isAlgTyCon )
import Demand ( Demand, isStrict, wwLazy )
-import Name ( setNameUnique )
+import Name ( setNameUnique, globaliseName, isLocalName )
import VarEnv
import PrimOp ( PrimOp(..), setCCallUnique )
import Type ( isUnLiftedType, isUnboxedTupleType, Type, splitFunTy_maybe,
uaUTy, usOnce, usMany, isTyVarTy
)
import UniqSupply -- all of it, really
-import BasicTypes ( TopLevelFlag(..), isNotTopLevel )
import UniqSet ( emptyUniqSet )
import ErrUtils ( showPass, dumpIfSet_dyn )
import CmdLineOpts ( DynFlags, DynFlag(..) )
in. (Pulling in a piece you don't need can be v bad, because it may
mention other pieces you don't need either, and so on.)
- Sadly, splitting up .hc files means that local names (like s234) are
- now globally visible, which can lead to clashes between two .hc
- files. So we make them all Global, so they are printed complete
- with their module name.
-
- We don't want to do this in CoreTidy, because at that stage we use
- Global to mean "external" and hence "should appear in interface files".
- This object-file splitting thing is a code generator matter that we
- don't want to pollute earlier phases.
+ Sadly, splitting up .hc files means that local names (like s234) are
+ now globally visible, which can lead to clashes between two .hc
+ files. So we make them all Global, so they are printed complete
+ with their module name.
+
+ We don't want to do this in CoreTidy, because at that stage we use
+ Global to mean "external" and hence "should appear in interface files".
+ This object-file splitting thing is a code generator matter that we
+ don't want to pollute earlier phases.
NOTE THAT:
\end{code}
\begin{code}
-topCoreBindsToStg :: DynFlags -> [CoreBind] -> IO [StgBinding]
-topCoreBindsToStg dflags core_binds
+topCoreBindsToStg :: DynFlags -> Module -> [CoreBind] -> IO [StgBinding]
+topCoreBindsToStg dflags mod core_binds
= do showPass dflags "Core2Stg"
us <- mkSplitUniqSupply 'c'
return (initUs_ us (coreBindsToStg emptyVarEnv core_binds))
where
+ top_flag = Top mod
+
coreBindsToStg :: StgEnv -> [CoreBind] -> UniqSM [StgBinding]
coreBindsToStg env [] = returnUs []
coreBindsToStg env (b:bs)
- = coreBindToStg TopLevel env b `thenUs` \ (bind_spec, new_env) ->
+ = coreBindToStg top_flag env b `thenUs` \ (bind_spec, new_env) ->
coreBindsToStg new_env bs `thenUs` \ new_bs ->
case bind_spec of
NonRecF bndr rhs dem floats
ppr b ) -- No top-level cases!
mkStgBinds floats rhs `thenUs` \ new_rhs ->
- returnUs (StgNonRec bndr (exprToRhs dem TopLevel new_rhs)
+ returnUs (StgNonRec bndr (exprToRhs dem top_flag new_rhs)
: new_bs)
-- Keep all the floats inside...
-- Some might be cases etc
%************************************************************************
\begin{code}
-coreBindToStg :: TopLevelFlag -> StgEnv -> CoreBind -> UniqSM (StgFloatBind, StgEnv)
+coreBindToStg :: TopLvl -> StgEnv -> CoreBind -> UniqSM (StgFloatBind, StgEnv)
coreBindToStg top_lev env (NonRec binder rhs)
= coreExprToStgFloat env rhs `thenUs` \ (floats, stg_rhs) ->
-- But we don't want to discard exported things. They can
-- occur; e.g. an exported user binding f = g
- other -> newLocalId top_lev env binder `thenUs` \ (new_env, new_binder) ->
+ other -> newBinder top_lev env binder `thenUs` \ (new_env, new_binder) ->
returnUs (NonRecF new_binder stg_rhs dem floats, new_env)
where
dem = bdrDem binder
coreBindToStg top_lev env (Rec pairs)
- = newLocalIds top_lev env binders `thenUs` \ (env', binders') ->
+ = newBinders top_lev env binders `thenUs` \ (env', binders') ->
mapUs (do_rhs env') pairs `thenUs` \ stg_rhss ->
returnUs (RecF (binders' `zip` stg_rhss), env')
where
%************************************************************************
\begin{code}
-exprToRhs :: RhsDemand -> TopLevelFlag -> StgExpr -> StgRhs
+exprToRhs :: RhsDemand -> TopLvl -> StgExpr -> StgRhs
exprToRhs dem _ (StgLam _ bndrs body)
= ASSERT( not (null bndrs) )
StgRhsClosure noCCS
then be run at load time to fix up static closures.
-}
exprToRhs dem toplev (StgConApp con args)
- | isNotTopLevel toplev || not (isDllConApp con args)
+ | isNotTop toplev || not (isDllConApp con args)
-- isDllConApp checks for LitLit args too
= StgRhsCon noCCS con args
expr
where
upd = if isOnceDem dem
- then (if isNotTopLevel toplev
+ then (if isNotTop toplev
then SingleEntry -- HA! Paydirt for "dem"
else
#ifdef DEBUG
= returnUs ([], StgLit lit)
coreExprToStgFloat env (Let bind body)
- = coreBindToStg NotTopLevel env bind `thenUs` \ (new_bind, new_env) ->
+ = coreBindToStg NotTop env bind `thenUs` \ (new_bind, new_env) ->
coreExprToStgFloat new_env body `thenUs` \ (floats, stg_body) ->
returnUs (new_bind:floats, stg_body)
\end{code}
coreExprToStgFloat env body
else
-- At least some value binders
- newLocalIds NotTopLevel env id_binders `thenUs` \ (env', binders') ->
- coreExprToStgFloat env' body `thenUs` \ (floats, stg_body) ->
- mkStgBinds floats stg_body `thenUs` \ stg_body' ->
+ newLocalBinders env id_binders `thenUs` \ (env', binders') ->
+ coreExprToStgFloat env' body `thenUs` \ (floats, stg_body) ->
+ mkStgBinds floats stg_body `thenUs` \ stg_body' ->
case stg_body' of
StgLam ty lam_bndrs lam_body ->
\begin{code}
coreExprToStgFloat env (Case scrut bndr alts)
= coreExprToStgFloat env scrut `thenUs` \ (binds, scrut') ->
- newLocalId NotTopLevel env bndr `thenUs` \ (env', bndr') ->
+ newLocalBinder env bndr `thenUs` \ (env', bndr') ->
alts_to_stg env' (findDefault alts) `thenUs` \ alts' ->
mkStgCase scrut' bndr' alts' `thenUs` \ expr' ->
returnUs (binds, expr')
returnUs (mkStgAlgAlts scrut_ty alts' deflt')
alg_alt_to_stg env (DataAlt con, bs, rhs)
- = newLocalIds NotTopLevel env (filter isId bs) `thenUs` \ (env', stg_bs) ->
- coreExprToStg env' rhs `thenUs` \ stg_rhs ->
+ = newLocalBinders env (filter isId bs) `thenUs` \ (env', stg_bs) ->
+ coreExprToStg env' rhs `thenUs` \ stg_rhs ->
returnUs (con, stg_bs, [ True | b <- stg_bs ]{-bogus use mask-}, stg_rhs)
-- NB the filter isId. Some of the binders may be
-- existential type variables, which STG doesn't care about
\end{code}
\begin{code}
-newLocalId TopLevel env id
+----------------------------
+data TopLvl = Top Module | NotTop
+
+isNotTop NotTop = True
+isNotTop (Top _) = False
+
+----------------------------
+newBinder :: TopLvl -> StgEnv -> Id -> UniqSM (StgEnv, Id)
+newBinder (Top mod) env id = returnUs (env, newTopBinder mod id)
+newBinder NotTop env id = newLocalBinder env id
+
+newBinders (Top mod) env ids = returnUs (env, map (newTopBinder mod) ids)
+newBinders NotTop env ids = newLocalBinders env ids
+
+
+----------------------------
+newTopBinder mod id
-- Don't clone top-level binders. MkIface relies on their
-- uniques staying the same, so it can snaffle IdInfo off the
-- STG ids to put in interface files.
- = let
- name = idName id
- ty = idType id
- in
- name `seq`
+ = name' `seq`
seqType ty `seq`
- returnUs (env, mkVanillaId name ty)
-
-
-newLocalId NotTopLevel env id
+ mkVanillaId name' ty
+ where
+ name = idName id
+ name' | isLocalName name = globaliseName name mod
+ | otherwise = name
+ ty = idType id
+
+----------------------------
+newLocalBinder :: StgEnv -> Id -> UniqSM (StgEnv, Id)
+newLocalBinder env id
= -- Local binder, give it a new unique Id.
getUniqueUs `thenUs` \ uniq ->
let
seqType ty `seq`
returnUs (new_env, new_id)
-newLocalIds :: TopLevelFlag -> StgEnv -> [Id] -> UniqSM (StgEnv, [Id])
-newLocalIds top_lev env []
+----------------------------
+newLocalBinders :: StgEnv -> [Id] -> UniqSM (StgEnv, [Id])
+newLocalBinders env []
= returnUs (env, [])
-newLocalIds top_lev env (b:bs)
- = newLocalId top_lev env b `thenUs` \ (env', b') ->
- newLocalIds top_lev env' bs `thenUs` \ (env'', bs') ->
+newLocalBinders env (b:bs)
+ = newLocalBinder env b `thenUs` \ (env', b') ->
+ newLocalBinders env' bs `thenUs` \ (env'', bs') ->
returnUs (env'', b':bs')
\end{code}
= if is_strict then
-- Strict let with WHNF rhs
mkStgBinds floats $
- StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel rhs)) body
+ StgLet (StgNonRec bndr (exprToRhs dem NotTop rhs)) body
else
-- Lazy let with WHNF rhs; float until we find a strict binding
let
in
mkStgBinds floats_in rhs `thenUs` \ new_rhs ->
mkStgBinds floats_out $
- StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel new_rhs)) body
+ StgLet (StgNonRec bndr (exprToRhs dem NotTop new_rhs)) body
| otherwise -- Not WHNF
= if is_strict then
else
-- Lazy let with non-WHNF rhs, so keep the floats in the RHS
mkStgBinds floats rhs `thenUs` \ new_rhs ->
- returnUs (StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel new_rhs)) body)
+ returnUs (StgLet (StgNonRec bndr (exprToRhs dem NotTop new_rhs)) body)
where
bndr_rep_ty = repType (idType bndr)
import HsSyn ( TyClDecl(..), Sig(..), MonoBinds(..),
HsExpr(..), HsLit(..), HsType(..), HsPred(..),
mkSimpleMatch, andMonoBinds, andMonoBindList,
- isClassDecl, isClassOpSig, isPragSig,
- getClassDeclSysNames, tyClDeclName
+ isClassOpSig, isPragSig,
+ getClassDeclSysNames,
)
import BasicTypes ( TopLevelFlag(..), RecFlag(..) )
import RnHsSyn ( RenamedTyClDecl,
newDicts, newMethod )
import TcEnv ( TcId, TcEnv, RecTcEnv, TyThingDetails(..), tcAddImportedIdInfo,
tcLookupClass, tcExtendTyVarEnvForMeths, tcExtendGlobalTyVars,
- tcExtendLocalValEnv, tcExtendTyVarEnv, newDefaultMethodName
+ tcExtendLocalValEnv, tcExtendTyVarEnv
)
import TcBinds ( tcBindWithSigs, tcSpecSigs )
import TcMonoType ( tcHsRecType, tcRecClassContext, checkSigTyVars, checkAmbiguity, sigCtxt, mkTcSig )
import DataCon ( mkDataCon, notMarkedStrict )
import Id ( Id, idType, idName )
import Module ( Module )
-import Name ( Name, NamedThing(..), isFrom )
+import Name ( Name, NamedThing(..) )
import Name ( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, plusNameEnv, nameEnvElts )
import NameSet ( emptyNameSet )
import Outputable
import CmdLineOpts
import ErrUtils ( dumpIfSet )
import Util ( count )
-import Maybes ( seqMaybe, maybeToBool, orElse )
+import Maybes ( seqMaybe, maybeToBool )
\end{code}
tcClassDecl1 :: RecFlag -> RecTcEnv -> RenamedTyClDecl -> TcM (Name, TyThingDetails)
tcClassDecl1 is_rec rec_env
- (ClassDecl context class_name
- tyvar_names fundeps class_sigs def_methods
- sys_names src_loc)
+ (ClassDecl {tcdCtxt = context, tcdName = class_name,
+ tcdTyVars = tyvar_names, tcdFDs = fundeps,
+ tcdSigs = class_sigs, tcdMeths = def_methods,
+ tcdSysNames = sys_names, tcdLoc = src_loc})
= -- CHECK ARITY 1 FOR HASKELL 1.4
doptsTc Opt_GlasgowExts `thenTc` \ glaExts ->
checkTc (glaExts || length tyvar_names == 1)
in
tcExtendTyVarEnv tyvars $
- -- CHECK THAT THE DEFAULT BINDINGS ARE LEGAL
- checkDefaultBinds clas op_names def_methods `thenTc` \ dm_info ->
- checkGenericClassIsUnary clas dm_info `thenTc_`
+ -- SOURCE-CODE CONSISTENCY CHECKS
+ (case def_methods of
+ Nothing -> returnTc Nothing -- Not source
+ Just dms -> checkDefaultBinds clas op_names dms `thenTc` \ dm_env ->
+ checkGenericClassIsUnary clas dm_env `thenTc_`
+ returnTc (Just dm_env)
+ ) `thenTc` \ mb_dm_env ->
-- CHECK THE CONTEXT
tcSuperClasses is_rec clas context sc_sel_names `thenTc` \ (sc_theta, sc_sel_ids) ->
-- CHECK THE CLASS SIGNATURES,
- mapTc (tcClassSig is_rec rec_env clas tyvars dm_info) op_sigs `thenTc` \ sig_stuff ->
+ mapTc (tcClassSig is_rec rec_env clas tyvars mb_dm_env) op_sigs `thenTc` \ sig_stuff ->
-- MAKE THE CLASS DETAILS
let
\end{code}
\begin{code}
-checkDefaultBinds :: Class -> [Name] -> RenamedMonoBinds -> TcM (NameEnv (DefMeth Name))
+checkDefaultBinds :: Class -> [Name] -> RenamedMonoBinds
+ -> TcM (NameEnv Bool)
+ -- The returned environment says
+ -- x not in env => no default method
+ -- x -> True => generic default method
+ -- x -> False => polymorphic default method
+
-- Check default bindings
-- a) must be for a class op for this class
-- b) must be all generic or all non-generic
-- and return a mapping from class-op to DefMeth info
+ -- But do all this only for source binds
+
checkDefaultBinds clas ops EmptyMonoBinds = returnTc emptyNameEnv
checkDefaultBinds clas ops (AndMonoBinds b1 b2)
-- Check that all the defns ar generic, or none are
checkTc (all_generic || none_generic) (mixedGenericErr op) `thenTc_`
- -- Make up the right dm_info
- if all_generic then
- returnTc (unitNameEnv op GenDefMeth)
- else
- -- An explicit non-generic default method
- newDefaultMethodName op loc `thenNF_Tc` \ dm_name ->
- returnTc (unitNameEnv op (DefMeth dm_name))
-
+ returnTc (unitNameEnv op all_generic)
where
n_generic = count (maybeToBool . maybeGenericMatch) matches
none_generic = n_generic == 0
all_generic = n_generic == length matches
-checkGenericClassIsUnary clas dm_info
+checkGenericClassIsUnary clas dm_env
= -- Check that if the class has generic methods, then the
-- class has only one parameter. We can't do generic
-- multi-parameter type classes!
checkTc (unary || no_generics) (genericMultiParamErr clas)
where
unary = length (classTyVars clas) == 1
- no_generics = null [() | GenDefMeth <- nameEnvElts dm_info]
+ no_generics = not (or (nameEnvElts dm_env))
\end{code}
tcClassSig :: RecFlag -> RecTcEnv -- Knot tying only!
-> Class -- ...ditto...
-> [TyVar] -- The class type variable, used for error check only
- -> NameEnv (DefMeth Name) -- Info about default methods
+ -> Maybe (NameEnv Bool) -- Info about default methods
-> RenamedClassOpSig
-> TcM (Type, -- Type of the method
ClassOpItem) -- Selector Id, default-method Id, True if explicit default binding
-- so we distinguish them in checkDefaultBinds, and pass this knowledge in the
-- Class.DefMeth data structure.
-tcClassSig is_rec unf_env clas clas_tyvars dm_info
- (ClassOpSig op_name maybe_dm op_ty src_loc)
+tcClassSig is_rec unf_env clas clas_tyvars maybe_dm_env
+ (ClassOpSig op_name sig_dm op_ty src_loc)
= tcAddSrcLoc src_loc $
-- Check the type signature. NB that the envt *already has*
let
-- Build the selector id and default method id
- sel_id = mkDictSelId op_name clas
-
- dm_info_name = maybe_dm `orElse` lookupNameEnv dm_info op_name `orElse` NoDefMeth
-
- dm_info_id = case dm_info_name of
- NoDefMeth -> NoDefMeth
- GenDefMeth -> GenDefMeth
- DefMeth dm_name -> DefMeth (tcAddImportedIdInfo unf_env dm_id)
- where
- dm_id = mkDefaultMethodId dm_name clas global_ty
+ sel_id = mkDictSelId op_name clas
+ dm_id = mkDefaultMethodId dm_name clas global_ty
+ DefMeth dm_name = sig_dm
+
+ dm_info = case maybe_dm_env of
+ Nothing -> iface_dm_info
+ Just dm_env -> mk_src_dm_info dm_env
+
+ iface_dm_info = case sig_dm of
+ NoDefMeth -> NoDefMeth
+ GenDefMeth -> GenDefMeth
+ DefMeth dm_name -> DefMeth (tcAddImportedIdInfo unf_env dm_id)
+
+ mk_src_dm_info dm_env = case lookupNameEnv dm_env op_name of
+ Nothing -> NoDefMeth
+ Just True -> GenDefMeth
+ Just False -> DefMeth dm_id
in
-- Check that for a generic method, the type of
-- the method is sufficiently simple
- checkTc (dm_info_name /= GenDefMeth || validGenericMethodType local_ty)
+ checkTc (dm_info /= GenDefMeth || validGenericMethodType local_ty)
(badGenericMethodType op_name op_ty) `thenTc_`
- returnTc (local_ty, (sel_id, dm_info_id))
+ returnTc (local_ty, (sel_id, dm_info))
\end{code}
tcClassDecls2 this_mod decls
= foldr combine
(returnNF_Tc (emptyLIE, EmptyMonoBinds))
- [tcClassDecl2 cls_decl | cls_decl <- decls,
- isClassDecl cls_decl,
- isFrom this_mod (tyClDeclName cls_decl)]
+ [tcClassDecl2 cls_decl | cls_decl@(ClassDecl {tcdMeths = Just _}) <- decls]
+ -- The 'Just' picks out source ClassDecls
where
combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) ->
tc2 `thenNF_Tc` \ (lie2, binds2) ->
tcClassDecl2 :: RenamedTyClDecl -- The class declaration
-> NF_TcM (LIE, TcMonoBinds)
-tcClassDecl2 (ClassDecl context class_name
- tyvar_names _ sigs default_binds _ src_loc)
- = -- A locally defined class
+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 ->
-- Fish the "deriving"-related information out of the TcEnv
-- and make the necessary "equations".
- makeDerivEqns mod tycl_decls `thenTc` \ eqns ->
+ makeDerivEqns tycl_decls `thenTc` \ eqns ->
if null eqns then
returnTc ([], EmptyBinds)
else
all those.
\begin{code}
-makeDerivEqns :: Module -> [RenamedTyClDecl] -> TcM [DerivEqn]
+makeDerivEqns :: [RenamedTyClDecl] -> TcM [DerivEqn]
-makeDerivEqns this_mod tycl_decls
+makeDerivEqns tycl_decls
= mapTc mk_eqn derive_these `thenTc` \ maybe_eqns ->
returnTc (catMaybes maybe_eqns)
where
-- Find the (Class,TyCon) pairs that must be `derived'
-- NB: only source-language decls have deriving, no imported ones do
derive_these = [ (clas,tycon)
- | TyData _ _ tycon _ _ _ (Just classes) _ _ _ <- tycl_decls,
+ | TyData {tcdName = tycon, tcdDerivs = Just classes} <- tycl_decls,
clas <- nub classes ]
------------------------------------------------------------------
case chk_out clas tycon of
Just err -> addErrTc err `thenNF_Tc_`
returnNF_Tc Nothing
- Nothing -> newDFunName this_mod clas [ty] locn `thenNF_Tc` \ dfun_name ->
+ Nothing -> newDFunName clas [ty] locn `thenNF_Tc` \ dfun_name ->
returnNF_Tc (Just (dfun_name, clas, tycon, tyvars, constraints))
-- New Ids
newLocalId, newSpecPragmaId,
- newDefaultMethodName, newDFunName,
+ newDFunName,
-- Misc
isLocalThing, tcSetEnv
import Class ( Class, ClassOpItem, ClassContext )
import Subst ( substTy )
import Name ( Name, OccName, NamedThing(..),
- nameOccName, nameModule, getSrcLoc, mkGlobalName,
+ nameOccName, getSrcLoc, mkLocalName,
isLocalName, nameModule_maybe
)
import Name ( NameEnv, lookupNameEnv, nameEnvElts, extendNameEnvList, emptyNameEnv )
-import OccName ( mkDFunOcc, mkDefaultMethodOcc, occNameString )
+import OccName ( mkDFunOcc, occNameString )
import HscTypes ( DFunId, TypeEnv, HomeSymbolTable, PackageTypeEnv )
import Module ( Module )
import InstEnv ( InstEnv, emptyInstEnv )
returnNF_Tc (mkSpecPragmaId (nameOccName name) uniq ty (getSrcLoc name))
\end{code}
-Make a name for the dict fun for an instance decl
+Make a name for the dict fun for an instance decl.
+It's a *local* name for the moment. The CoreTidy pass
+will globalise it.
\begin{code}
-newDFunName :: Module -> Class -> [Type] -> SrcLoc -> NF_TcM Name
-newDFunName mod clas (ty:_) loc
- = tcGetDFunUniq dfun_string `thenNF_Tc` \ inst_uniq ->
- tcGetUnique `thenNF_Tc` \ uniq ->
- returnNF_Tc (mkGlobalName uniq mod
- (mkDFunOcc dfun_string inst_uniq)
- loc)
+newDFunName :: Class -> [Type] -> SrcLoc -> NF_TcM Name
+newDFunName clas (ty:_) loc
+ = tcGetUnique `thenNF_Tc` \ uniq ->
+ returnNF_Tc (mkLocalName uniq (mkDFunOcc dfun_string) loc)
where
-- Any string that is somewhat unique will do
dfun_string = occNameString (getOccName clas) ++ occNameString (getDFunTyKey ty)
-newDFunName mod clas [] loc = pprPanic "newDFunName" (ppr mod <+> ppr clas <+> ppr loc)
-
-newDefaultMethodName :: Name -> SrcLoc -> NF_TcM Name
-newDefaultMethodName op_name loc
- = tcGetUnique `thenNF_Tc` \ uniq ->
- returnNF_Tc (mkGlobalName uniq (nameModule op_name)
- (mkDefaultMethodOcc (getOccName op_name))
- loc)
+newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc)
\end{code}
\begin{code}
tcInterfaceSigs unf_env decls
= listTc [ do_one name ty id_infos src_loc
- | IfaceSig name ty id_infos src_loc <- decls]
+ | IfaceSig {tcdName = name, tcdType = ty, tcdIdInfo = id_infos, tcdLoc =src_loc} <- decls]
where
in_scope_vars = [] -- I think this will be OK
clas_decls = filter isClassDecl tycl_decls
in
-- (1) Do the ordinary instance declarations
- mapNF_Tc (tcInstDecl1 mod unf_env) inst_decls `thenNF_Tc` \ inst_infos ->
+ mapNF_Tc (tcInstDecl1 unf_env) inst_decls `thenNF_Tc` \ inst_infos ->
-- (2) Instances from generic class declarations
- getGenericInstances mod clas_decls `thenTc` \ generic_inst_info ->
+ getGenericInstances clas_decls `thenTc` \ generic_inst_info ->
-- Next, construct the instance environment so far, consisting of
-- a) cached non-home-package InstEnv (gotten from pcs) pcs_insts pcs
\end{code}
\begin{code}
-tcInstDecl1 :: Module -> TcEnv -> RenamedInstDecl -> NF_TcM [InstInfo]
+tcInstDecl1 :: TcEnv -> RenamedInstDecl -> NF_TcM [InstInfo]
-- Deal with a single instance declaration
-tcInstDecl1 mod unf_env (InstDecl poly_ty binds uprags maybe_dfun_name src_loc)
+tcInstDecl1 unf_env (InstDecl poly_ty binds uprags maybe_dfun_name src_loc)
= -- Prime error recovery, set source location
recoverNF_Tc (returnNF_Tc []) $
tcAddSrcLoc src_loc $
mapNF_Tc scrutiniseInstanceConstraint theta `thenNF_Tc_`
-- Make the dfun id and return it
- newDFunName mod clas inst_tys src_loc `thenNF_Tc` \ dfun_name ->
+ newDFunName clas inst_tys src_loc `thenNF_Tc` \ dfun_name ->
returnNF_Tc (True, dfun_name)
Just dfun_name -> -- An interface-file instance declaration
\begin{code}
-getGenericInstances :: Module -> [RenamedTyClDecl] -> TcM [InstInfo]
-getGenericInstances mod class_decls
- = mapTc (get_generics mod) class_decls `thenTc` \ gen_inst_infos ->
+getGenericInstances :: [RenamedTyClDecl] -> TcM [InstInfo]
+getGenericInstances class_decls
+ = mapTc get_generics class_decls `thenTc` \ gen_inst_infos ->
let
gen_inst_info = concat gen_inst_infos
in
`thenNF_Tc_`
returnTc gen_inst_info
-get_generics mod decl@(ClassDecl context class_name tyvar_names
- fundeps class_sigs def_methods
- name_list loc)
+get_generics decl@(ClassDecl {tcdMeths = Nothing})
+ = returnTc [] -- 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, or
- -- its an imported class decl (=> has no methods at all)
+ = returnTc [] -- The comon case: no generic default methods
| otherwise -- A local class decl with generic default methods
= recoverNF_Tc (returnNF_Tc []) $
tcLookupClass class_name `thenTc` \ clas ->
-- Make an InstInfo out of each group
- mapTc (mkGenericInstance mod clas loc) groups `thenTc` \ inst_infos ->
+ mapTc (mkGenericInstance clas loc) groups `thenTc` \ inst_infos ->
-- Check that there is only one InstInfo for each type constructor
-- The main way this can fail is if you write
wrap ms = FunMonoBind id infixop ms loc
---------------------------------
-mkGenericInstance :: Module -> Class -> SrcLoc
+mkGenericInstance :: Class -> SrcLoc
-> (RenamedHsType, RenamedMonoBinds)
-> TcM InstInfo
-mkGenericInstance mod clas loc (hs_ty, binds)
+mkGenericInstance clas loc (hs_ty, binds)
-- Make a generic instance declaration
-- For example: instance (C a, C b) => C (a+b) where { binds }
(badGenericInstanceType binds) `thenTc_`
-- Make the dictionary function.
- newDFunName mod clas [inst_ty] loc `thenNF_Tc` \ dfun_name ->
+ newDFunName clas [inst_ty] loc `thenNF_Tc` \ dfun_name ->
let
inst_theta = [mkClassPred clas [mkTyVarTy tv] | tv <- tyvars]
inst_tys = [inst_ty]
\begin{code}
tcAddDeclCtxt decl thing_inside
- = tcAddSrcLoc loc $
+ = tcAddSrcLoc (tcdLoc decl) $
tcAddErrCtxt ctxt $
thing_inside
where
- (name, loc, thing)
- = case decl of
- (ClassDecl _ name _ _ _ _ _ loc) -> (name, loc, "class")
- (TySynonym name _ _ loc) -> (name, loc, "type synonym")
- (TyData NewType _ name _ _ _ _ loc _ _) -> (name, loc, "newtype")
- (TyData DataType _ name _ _ _ _ loc _ _) -> (name, loc, "data type")
+ thing = case decl of
+ ClassDecl {} -> "class"
+ TySynonym {} -> "type synonym"
+ TyData {tcdND = NewType} -> "newtype"
+ TyData {tcdND = DataType} -> "data type"
ctxt = hsep [ptext SLIT("In the"), text thing,
- ptext SLIT("declaration for"), quotes (ppr name)]
+ ptext SLIT("declaration for"), quotes (ppr (tcdName decl))]
\end{code}
\begin{code}
import TcClassDcl ( tcClassDecls2 )
import TcDefaults ( tcDefaults, defaultDefaultTys )
import TcExpr ( tcMonoExpr )
-import TcEnv ( TcEnv, InstInfo(iDFunId), tcExtendGlobalValEnv,
+import TcEnv ( TcEnv, InstInfo, tcExtendGlobalValEnv,
isLocalThing, tcSetEnv, tcSetInstEnv, initTcEnv, getTcGEnv
)
import TcRules ( tcIfaceRules, tcSourceRules )
import Bag ( isEmptyBag )
import Outputable
import HscTypes ( PersistentCompilerState(..), HomeSymbolTable,
- PackageTypeEnv, DFunId, ModIface(..),
+ PackageTypeEnv, ModIface(..),
TypeEnv, extendTypeEnvList,
TyThing(..), implicitTyThingIds,
mkTypeEnv
= TcResults {
-- All these fields have info *just for this module*
tc_env :: TypeEnv, -- The top level TypeEnv
- tc_insts :: [DFunId], -- Instances
tc_binds :: TypecheckedMonoBinds, -- Bindings
tc_fords :: [TypecheckedForeignDecl], -- Foreign import & exports.
tc_rules :: [TypecheckedRuleDecl] -- Transformation rules
returnTc (new_pcs,
TcResults { tc_env = local_type_env,
tc_binds = implicit_binds `AndMonoBinds` all_binds',
- tc_insts = map iDFunId local_inst_info,
tc_fords = foi_decls ++ foe_decls',
tc_rules = all_local_rules
}
tcGetEnv, tcSetEnv,
tcGetDefaultTys, tcSetDefaultTys,
- tcGetUnique, tcGetUniques, tcGetDFunUniq,
+ tcGetUnique, tcGetUniques,
doptsTc, getDOptsTc,
tcAddSrcLoc, tcGetSrcLoc, tcGetInstLoc,
splitUniqSupply, mkSplitUniqSupply,
UniqSM, initUs_ )
import SrcLoc ( SrcLoc, noSrcLoc )
-import FiniteMap ( FiniteMap, lookupFM, addToFM, emptyFM )
import UniqFM ( emptyUFM )
import Unique ( Unique )
import CmdLineOpts
= do {
us <- mkSplitUniqSupply 'a' ;
us_var <- newIORef us ;
- dfun_var <- newIORef emptyFM ;
errs_var <- newIORef (emptyBag,emptyBag) ;
tvs_var <- newIORef emptyUFM ;
let
- init_down = TcDown dflags [] us_var dfun_var
- noSrcLoc
- [] errs_var
+ 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 ;
\begin{code}
forkNF_Tc :: NF_TcM r -> NF_TcM r
-forkNF_Tc m (TcDown dflags deflts u_var df_var src_loc err_cxt err_var) env
+forkNF_Tc m down@(TcDown { tc_us = u_var }) env
= do
-- Get a fresh unique supply
us <- readIORef u_var
unsafeInterleaveIO (do {
us_var' <- newIORef us2 ;
err_var' <- newIORef (emptyBag,emptyBag) ;
- tv_var' <- newIORef emptyUFM ;
- let { down' = TcDown dflags deflts us_var' df_var src_loc err_cxt err_var' } ;
+ let { down' = down { tc_us = us_var', tc_errs = err_var' } };
m down' env
-- ToDo: optionally dump any error messages
})
\end{code}
-\begin{code}
-tcGetDFunUniq :: String -> NF_TcM Int
-tcGetDFunUniq key down env
- = do dfun_supply <- readIORef d_var
- let uniq = case lookupFM dfun_supply key of
- Just x -> x+1
- Nothing -> 0
- let dfun_supply' = addToFM dfun_supply key uniq
- writeIORef d_var dfun_supply'
- return uniq
- where
- d_var = getDFunSupplyVar down
-\end{code}
-
%************************************************************************
%* *
= TcDown {
tc_dflags :: DynFlags,
tc_def :: [Type], -- Types used for defaulting
-
tc_us :: (TcRef UniqSupply), -- Unique supply
- tc_ds :: (TcRef DFunNameSupply), -- Name supply for
- -- dictionary function names
-
tc_loc :: SrcLoc, -- Source location
tc_ctxt :: ErrCtxt, -- Error context
tc_errs :: (TcRef (Bag WarnMsg, Bag ErrMsg))
-- Innermost first. Monadic so that we have a chance
-- to deal with bound type variables just before error
-- message construction
-
-type DFunNameSupply = FiniteMap String Int
- -- This is used as a name supply for dictionary functions
- -- From the inst decl we derive a string, usually by glomming together
- -- the class and tycon name -- but it doesn't matter exactly how;
- -- this map then gives a unique int for each inst decl with that
- -- string. (In Haskell 98 there can only be one,
- -- but not so in more extended versions; also class CC type T
- -- and class C type TT might both give the string CCT
- --
- -- We could just use one Int for all the instance decls, but this
- -- way the uniques change less when you add an instance decl,
- -- hence less recompilation
\end{code}
-- These selectors are *local* to TcMonad.lhs
setLoc down loc = down{tc_loc=loc}
getUniqSupplyVar (TcDown{tc_us=us}) = us
-getDFunSupplyVar (TcDown{tc_ds=ds}) = ds
getErrCtxt (TcDown{tc_ctxt=ctxt}) = ctxt
setErrCtxt down msg = down{tc_ctxt=[msg]}
#include "HsVersions.h"
import CmdLineOpts ( DynFlags, DynFlag(..), dopt )
-import HsSyn ( TyClDecl(..), HsTyVarBndr,
+import HsSyn ( TyClDecl(..),
ConDecl(..), Sig(..), HsPred(..),
tyClDeclName, hsTyVarNames,
isIfaceSigDecl, isClassDecl, isSynDecl, isClassOpSig
import TcUnify ( unifyKind )
import TcInstDcls ( tcAddDeclCtxt )
-import Type ( Kind, mkArrowKind, boxedTypeKind, zipFunTys )
+import Type ( Kind, mkArrowKind, zipFunTys )
import Variance ( calcTyConArgVrcs )
import Class ( Class, mkClass, classTyCon )
import TyCon ( TyCon, tyConKind, ArgVrcs, AlgTyConFlavour(..),
\begin{code}
getInitialKind :: RenamedTyClDecl -> NF_TcM (Name, TcKind)
-getInitialKind (TySynonym name tyvars _ _)
- = kcHsTyVars tyvars `thenNF_Tc` \ arg_kinds ->
- newKindVar `thenNF_Tc` \ result_kind ->
- returnNF_Tc (name, mk_kind arg_kinds result_kind)
-
-getInitialKind (TyData _ _ name tyvars _ _ _ _ _ _)
- = kcHsTyVars tyvars `thenNF_Tc` \ arg_kinds ->
- returnNF_Tc (name, mk_kind arg_kinds boxedTypeKind)
-
-getInitialKind (ClassDecl _ name tyvars _ _ _ _ _ )
- = kcHsTyVars tyvars `thenNF_Tc` \ arg_kinds ->
- returnNF_Tc (name, mk_kind arg_kinds boxedTypeKind)
+getInitialKind decl
+ = kcHsTyVars (tcdTyVars decl) `thenNF_Tc` \ arg_kinds ->
+ newKindVar `thenNF_Tc` \ result_kind ->
+ returnNF_Tc (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}
\begin{code}
kcTyClDecl :: RenamedTyClDecl -> TcM ()
-kcTyClDecl decl@(TySynonym tycon_name hs_tyvars rhs loc)
- = tcAddDeclCtxt decl $
- kcTyClDeclBody tycon_name hs_tyvars $ \ result_kind ->
- kcHsType rhs `thenTc` \ rhs_kind ->
+kcTyClDecl decl@(TySynonym {tcdSynRhs = rhs})
+ = kcTyClDeclBody decl $ \ result_kind ->
+ kcHsType rhs `thenTc` \ rhs_kind ->
unifyKind result_kind rhs_kind
-kcTyClDecl decl@(TyData new_or_data context tycon_name hs_tyvars con_decls _ _ loc _ _)
- = tcAddDeclCtxt decl $
- kcTyClDeclBody tycon_name hs_tyvars $ \ result_kind ->
+kcTyClDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = context, tcdCons = con_decls})
+ = kcTyClDeclBody decl $ \ result_kind ->
kcHsContext context `thenTc_`
mapTc_ kc_con_decl con_decls
where
kc_con_decl (ConDecl _ _ ex_tvs ex_ctxt details loc)
- = tcAddSrcLoc loc $
- kcHsTyVars ex_tvs `thenNF_Tc` \ kind_env ->
+ = kcHsTyVars ex_tvs `thenNF_Tc` \ kind_env ->
tcExtendKindEnv kind_env $
kcConDetails new_or_data ex_ctxt details
-kcTyClDecl decl@(ClassDecl context class_name
- hs_tyvars fundeps class_sigs
- _ _ loc)
- = tcAddDeclCtxt decl $
- kcTyClDeclBody class_name hs_tyvars $ \ result_kind ->
- kcHsContext context `thenTc_`
+kcTyClDecl decl@(ClassDecl {tcdCtxt = context, tcdSigs = class_sigs})
+ = kcTyClDeclBody decl $ \ result_kind ->
+ kcHsContext context `thenTc_`
mapTc_ kc_sig (filter isClassOpSig class_sigs)
where
- kc_sig (ClassOpSig _ _ op_ty loc) = tcAddSrcLoc loc (kcHsBoxedSigType op_ty)
+ kc_sig (ClassOpSig _ _ op_ty loc) = kcHsBoxedSigType op_ty
-kcTyClDeclBody :: Name -> [HsTyVarBndr Name] -- Kind of the tycon/cls and its tyvars
- -> (Kind -> TcM a) -- Thing inside
- -> TcM a
+kcTyClDeclBody :: RenamedTyClDecl -> (Kind -> TcM a) -> TcM a
-- Extend the env with bindings for the tyvars, taken from
-- the kind of the tycon/class. Give it to the thing inside, and
-- check the result kind matches
-kcTyClDeclBody tc_name hs_tyvars thing_inside
- = tcLookup tc_name `thenNF_Tc` \ thing ->
+kcTyClDeclBody decl thing_inside
+ = tcAddDeclCtxt decl $
+ tcLookup (tcdName decl) `thenNF_Tc` \ thing ->
let
kind = case thing of
AGlobal (ATyCon tc) -> tyConKind tc
AThing kind -> kind
-- For some odd reason, a class doesn't include its kind
- (tyvars_w_kinds, result_kind) = zipFunTys (hsTyVarNames hs_tyvars) kind
+ (tyvars_w_kinds, result_kind) = zipFunTys (hsTyVarNames (tcdTyVars decl)) kind
in
tcExtendKindEnv tyvars_w_kinds (thing_inside result_kind)
\end{code}
-> RenamedTyClDecl -> TyThing
buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
- (TySynonym tycon_name tyvar_names rhs src_loc)
+ (TySynonym {tcdName = tycon_name, tcdTyVars = tyvar_names})
= ATyCon tycon
where
tycon = mkSynTyCon tycon_name tycon_kind arity tyvars rhs_ty argvrcs
argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
- (TyData data_or_new context tycon_name tyvar_names _ nconstrs _ src_loc name1 name2)
+ (TyData {tcdND = data_or_new, tcdName = tycon_name, tcdTyVars = tyvar_names,
+ tcdNCons = nconstrs, tcdSysNames = sys_names})
= ATyCon tycon
where
tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt argvrcs
flavour is_rec gen_info
gen_info | not (dopt Opt_Generics dflags) = Nothing
- | otherwise = mkTyConGenInfo tycon name1 name2
+ | otherwise = mkTyConGenInfo tycon sys_names
DataTyDetails ctxt data_cons sel_ids = lookupNameEnv_NF rec_details tycon_name
| otherwise -> DataTyCon
buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
- (ClassDecl context class_name
- tyvar_names fundeps class_sigs def_methods
- name_list src_loc)
+ (ClassDecl {tcdName = class_name, tcdTyVars = tyvar_names,
+ tcdFDs = fundeps, tcdSysNames = name_list} )
= AClass clas
where
(tycon_name, _, _, _) = getClassDeclSysNames name_list
mkClassEdges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Name, [Name])
-mkClassEdges decl@(ClassDecl ctxt name _ _ _ _ _ _) = Just (decl, name, [c | HsPClass c _ <- ctxt])
-mkClassEdges other_decl = Nothing
+mkClassEdges decl@(ClassDecl {tcdCtxt = ctxt, tcdName = name}) = Just (decl, name, [c | HsPClass c _ <- ctxt])
+mkClassEdges other_decl = Nothing
mkEdges :: RenamedTyClDecl -> (RenamedTyClDecl, Name, [Name])
mkEdges decl = (decl, tyClDeclName decl, tyClDeclFTVs decl)
\begin{code}
tcTyDecl1 :: RecFlag -> RecTcEnv -> RenamedTyClDecl -> TcM (Name, TyThingDetails)
-tcTyDecl1 is_rec unf_env (TySynonym tycon_name tyvar_names rhs src_loc)
+tcTyDecl1 is_rec unf_env (TySynonym {tcdName = tycon_name, tcdSynRhs = rhs})
= 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 unf_env (TyData new_or_data context tycon_name _ con_decls _ derivings src_loc name1 name2)
+tcTyDecl1 is_rec unf_env (TyData {tcdND = new_or_data, tcdCtxt = context,
+ tcdName = tycon_name, tcdCons = con_decls})
= tcLookupTyCon tycon_name `thenNF_Tc` \ tycon ->
let
tyvars = tyConTyVars tycon
__interface Generics 1 0 where
__export Generics mkTyConGenInfo ;
-2 mkTyConGenInfo :: TyCon.TyCon -> Name.Name -> Name.Name -> PrelMaybe.Maybe (BasicTypes.EP Var.Id) ;
+2 mkTyConGenInfo :: TyCon.TyCon -> [Name.Name] -> PrelMaybe.Maybe (BasicTypes.EP Var.Id) ;
%************************************************************************
\begin{code}
-mkTyConGenInfo :: TyCon -> Name -> Name -> Maybe (EP Id)
+mkTyConGenInfo :: TyCon -> [Name] -> Maybe (EP Id)
-- mkTyConGenInfo is called twice
-- once from TysWiredIn for Tuples
-- once the typechecker TcTyDecls
-- The two names are the names constructed by the renamer
-- for the fromT and toT conversion functions.
-mkTyConGenInfo tycon from_name to_name
+mkTyConGenInfo tycon [from_name, to_name]
| null datacons -- Abstractly imported types don't have
= Nothing -- to/from operations, (and should not need them)
projects / ghc-hetmet.git / commitdiff