From: simonpj Date: Fri, 1 Oct 2004 13:42:57 +0000 (+0000) Subject: [project @ 2004-10-01 13:42:04 by simonpj] X-Git-Tag: Initial_conversion_from_CVS_complete~1554 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=837824d2ff329a0f68c1434ae6812bea3ac7ec5f;p=ghc-hetmet.git [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. --- diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs index 476aa2a..147039b 100644 --- a/ghc/compiler/codeGen/ClosureInfo.lhs +++ b/ghc/compiler/codeGen/ClosureInfo.lhs @@ -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 diff --git a/ghc/compiler/coreSyn/MkExternalCore.lhs b/ghc/compiler/coreSyn/MkExternalCore.lhs index 03049fb..da88848 100644 --- a/ghc/compiler/coreSyn/MkExternalCore.lhs +++ b/ghc/compiler/coreSyn/MkExternalCore.lhs @@ -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 diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index 02c475f..02f60ed 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -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 { diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs index 269274c..4b2c1de 100644 --- a/ghc/compiler/deSugar/DsForeign.lhs +++ b/ghc/compiler/deSugar/DsForeign.lhs @@ -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) diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs index 501b2d3..3bae06a 100644 --- a/ghc/compiler/deSugar/DsMeta.hs +++ b/ghc/compiler/deSugar/DsMeta.hs @@ -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 diff --git a/ghc/compiler/deSugar/Match.hi-boot-5 b/ghc/compiler/deSugar/Match.hi-boot-5 index f8dc571..42c200f 100644 --- a/ghc/compiler/deSugar/Match.hi-boot-5 +++ b/ghc/compiler/deSugar/Match.hi-boot-5 @@ -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 ; diff --git a/ghc/compiler/deSugar/Match.hi-boot-6 b/ghc/compiler/deSugar/Match.hi-boot-6 index abd5d2b..168daf4 100644 --- a/ghc/compiler/deSugar/Match.hi-boot-6 +++ b/ghc/compiler/deSugar/Match.hi-boot-6 @@ -12,7 +12,7 @@ matchWrapper matchSimply :: CoreSyn.CoreExpr - -> HsExpr.HsMatchContext Var.Id + -> HsExpr.HsMatchContext Name.Name -> HsPat.LPat Var.Id -> CoreSyn.CoreExpr -> CoreSyn.CoreExpr diff --git a/ghc/compiler/iface/IfaceType.lhs b/ghc/compiler/iface/IfaceType.lhs index b771e5a..c3a64a8 100644 --- a/ghc/compiler/iface/IfaceType.lhs +++ b/ghc/compiler/iface/IfaceType.lhs @@ -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) diff --git a/ghc/compiler/iface/LoadIface.lhs b/ghc/compiler/iface/LoadIface.lhs index b6b59d7..d16dc39 100644 --- a/ghc/compiler/iface/LoadIface.lhs +++ b/ghc/compiler/iface/LoadIface.lhs @@ -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") diff --git a/ghc/compiler/iface/MkIface.lhs b/ghc/compiler/iface/MkIface.lhs index e8fbeb0..176dba5 100644 --- a/ghc/compiler/iface/MkIface.lhs +++ b/ghc/compiler/iface/MkIface.lhs @@ -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" diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index 41d38de..bcb967f 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -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 [] [] [] diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index ae10007..c9c59cc 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -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 diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 0f5ad41..5401584 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -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)) diff --git a/ghc/compiler/typecheck/TcMType.lhs b/ghc/compiler/typecheck/TcMType.lhs index 45ab32e..8dda867 100644 --- a/ghc/compiler/typecheck/TcMType.lhs +++ b/ghc/compiler/typecheck/TcMType.lhs @@ -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 diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index 53b7071..9d34979 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -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 diff --git a/ghc/compiler/typecheck/TcSplice.hi-boot-6 b/ghc/compiler/typecheck/TcSplice.hi-boot-6 index 8fbf843..cb93b13 100644 --- a/ghc/compiler/typecheck/TcSplice.hi-boot-6 +++ b/ghc/compiler/typecheck/TcSplice.hi-boot-6 @@ -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 diff --git a/ghc/compiler/typecheck/TcSplice.lhs b/ghc/compiler/typecheck/TcSplice.lhs index 66c0f57..08e47ee 100644 --- a/ghc/compiler/typecheck/TcSplice.lhs +++ b/ghc/compiler/typecheck/TcSplice.lhs @@ -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) } diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index 2be946e..120e6f8 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -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 diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index 7dd0a2e..3ceeb8e 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -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} diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs index a53daf5..379b370 100644 --- a/ghc/compiler/typecheck/TcType.lhs +++ b/ghc/compiler/typecheck/TcType.lhs @@ -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 diff --git a/ghc/compiler/typecheck/TcUnify.lhs b/ghc/compiler/typecheck/TcUnify.lhs index 07b4043..87b30c6 100644 --- a/ghc/compiler/typecheck/TcUnify.lhs +++ b/ghc/compiler/typecheck/TcUnify.lhs @@ -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 diff --git a/ghc/compiler/types/InstEnv.lhs b/ghc/compiler/types/InstEnv.lhs index 974f960..e7a7d8a 100644 --- a/ghc/compiler/types/InstEnv.lhs +++ b/ghc/compiler/types/InstEnv.lhs @@ -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 diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs index 96e1046..78cf5be 100644 --- a/ghc/compiler/types/TyCon.lhs +++ b/ghc/compiler/types/TyCon.lhs @@ -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} \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 diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index dfb72d3..9bad29d 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -29,13 +29,13 @@ module Type ( 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, @@ -95,7 +95,7 @@ import Class ( Class, classTyCon ) import TyCon ( TyCon, isRecursiveTyCon, isPrimTyCon, isUnboxedTupleTyCon, isUnLiftedTyCon, isFunTyCon, isNewTyCon, newTyConRep, newTyConRhs, - isAlgTyCon, isSynTyCon, tyConArity, + isAlgTyCon, isSynTyCon, tyConArity, newTyConRhs_maybe, tyConKind, getSynTyConDefn, PrimRep(..), tyConPrimRep, ) @@ -112,6 +112,49 @@ import Maybe ( isJust ) %************************************************************************ %* * + 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} %* * %************************************************************************ @@ -136,11 +179,9 @@ isTyVarTy :: Type -> Bool 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} @@ -156,7 +197,6 @@ mkAppTy orig_ty1 orig_ty2 = 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 @@ -179,22 +219,17 @@ mkAppTys orig_ty1 orig_tys2 = 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) @@ -205,12 +240,9 @@ splitAppTy ty = case splitAppTy_maybe ty of 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) @@ -232,26 +264,20 @@ isFunTy :: Type -> Bool 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) @@ -265,24 +291,19 @@ zipFunTys :: Outputable a => [a] -> Type -> ([(a,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} @@ -305,9 +326,6 @@ mkTyConApp tycon tys | isFunTyCon tycon, [ty1,ty2] <- tys = FunTy ty1 ty2 - | isNewTyCon tycon - = NewTcApp tycon tys - | otherwise = ASSERT(not (isSynTyCon tycon)) TyConApp tycon tys @@ -331,11 +349,9 @@ splitTyConApp ty = case splitTyConApp_maybe ty of 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} @@ -392,7 +408,7 @@ repType looks through (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} @@ -401,11 +417,11 @@ repType :: Type -> Type 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 @@ -449,19 +465,15 @@ isForAllTy other_ty = False 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 @@ -480,11 +492,9 @@ the expression. \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 @@ -540,10 +550,10 @@ predTypeRep :: PredType -> Type -- 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} @@ -556,52 +566,19 @@ predTypeRep (ClassP clas tys) = mkTyConApp (classTyCon clas) tys \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} @@ -619,7 +596,6 @@ typeKind :: Type -> Kind 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 @@ -636,7 +612,6 @@ typeKind (ForAllTy tv ty) = typeKind ty 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 @@ -724,8 +699,6 @@ tidyType env@(tidy_env, subst) ty 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) @@ -778,11 +751,9 @@ isUnLiftedType :: Type -> Bool -- 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 @@ -806,11 +777,10 @@ this function should be in TcType, but isStrictType is used by DataCon, 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)) @@ -847,7 +817,6 @@ seqType (FunTy t1 t2) = seqType t1 `seq` seqType t2 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] -> () @@ -886,15 +855,9 @@ I don't think this is harmful, but it's soemthing to watch out for. \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) @@ -913,9 +876,6 @@ eq_ty env t1 (PredTy sty2) = eq_ty env t1 (predTypeRep sty2) -- 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 @@ -1097,9 +1057,6 @@ subst_ty subst@(TvSubst in_scope env) ty 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) diff --git a/ghc/compiler/types/TypeRep.lhs b/ghc/compiler/types/TypeRep.lhs index 5c4bd33..7bbbc5a 100644 --- a/ghc/compiler/types/TypeRep.lhs +++ b/ghc/compiler/types/TypeRep.lhs @@ -35,7 +35,7 @@ import VarSet ( TyVarSet ) 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 @@ -114,7 +114,7 @@ Similarly splitForAllTys and splitFunTys can get into a loop. 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 @@ -148,26 +148,16 @@ data Type = 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] @@ -357,11 +347,6 @@ ppr_type p (NoteTy (SynNote ty1) ty2) = ppr_type p ty1 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("") - else ptext SLIT("") - ) <> - ppr_tc_app p tc tys ppr_type p (AppTy t1 t2) = maybeParen p TyConPrec $ pprType t1 <+> ppr_type TyConPrec t2 @@ -393,7 +378,7 @@ ppr_type p ty@(ForAllTy _ _) 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(":]") @@ -402,8 +387,16 @@ ppr_tc_app p tc tys = 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("") + else ptext SLIT("") + ) <> ppr tc + | otherwise = ppr tc + ------------------- pprForAll tvs = ptext SLIT("forall") <+> sep (map pprTvBndr tvs) <> dot diff --git a/ghc/compiler/types/Unify.lhs b/ghc/compiler/types/Unify.lhs index 42ea928..8d5f070 100644 --- a/ghc/compiler/types/Unify.lhs +++ b/ghc/compiler/types/Unify.lhs @@ -16,8 +16,8 @@ import Var ( Var, TyVar, tyVarKind ) 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 ) @@ -158,23 +158,15 @@ unify :: SrcFlag -- True, unifying source types, false core types -- 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 @@ -182,8 +174,7 @@ unify_ s subst (PredTy p1) (PredTy p2) = unify_pred s subst p1 p2 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 } @@ -218,9 +209,6 @@ unifySplitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2) 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 ------------------------------ diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs index 34a5b53..feeb687 100644 --- a/ghc/compiler/utils/Util.lhs +++ b/ghc/compiler/utils/Util.lhs @@ -373,34 +373,24 @@ Carsten \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 +-- Here is a `better' definition of group. -{- -Date: Mon, 12 Feb 1996 15:09:41 +0000 -From: Andy Gill - -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