Commit 1bcd32b8 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Add Type.tyConAppTyCon_maybe and tyConAppArgs_maybe, and use them

These turn out to be a useful special case of splitTyConApp_maybe.

A refactoring only; no change in behaviour
parent c679ce14
......@@ -619,9 +619,9 @@ isStateHackType ty
| opt_NoStateHack
= False
| otherwise
= case splitTyConApp_maybe ty of
Just (tycon,_) -> tycon == statePrimTyCon
_ -> False
= case tyConAppTyCon_maybe ty of
Just tycon -> tycon == statePrimTyCon
_ -> False
-- This is a gross hack. It claims that
-- every function over realWorldStatePrimTy is a one-shot
-- function. This is pretty true in practice, and makes a big
......
......@@ -268,9 +268,9 @@ might_be_a_function :: Type -> Bool
-- Return False only if we are *sure* it's a data type
-- Look through newtypes etc as much as poss
might_be_a_function ty
= case splitTyConApp_maybe (repType ty) of
Just (tc, _) -> not (isDataTyCon tc)
Nothing -> True
= case tyConAppTyCon_maybe (repType ty) of
Just tc -> not (isDataTyCon tc)
Nothing -> True
\end{code}
@mkConLFInfo@ is similar, for constructors.
......
......@@ -255,9 +255,9 @@ might_be_a_function :: Type -> Bool
-- Return False only if we are *sure* it's a data type
-- Look through newtypes etc as much as poss
might_be_a_function ty
= case splitTyConApp_maybe (repType ty) of
Just (tc, _) -> not (isDataTyCon tc)
Nothing -> True
= case tyConAppTyCon_maybe (repType ty) of
Just tc -> not (isDataTyCon tc)
Nothing -> True
-------------
mkConLFInfo :: DataCon -> LambdaFormInfo
......
......@@ -304,9 +304,8 @@ lintCoreExpr e@(Case scrut var alt_ty alts) =
; alt_ty <- lintInTy alt_ty
; var_ty <- lintInTy (idType var)
; let mb_tc_app = splitTyConApp_maybe (idType var)
; case mb_tc_app of
Just (tycon, _)
; case tyConAppTyCon_maybe (idType var) of
Just tycon
| debugIsOn &&
isAlgTyCon tycon &&
not (isFamilyTyCon tycon || isAbstractTyCon tycon) &&
......@@ -478,9 +477,9 @@ checkCaseAlts e ty alts =
non_deflt (DEFAULT, _, _) = False
non_deflt _ = True
is_infinite_ty = case splitTyConApp_maybe ty of
Nothing -> False
Just (tycon, _) -> isPrimTyCon tycon
is_infinite_ty = case tyConAppTyCon_maybe ty of
Nothing -> False
Just tycon -> isPrimTyCon tycon
\end{code}
\begin{code}
......@@ -696,7 +695,7 @@ lintCoercion (InstCo co arg_ty)
----------
checkTcApp :: Coercion -> Int -> Type -> LintM Type
checkTcApp co n ty
| Just (_, tys) <- splitTyConApp_maybe ty
| Just tys <- tyConAppArgs_maybe ty
, n < length tys
= return (tys !! n)
| otherwise
......
......@@ -138,7 +138,7 @@ unboxArg arg
= unboxArg (mkCoerce co arg)
-- Booleans
| Just (tc,_) <- splitTyConApp_maybe arg_ty,
| Just tc <- tyConAppTyCon_maybe arg_ty,
tc `hasKey` boolTyConKey
= do prim_arg <- newSysLocalDs intPrimTy
return (Var prim_arg,
......@@ -225,8 +225,8 @@ unboxArg arg
(data_con_arg_ty1 : _) = data_con_arg_tys
(_ : _ : data_con_arg_ty3 : _) = data_con_arg_tys
maybe_arg3_tycon = splitTyConApp_maybe data_con_arg_ty3
Just (arg3_tycon,_) = maybe_arg3_tycon
maybe_arg3_tycon = tyConAppTyCon_maybe data_con_arg_ty3
Just arg3_tycon = maybe_arg3_tycon
\end{code}
......@@ -259,7 +259,7 @@ boxResult result_ty
= case res of
(Just ty,_)
| isUnboxedTupleType ty
-> let (Just (_, ls)) = splitTyConApp_maybe ty in tail ls
-> let Just ls = tyConAppArgs_maybe ty in tail ls
_ -> []
return_result state anss
......@@ -320,7 +320,7 @@ mk_alt return_result (Just prim_res_ty, wrap_result)
-- The ccall returns a non-() value
| isUnboxedTupleType prim_res_ty= do
let
Just (_, ls) = splitTyConApp_maybe prim_res_ty
Just ls = tyConAppArgs_maybe prim_res_ty
arity = 1 + length ls
args_ids@(result_id:as) <- mapM newSysLocalDs ls
state_id <- newSysLocalDs realWorldStatePrimTy
......
......@@ -135,8 +135,8 @@ dsCImport :: Id
-> DsM ([Binding], SDoc, SDoc)
dsCImport id (CLabel cid) cconv _ = do
let ty = idType id
fod = case splitTyConApp_maybe (repType ty) of
Just (tycon, _)
fod = case tyConAppTyCon_maybe (repType ty) of
Just tycon
| tyConUnique tycon == funPtrTyConKey ->
IsFunction
_ -> IsData
......
......@@ -631,7 +631,7 @@ schemeT d s p app
-- Detect and extract relevant info for the tagToEnum kludge.
maybe_is_tagToEnum_call
= let extract_constr_Names ty
| Just (tyc, _) <- splitTyConApp_maybe (repType ty),
| Just tyc <- tyConAppTyCon_maybe (repType ty),
isDataTyCon tyc
= map (getName . dataConWorkId) (tyConDataCons tyc)
-- NOTE: use the worker name, not the source name of
......@@ -929,10 +929,10 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
pargs d (a:az)
= let arg_ty = repType (exprType (deAnnotate' a))
in case splitTyConApp_maybe arg_ty of
in case tyConAppTyCon_maybe arg_ty of
-- Don't push the FO; instead push the Addr# it
-- contains.
Just (t, _)
Just t
| t == arrayPrimTyCon || t == mutableArrayPrimTyCon
-> do rest <- pargs (d + addr_sizeW) az
code <- parg_ArrayishRep (fromIntegral arrPtrsHdrSize) d p a
......
......@@ -809,9 +809,9 @@ forceSpecBndr _ _ = False
ignoreDataCon env dc = ignoreTyCon env (dataConTyCon dc)
ignoreType env ty
= case splitTyConApp_maybe ty of
Just (tycon, _) -> ignoreTyCon env tycon
_ -> False
= case tyConAppTyCon_maybe ty of
Just tycon -> ignoreTyCon env tycon
_ -> False
ignoreTyCon :: ScEnv -> TyCon -> Bool
ignoreTyCon env tycon
......
......@@ -433,14 +433,14 @@ coreToStgExpr e = pprPanic "coreToStgExpr" (ppr e)
\begin{code}
mkStgAltType :: Id -> [CoreAlt] -> AltType
mkStgAltType bndr alts
= case splitTyConApp_maybe (repType (idType bndr)) of
Just (tc,_) | isUnboxedTupleTyCon tc -> UbxTupAlt tc
| isUnLiftedTyCon tc -> PrimAlt tc
| isHiBootTyCon tc -> look_for_better_tycon
| isAlgTyCon tc -> AlgAlt tc
| otherwise -> ASSERT2( _is_poly_alt_tycon tc, ppr tc )
PolyAlt
Nothing -> PolyAlt
= case tyConAppTyCon_maybe (repType (idType bndr)) of
Just tc | isUnboxedTupleTyCon tc -> UbxTupAlt tc
| isUnLiftedTyCon tc -> PrimAlt tc
| isHiBootTyCon tc -> look_for_better_tycon
| isAlgTyCon tc -> AlgAlt tc
| otherwise -> ASSERT2( _is_poly_alt_tycon tc, ppr tc )
PolyAlt
Nothing -> PolyAlt
where
_is_poly_alt_tycon tc
......
......@@ -207,9 +207,9 @@ lintStgExpr (StgCase scrut _ _ bndr _ alts_type alts) = runMaybeT $ do
lintStgAlts alts scrut_ty
where
scrut_ty = idType bndr
check_bndr tc = case splitTyConApp_maybe (repType scrut_ty) of
Just (bndr_tc, _) -> checkL (tc == bndr_tc) bad_bndr
Nothing -> addErrL bad_bndr
check_bndr tc = case tyConAppTyCon_maybe (repType scrut_ty) of
Just bndr_tc -> checkL (tc == bndr_tc) bad_bndr
Nothing -> addErrL bad_bndr
where
bad_bndr = mkDefltMsg bndr tc
......@@ -413,7 +413,7 @@ checkFunApp fun_ty arg_tys msg
(Nothing, Nothing) -- This is odd, but I've seen it
else cfa False (newTyConInstRhs tc tc_args) arg_tys
| Just (tc,_) <- splitTyConApp_maybe fun_ty
| Just tc <- tyConAppTyCon_maybe fun_ty
, not (isSynFamilyTyCon tc) -- Definite error
= (Nothing, Just msg) -- Too many args
......
......@@ -35,7 +35,7 @@ import TysWiredIn ( unboxedPairDataCon )
import TysPrim ( realWorldStatePrimTy )
import UniqFM ( addToUFM_Directly, lookupUFM_Directly,
minusUFM, filterUFM )
import Type ( isUnLiftedType, eqType, splitTyConApp_maybe )
import Type ( isUnLiftedType, eqType, tyConAppTyCon_maybe )
import Coercion ( coercionKind )
import Util ( mapAndUnzip, lengthIs, zipEqual )
import BasicTypes ( Arity, TopLevelFlag(..), isTopLevel, isNeverActive,
......@@ -157,7 +157,7 @@ dmdAnal env dmd (Cast e co)
(dmd_ty, e') = dmdAnal env dmd' e
to_co = pSnd (coercionKind co)
dmd'
| Just (tc, _) <- splitTyConApp_maybe to_co
| Just tc <- tyConAppTyCon_maybe to_co
, isRecursiveTyCon tc = evalDmd
| otherwise = dmd
-- This coerce usually arises from a recursive
......
......@@ -515,7 +515,7 @@ mk_absent_let :: Id -> Maybe (CoreExpr -> CoreExpr)
mk_absent_let arg
| not (isUnLiftedType arg_ty)
= Just (Let (NonRec arg abs_rhs))
| Just (tc, _) <- splitTyConApp_maybe arg_ty
| Just tc <- tyConAppTyCon_maybe arg_ty
, Just lit <- absentLiteralOf tc
= Just (Let (NonRec arg (Lit lit)))
| arg_ty `eqType` realWorldStatePrimTy
......
......@@ -393,7 +393,8 @@ kind_var_occ = mkOccName tvName "k"
\begin{code}
pprTcTyVarDetails :: TcTyVarDetails -> SDoc
-- For debugging
pprTcTyVarDetails (SkolemTv {}) = ptext (sLit "sk")
pprTcTyVarDetails (SkolemTv True) = ptext (sLit "ssk")
pprTcTyVarDetails (SkolemTv False) = ptext (sLit "sk")
pprTcTyVarDetails (RuntimeUnk {}) = ptext (sLit "rt")
pprTcTyVarDetails (FlatSkol {}) = ptext (sLit "fsk")
pprTcTyVarDetails (MetaTv TauTv _) = ptext (sLit "tau")
......
......@@ -1073,7 +1073,7 @@ coercionKinds :: [Coercion] -> Pair [Type]
coercionKinds tys = sequenceA $ map coercionKind tys
getNth :: Int -> Type -> Type
getNth n ty | Just (_, tys) <- splitTyConApp_maybe ty
getNth n ty | Just tys <- tyConAppArgs_maybe ty
= ASSERT2( n < length tys, ppr n <+> ppr tys ) tys !! n
getNth n ty = pprPanic "getNth" (ppr n <+> ppr ty)
\end{code}
......
......@@ -34,7 +34,7 @@ module Type (
funResultTy, funArgTy, zipFunTys,
mkTyConApp, mkTyConTy,
tyConAppTyCon, tyConAppArgs,
tyConAppTyCon_maybe, tyConAppArgs_maybe, tyConAppTyCon, tyConAppArgs,
splitTyConApp_maybe, splitTyConApp,
mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys,
......@@ -154,6 +154,7 @@ import Util
import Outputable
import FastString
import Maybes ( orElse )
import Data.Maybe ( isJust )
infixr 3 `mkFunTy` -- Associates to the right
......@@ -476,12 +477,25 @@ funArgTy ty = pprPanic "funArgTy" (ppr ty)
-- including functions are returned as Just ..
-- | The same as @fst . splitTyConApp@
tyConAppTyCon_maybe :: Type -> Maybe TyCon
tyConAppTyCon_maybe ty | Just ty' <- coreView ty = tyConAppTyCon_maybe ty'
tyConAppTyCon_maybe (TyConApp tc _) = Just tc
tyConAppTyCon_maybe (FunTy {}) = Just funTyCon
tyConAppTyCon_maybe _ = Nothing
tyConAppTyCon :: Type -> TyCon
tyConAppTyCon ty = fst (splitTyConApp ty)
tyConAppTyCon ty = tyConAppTyCon_maybe ty `orElse` pprPanic "tyConAppTyCon" (ppr ty)
-- | The same as @snd . splitTyConApp@
tyConAppArgs_maybe :: Type -> Maybe [Type]
tyConAppArgs_maybe ty | Just ty' <- coreView ty = tyConAppArgs_maybe ty'
tyConAppArgs_maybe (TyConApp _ tys) = Just tys
tyConAppArgs_maybe (FunTy arg res) = Just [arg,res]
tyConAppArgs_maybe _ = Nothing
tyConAppArgs :: Type -> [Type]
tyConAppArgs ty = snd (splitTyConApp ty)
tyConAppArgs ty = tyConAppArgs_maybe ty `orElse` pprPanic "tyConAppArgs" (ppr ty)
-- | Attempts to tease a type apart into a type constructor and the application
-- of a number of arguments to that constructor. Panics if that is not possible.
......@@ -982,9 +996,9 @@ isUnLiftedType (TyConApp tc _) = isUnLiftedTyCon tc
isUnLiftedType _ = False
isUnboxedTupleType :: Type -> Bool
isUnboxedTupleType ty = case splitTyConApp_maybe ty of
Just (tc, _ty_args) -> isUnboxedTupleTyCon tc
_ -> False
isUnboxedTupleType ty = case tyConAppTyCon_maybe ty of
Just tc -> isUnboxedTupleTyCon tc
_ -> False
-- | See "Type#type_classification" for what an algebraic type is.
-- Should only be applied to /types/, as opposed to e.g. partially
......
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