Wibbles in response to Richard's commentswip/T9858-typeable-spj

12 files changed, 63 insertions, 31 deletions

diff --git a/compiler/coreSyn/CorePrep.hs b/compiler/coreSyn/CorePrep.hs
index 1e99e80018..6b0e3e9dd1 100644
--- a/compiler/coreSyn/CorePrep.hs
+++ b/compiler/coreSyn/CorePrep.hs
@@ -60,7 +60,7 @@ import MonadUtils       ( mapAccumLM )
 import Data.List        ( mapAccumL )
 import Control.Monad
 
-#if __GLASGOW_HASKELL__ < 711
+#if __GLASGOW_HASKELL__ < 709
 import Control.Applicative
 #endif
 
diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
index bd9fec375c..733b6dfe6f 100644
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -915,7 +915,6 @@ dsEvTypeable ty ev
 
 ds_ev_typeable :: Type -> EvTypeable -> DsM CoreExpr
 -- Returns a CoreExpr :: TypeRep (for ty)
--- together with ty
 ds_ev_typeable ty (EvTypeableTyCon ev_ts)
   | Just (tc, kts) <- splitTyConApp_maybe ty
   , (ks, ts) <- splitTyConArgs tc kts
diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs
index cec6837408..3bc29674e9 100644
--- a/compiler/prelude/PrelNames.hs
+++ b/compiler/prelude/PrelNames.hs
@@ -778,6 +778,7 @@ and it's convenient to write them all down in one place.
 -}
 
 mkSpecialTyConRepName :: FastString -> Name -> Name
+-- See Note [Grand plan for Typeable] in TcTypeable
 mkSpecialTyConRepName fs tc_name
   = mkExternalName (tyConRepNameUnique (nameUnique tc_name))
                    tYPEABLE_INTERNAL
@@ -785,18 +786,20 @@ mkSpecialTyConRepName fs tc_name
                    wiredInSrcSpan
 
 mkPrelTyConRepName :: Name -> Name
-mkPrelTyConRepName name  -- Prelude tc_name is always External,
+-- See Note [Grand plan for Typeable] in TcTypeable
+mkPrelTyConRepName tc_name  -- Prelude tc_name is always External,
                             -- so nameModule will work
-  = mkExternalName rep_uniq rep_mod rep_occ (nameSrcSpan name)
+  = mkExternalName rep_uniq rep_mod rep_occ (nameSrcSpan tc_name)
   where
-    name_occ = nameOccName name
-    name_mod = nameModule name
-    name_uniq = nameUnique name
+    name_occ  = nameOccName tc_name
+    name_mod  = nameModule  tc_name
+    name_uniq = nameUnique  tc_name
     rep_uniq | isTcOcc name_occ = tyConRepNameUnique   name_uniq
              | otherwise        = dataConRepNameUnique name_uniq
     (rep_mod, rep_occ) = tyConRepModOcc name_mod name_occ
 
 tyConRepModOcc :: Module -> OccName  -> (Module, OccName)
+-- See Note [Grand plan for Typeable] in TcTypeable
 tyConRepModOcc tc_module tc_occ
   | tc_module == gHC_TYPES
   = (tYPEABLE_INTERNAL, mkTyConRepUserOcc tc_occ)
diff --git a/compiler/prelude/TysPrim.hs b/compiler/prelude/TysPrim.hs
index 6ce7abdadb..793635bd3c 100644
--- a/compiler/prelude/TysPrim.hs
+++ b/compiler/prelude/TysPrim.hs
@@ -319,12 +319,15 @@ superKindTyConName, anyKindTyConName, liftedTypeKindTyConName,
       constraintKindTyConName
    :: Name
 
-mk_kind_tycon :: Name -> FastString -> TyCon
+mk_kind_tycon :: Name         -- Name of the kind constructor,      e.g. *
+              -> FastString   -- Name of the TyConRepName function  e.g. tcLiftedKind :: TyCon
+              -> TyCon        -- The kind constructor
 mk_kind_tycon tc_name rep_fs
   = mkKindTyCon tc_name superKind (mkSpecialTyConRepName rep_fs tc_name)
+    -- mkSpecialTyConRepName: see Note [Grand plan for Typeable] in TcTypeable
 
 superKindTyCon = mk_kind_tycon superKindTyConName (fsLit "tcBOX")
-   -- See Note [SuperKind (BOX)]
+    -- See Note [SuperKind (BOX)]
 
 anyKindTyCon          = mk_kind_tycon anyKindTyConName          (fsLit "tcAnyK")
 constraintKindTyCon   = mk_kind_tycon constraintKindTyConName   (fsLit "tcConstraint")
diff --git a/compiler/prelude/TysWiredIn.hs b/compiler/prelude/TysWiredIn.hs
index 9c53e153d0..3628c432d2 100644
--- a/compiler/prelude/TysWiredIn.hs
+++ b/compiler/prelude/TysWiredIn.hs
@@ -417,9 +417,9 @@ tupleCon UnboxedTuple i = snd (unboxedTupleArr ! i)
 tupleCon ConstraintTuple    i = snd (factTupleArr    ! i)
 
 boxedTupleArr, unboxedTupleArr, factTupleArr :: Array Int (TyCon,DataCon)
-boxedTupleArr   = listArray (0,mAX_TUPLE_SIZE) [mk_tuple BoxedTuple i | i <- [0..mAX_TUPLE_SIZE]]
-unboxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple UnboxedTuple i | i <- [0..mAX_TUPLE_SIZE]]
-factTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple ConstraintTuple i | i <- [0..mAX_TUPLE_SIZE]]
+boxedTupleArr   = listArray (0,mAX_TUPLE_SIZE) [mk_tuple BoxedTuple i      | i <- [0..mAX_TUPLE_SIZE]]
+unboxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple UnboxedTuple i    | i <- [0..mAX_TUPLE_SIZE]]
+factTupleArr    = listArray (0,mAX_TUPLE_SIZE) [mk_tuple ConstraintTuple i | i <- [0..mAX_TUPLE_SIZE]]
 
 mk_tuple :: TupleSort -> Int -> (TyCon,DataCon)
 mk_tuple sort arity = (tycon, tuple_con)
@@ -429,7 +429,7 @@ mk_tuple sort arity = (tycon, tuple_con)
         rep_nm  = case sort of
           BoxedTuple      -> Just (mkPrelTyConRepName tc_name)
           UnboxedTuple    -> Nothing
-          ConstraintTuple -> Just (mkPrelTyConRepName tc_name)  -- I think
+          ConstraintTuple -> Nothing   -- Constraints are not typeble
 
         prom_tc = case sort of
           BoxedTuple      -> Promoted (mkPromotedTyCon tycon (promoteKind tc_kind))
diff --git a/compiler/typecheck/TcEvidence.hs b/compiler/typecheck/TcEvidence.hs
index ced34b7369..9c131290d5 100644
--- a/compiler/typecheck/TcEvidence.hs
+++ b/compiler/typecheck/TcEvidence.hs
@@ -734,6 +734,7 @@ data EvTerm
 
 
 -- | Instructions on how to make a 'Typeable' dictionary.
+-- See Note [Typeable evidence terms]
 data EvTypeable
   = EvTypeableTyCon [EvTerm]
     -- ^ Dicitionary for Typeable (T k1..kn t1..tn)
@@ -767,7 +768,19 @@ data EvCallStack
     -- @?name@, occurring at @loc@, in a calling context @stk@.
   deriving( Data.Data, Data.Typeable )
 
-{-
+{- Note [Typeable evidence terms]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The EvTypeable data type looks isomorphic to Type, but the EvTerms
+inside can be EvIds.  Eg
+   f :: forall a. Typeable a => a -> TypeRep
+   f x = typeRep (undefined :: Proxy [a])
+Here for the (Typeable [a]) dictionary passed to typeRep we make
+evidence
+  dl :: Typeable [a] = EvTypeable [a] (EvTypeableTyCon [EvId d]
+where
+  d :: Typable a
+is the lambda-bound dictionary passed into f.
+
 Note [Coercion evidence terms]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 A "coercion evidence term" takes one of these forms
diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs
index 45463ba3a5..8c61602f12 100644
--- a/compiler/typecheck/TcInteract.hs
+++ b/compiler/typecheck/TcInteract.hs
@@ -14,10 +14,10 @@ import TcCanonical
 import TcFlatten
 import VarSet
 import Type
-import Kind (isKind)
+import Kind   ( isKind, isConstraintKind )
 import Unify
 import InstEnv( DFunInstType, lookupInstEnv, instanceDFunId )
-import CoAxiom(sfInteractTop, sfInteractInert)
+import CoAxiom( sfInteractTop, sfInteractInert )
 
 import Var
 import TcType
@@ -1876,7 +1876,8 @@ matchTypeableClass :: Class    -- The Typeable class
                    -> [Type]
                    -> CtLoc -> TcS LookupInstResult
 matchTypeableClass clas [k, t] loc
-  | isForAllTy k                            = return NoInstance
+  | isForAllTy t                            = return NoInstance
+  | isConstraintKind k                      = return NoInstance
   | Just (tc, kts) <- splitTyConApp_maybe t = doTyConApp tc kts
   | Just (f,kt )   <- splitAppTy_maybe t    = doTyApp f kt
   | Just _         <- isNumLitTy t          = doLit
diff --git a/compiler/typecheck/TcTypeNats.hs b/compiler/typecheck/TcTypeNats.hs
index 2e545b2e4d..a888a31556 100644
--- a/compiler/typecheck/TcTypeNats.hs
+++ b/compiler/typecheck/TcTypeNats.hs
@@ -44,7 +44,7 @@ import qualified Data.Map as Map
 import Data.Maybe ( isJust )
 
 {-------------------------------------------------------------------------------
-Built-in type constructors for functions on type-lelve nats
+Built-in type constructors for functions on type-level nats
 -}
 
 typeNatTyCons :: [TyCon]
diff --git a/compiler/typecheck/TcTypeable.hs b/compiler/typecheck/TcTypeable.hs
index e3d0051fca..f3494a9378 100644
--- a/compiler/typecheck/TcTypeable.hs
+++ b/compiler/typecheck/TcTypeable.hs
@@ -80,9 +80,15 @@ There are many wrinkles:
 
 * To be able to define them by hand, they need to have user-writable
   names, thus
-        tcBool, not $tcBool
-  and   tcList, not $tc[]
-  Hence PrelNames.tyConRepModOcc, and mkSpecialTyConRepName.
+        tcBool    not $tcBool    for the type-rep TyCon for Bool
+  Hence PrelNames.tyConRepModOcc
+
+* Moreover for type constructors with special syntax, they need to have
+  completely hand-crafted names
+    lists    tcList         not $tc[]   for the type-rep TyCon for []
+    kinds    tcLiftedKind   not $tc*    for the type-rep TyCon for *
+  Hence PrelNames.mkSpecialTyConRepName, which takes an extra FastString
+  to use for the TyConRepName
 
 * Since listTyCon, boolTyCon etd are wired in, their TyConRepNames must
   be wired in as well.  For these wired-in TyCons we generate the
@@ -154,8 +160,8 @@ type TypeableStuff
     , LHsExpr Id  -- Of type GHC.Types.Module
     , String      -- Package name
     , String      -- Module name
-    , DataCon
-    , DataCon )
+    , DataCon     -- Data constructor GHC.Types.TyCon
+    , DataCon )   -- Data constructor GHC.Types.TrNameS
 
 mk_typeable_binds :: TypeableStuff -> TyCon -> LHsBinds Id
 mk_typeable_binds stuff tycon
diff --git a/compiler/types/TyCon.hs b/compiler/types/TyCon.hs
index 5258839ad5..7596fe2671 100644
--- a/compiler/types/TyCon.hs
+++ b/compiler/types/TyCon.hs
@@ -856,7 +856,7 @@ so the coercion tycon CoT must have
 
 ************************************************************************
 *                                                                      *
-                 PrimRep
+                 TyConRepName
 *                                                                      *
 ********************************************************************* -}
 
diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs
index 4d9dd1797e..dc7b64fe5d 100644
--- a/compiler/types/Type.hs
+++ b/compiler/types/Type.hs
@@ -577,12 +577,9 @@ splitTyConArgs :: TyCon -> [KindOrType] -> ([Kind], [Type])
 -- Given a tycon app (T k1 .. kn t1 .. tm), split the kind and type args
 -- TyCons always have prenex kinds
 splitTyConArgs tc kts
-  = go (tyConKind tc) [] kts
+  = splitAtList kind_vars kts
   where
-    go tc_kind acc (kt:kts)
-       | Just (_,body_kind) <- splitForAllTy_maybe tc_kind
-       = go body_kind (kt:acc) kts
-    go _ acc ts = (reverse acc, ts)
+    (kind_vars, _) = splitForAllTys (tyConKind tc)
 
 newTyConInstRhs :: TyCon -> [Type] -> Type
 -- ^ Unwrap one 'layer' of newtype on a type constructor and its
diff --git a/compiler/types/TypeRep.hs b/compiler/types/TypeRep.hs
index c78c9c5975..ea7724cfdd 100644
--- a/compiler/types/TypeRep.hs
+++ b/compiler/types/TypeRep.hs
@@ -730,8 +730,7 @@ pprTcApp _ pp tc [ty]
 
 pprTcApp p pp tc tys
   | isTupleTyCon tc && tyConArity tc == length tys
-  = pprPromotionQuote tc <>
-    tupleParens (tupleTyConSort tc) (sep (punctuate comma (map (pp TopPrec) tys)))
+  = pprTupleApp p pp tc tys
 
   | Just dc <- isPromotedDataCon_maybe tc
   , let dc_tc = dataConTyCon dc
@@ -746,6 +745,17 @@ pprTcApp p pp tc tys
   | otherwise
   = sdocWithDynFlags (pprTcApp_help p pp tc tys)
 
+pprTupleApp :: TyPrec -> (TyPrec -> a -> SDoc) -> TyCon -> [a] -> SDoc
+-- Print a saturated tuple
+pprTupleApp p pp tc tys
+  | null tys
+  , ConstraintTuple <- tupleTyConSort tc
+  = maybeParen p TopPrec $
+    ppr tc <+> dcolon <+> ppr (tyConKind tc)
+  | otherwise
+  = pprPromotionQuote tc <>
+    tupleParens (tupleTyConSort tc) (sep (punctuate comma (map (pp TopPrec) tys)))
+
 pprTcApp_help :: TyPrec -> (TyPrec -> a -> SDoc) -> TyCon -> [a] -> DynFlags -> SDoc
 -- This one has accss to the DynFlags
 pprTcApp_help p pp tc tys dflags