[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.)

ghc/compiler/codeGen/CgExpr.lhs

 %
 % (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}

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)

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 ->

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}

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 ->
+
+	
 
 
 %************************************************************************

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}

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}

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)

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

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

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
 

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}
 
 

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"
 

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:

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}		      
 
 %************************************************************************

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])

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