From: simonpj Date: Wed, 15 Nov 2000 17:07:36 +0000 (+0000) Subject: [project @ 2000-11-15 17:07:34 by simonpj] X-Git-Tag: Approximately_9120_patches~3333 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=ea659be5faea43df1b2c113d2f22947dff23367e;p=ghc-hetmet.git [project @ 2000-11-15 17:07:34 by simonpj] I finally got tired of not having splitTyConApp tyConAppTyCon tyConAppArgs (Previously we called splitTyConApp_maybe, but it's a pain in the neck.) --- diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs index 07537fb..ca015bd 100644 --- a/ghc/compiler/codeGen/CgExpr.lhs +++ b/ghc/compiler/codeGen/CgExpr.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgExpr.lhs,v 1.38 2000/11/15 14:37:08 simonpj Exp $ +% $Id: CgExpr.lhs,v 1.39 2000/11/15 17:07:34 simonpj Exp $ % %******************************************************** %* * @@ -44,7 +44,7 @@ import PrimOp ( primOpOutOfLine, getPrimOpResultInfo, PrimOp(..), PrimOpResultI import PrimRep ( PrimRep(..), isFollowableRep ) import TyCon ( maybeTyConSingleCon, isUnboxedTupleTyCon, isEnumerationTyCon ) -import Type ( Type, typePrimRep, splitTyConApp_maybe, repType ) +import Type ( Type, typePrimRep, splitTyConApp, tyConAppTyCon, repType ) import Maybes ( maybeToBool ) import ListSetOps ( assocMaybe ) import Unique ( mkBuiltinUnique ) @@ -143,7 +143,7 @@ cgExpr (StgPrimApp TagToEnumOp [arg] res_ty) -- -- That won't work. -- - (Just (tycon,_)) = splitTyConApp_maybe res_ty + tycon = tyConAppTyCon res_ty cgExpr x@(StgPrimApp op args res_ty) @@ -462,12 +462,10 @@ primRetUnboxedTuple op args res_ty allocate some temporaries for the return values. -} let - (tc,ty_args) = case splitTyConApp_maybe (repType res_ty) of - Nothing -> pprPanic "primRetUnboxedTuple" (ppr res_ty) - Just pr -> pr - prim_reps = map typePrimRep ty_args - temp_uniqs = map mkBuiltinUnique [ n_args .. n_args + length ty_args - 1] - temp_amodes = zipWith CTemp temp_uniqs prim_reps + (tc,ty_args) = splitTyConApp (repType res_ty) + prim_reps = map typePrimRep ty_args + temp_uniqs = map mkBuiltinUnique [ n_args .. n_args + length ty_args - 1] + temp_amodes = zipWith CTemp temp_uniqs prim_reps in returnUnboxedTuple temp_amodes (absC (COpStmt temp_amodes op arg_temps [])) \end{code} diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index ccd3afa..5a0c140 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -33,7 +33,7 @@ import ErrUtils ( doIfSet_dyn, dumpIfSet, ghcExit, Message, showPass, import SrcLoc ( SrcLoc, noSrcLoc ) import Type ( Type, tyVarsOfType, splitFunTy_maybe, mkTyVarTy, - splitForAllTy_maybe, splitTyConApp_maybe, + splitForAllTy_maybe, splitTyConApp_maybe, splitTyConApp, isUnLiftedType, typeKind, isUnboxedTupleType, hasMoreBoxityInfo @@ -466,7 +466,7 @@ lintCoreAlt scrut_ty alt@(DataAlt con, args, rhs) -- Scrutinee type must be a tycon applicn; checked by caller -- This code is remarkably compact considering what it does! -- NB: args must be in scope here so that the lintCoreArgs line works. - case splitTyConApp_maybe scrut_ty of { Just (tycon, tycon_arg_tys) -> + case splitTyConApp scrut_ty of { (tycon, tycon_arg_tys) -> lintTyApps (dataConRepType con) tycon_arg_tys `thenL` \ con_type -> lintCoreArgs con_type (map mk_arg args) `thenL` \ con_result_ty -> checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty) diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index 1745615..49f8939 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -57,28 +57,30 @@ deSugar dflags mod_name unqual hst tc_binds = all_binds, tc_rules = rules, tc_fords = fo_decls}) - = do - showPass dflags "Desugar" - us <- mkSplitUniqSupply 'd' + = do { showPass dflags "Desugar" + ; us <- mkSplitUniqSupply 'd' -- Do desugaring - let (result, ds_warns) = - initDs dflags us (hst,pcs,global_val_env) mod_name - (dsProgram mod_name all_binds rules fo_decls) - (ds_binds, ds_rules, _, _, _) = result + ; let (result, ds_warns) = initDs dflags us (hst,pcs,global_val_env) mod_name + (dsProgram mod_name all_binds rules fo_decls) + (ds_binds, ds_rules, _, _, _) = result -- Display any warnings - doIfSet (not (isEmptyBag ds_warns)) - (printErrs unqual (pprBagOfWarnings ds_warns)) + ; doIfSet (not (isEmptyBag ds_warns)) + (printErrs unqual (pprBagOfWarnings ds_warns)) -- Lint result if necessary - let do_dump_ds = dopt Opt_D_dump_ds dflags - endPass dflags "Desugar" do_dump_ds ds_binds + ; let do_dump_ds = dopt Opt_D_dump_ds dflags + ; endPass dflags "Desugar" do_dump_ds ds_binds -- Dump output - doIfSet do_dump_ds (printDump (ppr_ds_rules ds_rules)) + ; doIfSet do_dump_ds (printDump (ppr_ds_rules ds_rules)) - return result + ; return result + } + +-- deSugarExpr dflags unqual hst tc_expr +-- = do { dsProgram mod_name all_binds rules fo_decls = dsMonoBinds auto_scc all_binds [] `thenDs` \ core_prs -> diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs index c56b1d4..189672a 100644 --- a/ghc/compiler/deSugar/DsForeign.lhs +++ b/ghc/compiler/deSugar/DsForeign.lhs @@ -30,7 +30,7 @@ import Name ( mkGlobalName, nameModule, nameOccName, getOccString, NamedThing(..), ) import Type ( repType, - splitTyConApp_maybe, splitFunTys, splitForAllTys, + splitTyConApp_maybe, tyConAppTyCon, splitFunTys, splitForAllTys, Type, mkFunTys, mkForAllTys, mkTyConApp, mkFunTy, splitAppTy, applyTy, funResultTy ) @@ -487,9 +487,5 @@ showStgType :: Type -> SDoc showStgType t = text "Hs" <> text (showFFIType t) showFFIType :: Type -> String -showFFIType t = getOccString (getName tc) - where - tc = case splitTyConApp_maybe (repType t) of - Just (tc,_) -> tc - Nothing -> pprPanic "showFFIType" (ppr t) +showFFIType t = getOccString (getName (tyConAppTyCon t)) \end{code} diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index d6ae43c..467306c 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -381,8 +381,17 @@ hscExpr dflags hst hit pcs this_module expr -- Rename it (new_pcs, maybe_renamed_expr) <- renameExpr dflags hit hst pcs this_module parsed_expr ; - case maybe_renamed_expr of { - Nothing -> + ; case maybe_renamed_expr of { + Nothing -> FAIL + Just renamed_expr -> + + -- Typecheck it + maybe_tc_expr <- typecheckExpr dflags pcs hst unqual renamed_expr + ; case maybe_tc_expr of + Nothing -> FAIL + Just typechecked_expr -> + + %************************************************************************ diff --git a/ghc/compiler/prelude/PrelRules.lhs b/ghc/compiler/prelude/PrelRules.lhs index dff38e6..8b3f2d9 100644 --- a/ghc/compiler/prelude/PrelRules.lhs +++ b/ghc/compiler/prelude/PrelRules.lhs @@ -29,7 +29,7 @@ import TysWiredIn ( trueDataConId, falseDataConId ) import TyCon ( tyConDataConsIfAvailable, isEnumerationTyCon, isNewTyCon ) import DataCon ( dataConTag, dataConTyCon, dataConId, fIRST_TAG ) import CoreUtils ( exprIsValue, cheapEqExpr, exprIsConApp_maybe ) -import Type ( splitTyConApp_maybe ) +import Type ( tyConAppTyCon ) import OccName ( occNameUserString) import PrelNames ( unpackCStringFoldrName, unpackCStringFoldrIdKey, hasKey ) import Name ( Name ) @@ -392,8 +392,8 @@ tagToEnumRule [Type ty, Lit (MachInt i)] Just (SLIT("TagToEnum"), Var (dataConId dc)) where correct_tag dc = (dataConTag dc - fIRST_TAG) == tag - tag = fromInteger i - (Just (tycon,_)) = splitTyConApp_maybe ty + tag = fromInteger i + tycon = tyConAppTyCon ty tagToEnumRule other = Nothing \end{code} diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs index 70386d4..2d5b2cf 100644 --- a/ghc/compiler/prelude/PrimOp.lhs +++ b/ghc/compiler/prelude/PrimOp.lhs @@ -38,7 +38,7 @@ import OccName ( OccName, pprOccName, mkVarOcc ) import TyCon ( TyCon, tyConArity ) import Type ( Type, mkForAllTys, mkFunTy, mkFunTys, mkTyVarTys, mkTyConApp, typePrimRep, - splitFunTy_maybe, splitAlgTyConApp_maybe, splitTyConApp_maybe, + splitFunTy_maybe, splitAlgTyConApp_maybe, splitTyConApp, mkUTy, usOnce, usMany ) import Unique ( Unique, mkPrimOpIdUnique ) @@ -511,11 +511,9 @@ inFun op f g ty Nothing -> pprPanic "primOpUsg:inFun" (ppr op <+> ppr ty) inUB op fs ty - = case splitTyConApp_maybe ty of - Just (tc,tys) -> ASSERT( tc == tupleTyCon Unboxed (length fs) ) - mkTupleTy Unboxed (length fs) (zipWithEqual "primOpUsg" - ($) fs tys) - Nothing -> pprPanic "primOpUsg:inUB" (ppr op <+> ppr ty) + = case splitTyConApp ty of + (tc,tys) -> ASSERT( tc == tupleTyCon Unboxed (length fs) ) + mkTupleTy Unboxed (length fs) (zipWithEqual "primOpUsg" ($) fs tys) \end{code} \begin{code} diff --git a/ghc/compiler/simplCore/CSE.lhs b/ghc/compiler/simplCore/CSE.lhs index c659230..69b35be 100644 --- a/ghc/compiler/simplCore/CSE.lhs +++ b/ghc/compiler/simplCore/CSE.lhs @@ -14,7 +14,7 @@ import CmdLineOpts ( DynFlag(..), DynFlags, dopt ) import Id ( Id, idType ) import CoreUtils ( hashExpr, cheapEqExpr, exprIsBig, mkAltExpr ) import DataCon ( isUnboxedTupleCon ) -import Type ( splitTyConApp_maybe ) +import Type ( tyConAppArgs ) import Subst ( InScopeSet, uniqAway, emptyInScopeSet, extendInScopeSet, elemInScopeSet ) import CoreSyn @@ -170,9 +170,7 @@ cseAlts env scrut' bndr bndr' alts other -> (bndr', extendCSEnv env bndr' scrut') -- See "yet another wrinkle" -- map: scrut' -> bndr' - arg_tys = case splitTyConApp_maybe (idType bndr) of - Just (_, arg_tys) -> arg_tys - other -> pprPanic "cseAlts" (ppr bndr) + arg_tys = tyConAppArgs (idType bndr) cse_alt (DataAlt con, args, rhs) | not (null args || isUnboxedTupleCon con) diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs index e8a6433..fc9cd21 100644 --- a/ghc/compiler/simplCore/SimplUtils.lhs +++ b/ghc/compiler/simplCore/SimplUtils.lhs @@ -35,7 +35,7 @@ import Name ( setNameUnique ) import Demand ( isStrict ) import SimplMonad import Type ( Type, mkForAllTys, seqType, repType, - splitTyConApp_maybe, mkTyVarTys, splitFunTys, + splitTyConApp_maybe, tyConAppArgs, mkTyVarTys, splitFunTys, isDictTy, isDataType, isUnLiftedType, splitRepFunTys ) @@ -854,8 +854,7 @@ mkCase scrut case_bndr alts (mkConApp con (map Type arg_tys ++ map varToCoreExpr args)) identity_alt other = False - arg_tys = case splitTyConApp_maybe (idType case_bndr) of - Just (tycon, arg_tys) -> arg_tys + arg_tys = tyConAppArgs (idType case_bndr) \end{code} The catch-all case diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index e654e0d..e027f33 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -50,7 +50,7 @@ import CoreUtils ( cheapEqExpr, exprIsDupable, exprIsTrivial, exprIsConApp_maybe import Rules ( lookupRule ) import CostCentre ( currentCCS ) import Type ( mkTyVarTys, isUnLiftedType, seqType, - mkFunTy, splitTyConApp_maybe, + mkFunTy, splitTyConApp_maybe, tyConAppArgs, funResultTy ) import Subst ( mkSubst, substTy, @@ -1344,8 +1344,7 @@ prepareCaseAlts _ _ scrut_cons alts simplAlts zap_occ_info scrut_cons case_bndr' alts cont' = mapSmpl simpl_alt alts where - inst_tys' = case splitTyConApp_maybe (idType case_bndr') of - Just (tycon, inst_tys) -> inst_tys + inst_tys' = tyConAppArgs (idType case_bndr') -- handled_cons is all the constructors that are dealt -- with, either by being impossible, or by there being an alternative diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index 248453b..c69ae37 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -32,7 +32,7 @@ import Name ( setNameUnique ) import VarEnv import PrimOp ( PrimOp(..), setCCallUnique ) import Type ( isUnLiftedType, isUnboxedTupleType, Type, splitFunTy_maybe, - applyTy, repType, seqType, splitTyConApp_maybe, + applyTy, repType, seqType, splitTyConApp_maybe, splitTyConApp, splitRepFunTys, mkFunTys, uaUTy, usOnce, usMany, isTyVarTy ) @@ -667,9 +667,8 @@ mkStgAlgAlts ty alts deflt other -> StgAlgAlts Nothing alts deflt mkStgPrimAlts ty alts deflt - = case splitTyConApp_maybe ty of - Just (tc,_) -> StgPrimAlts tc alts deflt - Nothing -> pprPanic "mkStgAlgAlts" (ppr ty) + = case splitTyConApp ty of + (tc,_) -> StgPrimAlts tc alts deflt mkStgLam ty bndrs body = seqType ty `seq` StgLam ty bndrs body diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index f3ab742..feb9442 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -52,7 +52,7 @@ import VarSet import Type ( Type, tyVarsOfTypes, splitDFunTy, splitForAllTys, splitRhoTy, - getDFunTyKey, splitTyConApp_maybe + getDFunTyKey, tyConAppTyCon ) import DataCon ( DataCon ) import TyCon ( TyCon ) @@ -529,9 +529,7 @@ simpleInstInfoTy info = case splitDFunTy (idType (iDFunId info)) of simpleInstInfoTyCon :: InstInfo -> TyCon -- Gets the type constructor for a simple instance declaration, -- i.e. one of the form instance (...) => C (T a b c) where ... -simpleInstInfoTyCon inst - = case splitTyConApp_maybe (simpleInstInfoTy inst) of - Just (tycon, _) -> tycon +simpleInstInfoTyCon inst = tyConAppTyCon (simpleInstInfoTy inst) \end{code} diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 48f97dc..65c328c 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -4,7 +4,7 @@ \section[TcExpr]{Typecheck an expression} \begin{code} -module TcExpr ( tcApp, tcExpr, tcPolyExpr, tcId ) where +module TcExpr ( tcApp, tcExpr, tcMonoExpr, tcPolyExpr, tcId ) where #include "HsVersions.h" diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index ff885c7..ea69f29 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -5,8 +5,7 @@ \begin{code} module TcModule ( - typecheckModule, - TcResults(..) + typecheckModule, typecheckExpr, TcResults(..) ) where #include "HsVersions.h" @@ -14,17 +13,20 @@ module TcModule ( import CmdLineOpts ( DynFlag(..), DynFlags, opt_PprStyle_Debug ) import HsSyn ( HsBinds(..), MonoBinds(..), HsDecl(..) ) import HsTypes ( toHsType ) -import RnHsSyn ( RenamedHsDecl ) -import TcHsSyn ( TypecheckedMonoBinds, +import RnHsSyn ( RenamedHsDecl, RenamedHsExpr ) +import TcHsSyn ( TypecheckedMonoBinds, TypecheckedHsExpr, TypecheckedForeignDecl, TypecheckedRuleDecl, - zonkTopBinds, zonkForeignExports, zonkRules + zonkTopBinds, zonkForeignExports, zonkRules, mkHsLet ) + import TcMonad +import TcType ( newTyVarTy ) import Inst ( plusLIE ) import TcBinds ( tcTopBinds ) import TcClassDcl ( tcClassDecls2, mkImplicitClassBinds ) import TcDefaults ( tcDefaults ) +import TcExpr ( tcMonoExpr ) import TcEnv ( TcEnv, InstInfo(iDFunId), tcExtendGlobalValEnv, tcEnvTyCons, tcEnvClasses, isLocalThing, tcSetEnv, tcSetInstEnv, initTcEnv, getTcGEnv @@ -38,7 +40,7 @@ import TcTyClsDecls ( tcTyAndClassDecls ) import TcTyDecls ( mkImplicitDataBinds ) import CoreUnfold ( unfoldingTemplate ) -import Type ( funResultTy, splitForAllTys ) +import Type ( funResultTy, splitForAllTys, openTypeKind ) import Bag ( isEmptyBag ) import ErrUtils ( printErrorsAndWarnings, dumpIfSet_dyn, showPass ) import Id ( idType, idUnfolding ) @@ -86,24 +88,52 @@ typecheckModule -> IO (Maybe TcResults) typecheckModule dflags this_mod pcs hst mod_iface unqual decls + = do { maybe_tc_result <- typecheck dflags pcs hst unqual $ + tcModule pcs hst get_fixity this_mod decls + ; printTcDump dflags maybe_tc_result + ; return maybe_tc_result } + where + fixity_env = mi_fixities mod_iface + + get_fixity :: Name -> Maybe Fixity + get_fixity nm = lookupNameEnv fixity_env nm + +--------------- +typecheckExpr :: DynFlags + -> PersistentCompilerState + -> HomeSymbolTable + -> PrintUnqualified -- For error printing + -> RenamedHsExpr + -> IO (Maybe TypecheckedHsExpr) + +typecheckExpr dflags pcs hst unqual expr + = typecheck dflags pcs hst unqual $ + newTyVarTy openTypeKind `thenTc` \ ty -> + tcMonoExpr expr ty `thenTc` \ (expr', lie) -> + tcSimplifyTop lie `thenTc` \ binds -> + returnTc (mkHsLet binds expr') + +--------------- +typecheck :: DynFlags + -> PersistentCompilerState + -> HomeSymbolTable + -> PrintUnqualified -- For error printing + -> TcM r + -> IO (Maybe r) + +typecheck dflags pcs hst unqual thing_inside = do { showPass dflags "Typechecker"; ; env <- initTcEnv hst (pcs_PTE pcs) - ; (maybe_tc_result, (warns,errs)) <- initTc dflags env (tcModule pcs hst get_fixity this_mod decls) + ; (maybe_tc_result, (warns,errs)) <- initTc dflags env thing_inside ; printErrorsAndWarnings unqual (errs,warns) - ; printTcDump dflags maybe_tc_result ; if isEmptyBag errs then return maybe_tc_result else return Nothing } - where - fixity_env = mi_fixities mod_iface - - get_fixity :: Name -> Maybe Fixity - get_fixity nm = lookupNameEnv fixity_env nm \end{code} The internal monster: diff --git a/ghc/compiler/types/InstEnv.lhs b/ghc/compiler/types/InstEnv.lhs index ad2bd1f..c4b667f 100644 --- a/ghc/compiler/types/InstEnv.lhs +++ b/ghc/compiler/types/InstEnv.lhs @@ -22,7 +22,7 @@ import VarSet ( TyVarSet, unionVarSet, mkVarSet ) import VarEnv ( TyVarSubstEnv ) import Maybes ( MaybeErr(..), returnMaB, failMaB, thenMaB, maybeToBool ) import Name ( getSrcLoc ) -import Type ( Type, splitTyConApp_maybe, +import Type ( Type, tyConAppTyCon, splitSigmaTy, splitDFunTy, tyVarsOfTypes ) import PprType ( ) @@ -54,8 +54,7 @@ simpleDFunClassTyCon dfun = (clas, tycon) where (_,_,clas,[ty]) = splitDFunTy (idType dfun) - tycon = case splitTyConApp_maybe ty of - Just (tycon,_) -> tycon + tycon = tyConAppTyCon ty \end{code} %************************************************************************ diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index 18f4b8e..bc2d94c 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -33,7 +33,9 @@ module Type ( mkFunTy, mkFunTys, splitFunTy, splitFunTy_maybe, splitFunTys, splitFunTysN, funResultTy, funArgTy, zipFunTys, - mkTyConApp, mkTyConTy, splitTyConApp_maybe, + mkTyConApp, mkTyConTy, + tyConAppTyCon, tyConAppArgs, + splitTyConApp_maybe, splitTyConApp, splitAlgTyConApp_maybe, splitAlgTyConApp, mkUTy, splitUTy, splitUTy_maybe, @@ -340,6 +342,21 @@ mkTyConTy tycon = ASSERT( not (isSynTyCon tycon) ) -- mean a distinct type, but all other type-constructor applications -- including functions are returned as Just .. +tyConAppTyCon :: Type -> TyCon +tyConAppTyCon ty = case splitTyConApp_maybe ty of + Just (tc,_) -> tc + Nothing -> pprPanic "tyConAppTyCon" (pprType ty) + +tyConAppArgs :: Type -> [Type] +tyConAppArgs ty = case splitTyConApp_maybe ty of + Just (_,args) -> args + Nothing -> pprPanic "tyConAppArgs" (pprType ty) + +splitTyConApp :: Type -> (TyCon, [Type]) +splitTyConApp ty = case splitTyConApp_maybe ty of + Just stuff -> stuff + Nothing -> pprPanic "splitTyConApp" (pprType ty) + splitTyConApp_maybe :: Type -> Maybe (TyCon, [Type]) splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) splitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [unUTy arg,unUTy res]) diff --git a/ghc/compiler/usageSP/UsageSPInf.lhs b/ghc/compiler/usageSP/UsageSPInf.lhs index ba3291d..e745689 100644 --- a/ghc/compiler/usageSP/UsageSPInf.lhs +++ b/ghc/compiler/usageSP/UsageSPInf.lhs @@ -22,7 +22,7 @@ import CoreFVs ( mustHaveLocalBinding ) import Rules ( RuleBase ) import TypeRep ( Type(..), TyNote(..) ) -- friend import Type ( applyTy, applyTys, - splitFunTy_maybe, splitFunTys, splitTyConApp_maybe, + splitFunTy_maybe, splitFunTys, splitTyConApp, mkFunTy, mkForAllTy ) import TyCon ( tyConArgVrcs_maybe, isFunTyCon ) import Literal ( Literal(..), literalType ) @@ -352,7 +352,7 @@ usgInfCE ve e0@(Case e1 v1 alts) (e2,y2u,h2,f2) <- usgInfCE ve e1 let h3 = usgEqTy y2u y1u -- **! why not subty? (u2,y2) = splitUsgTy y2u - (tc,y2s) = expectJust "usgInfCE:Case" $ splitTyConApp_maybe y2 + (tc,y2s) = splitTyConApp y2 (cs,v1ss,es) = unzip3 alts v2ss = map (map (\ v -> setVarType v (mkUsgTy u2 (annotManyN (varType v))))) v1ss