TyCoRep: Implement some helpers for dropping/checking Levity arguments
authorÖmer Sinan Ağacan <omeragacan@gmail.com>
Tue, 2 Feb 2016 01:15:21 +0000 (20:15 -0500)
committerÖmer Sinan Ağacan <omeragacan@gmail.com>
Tue, 2 Feb 2016 01:16:37 +0000 (20:16 -0500)
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

compiler/ghci/RtClosureInspect.hs
compiler/types/TyCoRep.hs
compiler/types/Type.hs

index 2dca546..d7922c5 100644 (file)
@@ -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
index 758ac25..3576fdd 100644 (file)
@@ -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
+
 {-
 %************************************************************************
 %*                                                                      *
index 43aad5b..12befed 100644 (file)
@@ -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