[commit: ghc] master: TyCoRep: Implement some helpers for dropping/checking Levity arguments (af8fdb9)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/af8fdb97c27d6ba4c8f4ffffc2bdc2eceba61bf1/ghc

>---------------------------------------------------------------

commit af8fdb97c27d6ba4c8f4ffffc2bdc2eceba61bf1
Author: Ömer Sinan Ağacan <omeragacan at gmail.com>
Date:   Mon Feb 1 20:15:21 2016 -0500

    TyCoRep: Implement some helpers for dropping/checking Levity arguments
    
    Also fix `isLevityTy` (it should use `coreView`) and start using
    `dropLevityArgs` in some places.
    
    Reviewers: goldfire, simonpj, austin, hvr, bgamari
    
    Reviewed By: simonpj
    
    Subscribers: thomie
    
    Differential Revision: https://phabricator.haskell.org/D1867


>---------------------------------------------------------------

af8fdb97c27d6ba4c8f4ffffc2bdc2eceba61bf1
 compiler/ghci/RtClosureInspect.hs |  2 +-
 compiler/types/TyCoRep.hs         | 18 ++++++++++++++++--
 compiler/types/Type.hs            |  6 ++++--
 3 files changed, 21 insertions(+), 5 deletions(-)

diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
index 2dca546..d7922c5 100644
--- a/compiler/ghci/RtClosureInspect.hs
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -804,7 +804,7 @@ extractSubTerms recurse clos = liftM thdOf3 . go 0 (nonPtrs clos)
       | Just (tc, elem_tys) <- tcSplitTyConApp_maybe ty
       , isUnboxedTupleTyCon tc
                 -- See Note [Unboxed tuple levity vars] in TyCon
-      = do (ptr_i, ws, terms0) <- go ptr_i ws (drop (length elem_tys `div` 2) elem_tys)
+      = do (ptr_i, ws, terms0) <- go ptr_i ws (dropLevityArgs elem_tys)
            (ptr_i, ws, terms1) <- go ptr_i ws tys
            return (ptr_i, ws, unboxedTupleTerm ty terms0 : terms1)
       | otherwise
diff --git a/compiler/types/TyCoRep.hs b/compiler/types/TyCoRep.hs
index 758ac25..3576fdd 100644
--- a/compiler/types/TyCoRep.hs
+++ b/compiler/types/TyCoRep.hs
@@ -39,6 +39,7 @@ module TyCoRep (
         mkFunTy, mkFunTys,
         isLiftedTypeKind, isUnliftedTypeKind,
         isCoercionType, isLevityTy, isLevityVar,
+        isLevityKindedTy, dropLevityArgs,
         sameVis,
 
         -- Functions over binders
@@ -120,7 +121,7 @@ module TyCoRep (
 import {-# SOURCE #-} DataCon( dataConTyCon, dataConFullSig
                               , DataCon, eqSpecTyVar )
 import {-# SOURCE #-} Type( isPredTy, isCoercionTy, mkAppTy
-                          , partitionInvisibles, coreView )
+                          , partitionInvisibles, coreView, typeKind )
    -- Transitively pulls in a LOT of stuff, better to break the loop
 
 import {-# SOURCE #-} Coercion
@@ -523,13 +524,26 @@ isUnliftedTypeKind _ = False
 
 -- | Is this the type 'Levity'?
 isLevityTy :: Type -> Bool
+isLevityTy ty | Just ty' <- coreView ty = isLevityTy ty'
 isLevityTy (TyConApp tc []) = tc `hasKey` levityTyConKey
-isLevityTy _                = False
+isLevityTy _ = False
+
+-- | Is this a type of kind Levity? (e.g. Lifted, Unlifted)
+isLevityKindedTy :: Type -> Bool
+isLevityKindedTy = isLevityTy . typeKind
 
 -- | Is a tyvar of type 'Levity'?
 isLevityVar :: TyVar -> Bool
 isLevityVar = isLevityTy . tyVarKind
 
+-- | Drops prefix of Levity constructors in 'TyConApp's. Useful for e.g.
+-- dropping 'Lifted and 'Unlifted arguments of unboxed tuple TyCon applications:
+--
+--   dropLevityArgs ['Lifted, 'Unlifted, String, Int#] == [String, Int#]
+--
+dropLevityArgs :: [Type] -> [Type]
+dropLevityArgs = dropWhile isLevityKindedTy
+
 {-
 %************************************************************************
 %*                                                                      *
diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs
index 43aad5b..12befed 100644
--- a/compiler/types/Type.hs
+++ b/compiler/types/Type.hs
@@ -103,7 +103,9 @@ module Type (
         -- (Lifting and boxity)
         isUnliftedType, isUnboxedTupleType, isAlgType, isClosedAlgType,
         isPrimitiveType, isStrictType,
-        isLevityTy, isLevityVar, getLevity, getLevityFromKind,
+        isLevityTy, isLevityVar, isLevityKindedTy,
+        dropLevityArgs,
+        getLevity, getLevityFromKind,
 
         -- * Main data types representing Kinds
         Kind,
@@ -1134,7 +1136,7 @@ repType ty
          else UbxTupleRep (concatMap (flattenRepType . go rec_nts) non_levity_tys)
       where
           -- See Note [Unboxed tuple levity vars] in TyCon
-        non_levity_tys = drop (length tys `div` 2) tys
+        non_levity_tys = dropLevityArgs tys
 
     go rec_nts (CastTy ty _)
       = go rec_nts ty