Implement GHCi command :kind! which normalises its type
authorSimon Peyton Jones <simonpj@microsoft.com>
Fri, 23 Sep 2011 06:45:20 +0000 (07:45 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Fri, 23 Sep 2011 06:45:20 +0000 (07:45 +0100)
   type family F a
   type instance F Int = Bool
   type instance F Bool = Char

In GHCi
   *TF> :kind (F Int, F Bool)
   (F Int, F Bool) :: *
   *TF> :kind! F Int
   (F Int, F Bool) :: *
   = (Bool, Char)

We could call it ":normalise" but it seemed quite nice to have an
eager version of :kind

compiler/main/HscMain.lhs
compiler/main/InteractiveEval.hs
compiler/typecheck/TcRnDriver.lhs
compiler/types/FamInstEnv.lhs
ghc/InteractiveUI.hs

index ae421db..1842799 100644 (file)
@@ -1409,12 +1409,13 @@ hscTcExpr hsc_env expr = runHsc hsc_env $ do
 -- | Find the kind of a type
 hscKcType
   :: HscEnv
-  -> String                     -- ^ The type
-  -> IO Kind
+  -> Bool                      -- ^ Normalise the type
+  -> String                    -- ^ The type as a string
+  -> IO (Type, Kind)           -- ^ Resulting type (possibly normalised) and kind
 
-hscKcType hsc_env str = runHsc hsc_env $ do
+hscKcType hsc_env normalise str = runHsc hsc_env $ do
     ty <- hscParseType str
-    ioMsgMaybe $ tcRnType hsc_env (hsc_IC hsc_env) ty
+    ioMsgMaybe $ tcRnType hsc_env (hsc_IC hsc_env) normalise ty
 
 #endif
 \end{code}
index 47beb27..c09dab8 100644 (file)
@@ -942,9 +942,9 @@ exprType expr = withSession $ \hsc_env -> do
 -- Getting the kind of a type
 
 -- | Get the kind of a  type
-typeKind  :: GhcMonad m => String -> m Kind
-typeKind str = withSession $ \hsc_env -> do
-   liftIO $ hscKcType hsc_env str
+typeKind  :: GhcMonad m => Bool -> String -> m (Type, Kind)
+typeKind normalise str = withSession $ \hsc_env -> do
+   liftIO $ hscKcType hsc_env normalise str
 
 -----------------------------------------------------------------------------
 -- cmCompileExpr: compile an expression and deliver an HValue
index ed05220..4ef4ea7 100644 (file)
@@ -1408,19 +1408,28 @@ tcRnType just finds the kind of a type
 
 \begin{code}
 tcRnType :: HscEnv
-         -> InteractiveContext
+        -> InteractiveContext
+        -> Bool        -- Normalise the returned type
         -> LHsType RdrName
-        -> IO (Messages, Maybe Kind)
-tcRnType hsc_env ictxt rdr_type
-  = initTcPrintErrors hsc_env iNTERACTIVE $
+        -> IO (Messages, Maybe (Type, Kind))
+tcRnType hsc_env ictxt normalise rdr_type
+  = initTcPrintErrors hsc_env iNTERACTIVE $ 
     setInteractiveContext hsc_env ictxt $ do {
 
     rn_type <- rnLHsType doc rdr_type ;
     failIfErrsM ;
 
        -- Now kind-check the type
-    (_ty', kind) <- kcLHsType rn_type ;
-    return kind
+    ty <- tcHsSigType GenSigCtxt rn_type ;
+
+    ty' <- if normalise 
+           then do { fam_envs <- tcGetFamInstEnvs 
+                   ; return (snd (normaliseType fam_envs ty)) }
+                  -- normaliseType returns a coercion
+                  -- which we discard
+           else return ty ;
+            
+    return (ty', typeKind ty)
     }
   where
     doc = ptext (sLit "In GHCi input")
index c429a9b..ab99e9f 100644 (file)
@@ -17,7 +17,7 @@ module FamInstEnv (
        lookupFamInstEnv, lookupFamInstEnvConflicts, lookupFamInstEnvConflicts',
        
        -- Normalisation
-       topNormaliseType
+       topNormaliseType, normaliseType
     ) where
 
 #include "HsVersions.h"
@@ -550,8 +550,10 @@ topNormaliseType env ty
 
        | isFamilyTyCon tc              -- Expand open tycons
        , (co, ty) <- normaliseTcApp env tc tys
-               -- Note that normaliseType fully normalises, 
-               -- but it has do to so to be sure that 
+               -- Note that normaliseType fully normalises 'tys', 
+               -- It has do to so to be sure that nested calls like
+               --    F (G Int)
+               -- are correctly top-normalised
         , not (isReflCo co)
         = add_co co rec_nts ty
         where
index 8ee5804..28d6bca 100644 (file)
@@ -47,7 +47,8 @@ import Panic hiding ( showException )
 import Config
 import StaticFlags
 import Linker
-import Util
+import Util( on, global, toArgs, toCmdArgs, removeSpaces, getCmd,
+             filterOut, seqList, looksLikeModuleName, partitionWith )
 import NameSet
 import Maybes ( orElse, expectJust )
 import FastString
@@ -130,7 +131,8 @@ builtin_commands = [
   ("history",   keepGoing historyCmd,           noCompletion),
   ("info",      keepGoing' info,                completeIdentifier),
   ("issafe",    keepGoing' isSafeCmd,           completeModule),
-  ("kind",      keepGoing' kindOfType,          completeIdentifier),
+  ("kind",      keepGoing' (kindOfType False),  completeIdentifier),
+  ("kind!",     keepGoing' (kindOfType True),   completeIdentifier),
   ("load",      keepGoingPaths loadModule_,     completeHomeModuleOrFile),
   ("list",      keepGoing' listCmd,             noCompletion),
   ("module",    keepGoing moduleCmd,            completeSetModule),
@@ -1325,12 +1327,13 @@ typeOfExpr str
 -----------------------------------------------------------------------------
 -- :kind
 
-kindOfType :: String -> InputT GHCi ()
-kindOfType str 
+kindOfType :: Bool -> String -> InputT GHCi ()
+kindOfType normalise str 
   = handleSourceError GHC.printException
   $ do
-       ty <- GHC.typeKind str
-       printForUser $ text str <+> dcolon <+> ppr ty
+       (ty, kind) <- GHC.typeKind normalise str
+       printForUser $ vcat [ text str <+> dcolon <+> ppr kind
+                           , ppWhen normalise $ equals <+> ppr ty ]
 
 
 -----------------------------------------------------------------------------