{-# OPTIONS -#include "Linker.h" #-}
-----------------------------------------------------------------------------
--- $Id: InteractiveUI.hs,v 1.188 2005/02/15 12:15:25 simonmar Exp $
+-- $Id: InteractiveUI.hs,v 1.191 2005/02/25 13:07:10 simonpj Exp $
--
-- GHC Interactive User Interface
--
import CompManager
import HscTypes ( GhciMode(..) )
-import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecls(..), IfaceConDecl(..),
- IfaceInst(..), pprIfaceDeclHead, pprParendIfaceType, pprIfaceForAllPart )
+import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecls(..),
+ IfaceConDecl(..), IfaceType,
+ IfaceInst(..), pprIfaceDeclHead, pprParendIfaceType,
+ pprIfaceForAllPart, pprIfaceType )
import FunDeps ( pprFundeps )
import DriverFlags
import DriverState
import Linker ( showLinkerState, linkPackages )
import Util
import Name ( Name, NamedThing(..) )
-import OccName ( OccName, isSymOcc, occNameUserString )
+import OccName ( OccName, parenSymOcc, occNameUserString )
import BasicTypes ( StrictnessMark(..), defaultFixity, SuccessFlag(..) )
import Outputable
-import CmdLineOpts ( DynFlags(..) )
+import CmdLineOpts ( DynFlags(..), DynFlag(..), dopt )
import Panic hiding ( showException )
import Config
import SrcLoc ( SrcLoc, isGoodSrcLoc )
info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
info s = do { let names = words s
; init_cms <- getCmState
- ; mapM_ (infoThing init_cms) names }
+ ; dflags <- getDynFlags
+ ; let exts = dopt Opt_GlasgowExts dflags
+ ; mapM_ (infoThing exts init_cms) names }
where
- infoThing cms name
+ infoThing exts cms name
= do { stuff <- io (cmGetInfo cms name)
; io (putStrLn (showSDocForUser (cmGetPrintUnqual cms) $
- vcat (intersperse (text "") (map showThing stuff)))) }
+ vcat (intersperse (text "") (map (showThing exts) stuff)))) }
-showThing :: GetInfoResult -> SDoc
-showThing (wanted_str, (thing, fixity, src_loc, insts))
- = vcat [ showWithLoc src_loc (showDecl want_name thing),
+showThing :: Bool -> GetInfoResult -> SDoc
+showThing exts (wanted_str, (thing, fixity, src_loc, insts))
+ = vcat [ showWithLoc src_loc (showDecl exts want_name thing),
show_fixity fixity,
vcat (map show_inst insts)]
where
-- Now there is rather a lot of goop just to print declarations in a
-- civilised way with "..." for the parts we are less interested in.
-showDecl :: (OccName -> Bool) -> IfaceDecl -> SDoc
-showDecl want_name (IfaceForeign {ifName = tc})
+showDecl :: Bool -> (OccName -> Bool) -> IfaceDecl -> SDoc
+showDecl exts want_name (IfaceForeign {ifName = tc})
= ppr tc <+> ptext SLIT("is a foreign type")
-showDecl want_name (IfaceId {ifName = var, ifType = ty})
- = ppr var <+> dcolon <+> ppr ty
+showDecl exts want_name (IfaceId {ifName = var, ifType = ty})
+ = ppr var <+> dcolon <+> showType exts ty
-showDecl want_name (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_ty})
+showDecl exts want_name (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_ty})
= hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars)
2 (equals <+> ppr mono_ty)
-showDecl want_name (IfaceData {ifName = tycon,
+showDecl exts want_name (IfaceData {ifName = tycon,
ifTyVars = tyvars, ifCons = condecls})
= hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars)
2 (add_bars (ppr_trim show_con cs))
ppr_str MarkedUnboxed = ptext SLIT("!!")
ppr_str NotMarkedStrict = empty
-showDecl want_name (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
+showDecl exts want_name (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
ifFDs = fds, ifSigs = sigs})
= hang (ptext SLIT("class") <+> pprIfaceDeclHead context clas tyvars
<+> pprFundeps fds <+> ptext SLIT("where"))
2 (vcat (ppr_trim show_op sigs))
where
show_op (IfaceClassOp op dm ty)
- | want_name clas || want_name op = Just (ppr_bndr op <+> dcolon <+> ppr ty)
- | otherwise = Nothing
+ | want_name clas || want_name op
+ = Just (ppr_bndr op <+> dcolon <+> showType exts ty)
+ | otherwise
+ = Nothing
+
+showType :: Bool -> IfaceType -> SDoc
+showType True ty = pprIfaceType ty -- -fglasgow-exts: print with the foralls
+showType False ty = ppr ty -- otherwise, print without the foralls
ppr_trim :: (a -> Maybe SDoc) -> [a] -> [SDoc]
ppr_trim show xs
ppr_bndr :: OccName -> SDoc
-- Wrap operators in ()
-ppr_bndr occ | isSymOcc occ = parens (ppr occ)
- | otherwise = ppr occ
+ppr_bndr occ = parenSymOcc occ (ppr occ)
-----------------------------------------------------------------------------
let unqual = cmGetPrintUnqual cms1 -- NOTE: cms1 with the new context
+ dflags <- getDynFlags
+ let exts = dopt Opt_GlasgowExts dflags
io (putStrLn (showSDocForUser unqual (
- vcat (map (showDecl (const True)) things)
+ vcat (map (showDecl exts (const True)) things)
)))
-----------------------------------------------------------------------------