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
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.
-- 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
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(..) )
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
import SrcLoc ( Located(..), SrcSpan, unLoc )
import DATA_IOREF ( readIORef )
import FastString
-import Data.List ( sort )
+import Util ( sortLe )
\end{code}
%************************************************************************
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 {
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)
-- 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
__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 ;
matchSimply
:: CoreSyn.CoreExpr
- -> HsExpr.HsMatchContext Var.Id
+ -> HsExpr.HsMatchContext Name.Name
-> HsPat.LPat Var.Id
-> CoreSyn.CoreExpr
-> CoreSyn.CoreExpr
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)
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 )
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")
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"
= 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 [] [] []
= 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
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))
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')
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
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 )
-- 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 {
-- 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
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 ;
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
-- 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}
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)
| 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)
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
}}
------------------------------------------------
}}
------------------------------------------------
-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,
-- 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
-> 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
-- 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
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) }
@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
{ (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
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
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
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
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 ----------------------
| 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 = []
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
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}
-- MetaDetails
TcTyVarDetails(..),
MetaDetails(Flexi, Indirect), SkolemInfo(..), pprSkolemTyVar,
- isImmutableTyVar, isSkolemTyVar, isMetaTyVar, skolemTvInfo, metaTvRef,
+ isImmutableTyVar, isSkolemTyVar, isMetaTyVar, isExistentialTyVar, skolemTvInfo, metaTvRef,
isFlexi, isIndirect,
--------------------------------
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
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
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
-- 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
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
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
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
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
-- 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)
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
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]
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
import VarSet
import Type ( TvSubstEnv )
import TcType ( Type, tcTyConAppTyCon, tcIsTyVarTy,
- tcSplitDFunTy, tyVarsOfTypes, isSkolemTyVar
+ tcSplitDFunTy, tyVarsOfTypes, isExistentialTyVar
)
import Unify ( matchTys, unifyTys )
import FunDeps ( checkClsFD )
| 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:
-- 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
isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isPrimTyCon,
isEnumerationTyCon,
isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity,
- isRecursiveTyCon, newTyConRep, newTyConRhs, isHiBootTyCon,
+ isRecursiveTyCon, newTyConRep, newTyConRhs, newTyConRhs_maybe, isHiBootTyCon,
mkForeignTyCon, isForeignTyCon,
import Name ( Name, nameUnique, NamedThing(getName) )
import PrelNames ( Unique, Uniquable(..) )
import Maybes ( orElse )
+import Util ( equalLength )
import Outputable
import FastString
\end{code}
\end{code}
\begin{code}
-newTyConRep :: TyCon -> ([TyVar], Type)
-newTyConRep (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon _ _ rep}) = (tvs, rep)
-
newTyConRhs :: TyCon -> ([TyVar], Type)
newTyConRhs (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon _ rhs _}) = (tvs, rhs)
+newTyConRhs_maybe :: TyCon
+ -> [Type] -- Args to tycon
+ -> Maybe ([(TyVar,Type)], -- Substitution
+ Type) -- Body type (not yet substituted)
+-- Non-recursive newtypes are transparent to Core;
+-- Given an application to some types, return Just (tenv, ty)
+-- if it's a saturated, non-recursive newtype.
+newTyConRhs_maybe (AlgTyCon {tyConTyVars = tvs,
+ algTcRec = NonRecursive, -- Not recursive
+ algTcRhs = NewTyCon _ rhs _}) tys
+ | tvs `equalLength` tys -- Saturated
+ = Just (tvs `zip` tys, rhs)
+
+newTyConRhs_maybe other_tycon tys = Nothing
+
+
+newTyConRep :: TyCon -> ([TyVar], Type)
+newTyConRep (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon _ _ rep}) = (tvs, rep)
+
tyConPrimRep :: TyCon -> PrimRep
tyConPrimRep (PrimTyCon {primTyConRep = rep}) = rep
tyConPrimRep tc = ASSERT(not (isUnboxedTupleTyCon tc)) PtrRep
mkSynTy,
- repType, typePrimRep,
+ repType, typePrimRep, coreView,
mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys,
applyTy, applyTys, isForAllTy, dropForAlls,
-- Source types
- predTypeRep, newTypeRep, mkPredTy, mkPredTys,
+ predTypeRep, mkPredTy, mkPredTys,
-- Newtypes
splitRecNewType_maybe,
import TyCon ( TyCon, isRecursiveTyCon, isPrimTyCon,
isUnboxedTupleTyCon, isUnLiftedTyCon,
isFunTyCon, isNewTyCon, newTyConRep, newTyConRhs,
- isAlgTyCon, isSynTyCon, tyConArity,
+ isAlgTyCon, isSynTyCon, tyConArity, newTyConRhs_maybe,
tyConKind, getSynTyConDefn, PrimRep(..), tyConPrimRep,
)
%************************************************************************
%* *
+ Type representation
+%* *
+%************************************************************************
+
+In Core, we "look through" non-recursive newtypes and PredTypes.
+
+\begin{code}
+{-# INLINE coreView #-}
+coreView :: Type -> Maybe Type
+-- Srips off the *top layer only* of a type to give
+-- its underlying representation type.
+-- Returns Nothing if there is nothing to look through.
+--
+-- By being non-recursive and inlined, this case analysis gets efficiently
+-- joined onto the case analysis that the caller is already doing
+coreView (NoteTy _ ty) = Just ty
+coreView (PredTy p) = Just (predTypeRep p)
+coreView (TyConApp tc tys) = expandNewTcApp tc tys
+coreView ty = Nothing
+
+expandNewTcApp :: TyCon -> [Type] -> Maybe Type
+-- A local helper function (not exported)
+-- Expands *the outermoset level of* a newtype application to
+-- *either* a vanilla TyConApp (recursive newtype, or non-saturated)
+-- *or* the newtype representation (otherwise), meaning the
+-- type written in the RHS of the newtype decl,
+-- which may itself be a newtype
+--
+-- Example: newtype R = MkR S
+-- newtype S = MkS T
+-- newtype T = MkT (T -> T)
+-- expandNewTcApp on R gives Just S
+-- on S gives Just T
+-- on T gives Nothing (no expansion)
+
+expandNewTcApp tc tys = case newTyConRhs_maybe tc tys of
+ Nothing -> Nothing
+ Just (tenv, rhs) -> Just (substTy (mkTopTvSubst tenv) rhs)
+\end{code}
+
+
+%************************************************************************
+%* *
\subsection{Constructor-specific functions}
%* *
%************************************************************************
isTyVarTy ty = isJust (getTyVar_maybe ty)
getTyVar_maybe :: Type -> Maybe TyVar
-getTyVar_maybe (TyVarTy tv) = Just tv
-getTyVar_maybe (NoteTy _ t) = getTyVar_maybe t
-getTyVar_maybe (PredTy p) = getTyVar_maybe (predTypeRep p)
-getTyVar_maybe (NewTcApp tc tys) = getTyVar_maybe (newTypeRep tc tys)
-getTyVar_maybe other = Nothing
+getTyVar_maybe ty | Just ty' <- coreView ty = getTyVar_maybe ty'
+getTyVar_maybe (TyVarTy tv) = Just tv
+getTyVar_maybe other = Nothing
\end{code}
= mk_app orig_ty1
where
mk_app (NoteTy _ ty1) = mk_app ty1
- mk_app (NewTcApp tc tys) = NewTcApp tc (tys ++ [orig_ty2])
mk_app (TyConApp tc tys) = mkGenTyConApp tc (tys ++ [orig_ty2])
mk_app ty1 = AppTy orig_ty1 orig_ty2
-- We call mkGenTyConApp because the TyConApp could be an
= mk_app orig_ty1
where
mk_app (NoteTy _ ty1) = mk_app ty1
- mk_app (NewTcApp tc tys) = NewTcApp tc (tys ++ orig_tys2)
- mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ orig_tys2)
- -- Use mkTyConApp in case tc is (->)
+ mk_app (TyConApp tc tys) = mkGenTyConApp tc (tys ++ orig_tys2)
+ -- mkGenTyConApp: see notes with mkAppTy
mk_app ty1 = foldl AppTy orig_ty1 orig_tys2
splitAppTy_maybe :: Type -> Maybe (Type, Type)
+splitAppTy_maybe ty | Just ty' <- coreView ty = splitAppTy_maybe ty'
splitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2)
splitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2)
-splitAppTy_maybe (NoteTy _ ty) = splitAppTy_maybe ty
-splitAppTy_maybe (PredTy p) = splitAppTy_maybe (predTypeRep p)
-splitAppTy_maybe (NewTcApp tc tys) = splitAppTy_maybe (newTypeRep tc tys)
splitAppTy_maybe (TyConApp tc tys) = case snocView tys of
- Nothing -> Nothing
- Just (tys',ty') -> Just (mkGenTyConApp tc tys', ty')
- -- mkGenTyConApp just in case the tc is a newtype
-
+ Nothing -> Nothing
+ Just (tys',ty') -> Just (TyConApp tc tys', ty')
splitAppTy_maybe other = Nothing
splitAppTy :: Type -> (Type, Type)
splitAppTys :: Type -> (Type, [Type])
splitAppTys ty = split ty ty []
where
+ split orig_ty ty args | Just ty' <- coreView ty = split orig_ty ty' args
split orig_ty (AppTy ty arg) args = split ty ty (arg:args)
- split orig_ty (NoteTy _ ty) args = split orig_ty ty args
- split orig_ty (PredTy p) args = split orig_ty (predTypeRep p) args
- split orig_ty (NewTcApp tc tc_args) args = split orig_ty (newTypeRep tc tc_args) args
- split orig_ty (TyConApp tc tc_args) args = (mkGenTyConApp tc [], tc_args ++ args)
- -- mkGenTyConApp just in case the tc is a newtype
+ split orig_ty (TyConApp tc tc_args) args = (TyConApp tc [], tc_args ++ args)
split orig_ty (FunTy ty1 ty2) args = ASSERT( null args )
(TyConApp funTyCon [], [ty1,ty2])
split orig_ty ty args = (orig_ty, args)
isFunTy ty = isJust (splitFunTy_maybe ty)
splitFunTy :: Type -> (Type, Type)
+splitFunTy ty | Just ty' <- coreView ty = splitFunTy ty'
splitFunTy (FunTy arg res) = (arg, res)
-splitFunTy (NoteTy _ ty) = splitFunTy ty
-splitFunTy (PredTy p) = splitFunTy (predTypeRep p)
-splitFunTy (NewTcApp tc tys) = splitFunTy (newTypeRep tc tys)
splitFunTy other = pprPanic "splitFunTy" (ppr other)
splitFunTy_maybe :: Type -> Maybe (Type, Type)
+splitFunTy_maybe ty | Just ty' <- coreView ty = splitFunTy_maybe ty'
splitFunTy_maybe (FunTy arg res) = Just (arg, res)
-splitFunTy_maybe (NoteTy _ ty) = splitFunTy_maybe ty
-splitFunTy_maybe (PredTy p) = splitFunTy_maybe (predTypeRep p)
-splitFunTy_maybe (NewTcApp tc tys) = splitFunTy_maybe (newTypeRep tc tys)
splitFunTy_maybe other = Nothing
splitFunTys :: Type -> ([Type], Type)
splitFunTys ty = split [] ty ty
where
+ split args orig_ty ty | Just ty' <- coreView ty = split args orig_ty ty'
split args orig_ty (FunTy arg res) = split (arg:args) res res
- split args orig_ty (NoteTy _ ty) = split args orig_ty ty
- split args orig_ty (PredTy p) = split args orig_ty (predTypeRep p)
- split args orig_ty (NewTcApp tc tys) = split args orig_ty (newTypeRep tc tys)
split args orig_ty ty = (reverse args, orig_ty)
splitFunTysN :: Int -> Type -> ([Type], Type)
zipFunTys orig_xs orig_ty = split [] orig_xs orig_ty orig_ty
where
split acc [] nty ty = (reverse acc, nty)
+ split acc xs nty ty
+ | Just ty' <- coreView ty = split acc xs nty ty'
split acc (x:xs) nty (FunTy arg res) = split ((x,arg):acc) xs res res
- split acc xs nty (NoteTy _ ty) = split acc xs nty ty
- split acc xs nty (PredTy p) = split acc xs nty (predTypeRep p)
- split acc xs nty (NewTcApp tc tys) = split acc xs nty (newTypeRep tc tys)
split acc (x:xs) nty ty = pprPanic "zipFunTys" (ppr orig_xs <+> ppr orig_ty)
funResultTy :: Type -> Type
+funResultTy ty | Just ty' <- coreView ty = funResultTy ty'
funResultTy (FunTy arg res) = res
-funResultTy (NoteTy _ ty) = funResultTy ty
-funResultTy (PredTy p) = funResultTy (predTypeRep p)
-funResultTy (NewTcApp tc tys) = funResultTy (newTypeRep tc tys)
funResultTy ty = pprPanic "funResultTy" (ppr ty)
funArgTy :: Type -> Type
+funArgTy ty | Just ty' <- coreView ty = funArgTy ty'
funArgTy (FunTy arg res) = arg
-funArgTy (NoteTy _ ty) = funArgTy ty
-funArgTy (PredTy p) = funArgTy (predTypeRep p)
-funArgTy (NewTcApp tc tys) = funArgTy (newTypeRep tc tys)
funArgTy ty = pprPanic "funArgTy" (ppr ty)
\end{code}
| isFunTyCon tycon, [ty1,ty2] <- tys
= FunTy ty1 ty2
- | isNewTyCon tycon
- = NewTcApp tycon tys
-
| otherwise
= ASSERT(not (isSynTyCon tycon))
TyConApp tycon tys
Nothing -> pprPanic "splitTyConApp" (ppr ty)
splitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
+splitTyConApp_maybe ty | Just ty' <- coreView ty = splitTyConApp_maybe ty'
splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
splitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res])
-splitTyConApp_maybe (NoteTy _ ty) = splitTyConApp_maybe ty
-splitTyConApp_maybe (PredTy p) = splitTyConApp_maybe (predTypeRep p)
-splitTyConApp_maybe (NewTcApp tc tys) = splitTyConApp_maybe (newTypeRep tc tys)
splitTyConApp_maybe other = Nothing
\end{code}
(b) synonyms
(c) predicates
(d) usage annotations
- (e) [recursive] newtypes
+ (e) all newtypes, including recursive ones
It's useful in the back end.
\begin{code}
repType (ForAllTy _ ty) = repType ty
repType (NoteTy _ ty) = repType ty
repType (PredTy p) = repType (predTypeRep p)
-repType (NewTcApp tc tys) = ASSERT( tys `lengthIs` tyConArity tc )
+repType (TyConApp tc tys)
+ | isNewTyCon tc = ASSERT( tys `lengthIs` tyConArity tc )
repType (new_type_rep tc tys)
repType ty = ty
-
-- ToDo: this could be moved to the code generator, using splitTyConApp instead
-- of inspecting the type directly.
typePrimRep :: Type -> PrimRep
splitForAllTy_maybe :: Type -> Maybe (TyVar, Type)
splitForAllTy_maybe ty = splitFAT_m ty
where
- splitFAT_m (NoteTy _ ty) = splitFAT_m ty
- splitFAT_m (PredTy p) = splitFAT_m (predTypeRep p)
- splitFAT_m (NewTcApp tc tys) = splitFAT_m (newTypeRep tc tys)
- splitFAT_m (ForAllTy tyvar ty) = Just(tyvar, ty)
- splitFAT_m _ = Nothing
+ splitFAT_m ty | Just ty' <- coreView ty = splitFAT_m ty'
+ splitFAT_m (ForAllTy tyvar ty) = Just(tyvar, ty)
+ splitFAT_m _ = Nothing
splitForAllTys :: Type -> ([TyVar], Type)
splitForAllTys ty = split ty ty []
where
+ split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs
split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs)
- split orig_ty (NoteTy _ ty) tvs = split orig_ty ty tvs
- split orig_ty (PredTy p) tvs = split orig_ty (predTypeRep p) tvs
- split orig_ty (NewTcApp tc tys) tvs = split orig_ty (newTypeRep tc tys) tvs
split orig_ty t tvs = (reverse tvs, orig_ty)
dropForAlls :: Type -> Type
\begin{code}
applyTy :: Type -> Type -> Type
-applyTy (PredTy p) arg = applyTy (predTypeRep p) arg
-applyTy (NewTcApp tc tys) arg = applyTy (newTypeRep tc tys) arg
-applyTy (NoteTy _ fun) arg = applyTy fun arg
-applyTy (ForAllTy tv ty) arg = substTyWith [tv] [arg] ty
-applyTy other arg = panic "applyTy"
+applyTy ty arg | Just ty' <- coreView ty = applyTy ty' arg
+applyTy (ForAllTy tv ty) arg = substTyWith [tv] [arg] ty
+applyTy other arg = panic "applyTy"
applyTys :: Type -> [Type] -> Type
-- This function is interesting because
-- Convert a PredType to its "representation type";
-- the post-type-checking type used by all the Core passes of GHC.
-- Unwraps only the outermost level; for example, the result might
--- be a NewTcApp; c.f. newTypeRep
+-- be a newtype application
predTypeRep (IParam _ ty) = ty
predTypeRep (ClassP clas tys) = mkTyConApp (classTyCon clas) tys
- -- Result might be a NewTcApp, but the consumer will
+ -- Result might be a newtype application, but the consumer will
-- look through that too if necessary
\end{code}
\begin{code}
splitRecNewType_maybe :: Type -> Maybe Type
--- Newtypes are always represented by a NewTcApp
-- Sometimes we want to look through a recursive newtype, and that's what happens here
-- It only strips *one layer* off, so the caller will usually call itself recursively
-- Only applied to types of kind *, hence the newtype is always saturated
-splitRecNewType_maybe (NoteTy _ ty) = splitRecNewType_maybe ty
-splitRecNewType_maybe (PredTy p) = splitRecNewType_maybe (predTypeRep p)
-splitRecNewType_maybe (NewTcApp tc tys)
- | isRecursiveTyCon tc
- = ASSERT( tys `lengthIs` tyConArity tc && isNewTyCon tc )
- -- The assert should hold because splitRecNewType_maybe
- -- should only be applied to *types* (of kind *)
- Just (new_type_rhs tc tys)
+splitRecNewType_maybe ty | Just ty' <- coreView ty = splitRecNewType_maybe ty'
+splitRecNewType_maybe (TyConApp tc tys)
+ | isNewTyCon tc
+ = ASSERT( tys `lengthIs` tyConArity tc ) -- splitRecNewType_maybe only be applied
+ -- to *types* (of kind *)
+ ASSERT( isRecursiveTyCon tc ) -- Guaranteed by coreView
+ case newTyConRhs tc of
+ (tvs, rep_ty) -> Just (substTyWith tvs tys rep_ty)
+
splitRecNewType_maybe other = Nothing
-
------------------------------
-newTypeRep :: TyCon -> [Type] -> Type
--- A local helper function (not exported)
--- Expands *the outermoset level of* a newtype application to
--- *either* a vanilla TyConApp (recursive newtype, or non-saturated)
--- *or* the newtype representation (otherwise), meaning the
--- type written in the RHS of the newtype decl,
--- which may itself be a newtype
---
--- Example: newtype R = MkR S
--- newtype S = MkS T
--- newtype T = MkT (T -> T)
--- newTypeRep on R gives NewTcApp S
--- on S gives NewTcApp T
--- on T gives TyConApp T
---
--- NB: the returned TyConApp is always deconstructed immediately by the
--- caller... a TyConApp with a newtype type constructor never lives
--- in an ordinary type
-newTypeRep tc tys
- | not (isRecursiveTyCon tc), -- Not recursive and saturated
- tys `lengthIs` tyConArity tc -- treat as equivalent to expansion
- = new_type_rhs tc tys
- | otherwise
- = TyConApp tc tys
- -- ToDo: Consider caching this substitution in a NType
-
--- new_type_rhs doesn't ask any questions:
--- it just expands newtype one level, whether recursive or not
-new_type_rhs tc tys
- = case newTyConRhs tc of
- (tvs, rep_ty) -> substTyWith tvs tys rep_ty
\end{code}
typeKind (TyVarTy tyvar) = tyVarKind tyvar
typeKind (TyConApp tycon tys) = foldr (\_ k -> kindFunResult k) (tyConKind tycon) tys
-typeKind (NewTcApp tycon tys) = foldr (\_ k -> kindFunResult k) (tyConKind tycon) tys
typeKind (NoteTy _ ty) = typeKind ty
typeKind (PredTy _) = liftedTypeKind -- Predicates are always
-- represented by lifted types
tyVarsOfType :: Type -> TyVarSet
tyVarsOfType (TyVarTy tv) = unitVarSet tv
tyVarsOfType (TyConApp tycon tys) = tyVarsOfTypes tys
-tyVarsOfType (NewTcApp tycon tys) = tyVarsOfTypes tys
tyVarsOfType (NoteTy (FTVNote tvs) ty2) = tvs
tyVarsOfType (NoteTy (SynNote ty1) ty2) = tyVarsOfType ty2 -- See note [Syn] below
tyVarsOfType (PredTy sty) = tyVarsOfPred sty
Just tv' -> TyVarTy tv'
go (TyConApp tycon tys) = let args = map go tys
in args `seqList` TyConApp tycon args
- go (NewTcApp tycon tys) = let args = map go tys
- in args `seqList` NewTcApp tycon args
go (NoteTy note ty) = (NoteTy $! (go_note note)) $! (go ty)
go (PredTy sty) = PredTy (tidyPred env sty)
go (AppTy fun arg) = (AppTy $! (go fun)) $! (go arg)
-- They are pretty bogus types, mind you. It would be better never to
-- construct them
+isUnLiftedType ty | Just ty' <- coreView ty = isUnLiftedType ty'
isUnLiftedType (ForAllTy tv ty) = isUnLiftedType ty
-isUnLiftedType (NoteTy _ ty) = isUnLiftedType ty
isUnLiftedType (TyConApp tc _) = isUnLiftedTyCon tc
-isUnLiftedType (PredTy _) = False -- All source types are lifted
-isUnLiftedType (NewTcApp tc tys) = isUnLiftedType (newTypeRep tc tys)
isUnLiftedType other = False
isUnboxedTupleType :: Type -> Bool
which is below TcType in the hierarchy, so it's convenient to put it here.
\begin{code}
+isStrictType (PredTy pred) = isStrictPred pred
+isStrictType ty | Just ty' <- coreView ty = isStrictType ty'
isStrictType (ForAllTy tv ty) = isStrictType ty
-isStrictType (NoteTy _ ty) = isStrictType ty
isStrictType (TyConApp tc _) = isUnLiftedTyCon tc
-isStrictType (NewTcApp tc tys) = isStrictType (newTypeRep tc tys)
-isStrictType (PredTy pred) = isStrictPred pred
isStrictType other = False
isStrictPred (ClassP clas _) = opt_DictsStrict && not (isNewTyCon (classTyCon clas))
seqType (NoteTy note t2) = seqNote note `seq` seqType t2
seqType (PredTy p) = seqPred p
seqType (TyConApp tc tys) = tc `seq` seqTypes tys
-seqType (NewTcApp tc tys) = tc `seq` seqTypes tys
seqType (ForAllTy tv ty) = tv `seq` seqType ty
seqTypes :: [Type] -> ()
\begin{code}
eqType t1 t2 = eq_ty emptyVarEnv t1 t2
--- Look through Notes
-eq_ty env (NoteTy _ t1) t2 = eq_ty env t1 t2
-eq_ty env t1 (NoteTy _ t2) = eq_ty env t1 t2
-
--- Look through PredTy and NewTcApp. This is where the looping danger comes from.
--- We don't bother to check for the PredType/PredType case, no good reason
--- Hmm: maybe there is a good reason: see the notes below about newtypes
-eq_ty env (PredTy sty1) t2 = eq_ty env (predTypeRep sty1) t2
-eq_ty env t1 (PredTy sty2) = eq_ty env t1 (predTypeRep sty2)
+-- Look through Notes, PredTy, newtype applications
+eq_ty env t1 t2 | Just t1' <- coreView t1 = eq_ty env t1' t2
+eq_ty env t1 t2 | Just t2' <- coreView t2 = eq_ty env t1 t2'
-- NB: we *cannot* short-cut the newtype comparison thus:
-- eq_ty env (NewTcApp tc1 tys1) (NewTcApp tc2 tys2)
-- but we can only expand saturated newtypes, so just comparing
-- T with [] won't do.
-eq_ty env (NewTcApp tc1 tys1) t2 = eq_ty env (newTypeRep tc1 tys1) t2
-eq_ty env t1 (NewTcApp tc2 tys2) = eq_ty env t1 (newTypeRep tc2 tys2)
-
-- The rest is plain sailing
eq_ty env (TyVarTy tv1) (TyVarTy tv2) = case lookupVarEnv env tv1 of
Just tv1a -> tv1a == tv2
go (TyConApp tc tys) = let args = map go tys
in args `seqList` TyConApp tc args
- go (NewTcApp tc tys) = let args = map go tys
- in args `seqList` NewTcApp tc args
-
go (PredTy p) = PredTy $! (substPred subst p)
go (NoteTy (SynNote ty1) ty2) = NoteTy (SynNote $! (go ty1)) $! (go ty2)
import Name ( Name, NamedThing(..), BuiltInSyntax(..), mkWiredInName )
import OccName ( mkOccFS, tcName )
import BasicTypes ( IPName, tupleParens )
-import TyCon ( TyCon, mkFunTyCon, tyConArity, tupleTyConBoxity, isTupleTyCon, isRecursiveTyCon )
+import TyCon ( TyCon, mkFunTyCon, tyConArity, tupleTyConBoxity, isTupleTyCon, isRecursiveTyCon, isNewTyCon )
import Class ( Class )
-- others
Solution:
-* Newtypes are always represented using NewTcApp, never as TyConApp.
+* Newtypes are always represented using TyConApp.
* For non-recursive newtypes, P, treat P just like a type synonym after
type-checking is done; i.e. it's opaque during type checking (functions
= TyVarTy TyVar
| AppTy
- Type -- Function is *not* a TyConApp or NewTcApp
+ Type -- Function is *not* a TyConApp
Type -- It must be another AppTy, or TyVarTy
-- (or NoteTy of these)
- | TyConApp -- Application of a TyCon
+ | TyConApp -- Application of a TyCon, including newtypes
TyCon -- *Invariant* saturated appliations of FunTyCon and
-- synonyms have their own constructors, below.
- [Type] -- Might not be saturated.
-
- | NewTcApp -- Application of a NewType TyCon. All newtype applications
- TyCon -- show up like this until they are fed through newTypeRep,
- -- which returns
- -- * an ordinary TyConApp for non-saturated,
- -- or recursive newtypes
- --
- -- * the representation type of the newtype for satuarted,
- -- non-recursive ones
- -- [But the result of a call to newTypeRep is always consumed
- -- immediately; it never lives on in another type. So in any
- -- type, newtypes are always represented with NewTcApp.]
+ -- However, *unsaturated* type synonyms, and FunTyCons
+ -- do appear as TyConApps. (Unsaturated type synonyms
+ -- can appear as the RHS of a type synonym, for exmaple.)
[Type] -- Might not be saturated.
| FunTy -- Special case of TyConApp: TyConApp FunTyCon [t1,t2]
ppr_type p (NoteTy other ty2) = ppr_type p ty2
ppr_type p (TyConApp tc tys) = ppr_tc_app p tc tys
-ppr_type p (NewTcApp tc tys) = ifPprDebug (if isRecursiveTyCon tc
- then ptext SLIT("<recnt>")
- else ptext SLIT("<nt>")
- ) <>
- ppr_tc_app p tc tys
ppr_type p (AppTy t1 t2) = maybeParen p TyConPrec $
pprType t1 <+> ppr_type TyConPrec t2
ppr_tc_app :: Prec -> TyCon -> [Type] -> SDoc
ppr_tc_app p tc []
- = ppr tc
+ = ppr_tc tc
ppr_tc_app p tc [ty]
| tc `hasKey` listTyConKey = brackets (pprType ty)
| tc `hasKey` parrTyConKey = ptext SLIT("[:") <> pprType ty <> ptext SLIT(":]")
= tupleParens (tupleTyConBoxity tc) (sep (punctuate comma (map pprType tys)))
| otherwise
= maybeParen p TyConPrec $
- ppr tc <+> sep (map (ppr_type TyConPrec) tys)
-
+ ppr_tc tc <+> sep (map (ppr_type TyConPrec) tys)
+
+ppr_tc :: TyCon -> SDoc
+ppr_tc tc
+ | isNewTyCon tc = ifPprDebug (if isRecursiveTyCon tc
+ then ptext SLIT("<recnt>")
+ else ptext SLIT("<nt>")
+ ) <> ppr tc
+ | otherwise = ppr tc
+
-------------------
pprForAll tvs = ptext SLIT("forall") <+> sep (map pprTvBndr tvs) <> dot
import VarEnv
import VarSet
import Kind ( isSubKind )
-import Type ( predTypeRep, newTypeRep, typeKind,
- tyVarsOfType, tyVarsOfTypes,
+import Type ( predTypeRep, typeKind,
+ tyVarsOfType, tyVarsOfTypes, coreView,
TvSubstEnv, TvSubst(..), substTy )
import TypeRep ( Type(..), PredType(..), funTyCon )
import Util ( snocView )
-- nor guarantee that the outgoing one is. That's fixed up by
-- the wrappers.
--- ToDo: remove debugging junk
unify s subst ty1 ty2 = -- pprTrace "unify" (ppr subst <+> pprParendType ty1 <+> pprParendType ty2) $
- unify_ s subst ty1 ty2
+ unify_ s subst (rep s ty1) (rep s ty2)
--- Look through NoteTy in the obvious fashion
-unify_ s subst (NoteTy _ ty1) ty2 = unify s subst ty1 ty2
-unify_ s subst ty1 (NoteTy _ ty2) = unify s subst ty1 ty2
-
--- In Core mode, look through NewTcApps and Preds
-unify_ Core subst (NewTcApp tc tys) ty2 = unify Core subst (newTypeRep tc tys) ty2
-unify_ Core subst ty1 (NewTcApp tc tys) = unify Core subst ty1 (newTypeRep tc tys)
-
-unify_ Core subst (PredTy p) ty2 = unify Core subst (predTypeRep p) ty2
-unify_ Core subst ty1 (PredTy p) = unify Core subst ty1 (predTypeRep p)
-
--- From now on, any NewTcApps/Preds should be taken at face value
+rep :: SrcFlag -> Type -> Type -- Strip off the clutter
+rep Src (NoteTy _ ty) = rep Src ty
+rep Core ty | Just ty' <- coreView ty = rep Core ty'
+rep s ty = ty
+-- in unify_, any NewTcApps/Preds should be taken at face value
unify_ s subst (TyVarTy tv1) ty2 = uVar s False subst tv1 ty2
unify_ s subst ty1 (TyVarTy tv2) = uVar s True subst tv2 ty1
unify_ s subst t1@(TyConApp tyc1 tys1) t2@(TyConApp tyc2 tys2)
| tyc1 == tyc2 = unify_tys s subst tys1 tys2
-unify_ Src subst t1@(NewTcApp tc1 tys1) t2@(NewTcApp tc2 tys2)
- | tc1 == tc2 = unify_tys Src subst tys1 tys2
+
unify_ s subst (FunTy ty1a ty1b) (FunTy ty2a ty2b)
= do { subst' <- unify s subst ty1a ty2a
; unify s subst' ty1b ty2b }
unifySplitAppTy_maybe (TyConApp tc tys) = case snocView tys of
Just (tys', ty') -> Just (TyConApp tc tys', ty')
Nothing -> Nothing
-unifySplitAppTy_maybe (NewTcApp tc tys) = case snocView tys of
- Just (tys', ty') -> Just (NewTcApp tc tys', ty')
- Nothing -> Nothing
unifySplitAppTy_maybe other = Nothing
------------------------------
\begin{code}
group :: (a -> a -> Bool) -> [a] -> [[a]]
+-- Given a <= function, group finds maximal contiguous up-runs
+-- or down-runs in the input list.
+-- It's stable, in the sense that it never re-orders equal elements
+--
+-- Date: Mon, 12 Feb 1996 15:09:41 +0000
+-- From: Andy Gill <andy@dcs.gla.ac.uk>
+-- Here is a `better' definition of group.
-{-
-Date: Mon, 12 Feb 1996 15:09:41 +0000
-From: Andy Gill <andy@dcs.gla.ac.uk>
-
-Here is a `better' definition of group.
--}
group p [] = []
group p (x:xs) = group' xs x x (x :)
where
group' [] _ _ s = [s []]
group' (x:xs) x_min x_max s
- | not (x `p` x_max) = group' xs x_min x (s . (x :))
- | x `p` x_min = group' xs x x_max ((x :) . s)
+ | x_max `p` x = group' xs x_min x (s . (x :))
+ | not (x_min `p` x) = group' xs x x_max ((x :) . s)
| otherwise = s [] : group' xs x x (x :)
-
--- This one works forwards *and* backwards, as well as also being
--- faster that the one in Util.lhs.
-
-{- ORIG:
-group p [] = [[]]
-group p (x:xs) =
- let ((h1:t1):tt1) = group p xs
- (t,tt) = if null xs then ([],[]) else
- if x `p` h1 then (h1:t1,tt1) else
- ([], (h1:t1):tt1)
- in ((x:t):tt)
--}
+ -- NB: the 'not' is essential for stablity
+ -- x `p` x_min would reverse equal elements
generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
generalMerge p xs [] = xs
projects / ghc-hetmet.git / commitdiff