isImplicitId, isDeadBinder,
isSpecPragmaId, isExportedId, isLocalId, isGlobalId,
isRecordSelector,
+ isClassOpId_maybe,
isPrimOpId, isPrimOpId_maybe,
isFCallId, isFCallId_maybe,
isDataConWorkId, isDataConWorkId_maybe, idDataCon,
RecordSelId _ _ -> True
other -> False
+isClassOpId_maybe id = case globalIdDetails id of
+ ClassOpId cls -> Just cls
+ _other -> Nothing
+
isPrimOpId id = case globalIdDetails id of
PrimOpId op -> True
other -> False
mkModule, pprModule, Type, Module, SuccessFlag(..),
TyThing(..), Name, LoadHowMuch(..), Phase,
GhcException(..), showGhcException,
- CheckedModule(..) )
+ CheckedModule(..), SrcLoc )
+import PprTyThing
import Outputable
-- for createtags (should these come via GHC?)
import OccName( pprOccName )
import SrcLoc( isGoodSrcLoc, srcLocFile, srcLocLine, srcLocCol )
--- following all needed for :info... ToDo: remove
-import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecls(..),
- IfaceConDecl(..), IfaceType,
- pprIfaceDeclHead, pprParendIfaceType,
- pprIfaceForAllPart, pprIfaceType )
-import FunDeps ( pprFundeps )
-import SrcLoc ( SrcLoc, pprDefnLoc )
-import OccName ( OccName, parenSymOcc, occNameUserString )
-import BasicTypes ( StrictnessMark(..), defaultFixity, failed, successIf )
-
-- Other random utilities
+import BasicTypes ( failed, successIf )
import Panic ( panic, installSignalHandlers )
import Config
import StaticFlags ( opt_IgnoreDotGhci )
import Numeric
import Data.List
import Data.Int ( Int64 )
-import Data.Maybe ( isJust )
+import Data.Maybe ( isJust, fromMaybe, catMaybes )
import System.Cmd
import System.CPUTime
import System.Environment
; let exts = dopt Opt_GlasgowExts dflags
; mapM_ (infoThing exts session) names }
where
- infoThing exts session name
- = do { stuff <- io (GHC.getInfo session name)
- ; unqual <- io (GHC.getPrintUnqual session)
- ; io (putStrLn (showSDocForUser unqual $
- vcat (intersperse (text "") (map (showThing exts) stuff)))) }
-
-showThing :: Bool -> GHC.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)]
+ infoThing exts session str = io $ do
+ names <- GHC.parseName session str
+ let filtered = filterOutChildren names
+ mb_stuffs <- mapM (GHC.getInfo session) filtered
+ unqual <- GHC.getPrintUnqual session
+ putStrLn (showSDocForUser unqual $
+ vcat (intersperse (text "") $
+ [ pprInfo exts stuff | Just stuff <- mb_stuffs ]))
+
+ -- Filter out names whose parent is also there Good
+ -- example is '[]', which is both a type and data
+ -- constructor in the same type
+filterOutChildren :: [Name] -> [Name]
+filterOutChildren names = filter (not . parent_is_there) names
+ where parent_is_there n
+ | Just p <- GHC.nameParent_maybe n = p `elem` names
+ | otherwise = False
+
+pprInfo exts (thing, fixity, insts)
+ = pprTyThingLoc exts thing
+ $$ show_fixity fixity
+ $$ vcat (map GHC.pprInstance insts)
where
- want_name occ = wanted_str == occNameUserString occ
-
show_fixity fix
- | fix == defaultFixity = empty
- | otherwise = ppr fix <+> text wanted_str
-
- show_inst (inst_ty, loc)
- = showWithLoc loc (ptext SLIT("instance") <+> ppr inst_ty)
-
-showWithLoc :: SrcLoc -> SDoc -> SDoc
-showWithLoc loc doc
- = hang doc 2 (char '\t' <> comment <+> pprDefnLoc loc)
- -- The tab tries to make them line up a bit
- where
- comment = ptext SLIT("--")
-
-
--- 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 :: Bool -> (OccName -> Bool) -> IfaceDecl -> SDoc
-showDecl exts want_name (IfaceForeign {ifName = tc})
- = ppr tc <+> ptext SLIT("is a foreign type")
-
-showDecl exts want_name (IfaceId {ifName = var, ifType = ty})
- = ppr var <+> dcolon <+> showIfaceType exts 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 exts want_name (IfaceData {ifName = tycon,
- ifTyVars = tyvars, ifCons = condecls, ifCtxt = context})
- = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars)
- 2 (add_bars (ppr_trim show_con cs))
- where
- show_con (IfVanillaCon { ifConOcc = con_name, ifConInfix = is_infix, ifConArgTys = tys,
- ifConStricts = strs, ifConFields = flds})
- | want_name tycon || want_name con_name || any want_name flds
- = Just (show_guts con_name is_infix tys_w_strs flds)
- | otherwise = Nothing
- where
- tys_w_strs = tys `zip` (strs ++ repeat NotMarkedStrict)
- show_con (IfGadtCon { ifConOcc = con_name, ifConTyVars = tvs, ifConCtxt = theta,
- ifConArgTys = arg_tys, ifConResTys = res_tys, ifConStricts = strs })
- | want_name tycon || want_name con_name
- = Just (ppr_bndr con_name <+> colon <+> pprIfaceForAllPart tvs theta pp_tau)
- | otherwise = Nothing
- where
- tys_w_strs = arg_tys `zip` (strs ++ repeat NotMarkedStrict)
- pp_tau = foldr add pp_res_ty tys_w_strs
- pp_res_ty = ppr_bndr tycon <+> hsep (map pprParendIfaceType res_tys)
- add bty pp_ty = ppr_bangty bty <+> arrow <+> pp_ty
-
- show_guts con True [ty1, ty2] flds = sep [ppr_bangty ty1, ppr con, ppr_bangty ty2]
- show_guts con _ tys [] = ppr_bndr con <+> sep (map ppr_bangty tys)
- show_guts con _ tys flds
- = ppr_bndr con <+> braces (sep (punctuate comma (ppr_trim show_fld (tys `zip` flds))))
- where
- show_fld (bty, fld) | want_name tycon || want_name con || want_name fld
- = Just (ppr_bndr fld <+> dcolon <+> ppr_bangty bty)
- | otherwise = Nothing
-
- (pp_nd, cs) = case condecls of
- IfAbstractTyCon -> (ptext SLIT("data"), [])
- IfDataTyCon cs -> (ptext SLIT("data"), cs)
- IfNewTyCon c -> (ptext SLIT("newtype"),[c])
-
- add_bars [] = empty
- add_bars [c] = equals <+> c
- add_bars (c:cs) = equals <+> sep (c : map (char '|' <+>) cs)
-
- ppr_bangty (ty, str) = ppr_str str <> pprParendIfaceType ty
- ppr_str MarkedStrict = char '!'
- ppr_str MarkedUnboxed = ptext SLIT("!!")
- ppr_str NotMarkedStrict = empty
-
-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 <+> opt_where)
- 2 (vcat (ppr_trim show_op sigs))
- where
- opt_where | null sigs = empty
- | otherwise = ptext SLIT("where")
- show_op (IfaceClassOp op dm ty)
- | want_name clas || want_name op
- = Just (ppr_bndr op <+> dcolon <+> showIfaceType exts ty)
- | otherwise
- = Nothing
-
-showIfaceType :: Bool -> IfaceType -> SDoc
-showIfaceType True ty = pprIfaceType ty -- -fglasgow-exts: print with the foralls
-showIfaceType False ty = ppr ty -- otherwise, print without the foralls
-
-ppr_trim :: (a -> Maybe SDoc) -> [a] -> [SDoc]
-ppr_trim show xs
- = snd (foldr go (False, []) xs)
- where
- go x (eliding, so_far)
- | Just doc <- show x = (False, doc : so_far)
- | otherwise = if eliding then (True, so_far)
- else (True, ptext SLIT("...") : so_far)
-
-ppr_bndr :: OccName -> SDoc
--- Wrap operators in ()
-ppr_bndr occ = parenSymOcc occ (ppr occ)
-
+ | fix == GHC.defaultFixity = empty
+ | otherwise = ppr fix <+> ppr (GHC.getName thing)
-----------------------------------------------------------------------------
-- Commands
(as,bs) <- io (GHC.getContext s)
io (if exports_only then GHC.setContext s [] [prelude_mod,modl]
else GHC.setContext s [modl] [])
+ unqual <- io (GHC.getPrintUnqual s)
io (GHC.setContext s as bs)
- things <- io (GHC.browseModule s modl exports_only)
- unqual <- io (GHC.getPrintUnqual s)
+ mb_mod_info <- io $ GHC.getModuleInfo s modl
+ case mb_mod_info of
+ Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
+ Just mod_info -> do
+ let names
+ | exports_only = GHC.modInfoExports mod_info
+ | otherwise = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
- dflags <- getDynFlags
- let exts = dopt Opt_GlasgowExts dflags
- io (putStrLn (showSDocForUser unqual (
- vcat (map (showDecl exts (const True)) things)
- )))
+ filtered = filterOutChildren names
+
+ things <- io $ mapM (GHC.lookupName s) filtered
+
+ dflags <- getDynFlags
+ let exts = dopt Opt_GlasgowExts dflags
+ io (putStrLn (showSDocForUser unqual (
+ vcat (map (pprTyThing exts) (catMaybes things))
+ )))
+ -- ToDo: modInfoInstances currently throws an exception for
+ -- package modules. When it works, we can do this:
+ -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
-----------------------------------------------------------------------------
-- Setting the module context
setContext, getContext,
getNamesInScope,
moduleIsInterpreted,
- getInfo, GetInfoResult,
+ getInfo,
exprType,
typeKind,
parseName,
RunResult(..),
runStmt,
- browseModule,
showModule,
compileExpr, HValue,
lookupName,
Module, mkModule, pprModule,
-- ** Names
- Name, nameModule,
+ Name,
+ nameModule, nameParent_maybe, pprParenSymName, nameSrcLoc,
+ NamedThing(..),
-- ** Identifiers
Id, idType,
isImplicitId, isDeadBinder,
isSpecPragmaId, isExportedId, isLocalId, isGlobalId,
isRecordSelector,
- isPrimOpId, isFCallId,
+ isPrimOpId, isFCallId, isClassOpId_maybe,
isDataConWorkId, idDataCon,
isBottomingId, isDictonaryId,
+ recordSelectorFieldLabel,
-- ** Type constructors
TyCon,
+ tyConTyVars, tyConDataCons,
isClassTyCon, isSynTyCon, isNewTyCon,
+ getSynTyConDefn,
-- ** Data constructors
DataCon,
+ dataConSig, dataConType, dataConTyCon, dataConFieldLabels,
+ dataConIsInfix, isVanillaDataCon,
+ dataConStrictMarks,
+ StrictnessMark(..), isMarkedStrict,
-- ** Classes
Class,
- classSCTheta, classTvsFds,
+ classMethods, classSCTheta, classTvsFds,
+ pprFundeps,
-- ** Instances
- Instance,
+ Instance,
+ instanceDFunId, pprInstance,
-- ** Types and Kinds
- Type, dropForAlls,
+ Type, dropForAlls, splitForAllTys, funResultTy, pprParendType,
Kind,
+ PredType,
+ ThetaType, pprThetaArrow,
-- ** Entities
TyThing(..),
-- ** Syntax
module HsSyn, -- ToDo: remove extraneous bits
+ -- ** Fixities
+ FixityDirection(..),
+ defaultFixity, maxPrecedence,
+ negateFixity,
+ compareFixity,
+
+ -- ** Source locations
+ SrcLoc, pprDefnLoc,
+
-- * Exceptions
GhcException(..), showGhcException,
{-
ToDo:
- * inline bits of HscMain here to simplify layering: hscGetInfo,
- hscTcExpr, hscStmt.
+ * inline bits of HscMain here to simplify layering: hscTcExpr, hscStmt.
* we need to expose DynFlags, so should parseDynamicFlags really be
part of this interface?
* what StaticFlags should we expose, if any?
#ifdef GHCI
import qualified Linker
import Linker ( HValue, extendLinkEnv )
-import TcRnDriver ( getModuleContents, tcRnLookupRdrName,
- getModuleExports )
+import TcRnDriver ( tcRnLookupRdrName, tcRnGetInfo,
+ tcRnLookupName, getModuleExports )
import RdrName ( plusGlobalRdrEnv, Provenance(..),
ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..),
emptyGlobalRdrEnv, mkGlobalRdrEnv )
-import HscMain ( hscGetInfo, GetInfoResult, hscParseIdentifier,
- hscStmt, hscTcExpr, hscKcType )
+import HscMain ( hscParseIdentifier, hscStmt, hscTcExpr, hscKcType )
import Type ( tidyType )
import VarEnv ( emptyTidyEnv )
import GHC.Exts ( unsafeCoerce# )
-import IfaceSyn ( IfaceDecl )
#endif
import Packages ( initPackages, isHomeModule )
import RdrName ( GlobalRdrEnv, GlobalRdrElt(..), RdrName,
globalRdrEnvElts )
import HsSyn
-import Type ( Kind, Type, dropForAlls )
+import Type ( Kind, Type, dropForAlls, PredType, ThetaType,
+ pprThetaArrow, pprParendType, splitForAllTys,
+ funResultTy )
import Id ( Id, idType, isImplicitId, isDeadBinder,
isSpecPragmaId, isExportedId, isLocalId, isGlobalId,
- isRecordSelector,
- isPrimOpId, isFCallId,
+ isRecordSelector, recordSelectorFieldLabel,
+ isPrimOpId, isFCallId, isClassOpId_maybe,
isDataConWorkId, idDataCon,
isBottomingId )
-import TyCon ( TyCon, isClassTyCon, isSynTyCon, isNewTyCon )
-import Class ( Class, classSCTheta, classTvsFds )
-import DataCon ( DataCon )
-import Name ( Name, nameModule )
+import TyCon ( TyCon, isClassTyCon, isSynTyCon, isNewTyCon,
+ tyConTyVars, tyConDataCons, getSynTyConDefn )
+import Class ( Class, classSCTheta, classTvsFds, classMethods )
+import FunDeps ( pprFundeps )
+import DataCon ( DataCon, dataConWrapId, dataConSig, dataConTyCon,
+ dataConFieldLabels, dataConStrictMarks,
+ dataConIsInfix, isVanillaDataCon )
+import Name ( Name, nameModule, NamedThing(..), nameParent_maybe,
+ nameSrcLoc )
+import OccName ( parenSymOcc )
import NameEnv ( nameEnvElts )
-import InstEnv ( Instance )
+import InstEnv ( Instance, instanceDFunId, pprInstance )
import SrcLoc
import DriverPipeline
import DriverPhases ( Phase(..), isHaskellSrcFilename, startPhase )
import StringBuffer ( StringBuffer, hGetStringBuffer )
import Outputable
import SysTools ( cleanTempFilesExcept )
-import BasicTypes ( SuccessFlag(..), succeeded, failed )
+import BasicTypes
import TcType ( tcSplitSigmaTy, isDictTy )
import FastString ( mkFastString )
_not_a_home_module -> return False
-- | Looks up an identifier in the current interactive context (for :info)
-{-# DEPRECATED getInfo "we should be using parseName/lookupName instead" #-}
-getInfo :: Session -> String -> IO [GetInfoResult]
-getInfo s id = withSession s $ \hsc_env -> hscGetInfo hsc_env id
+getInfo :: Session -> Name -> IO (Maybe (TyThing,Fixity,[Instance]))
+getInfo s name = withSession s $ \hsc_env -> tcRnGetInfo hsc_env name
-- | Returns all names in scope in the current interactive context
getNamesInScope :: Session -> IO [Name]
-- | Returns the 'TyThing' for a 'Name'. The 'Name' may refer to any
-- entity known to GHC, including 'Name's defined using 'runStmt'.
lookupName :: Session -> Name -> IO (Maybe TyThing)
-lookupName s name = withSession s $ \hsc_env -> do
- case lookupTypeEnv (ic_type_env (hsc_IC hsc_env)) name of
- Just tt -> return (Just tt)
- Nothing -> do
- eps <- readIORef (hsc_EPS hsc_env)
- return $! lookupType (hsc_HPT hsc_env) (eps_PTE eps) name
+lookupName s name = withSession s $ \hsc_env -> tcRnLookupName hsc_env name
+
+-- -----------------------------------------------------------------------------
+-- Misc exported utils
+
+dataConType :: DataCon -> Type
+dataConType dc = idType (dataConWrapId dc)
+
+-- | print a 'NamedThing', adding parentheses if the name is an operator.
+pprParenSymName :: NamedThing a => a -> SDoc
+pprParenSymName a = parenSymOcc (getOccName a) (ppr (getName a))
-- -----------------------------------------------------------------------------
-- Getting the type of an expression
-- more informative than the C type!
-}
--- ---------------------------------------------------------------------------
--- cmBrowseModule: get all the TyThings defined in a module
-
-{-# DEPRECATED browseModule "we should be using getModuleInfo instead" #-}
-browseModule :: Session -> Module -> Bool -> IO [IfaceDecl]
-browseModule s modl exports_only = withSession s $ \hsc_env -> do
- mb_decls <- getModuleContents hsc_env modl exports_only
- case mb_decls of
- Nothing -> return [] -- An error of some kind
- Just ds -> return ds
-
-
-----------------------------------------------------------------------------
-- show a module and it's source/object filenames
hscParseIdentifier,
#ifdef GHCI
hscStmt, hscTcExpr, hscKcType,
- hscGetInfo, GetInfoResult,
compileExpr,
#endif
) where
import CoreTidy ( tidyExpr )
import CorePrep ( corePrepExpr )
import Flattening ( flattenExpr )
-import TcRnDriver ( tcRnStmt, tcRnExpr, tcRnGetInfo, GetInfoResult, tcRnType )
+import TcRnDriver ( tcRnStmt, tcRnExpr, tcRnType )
import Type ( Type )
import PrelNames ( iNTERACTIVE )
import Kind ( Kind )
%************************************************************************
%* *
-\subsection{Getting information about an identifer}
-%* *
-%************************************************************************
-
-\begin{code}
-#ifdef GHCI
-hscGetInfo -- like hscStmt, but deals with a single identifier
- :: HscEnv
- -> String -- The identifier
- -> IO [GetInfoResult]
-
-hscGetInfo hsc_env str
- = do maybe_rdr_name <- hscParseIdentifier (hsc_dflags hsc_env) str
- case maybe_rdr_name of {
- Nothing -> return [];
- Just (L _ rdr_name) -> do
-
- maybe_tc_result <- tcRnGetInfo hsc_env (hsc_IC hsc_env) rdr_name
-
- case maybe_tc_result of
- Nothing -> return []
- Just things -> return things
- }
-#endif
-\end{code}
-
-%************************************************************************
-%* *
Desugar, simplify, convert to bytecode, and link an expression
%* *
%************************************************************************
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Pretty-printing TyThings
+--
+-- (c) The GHC Team 2005
+--
+-----------------------------------------------------------------------------
+
+module PprTyThing (
+ pprTyThing,
+ pprTyThingInContext,
+ pprTyThingLoc,
+ pprTyThingInContextLoc,
+ ) where
+
+#include "HsVersions.h"
+
+import qualified GHC
+import GHC ( TyThing(..), SrcLoc )
+import Outputable
+
+-- -----------------------------------------------------------------------------
+-- Pretty-printing entities that we get from the GHC API
+
+-- This should be a good source of sample code for using the GHC API to
+-- inspect source code entities.
+
+-- | Pretty-prints a 'TyThing' with its defining location.
+pprTyThingLoc :: Bool -> TyThing -> SDoc
+pprTyThingLoc exts tyThing
+ = showWithLoc loc (pprTyThing exts tyThing)
+ where loc = GHC.nameSrcLoc (GHC.getName tyThing)
+
+-- | Pretty-prints a 'TyThing'.
+pprTyThing :: Bool -> TyThing -> SDoc
+pprTyThing exts (AnId id) = pprId exts id
+pprTyThing exts (ADataCon dataCon) = pprDataConSig exts dataCon
+pprTyThing exts (ATyCon tyCon) = pprTyCon exts tyCon
+pprTyThing exts (AClass cls) = pprClass exts cls
+
+-- | Like 'pprTyThingInContext', but adds the defining location.
+pprTyThingInContextLoc :: Bool -> TyThing -> SDoc
+pprTyThingInContextLoc exts tyThing
+ = showWithLoc loc (pprTyThingInContext exts tyThing)
+ where loc = GHC.nameSrcLoc (GHC.getName tyThing)
+
+-- | Pretty-prints a 'TyThing' in context: that is, if the entity
+-- is a data constructor, record selector, or class method, then
+-- the entity's parent declaration is pretty-printed with irrelevant
+-- parts omitted.
+pprTyThingInContext :: Bool -> TyThing -> SDoc
+pprTyThingInContext exts (AnId id) = pprIdInContext exts id
+pprTyThingInContext exts (ADataCon dataCon) = pprDataCon exts dataCon
+pprTyThingInContext exts (ATyCon tyCon) = pprTyCon exts tyCon
+pprTyThingInContext exts (AClass cls) = pprClass exts cls
+
+pprTyConHdr exts tyCon =
+ ptext keyword <+> ppr_bndr tyCon <+> hsep (map ppr vars)
+ where
+ vars = GHC.tyConTyVars tyCon
+
+ keyword | GHC.isSynTyCon tyCon = SLIT("type")
+ | GHC.isNewTyCon tyCon = SLIT("newtype")
+ | otherwise = SLIT("data")
+
+pprDataConSig exts dataCon =
+ ppr_bndr dataCon <+> dcolon <+> pprType exts (GHC.dataConType dataCon)
+
+pprClassHdr exts cls =
+ let (tyVars, funDeps) = GHC.classTvsFds cls
+ in ptext SLIT("class") <+>
+ GHC.pprThetaArrow (GHC.classSCTheta cls) <+>
+ ppr_bndr cls <+>
+ hsep (map ppr tyVars) <+>
+ GHC.pprFundeps funDeps
+
+pprIdInContext exts id
+ | GHC.isRecordSelector id = pprRecordSelector exts id
+ | Just cls <- GHC.isClassOpId_maybe id = pprClassOneMethod exts cls id
+ | otherwise = pprId exts id
+
+pprRecordSelector exts id
+ = pprAlgTyCon exts tyCon show_con show_label
+ where
+ (tyCon,label) = GHC.recordSelectorFieldLabel id
+ show_con dataCon = label `elem` GHC.dataConFieldLabels dataCon
+ show_label label' = label == label'
+
+pprId exts id
+ = hang (ppr_bndr id <+> dcolon) 2
+ (pprType exts (GHC.idType id))
+
+pprType True ty = ppr ty
+pprType False ty = ppr (GHC.dropForAlls ty)
+
+pprTyCon exts tyCon
+ | GHC.isSynTyCon tyCon
+ = let (_,rhs_type) = GHC.getSynTyConDefn tyCon
+ in hang (pprTyConHdr exts tyCon <+> equals) 2 (pprType exts rhs_type)
+ | otherwise
+ = pprAlgTyCon exts tyCon (const True) (const True)
+
+pprAlgTyCon exts tyCon ok_con ok_label
+ | gadt = pprTyConHdr exts tyCon <+> ptext SLIT("where") $$
+ nest 2 (vcat (ppr_trim show_con datacons))
+ | otherwise = hang (pprTyConHdr exts tyCon)
+ 2 (add_bars (ppr_trim show_con datacons))
+ where
+ datacons = GHC.tyConDataCons tyCon
+ gadt = any (not . GHC.isVanillaDataCon) datacons
+
+ show_con dataCon
+ | ok_con dataCon = Just (pprDataConDecl exts gadt ok_label dataCon)
+ | otherwise = Nothing
+
+pprDataCon exts dataCon = pprAlgTyCon exts tyCon (== dataCon) (const True)
+ where tyCon = GHC.dataConTyCon dataCon
+
+pprDataConDecl exts gadt_style show_label dataCon
+ | not gadt_style = ppr_fields tys_w_strs
+ | otherwise = ppr_bndr dataCon <+> dcolon <+>
+ sep [ ppr_tvs, GHC.pprThetaArrow theta, pp_tau ]
+ where
+ (tyvars, theta, argTypes, tyCon, res_tys) = GHC.dataConSig dataCon
+ labels = GHC.dataConFieldLabels dataCon
+ qualVars = filter (flip notElem (GHC.tyConTyVars tyCon)) tyvars
+ stricts = GHC.dataConStrictMarks dataCon
+ tys_w_strs = zip stricts argTypes
+
+ ppr_tvs
+ | null qualVars = empty
+ | otherwise = ptext SLIT("forall") <+>
+ hsep (map ppr qualVars) <> dot
+
+ -- printing out the dataCon as a type signature, in GADT style
+ pp_tau = foldr add pp_res_ty tys_w_strs
+ pp_res_ty = ppr_bndr tyCon <+> hsep (map GHC.pprParendType res_tys)
+ add (str,ty) pp_ty = pprBangTy str ty <+> arrow <+> pp_ty
+
+ pprParendBangTy (strict,ty)
+ | GHC.isMarkedStrict strict = char '!' <> GHC.pprParendType ty
+ | otherwise = GHC.pprParendType ty
+
+ pprBangTy strict ty
+ | GHC.isMarkedStrict strict = char '!' <> ppr ty
+ | otherwise = ppr ty
+
+ maybe_show_label (lbl,(strict,tp))
+ | show_label lbl = Just (ppr lbl <+> dcolon <+> pprBangTy strict tp)
+ | otherwise = Nothing
+
+ ppr_fields [ty1, ty2]
+ | GHC.dataConIsInfix dataCon && null labels
+ = sep [pprParendBangTy ty1, ppr dataCon, pprParendBangTy ty2]
+ ppr_fields fields
+ | null labels
+ = ppr_bndr dataCon <+> sep (map pprParendBangTy fields)
+ | otherwise
+ = ppr_bndr dataCon <+>
+ braces (sep (punctuate comma (ppr_trim maybe_show_label
+ (zip labels fields))))
+
+pprClass exts cls
+ | null methods =
+ pprClassHdr exts cls
+ | otherwise =
+ hang (pprClassHdr exts cls <+> ptext SLIT("where"))
+ 2 (vcat (map (pprClassMethod exts) methods))
+ where
+ methods = GHC.classMethods cls
+
+pprClassOneMethod exts cls this_one =
+ hang (pprClassHdr exts cls <+> ptext SLIT("where"))
+ 2 (vcat (ppr_trim show_meth methods))
+ where
+ methods = GHC.classMethods cls
+ show_meth id | id == this_one = Just (pprClassMethod exts id)
+ | otherwise = Nothing
+
+pprClassMethod exts id =
+ hang (ppr_bndr id <+> dcolon) 2 (pprType exts (classOpType id))
+ where
+ -- Here's the magic incantation to strip off the dictionary
+ -- from the class op type. Stolen from IfaceSyn.tyThingToIfaceDecl.
+ classOpType id = GHC.funResultTy rho_ty
+ where (_sel_tyvars, rho_ty) = GHC.splitForAllTys (GHC.idType id)
+
+ppr_trim :: (a -> Maybe SDoc) -> [a] -> [SDoc]
+ppr_trim show xs
+ = snd (foldr go (False, []) xs)
+ where
+ go x (eliding, so_far)
+ | Just doc <- show x = (False, doc : so_far)
+ | otherwise = if eliding then (True, so_far)
+ else (True, ptext SLIT("...") : so_far)
+
+add_bars [] = empty
+add_bars [c] = equals <+> c
+add_bars (c:cs) = sep ((equals <+> c) : map (char '|' <+>) cs)
+
+-- Wrap operators in ()
+ppr_bndr :: GHC.NamedThing a => a -> SDoc
+ppr_bndr a = GHC.pprParenSymName a
+
+showWithLoc :: SrcLoc -> SDoc -> SDoc
+showWithLoc loc doc
+ = hang doc 2 (char '\t' <> comment <+> GHC.pprDefnLoc loc)
+ -- The tab tries to make them line up a bit
+ where
+ comment = ptext SLIT("--")
+
-}
+{-
+Possible plan for x86 floating pt register alloc:
+
+ - The standard reg alloc procedure allocates pretend floating point
+ registers to the GXXX instructions. We need to convert these GXXX
+ instructions to proper x86 FXXX instructions, using the FP stack for
+ registers.
+
+ We could do this in a separate pass, but it helps to have the
+ information about which real registers are live after the
+ instruction, so we do it at reg alloc time where that information
+ is already available.
+
+ - keep a mapping from %fakeN to FP stack slot in the monad.
+
+ - after assigning registers to the GXXX instruction, convert the
+ instruction to an FXXX instruction. eg.
+ - for GMOV just update the mapping, and ffree any dead regs.
+ - GLD: just fld and update mapping
+ GLDZ: just fldz and update mapping
+ GLD1: just fld1 and update mapping
+ - GST: just fst and update mapping, ffree dead regs.
+ - special case for GST reg, where reg is st(0), we can fstp.
+ - for GADD fp1, fp2, fp3:
+ - easy way: fld fp2
+ fld fp1
+ faddp
+ -- record that fp3 is now in %st(0), and all other
+ -- slots are pushed down one.
+ ffree fp1 -- if fp1 is dead now
+ ffree fp2 -- if fp2 is dead now
+ - optimisation #1
+ - if fp1 is in %st(0) and is dead afterward
+ fadd %st(0), fp2
+ -- record fp3 is in %st(0)
+ ffree fp2 -- if fp2 is dead now
+ - if fp2 is in %st(0) and is dead afterward
+ fadd %st(0), fp1
+ -- record fp3 is in %st(0)
+ - if fp1 is in %st(0), fp2 is dead afterward
+ fadd fp2, %st(0)
+ -- record fp3 is in fp2's locn
+ - if fp2 is in %st(0), fp1 is dead afterward
+ fadd fp1, %st(0)
+ -- record fp3 is in fp1's locn
+
+ - we should be able to avoid the nasty ffree problems of the current
+ scheme. The stack should be empty before doing a non-local
+ jump/call - we can assert that this is the case.
+-}
+
+
module RegisterAlloc (
regAlloc
) where
\begin{code}
module TcRnDriver (
#ifdef GHCI
- getModuleContents, tcRnStmt,
- tcRnGetInfo, GetInfoResult,
- tcRnExpr, tcRnType,
+ tcRnStmt, tcRnExpr, tcRnType,
tcRnLookupRdrName,
+ tcRnLookupName,
+ tcRnGetInfo,
getModuleExports,
#endif
tcRnModule,
import InstEnv ( classInstances, instEnvElts )
import RnExpr ( rnStmts, rnLExpr )
import LoadIface ( loadSrcInterface, loadSysInterface )
-import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..),
- IfaceExtName(..), IfaceConDecls(..),
- tyThingToIfaceDecl )
-import IfaceType ( IfaceType, toIfaceType,
- interactiveExtNameFun )
-import IfaceEnv ( lookupOrig, ifaceExportNames )
-import Module ( lookupModuleEnv, moduleSetElts, mkModuleSet )
+import IfaceEnv ( ifaceExportNames )
+import Module ( moduleSetElts, mkModuleSet )
import RnEnv ( lookupOccRn, dataTcOccs, lookupFixityRn )
-import Id ( isImplicitId, setIdType, globalIdDetails )
+import Id ( setIdType )
import MkId ( unsafeCoerceId )
-import DataCon ( dataConTyCon )
import TyCon ( tyConName )
import TysWiredIn ( mkListTy, unitTy )
import IdInfo ( GlobalIdDetails(..) )
import Kind ( Kind )
import Var ( globaliseId )
-import Name ( nameOccName, nameModule, isBuiltInSyntax, nameParent_maybe )
-import OccName ( occNameUserString, isTcOcc )
+import Name ( nameOccName, nameModule, isBuiltInSyntax )
+import OccName ( isTcOcc )
import NameEnv ( delListFromNameEnv )
import PrelNames ( iNTERACTIVE, ioTyConName, printName, itName,
bindIOName, thenIOName, returnIOName )
-import HscTypes ( InteractiveContext(..), HomeModInfo(..),
- availNames, availName, ModIface(..), icPrintUnqual,
+import HscTypes ( InteractiveContext(..),
+ ModIface(..), icPrintUnqual,
Dependencies(..) )
import BasicTypes ( RecFlag(..), Fixity )
-import Panic ( ghcError, GhcException(..) )
-import SrcLoc ( SrcLoc, unLoc, noSrcSpan )
+import SrcLoc ( unLoc, noSrcSpan )
#endif
import FastString ( mkFastString )
-- Load any orphan-module interfaces,
-- so their instances are visible
ifaceExportNames (mi_exports iface)
-\end{code}
-\begin{code}
-getModuleContents
- :: HscEnv
- -> Module -- Module to inspect
- -> Bool -- Grab just the exports, or the whole toplev
- -> IO (Maybe [IfaceDecl])
-
-getModuleContents hsc_env mod exports_only
- = initTcPrintErrors hsc_env iNTERACTIVE (get_mod_contents exports_only)
- where
- get_mod_contents exports_only
- | not exports_only -- We want the whole top-level type env
- -- so it had better be a home module
- = do { hpt <- getHpt
- ; case lookupModuleEnv hpt mod of
- Just mod_info -> return (map (toIfaceDecl ext_nm) $
- filter wantToSee $
- typeEnvElts $
- md_types (hm_details mod_info))
- Nothing -> ghcError (ProgramError (showSDoc (noRdrEnvErr mod)))
- -- This is a system error; the module should be in the HPT
- }
-
- | otherwise -- Want the exports only
- = do { iface <- load_iface mod
- ; mappM get_decl [ (mod,avail) | (mod, avails) <- mi_exports iface
- , avail <- avails ]
- }
-
- get_decl (mod, avail)
- = do { main_name <- lookupOrig mod (availName avail)
- ; thing <- tcLookupGlobal main_name
- ; return (filter_decl (availNames avail) (toIfaceDecl ext_nm thing)) }
-
- ext_nm = interactiveExtNameFun (icPrintUnqual (hsc_IC hsc_env))
-
----------------------
-filter_decl occs decl@(IfaceClass {ifSigs = sigs})
- = decl { ifSigs = filter (keep_sig occs) sigs }
-filter_decl occs decl@(IfaceData {ifCons = IfDataTyCon cons})
- = decl { ifCons = IfDataTyCon (filter (keep_con occs) cons) }
-filter_decl occs decl@(IfaceData {ifCons = IfNewTyCon con})
- | keep_con occs con = decl
- | otherwise = decl {ifCons = IfAbstractTyCon} -- Hmm?
-filter_decl occs decl
- = decl
-
-keep_sig occs (IfaceClassOp occ _ _) = occ `elem` occs
-keep_con occs con = ifConOcc con `elem` occs
-
-wantToSee (AnId id) = not (isImplicitId id)
-wantToSee (ADataCon _) = False -- They'll come via their TyCon
-wantToSee _ = True
-
----------------------
load_iface mod = loadSrcInterface doc mod False {- Not boot iface -}
where
doc = ptext SLIT("context for compiling statements")
----------------------
-noRdrEnvErr mod = ptext SLIT("No top-level environment available for module")
- <+> quotes (ppr mod)
-\end{code}
-
-\begin{code}
-type GetInfoResult = (String, IfaceDecl, Fixity, SrcLoc,
- [(IfaceType,SrcLoc)] -- Instances
- )
tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Maybe [Name])
-
tcRnLookupRdrName hsc_env rdr_name
= initTcPrintErrors hsc_env iNTERACTIVE $
setInteractiveContext hsc_env (hsc_IC hsc_env) $
lookup_rdr_name rdr_name
-
lookup_rdr_name rdr_name = do {
-- If the identifier is a constructor (begins with an
-- upper-case letter), then we need to consider both
}
+tcRnLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
+tcRnLookupName hsc_env name
+ = initTcPrintErrors hsc_env iNTERACTIVE $
+ setInteractiveContext hsc_env (hsc_IC hsc_env) $
+ tcLookupGlobal name
+
+
tcRnGetInfo :: HscEnv
- -> InteractiveContext
- -> RdrName
- -> IO (Maybe [GetInfoResult])
+ -> Name
+ -> IO (Maybe (TyThing, Fixity, [Instance]))
-- Used to implemnent :info in GHCi
--
-- but we want to treat it as *both* a data constructor
-- *and* as a type or class constructor;
-- hence the call to dataTcOccs, and we return up to two results
-tcRnGetInfo hsc_env ictxt rdr_name
+tcRnGetInfo hsc_env name
= initTcPrintErrors hsc_env iNTERACTIVE $
- setInteractiveContext hsc_env ictxt $ do {
+ let ictxt = hsc_IC hsc_env in
+ setInteractiveContext hsc_env ictxt $ do
-- Load the interface for all unqualified types and classes
-- That way we will find all the instance declarations
-- (Packages have not orphan modules, and we assume that
-- in the home package all relevant modules are loaded.)
- loadUnqualIfaces ictxt ;
-
- good_names <- lookup_rdr_name rdr_name ;
-
- -- And lookup up the entities, avoiding duplicates, which arise
- -- because constructors and record selectors are represented by
- -- their parent declaration
- let { do_one name = do { thing <- tcLookupGlobal name
- ; fixity <- lookupFixityRn name
- ; ispecs <- lookupInsts print_unqual thing
- ; return (str, toIfaceDecl ext_nm thing, fixity,
- getSrcLoc thing,
- [(toIfaceType ext_nm (idType dfun), getSrcLoc dfun)
- | dfun <- map instanceDFunId ispecs ]
- ) }
- where
- -- str is the the naked occurrence name
- -- after stripping off qualification and parens (+)
- str = occNameUserString (nameOccName name)
-
- ; parent_is_there n
- | Just p <- nameParent_maybe n = p `elem` good_names
- | otherwise = False
- } ;
-
- -- For the SrcLoc, the 'thing' has better info than
- -- the 'name' because getting the former forced the
- -- declaration to be loaded into the cache
-
- mapM do_one (filter (not . parent_is_there) good_names)
- -- Filter out names whose parent is also there
- -- Good example is '[]', which is both a type and data constructor
- -- in the same type
- }
- where
- ext_nm = interactiveExtNameFun print_unqual
- print_unqual = icPrintUnqual ictxt
+ loadUnqualIfaces ictxt
+
+ thing <- tcLookupGlobal name
+ fixity <- lookupFixityRn name
+ ispecs <- lookupInsts (icPrintUnqual ictxt) thing
+ return (thing, fixity, ispecs)
+
lookupInsts :: PrintUnqualified -> TyThing -> TcM [Instance]
-- Filter the instances by the ones whose tycons (or clases resp)
| isExternalName name = print_unqual (nameModule name) (nameOccName name)
| otherwise = True
-toIfaceDecl :: (Name -> IfaceExtName) -> TyThing -> IfaceDecl
-toIfaceDecl ext_nm thing
- = tyThingToIfaceDecl ext_nm (munge thing)
- where
- -- munge transforms a thing to its "parent" thing
- munge (ADataCon dc) = ATyCon (dataConTyCon dc)
- munge (AnId id) = case globalIdDetails id of
- RecordSelId tc lbl -> ATyCon tc
- ClassOpId cls -> AClass cls
- other -> AnId id
- munge other_thing = other_thing
-
loadUnqualIfaces :: InteractiveContext -> TcM ()
-- Load the home module for everything that is in scope unqualified
-- This is so that we can accurately report the instances for
\begin{code}
traceTc, traceRn :: SDoc -> TcRn ()
-traceRn = dumpOptTcRn Opt_D_dump_rn_trace
-traceTc = dumpOptTcRn Opt_D_dump_tc_trace
-traceSplice = dumpOptTcRn Opt_D_dump_splices
+traceRn = traceOptTcRn Opt_D_dump_rn_trace
+traceTc = traceOptTcRn Opt_D_dump_tc_trace
+traceSplice = traceOptTcRn Opt_D_dump_splices
traceIf :: SDoc -> TcRnIf m n ()
-traceIf = dumpOptIf Opt_D_dump_if_trace
-traceHiDiffs = dumpOptIf Opt_D_dump_hi_diffs
+traceIf = traceOptIf Opt_D_dump_if_trace
+traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs
-dumpOptIf :: DynFlag -> SDoc -> TcRnIf m n () -- No RdrEnv available, so qualify everything
-dumpOptIf flag doc = ifOptM flag $
+traceOptIf :: DynFlag -> SDoc -> TcRnIf m n () -- No RdrEnv available, so qualify everything
+traceOptIf flag doc = ifOptM flag $
ioToIOEnv (printForUser stderr alwaysQualify doc)
-dumpOptTcRn :: DynFlag -> SDoc -> TcRn ()
-dumpOptTcRn flag doc = ifOptM flag $ do
+traceOptTcRn :: DynFlag -> SDoc -> TcRn ()
+traceOptTcRn flag doc = ifOptM flag $ do
{ ctxt <- getErrCtxt
; loc <- getSrcSpanM
; ctxt_msgs <- do_ctxt emptyTidyEnv ctxt
dumpTcRn :: SDoc -> TcRn ()
dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv ;
ioToTcRn (printForUser stderr (unQualInScope rdr_env) doc) }
+
+dumpOptTcRn :: DynFlag -> SDoc -> TcRn ()
+dumpOptTcRn flag doc = ifOptM flag (dumpTcRn doc)
\end{code}
DefMeth (..),
mkClass, classTyVars, classArity,
- classKey, className, classSelIds, classTyCon,
+ classKey, className, classSelIds, classTyCon, classMethods,
classBigSig, classExtraBigSig, classTvsFds, classSCTheta
) where
classArity clas = length (classTyVars clas)
-- Could memoise this
-classSelIds (Class {classSCSels = sc_sels, classOpStuff = op_stuff})
- = sc_sels ++ [op_sel | (op_sel, _) <- op_stuff]
+classSelIds :: Class -> [Id]
+classSelIds c@(Class {classSCSels = sc_sels})
+ = sc_sels ++ classMethods c
+
+classMethods :: Class -> [Id]
+classMethods (Class {classOpStuff = op_stuff})
+ = [op_sel | (op_sel, _) <- op_stuff]
classTvsFds c
= (classTyVars c, classFunDeps c)
pprInstance ispec@(Instance { is_flag = flag })
= hang (ptext SLIT("instance") <+> ppr flag
<+> sep [pprThetaArrow theta, pprClassPred clas tys])
- 2 (parens (pprDefnLoc (getSrcLoc ispec)))
+ 2 (ptext SLIT("--") <+> (pprDefnLoc (getSrcLoc ispec)))
where
(_, theta, clas, tys) = instanceHead ispec
-- Print without the for-all, which the programmer doesn't write
projects / ghc-hetmet.git / commitdiff