Commit ea659be5 authored by simonpj's avatar simonpj

[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.)
parent 894a5792
%
% (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}
......@@ -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)
......
......@@ -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 ->
......
......@@ -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}
......@@ -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 ->
%************************************************************************
......
......@@ -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}
......
......@@ -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}
......
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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}
......
......@@ -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"
......
......@@ -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:
......
......@@ -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}
%************************************************************************
......
......@@ -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])
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment