Commit 03d8585e authored by David Waern's avatar David Waern

Refactor Haddock options

This patch renames the DOC_OPTIONS pragma to OPTIONS_HADDOCK. It also
adds "-- # ..."-style Haddock option pragmas, for compatibility with
code that use them.

Another change is that both of these two pragmas behave like
OPTIONS_GHC, i.e. they are only allowed at the top of the module, they
are ignored everywhere else and they are stored in the dynflags. There is
no longer any Haddock options in HsSyn.

Please merge this to the 6.8.2 branch when 6.8.1 is out, if appropriate.
parent 1ab9e52b
......@@ -70,7 +70,6 @@ data HsModule name
-- often empty, downstream.
[LHsDecl name] -- Type, class, value, and interface signature decls
(Maybe DeprecTxt) -- reason/explanation for deprecation of this module
(Maybe String) -- Haddock options, declared with the {-# DOCOPTIONS ... #-} pragma
(HaddockModInfo name) -- Haddock module info
(Maybe (HsDoc name)) -- Haddock module description
......@@ -105,10 +104,10 @@ instance Outputable Char where
instance (OutputableBndr name)
=> Outputable (HsModule name) where
ppr (HsModule Nothing _ imports decls _ _ _ mbDoc)
ppr (HsModule Nothing _ imports decls _ _ mbDoc)
= pp_mb mbDoc $$ pp_nonnull imports $$ pp_nonnull decls
ppr (HsModule (Just name) exports imports decls deprec opts _ mbDoc)
ppr (HsModule (Just name) exports imports decls deprec _ mbDoc)
= vcat [
pp_mb mbDoc,
case exports of
......
......@@ -267,6 +267,7 @@ data DynFlag
| Opt_HideAllPackages
| Opt_PrintBindResult
| Opt_Haddock
| Opt_HaddockOptions
| Opt_Hpc_No_Auto
| Opt_BreakOnException
| Opt_BreakOnError
......@@ -390,7 +391,9 @@ data DynFlags = DynFlags {
flags :: [DynFlag],
-- message output
log_action :: Severity -> SrcSpan -> PprStyle -> Message -> IO ()
log_action :: Severity -> SrcSpan -> PprStyle -> Message -> IO (),
haddockOptions :: Maybe String
}
data HscTarget
......@@ -519,6 +522,7 @@ defaultDynFlags =
packageFlags = [],
pkgDatabase = Nothing,
pkgState = panic "no package state yet: call GHC.setSessionDynFlags",
haddockOptions = Nothing,
flags = [
Opt_ReadUserPackageConf,
......@@ -617,6 +621,8 @@ addOptwindres f d = d{ opt_windres = f : opt_windres d}
addCmdlineFramework f d = d{ cmdlineFrameworks = f : cmdlineFrameworks d}
addHaddockOpts f d = d{ haddockOptions = Just f}
-- -----------------------------------------------------------------------------
-- Command-line options
......@@ -1011,6 +1017,7 @@ dynamic_flags = [
, ( "no-hs-main" , NoArg (setDynFlag Opt_NoHsMain))
, ( "main-is" , SepArg setMainIs )
, ( "haddock" , NoArg (setDynFlag Opt_Haddock) )
, ( "haddock-opts" , HasArg (upd . addHaddockOpts))
, ( "hpcdir" , SepArg setOptHpcDir )
------- recompilation checker (DEPRECATED, use -fforce-recomp) -----
......
......@@ -67,7 +67,7 @@ getImports dflags buf filename source_filename = do
printErrorsAndWarnings dflags ms
when (errorsFound dflags ms) $ exitWith (ExitFailure 1)
case rdr_module of
L _ (HsModule mb_mod _ imps _ _ _ _ _) ->
L _ (HsModule mb_mod _ imps _ _ _ _) ->
let
main_loc = mkSrcLoc (mkFastString source_filename) 1 0
mod = mb_mod `orElse` L (srcLocSpan main_loc) mAIN_NAME
......@@ -146,6 +146,15 @@ getOptions' buf filename
, ITclose_prag <- getToken close
= map (L (getLoc open)) ["-#include",removeSpaces str] `combine`
parseToks xs
parseToks (open:close:xs)
| ITdocOptions str <- getToken open
, ITclose_prag <- getToken close
= map (L (getLoc open)) ["-haddock-opts", removeSpaces str]
`combine` parseToks xs
parseToks (open:xs)
| ITdocOptionsOld str <- getToken open
= map (L (getLoc open)) ["-haddock-opts", removeSpaces str]
`combine` parseToks xs
parseToks (open:xs)
| ITlanguage_prag <- getToken open
= parseLanguage xs
......
......@@ -30,7 +30,7 @@ import Util ( count )
%************************************************************************
\begin{code}
ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _ _ _))
ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _ _))
= (if short then hcat else vcat)
(map pp_val
[("ExportAll ", export_all), -- 1 if no export list
......
......@@ -149,7 +149,7 @@ $tab+ { warn Opt_WarnTabs (text "Tab character") }
-- space followed by a Haddock comment symbol (docsym) (in which case we'd
-- have a Haddock comment). The rules then munch the rest of the line.
"-- " ~$docsym .* ;
"-- " ~[$docsym \#] .* ;
"--" [^$symbol : \ ] .* ;
-- Next, match Haddock comments if no -haddock flag
......@@ -257,9 +257,6 @@ $tab+ { warn Opt_WarnTabs (text "Tab character") }
"{-#" $whitechar* (CORE|core) { token ITcore_prag }
"{-#" $whitechar* (UNPACK|unpack) { token ITunpack_prag }
"{-#" $whitechar* (DOC_OPTIONS|doc_options)
/ { ifExtension haddockEnabled } { lex_string_prag ITdocOptions }
"{-#" { nested_comment lexToken }
-- ToDo: should only be valid inside a pragma:
......@@ -267,11 +264,18 @@ $tab+ { warn Opt_WarnTabs (text "Tab character") }
}
<option_prags> {
"{-#" $whitechar* (OPTIONS|options) { lex_string_prag IToptions_prag }
"{-#" $whitechar* (OPTIONS_GHC|options_ghc)
"{-#" $whitechar* (OPTIONS|options) { lex_string_prag IToptions_prag }
"{-#" $whitechar* (OPTIONS_GHC|options_ghc)
{ lex_string_prag IToptions_prag }
"{-#" $whitechar* (LANGUAGE|language) { token ITlanguage_prag }
"{-#" $whitechar* (INCLUDE|include) { lex_string_prag ITinclude_prag }
"{-#" $whitechar* (OPTIONS_HADDOCK|options_haddock)
{ lex_string_prag ITdocOptions }
"-- #" { multiline_doc_comment }
"{-#" $whitechar* (LANGUAGE|language) { token ITlanguage_prag }
"{-#" $whitechar* (INCLUDE|include) { lex_string_prag ITinclude_prag }
}
<0> {
"-- #" .* ;
}
<0,option_prags> {
......@@ -284,8 +288,8 @@ $tab+ { warn Opt_WarnTabs (text "Tab character") }
-- Haddock comments
<0> {
"-- " $docsym / { ifExtension haddockEnabled } { multiline_doc_comment }
"{-" \ ? $docsym / { ifExtension haddockEnabled } { nested_doc_comment }
"-- " $docsym / { ifExtension haddockEnabled } { multiline_doc_comment }
"{-" \ ? $docsym / { ifExtension haddockEnabled } { nested_doc_comment }
}
-- "special" symbols
......@@ -555,6 +559,7 @@ data Token
| ITdocCommentNamed String -- something beginning '-- $'
| ITdocSection Int String -- a section heading
| ITdocOptions String -- doc options (prune, ignore-exports, etc)
| ITdocOptionsOld String -- doc options declared "-- # ..."-style
#ifdef DEBUG
deriving Show -- debugging
......@@ -819,7 +824,8 @@ withLexedDocType lexDocComment = do
'|' -> lexDocComment input ITdocCommentNext False
'^' -> lexDocComment input ITdocCommentPrev False
'$' -> lexDocComment input ITdocCommentNamed False
'*' -> lexDocSection 1 input
'*' -> lexDocSection 1 input
'#' -> lexDocComment input ITdocOptionsOld False
where
lexDocSection n input = case alexGetChar input of
Just ('*', input) -> lexDocSection (n+1) input
......
......@@ -322,7 +322,6 @@ incorrect.
DOCPREV { L _ (ITdocCommentPrev _) }
DOCNAMED { L _ (ITdocCommentNamed _) }
DOCSECTION { L _ (ITdocSection _ _) }
DOCOPTIONS { L _ (ITdocOptions _) }
-- Template Haskell
'[|' { L _ ITopenExpQuote }
......@@ -365,22 +364,19 @@ identifier :: { Located RdrName }
-- know what they are doing. :-)
module :: { Located (HsModule RdrName) }
: optdoc 'module' modid maybemoddeprec maybeexports 'where' body
{% fileSrcSpan >>= \ loc -> case $1 of { (opt, info, doc) ->
return (L loc (HsModule (Just $3) $5 (fst $7) (snd $7) $4
opt info doc) )}}
: maybedocheader 'module' modid maybemoddeprec maybeexports 'where' body
{% fileSrcSpan >>= \ loc -> case $1 of { (info, doc) ->
return (L loc (HsModule (Just $3) $5 (fst $7) (snd $7) $4
info doc) )}}
| body2
{% fileSrcSpan >>= \ loc ->
return (L loc (HsModule Nothing Nothing
(fst $1) (snd $1) Nothing Nothing emptyHaddockModInfo
return (L loc (HsModule Nothing Nothing
(fst $1) (snd $1) Nothing emptyHaddockModInfo
Nothing)) }
optdoc :: { (Maybe String, HaddockModInfo RdrName, Maybe (HsDoc RdrName)) }
: moduleheader { (Nothing, fst $1, snd $1) }
| docoptions { (Just $1, emptyHaddockModInfo, Nothing)}
| docoptions moduleheader { (Just $1, fst $2, snd $2) }
| moduleheader docoptions { (Just $2, fst $1, snd $1) }
| {- empty -} { (Nothing, emptyHaddockModInfo, Nothing) }
maybedocheader :: { (HaddockModInfo RdrName, Maybe (HsDoc RdrName)) }
: moduleheader { (fst $1, snd $1) }
| {- empty -} { (emptyHaddockModInfo, Nothing) }
missing_module_keyword :: { () }
: {- empty -} {% pushCurrentContext }
......@@ -409,14 +405,14 @@ cvtopdecls :: { [LHsDecl RdrName] }
-- Module declaration & imports only
header :: { Located (HsModule RdrName) }
: optdoc 'module' modid maybemoddeprec maybeexports 'where' header_body
{% fileSrcSpan >>= \ loc -> case $1 of { (opt, info, doc) ->
return (L loc (HsModule (Just $3) $5 $7 [] $4
opt info doc))}}
: maybedocheader 'module' modid maybemoddeprec maybeexports 'where' header_body
{% fileSrcSpan >>= \ loc -> case $1 of { (info, doc) ->
return (L loc (HsModule (Just $3) $5 $7 [] $4
info doc))}}
| missing_module_keyword importdecls
{% fileSrcSpan >>= \ loc ->
return (L loc (HsModule Nothing Nothing $2 [] Nothing
Nothing emptyHaddockModInfo Nothing)) }
return (L loc (HsModule Nothing Nothing $2 [] Nothing
emptyHaddockModInfo Nothing)) }
header_body :: { [LImportDecl RdrName] }
: '{' importdecls { $2 }
......@@ -1866,9 +1862,6 @@ docsection :: { Located (n, HsDoc RdrName) }
Left err -> parseError (getLoc $1) err;
Right doc -> return (L1 (n, doc)) } }
docoptions :: { String }
: DOCOPTIONS '#-}' { getDOCOPTIONS $1 }
moduleheader :: { (HaddockModInfo RdrName, Maybe (HsDoc RdrName)) }
: DOCNEXT {% let string = getDOCNEXT $1 in
case parseModuleHeader string of {
......@@ -1918,7 +1911,6 @@ getDOCNEXT (L _ (ITdocCommentNext x)) = x
getDOCPREV (L _ (ITdocCommentPrev x)) = x
getDOCNAMED (L _ (ITdocCommentNamed x)) = x
getDOCSECTION (L _ (ITdocSection n x)) = (n, x)
getDOCOPTIONS (L _ (ITdocOptions x)) = x
-- Utilities for combining source spans
comb2 :: Located a -> Located b -> SrcSpan
......
......@@ -125,7 +125,7 @@ tcRnModule :: HscEnv
tcRnModule hsc_env hsc_src save_rn_syntax
(L loc (HsModule maybe_mod export_ies
import_decls local_decls mod_deprec _
import_decls local_decls mod_deprec
module_info maybe_doc))
= do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
......
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