summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/basicTypes/Id.lhs6
-rw-r--r--compiler/codeGen/ClosureInfo.lhs6
-rw-r--r--compiler/codeGen/StgCmmClosure.hs6
-rw-r--r--compiler/coreSyn/CoreLint.lhs13
-rw-r--r--compiler/deSugar/DsCCall.lhs10
-rw-r--r--compiler/deSugar/DsForeign.lhs4
-rw-r--r--compiler/ghci/ByteCodeGen.lhs6
-rw-r--r--compiler/specialise/SpecConstr.lhs6
-rw-r--r--compiler/stgSyn/CoreToStg.lhs16
-rw-r--r--compiler/stgSyn/StgLint.lhs8
-rw-r--r--compiler/stranal/DmdAnal.lhs4
-rw-r--r--compiler/stranal/WwLib.lhs2
-rw-r--r--compiler/typecheck/TcType.lhs3
-rw-r--r--compiler/types/Coercion.lhs2
-rw-r--r--compiler/types/Type.lhs26
15 files changed, 66 insertions, 52 deletions
diff --git a/compiler/basicTypes/Id.lhs b/compiler/basicTypes/Id.lhs
index 0f90bf0327..a62d8a8e1f 100644
--- a/compiler/basicTypes/Id.lhs
+++ b/compiler/basicTypes/Id.lhs
@@ -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
diff --git a/compiler/codeGen/ClosureInfo.lhs b/compiler/codeGen/ClosureInfo.lhs
index 60f1bda7f5..8bfbfed0bc 100644
--- a/compiler/codeGen/ClosureInfo.lhs
+++ b/compiler/codeGen/ClosureInfo.lhs
@@ -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.
diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs
index 2492bafc6c..daaf021f03 100644
--- a/compiler/codeGen/StgCmmClosure.hs
+++ b/compiler/codeGen/StgCmmClosure.hs
@@ -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
diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs
index 6a23b10002..7bc82cf607 100644
--- a/compiler/coreSyn/CoreLint.lhs
+++ b/compiler/coreSyn/CoreLint.lhs
@@ -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
diff --git a/compiler/deSugar/DsCCall.lhs b/compiler/deSugar/DsCCall.lhs
index 58ebc26b2b..9adbac181f 100644
--- a/compiler/deSugar/DsCCall.lhs
+++ b/compiler/deSugar/DsCCall.lhs
@@ -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
diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs
index 6d73d1d2bb..d425214f97 100644
--- a/compiler/deSugar/DsForeign.lhs
+++ b/compiler/deSugar/DsForeign.lhs
@@ -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
diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs
index cd4b60da27..e8df54c7c6 100644
--- a/compiler/ghci/ByteCodeGen.lhs
+++ b/compiler/ghci/ByteCodeGen.lhs
@@ -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
diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs
index 6cc05a3dc6..f126bdac47 100644
--- a/compiler/specialise/SpecConstr.lhs
+++ b/compiler/specialise/SpecConstr.lhs
@@ -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
diff --git a/compiler/stgSyn/CoreToStg.lhs b/compiler/stgSyn/CoreToStg.lhs
index df8fabe710..9d555f12c5 100644
--- a/compiler/stgSyn/CoreToStg.lhs
+++ b/compiler/stgSyn/CoreToStg.lhs
@@ -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
diff --git a/compiler/stgSyn/StgLint.lhs b/compiler/stgSyn/StgLint.lhs
index d59e460c03..945d6c96d6 100644
--- a/compiler/stgSyn/StgLint.lhs
+++ b/compiler/stgSyn/StgLint.lhs
@@ -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
diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
index afa722fa8a..fab75a0601 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -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
diff --git a/compiler/stranal/WwLib.lhs b/compiler/stranal/WwLib.lhs
index 1b8b270024..7627ac9b04 100644
--- a/compiler/stranal/WwLib.lhs
+++ b/compiler/stranal/WwLib.lhs
@@ -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
diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index e32ca92f96..6602c79f89 100644
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@ -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")
diff --git a/compiler/types/Coercion.lhs b/compiler/types/Coercion.lhs
index a162255794..db7f96f0a7 100644
--- a/compiler/types/Coercion.lhs
+++ b/compiler/types/Coercion.lhs
@@ -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}
diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs
index bf595ef10e..2dc77824bd 100644
--- a/compiler/types/Type.lhs
+++ b/compiler/types/Type.lhs
@@ -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
View Lorry Controller Status