Commit 837824d2 authored by simonpj's avatar simonpj

[project @ 2004-10-01 13:42:04 by simonpj]

------------------------------------
	Simplify the treatment of newtypes
	Complete hi-boot file consistency checking
	------------------------------------

In the representation of types, newtypes used to have a special constructor
all to themselves, very like TyConApp, called NewTcApp.    The trouble is
that means we have to *know* when a newtype is a newtype, and in an hi-boot
context we may not -- the data type might be declared as
	data T
in the hi-boot file, but as
	newtype T = ...
in the source file.  In GHCi, which accumulates stuff from multiple compiles,
this makes a difference.

So I've nuked NewTcApp.  Newtypes are represented using TyConApps again. This
turned out to reduce the total amount of code, and simplify the Type data type,
which is all to the good.


This commit also fixes a few things in the hi-boot consistency checking
stuff.
parent fadd15c6
......@@ -919,7 +919,6 @@ getTyDescription ty
TyVarTy _ -> "*"
AppTy fun _ -> getTyDescription fun
FunTy _ res -> '-' : '>' : fun_result res
NewTcApp tycon _ -> getOccString tycon
TyConApp tycon _ -> getOccString tycon
NoteTy (FTVNote _) ty -> getTyDescription ty
NoteTy (SynNote ty1) _ -> getTyDescription ty1
......
......@@ -186,7 +186,7 @@ make_ty (FunTy t1 t2) = make_ty (TyConApp funTyCon [t1,t2])
make_ty (ForAllTy tv t) = C.Tforall (make_tbind tv) (make_ty t)
make_ty (TyConApp tc ts) = foldl C.Tapp (C.Tcon (make_con_qid (tyConName tc)))
(map make_ty ts)
-- The special case for newtypes says "do not expand newtypes".
-- Newtypes are treated just like any other type constructor; not expanded
-- Reason: predTypeRep does substitution and, while substitution deals
-- correctly with name capture, it's only correct if you see the uniques!
-- If you just see occurrence names, name capture may occur.
......@@ -198,9 +198,6 @@ make_ty (TyConApp tc ts) = foldl C.Tapp (C.Tcon (make_con_qid (tyConName tc)))
-- expose the representation in interface files, which definitely isn't right.
-- Maybe CoreTidy should know whether to expand newtypes or not?
make_ty (NewTcApp tc ts) = foldl C.Tapp (C.Tcon (make_con_qid (tyConName tc)))
(map make_ty ts)
make_ty (PredTy p) = make_ty (predTypeRep p)
make_ty (NoteTy _ t) = make_ty t
......
......@@ -10,7 +10,7 @@ module Desugar ( deSugar, deSugarExpr ) where
import CmdLineOpts ( DynFlag(..), dopt, opt_SccProfilingOn )
import HscTypes ( ModGuts(..), ModGuts, HscEnv(..), GhciMode(..),
Dependencies(..), TypeEnv, unQualInScope )
Dependencies(..), TypeEnv, IsBootInterface, unQualInScope )
import HsSyn ( RuleDecl(..), RuleBndr(..), HsExpr(..), LHsExpr,
HsBindGroup(..), LRuleDecl, HsBind(..) )
import TcRnTypes ( TcGblEnv(..), ImportAvails(..) )
......@@ -26,7 +26,7 @@ import DsBinds ( dsHsBinds, AutoScc(..) )
import DsForeign ( dsForeigns )
import DsExpr () -- Forces DsExpr to be compiled; DsBinds only
-- depends on DsExpr.hi-boot.
import Module ( Module, moduleEnvElts )
import Module ( Module, ModuleName, moduleEnvElts, delModuleEnv, moduleNameFS )
import Id ( Id )
import RdrName ( GlobalRdrEnv )
import NameSet
......@@ -44,7 +44,7 @@ import UniqSupply ( mkSplitUniqSupply )
import SrcLoc ( Located(..), SrcSpan, unLoc )
import DATA_IOREF ( readIORef )
import FastString
import Data.List ( sort )
import Util ( sortLe )
\end{code}
%************************************************************************
......@@ -100,9 +100,20 @@ deSugar hsc_env
pkgs | th_used = insertList thPackage (imp_dep_pkgs imports)
| otherwise = imp_dep_pkgs imports
deps = Deps { dep_mods = moduleEnvElts (imp_dep_mods imports),
dep_pkgs = sort pkgs,
dep_orphs = sort (imp_orphs imports) }
mods = moduleEnvElts (delModuleEnv (imp_dep_mods imports) mod)
-- M.hi-boot can be in the imp_dep_mods, but we must remove
-- it before recording the modules on which this one depends!
-- ModuleNames don't compare lexicographically usually,
-- but we want them to do so here.
le_mod :: ModuleName -> ModuleName -> Bool
le_mod m1 m2 = moduleNameFS m1 <= moduleNameFS m2
le_dep_mod :: (ModuleName, IsBootInterface) -> (ModuleName, IsBootInterface) -> Bool
le_dep_mod (m1,_) (m2,_) = m1 `le_mod` m2
deps = Deps { dep_mods = sortLe le_dep_mod mods,
dep_pkgs = sortLe (<=) pkgs,
dep_orphs = sortLe le_mod (imp_orphs imports) }
-- sort to get into canonical order
mod_guts = ModGuts {
......
......@@ -78,8 +78,8 @@ dsForeigns fos
combine (ForeignStubs acc_h acc_c acc_hdrs acc_feb, acc_f)
(L loc (ForeignImport id _ spec depr))
= traceIf (text "fi start" <+> ppr id) `thenDs` \ _ ->
dsFImport (unLoc id) spec `thenDs` \ (bs, h, c, mbhd) ->
warnDepr depr loc `thenDs` \ _ ->
dsFImport (unLoc id) spec `thenDs` \ (bs, h, c, mbhd) ->
warnDepr depr loc `thenDs` \ _ ->
traceIf (text "fi end" <+> ppr id) `thenDs` \ _ ->
returnDs (ForeignStubs (h $$ acc_h)
(c $$ acc_c)
......
......@@ -283,13 +283,14 @@ repC (L loc con_decl)
-- gaw 2004 FIX! Need a case for GadtDecl
repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))
repBangTy (L _ (HsBangTy str ty)) = do
MkC s <- rep2 strName []
MkC t <- repLTy ty
repBangTy ty= do
MkC s <- rep2 str []
MkC t <- repLTy ty'
rep2 strictTypeName [s, t]
where strName = case str of
HsNoBang -> notStrictName
other -> isStrictName
where
(str, ty') = case ty of
L _ (HsBangTy _ ty) -> (isStrictName, ty)
other -> (notStrictName, ty)
-------------------------------------------------------
-- Deriving clause
......
......@@ -2,5 +2,5 @@ __interface Match 1 0 where
__export Match match matchExport matchSimply matchSinglePat;
1 match :: [Var.Id] -> [DsUtils.EquationInfo] -> DsMonad.DsM DsUtils.MatchResult ;
1 matchExport :: [Var.Id] -> [DsUtils.EquationInfo] -> DsMonad.DsM DsUtils.MatchResult ;
1 matchSimply :: CoreSyn.CoreExpr -> HsExpr.HsMatchContext Var.Id -> HsPat.LPat Var.Id -> CoreSyn.CoreExpr -> CoreSyn.CoreExpr -> DsMonad.DsM CoreSyn.CoreExpr ;
1 matchSimply :: CoreSyn.CoreExpr -> HsExpr.HsMatchContext Name.Name -> HsPat.LPat Var.Id -> CoreSyn.CoreExpr -> CoreSyn.CoreExpr -> DsMonad.DsM CoreSyn.CoreExpr ;
1 matchSinglePat :: CoreSyn.CoreExpr -> DsMonad.DsMatchContext -> HsPat.LPat Var.Id -> DsUtils.MatchResult -> DsMonad.DsM DsUtils.MatchResult ;
......@@ -12,7 +12,7 @@ matchWrapper
matchSimply
:: CoreSyn.CoreExpr
-> HsExpr.HsMatchContext Var.Id
-> HsExpr.HsMatchContext Name.Name
-> HsPat.LPat Var.Id
-> CoreSyn.CoreExpr
-> CoreSyn.CoreExpr
......
......@@ -311,7 +311,6 @@ toIfaceType :: (Name -> IfaceExtName) -> Type -> IfaceType
toIfaceType ext (TyVarTy tv) = IfaceTyVar (getOccName tv)
toIfaceType ext (AppTy t1 t2) = IfaceAppTy (toIfaceType ext t1) (toIfaceType ext t2)
toIfaceType ext (FunTy t1 t2) = IfaceFunTy (toIfaceType ext t1) (toIfaceType ext t2)
toIfaceType ext (NewTcApp tc tys) = IfaceTyConApp (mkIfaceTc ext tc) (toIfaceTypes ext tys)
toIfaceType ext (TyConApp tc tys) = IfaceTyConApp (mkIfaceTc ext tc) (toIfaceTypes ext tys)
toIfaceType ext (ForAllTy tv t) = IfaceForAllTy (toIfaceTvBndr tv) (toIfaceType ext t)
toIfaceType ext (PredTy st) = IfacePredTy (toIfacePred ext st)
......
......@@ -25,12 +25,12 @@ import Parser ( parseIface )
import IfaceSyn ( IfaceDecl(..), IfaceConDecl(..), IfaceClassOp(..), IfaceConDecls(..),
IfaceInst(..), IfaceRule(..), IfaceExpr(..), IfaceTyCon(..), IfaceIdInfo(..),
IfaceType(..), IfacePredType(..), IfaceExtName, mkIfaceExtName )
import IfaceEnv ( newGlobalBinder, lookupIfaceExt, lookupIfaceTc )
import IfaceEnv ( newGlobalBinder, lookupIfaceExt, lookupIfaceTc, lookupOrig )
import HscTypes ( ModIface(..), TyThing, emptyModIface, EpsStats(..), addEpsInStats,
ExternalPackageState(..), PackageTypeEnv, emptyTypeEnv,
lookupIfaceByModName, emptyPackageIfaceTable,
IsBootInterface, mkIfaceFixCache, Gated, implicitTyThings,
addRulesToPool, addInstsToPool
addRulesToPool, addInstsToPool, availNames
)
import BasicTypes ( Version, Fixity(..), FixityDirection(..), isMarkedStrict )
......@@ -100,27 +100,32 @@ loadSrcInterface doc mod_name want_boot
elaborate err = hang (ptext SLIT("Failed to load interface for") <+>
quotes (ppr mod_name) <> colon) 4 err
loadHiBootInterface :: TcRn (Maybe ModIface)
loadHiBootInterface :: TcRn [Name]
-- Load the hi-boot iface for the module being compiled,
-- if it indeed exists in the transitive closure of imports
-- Return the list of names exported by the hi-boot file
loadHiBootInterface
= do { eps <- getEps
; mod <- getModule
-- We're read all the direct imports by now, so eps_is_boot will
-- record if any of our imports mention us by way of hi-boot file
; case lookupModuleEnv (eps_is_boot eps) mod of
Nothing -> return Nothing -- The typical case
Just (mod_nm, True) -> -- There's a hi-boot interface below us
-- Load it (into the PTE), and return its interface
do { iface <- loadSrcInterface (mk_doc mod_nm) mod_nm True
; return (Just iface) }
; case lookupModuleEnv (eps_is_boot eps) mod of {
Nothing -> return [] ; -- The typical case
Just (_, False) -> -- Someone below us imported us!
-- This is a loop with no hi-boot in the way
failWithTc (moduleLoop mod)
}
failWithTc (moduleLoop mod) ;
Just (mod_nm, True) -> -- There's a hi-boot interface below us
do { -- Load it (into the PTE, and return the exported names
iface <- loadSrcInterface (mk_doc mod_nm) mod_nm True
; sequenceM [ lookupOrig mod_nm occ
| (mod,avails) <- mi_exports iface,
avail <- avails, occ <- availNames avail]
}}}
where
mk_doc mod = ptext SLIT("Need the hi-boot interface for") <+> ppr mod
<+> ptext SLIT("to compare against the Real Thing")
......
......@@ -482,8 +482,8 @@ addVersionInfo (Just old_iface@(ModIface { mi_mod_vers = old_mod_vers,
no_deprec_change = mi_deprecs new_iface == mi_deprecs old_iface
-- If the usages havn't changed either, we don't need to write the interface file
-- Question: should we also check for equality of mi_deps?
no_other_changes = mi_usages new_iface == mi_usages old_iface
no_other_changes = mi_usages new_iface == mi_usages old_iface &&
mi_deps new_iface == mi_deps old_iface
no_change_at_all = no_output_change && no_other_changes
pp_diffs = vcat [pp_change no_export_change "Export list"
......
......@@ -665,6 +665,8 @@ data Dependencies
= Deps { dep_mods :: [(ModuleName,IsBootInterface)], -- Home-package module dependencies
dep_pkgs :: [PackageName], -- External package dependencies
dep_orphs :: [ModuleName] } -- Orphan modules (whether home or external pkg)
deriving( Eq )
-- Equality used only for old/new comparison in MkIface.addVersionInfo
noDependencies :: Dependencies
noDependencies = Deps [] [] []
......
......@@ -257,7 +257,7 @@ hsIfaceDecl (TyClD decl@(TyData {}))
= IfaceData { ifName = rdrNameOcc (tcdName decl),
ifTyVars = tvs,
ifCons = hsIfaceCons tvs decl,
ifRec = NonRecursive,
ifRec = Recursive, -- Hi-boot decls are always loop-breakers
ifVrcs = [], ifGeneric = False }
-- I'm not sure that [] is right for ifVrcs, but
-- since we don't use them I'm not going to fiddle
......
......@@ -213,8 +213,6 @@ importsFromImportDecl this_mod
ASSERT( not (mi_package iface `elem` dep_pkgs deps) )
([], mi_package iface : dep_pkgs deps)
not_self (m, _) = m /= this_mod_name
import_all = case imp_details of
Just (is_hiding, ls) -- Imports are spec'd explicitly
| not is_hiding -> Just (not (null ls))
......
......@@ -486,9 +486,6 @@ zonkType unbound_var_fn rflag ty
go (TyConApp tycon tys) = mappM go tys `thenM` \ tys' ->
returnM (TyConApp tycon tys')
go (NewTcApp tycon tys) = mappM go tys `thenM` \ tys' ->
returnM (NewTcApp tycon tys')
go (NoteTy (SynNote ty1) ty2) = go ty1 `thenM` \ ty1' ->
go ty2 `thenM` \ ty2' ->
returnM (NoteTy (SynNote ty1') ty2')
......@@ -802,9 +799,6 @@ check_tau_type rank ubx_tup (NoteTy (SynNote syn) ty)
check_tau_type rank ubx_tup (NoteTy other_note ty)
= check_tau_type rank ubx_tup ty
check_tau_type rank ubx_tup (NewTcApp tc tys)
= mappM_ check_arg_type tys
check_tau_type rank ubx_tup ty@(TyConApp tc tys)
| isSynTyCon tc
= -- NB: Type.mkSynTy builds a TyConApp (not a NoteTy) for an unsaturated
......
......@@ -52,6 +52,7 @@ import RnEnv ( lookupSrcOcc_maybe )
import RnSource ( rnSrcDecls, rnTyClDecls, checkModDeprec )
import PprCore ( pprIdRules, pprCoreBindings )
import CoreSyn ( IdCoreRule, bindersOfBinds )
import DataCon ( dataConWrapId )
import ErrUtils ( Messages, mkDumpDoc, showPass )
import Id ( mkExportedLocalId, isLocalId, idName, idType )
import Var ( Var )
......@@ -266,7 +267,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
-- Typecheck them all together so that
-- any mutually recursive types are done right
tcg_env <- checkNoErrs (tcTyAndClassDecls rn_decls) ;
tcg_env <- checkNoErrs (tcTyAndClassDecls [{- no boot names -}] rn_decls) ;
-- Make the new type env available to stuff slurped from interface files
setGblEnv tcg_env $ do {
......@@ -323,10 +324,10 @@ tcRnSrcDecls :: [LHsDecl RdrName] -> TcM TcGblEnv
-- Returns the variables free in the decls
-- Reason: solely to report unused imports and bindings
tcRnSrcDecls decls
= do { mb_boot_iface <- loadHiBootInterface ;
= do { boot_names <- loadHiBootInterface ;
-- Do all the declarations
(tc_envs, lie) <- getLIE (tc_rn_src_decls decls) ;
(tc_envs, lie) <- getLIE (tc_rn_src_decls boot_names decls) ;
-- tcSimplifyTop deals with constant or ambiguous InstIds.
-- How could there be ambiguous ones? They can only arise if a
......@@ -353,7 +354,7 @@ tcRnSrcDecls decls
let { final_type_env = extendTypeEnvWithIds type_env bind_ids } ;
-- Compre the hi-boot iface (if any) with the real thing
checkHiBootIface final_type_env mb_boot_iface ;
checkHiBootIface final_type_env boot_names ;
-- Make the new type env available to stuff slurped from interface files
writeMutVar (tcg_type_env_var tcg_env) final_type_env ;
......@@ -362,15 +363,15 @@ tcRnSrcDecls decls
tcg_binds = binds', tcg_rules = rules', tcg_fords = fords' })
}
tc_rn_src_decls :: [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv)
tc_rn_src_decls :: [Name] -> [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv)
-- Loops around dealing with each top level inter-splice group
-- in turn, until it's dealt with the entire module
tc_rn_src_decls ds
tc_rn_src_decls boot_names ds
= do { let { (first_group, group_tail) = findSplice ds } ;
-- If ds is [] we get ([], Nothing)
-- Type check the decls up to, but not including, the first splice
tc_envs@(tcg_env,tcl_env) <- tcRnGroup first_group ;
tc_envs@(tcg_env,tcl_env) <- tcRnGroup boot_names first_group ;
-- Bale out if errors; for example, error recovery when checking
-- the RHS of 'main' can mean that 'main' is not in the envt for
......@@ -401,7 +402,7 @@ tc_rn_src_decls ds
-- Glue them on the front of the remaining decls and loop
setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $
tc_rn_src_decls (spliced_decls ++ rest_ds)
tc_rn_src_decls boot_names (spliced_decls ++ rest_ds)
#endif /* GHCI */
}}}
\end{code}
......@@ -419,21 +420,15 @@ the hi-boot stuff in the EPT. We do so here, using the export list of
the hi-boot interface as our checklist.
\begin{code}
checkHiBootIface :: TypeEnv -> Maybe ModIface -> TcM ()
checkHiBootIface :: TypeEnv -> [Name] -> TcM ()
-- Compare the hi-boot file for this module (if there is one)
-- with the type environment we've just come up with
checkHiBootIface env Nothing -- No hi-boot
= return ()
checkHiBootIface env boot_names
= mapM_ (check_one env) boot_names
checkHiBootIface env (Just iface)
= mapM_ (check_one env) exports
where
exports = [ (mod, availName avail) | (mod,avails) <- mi_exports iface,
avail <- avails]
----------------
check_one local_env (mod,occ)
= do { name <- lookupOrig mod occ
; eps <- getEps
check_one local_env name
= do { eps <- getEps
-- Look up the hi-boot one;
-- it should jolly well be there (else GHC bug)
......@@ -464,6 +459,12 @@ check_thing (AnId boot_id) (AnId real_id)
| idType boot_id `tcEqType` idType real_id
= return ()
check_thing (ADataCon dc1) (ADataCon dc2)
| idType (dataConWrapId dc1) `tcEqType` idType (dataConWrapId dc2)
= return ()
-- Can't declare a class in a hi-boot file
check_thing boot_thing real_thing -- Default case; failure
= addErrAt (srcLocSpan (getSrcLoc real_thing))
(bootMisMatch real_thing)
......@@ -494,15 +495,15 @@ declarations. It expects there to be an incoming TcGblEnv in the
monad; it augments it and returns the new TcGblEnv.
\begin{code}
tcRnGroup :: HsGroup RdrName -> TcM (TcGblEnv, TcLclEnv)
tcRnGroup :: [Name] -> HsGroup RdrName -> TcM (TcGblEnv, TcLclEnv)
-- Returns the variables free in the decls, for unused-binding reporting
tcRnGroup decls
tcRnGroup boot_names decls
= do { -- Rename the declarations
(tcg_env, rn_decls) <- rnTopSrcDecls decls ;
setGblEnv tcg_env $ do {
-- Typecheck the declarations
tcTopSrcDecls rn_decls
tcTopSrcDecls boot_names rn_decls
}}
------------------------------------------------
......@@ -528,8 +529,8 @@ rnTopSrcDecls group
}}
------------------------------------------------
tcTopSrcDecls :: HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
tcTopSrcDecls
tcTopSrcDecls :: [Name] -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
tcTopSrcDecls boot_names
(HsGroup { hs_tyclds = tycl_decls,
hs_instds = inst_decls,
hs_fords = foreign_decls,
......@@ -540,7 +541,7 @@ tcTopSrcDecls
-- The latter come in via tycl_decls
traceTc (text "Tc2") ;
tcg_env <- checkNoErrs (tcTyAndClassDecls tycl_decls) ;
tcg_env <- checkNoErrs (tcTyAndClassDecls boot_names tycl_decls) ;
-- tcTyAndClassDecls recovers internally, but if anything gave rise to
-- an error we'd better stop now, to avoid a cascade
......
......@@ -5,7 +5,7 @@ tcSpliceExpr :: HsExpr.HsSplice Name.Name
-> TcRnTypes.TcM (HsExpr.HsExpr Var.Id)
kcSpliceType :: HsExpr.HsSplice Name.Name
-> TcRnTypes.TcM (HsType.HsType Name.Name, TcType.TcKind)
-> TcRnTypes.TcM (HsTypes.HsType Name.Name, TcType.TcKind)
tcBracket :: HsExpr.HsBracket Name.Name
-> TcUnify.Expected TcType.TcType
......
......@@ -140,7 +140,7 @@ tc_bracket (TypBr typ)
-- Result type is Type (= Q Typ)
tc_bracket (DecBr decls)
= tcTopSrcDecls decls `thenM_`
= tcTopSrcDecls [{- no boot-names -}] decls `thenM_`
-- Typecheck the declarations, dicarding the result
-- We'll get all that stuff later, when we splice it in
......@@ -618,7 +618,6 @@ reifyClass cls
reifyType :: TypeRep.Type -> TcM TH.Type
reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv))
reifyType (TyConApp tc tys) = reify_tc_app (reifyName tc) tys
reifyType (NewTcApp tc tys) = reify_tc_app (reifyName tc) tys
reifyType (NoteTy _ ty) = reifyType ty
reifyType (AppTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) }
reifyType (FunTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) }
......
......@@ -108,10 +108,10 @@ 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.
\begin{code}
tcTyAndClassDecls :: [LTyClDecl Name]
tcTyAndClassDecls :: [Name] -> [LTyClDecl Name]
-> TcM TcGblEnv -- Input env extended by types and classes
-- and their implicit Ids,DataCons
tcTyAndClassDecls decls
tcTyAndClassDecls boot_names decls
= do { -- First check for cyclic type synonysm or classes
-- See notes with checkCycleErrs
checkCycleErrs decls
......@@ -133,7 +133,7 @@ tcTyAndClassDecls decls
{ (kc_syn_decls, kc_alg_decls) <- kcTyClDecls syn_decls alg_decls
; let { calc_vrcs = calcTyConArgVrcs (rec_syn_tycons ++ rec_alg_tyclss)
; calc_rec = calcRecFlags rec_alg_tyclss
; calc_rec = calcRecFlags boot_names rec_alg_tyclss
; tc_decl = addLocM (tcTyClDecl calc_vrcs calc_rec) }
-- Type-check the type synonyms, and extend the envt
; syn_tycons <- tcSynDecls calc_vrcs kc_syn_decls
......
......@@ -95,7 +95,6 @@ synTyConsOfType ty
go :: Type -> NameEnv TyCon -- The NameEnv does duplicate elim
go (TyVarTy v) = emptyNameEnv
go (TyConApp tc tys) = go_tc tc tys -- See note (a)
go (NewTcApp tc tys) = go_s tys -- Ignore tycon
go (AppTy a b) = go a `plusNameEnv` go b
go (FunTy a b) = go a `plusNameEnv` go b
go (PredTy (IParam _ ty)) = go ty
......@@ -153,22 +152,34 @@ a "loop breaker". Labelling more than necessary as recursive is OK,
provided the invariant is maintained.
A newtype M.T is defined to be "recursive" iff
(a) its rhs mentions an abstract (hi-boot) TyCon
or (b) one can get from T's rhs to T via type
(a) it is declared in an hi-boot file (see RdrHsSyn.hsIfaceDecl)
(b) it is declared in a source file, but that source file has a
companion hi-boot file which declares the type
or (c) one can get from T's rhs to T via type
synonyms, or non-recursive newtypes *in M*
e.g. newtype T = MkT (T -> Int)
e.g. newtype T = MkT (T -> Int)
(a) is conservative; it assumes that the hi-boot type can loop
around to T. That's why in (b) we can restrict attention
(a) is conservative; declarations in hi-boot files are always
made loop breakers. That's why in (b) we can restrict attention
to tycons in M, because any loops through newtypes outside M
will be broken by those newtypes
(b) ensures that a newtype is not treated as a loop breaker in one place
and later as a non-loop-breaker. This matters in GHCi particularly, when
a newtype T might be embedded in many types in the environment, and then
T's source module is compiled. We don't want T's recursiveness to change.
The "recursive" flag for algebraic data types is irrelevant (never consulted)
for types with more than one constructor.
An algebraic data type M.T is "recursive" iff
it has just one constructor, and
(a) its arg types mention an abstract (hi-boot) TyCon
or (b) one can get from its arg types to T via type synonyms,
(a) it is declared in an hi-boot file (see RdrHsSyn.hsIfaceDecl)
(b) it is declared in a source file, but that source file has a
companion hi-boot file which declares the type
or (c) one can get from its arg types to T via type synonyms,
or by non-recursive newtypes or non-recursive product types in M
e.g. data T = MkT (T -> Int) Bool
e.g. data T = MkT (T -> Int) Bool
Just like newtype in fact
A type synonym is recursive if one can get from its
right hand side back to it via type synonyms. (This is
......@@ -202,17 +213,27 @@ recursiveness, because we need only look at the type decls in the module being
compiled, plus the outer structure of directly-mentioned types.
\begin{code}
calcRecFlags :: [TyThing] -> (Name -> RecFlag)
calcRecFlags tyclss
calcRecFlags :: [Name] -> [TyThing] -> (Name -> RecFlag)
-- The 'boot_names' are the things declared in M.hi-boot, if M is the current module.
-- Any type constructors in boot_names are automatically considered loop breakers
calcRecFlags boot_names tyclss
= is_rec
where
is_rec n | n `elemNameSet` rec_names = Recursive
| otherwise = NonRecursive
rec_names = nt_loop_breakers `unionNameSets` prod_loop_breakers
boot_name_set = mkNameSet boot_names
rec_names = boot_name_set `unionNameSets`
nt_loop_breakers `unionNameSets`
prod_loop_breakers
all_tycons = map getTyCon tyclss -- Recursion of newtypes/data types
-- can happen via the class TyCon
all_tycons = [ tc | tycls <- tyclss,
-- Recursion of newtypes/data types can happen via
-- the class TyCon, so tyclss includes the class tycons
let tc = getTyCon tycls,
not (tyConName tc `elemNameSet` boot_name_set) ]
-- Remove the boot_name_set because they are going
-- to be loop breakers regardless.
-------------------------------------------------
-- NOTE
......@@ -238,10 +259,8 @@ calcRecFlags tyclss
mk_nt_edges1 nt tc
| tc `elem` new_tycons = [tc] -- Loop
| isHiBootTyCon tc = [nt] -- Make it self-recursive if
-- it mentions an hi-boot TyCon
-- At this point we know that either it's a local data type,
-- or it's imported. Either way, it can't form part of a cycle
-- At this point we know that either it's a local *data* type,
-- or it's imported. Either way, it can't form part of a newtype cycle
| otherwise = []
--------------- Product types ----------------------
......@@ -262,8 +281,6 @@ calcRecFlags tyclss
| tc `elem` new_tycons = if is_rec_nt tc -- Local newtype
then []
else mk_prod_edges1 ptc (new_tc_rhs tc)
| isHiBootTyCon tc = [ptc] -- Make it self-recursive if
-- it mentions an hi-boot TyCon
-- At this point we know that either it's a local non-product data type,
-- or it's imported. Either way, it can't form part of a cycle
| otherwise = []
......@@ -298,7 +315,6 @@ tcTyConsOfType ty
go :: Type -> NameEnv TyCon -- The NameEnv does duplicate elim
go (TyVarTy v) = emptyNameEnv
go (TyConApp tc tys) = go_tc tc tys
go (NewTcApp tc tys) = go_tc tc tys
go (AppTy a b) = go a `plusNameEnv` go b
go (FunTy a b) = go a `plusNameEnv` go b
go (PredTy (IParam _ ty)) = go ty
......@@ -440,10 +456,6 @@ vrcInTy fao v (TyConApp tc tys) = let pms1 = map (vrcInTy fao v) tys
pms2 = fao tc
in orVrcs (zipWith timesVrc pms1 pms2)
vrcInTy fao v (NewTcApp tc tys) = let pms1 = map (vrcInTy fao v) tys
pms2 = fao tc
in orVrcs (zipWith timesVrc pms1 pms2)
vrcInTy fao v (PredTy st) = vrcInTy fao v (predTypeRep st)
\end{code}
......
......@@ -24,7 +24,7 @@ module TcType (
-- MetaDetails
TcTyVarDetails(..),
MetaDetails(Flexi, Indirect), SkolemInfo(..), pprSkolemTyVar,
isImmutableTyVar, isSkolemTyVar, isMetaTyVar, skolemTvInfo, metaTvRef,
isImmutableTyVar, isSkolemTyVar, isMetaTyVar, isExistentialTyVar, skolemTvInfo, metaTvRef,
isFlexi, isIndirect,
--------------------------------
......@@ -290,7 +290,7 @@ instance Outputable MetaDetails where
ppr Flexi = ptext SLIT("Flexi")
ppr (Indirect ty) = ptext SLIT("Indirect") <+> ppr ty
isImmutableTyVar, isSkolemTyVar, isMetaTyVar :: TyVar -> Bool
isImmutableTyVar, isSkolemTyVar, isExistentialTyVar, isMetaTyVar :: TyVar -> Bool
isImmutableTyVar tv
| isTcTyVar tv = isSkolemTyVar tv
| otherwise = True
......@@ -301,6 +301,12 @@ isSkolemTyVar tv
SkolemTv _ -> True
MetaTv _ -> False
isExistentialTyVar tv -- Existential type variable, bound by a pattern
= ASSERT( isTcTyVar tv )
case tcTyVarDetails tv of
SkolemTv (PatSkol _ _) -> True
other -> False
isMetaTyVar tv
= ASSERT( isTcTyVar tv )
case tcTyVarDetails tv of
......@@ -347,7 +353,6 @@ mkPhiTy theta ty = foldr (\p r -> FunTy (mkPredTy p) r) ty theta
isTauTy :: Type -> Bool
isTauTy (TyVarTy v) = True
isTauTy (TyConApp _ tys) = all isTauTy tys
isTauTy (NewTcApp _ tys) = all isTauTy tys
isTauTy (AppTy a b) = isTauTy a && isTauTy b
isTauTy (FunTy a b) = isTauTy a && isTauTy b
isTauTy (PredTy p) = True -- Don't look through source types
......@@ -360,7 +365,6 @@ getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to
-- construct a dictionary function name
getDFunTyKey (TyVarTy tv) = getOccName tv
getDFunTyKey (TyConApp tc _) = getOccName tc
getDFunTyKey (NewTcApp tc _) = getOccName tc
getDFunTyKey (AppTy fun _) = getDFunTyKey fun
getDFunTyKey (NoteTy _ t) = getDFunTyKey t
getDFunTyKey (FunTy arg _) = getOccName funTyCon
......@@ -422,7 +426,6 @@ tcSplitTyConApp ty = case tcSplitTyConApp_maybe ty of
tcSplitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
tcSplitTyConApp_maybe (NewTcApp tc tys) = Just (tc, tys)
tcSplitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res])
tcSplitTyConApp_maybe (NoteTy n ty) = tcSplitTyConApp_maybe ty
-- Newtypes are opaque, so they may be split
......@@ -453,9 +456,6 @@ tcSplitAppTy_maybe (NoteTy n ty) = tcSplitAppTy_maybe ty
tcSplitAppTy_maybe (TyConApp tc tys) = case snocView tys of
Just (tys', ty') -> Just (TyConApp tc tys', ty')
Nothing -> Nothing
tcSplitAppTy_maybe (NewTcApp tc tys) = case snocView tys of
Just (tys', ty') -> Just (NewTcApp tc tys', ty')
Nothing -> Nothing
tcSplitAppTy_maybe other = Nothing
tcSplitAppTy ty = case tcSplitAppTy_maybe ty of
......@@ -632,10 +632,9 @@ cmpTy env (PredTy p1) (PredTy p2) = cmpPredTy env p1 p2
cmpTy env (AppTy f1 a1) (AppTy f2 a2) = cmpTy env f1 f2 `thenCmp` cmpTy env a1 a2
cmpTy env (FunTy f1 a1) (FunTy f2 a2) = cmpTy env f1 f2 `thenCmp` cmpTy env a1 a2
cmpTy env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` (cmpTys env tys1 tys2)
cmpTy env (NewTcApp tc1 tys1) (NewTcApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` (cmpTys env tys1 tys2)
cmpTy env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = cmpTy (extendVarEnv env tv1 tv2) t1 t2
-- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < NewTcApp < ForAllTy < PredTy
-- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < ForAllTy < PredTy
cmpTy env (AppTy _ _) (TyVarTy _) = GT
cmpTy env (FunTy _ _) (TyVarTy _) = GT
......@@ -645,16 +644,10 @@ cmpTy env (TyConApp _ _) (TyVarTy _) = GT
cmpTy env (TyConApp _ _) (AppTy _ _) = GT
cmpTy env (TyConApp _ _) (FunTy _ _) = GT
cmpTy env (NewTcApp _ _) (TyVarTy _) = GT
cmpTy env (NewTcApp _ _) (AppTy _ _) = GT
cmpTy env (NewTcApp _ _) (FunTy _ _) = GT
cmpTy env (NewTcApp _ _) (TyConApp _ _) = GT
cmpTy env (ForAllTy _ _) (TyVarTy _) = GT
cmpTy env (ForAllTy _ _) (AppTy _ _) = GT
cmpTy env (ForAllTy _ _) (FunTy _ _) = GT
cmpTy env (ForAllTy _ _) (TyConApp _ _) = GT
cmpTy env (ForAllTy _ _) (NewTcApp _ _) = GT
cmpTy env (PredTy _) t2 = GT
......@@ -739,7 +732,6 @@ deNoteType :: Type -> Type
-- Remove synonyms, but not predicate types
deNoteType ty@(TyVarTy tyvar) = ty
deNoteType (TyConApp tycon tys) = TyConApp tycon (map deNoteType tys)
deNoteType (NewTcApp tycon tys) = NewTcApp tycon (map deNoteType tys)
deNoteType (PredTy p) = PredTy (deNotePredType p)
deNoteType (NoteTy _ ty) = deNoteType ty
deNoteType (AppTy fun arg) = AppTy (deNoteType fun) (deNoteType arg)
......@@ -758,7 +750,6 @@ end of the compiler.
tyClsNamesOfType :: Type -> NameSet
tyClsNamesOfType (TyVarTy tv) = emptyNameSet
tyClsNamesOfType (TyConApp tycon tys) = unitNameSet (getName tycon) `unionNameSets` tyClsNamesOfTypes tys
tyClsNamesOfType (NewTcApp tycon tys) = unitNameSet (getName tycon) `unionNameSets` tyClsNamesOfTypes tys
tyClsNamesOfType (NoteTy (SynNote ty1) ty2) = tyClsNamesOfType ty1
tyClsNamesOfType (NoteTy other_note ty2) = tyClsNamesOfType ty2
tyClsNamesOfType (PredTy (IParam n ty)) = tyClsNamesOfType ty
......
......@@ -700,12 +700,7 @@ uTys r1 _ (PredTy (ClassP c1 tys1)) r2 _ (PredTy (ClassP c2 tys2))
uTys r1 _ (FunTy fun1 arg1) r2 _ (FunTy fun2 arg2)
= uTys r1 fun1 fun1 r2 fun2 fun2 `thenM_` uTys r1 arg1 arg1 r2 arg2 arg2
-- NewType constructors must match
uTys r1 _ (NewTcApp tc1 tys1) r2 _ (NewTcApp tc2 tys2)
| tc1 == tc2 = unifyTauTyLists r1 tys1 r2 tys2
-- See Note [TyCon app]
-- Ordinary type constructors must match
-- Type constructors must match
uTys r1 ps_ty1 (TyConApp con1 tys1) r2 ps_ty2 (TyConApp con2 tys2)
| con1 == con2 = unifyTauTyLists r1 tys1 r2 tys2
-- See Note [TyCon app]
......@@ -983,7 +978,6 @@ okToUnifyWith tv ty
ok (AppTy t1 t2) = ok t1 `and` ok t2
ok (FunTy t1 t2) = ok t1 `and` ok t2
ok (TyConApp _ ts) = oks ts
ok (NewTcApp _ ts) = oks ts
ok (ForAllTy _ _) = Just NotMonoType
ok (PredTy st) = ok_st st
ok (NoteTy (FTVNote _) t) = ok t
......
......@@ -21,7 +21,7 @@ import Var ( Id )
import VarSet
import Type ( TvSubstEnv )
import TcType ( Type, tcTyConAppTyCon, tcIsTyVarTy,
tcSplitDFunTy, tyVarsOfTypes, isSkolemTyVar
tcSplitDFunTy, tyVarsOfTypes, isExistentialTyVar
)
import Unify ( matchTys, unifyTys )
import FunDeps ( checkClsFD )
......@@ -315,7 +315,7 @@ lookup_inst_env env key_cls key_tys key_all_tvs
| otherwise -> find insts [] []
where
key_vars = filterVarSet not_existential (tyVarsOfTypes key_tys)
not_existential tv = not (isSkolemTyVar tv)
not_existential tv = not (isExistentialTyVar tv)
-- The key_tys can contain skolem constants, and we can guarantee that those
-- are never going to be instantiated to anything, so we should not involve
-- them in the unification test. Example:
......@@ -328,6 +328,11 @@ lookup_inst_env env key_cls key_tys key_all_tvs
-- The op [x,x] means we need (Foo [a]). Without the filterVarSet we'd
-- complain, saying that the choice of instance depended on the instantiation
-- of 'a'; but of course it isn't *going* to be instantiated.
--
-- We do this only for pattern-bound skolems. For example we reject
-- g :: forall a => [a] -> Int
-- g x = op x
-- on the grounds that the correct instance depends on the instantiation of 'a'
find [] ms us = (ms, us)
find (item@(tpl_tyvars, tpl, dfun_id) : rest) ms us
......
......@@ -16,7 +16,7 @@ module TyCon(
isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isPrimTyCon,
isEnumerationTyCon,
isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity,
isRecursiveTyCon, newTyConRep, newTyConRhs, isHiBootTyCon,
isRecursiveTyCon, newTyConRep, newTyConRhs, newTyConRhs_maybe, isHiBootTyCon,
mkForeignTyCon, isForeignTyCon,
......@@ -63,6 +63,7 @@ import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed )
import Name ( Name, nameUnique, NamedThing(getName) )
import PrelNames ( Unique, Uniquable(..) )
import Maybes ( orElse )
import Util ( equalLength )
import Outputable
import FastString
\end{code}
......@@ -492,12 +493,28 @@ tyConSelIds tc = [id | (_,_,id) <- tyConFields tc]
\end{code}