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.

diff --git a/compiler/hsSyn/HsSyn.lhs b/compiler/hsSyn/HsSyn.lhs
index afaad8c..4394169 100644 (file)
--- a/compiler/hsSyn/HsSyn.lhs
+++ b/compiler/hsSyn/HsSyn.lhs
@@ -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

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index bf456c9..5d8922c 100644 (file)
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -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) -----

diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs
index a680695..7142645 100644 (file)
--- a/compiler/main/HeaderInfo.hs
+++ b/compiler/main/HeaderInfo.hs
@@ -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

diff --git a/compiler/main/HscStats.lhs b/compiler/main/HscStats.lhs
index e7b780a..188b4f3 100644 (file)
--- a/compiler/main/HscStats.lhs
+++ b/compiler/main/HscStats.lhs
@@ -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

diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 47fd107..2f6b732 100644 (file)
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -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

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index 109fd8b..8adc381 100644 (file)
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -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

diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index 694a77a..74209d9 100644 (file)
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -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" ;