Commit 6c9010f6 authored by Ian Lynagh's avatar Ian Lynagh

Add -fprint-explicit-foralls flag; fixes trac #1474

parent 230dc0b0
......@@ -663,17 +663,17 @@ info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
info s = do { let names = words s
; session <- getSession
; dflags <- getDynFlags
; let exts = dopt Opt_GlasgowExts dflags
; mapM_ (infoThing exts session) names }
; let pefas = dopt Opt_PrintExplicitForalls dflags
; mapM_ (infoThing pefas session) names }
where
infoThing exts session str = io $ do
infoThing pefas 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 ]))
[ pprInfo pefas stuff | Just stuff <- mb_stuffs ]))
-- Filter out names whose parent is also there Good
-- example is '[]', which is both a type and data
......@@ -685,8 +685,9 @@ filterOutChildren names = filter (not . parent_is_there) names
-- ToDo!!
| otherwise = False
pprInfo exts (thing, fixity, insts)
= pprTyThingInContextLoc exts thing
pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
pprInfo pefas (thing, fixity, insts)
= pprTyThingInContextLoc pefas thing
$$ show_fixity fixity
$$ vcat (map GHC.pprInstance insts)
where
......@@ -1000,9 +1001,9 @@ browseModule m exports_only = do
things <- io $ mapM (GHC.lookupName s) filtered
dflags <- getDynFlags
let exts = dopt Opt_GlasgowExts dflags
let pefas = dopt Opt_PrintExplicitForalls dflags
io (putStrLn (showSDocForUser unqual (
vcat (map (pprTyThingInContext exts) (catMaybes things))
vcat (map (pprTyThingInContext pefas) (catMaybes things))
)))
-- ToDo: modInfoInstances currently throws an exception for
-- package modules. When it works, we can do this:
......@@ -1264,7 +1265,7 @@ printTyThing _ = return ()
cleanType :: Type -> GHCi Type
cleanType ty = do
dflags <- getDynFlags
if dopt Opt_GlasgowExts dflags
if dopt Opt_PrintExplicitForalls dflags
then return ty
else return $! GHC.dropForAlls ty
......
......@@ -201,6 +201,8 @@ data DynFlag
| Opt_Rank2Types
| Opt_RankNTypes
| Opt_PrintExplicitForalls
-- optimisation opts
| Opt_Strictness
| Opt_FullLaziness
......@@ -1081,6 +1083,7 @@ fFlags = [
( "warn-deprecations", Opt_WarnDeprecations ),
( "warn-orphans", Opt_WarnOrphans ),
( "warn-tabs", Opt_WarnTabs ),
( "print-explicit-foralls", Opt_PrintExplicitForalls ),
( "strictness", Opt_Strictness ),
( "full-laziness", Opt_FullLaziness ),
( "liberate-case", Opt_LiberateCase ),
......@@ -1166,6 +1169,7 @@ impliedFlags = [
]
glasgowExtsFlags = [ Opt_GlasgowExts
, Opt_PrintExplicitForalls
, Opt_FFI
, Opt_GADTs
, Opt_ImplicitParams
......
......@@ -7,6 +7,7 @@
-----------------------------------------------------------------------------
module PprTyThing (
PrintExplicitForalls,
pprTyThing,
pprTyThingInContext,
pprTyThingLoc,
......@@ -21,6 +22,7 @@ import qualified GHC
import TyCon ( tyConFamInst_maybe )
import Type ( pprTypeApp )
import GHC ( TyThing(..), SrcSpan )
import Var
import Outputable
-- -----------------------------------------------------------------------------
......@@ -29,45 +31,47 @@ import Outputable
-- This should be a good source of sample code for using the GHC API to
-- inspect source code entities.
type PrintExplicitForalls = Bool
-- | Pretty-prints a 'TyThing' with its defining location.
pprTyThingLoc :: Bool -> TyThing -> SDoc
pprTyThingLoc exts tyThing
= showWithLoc loc (pprTyThing exts tyThing)
pprTyThingLoc :: PrintExplicitForalls -> TyThing -> SDoc
pprTyThingLoc pefas tyThing
= showWithLoc loc (pprTyThing pefas tyThing)
where loc = GHC.nameSrcSpan (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
pprTyThing :: PrintExplicitForalls -> TyThing -> SDoc
pprTyThing pefas (AnId id) = pprId pefas id
pprTyThing pefas (ADataCon dataCon) = pprDataConSig pefas dataCon
pprTyThing pefas (ATyCon tyCon) = pprTyCon pefas tyCon
pprTyThing pefas (AClass cls) = pprClass pefas cls
-- | Like 'pprTyThingInContext', but adds the defining location.
pprTyThingInContextLoc :: Bool -> TyThing -> SDoc
pprTyThingInContextLoc exts tyThing
= showWithLoc loc (pprTyThingInContext exts tyThing)
pprTyThingInContextLoc :: PrintExplicitForalls -> TyThing -> SDoc
pprTyThingInContextLoc pefas tyThing
= showWithLoc loc (pprTyThingInContext pefas tyThing)
where loc = GHC.nameSrcSpan (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
pprTyThingInContext :: PrintExplicitForalls -> TyThing -> SDoc
pprTyThingInContext pefas (AnId id) = pprIdInContext pefas id
pprTyThingInContext pefas (ADataCon dataCon) = pprDataCon pefas dataCon
pprTyThingInContext pefas (ATyCon tyCon) = pprTyCon pefas tyCon
pprTyThingInContext pefas (AClass cls) = pprClass pefas cls
-- | Pretty-prints the 'TyThing' header. For functions and data constructors
-- the function is equivalent to 'pprTyThing' but for type constructors
-- and classes it prints only the header part of the declaration.
pprTyThingHdr :: Bool -> TyThing -> SDoc
pprTyThingHdr exts (AnId id) = pprId exts id
pprTyThingHdr exts (ADataCon dataCon) = pprDataConSig exts dataCon
pprTyThingHdr exts (ATyCon tyCon) = pprTyConHdr exts tyCon
pprTyThingHdr exts (AClass cls) = pprClassHdr exts cls
pprTyThingHdr :: PrintExplicitForalls -> TyThing -> SDoc
pprTyThingHdr pefas (AnId id) = pprId pefas id
pprTyThingHdr pefas (ADataCon dataCon) = pprDataConSig pefas dataCon
pprTyThingHdr pefas (ATyCon tyCon) = pprTyConHdr pefas tyCon
pprTyThingHdr pefas (AClass cls) = pprClassHdr pefas cls
pprTyConHdr exts tyCon
pprTyConHdr pefas tyCon
| Just (fam_tc, tys) <- tyConFamInst_maybe tyCon
= ptext keyword <+> ptext SLIT("instance") <+> pprTypeApp tyCon (ppr_bndr tyCon) tys
| otherwise
......@@ -85,10 +89,10 @@ pprTyConHdr exts tyCon
| GHC.isOpenTyCon tyCon = ptext SLIT("family")
| otherwise = empty
pprDataConSig exts dataCon =
ppr_bndr dataCon <+> dcolon <+> pprType exts (GHC.dataConType dataCon)
pprDataConSig pefas dataCon =
ppr_bndr dataCon <+> dcolon <+> pprType pefas (GHC.dataConType dataCon)
pprClassHdr exts cls =
pprClassHdr pefas cls =
let (tyVars, funDeps) = GHC.classTvsFds cls
in ptext SLIT("class") <+>
GHC.pprThetaArrow (GHC.classSCTheta cls) <+>
......@@ -96,53 +100,55 @@ pprClassHdr exts 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
pprIdInContext pefas id
| GHC.isRecordSelector id = pprRecordSelector pefas id
| Just cls <- GHC.isClassOpId_maybe id = pprClassOneMethod pefas cls id
| otherwise = pprId pefas id
pprRecordSelector exts id
= pprAlgTyCon exts tyCon show_con show_label
pprRecordSelector pefas id
= pprAlgTyCon pefas 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))
pprId :: PrintExplicitForalls -> Var -> SDoc
pprId pefas ident
= hang (ppr_bndr ident <+> dcolon) 2
(pprType pefas (GHC.idType ident))
pprType :: PrintExplicitForalls -> GHC.Type -> SDoc
pprType True ty = ppr ty
pprType False ty = ppr (GHC.dropForAlls ty)
pprTyCon exts tyCon
pprTyCon pefas tyCon
| GHC.isSynTyCon tyCon
= if GHC.isOpenTyCon tyCon
then pprTyConHdr exts tyCon <+> dcolon <+>
pprType exts (GHC.synTyConResKind tyCon)
then pprTyConHdr pefas tyCon <+> dcolon <+>
pprType pefas (GHC.synTyConResKind tyCon)
else
let rhs_type = GHC.synTyConType tyCon
in hang (pprTyConHdr exts tyCon <+> equals) 2 (pprType exts rhs_type)
in hang (pprTyConHdr pefas tyCon <+> equals) 2 (pprType pefas rhs_type)
| otherwise
= pprAlgTyCon exts tyCon (const True) (const True)
= pprAlgTyCon pefas tyCon (const True) (const True)
pprAlgTyCon exts tyCon ok_con ok_label
| gadt = pprTyConHdr exts tyCon <+> ptext SLIT("where") $$
pprAlgTyCon pefas tyCon ok_con ok_label
| gadt = pprTyConHdr pefas tyCon <+> ptext SLIT("where") $$
nest 2 (vcat (ppr_trim show_con datacons))
| otherwise = hang (pprTyConHdr exts tyCon)
| otherwise = hang (pprTyConHdr pefas 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)
| ok_con dataCon = Just (pprDataConDecl pefas gadt ok_label dataCon)
| otherwise = Nothing
pprDataCon exts dataCon = pprAlgTyCon exts tyCon (== dataCon) (const True)
pprDataCon pefas dataCon = pprAlgTyCon pefas tyCon (== dataCon) (const True)
where tyCon = GHC.dataConTyCon dataCon
pprDataConDecl exts gadt_style show_label dataCon
pprDataConDecl pefas 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 ]
......@@ -186,25 +192,25 @@ pprDataConDecl exts gadt_style show_label dataCon
braces (sep (punctuate comma (ppr_trim maybe_show_label
(zip labels fields))))
pprClass exts cls
pprClass pefas cls
| null methods =
pprClassHdr exts cls
pprClassHdr pefas cls
| otherwise =
hang (pprClassHdr exts cls <+> ptext SLIT("where"))
2 (vcat (map (pprClassMethod exts) methods))
hang (pprClassHdr pefas cls <+> ptext SLIT("where"))
2 (vcat (map (pprClassMethod pefas) methods))
where
methods = GHC.classMethods cls
pprClassOneMethod exts cls this_one =
hang (pprClassHdr exts cls <+> ptext SLIT("where"))
pprClassOneMethod pefas cls this_one =
hang (pprClassHdr pefas 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)
show_meth id | id == this_one = Just (pprClassMethod pefas id)
| otherwise = Nothing
pprClassMethod exts id =
hang (ppr_bndr id <+> dcolon) 2 (pprType exts (classOpType id))
pprClassMethod pefas id =
hang (ppr_bndr id <+> dcolon) 2 (pprType pefas (classOpType id))
where
-- Here's the magic incantation to strip off the dictionary
-- from the class op type. Stolen from IfaceSyn.tyThingToIfaceDecl.
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment