[commit: ghc] master: Implement GHCi command :kind! which normalises its type (f3c7ed7)

[Simon Peyton Jones]

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/f3c7ed721133d53f81d945ecb737a77c2ef6ef73

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

commit f3c7ed721133d53f81d945ecb737a77c2ef6ef73
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Fri Sep 23 07:45:20 2011 +0100

    Implement GHCi command :kind! which normalises its type
    
       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         |    9 +++++----
 compiler/main/InteractiveEval.hs  |    6 +++---
 compiler/typecheck/TcRnDriver.lhs |   19 ++++++++++++++-----
 compiler/types/FamInstEnv.lhs     |    8 +++++---
 ghc/InteractiveUI.hs              |   15 +++++++++------
 5 files changed, 36 insertions(+), 21 deletions(-)

diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs
index ae421db..1842799 100644
--- a/compiler/main/HscMain.lhs
+++ b/compiler/main/HscMain.lhs
@@ -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}
diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index 47beb27..c09dab8 100644
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -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
diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index ed05220..4ef4ea7 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -1408,10 +1408,11 @@ 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
+	 -> IO (Messages, Maybe (Type, Kind))
+tcRnType hsc_env ictxt normalise rdr_type
   = initTcPrintErrors hsc_env iNTERACTIVE $
     setInteractiveContext hsc_env ictxt $ do {
 
@@ -1419,8 +1420,16 @@ tcRnType hsc_env ictxt 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")
diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs
index c429a9b..ab99e9f 100644
--- a/compiler/types/FamInstEnv.lhs
+++ b/compiler/types/FamInstEnv.lhs
@@ -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
diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs
index 8ee5804..28d6bca 100644
--- a/ghc/InteractiveUI.hs
+++ b/ghc/InteractiveUI.hs
@@ -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 ]
 
 
 -----------------------------------------------------------------------------