From 4b025fdbaf89f95f3899b54f09f07842420a16d9 Mon Sep 17 00:00:00 2001 From: Chaitanya Koparkar Date: Thu, 10 May 2018 11:44:58 -0400 Subject: Use the response file utilities defined in `base` (#821) Summary: The response file related modules were recently copied from `haddock` into `base`. This patch removes them from `haddock`. GHC Trac Issues: #13896 --- CHANGES.md | 3 ++ driver-test/Main.hs | 12 ----- driver-test/ResponseFileSpec.hs | 80 ----------------------------- driver/Main.hs | 5 +- driver/ResponseFile.hs | 110 ---------------------------------------- haddock.cabal | 17 ------- 6 files changed, 5 insertions(+), 222 deletions(-) delete mode 100644 driver-test/Main.hs delete mode 100644 driver-test/ResponseFileSpec.hs delete mode 100644 driver/ResponseFile.hs diff --git a/CHANGES.md b/CHANGES.md index 9ba8be07..ad0a86fb 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -25,6 +25,9 @@ * Overhaul handling of data declarations in XHTML and LaTeX. Adds support for documenting individual arguments of constructors/patterns (#709) + * Remove the response file related utilities, and use the ones that + come with `base` (Trac #13896) + ## Changes in version 2.18.1 * Synopsis is working again (#599) diff --git a/driver-test/Main.hs b/driver-test/Main.hs deleted file mode 100644 index d3f636e9..00000000 --- a/driver-test/Main.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Main where - -import Test.Hspec (describe, hspec, Spec) -import qualified ResponseFileSpec (spec) - - -main :: IO () -main = hspec spec - -spec :: Spec -spec = do - describe "ResponseFile" ResponseFileSpec.spec diff --git a/driver-test/ResponseFileSpec.hs b/driver-test/ResponseFileSpec.hs deleted file mode 100644 index 997adac4..00000000 --- a/driver-test/ResponseFileSpec.hs +++ /dev/null @@ -1,80 +0,0 @@ -module ResponseFileSpec where - -import Test.Hspec (context, describe, it, shouldBe, Spec) -import ResponseFile (escapeArgs, unescapeArgs) - --- The first two elements are --- 1) a list of 'args' to encode and --- 2) a single string of the encoded args --- The 3rd element is just a description for the tests. -testStrs :: [(([String], String), String)] -testStrs = - [ ((["a simple command line"], - "a\\ simple\\ command\\ line\n"), - "the white-space, end with newline") - - , ((["arg 'foo' is single quoted"], - "arg\\ \\'foo\\'\\ is\\ single\\ quoted\n"), - "the single quotes as well") - - , ((["arg \"bar\" is double quoted"], - "arg\\ \\\"bar\\\"\\ is\\ double\\ quoted\n"), - "the double quotes as well" ) - - , ((["arg \"foo bar\" has embedded whitespace"], - "arg\\ \\\"foo\\ bar\\\"\\ has\\ embedded\\ whitespace\n"), - "the quote-embedded whitespace") - - , ((["arg 'Jack said \\'hi\\'' has single quotes"], - "arg\\ \\'Jack\\ said\\ \\\\\\'hi\\\\\\'\\'\\ has\\ single\\ quotes\n"), - "the escaped single quotes") - - , ((["arg 'Jack said \\\"hi\\\"' has double quotes"], - "arg\\ \\'Jack\\ said\\ \\\\\\\"hi\\\\\\\"\\'\\ has\\ double\\ quotes\n"), - "the escaped double quotes") - - , ((["arg 'Jack said\\r\\n\\t \\\"hi\\\"' has other whitespace"], - "arg\\ \\'Jack\\ said\\\\r\\\\n\\\\t\\ \\\\\\\"hi\\\\\\\"\\'\\ has\\ \ - \other\\ whitespace\n"), - "the other whitespace") - - , (([ "--prologue=.\\dist\\.\\haddock-prologue3239114604.txt" - , "--title=HaddockNewline-0.1.0.0: This has a\n\ - \newline yo." - , "-BC:\\Program Files\\Haskell Platform\\lib"], - "--prologue=.\\\\dist\\\\.\\\\haddock-prologue3239114604.txt\n\ - \--title=HaddockNewline-0.1.0.0:\\ This\\ has\\ a\\\n\ - \newline\\ yo.\n\ - \-BC:\\\\Program\\ Files\\\\Haskell\\ Platform\\\\lib\n"), - "an actual haddock response file snippet with embedded newlines") - ] - -spec :: Spec -spec = do - describe "escapeArgs" $ do - mapM_ (\((ss1,s2),des) -> do - context ("given " ++ (show ss1)) $ do - it ("should escape " ++ des) $ do - escapeArgs ss1 `shouldBe` s2 - ) testStrs - describe "unescapeArgs" $ do - mapM_ (\((ss1,s2),des) -> do - context ("given " ++ (show s2)) $ do - it ("should unescape " ++ des) $ do - unescapeArgs s2 `shouldBe` ss1 - ) testStrs - describe "unescapeArgs" $ do - context "given unescaped single quotes" $ do - it "should pass-through, without escaping, everything inside" $ do - -- backslash *always* is escaped anywhere it appears - (filter (not . null) $ - unescapeArgs "this\\ is\\ 'not escape\\d \"inside\"'\\ yo\n") - `shouldBe` - ["this is not escaped \"inside\" yo"] - context "given unescaped double quotes" $ do - it "should pass-through, without escaping, everything inside" $ do - -- backslash *always* is escaped anywhere it appears - (filter (not . null) $ - unescapeArgs "this\\ is\\ \"not escape\\d 'inside'\"\\ yo\n") - `shouldBe` - ["this is not escaped 'inside' yo"] diff --git a/driver/Main.hs b/driver/Main.hs index 852f44c7..44df4692 100644 --- a/driver/Main.hs +++ b/driver/Main.hs @@ -1,8 +1,7 @@ module Main where import Documentation.Haddock (haddock) -import ResponseFile (expandResponse) -import System.Environment (getArgs) +import GHC.ResponseFile (getArgsWithResponseFiles) main :: IO () -main = getArgs >>= expandResponse >>= haddock +main = getArgsWithResponseFiles >>= haddock diff --git a/driver/ResponseFile.hs b/driver/ResponseFile.hs deleted file mode 100644 index 253c6004..00000000 --- a/driver/ResponseFile.hs +++ /dev/null @@ -1,110 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -module ResponseFile ( - unescapeArgs, - escapeArgs, - expandResponse - ) where - -import Control.Exception -import Data.Char (isSpace) -import Data.Foldable (foldl') -import System.Exit (exitFailure) -import System.IO - - --- | Given a string of concatenated strings, separate each by removing --- a layer of /quoting/ and\/or /escaping/ of certain characters. --- --- These characters are: any whitespace, single quote, double quote, --- and the backslash character. The backslash character always --- escapes (i.e., passes through without further consideration) the --- character which follows. Characters can also be escaped in blocks --- by quoting (i.e., surrounding the blocks with matching pairs of --- either single- or double-quotes which are not themselves escaped). --- --- Any whitespace which appears outside of either of the quoting and --- escaping mechanisms, is interpreted as having been added by this --- special concatenation process to designate where the boundaries --- are between the original, un-concatenated list of strings. These --- added whitespace characters are removed from the output. --- --- > unescapeArgs "hello\\ \\\"world\\\"\n" == escapeArgs "hello \"world\"" -unescapeArgs :: String -> [String] -unescapeArgs = filter (not . null) . unescape - --- | Given a list of strings, concatenate them into a single string --- with escaping of certain characters, and the addition of a newline --- between each string. The escaping is done by adding a single --- backslash character before any whitespace, single quote, double --- quote, or backslash character, so this escaping character must be --- removed. Unescaped whitespace (in this case, newline) is part --- of this "transport" format to indicate the end of the previous --- string and the start of a new string. --- --- While 'unescapeArgs' allows using quoting (i.e., convenient --- escaping of many characters) by having matching sets of single- or --- double-quotes,'escapeArgs' does not use the quoting mechasnism, --- and thus will always escape any whitespace, quotes, and --- backslashes. --- --- > unescapeArgs "hello\\ \\\"world\\\"\\n" == escapeArgs "hello \"world\"" -escapeArgs :: [String] -> String -escapeArgs = unlines . map escapeArg - --- | Arguments which look like '@foo' will be replaced with the --- contents of file @foo@. A gcc-like syntax for response files arguments --- is expected. This must re-constitute the argument list by doing an --- inverse of the escaping mechanism done by the calling-program side. --- --- We quit if the file is not found or reading somehow fails. --- (A convenience routine for haddock or possibly other clients) -expandResponse :: [String] -> IO [String] -expandResponse = fmap concat . mapM expand - where - expand :: String -> IO [String] - expand ('@':f) = readFileExc f >>= return . unescapeArgs - expand x = return [x] - - readFileExc f = - readFile f `catch` \(e :: IOException) -> do - hPutStrLn stderr $ "Error while expanding response file: " ++ show e - exitFailure - -data Quoting = NoneQ | SngQ | DblQ - -unescape :: String -> [String] -unescape args = reverse . map reverse $ go args NoneQ False [] [] - where - -- n.b., the order of these cases matters; these are cribbed from gcc - -- case 1: end of input - go [] _q _bs a as = a:as - -- case 2: back-slash escape in progress - go (c:cs) q True a as = go cs q False (c:a) as - -- case 3: no back-slash escape in progress, but got a back-slash - go (c:cs) q False a as - | '\\' == c = go cs q True a as - -- case 4: single-quote escaping in progress - go (c:cs) SngQ False a as - | '\'' == c = go cs NoneQ False a as - | otherwise = go cs SngQ False (c:a) as - -- case 5: double-quote escaping in progress - go (c:cs) DblQ False a as - | '"' == c = go cs NoneQ False a as - | otherwise = go cs DblQ False (c:a) as - -- case 6: no escaping is in progress - go (c:cs) NoneQ False a as - | isSpace c = go cs NoneQ False [] (a:as) - | '\'' == c = go cs SngQ False a as - | '"' == c = go cs DblQ False a as - | otherwise = go cs NoneQ False (c:a) as - -escapeArg :: String -> String -escapeArg = reverse . foldl' escape [] - -escape :: String -> Char -> String -escape cs c - | isSpace c - || '\\' == c - || '\'' == c - || '"' == c = c:'\\':cs -- n.b., our caller must reverse the result - | otherwise = c:cs diff --git a/haddock.cabal b/haddock.cabal index c6f241ee..e9280eb2 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -42,7 +42,6 @@ extra-source-files: doc/README.md doc/*.rst doc/conf.py - driver-test/*.hs haddock-api/src/haddock.sh html-test/src/*.hs html-test/ref/*.html @@ -83,8 +82,6 @@ executable haddock transformers other-modules: - ResponseFile, - Documentation.Haddock.Parser Documentation.Haddock.Parser.Monad Documentation.Haddock.Types @@ -155,20 +152,6 @@ executable haddock -- we pin down to a single haddock-api version. build-depends: haddock-api == 2.18.2 - other-modules: - ResponseFile - -test-suite driver-test - type: exitcode-stdio-1.0 - default-language: Haskell2010 - main-is: Main.hs - hs-source-dirs: driver-test, driver - other-modules: - ResponseFile - ResponseFileSpec - - build-depends: base, hspec - test-suite html-test type: exitcode-stdio-1.0 -- This tells cabal that this test depends on the executable -- cgit v1.2.3 From 46ff2306f580c44915a6f3adb652f02b7f4edfe9 Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Sun, 13 May 2018 17:35:21 -0400 Subject: Account for refactoring of LitString --- haddock-api/src/Haddock/Backends/LaTeX.hs | 10 +--------- 1 file changed, 1 insertion(+), 9 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 1b2515fa..fb42e0c2 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -169,15 +169,7 @@ ppLaTeXModule _title odir iface = do body = processExports exports -- - writeFile (odir moduleLaTeXFile mdl) (fullRender PageMode 80 1 string_txt "" tex) - - -string_txt :: TextDetails -> String -> String -string_txt (Chr c) s = c:s -string_txt (Str s1) s2 = s1 ++ s2 -string_txt (PStr s1) s2 = unpackFS s1 ++ s2 -string_txt (ZStr s1) s2 = zString s1 ++ s2 -string_txt (LStr s1 _) s2 = unpackLitString s1 ++ s2 + writeFile (odir moduleLaTeXFile mdl) (fullRender PageMode 80 1 txtPrinter "" tex) -- | Prints out an entry in a module export list. exportListItem :: ExportItem DocNameI -> LaTeX -- cgit v1.2.3 From 6857aefd94db1e25cd560a3c409a1d4e0efa3b4f Mon Sep 17 00:00:00 2001 From: Simon Jakobi Date: Mon, 28 May 2018 03:13:15 +0200 Subject: Adjust to new HsDocString internals --- haddock-api/src/Haddock/Interface/Create.hs | 10 +++++----- haddock-api/src/Haddock/Interface/LexParseRn.hs | 12 ++++++------ 2 files changed, 11 insertions(+), 11 deletions(-) diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index bc93449f..2c91f142 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -58,7 +58,7 @@ import NameEnv import Bag import RdrName import TcRnTypes -import FastString (concatFS) +import FastString (fastStringToByteString) import BasicTypes ( StringLiteral(..), SourceText(..) ) import qualified Outputable as O import HsDecls ( getConArgs ) @@ -293,11 +293,11 @@ moduleWarning dflags gre (WarnAll w) = Just <$> parseWarning dflags gre w parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> ErrMsgM (Doc Name) parseWarning dflags gre w = case w of - DeprecatedTxt _ msg -> format "Deprecated: " (concatFS $ map (sl_fs . unLoc) msg) - WarningTxt _ msg -> format "Warning: " (concatFS $ map (sl_fs . unLoc) msg) + DeprecatedTxt _ msg -> format "Deprecated: " (foldMap (fastStringToByteString . sl_fs . unLoc) msg) + WarningTxt _ msg -> format "Warning: " (foldMap (fastStringToByteString . sl_fs . unLoc) msg) where - format x xs = DocWarning . DocParagraph . DocAppend (DocString x) - <$> processDocString dflags gre (HsDocString xs) + format x bs = DocWarning . DocParagraph . DocAppend (DocString x) + <$> processDocString dflags gre (mkHsDocStringUtf8ByteString bs) ------------------------------------------------------------------------------- diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index 75b2f223..ce1dbc62 100644 --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -46,12 +46,12 @@ processDocStrings dflags gre strs = do x -> pure (Just x) processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (MDoc Name) -processDocStringParas dflags gre (HsDocString fs) = - overDocF (rename dflags gre) $ parseParas dflags (unpackFS fs) +processDocStringParas dflags gre hds = + overDocF (rename dflags gre) $ parseParas dflags (unpackHDS hds) processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Doc Name) -processDocString dflags gre (HsDocString fs) = - rename dflags gre $ parseString dflags (unpackFS fs) +processDocString dflags gre hds = + rename dflags gre $ parseString dflags (unpackHDS hds) processModuleHeader :: DynFlags -> GlobalRdrEnv -> SafeHaskellMode -> Maybe LHsDocString -> ErrMsgM (HaddockModInfo Name, Maybe (MDoc Name)) @@ -59,8 +59,8 @@ processModuleHeader dflags gre safety mayStr = do (hmi, doc) <- case mayStr of Nothing -> return failure - Just (L _ (HsDocString fs)) -> do - let str = unpackFS fs + Just (L _ hds) -> do + let str = unpackHDS hds (hmi, doc) = parseModuleHeader dflags str !descr <- case hmi_description hmi of Just hmi_descr -> Just <$> rename dflags gre hmi_descr -- cgit v1.2.3 From f77c9c5cc8bb669f584d36494630589ea80eb799 Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Sat, 2 Jun 2018 15:45:54 -0400 Subject: Remove ParallelArrays and Data Parallel Haskell --- haddock-api/src/Haddock/Backends/Hoogle.hs | 1 - haddock-api/src/Haddock/Backends/LaTeX.hs | 5 ----- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 1 - haddock-api/src/Haddock/Interface/Rename.hs | 1 - haddock-api/src/Haddock/Interface/Specialize.hs | 1 - haddock-api/src/Haddock/Types.hs | 1 - 6 files changed, 10 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 2c7be079..c6139f12 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -80,7 +80,6 @@ dropHsDocTy = f f (HsAppTy x a b) = HsAppTy x (g a) (g b) f (HsFunTy x a b) = HsFunTy x (g a) (g b) f (HsListTy x a) = HsListTy x (g a) - f (HsPArrTy x a) = HsPArrTy x (g a) f (HsTupleTy x a b) = HsTupleTy x a (map g b) f (HsOpTy x a b c) = HsOpTy x (g a) b (g c) f (HsParTy x a) = HsParTy x (g a) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index fb42e0c2..597f1f15 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -969,7 +969,6 @@ ppr_mono_ty _ (HsTupleTy _ con tys) u = tupleParens con (map (ppLType u) ppr_mono_ty _ (HsSumTy _ tys) u = sumParens (map (ppLType u) tys) ppr_mono_ty _ (HsKindSig _ ty kind) u = parens (ppr_mono_lty pREC_TOP ty u <+> dcolon u <+> ppLKind u kind) ppr_mono_ty _ (HsListTy _ ty) u = brackets (ppr_mono_lty pREC_TOP ty u) -ppr_mono_ty _ (HsPArrTy _ ty) u = pabrackets (ppr_mono_lty pREC_TOP ty u) ppr_mono_ty _ (HsIParamTy _ (L _ n) ty) u = brackets (ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u) ppr_mono_ty _ (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy" ppr_mono_ty _ (HsRecTy {}) _ = text "{..}" @@ -1289,10 +1288,6 @@ ubxparens :: LaTeX -> LaTeX ubxparens h = text "(#" <> h <> text "#)" -pabrackets :: LaTeX -> LaTeX -pabrackets h = text "[:" <> h <> text ":]" - - nl :: LaTeX nl = text "\\\\" diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 8ac3d91b..fe33fbe9 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -1195,7 +1195,6 @@ ppr_mono_ty _ (HsSumTy _ tys) u q _ = sumParens (map (ppLType u q HideEm ppr_mono_ty _ (HsKindSig _ ty kind) u q e = parens (ppr_mono_lty pREC_TOP ty u q e <+> dcolon u <+> ppLKind u q kind) ppr_mono_ty _ (HsListTy _ ty) u q _ = brackets (ppr_mono_lty pREC_TOP ty u q HideEmptyContexts) -ppr_mono_ty _ (HsPArrTy _ ty) u q _ = pabrackets (ppr_mono_lty pREC_TOP ty u q HideEmptyContexts) ppr_mono_ty ctxt_prec (HsIParamTy _ (L _ n) ty) u q _ = maybeParen ctxt_prec pREC_CTX $ ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q HideEmptyContexts ppr_mono_ty _ (HsSpliceTy {}) _ _ _ = error "ppr_mono_ty HsSpliceTy" diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 5b588964..14f2bfe2 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -235,7 +235,6 @@ renameType t = case t of return (HsFunTy NoExt a' b') HsListTy _ ty -> return . (HsListTy NoExt) =<< renameLType ty - HsPArrTy _ ty -> return . (HsPArrTy NoExt) =<< renameLType ty HsIParamTy _ n ty -> liftM (HsIParamTy NoExt n) (renameLType ty) HsEqTy _ ty1 ty2 -> liftM2 (HsEqTy NoExt) (renameLType ty1) (renameLType ty2) diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index c49663db..092a2f4e 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -257,7 +257,6 @@ renameType (HsTyVar x ip name) = HsTyVar x ip <$> located renameName name renameType (HsAppTy x lf la) = HsAppTy x <$> renameLType lf <*> renameLType la renameType (HsFunTy x la lr) = HsFunTy x <$> renameLType la <*> renameLType lr renameType (HsListTy x lt) = HsListTy x <$> renameLType lt -renameType (HsPArrTy x lt) = HsPArrTy x <$> renameLType lt renameType (HsTupleTy x srt lt) = HsTupleTy x srt <$> mapM renameLType lt renameType (HsSumTy x lt) = HsSumTy x <$> mapM renameLType lt renameType (HsOpTy x la lop lb) = diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 99fccf2a..444a1014 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -660,7 +660,6 @@ type instance XAppsTy DocNameI = NoExt type instance XAppTy DocNameI = NoExt type instance XFunTy DocNameI = NoExt type instance XListTy DocNameI = NoExt -type instance XPArrTy DocNameI = NoExt type instance XTupleTy DocNameI = NoExt type instance XSumTy DocNameI = NoExt type instance XOpTy DocNameI = NoExt -- cgit v1.2.3 From 14110449370a77195093dd3f610ab869ab9e36cf Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Wed, 9 May 2018 10:42:03 -0400 Subject: DerivingVia changes --- haddock-api/src/Haddock/Interface/Rename.hs | 11 +++++++++-- haddock-api/src/Haddock/Types.hs | 1 + 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 14f2bfe2..e3e4e987 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -540,13 +540,20 @@ renameDerivD :: DerivDecl GhcRn -> RnM (DerivDecl DocNameI) renameDerivD (DerivDecl { deriv_type = ty , deriv_strategy = strat , deriv_overlap_mode = omode }) = do - ty' <- renameLSigWcType ty + ty' <- renameLSigWcType ty + strat' <- mapM (mapM renameDerivStrategy) strat return (DerivDecl { deriv_ext = noExt , deriv_type = ty' - , deriv_strategy = strat + , deriv_strategy = strat' , deriv_overlap_mode = omode }) renameDerivD (XDerivDecl _) = panic "haddock:renameDerivD" +renameDerivStrategy :: DerivStrategy GhcRn -> RnM (DerivStrategy DocNameI) +renameDerivStrategy StockStrategy = pure StockStrategy +renameDerivStrategy AnyclassStrategy = pure AnyclassStrategy +renameDerivStrategy NewtypeStrategy = pure NewtypeStrategy +renameDerivStrategy (ViaStrategy ty) = ViaStrategy <$> renameLSigType ty + renameClsInstD :: ClsInstDecl GhcRn -> RnM (ClsInstDecl DocNameI) renameClsInstD (ClsInstDecl { cid_overlap_mode = omode , cid_poly_ty =ltype, cid_tyfam_insts = lATs diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 444a1014..8e879cc8 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -710,6 +710,7 @@ type instance XCFamEqn DocNameI _ _ = NoExt type instance XCClsInstDecl DocNameI = NoExt type instance XCDerivDecl DocNameI = NoExt +type instance XViaStrategy DocNameI = LHsSigType DocNameI type instance XDataFamInstD DocNameI = NoExt type instance XTyFamInstD DocNameI = NoExt type instance XClsInstD DocNameI = NoExt -- cgit v1.2.3 From 9a7f539d0c20654ff394f2ff99836412a6844df1 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Tue, 5 Jun 2018 13:53:25 -0700 Subject: Extract docs from strict/unpacked constructor args (#839) This fixes #836. --- haddock-api/src/Haddock/Interface/Create.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 2c91f142..78b5c36d 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -472,6 +472,7 @@ conArgDocs con = case getConArgs con of RecCon _ -> go 1 ret where go n (HsDocTy _ _ (L _ ds) : tys) = M.insert n ds $ go (n+1) tys + go n (HsBangTy _ _ (L _ (HsDocTy _ _ (L _ ds))) : tys) = M.insert n ds $ go (n+1) tys go n (_ : tys) = go (n+1) tys go _ [] = M.empty -- cgit v1.2.3