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

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