Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Alex D
GHC
Commits
6c9010f6
Commit
6c9010f6
authored
Jul 09, 2007
by
Ian Lynagh
Browse files
Add -fprint-explicit-foralls flag; fixes trac #1474
parent
230dc0b0
Changes
3
Hide whitespace changes
Inline
Side-by-side
compiler/ghci/InteractiveUI.hs
View file @
6c9010f6
...
...
@@ -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
ext
s
=
dopt
Opt_
GlasgowExt
s
dflags
;
mapM_
(
infoThing
ext
s
session
)
names
}
;
let
pefa
s
=
dopt
Opt_
PrintExplicitForall
s
dflags
;
mapM_
(
infoThing
pefa
s
session
)
names
}
where
infoThing
ext
s
session
str
=
io
$
do
infoThing
pefa
s
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
ext
s
stuff
|
Just
stuff
<-
mb_stuffs
]))
[
pprInfo
pefa
s
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
ext
s
=
dopt
Opt_
GlasgowExt
s
dflags
let
pefa
s
=
dopt
Opt_
PrintExplicitForall
s
dflags
io
(
putStrLn
(
showSDocForUser
unqual
(
vcat
(
map
(
pprTyThingInContext
ext
s
)
(
catMaybes
things
))
vcat
(
map
(
pprTyThingInContext
pefa
s
)
(
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_
GlasgowExt
s
dflags
if
dopt
Opt_
PrintExplicitForall
s
dflags
then
return
ty
else
return
$!
GHC
.
dropForAlls
ty
...
...
compiler/main/DynFlags.hs
View file @
6c9010f6
...
...
@@ -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
...
...
compiler/main/PprTyThing.hs
View file @
6c9010f6
...
...
@@ -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
ext
s
tyThing
=
showWithLoc
loc
(
pprTyThing
ext
s
tyThing
)
pprTyThingLoc
::
PrintExplicitForalls
->
TyThing
->
SDoc
pprTyThingLoc
pefa
s
tyThing
=
showWithLoc
loc
(
pprTyThing
pefa
s
tyThing
)
where
loc
=
GHC
.
nameSrcSpan
(
GHC
.
getName
tyThing
)
-- | Pretty-prints a 'TyThing'.
pprTyThing
::
Bool
->
TyThing
->
SDoc
pprTyThing
ext
s
(
AnId
id
)
=
pprId
ext
s
id
pprTyThing
ext
s
(
ADataCon
dataCon
)
=
pprDataConSig
ext
s
dataCon
pprTyThing
ext
s
(
ATyCon
tyCon
)
=
pprTyCon
ext
s
tyCon
pprTyThing
ext
s
(
AClass
cls
)
=
pprClass
ext
s
cls
pprTyThing
::
PrintExplicitForalls
->
TyThing
->
SDoc
pprTyThing
pefa
s
(
AnId
id
)
=
pprId
pefa
s
id
pprTyThing
pefa
s
(
ADataCon
dataCon
)
=
pprDataConSig
pefa
s
dataCon
pprTyThing
pefa
s
(
ATyCon
tyCon
)
=
pprTyCon
pefa
s
tyCon
pprTyThing
pefa
s
(
AClass
cls
)
=
pprClass
pefa
s
cls
-- | Like 'pprTyThingInContext', but adds the defining location.
pprTyThingInContextLoc
::
Bool
->
TyThing
->
SDoc
pprTyThingInContextLoc
ext
s
tyThing
=
showWithLoc
loc
(
pprTyThingInContext
ext
s
tyThing
)
pprTyThingInContextLoc
::
PrintExplicitForalls
->
TyThing
->
SDoc
pprTyThingInContextLoc
pefa
s
tyThing
=
showWithLoc
loc
(
pprTyThingInContext
pefa
s
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
ext
s
(
AnId
id
)
=
pprIdInContext
ext
s
id
pprTyThingInContext
ext
s
(
ADataCon
dataCon
)
=
pprDataCon
ext
s
dataCon
pprTyThingInContext
ext
s
(
ATyCon
tyCon
)
=
pprTyCon
ext
s
tyCon
pprTyThingInContext
ext
s
(
AClass
cls
)
=
pprClass
ext
s
cls
pprTyThingInContext
::
PrintExplicitForalls
->
TyThing
->
SDoc
pprTyThingInContext
pefa
s
(
AnId
id
)
=
pprIdInContext
pefa
s
id
pprTyThingInContext
pefa
s
(
ADataCon
dataCon
)
=
pprDataCon
pefa
s
dataCon
pprTyThingInContext
pefa
s
(
ATyCon
tyCon
)
=
pprTyCon
pefa
s
tyCon
pprTyThingInContext
pefa
s
(
AClass
cls
)
=
pprClass
pefa
s
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
ext
s
(
AnId
id
)
=
pprId
ext
s
id
pprTyThingHdr
ext
s
(
ADataCon
dataCon
)
=
pprDataConSig
ext
s
dataCon
pprTyThingHdr
ext
s
(
ATyCon
tyCon
)
=
pprTyConHdr
ext
s
tyCon
pprTyThingHdr
ext
s
(
AClass
cls
)
=
pprClassHdr
ext
s
cls
pprTyThingHdr
::
PrintExplicitForalls
->
TyThing
->
SDoc
pprTyThingHdr
pefa
s
(
AnId
id
)
=
pprId
pefa
s
id
pprTyThingHdr
pefa
s
(
ADataCon
dataCon
)
=
pprDataConSig
pefa
s
dataCon
pprTyThingHdr
pefa
s
(
ATyCon
tyCon
)
=
pprTyConHdr
pefa
s
tyCon
pprTyThingHdr
pefa
s
(
AClass
cls
)
=
pprClassHdr
pefa
s
cls
pprTyConHdr
ext
s
tyCon
pprTyConHdr
pefa
s
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
ext
s
dataCon
=
ppr_bndr
dataCon
<+>
dcolon
<+>
pprType
ext
s
(
GHC
.
dataConType
dataCon
)
pprDataConSig
pefa
s
dataCon
=
ppr_bndr
dataCon
<+>
dcolon
<+>
pprType
pefa
s
(
GHC
.
dataConType
dataCon
)
pprClassHdr
ext
s
cls
=
pprClassHdr
pefa
s
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
ext
s
id
|
GHC
.
isRecordSelector
id
=
pprRecordSelector
ext
s
id
|
Just
cls
<-
GHC
.
isClassOpId_maybe
id
=
pprClassOneMethod
ext
s
cls
id
|
otherwise
=
pprId
ext
s
id
pprIdInContext
pefa
s
id
|
GHC
.
isRecordSelector
id
=
pprRecordSelector
pefa
s
id
|
Just
cls
<-
GHC
.
isClassOpId_maybe
id
=
pprClassOneMethod
pefa
s
cls
id
|
otherwise
=
pprId
pefa
s
id
pprRecordSelector
ext
s
id
=
pprAlgTyCon
ext
s
tyCon
show_con
show_label
pprRecordSelector
pefa
s
id
=
pprAlgTyCon
pefa
s
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
ext
s
tyCon
pprTyCon
pefa
s
tyCon
|
GHC
.
isSynTyCon
tyCon
=
if
GHC
.
isOpenTyCon
tyCon
then
pprTyConHdr
ext
s
tyCon
<+>
dcolon
<+>
pprType
ext
s
(
GHC
.
synTyConResKind
tyCon
)
then
pprTyConHdr
pefa
s
tyCon
<+>
dcolon
<+>
pprType
pefa
s
(
GHC
.
synTyConResKind
tyCon
)
else
let
rhs_type
=
GHC
.
synTyConType
tyCon
in
hang
(
pprTyConHdr
ext
s
tyCon
<+>
equals
)
2
(
pprType
ext
s
rhs_type
)
in
hang
(
pprTyConHdr
pefa
s
tyCon
<+>
equals
)
2
(
pprType
pefa
s
rhs_type
)
|
otherwise
=
pprAlgTyCon
ext
s
tyCon
(
const
True
)
(
const
True
)
=
pprAlgTyCon
pefa
s
tyCon
(
const
True
)
(
const
True
)
pprAlgTyCon
ext
s
tyCon
ok_con
ok_label
|
gadt
=
pprTyConHdr
ext
s
tyCon
<+>
ptext
SLIT
(
"where"
)
$$
pprAlgTyCon
pefa
s
tyCon
ok_con
ok_label
|
gadt
=
pprTyConHdr
pefa
s
tyCon
<+>
ptext
SLIT
(
"where"
)
$$
nest
2
(
vcat
(
ppr_trim
show_con
datacons
))
|
otherwise
=
hang
(
pprTyConHdr
ext
s
tyCon
)
|
otherwise
=
hang
(
pprTyConHdr
pefa
s
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
ext
s
gadt
ok_label
dataCon
)
|
ok_con
dataCon
=
Just
(
pprDataConDecl
pefa
s
gadt
ok_label
dataCon
)
|
otherwise
=
Nothing
pprDataCon
ext
s
dataCon
=
pprAlgTyCon
ext
s
tyCon
(
==
dataCon
)
(
const
True
)
pprDataCon
pefa
s
dataCon
=
pprAlgTyCon
pefa
s
tyCon
(
==
dataCon
)
(
const
True
)
where
tyCon
=
GHC
.
dataConTyCon
dataCon
pprDataConDecl
ext
s
gadt_style
show_label
dataCon
pprDataConDecl
pefa
s
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
ext
s
cls
pprClass
pefa
s
cls
|
null
methods
=
pprClassHdr
ext
s
cls
pprClassHdr
pefa
s
cls
|
otherwise
=
hang
(
pprClassHdr
ext
s
cls
<+>
ptext
SLIT
(
"where"
))
2
(
vcat
(
map
(
pprClassMethod
ext
s
)
methods
))
hang
(
pprClassHdr
pefa
s
cls
<+>
ptext
SLIT
(
"where"
))
2
(
vcat
(
map
(
pprClassMethod
pefa
s
)
methods
))
where
methods
=
GHC
.
classMethods
cls
pprClassOneMethod
ext
s
cls
this_one
=
hang
(
pprClassHdr
ext
s
cls
<+>
ptext
SLIT
(
"where"
))
pprClassOneMethod
pefa
s
cls
this_one
=
hang
(
pprClassHdr
pefa
s
cls
<+>
ptext
SLIT
(
"where"
))
2
(
vcat
(
ppr_trim
show_meth
methods
))
where
methods
=
GHC
.
classMethods
cls
show_meth
id
|
id
==
this_one
=
Just
(
pprClassMethod
ext
s
id
)
show_meth
id
|
id
==
this_one
=
Just
(
pprClassMethod
pefa
s
id
)
|
otherwise
=
Nothing
pprClassMethod
ext
s
id
=
hang
(
ppr_bndr
id
<+>
dcolon
)
2
(
pprType
ext
s
(
classOpType
id
))
pprClassMethod
pefa
s
id
=
hang
(
ppr_bndr
id
<+>
dcolon
)
2
(
pprType
pefa
s
(
classOpType
id
))
where
-- Here's the magic incantation to strip off the dictionary
-- from the class op type. Stolen from IfaceSyn.tyThingToIfaceDecl.
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment