packages feed

haddock 2.20.0 → 2.21.0

raw patch · 82 files changed

+4084/−4641 lines, 82 filesdep +parsecdep +textdep −hspecdep ~basedep ~ghcdep ~haddock-api

Dependencies added: parsec, text

Dependencies removed: hspec

Dependency ranges changed: base, ghc, haddock-api

Files

CHANGES.md view
@@ -1,5 +1,18 @@-## Changes in version 2.19.1+## Changes in version 2.21.0 + * Overhaul handling of data declarations in XHTML and LaTeX. Adds support for+   documenting individual arguments of constructors/patterns (#709)++ * Actually list all fixities for `--hoogle` (#871)++ * Fix broken instance source links (#869)++ * Avoiding line breaks due to ling line in the output of `--hoogle` (#868)++ * Capture docs on type family instances (#867)++## Changes in version 2.20.0+  * Show where instances are defined (#748)   * `@since` includes package name (#452, #550, #749)@@ -38,10 +51,16 @@    This notably fixes rendering of quasiquotes.   * Overhaul Haddock's rendering of kind signatures so that invisible kind-   parameters are not printed (#681)+   parameters are not printed (#681) (Fixes #544)   * Recognise `SPDX-License-Identifier` as alias for `License` in module header    parser (#743)++ * Remove the response file related utilities, and use the ones that+   come with `base` (Trac #13896)++ * Remove the response file related utilities, and use the ones that+   come with `base` (Trac #13896)  ## Changes in version 2.18.1
README.md view
@@ -1,4 +1,4 @@-# Haddock, a Haskell Documentation Tool [![Build Status](https://travis-ci.org/haskell/haddock.svg?branch=master)](https://travis-ci.org/haskell/haddock)+# Haddock, a Haskell Documentation Tool [![Build Status](https://travis-ci.org/haskell/haddock.svg?branch=ghc-8.6)](https://travis-ci.org/haskell/haddock)   ## About haddock@@ -11,6 +11,32 @@ [reStructedText format](http://www.sphinx-doc.org/en/stable/rest.html) format. ++## Project overview++This project consists of three packages:++* haddock+* haddock-api+* haddock-library++### haddock++The haddock package provides the `haddock` executable. It is implemented as a+tiny wrapper around haddock-api's `Documentation.Haddock.haddock` function.++### haddock-api++haddock-api contains the program logic of the `haddock` tool. [The haddocks for+the `Documentation.Haddock` module](http://hackage.haskell.org/package/haddock-api-2.19.0.1/docs/Documentation-Haddock.html)+offer a good overview of haddock-api's functionality.++### haddock-library++haddock-library is concerned with the parsing and processing of the Haddock+markup language.++ ## Contributing  Please create issues when you have any problems and pull requests if you have some code.@@ -31,9 +57,9 @@ #### Using [`cabal new-build`](http://cabal.readthedocs.io/en/latest/nix-local-build-overview.html)  ```bash-cabal new-build -w ghc-8.4.1+cabal new-build -w ghc-8.6.1 # build & run the test suite-cabal new-test -w ghc-8.4.1+cabal new-test -w ghc-8.6.1 all ```  #### Using Cabal sandboxes@@ -65,11 +91,16 @@ ### Git Branches  If you're a GHC developer and want to update Haddock to work with your-changes, you should be working on `ghc-head` branch instead of `master`.+changes, you should be working on `ghc-head` branch. See instructions at https://ghc.haskell.org/trac/ghc/wiki/WorkingConventions/Git/Submodules for an example workflow. -The `master` branch usually requires a GHC from the latest GHC stable-branch. The required GHC version can be inferred from the version-bounds on `ghc` in the respective `.cabal` files.+### Updating `html-test`++When accepting any changes in the output of `html-test`, it is important+to use the `--haddock-path` option. For example:++```+cabal new-run -- html-test --haddock-path $(find dist-newstyle/ -executable -type f -name haddock) --accept+```
doc/markup.rst view
@@ -39,6 +39,8 @@  -  A ``data`` declaration, +-  A ``pattern`` declaration,+ -  A ``newtype`` declaration,  -  A ``type`` declaration@@ -118,6 +120,15 @@ or like this: ::      data T a b+      = C1   -- ^ This is the documentation for the 'C1' constructor+          a  -- ^ This is the documentation for the argument of type 'a'+          b  -- ^ This is the documentation for the argument of type 'b'++There is one edge case that is handled differently: only one ``-- ^``+annotation occuring after the constructor and all its arguments is+applied to the constructor, not its last argument: ::++    data T a b       = C1 a b  -- ^ This is the documentation for the 'C1' constructor       | C2 a b  -- ^ This is the documentation for the 'C2' constructor @@ -164,6 +175,9 @@        -> Float    -- ^ The 'Float' argument        -> IO ()    -- ^ The return value +Pattern synonyms and GADT-style data constructors also support this+style of documentation.+ .. _module-description:  The Module Description@@ -845,10 +859,13 @@ ~~~~~~~~~~~~~~~~~~~~~~~  Referring to a Haskell identifier, whether it be a type, class,-constructor, or function, is done by surrounding it with single quotes: ::+constructor, or function, is done by surrounding it with a combination+of single quotes and backticks. For example: ::      -- | This module defines the type 'T'. +```T``` is also ok. ``'T``` and ```T'`` are accepted but less common.+ If there is an entity ``T`` in scope in the current module, then the documentation will hyperlink the reference in the text to the definition of ``T`` (if the output format supports hyperlinking, of course; in a@@ -875,14 +892,6 @@ apostrophes themselves: to hyperlink ``foo'`` one would simply type ``'foo''``. To hyperlink identifiers written in infix form, simply put them in quotes as always: ``'`elem`'``.--For compatibility with other systems, the following alternative form of-markup is accepted [3]_: ```T'``.--.. [3]-   We chose not to use this as the primary markup for identifiers-   because strictly speaking the ````` character should not be used as a-   left quote, it is a grave accent.  Emphasis, Bold and Monospaced Text ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
− driver-test/Main.hs 
@@ -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
− driver-test/ResponseFileSpec.hs 
@@ -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"]
driver/Main.hs view
@@ -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
− driver/ResponseFile.hs 
@@ -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
haddock-api/src/Haddock.hs view
@@ -75,6 +75,7 @@ import Panic (handleGhcException) import Module import FastString+import qualified DynamicLoading  -------------------------------------------------------------------------------- -- * Exception handling@@ -437,7 +438,10 @@   -- that may need to be re-linked: Haddock doesn't do any   -- dynamic or static linking at all!   _ <- setSessionDynFlags dynflags''-  ghcActs dynflags''+  hscenv <- GHC.getSession+  dynflags''' <- liftIO (DynamicLoading.initializePlugins hscenv dynflags'')+  _ <- setSessionDynFlags dynflags'''+  ghcActs dynflags'''   where      -- ignore sublists of flags that start with "+RTS" and end in "-RTS"
haddock-api/src/Haddock/Backends/Hoogle.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module      :  Haddock.Backends.Hoogle@@ -45,13 +46,15 @@  ppHoogle :: DynFlags -> String -> Version -> String -> Maybe (Doc RdrName) -> [Interface] -> FilePath -> IO () ppHoogle dflags package version synopsis prologue ifaces odir = do-    let filename = package ++ ".txt"+    let -- Since Hoogle is line based, we want to avoid breaking long lines.+        dflags' = dflags{ pprCols = maxBound }+        filename = package ++ ".txt"         contents = prefix ++-                   docWith dflags (drop 2 $ dropWhile (/= ':') synopsis) prologue +++                   docWith dflags' (drop 2 $ dropWhile (/= ':') synopsis) prologue ++                    ["@package " ++ package] ++                    ["@version " ++ showVersion version                    | not (null (versionBranch version)) ] ++-                   concat [ppModule dflags i | i <- ifaces, OptHide `notElem` ifaceOptions i]+                   concat [ppModule dflags' i | i <- ifaces, OptHide `notElem` ifaceOptions i]     createDirectoryIfMissing True odir     h <- openFile (odir </> filename) WriteMode     hSetEncoding h utf8@@ -73,23 +76,22 @@ dropHsDocTy = f     where         g (L src x) = L src (f x)-        f (HsForAllTy a e) = HsForAllTy a (g e)-        f (HsQualTy a e) = HsQualTy a (g e)-        f (HsBangTy a b) = HsBangTy a (g b)-        f (HsAppTy a b) = HsAppTy (g a) (g b)-        f (HsFunTy a b) = HsFunTy (g a) (g b)-        f (HsListTy a) = HsListTy (g a)-        f (HsPArrTy a) = HsPArrTy (g a)-        f (HsTupleTy a b) = HsTupleTy a (map g b)-        f (HsOpTy a b c) = HsOpTy (g a) b (g c)-        f (HsParTy a) = HsParTy (g a)-        f (HsKindSig a b) = HsKindSig (g a) b-        f (HsDocTy a _) = f $ unL a+        f (HsForAllTy x a e) = HsForAllTy x a (g e)+        f (HsQualTy x a e) = HsQualTy x a (g e)+        f (HsBangTy x a b) = HsBangTy x a (g b)+        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 (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)+        f (HsKindSig x a b) = HsKindSig x (g a) b+        f (HsDocTy _ a _) = f $ unL a         f x = x -outHsType :: (SourceTextX a, OutputableBndrId a)+outHsType :: (a ~ GhcPass p, OutputableBndrId a)           => DynFlags -> HsType a -> String-outHsType dflags = out dflags . dropHsDocTy+outHsType dflags = out dflags . reparenType . dropHsDocTy   dropComment :: String -> String@@ -123,28 +125,25 @@                            , expItemMbDoc   = (dc, _)                            , expItemSubDocs = subdocs                            , expItemFixities = fixities-                           } = ppDocumentation dflags dc ++ f decl+                           } = ppDocumentation dflags dc ++ f decl ++ ppFixities     where-        f (TyClD d@DataDecl{})  = ppData dflags d subdocs-        f (TyClD d@SynDecl{})   = ppSynonym dflags d-        f (TyClD d@ClassDecl{}) = ppClass dflags d subdocs-        f (ForD (ForeignImport name typ _ _)) = [pp_sig dflags [name] (hsSigType typ)]-        f (ForD (ForeignExport name typ _ _)) = [pp_sig dflags [name] (hsSigType typ)]-        f (SigD sig) = ppSig dflags sig ++ ppFixities+        f (TyClD _ d@DataDecl{})  = ppData dflags d subdocs+        f (TyClD _ d@SynDecl{})   = ppSynonym dflags d+        f (TyClD _ d@ClassDecl{}) = ppClass dflags d subdocs+        f (TyClD _ (FamDecl _ d)) = ppFam dflags d+        f (ForD _ (ForeignImport _ name typ _)) = [pp_sig dflags [name] (hsSigType typ)]+        f (ForD _ (ForeignExport _ name typ _)) = [pp_sig dflags [name] (hsSigType typ)]+        f (SigD _ sig) = ppSig dflags sig         f _ = []          ppFixities = concatMap (ppFixity dflags) fixities ppExport _ _ = []  ppSigWithDoc :: DynFlags -> Sig GhcRn -> [(Name, DocForDecl Name)] -> [String]-ppSigWithDoc dflags (TypeSig names sig) subdocs+ppSigWithDoc dflags (TypeSig _ names sig) subdocs     = concatMap mkDocSig names     where-        mkDocSig n = concatMap (ppDocumentation dflags) (getDoc n)-                     ++ [pp_sig dflags [n] (hsSigWcType sig)]--        getDoc :: Located Name -> [Documentation Name]-        getDoc n = maybe [] (return . fst) (lookup (unL n) subdocs)+        mkDocSig n = mkSubdoc dflags n subdocs [pp_sig dflags [n] (hsSigWcType sig)]  ppSigWithDoc _ _ _ = [] @@ -172,10 +171,14 @@         ppTyFams             | null $ tcdATs decl = ""             | otherwise = (" " ++) . showSDocUnqual dflags . whereWrapper $ concat-                [ map ppr (tcdATs decl)+                [ map pprTyFam (tcdATs decl)                 , map (ppr . tyFamEqnToSyn . unLoc) (tcdATDefs decl)                 ] +        pprTyFam :: LFamilyDecl GhcRn -> SDoc+        pprTyFam (L _ at) = vcat' $ map text $+            mkSubdoc dflags (fdLName at) subdocs (ppFam dflags at)+         whereWrapper elems = vcat'             [ text "where" <+> lbrace             , nest 4 . vcat . map (Outputable.<> semi) $ elems@@ -188,9 +191,19 @@             , tcdTyVars = feqn_pats tfe             , tcdFixity = feqn_fixity tfe             , tcdRhs    = feqn_rhs tfe-            , tcdFVs    = emptyNameSet+            , tcdSExt   = emptyNameSet             } +ppFam :: DynFlags -> FamilyDecl GhcRn -> [String]+ppFam dflags decl@(FamilyDecl { fdInfo = info })+  = [out dflags decl']+  where+    decl' = case info of+              -- We don't need to print out a closed type family's equations+              -- for Hoogle, so pretend it doesn't have any.+              ClosedTypeFamily{} -> decl { fdInfo = OpenTypeFamily }+              _                  -> decl+ppFam _ XFamilyDecl {} = panic "ppFam"  ppInstance :: DynFlags -> ClsInst -> [String] ppInstance dflags x =@@ -213,13 +226,12 @@       concatMap (ppCtor dflags decl subdocs . unL) (dd_cons defn)     where -        -- GHC gives out "data Bar =", we want to delete the equals-        -- also writes data : a b, when we want data (:) a b-        showData d = unwords $ map f $ if last xs == "=" then init xs else xs+        -- GHC gives out "data Bar =", we want to delete the equals.+        -- There's no need to worry about parenthesizing infix data type names,+        -- since this Outputable instance for TyClDecl gets this right already.+        showData d = unwords $ if last xs == "=" then init xs else xs             where                 xs = words $ out dflags d-                nam = out dflags $ tyClDeclLName d-                f w = if w == nam then operator nam else w ppData _ _ _ = panic "ppData"  -- | for constructors, and named-fields...@@ -231,17 +243,17 @@ ppCtor :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> ConDecl GhcRn -> [String] ppCtor dflags dat subdocs con@ConDeclH98 {}   -- AZ:TODO get rid of the concatMap-   = concatMap (lookupCon dflags subdocs) [con_name con] ++ f (getConDetails con)+   = concatMap (lookupCon dflags subdocs) [con_name con] ++ f (getConArgs con)     where         f (PrefixCon args) = [typeSig name $ args ++ [resType]]         f (InfixCon a1 a2) = f $ PrefixCon [a1,a2]         f (RecCon (L _ recs)) = f (PrefixCon $ map cd_fld_type (map unLoc recs)) ++ concat-                          [(concatMap (lookupCon dflags subdocs . noLoc . selectorFieldOcc . unLoc) (cd_fld_names r)) ++-                           [out dflags (map (selectorFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]]+                          [(concatMap (lookupCon dflags subdocs . noLoc . extFieldOcc . unLoc) (cd_fld_names r)) +++                           [out dflags (map (extFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]]                           | r <- map unLoc recs] -        funs = foldr1 (\x y -> reL $ HsFunTy x y)-        apps = foldl1 (\x y -> reL $ HsAppTy x y)+        funs = foldr1 (\x y -> reL $ HsFunTy NoExt x y)+        apps = foldl1 (\x y -> reL $ HsAppTy NoExt x y)          typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds) @@ -249,20 +261,20 @@         -- docs for con_names on why it is a list to begin with.         name = commaSeparate dflags . map unL $ getConNames con -        resType = apps $ map (reL . HsTyVar NotPromoted . reL) $-                        (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvExplicit $ tyClDeclTyVars dat]+        resType = apps $ map (reL . HsTyVar NoExt NotPromoted . reL) $+                        (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _ _) <- hsQTvExplicit $ tyClDeclTyVars dat] -ppCtor dflags _dat subdocs con@ConDeclGADT {}+ppCtor dflags _dat subdocs con@(ConDeclGADT { })    = concatMap (lookupCon dflags subdocs) (getConNames con) ++ f     where-        f = [typeSig name (hsib_body $ con_type con)]+        f = [typeSig name (getGADTConTypeG con)]          typeSig nm ty = operator nm ++ " :: " ++ outHsType dflags (unL ty)         name = out dflags $ map unL $ getConNames con-+ppCtor _ _ _ XConDecl {} = panic "haddock:ppCtor"  ppFixity :: DynFlags -> (Name, Fixity) -> [String]-ppFixity dflags (name, fixity) = [out dflags ((FixitySig [noLoc name] fixity) :: FixitySig GhcRn)]+ppFixity dflags (name, fixity) = [out dflags ((FixitySig noExt [noLoc name] fixity) :: FixitySig GhcRn)]   ---------------------------------------------------------------------@@ -285,6 +297,10 @@     lines header ++ ["" | header /= "" && isJust d] ++     maybe [] (showTags . markup (markupTag dflags)) d +mkSubdoc :: DynFlags -> Located Name -> [(Name, DocForDecl Name)] -> [String] -> [String]+mkSubdoc dflags n subdocs s = concatMap (ppDocumentation dflags) getDoc ++ s+ where+   getDoc = maybe [] (return . fst) (lookup (unL n) subdocs)  data Tag = TagL Char [Tags] | TagP Tags | TagPre Tags | TagInline String Tags | Str String            deriving Show
haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs view
@@ -13,6 +13,7 @@  import qualified GHC import qualified SrcLoc+import qualified Outputable as GHC  import Control.Applicative import Control.Monad (guard)@@ -79,9 +80,9 @@     everythingInRenamedSource (var `Syb.combine` rec)   where     var term = case cast term of-        (Just ((GHC.L sspan (GHC.HsVar name)) :: GHC.LHsExpr GHC.GhcRn)) ->+        (Just ((GHC.L sspan (GHC.HsVar _ name)) :: GHC.LHsExpr GHC.GhcRn)) ->             pure (sspan, RtkVar (GHC.unLoc name))-        (Just (GHC.L _ (GHC.RecordCon (GHC.L sspan name) _ _ _))) ->+        (Just (GHC.L _ (GHC.RecordCon _ (GHC.L sspan name) _))) ->             pure (sspan, RtkVar name)         _ -> empty     rec term = case cast term of@@ -95,9 +96,9 @@   where     ty :: forall a. Data a => a -> [(GHC.SrcSpan, TokenDetails)]     ty term = case cast term of-        (Just ((GHC.L sspan (GHC.HsTyVar _ name)) :: GHC.LHsType GHC.GhcRn)) ->+        (Just ((GHC.L sspan (GHC.HsTyVar _ _ name)) :: GHC.LHsType GHC.GhcRn)) ->             pure (sspan, RtkType (GHC.unLoc name))-        (Just ((GHC.L sspan (GHC.HsOpTy l name r)) :: GHC.LHsType GHC.GhcRn)) ->+        (Just ((GHC.L sspan (GHC.HsOpTy _ l name r)) :: GHC.LHsType GHC.GhcRn)) ->             (sspan, RtkType (GHC.unLoc name)):(ty l ++ ty r)         _ -> empty @@ -112,20 +113,20 @@       (fun `Syb.combine` pat `Syb.combine` tvar)   where     fun term = case cast term of-        (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.GhcRn)) ->+        (Just (GHC.FunBind _ (GHC.L sspan name) _ _ _ :: GHC.HsBind GHC.GhcRn)) ->             pure (sspan, RtkBind name)-        (Just (GHC.PatSynBind (GHC.PSB (GHC.L sspan name) _ args _ _))) ->+        (Just (GHC.PatSynBind _ (GHC.PSB _ (GHC.L sspan name) args _ _))) ->             pure (sspan, RtkBind name) ++ everythingInRenamedSource patsyn_binds args         _ -> empty     patsyn_binds term = case cast term of         (Just (GHC.L sspan (name :: GHC.Name))) -> pure (sspan, RtkVar name)         _ -> empty     pat term = case cast term of-        (Just ((GHC.L sspan (GHC.VarPat name)) :: GHC.LPat GHC.GhcRn)) ->+        (Just ((GHC.L sspan (GHC.VarPat _ name)) :: GHC.LPat GHC.GhcRn)) ->             pure (sspan, RtkBind (GHC.unLoc name))         (Just (GHC.L _ (GHC.ConPatIn (GHC.L sspan name) recs))) ->             [(sspan, RtkVar name)] ++ everythingInRenamedSource rec recs-        (Just (GHC.L _ (GHC.AsPat (GHC.L sspan name) _))) ->+        (Just (GHC.L _ (GHC.AsPat _ (GHC.L sspan name) _))) ->             pure (sspan, RtkBind name)         _ -> empty     rec term = case cast term of@@ -133,9 +134,9 @@             pure (sspan, RtkVar name)         _ -> empty     tvar term = case cast term of-        (Just ((GHC.L sspan (GHC.UserTyVar name)) :: GHC.LHsTyVarBndr GHC.GhcRn)) ->+        (Just ((GHC.L sspan (GHC.UserTyVar _ name)) :: GHC.LHsTyVarBndr GHC.GhcRn)) ->             pure (sspan, RtkBind (GHC.unLoc name))-        (Just (GHC.L _ (GHC.KindedTyVar (GHC.L sspan name) _))) ->+        (Just (GHC.L _ (GHC.KindedTyVar _ (GHC.L sspan name) _))) ->             pure (sspan, RtkBind name)         _ -> empty @@ -150,16 +151,17 @@   where     typ (GHC.L _ t) = case t of         GHC.DataDecl { tcdLName = name } -> pure . decl $ name-        GHC.SynDecl name _ _ _ _ -> pure . decl $ name-        GHC.FamDecl fam -> pure . decl $ GHC.fdLName fam+        GHC.SynDecl _ name _ _ _ -> pure . decl $ name+        GHC.FamDecl _ fam -> pure . decl $ GHC.fdLName fam         GHC.ClassDecl{..} ->           [decl tcdLName]             ++ concatMap sig tcdSigs             ++ concatMap tyfam tcdATs+        GHC.XTyClDecl {} -> GHC.panic "haddock:decls"     fun term = case cast term of-        (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.GhcRn))+        (Just (GHC.FunBind _ (GHC.L sspan name) _ _ _ :: GHC.HsBind GHC.GhcRn))             | GHC.isExternalName name -> pure (sspan, RtkDecl name)-        (Just (GHC.PatSynBind (GHC.PSB (GHC.L sspan name) _ _ _ _)))+        (Just (GHC.PatSynBind _ (GHC.PSB _ (GHC.L sspan name) _ _ _)))             | GHC.isExternalName name -> pure (sspan, RtkDecl name)         _ -> empty     con term = case cast term of@@ -168,24 +170,27 @@               ++ everythingInRenamedSource fld cdcl         Nothing -> empty     ins term = case cast term of-        (Just ((GHC.DataFamInstD (GHC.DataFamInstDecl eqn))+        (Just ((GHC.DataFamInstD _ (GHC.DataFamInstDecl eqn))                 :: GHC.InstDecl GHC.GhcRn))           -> pure . tyref $ GHC.feqn_tycon $ GHC.hsib_body eqn-        (Just (GHC.TyFamInstD (GHC.TyFamInstDecl eqn))) ->+        (Just (GHC.TyFamInstD _ (GHC.TyFamInstDecl eqn))) ->             pure . tyref $ GHC.feqn_tycon $ GHC.hsib_body eqn         _ -> empty     fld term = case cast term of         Just (field :: GHC.ConDeclField GHC.GhcRn)-          -> map (decl . fmap GHC.selectorFieldOcc) $ GHC.cd_fld_names field+          -> map (decl . fmap GHC.extFieldOcc) $ GHC.cd_fld_names field         Nothing -> empty     fix term = case cast term of-        Just ((GHC.FixitySig names _) :: GHC.FixitySig GHC.GhcRn)-          -> map decl names+        Just ((GHC.FixitySig _ names _) :: GHC.FixitySig GHC.GhcRn)+          -> map (\(GHC.L sspan x) -> (sspan, RtkVar x)) names+        Just ((GHC.XFixitySig {}) :: GHC.FixitySig GHC.GhcRn)+          -> GHC.panic "haddock:decls"         Nothing -> empty     tyfam (GHC.L _ (GHC.FamilyDecl{..})) = [decl fdLName]-    sig (GHC.L _ (GHC.TypeSig names _)) = map decl names-    sig (GHC.L _ (GHC.PatSynSig names _)) = map decl names-    sig (GHC.L _ (GHC.ClassOpSig _ names _)) = map decl names+    tyfam (GHC.L _ (GHC.XFamilyDecl {})) = GHC.panic "haddock:dels"+    sig (GHC.L _ (GHC.TypeSig _ names _)) = map decl names+    sig (GHC.L _ (GHC.PatSynSig _ names _)) = map decl names+    sig (GHC.L _ (GHC.ClassOpSig _ _ names _)) = map decl names     sig _ = []     decl (GHC.L sspan name) = (sspan, RtkDecl name)     tyref (GHC.L sspan name) = (sspan, RtkType name)@@ -199,12 +204,12 @@     everythingInRenamedSource ie src ++ mapMaybe (imp . GHC.unLoc) imps   where     ie term = case cast term of-        (Just ((GHC.IEVar v) :: GHC.IE GHC.GhcRn)) -> pure $ var $ GHC.ieLWrappedName v-        (Just (GHC.IEThingAbs t)) -> pure $ typ $ GHC.ieLWrappedName t-        (Just (GHC.IEThingAll t)) -> pure $ typ $ GHC.ieLWrappedName t-        (Just (GHC.IEThingWith t _ vs _fls)) ->+        (Just ((GHC.IEVar _ v) :: GHC.IE GHC.GhcRn)) -> pure $ var $ GHC.ieLWrappedName v+        (Just (GHC.IEThingAbs _ t)) -> pure $ typ $ GHC.ieLWrappedName t+        (Just (GHC.IEThingAll _ t)) -> pure $ typ $ GHC.ieLWrappedName t+        (Just (GHC.IEThingWith _ t _ vs _fls)) ->           [typ $ GHC.ieLWrappedName t] ++ map (var . GHC.ieLWrappedName) vs-        (Just (GHC.IEModuleContents m)) -> pure $ modu m+        (Just (GHC.IEModuleContents _ m)) -> pure $ modu m         _ -> empty     typ (GHC.L sspan name) = (sspan, RtkType name)     var (GHC.L sspan name) = (sspan, RtkVar name)
haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs view
@@ -3,6 +3,8 @@ import Data.Either         ( isRight, isLeft ) import Data.List           ( foldl', isPrefixOf, isSuffixOf ) import Data.Maybe          ( maybeToList )+import Data.Char           ( isSpace )+import qualified Text.Read as R  import GHC                 ( DynFlags, addSourceToTokens ) import SrcLoc@@ -24,8 +26,13 @@ -- (In reality, this only holds for input not containing '\r', '\t', '\f', '\v', -- characters, since GHC transforms those into ' ' and '\n') parse :: DynFlags -> FilePath -> String -> [T.Token]-parse dflags fp s = ghcToks (processCPP dflags fp s)-+parse dflags fp = ghcToks . processCPP dflags fp . filterCRLF+  where+    -- Remove CRLFs from source+    filterCRLF :: String -> String+    filterCRLF ('\r':'\n':cs) = '\n' : filterCRLF cs+    filterCRLF (c:cs) = c : filterCRLF cs+    filterCRLF [] = []  -- | Parse the source into tokens using the GHC lexer. --@@ -104,12 +111,9 @@ isCPPline = isPrefixOf "#" . dropWhile (`elem` " \t") . take 5  --- | Split a "line" off the front of a string, supporting newline escapes.------ By "line", we understand: the shortest substring ending in a '\n' that is not------   1. immediately preceded by a '\\'---   2. not inside some (possibly nested) block comment+-- | Split a "line" off the front of a string, hopefully without cutting tokens+-- in half. I say "hopefully" because knowing what a token is requires lexing,+-- yet lexing depends on this function. -- -- All characters in the input are present in the output: --@@ -117,17 +121,36 @@ spanToNewline :: Int                 -- ^ open '{-'               -> String              -- ^ input               -> (String, String)-spanToNewline _ [] = ([], [])++-- Base case and space characters+spanToNewline _ "" = ("", "") spanToNewline n ('\n':str) | n <= 0 = ("\n", str)+spanToNewline n ('\n':str) | n <= 0 = ("\n", str) spanToNewline n ('\\':'\n':str) =     let (str', rest) = spanToNewline n str     in ('\\':'\n':str', rest)++-- Block comments spanToNewline n ('{':'-':str) =     let (str', rest) = spanToNewline (n+1) str     in ('{':'-':str', rest) spanToNewline n ('-':'}':str) =     let (str', rest) = spanToNewline (n-1) str     in ('-':'}':str', rest)++-- When not in a block comment, try to lex a Haskell token+spanToNewline 0 str@(c:_) | ((lexed, str') : _) <- R.lex str, not (isSpace c) =+    if all (== '-') lexed && length lexed >= 2+      -- A Haskell line comment+      then case span (/= '\n') str' of+             (str'', '\n':rest) -> (lexed ++ str'' ++ "\n", rest)+             (_, _) -> (str, "") ++      -- An actual Haskell token+      else let (str'', rest) = spanToNewline 0 str'+           in (lexed ++ str'', rest)++-- In all other cases, advance one character at a time spanToNewline n (c:str) =     let (str', rest) = spanToNewline n str     in (c:str', rest)@@ -211,6 +234,7 @@     ITqualified            -> TkKeyword     ITthen                 -> TkKeyword     ITtype                 -> TkKeyword+    ITvia                  -> TkKeyword     ITwhere                -> TkKeyword      ITforall            {} -> TkKeyword@@ -261,9 +285,6 @@     IToptions_prag      {} -> TkPragma     ITinclude_prag      {} -> TkPragma     ITlanguage_prag        -> TkPragma-    ITvect_prag         {} -> TkPragma-    ITvect_scalar_prag  {} -> TkPragma-    ITnovect_prag       {} -> TkPragma     ITminimal_prag      {} -> TkPragma     IToverlappable_prag {} -> TkPragma     IToverlapping_prag  {} -> TkPragma@@ -282,11 +303,11 @@     ITrarrow            {} -> TkGlyph     ITat                   -> TkGlyph     ITtilde                -> TkGlyph-    ITtildehsh             -> TkGlyph     ITdarrow            {} -> TkGlyph     ITminus                -> TkGlyph     ITbang                 -> TkGlyph     ITdot                  -> TkOperator+    ITstar              {} -> TkOperator     ITtypeApp              -> TkGlyph      ITbiglam               -> TkGlyph@@ -408,9 +429,6 @@     IToptions_prag      {} -> True     ITinclude_prag      {} -> True     ITlanguage_prag        -> True-    ITvect_prag         {} -> True-    ITvect_scalar_prag  {} -> True-    ITnovect_prag       {} -> True     ITminimal_prag      {} -> True     IToverlappable_prag {} -> True     IToverlapping_prag  {} -> True
haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE RecordWildCards #-} - module Haddock.Backends.Hyperlinker.Renderer (render) where  @@ -28,36 +27,10 @@        -> Html render mcss mjs srcs tokens = header mcss mjs <> body srcs tokens --data TokenGroup-    = GrpNormal Token-    | GrpRich TokenDetails [Token]----- | Group consecutive tokens pointing to the same element.------ We want to render qualified identifiers as one entity. For example,--- @Bar.Baz.foo@ consists of 5 tokens (@Bar@, @.@, @Baz@, @.@, @foo@) but for--- better user experience when highlighting and clicking links, these tokens--- should be regarded as one identifier. Therefore, before rendering we must--- group consecutive elements pointing to the same 'GHC.Name' (note that even--- dot token has it if it is part of qualified name).-groupTokens :: [RichToken] -> [TokenGroup]-groupTokens [] = []-groupTokens ((RichToken tok Nothing):rest) = (GrpNormal tok):(groupTokens rest)-groupTokens ((RichToken tok (Just det)):rest) =-    let (grp, rest') = span same rest-    in (GrpRich det (tok:(map rtkToken grp))):(groupTokens rest')-  where-    same (RichToken _ (Just det')) = det == det'-    same _ = False-- body :: SrcMap -> [RichToken] -> Html-body srcs tokens =-    Html.body . Html.pre $ hypsrc+body srcs tokens = Html.body . Html.pre $ hypsrc   where-    hypsrc = mconcat . map (tokenGroup srcs) . groupTokens $ tokens+    hypsrc = mconcat . map (richToken srcs) $ tokens   header :: Maybe FilePath -> Maybe FilePath -> Html@@ -78,29 +51,20 @@         , Html.src scriptFile         ] --tokenGroup :: SrcMap -> TokenGroup -> Html-tokenGroup _ (GrpNormal tok@(Token { .. }))+-- | Given information about the source position of definitions, render a token+richToken :: SrcMap -> RichToken -> Html+richToken srcs (RichToken Token{..} details)     | tkType == TkSpace = renderSpace (GHC.srcSpanStartLine tkSpan) tkValue-    | otherwise = tokenSpan tok ! attrs-  where-    attrs = [ multiclass . tokenStyle $ tkType ]-tokenGroup srcs (GrpRich det tokens) =-    externalAnchor det . internalAnchor det . hyperlink srcs det $ content-  where-    content = mconcat . map (richToken det) $ tokens---richToken :: TokenDetails -> Token -> Html-richToken det tok =-    tokenSpan tok ! [ multiclass style ]+    | otherwise = linked content   where-    style = (tokenStyle . tkType) tok ++ richTokenStyle det---tokenSpan :: Token -> Html-tokenSpan = Html.thespan . Html.toHtml . tkValue+    content = tokenSpan ! [ multiclass style ]+    tokenSpan = Html.thespan (Html.toHtml tkValue)+    style = tokenStyle tkType ++ maybe [] richTokenStyle details +    -- If we have name information, we can make links+    linked = case details of+      Just d -> externalAnchor d . internalAnchor d . hyperlink srcs d+      Nothing -> id  richTokenStyle :: TokenDetails -> [StyleClass] richTokenStyle (RtkVar _) = ["hs-var"]
haddock-api/src/Haddock/Backends/LaTeX.hs view
@@ -27,7 +27,7 @@ import OccName import Name                 ( nameOccName ) import RdrName              ( rdrNameOcc )-import FastString           ( unpackFS, unpackLitString, zString )+import FastString           ( unpackFS ) import Outputable           ( panic)  import qualified Data.Map as Map@@ -169,23 +169,16 @@        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 exportListItem ExportDecl { expItemDecl = decl, expItemSubDocs = subdocs }-  = sep (punctuate comma . map ppDocBinder $ declNames decl) <>-     case subdocs of-       [] -> empty-       _  -> parens (sep (punctuate comma (map (ppDocBinder . fst) subdocs)))+  = let (leader, names) = declNames decl+    in sep (punctuate comma [ leader <+> ppDocBinder name | name <- names ]) <>+         case subdocs of+           [] -> empty+           _  -> parens (sep (punctuate comma (map (ppDocBinder . fst) subdocs))) exportListItem (ExportNoDecl y [])   = ppDocBinder y exportListItem (ExportNoDecl y subs)@@ -215,7 +208,7 @@   isSimpleSig :: ExportItem DocNameI -> Maybe ([DocName], HsType DocNameI)-isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig lnames t))+isSimpleSig ExportDecl { expItemDecl = L _ (SigD _ (TypeSig _ lnames t))                        , expItemMbDoc = (Documentation Nothing Nothing, argDocs) }   | Map.null argDocs = Just (map unLoc lnames, unLoc (hsSigWcType t)) isSimpleSig _ = Nothing@@ -249,13 +242,17 @@         sec _ = text "\\paragraph"  -declNames :: LHsDecl DocNameI -> [DocName]+-- | Given a declaration, extract out the names being declared+declNames :: LHsDecl DocNameI+          -> ( LaTeX           -- ^ to print before each name in an export list+             , [DocName]       -- ^ names being declared+             ) declNames (L _ decl) = case decl of-  TyClD d  -> [tcdName d]-  SigD (TypeSig lnames _ ) -> map unLoc lnames-  SigD (PatSynSig lnames _) -> map unLoc lnames-  ForD (ForeignImport (L _ n) _ _ _) -> [n]-  ForD (ForeignExport (L _ n) _ _ _) -> [n]+  TyClD _ d  -> (empty, [tcdName d])+  SigD _ (TypeSig _ lnames _ ) -> (empty, map unLoc lnames)+  SigD _ (PatSynSig _ lnames _) -> (text "pattern", map unLoc lnames)+  ForD _ (ForeignImport _ (L _ n) _ _) -> (empty, [n])+  ForD _ (ForeignExport _ (L _ n) _ _) -> (empty, [n])   _ -> error "declaration not supported by declNames"  @@ -278,47 +275,44 @@ -- * Decls ------------------------------------------------------------------------------- --ppDecl :: LHsDecl DocNameI-       -> [(HsDecl DocNameI, DocForDecl DocName)]-       -> DocForDecl DocName-       -> [DocInstance DocNameI]-       -> [(DocName, DocForDecl DocName)]-       -> [(DocName, Fixity)]+-- | Pretty print a declaration+ppDecl :: LHsDecl DocNameI                         -- ^ decl to print+       -> [(HsDecl DocNameI, DocForDecl DocName)]  -- ^ all pattern decls+       -> DocForDecl DocName                       -- ^ documentation for decl+       -> [DocInstance DocNameI]                   -- ^ all instances+       -> [(DocName, DocForDecl DocName)]          -- ^ all subdocs+       -> [(DocName, Fixity)]                      -- ^ all fixities        -> LaTeX -ppDecl (L loc decl) pats (doc, fnArgsDoc) instances subdocs _fixities = case decl of-  TyClD d@(FamDecl {})          -> ppTyFam False loc doc d unicode-  TyClD d@(DataDecl {})-                                -> ppDataDecl pats instances subdocs loc (Just doc) d unicode-  TyClD d@(SynDecl {})          -> ppTySyn loc (doc, fnArgsDoc) d unicode+ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of+  TyClD _ d@FamDecl {}         -> ppTyFam False doc d unicode+  TyClD _ d@DataDecl {}        -> ppDataDecl pats instances subdocs (Just doc) d unicode+  TyClD _ d@SynDecl {}         -> ppTySyn (doc, fnArgsDoc) d unicode -- Family instances happen via FamInst now---  TyClD d@(TySynonym {})+--  TyClD _ d@TySynonym{} --    | Just _  <- tcdTyPats d    -> ppTyInst False loc doc d unicode -- Family instances happen via FamInst now-  TyClD d@(ClassDecl {})    -> ppClassDecl instances loc doc subdocs d unicode-  SigD (TypeSig lnames t)   -> ppFunSig loc (doc, fnArgsDoc) (map unLoc lnames)-                                        (hsSigWcType t) unicode-  SigD (PatSynSig lnames ty) ->-      ppLPatSig loc (doc, fnArgsDoc) (map unLoc lnames) ty unicode-  ForD d                         -> ppFor loc (doc, fnArgsDoc) d unicode-  InstD _                        -> empty-  DerivD _                       -> empty+  TyClD _ d@ClassDecl{}          -> ppClassDecl instances doc subdocs d unicode+  SigD _ (TypeSig _ lnames ty)   -> ppFunSig (doc, fnArgsDoc) (map unLoc lnames) (hsSigWcType ty) unicode+  SigD _ (PatSynSig _ lnames ty) -> ppLPatSig (doc, fnArgsDoc) (map unLoc lnames) ty unicode+  ForD _ d                       -> ppFor (doc, fnArgsDoc) d unicode+  InstD _ _                      -> empty+  DerivD _ _                     -> empty   _                              -> error "declaration not supported by ppDecl"   where     unicode = False  -ppTyFam :: Bool -> SrcSpan -> Documentation DocName ->+ppTyFam :: Bool -> Documentation DocName ->               TyClDecl DocNameI -> Bool -> LaTeX-ppTyFam _ _ _ _ _ =+ppTyFam _ _ _ _ =   error "type family declarations are currently not supported by --latex"  -ppFor :: SrcSpan -> DocForDecl DocName -> ForeignDecl DocNameI -> Bool -> LaTeX-ppFor loc doc (ForeignImport (L _ name) typ _ _) unicode =-  ppFunSig loc doc [name] (hsSigType typ) unicode-ppFor _ _ _ _ = error "ppFor error in Haddock.Backends.LaTeX"+ppFor :: DocForDecl DocName -> ForeignDecl DocNameI -> Bool -> LaTeX+ppFor doc (ForeignImport _ (L _ name) typ _) unicode =+  ppFunSig doc [name] (hsSigType typ) unicode+ppFor _ _ _ = error "ppFor error in Haddock.Backends.LaTeX" --  error "foreign declarations are currently not supported by --latex"  @@ -328,18 +322,18 @@   -- we skip type patterns for now-ppTySyn :: SrcSpan -> DocForDecl DocName -> TyClDecl DocNameI -> Bool -> LaTeX+ppTySyn :: DocForDecl DocName -> TyClDecl DocNameI -> Bool -> LaTeX -ppTySyn loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars+ppTySyn doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars                          , tcdRhs = ltype }) unicode-  = ppTypeOrFunSig loc [name] (unLoc ltype) doc (full, hdr, char '=') unicode+  = ppTypeOrFunSig (unLoc ltype) doc (full, hdr, char '=') unicode   where     hdr  = hsep (keyword "type"                  : ppDocBinder name                  : map ppSymName (tyvarNames ltyvars))     full = hdr <+> char '=' <+> ppLType unicode ltype -ppTySyn _ _ _ _ = error "declaration not supported by ppTySyn"+ppTySyn _ _ _ = error "declaration not supported by ppTySyn"   -------------------------------------------------------------------------------@@ -347,63 +341,100 @@ -------------------------------------------------------------------------------  -ppFunSig :: SrcSpan -> DocForDecl DocName -> [DocName] -> LHsType DocNameI+ppFunSig :: DocForDecl DocName -> [DocName] -> LHsType DocNameI          -> Bool -> LaTeX-ppFunSig loc doc docnames (L _ typ) unicode =-  ppTypeOrFunSig loc docnames typ doc+ppFunSig doc docnames (L _ typ) unicode =+  ppTypeOrFunSig typ doc     ( ppTypeSig names typ False     , hsep . punctuate comma $ map ppSymName names-    , dcolon unicode)+    , dcolon unicode+    )     unicode  where    names = map getName docnames -ppLPatSig :: SrcSpan -> DocForDecl DocName -> [DocName]-          -> LHsSigType DocNameI-          -> Bool -> LaTeX-ppLPatSig _loc (doc, _argDocs) docnames ty unicode-  = declWithDoc pref1 (documentationToLaTeX doc)+-- | Pretty-print a pattern synonym+ppLPatSig :: DocForDecl DocName  -- ^ documentation+          -> [DocName]           -- ^ pattern names in the pattern signature+          -> LHsSigType DocNameI -- ^ type of the pattern synonym+          -> Bool                -- ^ unicode+          -> LaTeX+ppLPatSig doc docnames ty unicode+  = ppTypeOrFunSig typ doc+      ( keyword "pattern" <+> ppTypeSig names typ False+      , keyword "pattern" <+> (hsep . punctuate comma $ map ppSymName names)+      , dcolon unicode+      )+      unicode   where-    pref1 = hsep [ keyword "pattern"-                 , hsep $ punctuate comma $ map ppDocBinder docnames-                 , dcolon unicode-                 , ppLType unicode (hsSigType ty)-                 ]+    typ = unLoc (hsSigType ty)+    names = map getName docnames -ppTypeOrFunSig :: SrcSpan -> [DocName] -> HsType DocNameI-               -> DocForDecl DocName -> (LaTeX, LaTeX, LaTeX)-               -> Bool -> LaTeX-ppTypeOrFunSig _ _ typ (doc, argDocs) (pref1, pref2, sep0)-               unicode-  | Map.null argDocs =-      declWithDoc pref1 (documentationToLaTeX doc)-  | otherwise        =-      declWithDoc pref2 $ Just $+-- | Pretty-print a type, adding documentation to the whole type and its+-- arguments as needed.+ppTypeOrFunSig :: HsType DocNameI+               -> DocForDecl DocName  -- ^ documentation+               -> ( LaTeX             -- ^ first-line (no-argument docs only)+                  , LaTeX             -- ^ first-line (argument docs only)+                  , LaTeX             -- ^ type prefix (argument docs only)+                  )+               -> Bool                -- ^ unicode+               -> LaTeX+ppTypeOrFunSig typ (doc, argDocs) (pref1, pref2, sep0) unicode+  | Map.null argDocs = declWithDoc pref1 (documentationToLaTeX doc)+  | otherwise        = declWithDoc pref2 $ Just $         text "\\haddockbeginargs" $$-        do_args 0 sep0 typ $$+        vcat (map (uncurry (<->)) (ppSubSigLike unicode typ argDocs [] sep0)) $$         text "\\end{tabulary}\\par" $$         fromMaybe empty (documentationToLaTeX doc)++-- This splits up a type signature along `->` and adds docs (when they exist)+-- to the arguments. The output is a list of (leader/seperator, argument and+-- its doc)+ppSubSigLike :: Bool                  -- ^ unicode+             -> HsType DocNameI       -- ^ type signature+             -> FnArgsDoc DocName     -- ^ docs to add+             -> [(DocName, DocForDecl DocName)] -- ^ all subdocs (useful when we have `HsRecTy`)+             -> LaTeX                 -- ^ seperator (beginning of first line)+             -> [(LaTeX, LaTeX)]      -- ^ arguments (leader/sep, type)+ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ   where-     do_largs n leader (L _ t) = do_args n leader t+    do_largs n leader (L _ t) = do_args n leader t -     arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs+    arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs -     do_args :: Int -> LaTeX -> HsType DocNameI -> LaTeX-     do_args _n leader (HsForAllTy tvs ltype)-       = decltt leader-         <-> decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]))-         <+> ppLType unicode ltype-     do_args n leader (HsQualTy lctxt ltype)-       = decltt leader-         <-> ppLContextNoArrow lctxt unicode <+> nl $$-             do_largs n (darrow unicode) ltype-     do_args n leader (HsFunTy lt r)-       = decltt leader <-> decltt (ppLFunLhType unicode lt) <-> arg_doc n <+> nl $$-         do_largs (n+1) (arrow unicode) r-     do_args n leader t-       = decltt leader <-> decltt (ppType unicode t) <-> arg_doc n <+> nl+    do_args :: Int -> LaTeX -> HsType DocNameI -> [(LaTeX, LaTeX)]+    do_args _n leader (HsForAllTy _ tvs ltype)+      = [ ( decltt leader+          , decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]))+              <+> ppLType unicode ltype+          ) ]+    do_args n leader (HsQualTy _ lctxt ltype)+      = (decltt leader, ppLContextNoArrow lctxt unicode <+> nl)+        : do_largs n (darrow unicode) ltype +    do_args n leader (HsFunTy _ (L _ (HsRecTy _ fields)) r)+      = [ (decltt ldr, latex <+> nl)+        | (L _ field, ldr) <- zip fields (leader <+> gadtOpen : repeat gadtComma)+        , let latex = ppSideBySideField subdocs unicode field+        ]+        ++ do_largs (n+1) (gadtEnd <+> arrow unicode) r+    do_args n leader (HsFunTy _ lt r)+      = (decltt leader, decltt (ppLFunLhType unicode lt) <-> arg_doc n <+> nl)+        : do_largs (n+1) (arrow unicode) r+    do_args n leader t+      = [ (decltt leader, decltt (ppType unicode t) <-> arg_doc n <+> nl) ] +    -- FIXME: this should be done more elegantly+    --+    -- We need 'gadtComma' and 'gadtEnd' to line up with the `{` from+    -- 'gadtOpen', so we add 3 spaces to cover for `-> `/`:: ` (3 in unicode+    -- mode since `->` and `::` are rendered as single characters.+    gadtComma = hcat (replicate (if unicode then 3 else 4) (text "\\ ")) <> text ","+    gadtEnd = hcat (replicate (if unicode then 3 else 4) (text "\\ ")) <> text "\\}"+    gadtOpen = text "\\{"++ ppTypeSig :: [Name] -> HsType DocNameI  -> Bool -> LaTeX ppTypeSig nms ty unicode =   hsep (punctuate comma $ map ppSymName nms)@@ -483,10 +514,10 @@                            hsep (map (ppDocName . unLoc) vars2)  -ppClassDecl :: [DocInstance DocNameI] -> SrcSpan+ppClassDecl :: [DocInstance DocNameI]             -> Documentation DocName -> [(DocName, DocForDecl DocName)]             -> TyClDecl DocNameI -> Bool -> LaTeX-ppClassDecl instances loc doc subdocs+ppClassDecl instances doc subdocs   (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars, tcdFDs = lfds              , tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs }) unicode   = declWithDoc classheader (if null body then Nothing else Just (vcat body)) $$@@ -508,15 +539,15 @@      methodTable =       text "\\haddockpremethods{}\\textbf{Methods}" $$-      vcat  [ ppFunSig loc doc [name] (hsSigWcType typ) unicode-            | L _ (TypeSig lnames typ) <- lsigs+      vcat  [ ppFunSig doc [name] (hsSigWcType typ) unicode+            | L _ (TypeSig _ lnames typ) <- lsigs             , name <- map unLoc lnames             , let doc = lookupAnySubdoc name subdocs             ]      instancesBit = ppDocInstances unicode instances -ppClassDecl _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"+ppClassDecl _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"  ppDocInstances :: Bool -> [DocInstance DocNameI] -> LaTeX ppDocInstances _unicode [] = empty@@ -565,15 +596,17 @@ -- * Data & newtype declarations ------------------------------------------------------------------------------- --ppDataDecl :: [(HsDecl DocNameI, DocForDecl DocName)] -> [DocInstance DocNameI] ->-              [(DocName, DocForDecl DocName)] -> SrcSpan ->-              Maybe (Documentation DocName) -> TyClDecl DocNameI -> Bool ->-              LaTeX-ppDataDecl pats instances subdocs _loc doc dataDecl unicode--   =  declWithDoc (ppDataHeader dataDecl unicode <+> whereBit)-                  (if null body then Nothing else Just (vcat body))+-- | Pretty-print a data declaration+ppDataDecl :: [(HsDecl DocNameI, DocForDecl DocName)] -- ^ relevant patterns+           -> [DocInstance DocNameI]                  -- ^ relevant instances+           -> [(DocName, DocForDecl DocName)]         -- ^ relevant decl docs+           -> Maybe (Documentation DocName)           -- ^ this decl's docs+           -> TyClDecl DocNameI                       -- ^ data decl to print+           -> Bool                                    -- ^ unicode+           -> LaTeX+ppDataDecl pats instances subdocs doc dataDecl unicode =+   declWithDoc (ppDataHeader dataDecl unicode <+> whereBit)+               (if null body then Nothing else Just (vcat body))    $$ instancesBit    where@@ -585,28 +618,26 @@     (whereBit, leaders)       | null cons       , null pats = (empty,[])-      | null cons = (decltt (keyword "where"), repeat empty)+      | null cons = (text "where", repeat empty)       | otherwise = case resTy of-        ConDeclGADT{} -> (decltt (keyword "where"), repeat empty)+        ConDeclGADT{} -> (text "where", repeat empty)         _             -> (empty, (decltt (text "=") : repeat (decltt (text "|"))))      constrBit       | null cons = Nothing       | otherwise = Just $+          text "\\enspace" <+> emph (text "Constructors") <> text "\\par" $$           text "\\haddockbeginconstrs" $$           vcat (zipWith (ppSideBySideConstr subdocs unicode) leaders cons) $$           text "\\end{tabulary}\\par"      patternBit-      | null cons = Nothing+      | null pats = Nothing       | otherwise = Just $+          text "\\enspace" <+> emph (text "Bundled Patterns") <> text "\\par" $$           text "\\haddockbeginconstrs" $$-          vcat [ hsep [ keyword "pattern"-                      , hsep $ punctuate comma $ map (ppDocBinder . unLoc) lnames-                      , dcolon unicode-                      , ppLType unicode (hsSigType ty)-                      ] <-> rDoc (fmap _doc . combineDocumentation . fst $ d)-               | (SigD (PatSynSig lnames ty),d) <- pats+          vcat [ empty <-> ppSideBySidePat lnames typ d unicode+               | (SigD _ (PatSynSig _ lnames typ), d) <- pats                ] $$           text "\\end{tabulary}\\par" @@ -625,192 +656,155 @@       False -> empty  -ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LaTeX-                   -> LConDecl DocNameI -> LaTeX-ppSideBySideConstr subdocs unicode leader (L _ con@(ConDeclH98 {})) =-  leader <->-  case con_details con of--    PrefixCon args ->-      decltt (hsep ((header_ unicode <+> ppOcc) :-                 map (ppLParendType unicode) args))-      <-> rDoc mbDoc <+> nl--    RecCon (L _ fields) ->-      (decltt (header_ unicode <+> ppOcc)-        <-> rDoc mbDoc <+> nl)-      $$-      doRecordFields fields--    InfixCon arg1 arg2 ->-      decltt (hsep [ header_ unicode <+> ppLParendType unicode arg1,-                 ppOcc,-                 ppLParendType unicode arg2 ])-      <-> rDoc mbDoc <+> nl-- where-    doRecordFields fields =-        vcat (map (ppSideBySideField subdocs unicode) (map unLoc fields))+-- | Pretty-print a constructor+ppSideBySideConstr :: [(DocName, DocForDecl DocName)]  -- ^ all decl docs+                   -> Bool                             -- ^ unicode+                   -> LaTeX                            -- ^ prefix to decl+                   -> LConDecl DocNameI                -- ^ constructor decl+                   -> LaTeX+ppSideBySideConstr subdocs unicode leader (L _ con) =+  leader <-> decltt decl <-> rDoc mbDoc <+> nl+  $$ fieldPart+  where+    -- Find the name of a constructors in the decl (`getConName` always returns+    -- a non-empty list)+    aConName = unLoc (head (getConNames con)) +    occ      = map (nameOccName . getName . unLoc) $ getConNames con -    header_ = ppConstrHdr False tyVars context-    occ     = map (nameOccName . getName . unLoc) $ getConNames con-    ppOcc   = case occ of-      [one] -> ppBinder one-      _     -> cat (punctuate comma (map ppBinder occ))-    tyVars  = tyvarNames (fromMaybe (HsQTvs PlaceHolder [] PlaceHolder) (con_qvars con))-    context = unLoc (fromMaybe (noLoc []) (con_cxt con))+    ppOcc      = cat (punctuate comma (map ppBinder occ))+    ppOccInfix = cat (punctuate comma (map ppBinderInfix occ)) -    -- don't use "con_doc con", in case it's reconstructed from a .hi file,-    -- or also because we want Haddock to do the doc-parsing, not GHC.-    mbDoc = case getConNames con of-              [] -> panic "empty con_names"-              (cn:_) -> lookup (unLoc cn) subdocs >>=-                        fmap _doc . combineDocumentation . fst+    -- Extract out the map of of docs corresponding to the constructors arguments+    argDocs = maybe Map.empty snd (lookup aConName subdocs)+    hasArgDocs = not $ Map.null argDocs -ppSideBySideConstr subdocs unicode leader (L _ con@(ConDeclGADT {})) =-  leader <->-  doGADTCon (hsib_body $ con_type con)+    -- First line of the constructor (no doc, no fields, single-line)+    decl = case con of+      ConDeclH98{ con_args = det+                , con_ex_tvs = vars+                , con_mb_cxt = cxt+                } -> let tyVars = map (getName . hsLTyVarName) vars+                         context = unLoc (fromMaybe (noLoc []) cxt)+                         forall_ = False+                         header_ = ppConstrHdr forall_ tyVars context unicode+                     in case det of+        -- Prefix constructor, e.g. 'Just a'+        PrefixCon args+          | hasArgDocs -> header_ <+> ppOcc+          | otherwise -> hsep [ header_+                              , ppOcc+                              , hsep (map (ppLParendType unicode) args)+                              ] - where-    doGADTCon resTy = decltt (ppOcc <+> dcolon unicode <+>-                               ppLType unicode resTy-                            ) <-> rDoc mbDoc+        -- Record constructor, e.g. 'Identity { runIdentity :: a }'+        RecCon _ ->  header_ <+> ppOcc -    occ     = map (nameOccName . getName . unLoc) $ getConNames con-    ppOcc   = case occ of-      [one] -> ppBinder one-      _     -> cat (punctuate comma (map ppBinder occ))+        -- Infix constructor, e.g. 'a :| [a]'+        InfixCon arg1 arg2+          | hasArgDocs -> header_ <+> ppOcc+          | otherwise -> hsep [ header_+                              , ppLParendType unicode arg1+                              , ppOccInfix+                              , ppLParendType unicode arg2+                              ] -    -- don't use "con_doc con", in case it's reconstructed from a .hi file,-    -- or also because we want Haddock to do the doc-parsing, not GHC.-    mbDoc = case getConNames con of-              [] -> panic "empty con_names"-              (cn:_) -> lookup (unLoc cn) subdocs >>=-                        fmap _doc . combineDocumentation . fst-{- old+      ConDeclGADT{}+        | hasArgDocs || not (isEmpty fieldPart) -> ppOcc+        | otherwise -> hsep [ ppOcc+                            , dcolon unicode+                            -- ++AZ++ make this prepend "{..}" when it is a record style GADT+                            , ppLType unicode (getGADTConType con)+                            ]+      XConDecl{} -> panic "haddock:ppSideBySideConstr" -ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LaTeX-                   -> LConDecl DocName -> LaTeX-ppSideBySideConstr subdocs unicode leader (L loc con) =-  leader <->-  case con_res con of-  ResTyH98 -> case con_details con of+    fieldPart = case (con, getConArgs con) of+        -- Record style GADTs+        (ConDeclGADT{}, RecCon _)            -> doConstrArgsWithDocs [] -    PrefixCon args ->-      decltt (hsep ((header_ unicode <+> ppOcc) :-                 map (ppLParendType unicode) args))-      <-> rDoc mbDoc <+> nl+        -- Regular record declarations+        (_, RecCon (L _ fields))             -> doRecordFields fields -    RecCon (L _ fields) ->-      (decltt (header_ unicode <+> ppOcc)-        <-> rDoc mbDoc <+> nl)-      $$-      doRecordFields fields+        -- Any GADT or a regular H98 prefix data constructor+        (_, PrefixCon args)     | hasArgDocs -> doConstrArgsWithDocs args -    InfixCon arg1 arg2 ->-      decltt (hsep [ header_ unicode <+> ppLParendType unicode arg1,-                 ppOcc,-                 ppLParendType unicode arg2 ])-      <-> rDoc mbDoc <+> nl+        -- An infix H98 data constructor+        (_, InfixCon arg1 arg2) | hasArgDocs -> doConstrArgsWithDocs [arg1,arg2] -  ResTyGADT _ resTy -> case con_details con of-    -- prefix & infix could also use hsConDeclArgTys if it seemed to-    -- simplify the code.-    PrefixCon args -> doGADTCon args resTy-    cd@(RecCon (L _ fields)) -> doGADTCon (hsConDeclArgTys cd) resTy <+> nl $$-                                     doRecordFields fields-    InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy+        _ -> empty - where     doRecordFields fields =-        vcat (map (ppSideBySideField subdocs unicode) (map unLoc fields))+      vcat [ empty <-> tt (text begin) <+> ppSideBySideField subdocs unicode field <+> nl+           | (begin, L _ field) <- zip ("\\qquad \\{" : repeat "\\qquad ,") fields+           ]+      $$+      empty <-> tt (text "\\qquad \\}") <+> nl -    doGADTCon args resTy = decltt (ppOcc <+> dcolon unicode <+>-                               ppLType unicode (mk_forall $ mk_phi $-                                                foldr mkFunTy resTy args)-                            ) <-> rDoc mbDoc+    doConstrArgsWithDocs args = vcat $ map (\l -> empty <-> text "\\qquad" <+> l) $ case con of+      ConDeclH98{} ->+        [ decltt (ppLParendType unicode arg) <-> rDoc (fmap _doc mdoc) <+> nl+        | (i, arg) <- zip [0..] args+        , let mdoc = Map.lookup i argDocs+        ]+      ConDeclGADT{} ->+        [ l <+> text "\\enspace" <+> r+        | (l,r) <- ppSubSigLike unicode (unLoc (getGADTConType con)) argDocs subdocs (dcolon unicode)+        ]+      XConDecl{} -> panic "haddock:doConstrArgsWithDocs"  -    header_ = ppConstrHdr (con_explicit con) tyVars context-    occ     = map (nameOccName . getName . unLoc) $ con_names con-    ppOcc   = case occ of-      [one] -> ppBinder one-      _     -> cat (punctuate comma (map ppBinder occ))-    ltvs    = con_qvars con-    tyVars  = tyvarNames (con_qvars con)-    context = unLoc (con_cxt con)--    mk_forall ty | con_explicit con = L loc (HsForAllTy (hsQTvExplicit ltvs) ty)-                 | otherwise        = ty-    mk_phi ty | null context = ty-              | otherwise    = L loc (HsQualTy (con_cxt con) ty)-     -- don't use "con_doc con", in case it's reconstructed from a .hi file,     -- or also because we want Haddock to do the doc-parsing, not GHC.-    mbDoc = case con_names con of+    mbDoc = case getConNames con of               [] -> panic "empty con_names"               (cn:_) -> lookup (unLoc cn) subdocs >>=                         fmap _doc . combineDocumentation . fst-    mkFunTy a b = noLoc (HsFunTy a b)--} ++-- | Pretty-print a record field ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocNameI ->  LaTeX-ppSideBySideField subdocs unicode (ConDeclField names ltype _) =+ppSideBySideField subdocs unicode (ConDeclField _ names ltype _) =   decltt (cat (punctuate comma (map (ppBinder . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names))     <+> dcolon unicode <+> ppLType unicode ltype) <-> rDoc mbDoc   where     -- don't use cd_fld_doc for same reason we don't use con_doc above     -- Where there is more than one name, they all have the same documentation-    mbDoc = lookup (selectorFieldOcc $ unLoc $ head names) subdocs >>= fmap _doc . combineDocumentation . fst+    mbDoc = lookup (extFieldOcc $ unLoc $ head names) subdocs >>= fmap _doc . combineDocumentation . fst+ppSideBySideField _ _ (XConDeclField _) = panic "haddock:ppSideBySideField" --- {---- ppHsFullConstr :: HsConDecl -> LaTeX--- ppHsFullConstr (HsConDecl _ nm tvs ctxt typeList doc) =---      declWithDoc False doc (--- 	hsep ((ppHsConstrHdr tvs ctxt +++--- 		ppHsBinder False nm) : map ppHsBangType typeList)---       )--- ppHsFullConstr (HsRecDecl _ nm tvs ctxt fields doc) =---    td << vanillaTable << (---      case doc of---        Nothing -> aboves [hdr, fields_html]---        Just _  -> aboves [hdr, constr_doc, fields_html]---    )------   where hdr = declBox (ppHsConstrHdr tvs ctxt +++ ppHsBinder False nm)------ 	constr_doc--- 	  | isJust doc = docBox (docToLaTeX (fromJust doc))--- 	  | otherwise  = LaTeX.emptyTable------ 	fields_html =--- 	   td <<--- 	      table ! [width "100%", cellpadding 0, cellspacing 8] << (--- 		   aboves (map ppFullField (concat (map expandField fields)))--- 		)--- -}------ ppShortField :: Bool -> Bool -> ConDeclField DocName -> LaTeX--- ppShortField summary unicode (ConDeclField (L _ name) ltype _)---   = tda [theclass "recfield"] << (---       ppBinder summary (docNameOcc name)---       <+> dcolon unicode <+> ppLType unicode ltype---     )------ {---- ppFullField :: HsFieldDecl -> LaTeX--- ppFullField (HsFieldDecl [n] ty doc)---   = declWithDoc False doc (--- 	ppHsBinder False n <+> dcolon <+> ppHsBangType ty---     )--- ppFullField _ = error "ppFullField"------ expandField :: HsFieldDecl -> [HsFieldDecl]--- expandField (HsFieldDecl ns ty doc) = [ HsFieldDecl [n] ty doc | n <- ns ]--- -} +-- | Pretty-print a bundled pattern synonym+ppSideBySidePat :: [Located DocName]    -- ^ pattern name(s)+                -> LHsSigType DocNameI  -- ^ type of pattern(s)+                -> DocForDecl DocName   -- ^ doc map+                -> Bool                 -- ^ unicode+                -> LaTeX+ppSideBySidePat lnames typ (doc, argDocs) unicode =+  decltt decl <-> rDoc mDoc <+> nl+  $$ fieldPart+  where+    hasArgDocs = not $ Map.null argDocs+    ppOcc = hsep (punctuate comma (map (ppDocBinder . unLoc) lnames)) +    decl | hasArgDocs = keyword "pattern" <+> ppOcc+         | otherwise = hsep [ keyword "pattern"+                            , ppOcc+                            , dcolon unicode+                            , ppLType unicode (hsSigType typ)+                            ]++    fieldPart+      | not hasArgDocs = empty+      | otherwise = vcat+          [ empty <-> text "\\qquad" <+> l <+> text "\\enspace" <+> r+          | (l,r) <- ppSubSigLike unicode (unLoc patTy) argDocs [] (dcolon unicode)+          ]++    patTy = hsSigType typ++    mDoc = fmap _doc $ combineDocumentation doc++ -- | Print the LHS of a data\/newtype declaration. -- Currently doesn't handle 'data instance' decls or kind signatures ppDataHeader :: TyClDecl DocNameI -> Bool -> LaTeX@@ -824,6 +818,7 @@     ppAppDocNameNames False name (tyvarNames tyvars) ppDataHeader _ _ = error "ppDataHeader: illegal argument" + -------------------------------------------------------------------------------- -- * Type applications --------------------------------------------------------------------------------@@ -911,24 +906,6 @@ -- Stolen from Html and tweaked for LaTeX generation ------------------------------------------------------------------------------- --pREC_TOP, pREC_FUN, pREC_OP, pREC_CON :: Int--pREC_TOP = (0 :: Int)   -- type in ParseIface.y in GHC-pREC_FUN = (1 :: Int)   -- btype in ParseIface.y in GHC-                        -- Used for LH arg of (->)-pREC_OP  = (2 :: Int)   -- Used for arg of any infix operator-                        -- (we don't keep their fixities around)-pREC_CON = (3 :: Int)   -- Used for arg of type applicn:-                        -- always parenthesise unless atomic--maybeParen :: Int           -- Precedence of context-           -> Int           -- Precedence of top-level operator-           -> LaTeX -> LaTeX  -- Wrap in parens if (ctxt >= op)-maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p-                               | otherwise            = p-- ppLType, ppLParendType, ppLFunLhType :: Bool -> Located (HsType DocNameI) -> LaTeX ppLType       unicode y = ppType unicode (unLoc y) ppLParendType unicode y = ppParendType unicode (unLoc y)@@ -936,78 +913,70 @@   ppType, ppParendType, ppFunLhType :: Bool -> HsType DocNameI -> LaTeX-ppType       unicode ty = ppr_mono_ty pREC_TOP ty unicode-ppParendType unicode ty = ppr_mono_ty pREC_CON ty unicode-ppFunLhType  unicode ty = ppr_mono_ty pREC_FUN ty unicode+ppType       unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode+ppParendType unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode+ppFunLhType  unicode ty = ppr_mono_ty (reparenTypePrec PREC_FUN ty) unicode  ppLKind :: Bool -> LHsKind DocNameI -> LaTeX ppLKind unicode y = ppKind unicode (unLoc y)  ppKind :: Bool -> HsKind DocNameI -> LaTeX-ppKind unicode ki = ppr_mono_ty pREC_TOP ki unicode+ppKind unicode ki = ppr_mono_ty (reparenTypePrec PREC_TOP ki) unicode   -- Drop top-level for-all type variables in user style -- since they are implicit in Haskell -ppr_mono_lty :: Int -> LHsType DocNameI -> Bool -> LaTeX-ppr_mono_lty ctxt_prec ty unicode = ppr_mono_ty ctxt_prec (unLoc ty) unicode+ppr_mono_lty :: LHsType DocNameI -> Bool -> LaTeX+ppr_mono_lty ty unicode = ppr_mono_ty (unLoc ty) unicode  -ppr_mono_ty :: Int -> HsType DocNameI -> Bool -> LaTeX-ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode-  = maybeParen ctxt_prec pREC_FUN $-    sep [ hsep (forallSymbol unicode : ppTyVars tvs) <> dot-        , ppr_mono_lty pREC_TOP ty unicode ]-ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode-  = maybeParen ctxt_prec pREC_FUN $-    sep [ ppLContext ctxt unicode-        , ppr_mono_lty pREC_TOP ty unicode ]--ppr_mono_ty _         (HsBangTy b ty)     u = ppBang b <> ppLParendType u ty-ppr_mono_ty _         (HsTyVar NotPromoted (L _ name)) _ = ppDocName name-ppr_mono_ty _         (HsTyVar Promoted    (L _ name)) _ = char '\'' <> ppDocName name-ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2)   u = ppr_fun_ty ctxt_prec ty1 ty2 u-ppr_mono_ty _         (HsTupleTy con tys) u = tupleParens con (map (ppLType u) tys)-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 {})        _ = error "ppr_mono_ty HsRecTy"-ppr_mono_ty _         (HsCoreTy {})       _ = error "ppr_mono_ty HsCoreTy"-ppr_mono_ty _         (HsExplicitListTy Promoted _ tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys-ppr_mono_ty _         (HsExplicitListTy NotPromoted _ tys) u = brackets $ hsep $ punctuate comma $ map (ppLType u) tys-ppr_mono_ty _         (HsExplicitTupleTy _ tys) u = Pretty.quote $ parenList $ map (ppLType u) tys+ppr_mono_ty :: HsType DocNameI -> Bool -> LaTeX+ppr_mono_ty (HsForAllTy _ tvs ty) unicode+  = sep [ hsep (forallSymbol unicode : ppTyVars tvs) <> dot+        , ppr_mono_lty ty unicode ]+ppr_mono_ty (HsQualTy _ ctxt ty) unicode+  = sep [ ppLContext ctxt unicode+        , ppr_mono_lty ty unicode ]+ppr_mono_ty (HsFunTy _ ty1 ty2)   u+  = sep [ ppr_mono_lty ty1 u+        , arrow u <+> ppr_mono_lty ty2 u ] -ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode-  = maybeParen ctxt_prec pREC_OP $-    ppr_mono_lty pREC_OP ty1 unicode <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode+ppr_mono_ty (HsBangTy _ b ty)     u = ppBang b <> ppLParendType u ty+ppr_mono_ty (HsTyVar _ NotPromoted (L _ name)) _ = ppDocName name+ppr_mono_ty (HsTyVar _ Promoted    (L _ name)) _ = char '\'' <> ppDocName name+ppr_mono_ty (HsTupleTy _ con tys) u = tupleParens con (map (ppLType u) tys)+ppr_mono_ty (HsSumTy _ tys) u       = sumParens (map (ppLType u) tys)+ppr_mono_ty (HsKindSig _ ty kind) u = parens (ppr_mono_lty ty u <+> dcolon u <+> ppLKind u kind)+ppr_mono_ty (HsListTy _ ty)       u = brackets (ppr_mono_lty ty u)+ppr_mono_ty (HsIParamTy _ (L _ n) ty) u = brackets (ppIPName n <+> dcolon u <+> ppr_mono_lty ty u)+ppr_mono_ty (HsSpliceTy {})     _ = error "ppr_mono_ty HsSpliceTy"+ppr_mono_ty (HsRecTy {})        _ = text "{..}"+ppr_mono_ty (XHsType (NHsCoreTy {}))  _ = error "ppr_mono_ty HsCoreTy"+ppr_mono_ty (HsExplicitListTy _ Promoted tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys+ppr_mono_ty (HsExplicitListTy _ NotPromoted tys) u = brackets $ hsep $ punctuate comma $ map (ppLType u) tys+ppr_mono_ty (HsExplicitTupleTy _ tys) u = Pretty.quote $ parenList $ map (ppLType u) tys -ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode-  = maybeParen ctxt_prec pREC_CON $-    hsep [ppr_mono_lty pREC_FUN fun_ty unicode, ppr_mono_lty pREC_CON arg_ty unicode]+ppr_mono_ty (HsAppTy _ fun_ty arg_ty) unicode+  = hsep [ppr_mono_lty fun_ty unicode, ppr_mono_lty arg_ty unicode] -ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode-  = maybeParen ctxt_prec pREC_FUN $-    ppr_mono_lty pREC_OP ty1 unicode <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode+ppr_mono_ty (HsOpTy _ ty1 op ty2) unicode+  = ppr_mono_lty ty1 unicode <+> ppr_op <+> ppr_mono_lty ty2 unicode   where     ppr_op = if not (isSymOcc occName) then char '`' <> ppLDocName op <> char '`' else ppLDocName op     occName = nameOccName . getName . unLoc $ op -ppr_mono_ty ctxt_prec (HsParTy ty) unicode---  = parens (ppr_mono_lty pREC_TOP ty)-  = ppr_mono_lty ctxt_prec ty unicode--ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode-  = ppr_mono_lty ctxt_prec ty unicode+ppr_mono_ty (HsParTy _ ty) unicode+  = parens (ppr_mono_lty ty unicode)+--  = ppr_mono_lty ty unicode -ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ = char '_'+ppr_mono_ty (HsDocTy _ ty _) unicode+  = ppr_mono_lty ty unicode -ppr_mono_ty _ (HsTyLit t) u = ppr_tylit t u+ppr_mono_ty (HsWildCardTy (AnonWildCard _)) _ = char '_' -ppr_mono_ty _ (HsAppsTy {}) _ = panic "ppr_mono_ty:HsAppsTy"+ppr_mono_ty (HsTyLit _ t) u = ppr_tylit t u+ppr_mono_ty (HsStarTy _ isUni) unicode = starSymbol (isUni || unicode)   ppr_tylit :: HsTyLit -> Bool -> LaTeX@@ -1017,15 +986,6 @@   -- XXX: Do something with Unicode parameter?  -ppr_fun_ty :: Int -> LHsType DocNameI -> LHsType DocNameI -> Bool -> LaTeX-ppr_fun_ty ctxt_prec ty1 ty2 unicode-  = let p1 = ppr_mono_lty pREC_FUN ty1 unicode-        p2 = ppr_mono_lty pREC_TOP ty2 unicode-    in-    maybeParen ctxt_prec pREC_FUN $-    sep [p1, arrow unicode <+> p2]-- ------------------------------------------------------------------------------- -- * Names -------------------------------------------------------------------------------@@ -1036,6 +996,11 @@   | isInfixName n = parens $ ppOccName n   | otherwise     = ppOccName n +ppBinderInfix :: OccName -> LaTeX+ppBinderInfix n+  | isInfixName n = ppOccName n+  | otherwise     = cat [ char '`', ppOccName n, char '`' ]+ isInfixName :: OccName -> Bool isInfixName n = isVarSym n || isConSym n @@ -1267,12 +1232,12 @@ quote doc = text "\\begin{quote}" $$ doc $$ text "\\end{quote}"  -dcolon, arrow, darrow, forallSymbol :: Bool -> LaTeX+dcolon, arrow, darrow, forallSymbol, starSymbol :: Bool -> LaTeX dcolon unicode = text (if unicode then "∷" else "::") arrow  unicode = text (if unicode then "→" else "->") darrow unicode = text (if unicode then "⇒" else "=>") forallSymbol unicode = text (if unicode then "∀" else "forall")-+starSymbol unicode = text (if unicode then "★" else "*")  dot :: LaTeX dot = char '.'@@ -1288,10 +1253,6 @@  ubxparens :: LaTeX -> LaTeX ubxparens h = text "(#" <> h <> text "#)"---pabrackets :: LaTeX -> LaTeX-pabrackets h = text "[:" <> h <> text ":]"   nl :: LaTeX
haddock-api/src/Haddock/Backends/Xhtml.hs view
@@ -667,7 +667,7 @@  processExport :: Bool -> LinksInfo -> Bool -> Maybe Package -> Qualification               -> ExportItem DocNameI -> Maybe Html-processExport _ _ _ _ _ ExportDecl { expItemDecl = L _ (InstD _) } = Nothing -- Hide empty instances+processExport _ _ _ _ _ ExportDecl { expItemDecl = L _ (InstD {}) } = Nothing -- Hide empty instances processExport summary _ _ pkg qual (ExportGroup lev id0 doc)   = nothingIf summary $ groupHeading lev id0 << docToHtml (Just id0) pkg qual (mkMeta doc) processExport summary links unicode pkg qual (ExportDecl decl pats doc subdocs insts fixities splice)
haddock-api/src/Haddock/Backends/Xhtml/Decl.hs view
@@ -39,24 +39,34 @@ import Name import BooleanFormula import RdrName ( rdrNameOcc )+import Outputable ( panic ) -ppDecl :: Bool -> LinksInfo -> LHsDecl DocNameI-       -> [(HsDecl DocNameI, DocForDecl DocName)]-       -> DocForDecl DocName ->  [DocInstance DocNameI] -> [(DocName, Fixity)]-       -> [(DocName, DocForDecl DocName)] -> Splice -> Unicode-       -> Maybe Package -> Qualification -> Html+-- | Pretty print a declaration+ppDecl :: Bool                                     -- ^ print summary info only+       -> LinksInfo                                -- ^ link information+       -> LHsDecl DocNameI                         -- ^ declaration to print+       -> [(HsDecl DocNameI, DocForDecl DocName)]  -- ^ relevant pattern synonyms+       -> DocForDecl DocName                       -- ^ documentation for this decl+       -> [DocInstance DocNameI]                   -- ^ relevant instances+       -> [(DocName, Fixity)]                      -- ^ relevant fixities+       -> [(DocName, DocForDecl DocName)]          -- ^ documentation for all decls+       -> Splice+       -> Unicode                                  -- ^ unicode output+       -> Maybe Package+       -> Qualification+       -> Html ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode pkg qual = case decl of-  TyClD (FamDecl d)            -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode pkg qual-  TyClD d@(DataDecl {})        -> ppDataDecl summ links instances fixities subdocs loc mbDoc d pats splice unicode pkg qual-  TyClD d@(SynDecl {})         -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode pkg qual-  TyClD d@(ClassDecl {})       -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode pkg qual-  SigD (TypeSig lnames lty)    -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames+  TyClD _ (FamDecl _ d)          -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode pkg qual+  TyClD _ d@(DataDecl {})        -> ppDataDecl summ links instances fixities subdocs loc mbDoc d pats splice unicode pkg qual+  TyClD _ d@(SynDecl {})         -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode pkg qual+  TyClD _ d@(ClassDecl {})       -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode pkg qual+  SigD _ (TypeSig _ lnames lty)  -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames                                          (hsSigWcType lty) fixities splice unicode pkg qual-  SigD (PatSynSig lnames ty)   -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames-                                         ty fixities splice unicode pkg qual-  ForD d                       -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode pkg qual-  InstD _                      -> noHtml-  DerivD _                     -> noHtml+  SigD _ (PatSynSig _ lnames lty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames+                                         (hsSigType lty) fixities splice unicode pkg qual+  ForD _ d                       -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode pkg qual+  InstD _ _                      -> noHtml+  DerivD _ _                     -> noHtml   _                            -> error "declaration not supported by ppDecl"  @@ -76,22 +86,19 @@   where     pp_typ = ppLType unicode qual HideEmptyContexts typ -ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->-             [Located DocName] -> LHsSigType DocNameI ->-             [(DocName, Fixity)] ->-             Splice -> Unicode -> Maybe Package -> Qualification -> Html-ppLPatSig summary links loc (doc, _argDocs) docnames typ fixities splice-          unicode pkg qual-  | summary = pref1-  | otherwise = topDeclElem links loc splice (map unLoc docnames) (pref1 <+> ppFixities fixities qual)-                +++ docSection Nothing pkg qual doc+-- | Pretty print a pattern synonym+ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName+          -> [Located DocName]     -- ^ names of patterns in declaration+          -> LHsType DocNameI      -- ^ type of patterns in declaration+          -> [(DocName, Fixity)]+          -> Splice -> Unicode -> Maybe Package -> Qualification -> Html+ppLPatSig summary links loc doc lnames typ fixities splice unicode pkg qual =+  ppSigLike summary links loc (keyword "pattern") doc (map unLoc lnames) fixities+            (unLoc typ, pp_typ) splice unicode pkg qual (patSigContext typ)   where-    pref1 = hsep [ keyword "pattern"-                 , hsep $ punctuate comma $ map (ppBinder summary . getOccName) docnames-                 , dcolon unicode-                 , ppPatSigType unicode qual (hsSigType typ)-                 ]+    pp_typ = ppPatSigType unicode qual typ + ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName ->              [DocName] -> [(DocName, Fixity)] -> (HsType DocNameI, Html) ->              Splice -> Unicode -> Maybe Package -> Qualification -> HideEmptyContexts -> Html@@ -99,7 +106,7 @@           splice unicode pkg qual emptyCtxts =   ppTypeOrFunSig summary links loc docnames typ doc     ( addFixities $ leader <+> ppTypeSig summary occnames pp_typ unicode-    , addFixities . concatHtml . punctuate comma $ map (ppBinder False) occnames+    , (leader <+>) . addFixities . concatHtml . punctuate comma $ map (ppBinder False) occnames     , dcolon unicode     )     splice unicode pkg qual emptyCtxts@@ -118,36 +125,72 @@                splice unicode pkg qual emptyCtxts   | summary = pref1   | Map.null argDocs = topDeclElem links loc splice docnames pref1 +++ docSection curName pkg qual doc-  | otherwise = topDeclElem links loc splice docnames pref2 +++-      subArguments pkg qual (do_args 0 sep typ) +++ docSection curName pkg qual doc+  | otherwise = topDeclElem links loc splice docnames pref2+                  +++ subArguments pkg qual (ppSubSigLike unicode qual typ argDocs [] sep emptyCtxts)+                  +++ docSection curName pkg qual doc   where     curName = getName <$> listToMaybe docnames+++-- This splits up a type signature along `->` and adds docs (when they exist) to+-- the arguments.+--+-- If one passes in a list of the available subdocs, any top-level `HsRecTy`+-- found will be expanded out into their fields.+ppSubSigLike :: Unicode -> Qualification+             -> HsType DocNameI                  -- ^ type signature+             -> FnArgsDoc DocName                -- ^ docs to add+             -> [(DocName, DocForDecl DocName)]  -- ^ all subdocs (useful when+                                                 -- we expand an `HsRecTy`)+             -> Html -> HideEmptyContexts -> [SubDecl]+ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_args 0 sep typ+  where     argDoc n = Map.lookup n argDocs      do_largs n leader (L _ t) = do_args n leader t      do_args :: Int -> Html -> HsType DocNameI -> [SubDecl]-    do_args n leader (HsForAllTy tvs ltype)+    do_args n leader (HsForAllTy _ tvs ltype)       = do_largs n leader' ltype       where         leader' = leader <+> ppForAll tvs unicode qual -    do_args n leader (HsQualTy lctxt ltype)+    do_args n leader (HsQualTy _ lctxt ltype)       | null (unLoc lctxt)       = do_largs n leader ltype       | otherwise       = (leader <+> ppLContextNoArrow lctxt unicode qual emptyCtxts, Nothing, [])         : do_largs n (darrow unicode) ltype -    do_args n leader (HsFunTy lt r)+    do_args n leader (HsFunTy _ (L _ (HsRecTy _ fields)) r)+      = [ (ldr <+> html, mdoc, subs)+        | (L _ field, ldr) <- zip fields (leader <+> gadtOpen : repeat gadtComma)+        , let (html, mdoc, subs) = ppSideBySideField subdocs unicode qual field+        ]+        ++ do_largs (n+1) (gadtEnd <+> arrow unicode) r++    do_args n leader (HsFunTy _ lt r)       = (leader <+> ppLFunLhType unicode qual emptyCtxts lt, argDoc n, [])         : do_largs (n+1) (arrow unicode) r+     do_args n leader t       = [(leader <+> ppType unicode qual emptyCtxts t, argDoc n, [])] ++    -- FIXME: this should be done more elegantly+    --+    -- We need 'gadtComma' and 'gadtEnd' to line up with the `{` from+    -- 'gadtOpen', so we add 3 spaces to cover for `-> `/`:: ` (3 in unicode+    -- mode since `->` and `::` are rendered as single characters.+    gadtComma = concatHtml (replicate (if unicode then 2 else 3) spaceHtml) <> toHtml ","+    gadtEnd = concatHtml (replicate (if unicode then 2 else 3) spaceHtml) <> toHtml "}"+    gadtOpen = toHtml "{"+++ ppForAll :: [LHsTyVarBndr DocNameI] -> Unicode -> Qualification -> Html ppForAll tvs unicode qual =-  case [ppKTv n k | L _ (KindedTyVar (L _ n) k) <- tvs] of+  case [ppKTv n k | L _ (KindedTyVar _ (L _ n) k) <- tvs] of     [] -> noHtml     ts -> forallSymbol unicode <+> hsep ts +++ dot   where ppKTv n k = parens $@@ -186,7 +229,7 @@ ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName       -> ForeignDecl DocNameI -> [(DocName, Fixity)]       -> Splice -> Unicode -> Maybe Package -> Qualification -> Html-ppFor summary links loc doc (ForeignImport (L _ name) typ _ _) fixities+ppFor summary links loc doc (ForeignImport _ (L _ name) typ _) fixities       splice unicode pkg qual   = ppFunSig summary links loc doc [name] (hsSigType typ) fixities splice unicode pkg qual ppFor _ _ _ _ _ _ _ _ _ _ = error "ppFor"@@ -279,12 +322,14 @@      ClosedTypeFamily _ -> keyword "where ..."      _                  -> mempty   )+ppTyFamHeader _ _ (XFamilyDecl _) _ _ = panic "haddock;ppTyFamHeader"  ppResultSig :: FamilyResultSig DocNameI -> Unicode -> Qualification -> Html ppResultSig result unicode qual = case result of-    NoSig               -> noHtml-    KindSig kind        -> dcolon unicode  <+> ppLKind unicode qual kind-    TyVarSig (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr+    NoSig _               -> noHtml+    KindSig _ kind        -> dcolon unicode  <+> ppLKind unicode qual kind+    TyVarSig _ (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr+    XFamilyResultSig _    -> panic "haddock:ppResultSig"  ppPseudoFamilyHeader :: Unicode -> Qualification -> PseudoFamilyDecl DocNameI                      -> Html@@ -330,6 +375,8 @@       = ( ppAppNameTypes (unLoc n) (map unLoc ts) unicode qual           <+> equals <+> ppType unicode qual HideEmptyContexts (unLoc rhs)         , Nothing, [] )+    ppTyFamEqn (XHsImplicitBndrs _) = panic "haddock:ppTyFam"+    ppTyFamEqn (HsIB { hsib_body = XFamEqn _}) = panic "haddock:ppTyFam"   @@ -363,6 +410,7 @@ ppFamDeclBinderWithVars :: Bool -> Unicode -> Qualification -> FamilyDecl DocNameI -> Html ppFamDeclBinderWithVars summ unicode qual (FamilyDecl { fdLName = lname, fdTyVars = tvs }) =   ppAppDocNameTyVarBndrs summ unicode qual (unLoc lname) (hsq_explicit tvs)+ppFamDeclBinderWithVars _ _ _ (XFamilyDecl _) = panic "haddock:ppFamDeclBinderWithVars"  -- | Print a newtype / data binder and its variables ppDataBinderWithVars :: Bool -> Unicode -> Qualification -> TyClDecl DocNameI -> Html@@ -475,9 +523,9 @@                  -- ToDo: add associated type defaults -            [ ppFunSig summary links loc doc names (hsSigWcType typ)+            [ ppFunSig summary links loc doc names (hsSigType typ)                        [] splice unicode pkg qual-              | L _ (TypeSig lnames typ) <- sigs+              | L _ (ClassOpSig _ False lnames typ) <- sigs               , let doc = lookupAnySubdoc (head names) subdocs                     names = map unLoc lnames ]               -- FIXME: is taking just the first name ok? Is it possible that@@ -525,7 +573,7 @@      methodBit = subMethods [ ppFunSig summary links loc doc [name] (hsSigType typ)                                       subfixs splice unicode pkg qual-                           | L _ (ClassOpSig _ lnames typ) <- lsigs+                           | L _ (ClassOpSig _ _ lnames typ) <- lsigs                            , name <- map unLoc lnames                            , let doc = lookupAnySubdoc name subdocs                                  subfixs = [ f | f@(n',_) <- fixities@@ -534,15 +582,15 @@                            -- N.B. taking just the first name is ok. Signatures with multiple names                            -- are expanded so that each name gets its own signature. -    minimalBit = case [ s | MinimalSig _ (L _ s) <- sigs ] of+    minimalBit = case [ s | MinimalSig _ _ (L _ s) <- sigs ] of       -- Miminal complete definition = every shown method       And xs : _ | sort [getName n | L _ (Var (L _ n)) <- xs] ==-                   sort [getName n | TypeSig ns _ <- sigs, L _ n <- ns]+                   sort [getName n | ClassOpSig _ _ ns _ <- sigs, L _ n <- ns]         -> noHtml        -- Minimal complete definition = the only shown method       Var (L _ n) : _ | [getName n] ==-                        [getName n' | L _ (TypeSig ns _) <- lsigs, L _ n' <- ns]+                        [getName n' | L _ (ClassOpSig _ _ ns _) <- lsigs, L _ n' <- ns]         -> noHtml        -- Minimal complete definition = nothing@@ -572,9 +620,9 @@   -- force Splice = True to use line URLs   where     instName = getOccString origin-    instDecl :: Int -> DocInstance DocNameI -> (SubDecl,Located DocName)+    instDecl :: Int -> DocInstance DocNameI -> (SubDecl, Maybe Module, Located DocName)     instDecl no (inst, mdoc, loc, mdl) =-        ((ppInstHead links splice unicode qual mdoc origin False no inst mdl), loc)+        ((ppInstHead links splice unicode qual mdoc origin False no inst mdl), mdl, loc)   ppOrphanInstances :: LinksInfo@@ -587,9 +635,9 @@     instOrigin :: InstHead name -> InstOrigin (IdP name)     instOrigin inst = OriginClass (ihdClsName inst) -    instDecl :: Int -> DocInstance DocNameI -> (SubDecl,Located DocName)+    instDecl :: Int -> DocInstance DocNameI -> (SubDecl, Maybe Module, Located DocName)     instDecl no (inst, mdoc, loc, mdl) =-        ((ppInstHead links splice unicode qual mdoc (instOrigin inst) True no inst mdl), loc)+        ((ppInstHead links splice unicode qual mdoc (instOrigin inst) True no inst Nothing), mdl, loc)   ppInstHead :: LinksInfo -> Splice -> Unicode -> Qualification@@ -645,7 +693,7 @@               -> [Sig DocNameI]               -> [Html] ppInstanceSigs links splice unicode qual sigs = do-    TypeSig lnames typ <- sigs+    TypeSig _ lnames typ <- sigs     let names = map unLoc lnames         L _ rtyp = hsSigWcType typ     -- Instance methods signatures are synified and thus don't have a useful@@ -706,21 +754,27 @@     isH98     = case unLoc (head cons) of                   ConDeclH98 {} -> True                   ConDeclGADT{} -> False+                  XConDecl{}    -> False      pats1 = [ hsep [ keyword "pattern"                    , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames                    , dcolon unicode                    , ppPatSigType unicode qual (hsSigType typ)                    ]-            | (SigD (PatSynSig lnames typ),_) <- pats+            | (SigD _ (PatSynSig _ lnames typ),_) <- pats             ]  -ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocNameI] -> [(DocName, Fixity)] ->-              [(DocName, DocForDecl DocName)] ->-              SrcSpan -> Documentation DocName -> TyClDecl DocNameI ->-              [(HsDecl DocNameI, DocForDecl DocName)] ->-              Splice -> Unicode -> Maybe Package -> Qualification -> Html+-- | Pretty-print a data declaration+ppDataDecl :: Bool -> LinksInfo+           -> [DocInstance DocNameI]                  -- ^ relevant instances+           -> [(DocName, Fixity)]                     -- ^ relevant fixities+           -> [(DocName, DocForDecl DocName)]         -- ^ all decl documentation+           -> SrcSpan+           -> Documentation DocName                   -- ^ this decl's documentation+           -> TyClDecl DocNameI                       -- ^ this decl+           -> [(HsDecl DocNameI, DocForDecl DocName)] -- ^ relevant patterns+           -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats            splice unicode pkg qual @@ -733,6 +787,7 @@     isH98     = case unLoc (head cons) of                   ConDeclH98 {} -> True                   ConDeclGADT{} -> False+                  XConDecl{}    -> False      header_ = topDeclElem links loc splice [docname] $              ppDataHeader summary dataDecl unicode qual <+> whereBit <+> fix@@ -749,25 +804,20 @@       [ ppSideBySideConstr subdocs subfixs unicode pkg qual c       | c <- cons       , let subfixs = filter (\(n,_) -> any (\cn -> cn == n)-                                     (map unLoc (getConNames (unLoc c)))) fixities+                                            (map unLoc (getConNames (unLoc c)))) fixities       ]      patternBit = subPatterns pkg qual-      [ (hsep [ keyword "pattern"-              , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames-              , dcolon unicode-              , ppPatSigType unicode qual (hsSigType typ)-              ] <+> ppFixities subfixs qual-        ,combineDocumentation (fst d), [])-      | (SigD (PatSynSig lnames typ),d) <- pats-      , let subfixs = filter (\(n,_) -> any (\cn -> cn == n) (map unLoc lnames)) fixities+      [ ppSideBySidePat subfixs unicode qual lnames typ d+      | (SigD _ (PatSynSig _ lnames typ), d) <- pats+      , let subfixs = filter (\(n,_) -> any (\cn -> cn == n)+                                            (map unLoc lnames)) fixities       ]      instancesBit = ppInstances links (OriginData docname) instances         splice unicode pkg qual  - ppShortConstr :: Bool -> ConDecl DocNameI -> Unicode -> Qualification -> Html ppShortConstr summary con unicode qual = cHead <+> cBody <+> cFoot   where@@ -777,121 +827,183 @@ -- returns three pieces: header, body, footer so that header & footer can be -- incorporated into the declaration ppShortConstrParts :: Bool -> Bool -> ConDecl DocNameI -> Unicode -> Qualification -> (Html, Html, Html)-ppShortConstrParts summary dataInst con unicode qual = case con of-  ConDeclH98{} -> case con_details con of-    PrefixCon args ->-      (header_ unicode qual +++ hsep (ppOcc-            : map (ppLParendType unicode qual HideEmptyContexts) args), noHtml, noHtml)-    RecCon (L _ fields) ->-      (header_ unicode qual +++ ppOcc <+> char '{',-       doRecordFields fields,-       char '}')-    InfixCon arg1 arg2 ->-      (header_ unicode qual +++ hsep [ppLParendType unicode qual HideEmptyContexts arg1,-            ppOccInfix, ppLParendType unicode qual HideEmptyContexts arg2],-       noHtml, noHtml)+ppShortConstrParts summary dataInst con unicode qual+  = case con of+      ConDeclH98{ con_args = det+                , con_ex_tvs = vars+                , con_mb_cxt = cxt+                } -> let tyVars = map (getName . hsLTyVarName) vars+                         context = unLoc (fromMaybe (noLoc []) cxt)+                         forall_ = False+                         header_ = ppConstrHdr forall_ tyVars context unicode qual+                     in case det of -  ConDeclGADT {} -> (ppOcc <+> dcolon unicode <+> ppLType unicode qual HideEmptyContexts resTy,noHtml,noHtml)+        -- Prefix constructor, e.g. 'Just a'+        PrefixCon args ->+          ( header_ +++ hsep (ppOcc : map (ppLParendType unicode qual HideEmptyContexts) args)+          , noHtml+          , noHtml+          ) -  where-    resTy = hsib_body (con_type con)+        -- Record constructor, e.g. 'Identity { runIdentity :: a }'+        RecCon (L _ fields) ->+          ( header_ +++ ppOcc <+> char '{'+          , shortSubDecls dataInst [ ppShortField summary unicode qual field+                                   | L _ field <- fields+                                   ]+          , char '}'+          ) -    doRecordFields fields = shortSubDecls dataInst (map (ppShortField summary unicode qual) (map unLoc fields))+        -- Infix constructor, e.g. 'a :| [a]'+        InfixCon arg1 arg2 ->+          ( header_ +++ hsep [ ppLParendType unicode qual HideEmptyContexts arg1+                             , ppOccInfix+                             , ppLParendType unicode qual HideEmptyContexts arg2+                             ]+          , noHtml+          , noHtml+          ) -    header_  = ppConstrHdr forall_ tyVars context+      -- GADT constructor, e.g. 'Foo :: Int -> Foo'+      ConDeclGADT {} ->+          ( hsep [ ppOcc, dcolon unicode, ppLType unicode qual HideEmptyContexts (getGADTConType con) ]+          , noHtml+          , noHtml+          )+      XConDecl {} -> panic "haddock:ppShortConstrParts"++  where     occ        = map (nameOccName . getName . unLoc) $ getConNames con+    ppOcc      = hsep (punctuate comma (map (ppBinder summary) occ))+    ppOccInfix = hsep (punctuate comma (map (ppBinderInfix summary) occ)) -    ppOcc      = case occ of-      [one] -> ppBinder summary one-      _     -> hsep (punctuate comma (map (ppBinder summary) occ)) -    ppOccInfix = case occ of-      [one] -> ppBinderInfix summary one-      _     -> hsep (punctuate comma (map (ppBinderInfix summary) occ))+-- | Pretty print an expanded constructor+ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> [(DocName, Fixity)]+                   -> Unicode -> Maybe Package -> Qualification+                   -> LConDecl DocNameI -- ^ constructor declaration to print+                   -> SubDecl+ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con)+ = ( decl       -- Constructor header (name, fixity)+   , mbDoc      -- Docs on the whole constructor+   , fieldPart  -- Information on the fields (or arguments, if they have docs)+   )+ where+    -- Find the name of a constructors in the decl (`getConName` always returns a non-empty list)+    aConName = unLoc (head (getConNames con)) -    ltvs     = fromMaybe (HsQTvs PlaceHolder [] PlaceHolder) (con_qvars con)-    tyVars   = tyvarNames ltvs-    lcontext = fromMaybe (noLoc []) (con_cxt con)-    context  = unLoc lcontext-    forall_  = False+    fixity   = ppFixities fixities qual+    occ      = map (nameOccName . getName . unLoc) $ getConNames con +    ppOcc      = hsep (punctuate comma (map (ppBinder False) occ))+    ppOccInfix = hsep (punctuate comma (map (ppBinderInfix False) occ)) --- ppConstrHdr is for (non-GADT) existentials constructors' syntax-ppConstrHdr :: Bool -> [Name] -> HsContext DocNameI -> Unicode-            -> Qualification -> Html-ppConstrHdr forall_ tvs ctxt unicode qual- = (if null tvs then noHtml else ppForall)-   +++-   (if null ctxt then noHtml-    else ppContextNoArrow ctxt unicode qual HideEmptyContexts-         <+> darrow unicode +++ toHtml " ")-  where-    ppForall | forall_   = forallSymbol unicode <+> hsep (map (ppName Prefix) tvs)-                           <+> toHtml ". "-             | otherwise = noHtml+    -- Extract out the map of of docs corresponding to the constructors arguments+    argDocs = maybe Map.empty snd (lookup aConName subdocs)+    hasArgDocs = not $ Map.null argDocs -ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> [(DocName, Fixity)]-                   -> Unicode -> Maybe Package -> Qualification -> LConDecl DocNameI -> SubDecl-ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con)- = (decl, mbDoc, fieldPart)- where     decl = case con of-      ConDeclH98{} -> case con_details con of-        PrefixCon args ->-          hsep ((header_ +++ ppOcc)-            : map (ppLParendType unicode qual HideEmptyContexts) args)-          <+> fixity+      ConDeclH98{ con_args = det+                , con_ex_tvs = vars+                , con_mb_cxt = cxt+                } -> let tyVars = map (getName . hsLTyVarName) vars+                         context = unLoc (fromMaybe (noLoc []) cxt)+                         forall_ = False+                         header_ = ppConstrHdr forall_ tyVars context unicode qual+                     in case det of+        -- Prefix constructor, e.g. 'Just a'+        PrefixCon args+          | hasArgDocs -> header_ +++ ppOcc <+> fixity+          | otherwise -> hsep [ header_ +++ ppOcc+                              , hsep (map (ppLParendType unicode qual HideEmptyContexts) args)+                              , fixity+                              ] +        -- Record constructor, e.g. 'Identity { runIdentity :: a }'         RecCon _ -> header_ +++ ppOcc <+> fixity -        InfixCon arg1 arg2 ->-          hsep [header_ +++ ppLParendType unicode qual HideEmptyContexts arg1,-            ppOccInfix,-            ppLParendType unicode qual HideEmptyContexts arg2]-          <+> fixity+        -- Infix constructor, e.g. 'a :| [a]'+        InfixCon arg1 arg2+          | hasArgDocs -> header_ +++ ppOcc <+> fixity+          | otherwise -> hsep [ header_ +++ ppLParendType unicode qual HideEmptyContexts arg1+                              , ppOccInfix+                              , ppLParendType unicode qual HideEmptyContexts arg2+                              , fixity+                              ] -      ConDeclGADT{} -> doGADTCon resTy+      -- GADT constructor, e.g. 'Foo :: Int -> Foo'+      ConDeclGADT{}+          | hasArgDocs || not (null fieldPart) -> ppOcc <+> fixity+          | otherwise -> hsep [ ppOcc+                              , dcolon unicode+                              -- ++AZ++ make this prepend "{..}" when it is a record style GADT+                              , ppLType unicode qual HideEmptyContexts (getGADTConType con)+                              , fixity+                              ]+      XConDecl{} -> panic "haddock:ppSideBySideConstr" -    resTy = hsib_body (con_type con)+    fieldPart = case (con, getConArgs con) of+        -- Record style GADTs+        (ConDeclGADT{}, RecCon _)            -> [ doConstrArgsWithDocs [] ] -    fieldPart = case getConDetails con of-        RecCon (L _ fields) -> [doRecordFields fields]-        _ -> []+        -- Regular record declarations+        (_, RecCon (L _ fields))             -> [ doRecordFields fields ] -    doRecordFields fields = subFields pkg qual-      (map (ppSideBySideField subdocs unicode qual) (map unLoc fields))+        -- Any GADT or a regular H98 prefix data constructor+        (_, PrefixCon args)     | hasArgDocs -> [ doConstrArgsWithDocs args ] -    doGADTCon :: Located (HsType DocNameI) -> Html-    doGADTCon ty = ppOcc <+> dcolon unicode-        -- ++AZ++ make this prepend "{..}" when it is a record style GADT-        <+> ppLType unicode qual HideEmptyContexts ty-        <+> fixity+        -- An infix H98 data constructor+        (_, InfixCon arg1 arg2) | hasArgDocs -> [ doConstrArgsWithDocs [arg1,arg2] ] -    fixity  = ppFixities fixities qual-    header_ = ppConstrHdr forall_ tyVars context unicode qual-    occ       = map (nameOccName . getName . unLoc) $ getConNames con+        _ -> [] -    ppOcc     = case occ of-      [one] -> ppBinder False one-      _     -> hsep (punctuate comma (map (ppBinder False) occ))+    doRecordFields fields = subFields pkg qual+      (map (ppSideBySideField subdocs unicode qual) (map unLoc fields)) -    ppOccInfix = case occ of-      [one] -> ppBinderInfix False one-      _     -> hsep (punctuate comma (map (ppBinderInfix False) occ))+    doConstrArgsWithDocs args = subFields pkg qual $ case con of+      ConDeclH98{} ->+        [ (ppLParendType unicode qual HideEmptyContexts arg, mdoc, [])+        | (i, arg) <- zip [0..] args+        , let mdoc = Map.lookup i argDocs+        ]+      ConDeclGADT{} ->+        ppSubSigLike unicode qual (unLoc (getGADTConType con))+                     argDocs subdocs (dcolon unicode) HideEmptyContexts+      XConDecl{} -> panic "haddock:doConstrArgsWithDocs" -    tyVars  = tyvarNames (fromMaybe (HsQTvs PlaceHolder [] PlaceHolder) (con_qvars con))-    context = unLoc (fromMaybe (noLoc []) (con_cxt con))-    forall_ = False     -- don't use "con_doc con", in case it's reconstructed from a .hi file,     -- or also because we want Haddock to do the doc-parsing, not GHC.     mbDoc = lookup (unLoc $ head $ getConNames con) subdocs >>=             combineDocumentation . fst  +-- ppConstrHdr is for (non-GADT) existentials constructors' syntax+ppConstrHdr :: Bool               -- ^ print explicit foralls+            -> [Name]             -- ^ type variables+            -> HsContext DocNameI -- ^ context+            -> Unicode -> Qualification -> Html+ppConstrHdr forall_ tvs ctxt unicode qual = ppForall +++ ppCtxt+  where+    ppForall+      | null tvs || not forall_ = noHtml+      | otherwise = forallSymbol unicode+                      <+> hsep (map (ppName Prefix) tvs)+                      <+> toHtml ". "++    ppCtxt+      | null ctxt = noHtml+      | otherwise = ppContextNoArrow ctxt unicode qual HideEmptyContexts+                      <+> darrow unicode +++ toHtml " "+++-- | Pretty-print a record field ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification                   -> ConDeclField DocNameI -> SubDecl-ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) =-  ( hsep (punctuate comma (map ((ppBinder False) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names))+ppSideBySideField subdocs unicode qual (ConDeclField _ names ltype _) =+  ( hsep (punctuate comma [ ppBinder False (rdrNameOcc field)+                          | L _ name <- names+                          , let field = (unLoc . rdrNameFieldOcc) name+                          ])       <+> dcolon unicode       <+> ppLType unicode qual HideEmptyContexts ltype   , mbDoc@@ -900,15 +1012,51 @@   where     -- don't use cd_fld_doc for same reason we don't use con_doc above     -- Where there is more than one name, they all have the same documentation-    mbDoc = lookup (selectorFieldOcc $ unLoc $ head names) subdocs >>= combineDocumentation . fst+    mbDoc = lookup (extFieldOcc $ unLoc $ head names) subdocs >>= combineDocumentation . fst+ppSideBySideField _ _ _ (XConDeclField _) = panic "haddock:ppSideBySideField"   ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocNameI -> Html-ppShortField summary unicode qual (ConDeclField names ltype _)+ppShortField summary unicode qual (ConDeclField _ names ltype _)   = hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names))     <+> dcolon unicode <+> ppLType unicode qual HideEmptyContexts ltype+ppShortField _ _ _ (XConDeclField _) = panic "haddock:ppShortField"  +-- | Pretty print an expanded pattern (for bundled patterns)+ppSideBySidePat :: [(DocName, Fixity)] -> Unicode -> Qualification+                   -> [Located DocName]    -- ^ pattern name(s)+                   -> LHsSigType DocNameI  -- ^ type of pattern(s)+                   -> DocForDecl DocName   -- ^ doc map+                   -> SubDecl+ppSideBySidePat fixities unicode qual lnames typ (doc, argDocs) =+  ( decl+  , combineDocumentation doc+  , fieldPart+  )+  where+    hasArgDocs = not $ Map.null argDocs+    fixity = ppFixities fixities qual+    ppOcc = hsep (punctuate comma (map (ppBinder False . getOccName) lnames))++    decl | hasArgDocs = keyword "pattern" <+> ppOcc <+> fixity+         | otherwise = hsep [ keyword "pattern"+                            , ppOcc+                            , dcolon unicode+                            , ppPatSigType unicode qual (hsSigType typ)+                            , fixity+                            ]++    fieldPart+      | not hasArgDocs = []+      | otherwise = [ subFields Nothing qual (ppSubSigLike unicode qual (unLoc patTy)+                                                        argDocs [] (dcolon unicode)+                                                        emptyCtxt) ]++    patTy = hsSigType typ+    emptyCtxt = patSigContext patTy++ -- | Print the LHS of a data\/newtype declaration. -- Currently doesn't handle 'data instance' decls or kind signatures ppDataHeader :: Bool -> TyClDecl DocNameI -> Unicode -> Qualification -> Html@@ -953,129 +1101,112 @@ -- * Rendering of HsType -------------------------------------------------------------------------------- --pREC_TOP, pREC_CTX, pREC_FUN, pREC_OP, pREC_CON :: Int--pREC_TOP = 0 :: Int   -- type in ParseIface.y in GHC-pREC_CTX = 1 :: Int   -- Used for single contexts, eg. ctx => type-                      -- (as opposed to (ctx1, ctx2) => type)-pREC_FUN = 2 :: Int   -- btype in ParseIface.y in GHC-                      -- Used for LH arg of (->)-pREC_OP  = 3 :: Int   -- Used for arg of any infix operator-                      -- (we don't keep their fixities around)-pREC_CON = 4 :: Int   -- Used for arg of type applicn:-                      -- always parenthesise unless atomic--maybeParen :: Int           -- Precedence of context-           -> Int           -- Precedence of top-level operator-           -> Html -> Html  -- Wrap in parens if (ctxt >= op)-maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p-                               | otherwise            = p-- ppLType, ppLParendType, ppLFunLhType :: Unicode -> Qualification -> HideEmptyContexts -> Located (HsType DocNameI) -> Html ppLType       unicode qual emptyCtxts y = ppType unicode qual emptyCtxts (unLoc y) ppLParendType unicode qual emptyCtxts y = ppParendType unicode qual emptyCtxts (unLoc y) ppLFunLhType  unicode qual emptyCtxts y = ppFunLhType unicode qual emptyCtxts (unLoc y)  ppCtxType :: Unicode -> Qualification -> HsType DocNameI -> Html-ppCtxType unicode qual ty = ppr_mono_ty pREC_CTX ty unicode qual HideEmptyContexts+ppCtxType unicode qual ty = ppr_mono_ty (reparenTypePrec PREC_CTX ty) unicode qual HideEmptyContexts  ppType, ppParendType, ppFunLhType :: Unicode -> Qualification -> HideEmptyContexts -> HsType DocNameI -> Html-ppType       unicode qual emptyCtxts ty = ppr_mono_ty pREC_TOP ty unicode qual emptyCtxts-ppParendType unicode qual emptyCtxts ty = ppr_mono_ty pREC_CON ty unicode qual emptyCtxts-ppFunLhType  unicode qual emptyCtxts ty = ppr_mono_ty pREC_FUN ty unicode qual emptyCtxts+ppType       unicode qual emptyCtxts ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode qual emptyCtxts+ppParendType unicode qual emptyCtxts ty = ppr_mono_ty (reparenTypePrec PREC_CON ty) unicode qual emptyCtxts+ppFunLhType  unicode qual emptyCtxts ty = ppr_mono_ty (reparenTypePrec PREC_FUN ty) unicode qual emptyCtxts  ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr DocNameI -> Html-ppHsTyVarBndr _       qual (UserTyVar (L _ name)) =+ppHsTyVarBndr _       qual (UserTyVar _ (L _ name)) =     ppDocName qual Raw False name-ppHsTyVarBndr unicode qual (KindedTyVar name kind) =+ppHsTyVarBndr unicode qual (KindedTyVar _ name kind) =     parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+>             ppLKind unicode qual kind)+ppHsTyVarBndr _ _ (XTyVarBndr _) = error "haddock:ppHsTyVarBndr"  ppLKind :: Unicode -> Qualification -> LHsKind DocNameI -> Html ppLKind unicode qual y = ppKind unicode qual (unLoc y)  ppKind :: Unicode -> Qualification -> HsKind DocNameI -> Html-ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual HideEmptyContexts+ppKind unicode qual ki = ppr_mono_ty (reparenTypePrec PREC_TOP ki) unicode qual HideEmptyContexts -ppPatSigType :: Unicode -> Qualification -> LHsType DocNameI -> Html-ppPatSigType unicode qual typ =-  let emptyCtxts =-        if hasNonEmptyContext typ && isFirstContextEmpty typ-          then ShowEmptyToplevelContexts-          else HideEmptyContexts-  in ppLType unicode qual emptyCtxts typ+patSigContext :: LHsType name -> HideEmptyContexts+patSigContext typ | hasNonEmptyContext typ && isFirstContextEmpty typ =  ShowEmptyToplevelContexts+                  | otherwise = HideEmptyContexts   where     hasNonEmptyContext :: LHsType name -> Bool     hasNonEmptyContext t =       case unLoc t of-        HsForAllTy _ s -> hasNonEmptyContext s-        HsQualTy cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True-        HsFunTy _ s -> hasNonEmptyContext s+        HsForAllTy _ _ s -> hasNonEmptyContext s+        HsQualTy _ cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True+        HsFunTy _ _ s    -> hasNonEmptyContext s         _ -> False     isFirstContextEmpty :: LHsType name -> Bool     isFirstContextEmpty t =       case unLoc t of-        HsForAllTy _ s -> isFirstContextEmpty s-        HsQualTy cxt _ -> null (unLoc cxt)-        HsFunTy _ s -> isFirstContextEmpty s+        HsForAllTy _ _ s -> isFirstContextEmpty s+        HsQualTy _ cxt _ -> null (unLoc cxt)+        HsFunTy _ _ s    -> isFirstContextEmpty s         _ -> False ++-- | Pretty-print a pattern signature (all this does over 'ppLType' is slot in+-- the right 'HideEmptyContext' value)+ppPatSigType :: Unicode -> Qualification -> LHsType DocNameI -> Html+ppPatSigType unicode qual typ =+  let emptyCtxts = patSigContext typ in ppLType unicode qual emptyCtxts typ+ ppForAllPart :: Unicode -> Qualification -> [LHsTyVarBndr DocNameI] -> Html ppForAllPart unicode qual tvs = hsep (forallSymbol unicode : ppTyVars unicode qual tvs) +++ dot -ppr_mono_lty :: Int -> LHsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html-ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty)+ppr_mono_lty :: LHsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html+ppr_mono_lty ty = ppr_mono_ty (unLoc ty)  -ppr_mono_ty :: Int -> HsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html-ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode qual emptyCtxts-  = maybeParen ctxt_prec pREC_FUN $-    ppForAllPart unicode qual tvs <+> ppr_mono_lty pREC_TOP ty unicode qual emptyCtxts+ppr_mono_ty :: HsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html+ppr_mono_ty (HsForAllTy _ tvs ty) unicode qual emptyCtxts+  = ppForAllPart unicode qual tvs <+> ppr_mono_lty ty unicode qual emptyCtxts -ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode qual emptyCtxts-  = maybeParen ctxt_prec pREC_FUN $-    ppLContext ctxt unicode qual emptyCtxts <+> ppr_mono_lty pREC_TOP ty unicode qual emptyCtxts+ppr_mono_ty (HsQualTy _ ctxt ty) unicode qual emptyCtxts+  = ppLContext ctxt unicode qual emptyCtxts <+> ppr_mono_lty ty unicode qual emptyCtxts  -- UnicodeSyntax alternatives-ppr_mono_ty _ (HsTyVar _ (L _ name)) True _ _-  | getOccString (getName name) == "*"    = toHtml "★"+ppr_mono_ty (HsTyVar _ _ (L _ name)) True _ _   | getOccString (getName name) == "(->)" = toHtml "(→)" -ppr_mono_ty _         (HsBangTy b ty)     u q _ = ppBang b +++ ppLParendType u q HideEmptyContexts ty-ppr_mono_ty _         (HsTyVar _ (L _ name)) _ q _ = ppDocName q Prefix True name-ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2)   u q e = ppr_fun_ty ctxt_prec ty1 ty2 u q e-ppr_mono_ty _         (HsTupleTy con tys) u q _ = tupleParens con (map (ppLType u q HideEmptyContexts) tys)-ppr_mono_ty _         (HsSumTy tys) u q _ = sumParens (map (ppLType u q HideEmptyContexts) tys)-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"-ppr_mono_ty _         (HsRecTy {})        _ _ _ = toHtml "{..}"+ppr_mono_ty (HsBangTy _ b ty) u q _ =+  ppBang b +++ ppLParendType u q HideEmptyContexts ty+ppr_mono_ty (HsTyVar _ _ (L _ name)) _ q _ =+  ppDocName q Prefix True name+ppr_mono_ty (HsStarTy _ isUni) u _ _ =+  toHtml (if u || isUni then "★" else "*")+ppr_mono_ty (HsFunTy _ ty1 ty2) u q e =+  hsep [ ppr_mono_lty ty1 u q HideEmptyContexts+       , arrow u <+> ppr_mono_lty ty2 u q e+       ]+ppr_mono_ty (HsTupleTy _ con tys) u q _ =+  tupleParens con (map (ppLType u q HideEmptyContexts) tys)+ppr_mono_ty (HsSumTy _ tys) u q _ =+  sumParens (map (ppLType u q HideEmptyContexts) tys)+ppr_mono_ty (HsKindSig _ ty kind) u q e =+  parens (ppr_mono_lty ty u q e <+> dcolon u <+> ppLKind u q kind)+ppr_mono_ty (HsListTy _ ty)       u q _ = brackets (ppr_mono_lty ty u q HideEmptyContexts)+ppr_mono_ty (HsIParamTy _ (L _ n) ty) u q _ =+  ppIPName n <+> dcolon u <+> ppr_mono_lty ty u q HideEmptyContexts+ppr_mono_ty (HsSpliceTy {})     _ _ _ = error "ppr_mono_ty HsSpliceTy"+ppr_mono_ty (HsRecTy {})        _ _ _ = toHtml "{..}"        -- Can now legally occur in ConDeclGADT, the output here is to provide a        -- placeholder in the signature, which is followed by the field        -- declarations.-ppr_mono_ty _         (HsCoreTy {})       _ _ _ = error "ppr_mono_ty HsCoreTy"-ppr_mono_ty _         (HsExplicitListTy Promoted _ tys) u q _ = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys-ppr_mono_ty _         (HsExplicitListTy NotPromoted _ tys) u q _ = brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys-ppr_mono_ty _         (HsExplicitTupleTy _ tys) u q _ = promoQuote $ parenList $ map (ppLType u q HideEmptyContexts) tys-ppr_mono_ty _         (HsAppsTy {})       _ _ _ = error "ppr_mono_ty HsAppsTy"--ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode qual _-  = maybeParen ctxt_prec pREC_CTX $-    ppr_mono_lty pREC_OP ty1 unicode qual HideEmptyContexts <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode qual HideEmptyContexts+ppr_mono_ty (XHsType (NHsCoreTy {})) _ _ _ = error "ppr_mono_ty HsCoreTy"+ppr_mono_ty (HsExplicitListTy _ Promoted tys) u q _ = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys+ppr_mono_ty (HsExplicitListTy _ NotPromoted tys) u q _ = brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys+ppr_mono_ty (HsExplicitTupleTy _ tys) u q _ = promoQuote $ parenList $ map (ppLType u q HideEmptyContexts) tys -ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode qual _-  = maybeParen ctxt_prec pREC_CON $-    hsep [ppr_mono_lty pREC_FUN fun_ty unicode qual HideEmptyContexts, ppr_mono_lty pREC_CON arg_ty unicode qual HideEmptyContexts]+ppr_mono_ty (HsAppTy _ fun_ty arg_ty) unicode qual _+  = hsep [ ppr_mono_lty fun_ty unicode qual HideEmptyContexts+         , ppr_mono_lty arg_ty unicode qual HideEmptyContexts ] -ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode qual _-  = maybeParen ctxt_prec pREC_FUN $-    ppr_mono_lty pREC_OP ty1 unicode qual HideEmptyContexts <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual HideEmptyContexts+ppr_mono_ty (HsOpTy _ ty1 op ty2) unicode qual _+  = ppr_mono_lty ty1 unicode qual HideEmptyContexts <+> ppr_op <+> ppr_mono_lty ty2 unicode qual HideEmptyContexts   where     -- `(:)` is valid in type signature only as constructor to promoted list     -- and needs to be quoted in code so we explicitly quote it here too.@@ -1084,24 +1215,17 @@         | otherwise = ppr_op'     ppr_op' = ppLDocName qual Infix op -ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual emptyCtxts---  = parens (ppr_mono_lty pREC_TOP ty)-  = ppr_mono_lty ctxt_prec ty unicode qual emptyCtxts+ppr_mono_ty (HsParTy _ ty) unicode qual emptyCtxts+  = parens (ppr_mono_lty ty unicode qual emptyCtxts)+--  = parens (ppr_mono_lty ctxt_prec ty unicode qual emptyCtxts) -ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual emptyCtxts-  = ppr_mono_lty ctxt_prec ty unicode qual emptyCtxts+ppr_mono_ty (HsDocTy _ ty _) unicode qual emptyCtxts+  = ppr_mono_lty ty unicode qual emptyCtxts -ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ _ _ = char '_'-ppr_mono_ty _ (HsTyLit n) _ _ _ = ppr_tylit n+ppr_mono_ty (HsWildCardTy (AnonWildCard _)) _ _ _ = char '_'+ppr_mono_ty (HsTyLit _ n) _ _ _ = ppr_tylit n  ppr_tylit :: HsTyLit -> Html ppr_tylit (HsNumTy _ n) = toHtml (show n) ppr_tylit (HsStrTy _ s) = toHtml (show s) -ppr_fun_ty :: Int -> LHsType DocNameI -> LHsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html-ppr_fun_ty ctxt_prec ty1 ty2 unicode qual emptyCtxts-  = let p1 = ppr_mono_lty pREC_FUN ty1 unicode qual HideEmptyContexts-        p2 = ppr_mono_lty pREC_TOP ty2 unicode qual emptyCtxts-    in-    maybeParen ctxt_prec pREC_FUN $-    hsep [p1, arrow unicode <+> p2]
haddock-api/src/Haddock/Backends/Xhtml/Layout.hs view
@@ -40,7 +40,6 @@   topDeclElem, declElem, ) where - import Haddock.Backends.Xhtml.DocMarkup import Haddock.Backends.Xhtml.Types import Haddock.Backends.Xhtml.Utils@@ -48,6 +47,7 @@ import Haddock.Utils (makeAnchorId, nameAnchorId) import qualified Data.Map as Map import Text.XHtml hiding ( name, title, quote )+import Data.Maybe (fromMaybe)  import FastString            ( unpackFS ) import GHC@@ -151,21 +151,23 @@  -- | Sub table with source information (optional). subTableSrc :: Maybe Package -> Qualification -> LinksInfo -> Bool-            -> [(SubDecl,Located DocName)] -> Maybe Html+            -> [(SubDecl, Maybe Module, Located DocName)] -> Maybe Html subTableSrc _ _ _ _ [] = Nothing subTableSrc pkg qual lnks splice decls = Just $ table << aboves (concatMap subRow decls)   where-    subRow ((decl, mdoc, subs),L loc dn) =+    subRow ((decl, mdoc, subs), mdl, L loc dn) =       (td ! [theclass "src clearfix"] <<         (thespan ! [theclass "inst-left"] << decl)-        <+> linkHtml loc dn+        <+> linkHtml loc mdl dn       <->       docElement td << fmap (docToHtml Nothing pkg qual) mdoc       )       : map (cell . (td <<)) subs-    linkHtml loc@(RealSrcSpan _) dn = links lnks loc splice dn-    linkHtml _ _ = noHtml +    linkHtml :: SrcSpan -> Maybe Module -> DocName -> Html+    linkHtml loc@(RealSrcSpan _) mdl dn = links lnks loc splice mdl dn+    linkHtml _ _ _ = noHtml+ subBlock :: [Html] -> Maybe Html subBlock [] = Nothing subBlock hs = Just $ toHtml hs@@ -197,7 +199,7 @@ subInstances :: Maybe Package -> Qualification              -> String -- ^ Class name, used for anchor generation              -> LinksInfo -> Bool-             -> [(SubDecl,Located DocName)] -> Html+             -> [(SubDecl, Maybe Module, Located DocName)] -> Html subInstances pkg qual nm lnks splice = maybe noHtml wrap . instTable   where     wrap contents = subSection (collapseDetails id_ DetailsOpen (summary +++ contents))@@ -209,7 +211,7 @@  subOrphanInstances :: Maybe Package -> Qualification                    -> LinksInfo -> Bool-                   -> [(SubDecl,Located DocName)] -> Html+                   -> [(SubDecl, Maybe Module, Located DocName)] -> Html subOrphanInstances pkg qual lnks splice  = maybe noHtml wrap . instTable   where     wrap = ((h1 << "Orphan instances") +++)@@ -268,13 +270,13 @@ -- it adds a source and wiki link at the right hand side of the box topDeclElem :: LinksInfo -> SrcSpan -> Bool -> [DocName] -> Html -> Html topDeclElem lnks loc splice names html =-    declElem << (html <+> (links lnks loc splice $ head names))+    declElem << (html <+> (links lnks loc splice Nothing $ head names))         -- FIXME: is it ok to simply take the first name?  -- | Adds a source and wiki link at the right hand side of the box. -- Name must be documented, otherwise we wouldn't get here.-links :: LinksInfo -> SrcSpan -> Bool -> DocName -> Html-links ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice docName@(Documented n mdl) =+links :: LinksInfo -> SrcSpan -> Bool -> Maybe Module -> DocName -> Html+links ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice mdl' docName@(Documented n mdl) =   srcLink <+> wikiLink <+> (selfLink ! [theclass "selflink"] << "#")   where selfLink = linkedAnchor (nameAnchorId (nameOccName (getName docName))) @@ -298,12 +300,13 @@          -- For source links, we want to point to the original module,         -- because only that will have the source.-        -- TODO: do something about type instances. They will point to-        -- the module defining the type family, which is wrong.-        origMod = nameModule n+        --+        -- 'mdl'' is a way of "overriding" the module. Without it, instances+        -- will point to the module defining the class/family, which is wrong.+        origMod = fromMaybe (nameModule n) mdl'         origPkg = moduleUnitId origMod          fname = case loc of           RealSrcSpan l -> unpackFS (srcSpanFile l)           UnhelpfulSpan _ -> error "links: UnhelpfulSpan"-links _ _ _ _ = noHtml+links _ _ _ _ _ = noHtml
haddock-api/src/Haddock/Backends/Xhtml/Utils.hs view
@@ -110,7 +110,7 @@  hsep :: [Html] -> Html hsep [] = noHtml-hsep htmls = foldr1 (\a b -> a+++" "+++b) htmls+hsep htmls = foldr1 (<+>) htmls  -- | Concatenate a series of 'Html' values vertically, with linebreaks in between. vcat :: [Html] -> Html
haddock-api/src/Haddock/Convert.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, PatternGuards #-}+{-# LANGUAGE CPP, PatternGuards, TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module      :  Haddock.Convert@@ -31,13 +31,13 @@ import RdrName ( mkVarUnqual ) import PatSyn import SrcLoc ( Located, noLoc, unLoc, GenLocated(..), srcLocSpan )-import TcType ( tcSplitSigmaTy )+import TcType import TyCon import Type import TyCoRep import TysPrim ( alphaTyVars )-import TysWiredIn ( listTyConName, starKindTyConName, unitTy )-import PrelNames ( hasKey, eqTyConKey, ipClassKey+import TysWiredIn ( listTyConName, liftedTypeKindTyConName, unitTy )+import PrelNames ( hasKey, eqTyConKey, eqTyConName, ipClassKey                  , tYPETyConKey, liftedRepDataConKey ) import Unique ( getUnique ) import Util ( chkAppend, compareLength, dropList, filterByList, filterOut@@ -61,14 +61,14 @@   -- in a future code version we could turn idVarDetails = foreign-call   -- into a ForD instead of a SigD if we wanted.  Haddock doesn't   -- need to care.-  AnId i -> allOK $ SigD (synifyIdSig ImplicitizeForAll i)+  AnId i -> allOK $ SigD noExt (synifyIdSig ImplicitizeForAll i)    -- type-constructors (e.g. Maybe) are complicated, put the definition   -- later in the file (also it's used for class associated-types too.)   ATyCon tc     | Just cl <- tyConClass_maybe tc -- classes are just a little tedious     -> let extractFamilyDecl :: TyClDecl a -> Either ErrMsg (LFamilyDecl a)-           extractFamilyDecl (FamDecl d) = return $ noLoc d+           extractFamilyDecl (FamDecl _ d) = return $ noLoc d            extractFamilyDecl _           =              Left "tyThingToLHsDecl: impossible associated tycon" @@ -76,7 +76,7 @@            atFamDecls  = map extractFamilyDecl (rights atTyClDecls)            tyClErrors = lefts atTyClDecls            famDeclErrors = lefts atFamDecls-       in withErrs (tyClErrors ++ famDeclErrors) . TyClD $ ClassDecl+       in withErrs (tyClErrors ++ famDeclErrors) . TyClD noExt $ ClassDecl          { tcdCtxt = synifyCtx (classSCTheta cl)          , tcdLName = synifyName cl          , tcdTyVars = synifyTyVars (tyConVisibleTyVars (classTyCon cl))@@ -84,7 +84,7 @@          , tcdFDs = map (\ (l,r) -> noLoc                         (map (noLoc . getName) l, map (noLoc . getName) r) ) $                          snd $ classTvsFds cl-         , tcdSigs = noLoc (MinimalSig NoSourceText . noLoc . fmap noLoc $ classMinimalDef cl) :+         , tcdSigs = noLoc (MinimalSig noExt NoSourceText . noLoc . fmap noLoc $ classMinimalDef cl) :                       map (noLoc . synifyTcIdSig DeleteTopLevelQuantification)                         (classMethods cl)          , tcdMeths = emptyBag --ignore default method definitions, they don't affect signature@@ -92,20 +92,20 @@          , tcdATs = rights atFamDecls          , tcdATDefs = [] --ignore associated type defaults          , tcdDocs = [] --we don't have any docs at this point-         , tcdFVs = placeHolderNamesTc }+         , tcdCExt = placeHolderNamesTc }     | otherwise-    -> synifyTyCon Nothing tc >>= allOK . TyClD+    -> synifyTyCon Nothing tc >>= allOK . TyClD noExt    -- type-constructors (e.g. Maybe) are complicated, put the definition   -- later in the file (also it's used for class associated-types too.)   ACoAxiom ax -> synifyAxiom ax >>= allOK    -- a data-constructor alone just gets rendered as a function:-  AConLike (RealDataCon dc) -> allOK $ SigD (TypeSig [synifyName dc]+  AConLike (RealDataCon dc) -> allOK $ SigD noExt (TypeSig noExt [synifyName dc]     (synifySigWcType ImplicitizeForAll (dataConUserType dc)))    AConLike (PatSynCon ps) ->-    allOK . SigD $ PatSynSig [synifyName ps] (synifyPatSynSigType ps)+    allOK . SigD noExt $ PatSynSig noExt [synifyName ps] (synifyPatSynSigType ps)   where     withErrs e x = return (e, x)     allOK x = return (mempty, x)@@ -118,9 +118,10 @@         annot_typats    = zipWith3 annotHsType (mkIsPolyTvs fam_tvs)                                    args_types_only typats         hs_rhs          = synifyType WithinType rhs-    in HsIB { hsib_vars   = map tyVarName tkvs-            , hsib_closed = True-            , hsib_body   = FamEqn { feqn_tycon  = name+    in HsIB { hsib_ext = HsIBRn { hsib_vars   = map tyVarName tkvs+                                , hsib_closed = True }+            , hsib_body   = FamEqn { feqn_ext    = noExt+                                   , feqn_tycon  = name                                    , feqn_pats   = annot_typats                                    , feqn_fixity = Prefix                                    , feqn_rhs    = hs_rhs } }@@ -131,13 +132,13 @@ synifyAxiom ax@(CoAxiom { co_ax_tc = tc })   | isOpenTypeFamilyTyCon tc   , Just branch <- coAxiomSingleBranch_maybe ax-  = return $ InstD-           $ TyFamInstD+  = return $ InstD noExt+           $ TyFamInstD noExt            $ TyFamInstDecl { tfid_eqn = synifyAxBranch tc branch }    | Just ax' <- isClosedSynFamilyTyConWithAxiom_maybe tc   , getUnique ax' == getUnique ax   -- without the getUniques, type error-  = synifyTyCon (Just ax) tc >>= return . TyClD+  = synifyTyCon (Just ax) tc >>= return . TyClD noExt    | otherwise   = Left "synifyAxiom: closed/open family confusion"@@ -150,25 +151,27 @@     DataDecl { tcdLName = synifyName tc              , tcdTyVars =       -- tyConTyVars doesn't work on fun/prim, but we can make them up:                          let mk_hs_tv realKind fakeTyVar-                                = noLoc $ KindedTyVar (noLoc (getName fakeTyVar))+                                = noLoc $ KindedTyVar noExt (noLoc (getName fakeTyVar))                                                       (synifyKindSig realKind)-                         in HsQTvs { hsq_implicit = []   -- No kind polymorphism+                         in HsQTvs { hsq_ext =+                                       HsQTvsRn { hsq_implicit = []   -- No kind polymorphism+                                                , hsq_dependent = emptyNameSet }                                    , hsq_explicit = zipWith mk_hs_tv (fst (splitFunTys (tyConKind tc)))                                                                 alphaTyVars --a, b, c... which are unfortunately all kind *-                                   , hsq_dependent = emptyNameSet }+                                   }             , tcdFixity = Prefix -           , tcdDataDefn = HsDataDefn { dd_ND = DataType  -- arbitrary lie, they are neither+           , tcdDataDefn = HsDataDefn { dd_ext = noExt+                                      , dd_ND = DataType  -- arbitrary lie, they are neither                                                     -- algebraic data nor newtype:                                       , dd_ctxt = noLoc []                                       , dd_cType = Nothing-                                      , dd_kindSig = synifyDataTyConReturnKind tc+                                      , dd_kindSig = Just (synifyKindSig (tyConKind tc))                                                -- we have their kind accurately:                                       , dd_cons = []  -- No constructors                                       , dd_derivs = noLoc [] }-           , tcdDataCusk = False-           , tcdFVs = placeHolderNamesTc }+           , tcdDExt = DataDeclRn False placeHolderNamesTc }  synifyTyCon _coax tc   | Just flav <- famTyConFlav_maybe tc@@ -189,8 +192,9 @@         -> mkFamDecl DataFamily   where     resultVar = famTcResVar tc-    mkFamDecl i = return $ FamDecl $-      FamilyDecl { fdInfo = i+    mkFamDecl i = return $ FamDecl noExt $+      FamilyDecl { fdExt = noExt+                 , fdInfo = i                  , fdLName = synifyName tc                  , fdTyVars = synifyTyVars (tyConVisibleTyVars tc)                  , fdFixity = Prefix@@ -203,11 +207,11 @@  synifyTyCon coax tc   | Just ty <- synTyConRhs_maybe tc-  = return $ SynDecl { tcdLName = synifyName tc+  = return $ SynDecl { tcdSExt   = emptyNameSet+                     , tcdLName  = synifyName tc                      , tcdTyVars = synifyTyVars (tyConVisibleTyVars tc)                      , tcdFixity = Prefix-                     , tcdRhs = synifyType WithinType ty-                     , tcdFVs = placeHolderNamesTc }+                     , tcdRhs = synifyType WithinType ty }   | otherwise =   -- (closed) newtype and data   let@@ -240,7 +244,8 @@   cons = rights consRaw   -- "deriving" doesn't affect the signature, no need to specify any.   alg_deriv = noLoc []-  defn = HsDataDefn { dd_ND      = alg_nd+  defn = HsDataDefn { dd_ext     = noExt+                    , dd_ND      = alg_nd                     , dd_ctxt    = alg_ctx                     , dd_cType   = Nothing                     , dd_kindSig = kindSig@@ -250,7 +255,7 @@   [] -> return $         DataDecl { tcdLName = name, tcdTyVars = tyvars, tcdFixity = Prefix                  , tcdDataDefn = defn-                 , tcdDataCusk = False, tcdFVs = placeHolderNamesTc }+                 , tcdDExt = DataDeclRn False placeHolderNamesTc }   dataConErrs -> Left $ unlines dataConErrs  -- In this module, every TyCon being considered has come from an interface@@ -284,9 +289,9 @@  synifyFamilyResultSig :: Maybe Name -> Kind -> LFamilyResultSig GhcRn synifyFamilyResultSig  Nothing    kind =-   noLoc $ KindSig  (synifyKindSig kind)+   noLoc $ KindSig  noExt (synifyKindSig kind) synifyFamilyResultSig (Just name) kind =-   noLoc $ TyVarSig (noLoc $ KindedTyVar (noLoc name) (synifyKindSig kind))+   noLoc $ TyVarSig noExt (noLoc $ KindedTyVar noExt (noLoc name) (synifyKindSig kind))  -- User beware: it is your responsibility to pass True (use_gadt_syntax) -- for any constructor that would be misrepresented by omitting its@@ -304,10 +309,6 @@   -- con_qvars means a different thing depending on gadt-syntax   (univ_tvs, ex_tvs, _eq_spec, theta, arg_tys, res_ty) = dataConFullSig dc -  qvars = if use_gadt_syntax-          then synifyTyVars (univ_tvs ++ ex_tvs)-          else synifyTyVars ex_tvs-   -- skip any EqTheta, use 'orig'inal syntax   ctx = synifyCtx theta @@ -316,12 +317,12 @@                let tySyn = synifyType WithinType ty                in case bang of                     (HsSrcBang _ NoSrcUnpack NoSrcStrict) -> tySyn-                    bang' -> noLoc $ HsBangTy bang' tySyn)+                    bang' -> noLoc $ HsBangTy noExt bang' tySyn)             arg_tys (dataConSrcBangs dc)    field_tys = zipWith con_decl_field (dataConFieldLabels dc) linear_tys   con_decl_field fl synTy = noLoc $-    ConDeclField [noLoc $ FieldOcc (noLoc $ mkVarUnqual $ flLabel fl) (flSelector fl)] synTy+    ConDeclField noExt [noLoc $ FieldOcc (flSelector fl) (noLoc $ mkVarUnqual $ flLabel fl)] synTy                  Nothing   hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of           (True,True) -> Left "synifyDataCon: contradiction!"@@ -330,45 +331,51 @@           (False,True) -> case linear_tys of                            [a,b] -> return $ InfixCon a b                            _ -> Left "synifyDataCon: infix with non-2 args?"-  gadt_ty = HsIB [] (synifyType WithinType res_ty) False  -- finally we get synifyDataCon's result!  in hs_arg_tys >>=       \hat ->         if use_gadt_syntax            then return $ noLoc $-              ConDeclGADT { con_names = [name]-                          , con_type = gadt_ty-                          , con_doc =  Nothing }+              ConDeclGADT { con_g_ext  = noExt+                          , con_names  = [name]+                          , con_forall = noLoc True+                          , con_qvars  = synifyTyVars (univ_tvs ++ ex_tvs)+                          , con_mb_cxt = Just ctx+                          , con_args   =  hat+                          , con_res_ty = synifyType WithinType res_ty+                          , con_doc    =  Nothing }            else return $ noLoc $-              ConDeclH98 { con_name = name-                         , con_qvars = Just qvars-                         , con_cxt   = Just ctx-                         , con_details =  hat-                         , con_doc =  Nothing }+              ConDeclH98 { con_ext    = noExt+                         , con_name   = name+                         , con_forall = noLoc True+                         , con_ex_tvs = map synifyTyVar ex_tvs+                         , con_mb_cxt = Just ctx+                         , con_args   = hat+                         , con_doc    = Nothing }  synifyName :: NamedThing n => n -> Located Name synifyName n = L (srcLocSpan (getSrcLoc n)) (getName n)   synifyIdSig :: SynifyTypeState -> Id -> Sig GhcRn-synifyIdSig s i = TypeSig [synifyName i] (synifySigWcType s (varType i))+synifyIdSig s i = TypeSig noExt [synifyName i] (synifySigWcType s (varType i))  synifyTcIdSig :: SynifyTypeState -> Id -> Sig GhcRn-synifyTcIdSig s i = ClassOpSig False [synifyName i] (synifySigType s (varType i))+synifyTcIdSig s i = ClassOpSig noExt False [synifyName i] (synifySigType s (varType i))  synifyCtx :: [PredType] -> LHsContext GhcRn synifyCtx = noLoc . map (synifyType WithinType)   synifyTyVars :: [TyVar] -> LHsQTyVars GhcRn-synifyTyVars ktvs = HsQTvs { hsq_implicit = []-                           , hsq_explicit = map synifyTyVar ktvs-                           , hsq_dependent = emptyNameSet }+synifyTyVars ktvs = HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = []+                                                , hsq_dependent = emptyNameSet }+                           , hsq_explicit = map synifyTyVar ktvs }  synifyTyVar :: TyVar -> LHsTyVarBndr GhcRn synifyTyVar tv-  | isLiftedTypeKind kind = noLoc (UserTyVar (noLoc name))-  | otherwise             = noLoc (KindedTyVar (noLoc name) (synifyKindSig kind))+  | isLiftedTypeKind kind = noLoc (UserTyVar noExt (noLoc name))+  | otherwise             = noLoc (KindedTyVar noExt (noLoc name) (synifyKindSig kind))   where     kind = tyVarKind tv     name = getName tv@@ -385,7 +392,7 @@   | not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType ty   = let ki    = typeKind ty         hs_ki = synifyType WithinType ki-    in noLoc (HsKindSig hs_ty hs_ki)+    in noLoc (HsKindSig noExt hs_ty hs_ki) annotHsType _    _ hs_ty = hs_ty  -- | For every type variable in the input,@@ -430,7 +437,7 @@ synifyPatSynSigType ps = mkEmptyImplicitBndrs (synifyPatSynType ps)  synifyType :: SynifyTypeState -> Type -> LHsType GhcRn-synifyType _ (TyVarTy tv) = noLoc $ HsTyVar NotPromoted $ noLoc (getName tv)+synifyType _ (TyVarTy tv) = noLoc $ HsTyVar noExt NotPromoted $ noLoc (getName tv) synifyType _ (TyConApp tc tys)   = maybe_sig res_ty   where@@ -440,41 +447,46 @@       | tc `hasKey` tYPETyConKey       , [TyConApp lev []] <- tys       , lev `hasKey` liftedRepDataConKey-      = noLoc (HsTyVar NotPromoted (noLoc starKindTyConName))+      = noLoc (HsTyVar noExt NotPromoted (noLoc liftedTypeKindTyConName))       -- Use non-prefix tuple syntax where possible, because it looks nicer.       | Just sort <- tyConTuple_maybe tc       , tyConArity tc == length tys-      = noLoc $ HsTupleTy (case sort of+      = noLoc $ HsTupleTy noExt+                          (case sort of                               BoxedTuple      -> HsBoxedTuple                               ConstraintTuple -> HsConstraintTuple                               UnboxedTuple    -> HsUnboxedTuple)                            (map (synifyType WithinType) vis_tys)       -- ditto for lists       | getName tc == listTyConName, [ty] <- tys =-         noLoc $ HsListTy (synifyType WithinType ty)+         noLoc $ HsListTy noExt (synifyType WithinType ty)       -- ditto for implicit parameter tycons       | tc `hasKey` ipClassKey       , [name, ty] <- tys       , Just x <- isStrLitTy name-      = noLoc $ HsIParamTy (noLoc $ HsIPName x) (synifyType WithinType ty)+      = noLoc $ HsIParamTy noExt (noLoc $ HsIPName x) (synifyType WithinType ty)       -- and equalities       | tc `hasKey` eqTyConKey       , [ty1, ty2] <- tys-      = noLoc $ HsEqTy (synifyType WithinType ty1) (synifyType WithinType ty2)+      = noLoc $ HsOpTy noExt+                       (synifyType WithinType ty1)+                       (noLoc eqTyConName)+                       (synifyType WithinType ty2)       -- and infix type operators       | isSymOcc (nameOccName (getName tc))       , ty1:ty2:tys_rest <- vis_tys-      = mk_app_tys (HsOpTy (synifyType WithinType ty1)+      = mk_app_tys (HsOpTy noExt+                           (synifyType WithinType ty1)                            (noLoc $ getName tc)                            (synifyType WithinType ty2))                    tys_rest       -- Most TyCons:       | otherwise-      = mk_app_tys (HsTyVar NotPromoted $ noLoc (getName tc))+      = mk_app_tys (HsTyVar noExt NotPromoted $ noLoc (getName tc))                    vis_tys       where         mk_app_tys ty_app ty_args =-          foldl (\t1 t2 -> noLoc $ HsAppTy t1 t2)+          foldl (\t1 t2 -> noLoc $ HsAppTy noExt t1 t2)                 (noLoc ty_app)                 (map (synifyType WithinType) $                  filterOut isCoercionTy ty_args)@@ -488,7 +500,7 @@       | needs_kind_sig       = let full_kind  = typeKind (mkTyConApp tc tys)             full_kind' = synifyType WithinType full_kind-        in noLoc $ HsKindSig ty' full_kind'+        in noLoc $ HsKindSig noExt ty' full_kind'       | otherwise = ty'      needs_kind_sig :: Bool@@ -509,22 +521,24 @@ synifyType _ (AppTy t1 t2) = let   s1 = synifyType WithinType t1   s2 = synifyType WithinType t2-  in noLoc $ HsAppTy s1 s2+  in noLoc $ HsAppTy noExt s1 s2 synifyType _ (FunTy t1 t2) = let   s1 = synifyType WithinType t1   s2 = synifyType WithinType t2-  in noLoc $ HsFunTy s1 s2+  in noLoc $ HsFunTy noExt s1 s2 synifyType s forallty@(ForAllTy _tv _ty) =-  let (tvs, ctx, tau) = tcSplitSigmaTy forallty+  let (tvs, ctx, tau) = tcSplitSigmaTyPreserveSynonyms forallty       sPhi = HsQualTy { hst_ctxt = synifyCtx ctx+                      , hst_xqual   = noExt                       , hst_body = synifyType WithinType tau }   in case s of     DeleteTopLevelQuantification -> synifyType ImplicitizeForAll tau     WithinType        -> noLoc $ HsForAllTy { hst_bndrs = map synifyTyVar tvs+                                            , hst_xforall = noExt                                             , hst_body  = noLoc sPhi }     ImplicitizeForAll -> noLoc sPhi -synifyType _ (LitTy t) = noLoc $ HsTyLit $ synifyTyLit t+synifyType _ (LitTy t) = noLoc $ HsTyLit noExt $ synifyTyLit t synifyType s (CastTy t _) = synifyType s t synifyType _ (CoercionTy {}) = error "synifyType:Coercion" @@ -537,10 +551,12 @@                -- possible by taking theta = [], as that will print no context at all              | otherwise = req_theta   sForAll []  s = s-  sForAll tvs s = HsForAllTy { hst_bndrs = map synifyTyVar tvs-                             , hst_body  = noLoc s }-  sQual theta s = HsQualTy   { hst_ctxt  = synifyCtx theta-                             , hst_body  = noLoc s }+  sForAll tvs s = HsForAllTy { hst_bndrs   = map synifyTyVar tvs+                             , hst_xforall = noExt+                             , hst_body    = noLoc s }+  sQual theta s = HsQualTy   { hst_ctxt    = synifyCtx theta+                             , hst_xqual   = noExt+                             , hst_body    = noLoc s }   sTau = unLoc $ synifyType WithinType $ mkFunTys arg_tys res_ty   in noLoc $ sForAll univ_tvs $ sQual req_theta' $ sForAll ex_tvs $ sQual prov_theta sTau @@ -560,7 +576,7 @@         , clsiTyVars = synifyTyVars (tyConVisibleTyVars cls_tycon)         , clsiSigs = map synifyClsIdSig $ classMethods cls         , clsiAssocTys = do-            (Right (FamDecl fam)) <- map (synifyTyCon Nothing) $ classATs cls+            (Right (FamDecl _ fam)) <- map (synifyTyCon Nothing) $ classATs cls             pure $ mkPseudoFamilyDecl fam         }     }@@ -610,3 +626,47 @@     ts' = synifyTypes ts     annot_ts = zipWith3 annotHsType is_poly_tvs ts ts'     is_poly_tvs = mkIsPolyTvs (tyConVisibleTyVars fam_tc)++{-+Note [Invariant: Never expand type synonyms]++In haddock, we never want to expand a type synonym that may be presented to the+user, as we want to keep the link to the abstraction captured in the synonym.++All code in Haddock.Convert must make sure that this invariant holds.++See https://github.com/haskell/haddock/issues/879 for a bug where this+invariant didn't hold.+-}++-- | A version of 'TcType.tcSplitSigmaTy' that preserves type synonyms.+--+-- See Note [Invariant: Never expand type synonyms]+tcSplitSigmaTyPreserveSynonyms :: Type -> ([TyVar], ThetaType, Type)+tcSplitSigmaTyPreserveSynonyms ty =+    case tcSplitForAllTysPreserveSynonyms ty of+      (tvs, rho) -> case tcSplitPhiTyPreserveSynonyms rho of+        (theta, tau) -> (tvs, theta, tau)++-- | See Note [Invariant: Never expand type synonyms]+tcSplitForAllTysPreserveSynonyms :: Type -> ([TyVar], Type)+tcSplitForAllTysPreserveSynonyms ty = split ty ty []+  where+    split _       (ForAllTy (TvBndr tv _) ty') tvs = split ty' ty' (tv:tvs)+    split orig_ty _                            tvs = (reverse tvs, orig_ty)++-- | See Note [Invariant: Never expand type synonyms]+tcSplitPhiTyPreserveSynonyms :: Type -> (ThetaType, Type)+tcSplitPhiTyPreserveSynonyms ty0 = split ty0 []+  where+    split ty ts+      = case tcSplitPredFunTyPreserveSynonyms_maybe ty of+          Just (pred_, ty') -> split ty' (pred_:ts)+          Nothing           -> (reverse ts, ty)++-- | See Note [Invariant: Never expand type synonyms]+tcSplitPredFunTyPreserveSynonyms_maybe :: Type -> Maybe (PredType, Type)+tcSplitPredFunTyPreserveSynonyms_maybe (FunTy arg res)+  | isPredTy arg = Just (arg, res)+tcSplitPredFunTyPreserveSynonyms_maybe _+  = Nothing
haddock-api/src/Haddock/GhcUtils.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns, FlexibleInstances, ViewPatterns #-}+{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_HADDOCK hide #-} -----------------------------------------------------------------------------@@ -17,6 +18,7 @@   import Control.Arrow+import Haddock.Types( DocNameI )  import Exception import Outputable@@ -27,8 +29,11 @@ import HscTypes import GHC import Class+import DynFlags +import HsTypes (HsType(..)) + moduleString :: Module -> String moduleString = moduleNameString . moduleName @@ -44,57 +49,65 @@   getMainDeclBinder :: HsDecl name -> [IdP name]-getMainDeclBinder (TyClD d) = [tcdName d]-getMainDeclBinder (ValD d) =+getMainDeclBinder (TyClD _ d) = [tcdName d]+getMainDeclBinder (ValD _ d) =   case collectHsBindBinders d of     []       -> []     (name:_) -> [name]-getMainDeclBinder (SigD d) = sigNameNoLoc d-getMainDeclBinder (ForD (ForeignImport name _ _ _)) = [unLoc name]-getMainDeclBinder (ForD (ForeignExport _ _ _ _)) = []+getMainDeclBinder (SigD _ d) = sigNameNoLoc d+getMainDeclBinder (ForD _ (ForeignImport _ name _ _)) = [unLoc name]+getMainDeclBinder (ForD _ (ForeignExport _ _ _ _)) = [] getMainDeclBinder _ = []  -- Extract the source location where an instance is defined. This is used -- to correlate InstDecls with their Instance/CoAxiom Names, via the -- instanceMap. getInstLoc :: InstDecl name -> SrcSpan-getInstLoc (ClsInstD (ClsInstDecl { cid_poly_ty = ty })) = getLoc (hsSigType ty)-getInstLoc (DataFamInstD (DataFamInstDecl+getInstLoc (ClsInstD _ (ClsInstDecl { cid_poly_ty = ty })) = getLoc (hsSigType ty)+getInstLoc (DataFamInstD _ (DataFamInstDecl   { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = L l _ }}})) = l-getInstLoc (TyFamInstD (TyFamInstDecl+getInstLoc (TyFamInstD _ (TyFamInstDecl   -- Since CoAxioms' Names refer to the whole line for type family instances   -- in particular, we need to dig a bit deeper to pull out the entire   -- equation. This does not happen for data family instances, for some reason.   { tfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = L l _ }}})) = l+getInstLoc (ClsInstD _ (XClsInstDecl _)) = panic "getInstLoc"+getInstLoc (DataFamInstD _ (DataFamInstDecl (HsIB _ (XFamEqn _)))) = panic "getInstLoc"+getInstLoc (TyFamInstD _ (TyFamInstDecl (HsIB _ (XFamEqn _)))) = panic "getInstLoc"+getInstLoc (XInstDecl _) = panic "getInstLoc"+getInstLoc (DataFamInstD _ (DataFamInstDecl (XHsImplicitBndrs _))) = panic "getInstLoc"+getInstLoc (TyFamInstD _ (TyFamInstDecl (XHsImplicitBndrs _))) = panic "getInstLoc" ++ -- Useful when there is a signature with multiple names, e.g. --   foo, bar :: Types.. -- but only one of the names is exported and we have to change the -- type signature to only include the exported names.-filterLSigNames :: (IdP name -> Bool) -> LSig name -> Maybe (LSig name)+filterLSigNames :: (IdP (GhcPass p) -> Bool) -> LSig (GhcPass p) -> Maybe (LSig (GhcPass p)) filterLSigNames p (L loc sig) = L loc <$> (filterSigNames p sig) -filterSigNames :: (IdP name -> Bool) -> Sig name -> Maybe (Sig name)-filterSigNames p orig@(SpecSig n _ _)          = ifTrueJust (p $ unLoc n) orig-filterSigNames p orig@(InlineSig n _)          = ifTrueJust (p $ unLoc n) orig-filterSigNames p (FixSig (FixitySig ns ty)) =+filterSigNames :: (IdP (GhcPass p) -> Bool) -> Sig (GhcPass p) -> Maybe (Sig (GhcPass p))+filterSigNames p orig@(SpecSig _ n _ _)          = ifTrueJust (p $ unLoc n) orig+filterSigNames p orig@(InlineSig _ n _)          = ifTrueJust (p $ unLoc n) orig+filterSigNames p (FixSig _ (FixitySig _ ns ty)) =   case filter (p . unLoc) ns of     []       -> Nothing-    filtered -> Just (FixSig (FixitySig filtered ty))-filterSigNames _ orig@(MinimalSig _ _)      = Just orig-filterSigNames p (TypeSig ns ty) =+    filtered -> Just (FixSig noExt (FixitySig noExt filtered ty))+filterSigNames _ orig@(MinimalSig _ _ _)      = Just orig+filterSigNames p (TypeSig _ ns ty) =   case filter (p . unLoc) ns of     []       -> Nothing-    filtered -> Just (TypeSig filtered ty)-filterSigNames p (ClassOpSig is_default ns ty) =+    filtered -> Just (TypeSig noExt filtered ty)+filterSigNames p (ClassOpSig _ is_default ns ty) =   case filter (p . unLoc) ns of     []       -> Nothing-    filtered -> Just (ClassOpSig is_default filtered ty)-filterSigNames p (PatSynSig ns ty) =+    filtered -> Just (ClassOpSig noExt is_default filtered ty)+filterSigNames p (PatSynSig _ ns ty) =   case filter (p . unLoc) ns of     []       -> Nothing-    filtered -> Just (PatSynSig filtered ty)-filterSigNames _ _                           = Nothing+    filtered -> Just (PatSynSig noExt filtered ty)+filterSigNames _ _                             = Nothing  ifTrueJust :: Bool -> name -> Maybe name ifTrueJust True  = Just@@ -104,13 +117,13 @@ sigName (L _ sig) = sigNameNoLoc sig  sigNameNoLoc :: Sig name -> [IdP name]-sigNameNoLoc (TypeSig      ns _)       = map unLoc ns-sigNameNoLoc (ClassOpSig _ ns _)       = map unLoc ns-sigNameNoLoc (PatSynSig    ns _)       = map unLoc ns-sigNameNoLoc (SpecSig      n _ _)      = [unLoc n]-sigNameNoLoc (InlineSig    n _)        = [unLoc n]-sigNameNoLoc (FixSig (FixitySig ns _)) = map unLoc ns-sigNameNoLoc _                         = []+sigNameNoLoc (TypeSig    _   ns _)         = map unLoc ns+sigNameNoLoc (ClassOpSig _ _ ns _)         = map unLoc ns+sigNameNoLoc (PatSynSig  _   ns _)         = map unLoc ns+sigNameNoLoc (SpecSig    _   n _ _)        = [unLoc n]+sigNameNoLoc (InlineSig  _   n _)          = [unLoc n]+sigNameNoLoc (FixSig _ (FixitySig _ ns _)) = map unLoc ns+sigNameNoLoc _                             = []  -- | Was this signature given by the user? isUserLSig :: LSig name -> Bool@@ -121,16 +134,16 @@   isClassD :: HsDecl a -> Bool-isClassD (TyClD d) = isClassDecl d+isClassD (TyClD _ d) = isClassDecl d isClassD _ = False  isValD :: HsDecl a -> Bool-isValD (ValD _) = True+isValD (ValD _ _) = True isValD _ = False   declATs :: HsDecl a -> [IdP a]-declATs (TyClD d) | isClassDecl d = map (unL . fdLName . unL) $ tcdATs d+declATs (TyClD _ d) | isClassDecl d = map (unL . fdLName . unL) $ tcdATs d declATs _ = []  @@ -148,7 +161,168 @@       where         y = f x +-- ---------------------------------------------------------------------++-- This function is duplicated as getGADTConType and getGADTConTypeG,+-- as I can't get the types to line up otherwise. AZ.++getGADTConType :: ConDecl DocNameI -> LHsType DocNameI+-- The full type of a GADT data constructor We really only get this in+-- order to pretty-print it, and currently only in Haddock's code.  So+-- we are cavalier about locations and extensions, hence the+-- 'undefined's+getGADTConType (ConDeclGADT { con_forall = L _ has_forall+                            , con_qvars = qtvs+                            , con_mb_cxt = mcxt, con_args = args+                            , con_res_ty = res_ty })+ | has_forall = noLoc (HsForAllTy { hst_xforall = NoExt+                                  , hst_bndrs = hsQTvExplicit qtvs+                                  , hst_body  = theta_ty })+ | otherwise  = theta_ty+ where+   theta_ty | Just theta <- mcxt+            = noLoc (HsQualTy { hst_xqual = NoExt, hst_ctxt = theta, hst_body = tau_ty })+            | otherwise+            = tau_ty++   tau_ty = case args of+              RecCon flds -> noLoc (HsFunTy noExt (noLoc (HsRecTy noExt (unLoc flds))) res_ty)+              PrefixCon pos_args -> foldr mkFunTy res_ty pos_args+              InfixCon arg1 arg2 -> arg1 `mkFunTy` (arg2 `mkFunTy` res_ty)++   mkFunTy a b = noLoc (HsFunTy noExt a b)++getGADTConType (ConDeclH98 {}) = panic "getGADTConType"+  -- Should only be called on ConDeclGADT+getGADTConType (XConDecl {}) = panic "getGADTConType"++-- -------------------------------------++getGADTConTypeG :: ConDecl (GhcPass p) -> LHsType (GhcPass p)+-- The full type of a GADT data constructor We really only get this in+-- order to pretty-print it, and currently only in Haddock's code.  So+-- we are cavalier about locations and extensions, hence the+-- 'undefined's+getGADTConTypeG (ConDeclGADT { con_forall = L _ has_forall+                            , con_qvars = qtvs+                            , con_mb_cxt = mcxt, con_args = args+                            , con_res_ty = res_ty })+ | has_forall = noLoc (HsForAllTy { hst_xforall = NoExt+                                  , hst_bndrs = hsQTvExplicit qtvs+                                  , hst_body  = theta_ty })+ | otherwise  = theta_ty+ where+   theta_ty | Just theta <- mcxt+            = noLoc (HsQualTy { hst_xqual = NoExt, hst_ctxt = theta, hst_body = tau_ty })+            | otherwise+            = tau_ty++   tau_ty = case args of+              RecCon flds -> noLoc (HsFunTy noExt (noLoc (HsRecTy noExt (unLoc flds))) res_ty)+              PrefixCon pos_args -> foldr mkFunTy res_ty pos_args+              InfixCon arg1 arg2 -> arg1 `mkFunTy` (arg2 `mkFunTy` res_ty)++   mkFunTy a b = noLoc (HsFunTy noExt a b)++getGADTConTypeG (ConDeclH98 {}) = panic "getGADTConTypeG"+  -- Should only be called on ConDeclGADT+getGADTConTypeG (XConDecl {}) = panic "getGADTConTypeG"++ -------------------------------------------------------------------------------+-- * Parenthesization+-------------------------------------------------------------------------------++-- | Precedence level (inside the 'HsType' AST).+data Precedence+  = PREC_TOP  -- ^ precedence of 'type' production in GHC's parser++  | PREC_CTX  -- ^ Used for single contexts, eg. ctx => type+              -- (as opposed to (ctx1, ctx2) => type)++  | PREC_FUN  -- ^ precedence of 'btype' production in GHC's parser+              -- (used for LH arg of (->))++  | PREC_OP   -- ^ arg of any infix operator+              -- (we don't keep have fixity info)++  | PREC_CON  -- ^ arg of type application: always parenthesize unless atomic+  deriving (Eq, Ord)++-- | Add in extra 'HsParTy' where needed to ensure that what would be printed+-- out using 'ppr' has enough parentheses to be re-parsed properly.+--+-- We cannot add parens that may be required by fixities because we do not have+-- any fixity information to work with in the first place :(.+reparenTypePrec :: (XParTy a ~ NoExt) => Precedence -> HsType a -> HsType a+reparenTypePrec = go+  where++  -- Shorter name for 'reparenType'+  go :: (XParTy a ~ NoExt) => Precedence -> HsType a -> HsType a+  go _ (HsBangTy x b ty)     = HsBangTy x b (reparenLType ty)+  go _ (HsTupleTy x con tys) = HsTupleTy x con (map reparenLType tys)+  go _ (HsSumTy x tys)       = HsSumTy x (map reparenLType tys)+  go _ (HsKindSig x ty kind) = HsKindSig x (reparenLType ty) (reparenLType kind)+  go _ (HsListTy x ty)       = HsListTy x (reparenLType ty)+  go _ (HsRecTy x flds)      = HsRecTy x (map (fmap reparenConDeclField) flds)+  go p (HsDocTy x ty d)      = HsDocTy x (goL p ty) d+  go _ (HsExplicitListTy x p tys) = HsExplicitListTy x p (map reparenLType tys)+  go _ (HsExplicitTupleTy x tys) = HsExplicitTupleTy x (map reparenLType tys)+  go p (HsIParamTy x n ty)+    = paren p PREC_CTX $ HsIParamTy x n (reparenLType ty)+  go p (HsForAllTy x tvs ty)+    = paren p PREC_CTX $ HsForAllTy x (map (fmap reparenTyVar) tvs) (reparenLType ty)+  go p (HsQualTy x ctxt ty)+    = paren p PREC_FUN $ HsQualTy x (fmap (map reparenLType) ctxt) (reparenLType ty)+  go p (HsFunTy x ty1 ty2)+    = paren p PREC_FUN $ HsFunTy x (goL PREC_FUN ty1) (goL PREC_TOP ty2)+  go p (HsAppTy x fun_ty arg_ty)+    = paren p PREC_CON $ HsAppTy x (goL PREC_FUN fun_ty) (goL PREC_CON arg_ty)+  go p (HsOpTy x ty1 op ty2)+    = paren p PREC_FUN $ HsOpTy x (goL PREC_OP ty1) op (goL PREC_OP ty2)+  go p (HsParTy _ t) = unLoc $ goL p t -- pretend the paren doesn't exist - it will be added back if needed+  go _ t@HsTyVar{} = t+  go _ t@HsStarTy{} = t+  go _ t@HsSpliceTy{} = t+  go _ t@HsTyLit{} = t+  go _ t@HsWildCardTy{} = t+  go _ t@XHsType{} = t++  -- Located variant of 'go'+  goL :: (XParTy a ~ NoExt) => Precedence -> LHsType a -> LHsType a+  goL ctxt_prec = fmap (go ctxt_prec)++  -- Optionally wrap a type in parens+  paren :: (XParTy a ~ NoExt)+        => Precedence            -- Precedence of context+        -> Precedence            -- Precedence of top-level operator+        -> HsType a -> HsType a  -- Wrap in parens if (ctxt >= op)+  paren ctxt_prec op_prec | ctxt_prec >= op_prec = HsParTy NoExt . noLoc+                          | otherwise            = id+++-- | Add parenthesis around the types in a 'HsType' (see 'reparenTypePrec')+reparenType :: (XParTy a ~ NoExt) => HsType a -> HsType a+reparenType = reparenTypePrec PREC_TOP++-- | Add parenthesis around the types in a 'LHsType' (see 'reparenTypePrec')+reparenLType :: (XParTy a ~ NoExt) => LHsType a -> LHsType a+reparenLType = fmap reparenType++-- | Add parenthesis around the types in a 'HsTyVarBndr' (see 'reparenTypePrec')+reparenTyVar :: (XParTy a ~ NoExt) => HsTyVarBndr a -> HsTyVarBndr a+reparenTyVar (UserTyVar x n) = UserTyVar x n+reparenTyVar (KindedTyVar x n kind) = KindedTyVar x n (reparenLType kind)+reparenTyVar v@XTyVarBndr{} = v++-- | Add parenthesis around the types in a 'ConDeclField' (see 'reparenTypePrec')+reparenConDeclField :: (XParTy a ~ NoExt) => ConDeclField a -> ConDeclField a+reparenConDeclField (ConDeclField x n t d) = ConDeclField x n (reparenLType t) d+reparenConDeclField c@XConDeclField{} = c+++------------------------------------------------------------------------------- -- * Located ------------------------------------------------------------------------------- @@ -179,8 +353,8 @@  instance Parent (ConDecl GhcRn) where   children con =-    case getConDetails con of-      RecCon fields -> map (selectorFieldOcc . unL) $+    case con_args con of+      RecCon fields -> map (extFieldOcc . unL) $                          concatMap (cd_fld_names . unL) (unL fields)       _             -> [] @@ -190,7 +364,7 @@                               $ (dd_cons . tcdDataDefn) $ d     | isClassDecl d =         map (unL . fdLName . unL) (tcdATs d) ++-        [ unL n | L _ (TypeSig ns _) <- tcdSigs d, n <- ns ]+        [ unL n | L _ (TypeSig _ ns _) <- tcdSigs d, n <- ns ]     | otherwise = []  @@ -218,7 +392,7 @@  -- | The parents of a subordinate in a declaration parents :: Name -> HsDecl GhcRn -> [Name]-parents n (TyClD d) = [ p | (c, p) <- parentMap d, c == n ]+parents n (TyClD _ d) = [ p | (c, p) <- parentMap d, c == n ] parents _ _ = []  @@ -255,7 +429,10 @@ setObjectDir, setHiDir, setStubDir, setOutputDir :: String -> DynFlags -> DynFlags setObjectDir  f d = d{ objectDir  = Just f} setHiDir      f d = d{ hiDir      = Just f}-setStubDir    f d = d{ stubDir    = Just f, includePaths = f : includePaths d }+setStubDir    f d = d{ stubDir    = Just f+                     , includePaths = addGlobalInclude (includePaths d) [f] }   -- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file   -- \#included from the .hc file when compiling with -fvia-C. setOutputDir  f = setObjectDir f . setHiDir f . setStubDir f++
haddock-api/src/Haddock/Interface.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, OverloadedStrings #-}+{-# LANGUAGE CPP, OverloadedStrings, BangPatterns #-} ----------------------------------------------------------------------------- -- | -- Module      :  Haddock.Interface@@ -51,6 +51,7 @@ import System.FilePath import Text.Printf +import Module (mkModuleSet, emptyModuleSet, unionModuleSet, ModuleSet) import Digraph import DynFlags hiding (verbosity) import Exception@@ -59,7 +60,9 @@ import FastString (unpackFS) import MonadUtils (liftIO) import TcRnTypes (tcg_rdr_env)-import RdrName (plusGlobalRdrEnv)+import Name (nameIsFromExternalPackage, nameOccName)+import OccName (isTcOcc)+import RdrName (unQualOK, gre_name, globalRdrEnvElts) import ErrUtils (withTiming)  #if defined(mingw32_HOST_OS)@@ -87,7 +90,7 @@   out verbosity verbose "Creating interfaces..."   let instIfaceMap =  Map.fromList [ (instMod iface, iface) | ext <- extIfaces                                    , iface <- ifInstalledIfaces ext ]-  interfaces <- createIfaces0 verbosity modules flags instIfaceMap+  (interfaces, ms) <- createIfaces0 verbosity modules flags instIfaceMap    let exportedNames =         Set.unions $ map (Set.fromList . ifaceExports) $@@ -96,7 +99,7 @@   out verbosity verbose "Attaching instances..."   interfaces' <- {-# SCC attachInstances #-}                  withTiming getDynFlags "attachInstances" (const ()) $ do-                   attachInstances (exportedNames, mods) interfaces instIfaceMap+                   attachInstances (exportedNames, mods) interfaces instIfaceMap ms    out verbosity verbose "Building cross-linking environment..."   -- Combine the link envs of the external packages into one@@ -120,7 +123,7 @@ --------------------------------------------------------------------------------  -createIfaces0 :: Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc [Interface]+createIfaces0 :: Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc ([Interface], ModuleSet) createIfaces0 verbosity modules flags instIfaceMap =   -- Output dir needs to be set before calling depanal since depanal uses it to   -- compute output file names that are stored in the DynFlags of the@@ -150,44 +153,52 @@       depanal [] False  -createIfaces :: Verbosity -> [Flag] -> InstIfaceMap -> ModuleGraph -> Ghc [Interface]+createIfaces :: Verbosity -> [Flag] -> InstIfaceMap -> ModuleGraph -> Ghc ([Interface], ModuleSet) createIfaces verbosity flags instIfaceMap mods = do   let sortedMods = flattenSCCs $ topSortModuleGraph False mods Nothing   out verbosity normal "Haddock coverage:"-  (ifaces, _) <- foldM f ([], Map.empty) sortedMods-  return (reverse ifaces)+  (ifaces, _, !ms) <- foldM f ([], Map.empty, emptyModuleSet) sortedMods+  return (reverse ifaces, ms)   where-    f (ifaces, ifaceMap) modSummary = do+    f (ifaces, ifaceMap, !ms) modSummary = do       x <- {-# SCC processModule #-}            withTiming getDynFlags "processModule" (const ()) $ do              processModule verbosity modSummary flags ifaceMap instIfaceMap       return $ case x of-        Just iface -> (iface:ifaces, Map.insert (ifaceMod iface) iface ifaceMap)-        Nothing    -> (ifaces, ifaceMap) -- Boot modules don't generate ifaces.+        Just (iface, ms') -> ( iface:ifaces+                             , Map.insert (ifaceMod iface) iface ifaceMap+                             , unionModuleSet ms ms' )+        Nothing           -> ( ifaces+                             , ifaceMap+                             , ms ) -- Boot modules don't generate ifaces.  -processModule :: Verbosity -> ModSummary -> [Flag] -> IfaceMap -> InstIfaceMap -> Ghc (Maybe Interface)+processModule :: Verbosity -> ModSummary -> [Flag] -> IfaceMap -> InstIfaceMap -> Ghc (Maybe (Interface, ModuleSet)) processModule verbosity modsum flags modMap instIfaceMap = do   out verbosity verbose $ "Checking module " ++ moduleString (ms_mod modsum) ++ "..."   tm <- {-# SCC "parse/typecheck/load" #-} loadModule =<< typecheckModule =<< parseModule modsum -  -- We need to modify the interactive context's environment so that when-  -- Haddock later looks for instances, it also looks in the modules it-  -- encountered while typechecking.-  ---  -- See https://github.com/haskell/haddock/issues/469.-  hsc_env@HscEnv{ hsc_IC = old_IC } <- getSession-  let new_rdr_env = tcg_rdr_env . fst . GHC.tm_internals_ $ tm-  setSession hsc_env{ hsc_IC = old_IC {-    ic_rn_gbl_env = ic_rn_gbl_env old_IC `plusGlobalRdrEnv` new_rdr_env-  } }-   if not $ isBootSummary modsum then do     out verbosity verbose "Creating interface..."-    (interface, msg) <- {-# SCC createIterface #-}+    (interface, msgs) <- {-# SCC createIterface #-}                         withTiming getDynFlags "createInterface" (const ()) $ do                           runWriterGhc $ createInterface tm flags modMap instIfaceMap-    liftIO $ mapM_ putStrLn msg++    -- We need to keep track of which modules were somehow in scope so that when+    -- Haddock later looks for instances, it also looks in these modules too.+    --+    -- See https://github.com/haskell/haddock/issues/469.+    hsc_env <- getSession+    let new_rdr_env = tcg_rdr_env . fst . GHC.tm_internals_ $ tm+        this_pkg = thisPackage (hsc_dflags hsc_env)+        !mods = mkModuleSet [ nameModule name+                            | gre <- globalRdrEnvElts new_rdr_env+                            , let name = gre_name gre+                            , nameIsFromExternalPackage this_pkg name+                            , isTcOcc (nameOccName name)   -- Types and classes only+                            , unQualOK gre ]               -- In scope unqualified++    liftIO $ mapM_ putStrLn (nub msgs)     dflags <- getDynFlags     let (haddockable, haddocked) = ifaceHaddockCoverage interface         percentage = round (fromIntegral haddocked * 100 / fromIntegral haddockable :: Double) :: Int@@ -220,7 +231,7 @@         unless header $ out verbosity normal "    Module header"         mapM_ (out verbosity normal . ("    " ++)) undocumentedExports     interface' <- liftIO $ evaluate interface-    return (Just interface')+    return (Just (interface', mods))   else     return Nothing
haddock-api/src/Haddock/Interface/AttachInstances.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, MagicHash #-}+{-# LANGUAGE CPP, MagicHash, BangPatterns #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- |@@ -34,6 +34,7 @@ import FastString import GHC import InstEnv+import Module ( ModuleSet, moduleSetElts ) import MonadUtils (liftIO) import Name import NameEnv@@ -51,11 +52,13 @@ type ExportInfo = (ExportedNames, Modules)  -- Also attaches fixities-attachInstances :: ExportInfo -> [Interface] -> InstIfaceMap -> Ghc [Interface]-attachInstances expInfo ifaces instIfaceMap = do-  (_msgs, mb_index) <- getNameToInstancesIndex (map ifaceMod ifaces)+attachInstances :: ExportInfo -> [Interface] -> InstIfaceMap -> ModuleSet -> Ghc [Interface]+attachInstances expInfo ifaces instIfaceMap mods = do+  (_msgs, mb_index) <- getNameToInstancesIndex (map ifaceMod ifaces) mods'   mapM (attach $ fromMaybe emptyNameEnv mb_index) ifaces   where+    mods' = Just (moduleSetElts mods)+     -- TODO: take an IfaceMap as input     ifaceMap = Map.fromList [ (ifaceMod i, i) | i <- ifaces ] @@ -86,7 +89,7 @@   -> Ghc (ExportItem GhcRn) attachToExportItem index expInfo iface ifaceMap instIfaceMap export =   case attachFixities export of-    e@ExportDecl { expItemDecl = L eSpan (TyClD d) } -> do+    e@ExportDecl { expItemDecl = L eSpan (TyClD _ d) } -> do       insts <-         let mb_instances  = lookupNameEnv index (tcdName d)             cls_instances = maybeToList mb_instances >>= fst
haddock-api/src/Haddock/Interface/Create.hs view
@@ -58,10 +58,10 @@ import Bag import RdrName import TcRnTypes-import FastString ( concatFS, unpackFS )+import FastString ( unpackFS, fastStringToByteString) import BasicTypes ( StringLiteral(..), SourceText(..) ) import qualified Outputable as O-import HsDecls    ( getConDetails )+import HsDecls ( getConArgs )   -- | Use a 'TypecheckedModule' to produce an 'Interface'.@@ -135,7 +135,7 @@                         $  map getName instances                         ++ map getName fam_instances       -- Locations of all TH splices-      splices = [ l | L l (SpliceD _) <- hsmodDecls hsm ]+      splices = [ l | L l (SpliceD _ _) <- hsmodDecls hsm ]    warningMap <- liftErrMsg (mkWarningMap dflags warnings gre exportedNames) @@ -304,11 +304,11 @@  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)   -------------------------------------------------------------------------------@@ -393,7 +393,7 @@             m'   <- traverse (processDocStringParas dflags pkgName gre) m             pure (doc', m') -      (doc, args) <- declDoc docStrs (typeDocs decl)+      (doc, args) <- declDoc docStrs (declTypeDocs decl)        let           subs :: [(Name, [HsDocString], Map Int HsDocString)]@@ -419,9 +419,12 @@     instanceMap = M.fromList [ (getSrcSpan n, n) | n <- instances ]      names :: SrcSpan -> HsDecl GhcRn -> [Name]-    names l (InstD d) = maybeToList (M.lookup loc instanceMap) -- See note [2].+    names _ (InstD _ d) = maybeToList (M.lookup loc instanceMap) -- See note [2].       where loc = case d of-              TyFamInstD _ -> l -- The CoAx's loc is the whole line, but only for TFs+              -- The CoAx's loc is the whole line, but only for TFs. The+              -- workaround is to dig into the family instance declaration and+              -- get the identifier with the right location.+              TyFamInstD _ (TyFamInstDecl d') -> getLoc (feqn_tycon (hsib_body d'))               _ -> getInstLoc d     names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See note [2].     names _ decl = getMainDeclBinder decl@@ -446,67 +449,83 @@              -> HsDecl GhcRn              -> [(Name, [HsDocString], Map Int HsDocString)] subordinates instMap decl = case decl of-  InstD (ClsInstD d) -> do+  InstD _ (ClsInstD _ d) -> do     DataFamInstDecl { dfid_eqn = HsIB { hsib_body =       FamEqn { feqn_tycon = L l _              , feqn_rhs   = defn }}} <- unLoc <$> cid_datafam_insts d     [ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs defn -  InstD (DataFamInstD (DataFamInstDecl (HsIB { hsib_body = d })))+  InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body = d })))     -> dataSubs (feqn_rhs d)-  TyClD d | isClassDecl d -> classSubs d-          | isDataDecl  d -> dataSubs (tcdDataDefn d)+  TyClD _ d | isClassDecl d -> classSubs d+            | isDataDecl  d -> dataSubs (tcdDataDefn d)   _ -> []   where-    classSubs dd = [ (name, doc, typeDocs d) | (L _ d, doc) <- classDecls dd+    classSubs dd = [ (name, doc, declTypeDocs d) | (L _ d, doc) <- classDecls dd                    , name <- getMainDeclBinder d, not (isValD d)                    ]     dataSubs :: HsDataDefn GhcRn -> [(Name, [HsDocString], Map Int HsDocString)]     dataSubs dd = constrs ++ fields ++ derivs       where         cons = map unL $ (dd_cons dd)-        constrs = [ (unL cname, maybeToList $ fmap unL $ con_doc c, M.empty)+        constrs = [ (unL cname, maybeToList $ fmap unL $ con_doc c, conArgDocs c)                   | c <- cons, cname <- getConNames c ]-        fields  = [ (selectorFieldOcc n, maybeToList $ fmap unL doc, M.empty)-                  | RecCon flds <- map getConDetails cons-                  , L _ (ConDeclField ns _ doc) <- (unLoc flds)+        fields  = [ (extFieldOcc n, maybeToList $ fmap unL doc, M.empty)+                  | RecCon flds <- map getConArgs cons+                  , L _ (ConDeclField _ ns _ doc) <- (unLoc flds)                   , L _ n <- ns ]         derivs  = [ (instName, [unL doc], M.empty)-                  | HsIB { hsib_body = L l (HsDocTy _ doc) }+                  | HsIB { hsib_body = L l (HsDocTy _ _ doc) }                       <- concatMap (unLoc . deriv_clause_tys . unLoc) $                            unLoc $ dd_derivs dd                   , Just instName <- [M.lookup l instMap] ] +-- | Extract constructor argument docs from inside constructor decls.+conArgDocs :: ConDecl GhcRn -> Map Int HsDocString+conArgDocs con = case getConArgs con of+                   PrefixCon args -> go 0 (map unLoc args ++ ret)+                   InfixCon arg1 arg2 -> go 0 ([unLoc arg1, unLoc arg2] ++ ret)+                   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++    ret = case con of+            ConDeclGADT { con_res_ty = res_ty } -> [ unLoc res_ty ]+            _ -> []++-- | Extract function argument docs from inside top-level decls.+declTypeDocs :: HsDecl GhcRn -> Map Int HsDocString+declTypeDocs (SigD  _ (TypeSig _ _ ty))          = typeDocs (unLoc (hsSigWcType ty))+declTypeDocs (SigD  _ (ClassOpSig _ _ _ ty))     = typeDocs (unLoc (hsSigType ty))+declTypeDocs (SigD  _ (PatSynSig _ _ ty))        = typeDocs (unLoc (hsSigType ty))+declTypeDocs (ForD  _ (ForeignImport _ _ ty _))  = typeDocs (unLoc (hsSigType ty))+declTypeDocs (TyClD _ (SynDecl { tcdRhs = ty })) = typeDocs (unLoc ty)+declTypeDocs _ = M.empty+ -- | Extract function argument docs from inside types.-typeDocs :: HsDecl GhcRn -> Map Int HsDocString-typeDocs d =-  let docs = go 0 in-  case d of-    SigD (TypeSig _ ty)      -> docs (unLoc (hsSigWcType ty))-    SigD (ClassOpSig _ _ ty) -> docs (unLoc (hsSigType ty))-    SigD (PatSynSig _ ty)    -> docs (unLoc (hsSigType ty))-    ForD (ForeignImport _ ty _ _)   -> docs (unLoc (hsSigType ty))-    TyClD (SynDecl { tcdRhs = ty }) -> docs (unLoc ty)-    _ -> M.empty+typeDocs :: HsType GhcRn -> Map Int HsDocString+typeDocs = go 0   where     go n (HsForAllTy { hst_body = ty }) = go n (unLoc ty)     go n (HsQualTy   { hst_body = ty }) = go n (unLoc ty)-    go n (HsFunTy (L _ (HsDocTy _ (L _ x))) (L _ ty)) = M.insert n x $ go (n+1) ty-    go n (HsFunTy _ ty) = go (n+1) (unLoc ty)-    go n (HsDocTy _ (L _ doc)) = M.singleton n doc+    go n (HsFunTy _ (L _ (HsDocTy _ _ (L _ x))) (L _ ty)) = M.insert n x $ go (n+1) ty+    go n (HsFunTy _ _ ty) = go (n+1) (unLoc ty)+    go n (HsDocTy _ _ (L _ doc)) = M.singleton n doc     go _ _ = M.empty - -- | All the sub declarations of a class (that we handle), ordered by -- source location, with documentation attached if it exists. classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])] classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls   where     decls = docs ++ defs ++ sigs ++ ats-    docs  = mkDecls tcdDocs DocD class_-    defs  = mkDecls (bagToList . tcdMeths) ValD class_-    sigs  = mkDecls tcdSigs SigD class_-    ats   = mkDecls tcdATs (TyClD . FamDecl) class_+    docs  = mkDecls tcdDocs (DocD noExt) class_+    defs  = mkDecls (bagToList . tcdMeths) (ValD noExt) class_+    sigs  = mkDecls tcdSigs (SigD noExt) class_+    ats   = mkDecls tcdATs (TyClD noExt . FamDecl noExt) class_   -- | The top-level declarations of a module that we care about,@@ -518,26 +537,26 @@ -- | Extract a map of fixity declarations only mkFixMap :: HsGroup GhcRn -> FixMap mkFixMap group_ = M.fromList [ (n,f)-                             | L _ (FixitySig ns f) <- hs_fixds group_,+                             | L _ (FixitySig _ ns f) <- hs_fixds group_,                                L _ n <- ns ]   -- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'. ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn] ungroup group_ =-  mkDecls (tyClGroupTyClDecls . hs_tyclds) TyClD  group_ ++-  mkDecls hs_derivds             DerivD group_ ++-  mkDecls hs_defds               DefD   group_ ++-  mkDecls hs_fords               ForD   group_ ++-  mkDecls hs_docs                DocD   group_ ++-  mkDecls (tyClGroupInstDecls . hs_tyclds) InstD  group_ ++-  mkDecls (typesigs . hs_valds)  SigD   group_ ++-  mkDecls (valbinds . hs_valds)  ValD   group_+  mkDecls (tyClGroupTyClDecls . hs_tyclds) (TyClD noExt)  group_ +++  mkDecls hs_derivds             (DerivD noExt) group_ +++  mkDecls hs_defds               (DefD noExt)   group_ +++  mkDecls hs_fords               (ForD noExt)   group_ +++  mkDecls hs_docs                (DocD noExt)   group_ +++  mkDecls (tyClGroupInstDecls . hs_tyclds) (InstD noExt)  group_ +++  mkDecls (typesigs . hs_valds)  (SigD noExt)   group_ +++  mkDecls (valbinds . hs_valds)  (ValD noExt)   group_   where-    typesigs (ValBindsOut _ sigs) = filter isUserLSig sigs+    typesigs (XValBindsLR (NValBinds _ sigs)) = filter isUserLSig sigs     typesigs _ = error "expected ValBindsOut" -    valbinds (ValBindsOut binds _) = concatMap bagToList . snd . unzip $ binds+    valbinds (XValBindsLR (NValBinds binds _)) = concatMap bagToList . snd . unzip $ binds     valbinds _ = error "expected ValBindsOut"  @@ -563,14 +582,14 @@ filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)] filterDecls = filter (isHandled . unL . fst)   where-    isHandled (ForD (ForeignImport {})) = True+    isHandled (ForD _ (ForeignImport {})) = True     isHandled (TyClD {})  = True     isHandled (InstD {})  = True     isHandled (DerivD {}) = True-    isHandled (SigD d) = isUserLSig (reL d)-    isHandled (ValD _) = True+    isHandled (SigD _ d)  = isUserLSig (reL d)+    isHandled (ValD {})   = True     -- we keep doc declarations to be able to get at named docs-    isHandled (DocD _) = True+    isHandled (DocD {})   = True     isHandled _ = False  -- | Go through all class declarations and filter their sub-declarations@@ -578,8 +597,8 @@ filterClasses decls = [ if isClassD d then (L loc (filterClass d), doc) else x                       | x@(L loc d, doc) <- decls ]   where-    filterClass (TyClD c) =-      TyClD $ c { tcdSigs = filter (liftA2 (||) isUserLSig isMinimalLSig) $ tcdSigs c }+    filterClass (TyClD x c) =+      TyClD x $ c { tcdSigs = filter (liftA2 (||) isUserLSig isMinimalLSig) $ tcdSigs c }     filterClass _ = error "expected TyClD"  @@ -598,10 +617,10 @@   where     go Nothing _ [] = []     go (Just prev) docs [] = finished prev docs []-    go prev docs (L _ (DocD (DocCommentNext str)) : ds)+    go prev docs (L _ (DocD _ (DocCommentNext str)) : ds)       | Nothing <- prev = go Nothing (str:docs) ds       | Just decl <- prev = finished decl docs (go Nothing [str] ds)-    go prev docs (L _ (DocD (DocCommentPrev str)) : ds) = go prev (str:docs) ds+    go prev docs (L _ (DocD _ (DocCommentPrev str)) : ds) = go prev (str:docs) ds     go Nothing docs (d:ds) = go (Just d) docs ds     go (Just prev) docs (d:ds) = finished prev docs (go (Just d) [] ds) @@ -644,22 +663,22 @@         allExports     Just exports -> liftM concat $ mapM lookupExport exports   where-    lookupExport (IEGroup lev docStr, _)  = liftErrMsg $ do+    lookupExport (IEGroup _ lev docStr, _)  = liftErrMsg $ do       doc <- processDocString dflags gre docStr       return [ExportGroup lev "" doc] -    lookupExport (IEDoc docStr, _)        = liftErrMsg $ do+    lookupExport (IEDoc _ docStr, _)        = liftErrMsg $ do       doc <- processDocStringParas dflags pkgName gre docStr       return [ExportDoc doc] -    lookupExport (IEDocNamed str, _)      = liftErrMsg $+    lookupExport (IEDocNamed _ str, _)      = liftErrMsg $       findNamedDoc str [ unL d | d <- decls ] >>= \case         Nothing -> return  []         Just docStr -> do           doc <- processDocStringParas dflags pkgName gre docStr           return [ExportDoc doc] -    lookupExport (IEModuleContents (L _ mod_name), _)+    lookupExport (IEModuleContents _ (L _ mod_name), _)       -- only consider exporting a module if we are sure we       -- are really exporting the whole module and not some       -- subset. We also look through module aliases here.@@ -696,7 +715,7 @@       let t = availName avail       r    <- findDecl avail       case r of-        ([L l (ValD _)], (doc, _)) -> do+        ([L l (ValD _ _)], (doc, _)) -> do           -- Top-level binding without type signature           export <- hiValExportItem dflags t l doc (l `elem` splices) $ M.lookup t fixMap           return [export]@@ -721,17 +740,17 @@                   -- A single signature might refer to many names, but we                   -- create an export item for a single name only.  So we                   -- modify the signature to contain only that single name.-                  L loc (SigD sig) ->+                  L loc (SigD _ sig) ->                     -- fromJust is safe since we already checked in guards                     -- that 't' is a name declared in this declaration.-                    let newDecl = L loc . SigD . fromJust $ filterSigNames (== t) sig+                    let newDecl = L loc . SigD noExt . fromJust $ filterSigNames (== t) sig                     in availExportDecl avail newDecl docs_ -                  L loc (TyClD cl@ClassDecl{}) -> do+                  L loc (TyClD _ cl@ClassDecl{}) -> do                     mdef <- liftGhcToErrMsgGhc $ minimalDef t-                    let sig = maybeToList $ fmap (noLoc . MinimalSig NoSourceText . noLoc . fmap noLoc) mdef+                    let sig = maybeToList $ fmap (noLoc . MinimalSig noExt NoSourceText . noLoc . fmap noLoc) mdef                     availExportDecl avail-                      (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_+                      (L loc $ TyClD noExt cl { tcdSigs = sig ++ tcdSigs cl }) docs_                    _ -> availExportDecl avail decl docs_ @@ -994,13 +1013,13 @@   let availEnv = availsToNameEnv (nubAvails avails)   (concat . concat) `fmap` (for decls $ \decl -> do     case decl of-      (L _ (DocD (DocGroup lev docStr))) -> do+      (L _ (DocD _ (DocGroup lev docStr))) -> do         doc <- liftErrMsg (processDocString dflags gre docStr)         return [[ExportGroup lev "" doc]]-      (L _ (DocD (DocCommentNamed _ docStr))) -> do+      (L _ (DocD _ (DocCommentNamed _ docStr))) -> do         doc <- liftErrMsg (processDocStringParas dflags pkgName gre docStr)         return [[ExportDoc doc]]-      (L _ (ValD valDecl))+      (L _ (ValD _ valDecl))         | name:_ <- collectHsBindBinders valDecl         , Just (L _ SigD{}:_) <- filter isSigD <$> M.lookup name declMap         -> return []@@ -1025,12 +1044,12 @@   | name `elem` getMainDeclBinder (unLoc decl) = decl   | otherwise  =     case unLoc decl of-      TyClD d@ClassDecl {} ->+      TyClD _ d@ClassDecl {} ->         let           matchesMethod =             [ lsig             | lsig <- tcdSigs d-            , ClassOpSig False _ _ <- pure $ unLoc lsig+            , ClassOpSig _ False _ _ <- pure $ unLoc lsig               -- Note: exclude `default` declarations (see #505)             , name `elem` sigName lsig             ]@@ -1045,8 +1064,8 @@         in case (matchesMethod, matchesAssociatedType)  of           ([s0], _) -> let (n, tyvar_names) = (tcdName d, tyClDeclTyVars d)                            L pos sig = addClassContext n tyvar_names s0-                       in L pos (SigD sig)-          (_, [L pos fam_decl]) -> L pos (TyClD (FamDecl fam_decl))+                       in L pos (SigD noExt sig)+          (_, [L pos fam_decl]) -> L pos (TyClD noExt (FamDecl noExt fam_decl))            ([], [])             | Just (famInstDecl:_) <- M.lookup name declMap@@ -1055,23 +1074,23 @@                                          O.$$ O.nest 4 (O.ppr d)                                          O.$$ O.text "Matches:"                                          O.$$ O.nest 4 (O.ppr matchesMethod O.<+> O.ppr matchesAssociatedType))-      TyClD d@DataDecl {} ->+      TyClD _ d@DataDecl {} ->         let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars d))         in if isDataConName name-           then SigD <$> extractPatternSyn name n tyvar_tys (dd_cons (tcdDataDefn d))-           else SigD <$> extractRecSel name n tyvar_tys (dd_cons (tcdDataDefn d))-      TyClD FamDecl {}+           then SigD noExt <$> extractPatternSyn name n tyvar_tys (dd_cons (tcdDataDefn d))+           else SigD noExt <$> extractRecSel name n tyvar_tys (dd_cons (tcdDataDefn d))+      TyClD _ FamDecl {}         | isValName name         , Just (famInst:_) <- M.lookup name declMap         -> extractDecl declMap name famInst-      InstD (DataFamInstD (DataFamInstDecl (HsIB { hsib_body =+      InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body =                              FamEqn { feqn_tycon = L _ n                                     , feqn_pats  = tys                                     , feqn_rhs   = defn }}))) ->         if isDataConName name-        then SigD <$> extractPatternSyn name n tys (dd_cons defn)-        else SigD <$> extractRecSel name n tys (dd_cons defn)-      InstD (ClsInstD ClsInstDecl { cid_datafam_insts = insts })+        then SigD noExt <$> extractPatternSyn name n tys (dd_cons defn)+        else SigD noExt <$> extractRecSel name n tys (dd_cons defn)+      InstD _ (ClsInstD _ ClsInstDecl { cid_datafam_insts = insts })         | isDataConName name ->             let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body =                                           FamEqn { feqn_rhs   = dd@@ -1080,19 +1099,19 @@                                , name `elem` map unLoc (concatMap (getConNames . unLoc) (dd_cons dd))                                ]             in case matches of-                [d0] -> extractDecl declMap name (noLoc (InstD (DataFamInstD d0)))+                [d0] -> extractDecl declMap name (noLoc (InstD noExt (DataFamInstD noExt d0)))                 _    -> error "internal: extractDecl (ClsInstD)"         | otherwise ->             let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body = d }))                                    <- insts                                  -- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (feqn_rhs d)-                               , RecCon rec <- map (getConDetails . unLoc) (dd_cons (feqn_rhs d))+                               , RecCon rec <- map (getConArgs . unLoc) (dd_cons (feqn_rhs d))                                , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec)                                , L _ n <- ns-                               , selectorFieldOcc n == name+                               , extFieldOcc n == name                           ]             in case matches of-              [d0] -> extractDecl declMap name (noLoc . InstD $ DataFamInstD d0)+              [d0] -> extractDecl declMap name (noLoc . InstD noExt $ DataFamInstD noExt d0)               _ -> error "internal: extractDecl (ClsInstD)"       _ -> error "internal: extractDecl" @@ -1108,42 +1127,42 @@   extract :: ConDecl GhcRn -> Sig GhcRn   extract con =     let args =-          case getConDetails con of+          case getConArgs con of             PrefixCon args' -> args'             RecCon (L _ fields) -> cd_fld_type . unLoc <$> fields             InfixCon arg1 arg2 -> [arg1, arg2]         typ = longArrow args (data_ty con)         typ' =           case con of-            ConDeclH98 { con_cxt = Just cxt } -> noLoc (HsQualTy cxt typ)+            ConDeclH98 { con_mb_cxt = Just cxt } -> noLoc (HsQualTy noExt cxt typ)             _ -> typ-        typ'' = noLoc (HsQualTy (noLoc []) typ')-    in PatSynSig [noLoc nm] (mkEmptyImplicitBndrs typ'')+        typ'' = noLoc (HsQualTy noExt (noLoc []) typ')+    in PatSynSig noExt [noLoc nm] (mkEmptyImplicitBndrs typ'') -  longArrow :: [LHsType name] -> LHsType name -> LHsType name-  longArrow inputs output = foldr (\x y -> noLoc (HsFunTy x y)) output inputs+  longArrow :: [LHsType GhcRn] -> LHsType GhcRn -> LHsType GhcRn+  longArrow inputs output = foldr (\x y -> noLoc (HsFunTy noExt x y)) output inputs    data_ty con-    | ConDeclGADT{} <- con = hsib_body $ con_type con-    | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar NotPromoted (noLoc t))) tvs+    | ConDeclGADT{} <- con = con_res_ty con+    | otherwise = foldl' (\x y -> noLoc (HsAppTy noExt x y)) (noLoc (HsTyVar noExt NotPromoted (noLoc t))) tvs  extractRecSel :: Name -> Name -> [LHsType GhcRn] -> [LConDecl GhcRn]               -> LSig GhcRn extractRecSel _ _ _ [] = error "extractRecSel: selector not found"  extractRecSel nm t tvs (L _ con : rest) =-  case getConDetails con of-    RecCon (L _ fields) | ((l,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields ->-      L l (TypeSig [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy data_ty (getBangType ty)))))+  case getConArgs con of+    RecCon (L _ fields) | ((l,L _ (ConDeclField _ _nn ty _)) : _) <- matching_fields fields ->+      L l (TypeSig noExt [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExt data_ty (getBangType ty)))))     _ -> extractRecSel nm t tvs rest  where   matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)]-  matching_fields flds = [ (l,f) | f@(L _ (ConDeclField ns _ _)) <- flds-                                 , L l n <- ns, selectorFieldOcc n == nm ]+  matching_fields flds = [ (l,f) | f@(L _ (ConDeclField _ ns _ _)) <- flds+                                 , L l n <- ns, extFieldOcc n == nm ]   data_ty     -- ResTyGADT _ ty <- con_res con = ty-    | ConDeclGADT{} <- con = hsib_body $ con_type con-    | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar NotPromoted (noLoc t))) tvs+    | ConDeclGADT{} <- con = con_res_ty con+    | otherwise = foldl' (\x y -> noLoc (HsAppTy noExt x y)) (noLoc (HsTyVar noExt NotPromoted (noLoc t))) tvs  -- | Keep export items with docs. pruneExportItems :: [ExportItem GhcRn] -> [ExportItem GhcRn]@@ -1163,8 +1182,8 @@       where subs    = map fst (expItemSubDocs e)             patsyns = concatMap (getMainDeclBinder . fst) (expItemPats e)             name = case unLoc $ expItemDecl e of-              InstD d -> maybeToList $ M.lookup (getInstLoc d) instMap-              decl    -> getMainDeclBinder decl+              InstD _ d -> maybeToList $ M.lookup (getInstLoc d) instMap+              decl      -> getMainDeclBinder decl     exportName ExportNoDecl {} = [] -- we don't count these as visible, since                                     -- we don't want links to go to them.     exportName _ = []@@ -1208,7 +1227,7 @@     search [] = do       tell ["Cannot find documentation for: $" ++ name]       return Nothing-    search (DocD (DocCommentNamed name' doc) : rest)+    search (DocD _ (DocCommentNamed name' doc) : rest)       | name == name' = return (Just doc)       | otherwise = search rest     search (_other_decl : rest) = search rest
haddock-api/src/Haddock/Interface/LexParseRn.hs view
@@ -1,5 +1,6 @@ {-# OPTIONS_GHC -Wwarn #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ViewPatterns #-}   ----------------------------------------------------------------------------- -- | -- Module      :  Haddock.Interface.LexParseRn@@ -18,17 +19,20 @@   , processModuleHeader   ) where +import Avail+import Control.Arrow+import Control.Monad import Data.List+import Data.Ord import Documentation.Haddock.Doc (metaDocConcat) import DynFlags (languageExtensions) import qualified GHC.LanguageExtensions as LangExt-import FastString import GHC import Haddock.Interface.ParseModuleHeader import Haddock.Parser import Haddock.Types import Name-import Outputable ( showPpr )+import Outputable ( showPpr, showSDoc ) import RdrName import EnumSet import RnEnv (dataTcOccs)@@ -44,14 +48,13 @@     MetaDoc { _meta = Meta Nothing Nothing, _doc = DocEmpty } -> pure Nothing     x -> pure (Just x) -processDocStringParas :: DynFlags -> Maybe Package -> GlobalRdrEnv -> HsDocString-                      -> ErrMsgM (MDoc Name)-processDocStringParas dflags pkg gre (HsDocString fs) =-  overDocF (rename dflags gre) $ parseParas dflags pkg (unpackFS fs)+processDocStringParas :: DynFlags -> Maybe Package -> GlobalRdrEnv -> HsDocString -> ErrMsgM (MDoc Name)+processDocStringParas dflags pkg gre hds =+  overDocF (rename dflags gre) $ parseParas dflags pkg (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 -> Maybe Package -> GlobalRdrEnv -> SafeHaskellMode -> Maybe LHsDocString                     -> ErrMsgM (HaddockModInfo Name, Maybe (MDoc Name))@@ -59,8 +62,8 @@   (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 pkgName str         !descr <- case hmi_description hmi of                     Just hmi_descr -> Just <$> rename dflags gre hmi_descr@@ -96,15 +99,15 @@         -- Generate the choices for the possible kind of thing this         -- is.         let choices = dataTcOccs x-        -- Try to look up all the names in the GlobalRdrEnv that match-        -- the names.-        let names = concatMap (\c -> map gre_name (lookupGRE_RdrName c gre)) choices -        case names of+        -- Lookup any GlobalRdrElts that match the choices.+        case concatMap (\c -> lookupGRE_RdrName c gre) choices of           -- We found no names in the env so we start guessing.           [] ->             case choices of+              -- This shouldn't happen as 'dataTcOccs' always returns at least its input.               [] -> pure (DocMonospaced (DocString (showPpr dflags x)))+               -- There was nothing in the environment so we need to               -- pick some default from what's available to us. We               -- diverge here from the old way where we would default@@ -113,17 +116,15 @@               -- type constructor names (such as in #253). So now we               -- only get type constructor links if they are actually               -- in scope.-              a:_ -> pure (outOfScope dflags a)+              a:_ -> outOfScope dflags a            -- There is only one name in the environment that matches so           -- use it.-          [a] -> pure (DocIdentifier a)-          -- But when there are multiple names available, default to-          -- type constructors: somewhat awfully GHC returns the-          -- values in the list positionally.-          a:b:_ | isTyConName a -> pure (DocIdentifier a)-                | otherwise -> pure (DocIdentifier b)+          [a] -> pure (DocIdentifier (gre_name a)) +          -- There are multiple names available.+          gres -> ambiguous dflags x gres+       DocWarning doc -> DocWarning <$> rn doc       DocEmphasis doc -> DocEmphasis <$> rn doc       DocBold doc -> DocBold <$> rn doc@@ -154,12 +155,47 @@ -- users shouldn't rely on this doing the right thing. See tickets -- #253 and #375 on the confusion this causes depending on which -- default we pick in 'rename'.-outOfScope :: DynFlags -> RdrName -> Doc a+outOfScope :: DynFlags -> RdrName -> ErrMsgM (Doc a) outOfScope dflags x =   case x of-    Unqual occ -> monospaced occ-    Qual mdl occ -> DocIdentifierUnchecked (mdl, occ)-    Orig _ occ -> monospaced occ-    Exact name -> monospaced name  -- Shouldn't happen since x is out of scope+    Unqual occ -> warnAndMonospace occ+    Qual mdl occ -> pure (DocIdentifierUnchecked (mdl, occ))+    Orig _ occ -> warnAndMonospace occ+    Exact name -> warnAndMonospace name  -- Shouldn't happen since x is out of scope   where+    warnAndMonospace a = do+      tell ["Warning: '" ++ showPpr dflags a ++ "' is out of scope.\n" +++            "    If you qualify the identifier, haddock can try to link it\n" +++            "    it anyway."]+      pure (monospaced a)     monospaced a = DocMonospaced (DocString (showPpr dflags a))++-- | Handle ambiguous identifiers.+--+-- Prefers local names primarily and type constructors or class names secondarily.+--+-- Emits a warning if the 'GlobalRdrElts's don't belong to the same type or class.+ambiguous :: DynFlags+          -> RdrName+          -> [GlobalRdrElt] -- ^ More than one @gre@s sharing the same `RdrName` above.+          -> ErrMsgM (Doc Name)+ambiguous dflags x gres = do+  let noChildren = map availName (gresToAvailInfo gres)+      dflt = maximumBy (comparing (isLocalName &&& isTyConName)) noChildren+      msg = "Warning: " ++ x_str ++ " is ambiguous. It is defined\n" +++            concatMap (\n -> "    * " ++ defnLoc n ++ "\n") (map gre_name gres) +++            "    You may be able to disambiguate the identifier by qualifying it or\n" +++            "    by hiding some imports.\n" +++            "    Defaulting to " ++ x_str ++ " defined " ++ defnLoc dflt+  -- TODO: Once we have a syntax for namespace qualification (#667) we may also+  -- want to emit a warning when an identifier is a data constructor for a type+  -- of the same name, but not the only constructor.+  -- For example, for @data D = C | D@, someone may want to reference the @D@+  -- constructor.+  when (length noChildren > 1) $ tell [msg]+  pure (DocIdentifier dflt)+  where+    isLocalName (nameSrcLoc -> RealSrcLoc {}) = True+    isLocalName _ = False+    x_str = '\'' : showPpr dflags x ++ "'"+    defnLoc = showSDoc dflags . pprNameDefnLoc
haddock-api/src/Haddock/Interface/Rename.hs view
@@ -21,6 +21,7 @@ import Bag (emptyBag) import GHC hiding (NoLink) import Name+import Outputable ( panic ) import RdrName (RdrName(Exact)) import PrelNames (eqTyCon_RDR) @@ -197,14 +198,15 @@ renameMaybeLKind = traverse renameLKind  renameFamilyResultSig :: LFamilyResultSig GhcRn -> RnM (LFamilyResultSig DocNameI)-renameFamilyResultSig (L loc NoSig)-    = return (L loc NoSig)-renameFamilyResultSig (L loc (KindSig ki))+renameFamilyResultSig (L loc (NoSig _))+    = return (L loc (NoSig noExt))+renameFamilyResultSig (L loc (KindSig _ ki))     = do { ki' <- renameLKind ki-         ; return (L loc (KindSig ki')) }-renameFamilyResultSig (L loc (TyVarSig bndr))+         ; return (L loc (KindSig noExt ki')) }+renameFamilyResultSig (L loc (TyVarSig _ bndr))     = do { bndr' <- renameLTyVarBndr bndr-         ; return (L loc (TyVarSig bndr')) }+         ; return (L loc (TyVarSig noExt bndr')) }+renameFamilyResultSig (L _ (XFamilyResultSig _)) = panic "haddock:renameFamilyResultSig"  renameInjectivityAnn :: LInjectivityAnn GhcRn -> RnM (LInjectivityAnn DocNameI) renameInjectivityAnn (L loc (InjectivityAnn lhs rhs))@@ -221,61 +223,60 @@   HsForAllTy { hst_bndrs = tyvars, hst_body = ltype } -> do     tyvars'   <- mapM renameLTyVarBndr tyvars     ltype'    <- renameLType ltype-    return (HsForAllTy { hst_bndrs = tyvars', hst_body = ltype' })+    return (HsForAllTy { hst_xforall = NoExt, hst_bndrs = tyvars', hst_body = ltype' })    HsQualTy { hst_ctxt = lcontext , hst_body = ltype } -> do     lcontext' <- renameLContext lcontext     ltype'    <- renameLType ltype-    return (HsQualTy { hst_ctxt = lcontext', hst_body = ltype' })+    return (HsQualTy { hst_xqual = NoExt, hst_ctxt = lcontext', hst_body = ltype' }) -  HsTyVar ip (L l n) -> return . HsTyVar ip . L l =<< rename n-  HsBangTy b ltype -> return . HsBangTy b =<< renameLType ltype+  HsTyVar _ ip (L l n) -> return . HsTyVar NoExt ip . L l =<< rename n+  HsBangTy _ b ltype -> return . HsBangTy NoExt b =<< renameLType ltype -  HsAppTy a b -> do+  HsStarTy _ isUni -> return (HsStarTy NoExt isUni)++  HsAppTy _ a b -> do     a' <- renameLType a     b' <- renameLType b-    return (HsAppTy a' b')+    return (HsAppTy NoExt a' b') -  HsFunTy a b -> do+  HsFunTy _ a b -> do     a' <- renameLType a     b' <- renameLType b-    return (HsFunTy a' b')+    return (HsFunTy NoExt a' b') -  HsListTy ty -> return . HsListTy =<< renameLType ty-  HsPArrTy ty -> return . HsPArrTy =<< renameLType ty-  HsIParamTy n ty -> liftM (HsIParamTy n) (renameLType ty)-  HsEqTy ty1 ty2 -> liftM2 HsEqTy (renameLType ty1) (renameLType ty2)+  HsListTy _ ty -> return . (HsListTy NoExt) =<< renameLType ty+  HsIParamTy _ n ty -> liftM (HsIParamTy NoExt n) (renameLType ty) -  HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts-  HsSumTy ts -> HsSumTy <$> mapM renameLType ts+  HsTupleTy _ b ts -> return . HsTupleTy NoExt b =<< mapM renameLType ts+  HsSumTy _ ts -> HsSumTy NoExt <$> mapM renameLType ts -  HsOpTy a (L loc op) b -> do+  HsOpTy _ a (L loc op) b -> do     op' <- rename op     a'  <- renameLType a     b'  <- renameLType b-    return (HsOpTy a' (L loc op') b')+    return (HsOpTy NoExt a' (L loc op') b') -  HsParTy ty -> return . HsParTy =<< renameLType ty+  HsParTy _ ty -> return . (HsParTy NoExt) =<< renameLType ty -  HsKindSig ty k -> do+  HsKindSig _ ty k -> do     ty' <- renameLType ty     k' <- renameLKind k-    return (HsKindSig ty' k')+    return (HsKindSig NoExt ty' k') -  HsDocTy ty doc -> do+  HsDocTy _ ty doc -> do     ty' <- renameLType ty     doc' <- renameLDocHsSyn doc-    return (HsDocTy ty' doc')+    return (HsDocTy NoExt ty' doc') -  HsTyLit x -> return (HsTyLit x)+  HsTyLit _ x -> return (HsTyLit NoExt x) -  HsRecTy a               -> HsRecTy <$> mapM renameConDeclFieldField a-  HsCoreTy a              -> pure (HsCoreTy a)+  HsRecTy _ a               -> HsRecTy NoExt <$> mapM renameConDeclFieldField a+  (XHsType (NHsCoreTy a))   -> pure (XHsType (NHsCoreTy a))   HsExplicitListTy i a b  -> HsExplicitListTy i a <$> mapM renameLType b   HsExplicitTupleTy a b   -> HsExplicitTupleTy a <$> mapM renameLType b-  HsSpliceTy s _          -> renameHsSpliceTy s+  HsSpliceTy _ s          -> renameHsSpliceTy s   HsWildCardTy a          -> HsWildCardTy <$> renameWildCardInfo a-  HsAppsTy _              -> error "renameType: HsAppsTy"  -- | Rename splices, but _only_ those that turn out to be for types. -- I think this is actually safe for our possible inputs:@@ -284,32 +285,34 @@ --  * the input is typechecked, and only 'HsSplicedTy' should get through that -- renameHsSpliceTy :: HsSplice GhcRn -> RnM (HsType DocNameI)-renameHsSpliceTy (HsSpliced _ (HsSplicedTy t)) = renameType t-renameHsSpliceTy (HsSpliced _ _) = error "renameHsSpliceTy: not an HsSplicedTy"+renameHsSpliceTy (HsSpliced _ _ (HsSplicedTy t)) = renameType t+renameHsSpliceTy (HsSpliced _ _ _) = error "renameHsSpliceTy: not an HsSplicedTy" renameHsSpliceTy _ = error "renameHsSpliceTy: not an HsSpliced"  renameLHsQTyVars :: LHsQTyVars GhcRn -> RnM (LHsQTyVars DocNameI)-renameLHsQTyVars (HsQTvs { hsq_implicit = _, hsq_explicit = tvs })+renameLHsQTyVars (HsQTvs { hsq_explicit = tvs })   = do { tvs' <- mapM renameLTyVarBndr tvs-       ; return (HsQTvs { hsq_implicit = error "haddock:renameLHsQTyVars", hsq_explicit = tvs', hsq_dependent = error "haddock:renameLHsQTyVars" }) }-                -- This is rather bogus, but I'm not sure what else to do+       ; return (HsQTvs { hsq_ext = noExt+                        , hsq_explicit = tvs' }) }+renameLHsQTyVars (XLHsQTyVars _) = panic "haddock:renameLHsQTyVars"  renameLTyVarBndr :: LHsTyVarBndr GhcRn -> RnM (LHsTyVarBndr DocNameI)-renameLTyVarBndr (L loc (UserTyVar (L l n)))+renameLTyVarBndr (L loc (UserTyVar x (L l n)))   = do { n' <- rename n-       ; return (L loc (UserTyVar (L l n'))) }-renameLTyVarBndr (L loc (KindedTyVar (L lv n) kind))+       ; return (L loc (UserTyVar x (L l n'))) }+renameLTyVarBndr (L loc (KindedTyVar x (L lv n) kind))   = do { n' <- rename n        ; kind' <- renameLKind kind-       ; return (L loc (KindedTyVar (L lv n') kind')) }+       ; return (L loc (KindedTyVar x (L lv n') kind')) }+renameLTyVarBndr (L _ (XTyVarBndr _ )) = error "haddock:renameLTyVarBndr"  renameLContext :: Located [LHsType GhcRn] -> RnM (Located [LHsType DocNameI]) renameLContext (L loc context) = do   context' <- mapM renameLType context   return (L loc context') -renameWildCardInfo :: HsWildCardInfo GhcRn -> RnM (HsWildCardInfo DocNameI)-renameWildCardInfo (AnonWildCard  (L l name)) = AnonWildCard . L l <$> rename name+renameWildCardInfo :: HsWildCardInfo -> RnM HsWildCardInfo+renameWildCardInfo (AnonWildCard  (L l name)) = return (AnonWildCard (L l name))  renameInstHead :: InstHead GhcRn -> RnM (InstHead DocNameI) renameInstHead InstHead {..} = do@@ -340,21 +343,21 @@  renameDecl :: HsDecl GhcRn -> RnM (HsDecl DocNameI) renameDecl decl = case decl of-  TyClD d -> do+  TyClD _ d -> do     d' <- renameTyClD d-    return (TyClD d')-  SigD s -> do+    return (TyClD noExt d')+  SigD _ s -> do     s' <- renameSig s-    return (SigD s')-  ForD d -> do+    return (SigD noExt s')+  ForD _ d -> do     d' <- renameForD d-    return (ForD d')-  InstD d -> do+    return (ForD noExt d')+  InstD _ d -> do     d' <- renameInstD d-    return (InstD d')-  DerivD d -> do+    return (InstD noExt d')+  DerivD _ d -> do     d' <- renameDerivD d-    return (DerivD d')+    return (DerivD noExt d')   _ -> error "renameDecl"  renameLThing :: (a GhcRn -> RnM (a DocNameI)) -> Located (a GhcRn) -> RnM (Located (a DocNameI))@@ -365,19 +368,21 @@ --  TyFamily flav lname ltyvars kind tckind -> do   FamDecl { tcdFam = decl } -> do     decl' <- renameFamilyDecl decl-    return (FamDecl { tcdFam = decl' })+    return (FamDecl { tcdFExt = noExt, tcdFam = decl' }) -  SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdRhs = rhs, tcdFVs = _fvs } -> do+  SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdRhs = rhs } -> do     lname'    <- renameL lname     tyvars'   <- renameLHsQTyVars tyvars     rhs'     <- renameLType rhs-    return (SynDecl { tcdLName = lname', tcdTyVars = tyvars', tcdFixity = fixity, tcdRhs = rhs', tcdFVs = placeHolderNames })+    return (SynDecl { tcdSExt = noExt, tcdLName = lname', tcdTyVars = tyvars'+                    , tcdFixity = fixity, tcdRhs = rhs' }) -  DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdDataDefn = defn, tcdFVs = _fvs } -> do+  DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdDataDefn = defn } -> do     lname'    <- renameL lname     tyvars'   <- renameLHsQTyVars tyvars     defn'     <- renameDataDefn defn-    return (DataDecl { tcdLName = lname', tcdTyVars = tyvars', tcdFixity = fixity, tcdDataDefn = defn', tcdDataCusk = PlaceHolder, tcdFVs = placeHolderNames })+    return (DataDecl { tcdDExt = noExt, tcdLName = lname', tcdTyVars = tyvars'+                     , tcdFixity = fixity, tcdDataDefn = defn' })    ClassDecl { tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars, tcdFixity = fixity             , tcdFDs = lfundeps, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs } -> do@@ -392,7 +397,8 @@     return (ClassDecl { tcdCtxt = lcontext', tcdLName = lname', tcdTyVars = ltyvars'                       , tcdFixity = fixity                       , tcdFDs = lfundeps', tcdSigs = lsigs', tcdMeths= emptyBag-                      , tcdATs = ats', tcdATDefs = at_defs', tcdDocs = [], tcdFVs = placeHolderNames })+                      , tcdATs = ats', tcdATDefs = at_defs', tcdDocs = [], tcdCExt = NoExt })+  XTyClDecl _ -> panic "haddock:renameTyClD"    where     renameLFunDep (L loc (xs, ys)) = do@@ -413,11 +419,12 @@     ltyvars'     <- renameLHsQTyVars ltyvars     result'      <- renameFamilyResultSig result     injectivity' <- renameMaybeInjectivityAnn injectivity-    return (FamilyDecl { fdInfo = info', fdLName = lname'+    return (FamilyDecl { fdExt = noExt, fdInfo = info', fdLName = lname'                        , fdTyVars = ltyvars'                        , fdFixity = fixity                        , fdResultSig = result'                        , fdInjectivityAnn = injectivity' })+renameFamilyDecl (XFamilyDecl _) = panic "renameFamilyDecl"   renamePseudoFamilyDecl :: PseudoFamilyDecl GhcRn@@ -443,108 +450,130 @@     k'        <- renameMaybeLKind k     cons'     <- mapM (mapM renameCon) cons     -- I don't think we need the derivings, so we return Nothing-    return (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext', dd_cType = cType+    return (HsDataDefn { dd_ext = noExt+                       , dd_ND = nd, dd_ctxt = lcontext', dd_cType = cType                        , dd_kindSig = k', dd_cons = cons'                        , dd_derivs = noLoc [] })+renameDataDefn (XHsDataDefn _) = panic "haddock:renameDataDefn"  renameCon :: ConDecl GhcRn -> RnM (ConDecl DocNameI)-renameCon decl@(ConDeclH98 { con_name = lname, con_qvars = ltyvars-                           , con_cxt = lcontext, con_details = details+renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars+                           , con_mb_cxt = lcontext, con_args = details                            , con_doc = mbldoc }) = do       lname'    <- renameL lname-      ltyvars'  <- traverse renameLHsQTyVars ltyvars+      ltyvars'  <- mapM renameLTyVarBndr ltyvars       lcontext' <- traverse renameLContext lcontext       details'  <- renameDetails details       mbldoc'   <- mapM renameLDocHsSyn mbldoc-      return (decl { con_name = lname', con_qvars = ltyvars', con_cxt = lcontext'-                   , con_details = details', con_doc = mbldoc' })--  where-    renameDetails (RecCon (L l fields)) = do-      fields' <- mapM renameConDeclFieldField fields-      return (RecCon (L l fields'))-    renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps-    renameDetails (InfixCon a b) = do-      a' <- renameLType a-      b' <- renameLType b-      return (InfixCon a' b')+      return (decl { con_ext = noExt, con_name = lname', con_ex_tvs = ltyvars'+                   , con_mb_cxt = lcontext'+                   , con_args = details', con_doc = mbldoc' }) -renameCon decl@(ConDeclGADT { con_names = lnames-                            , con_type = lty+renameCon decl@(ConDeclGADT { con_names = lnames, con_qvars = ltyvars+                            , con_mb_cxt = lcontext, con_args = details+                            , con_res_ty = res_ty                             , con_doc = mbldoc }) = do       lnames'   <- mapM renameL lnames-      lty'      <- renameLSigType lty+      ltyvars'  <- renameLHsQTyVars ltyvars+      lcontext' <- traverse renameLContext lcontext+      details'  <- renameDetails details+      res_ty'   <- renameLType res_ty       mbldoc'   <- mapM renameLDocHsSyn mbldoc-      return (decl { con_names = lnames'-                   , con_type = lty', con_doc = mbldoc' })+      return (decl { con_g_ext = noExt, con_names = lnames', con_qvars = ltyvars'+                   , con_mb_cxt = lcontext', con_args = details'+                   , con_res_ty = res_ty', con_doc = mbldoc' })+renameCon (XConDecl _) = panic "haddock:renameCon" +renameDetails :: HsConDeclDetails GhcRn -> RnM (HsConDeclDetails DocNameI)+renameDetails (RecCon (L l fields)) = do+  fields' <- mapM renameConDeclFieldField fields+  return (RecCon (L l fields'))+renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps+renameDetails (InfixCon a b) = do+  a' <- renameLType a+  b' <- renameLType b+  return (InfixCon a' b')+ renameConDeclFieldField :: LConDeclField GhcRn -> RnM (LConDeclField DocNameI)-renameConDeclFieldField (L l (ConDeclField names t doc)) = do+renameConDeclFieldField (L l (ConDeclField _ names t doc)) = do   names' <- mapM renameLFieldOcc names   t'   <- renameLType t   doc' <- mapM renameLDocHsSyn doc-  return $ L l (ConDeclField names' t' doc')+  return $ L l (ConDeclField noExt names' t' doc')+renameConDeclFieldField (L _ (XConDeclField _)) = panic "haddock:renameConDeclFieldField"  renameLFieldOcc :: LFieldOcc GhcRn -> RnM (LFieldOcc DocNameI)-renameLFieldOcc (L l (FieldOcc lbl sel)) = do+renameLFieldOcc (L l (FieldOcc sel lbl)) = do   sel' <- rename sel-  return $ L l (FieldOcc lbl sel')+  return $ L l (FieldOcc sel' lbl)+renameLFieldOcc (L _ (XFieldOcc _)) = error "haddock:renameLFieldOcc"  renameSig :: Sig GhcRn -> RnM (Sig DocNameI) renameSig sig = case sig of-  TypeSig lnames ltype -> do+  TypeSig _ lnames ltype -> do     lnames' <- mapM renameL lnames     ltype' <- renameLSigWcType ltype-    return (TypeSig lnames' ltype')-  ClassOpSig is_default lnames sig_ty -> do+    return (TypeSig noExt lnames' ltype')+  ClassOpSig _ is_default lnames sig_ty -> do     lnames' <- mapM renameL lnames     ltype' <- renameLSigType sig_ty-    return (ClassOpSig is_default lnames' ltype')-  PatSynSig lnames sig_ty -> do+    return (ClassOpSig noExt is_default lnames' ltype')+  PatSynSig _ lnames sig_ty -> do     lnames' <- mapM renameL lnames     sig_ty' <- renameLSigType sig_ty-    return $ PatSynSig lnames' sig_ty'-  FixSig (FixitySig lnames fixity) -> do+    return $ PatSynSig noExt lnames' sig_ty'+  FixSig _ (FixitySig _ lnames fixity) -> do     lnames' <- mapM renameL lnames-    return $ FixSig (FixitySig lnames' fixity)-  MinimalSig src (L l s) -> do+    return $ FixSig noExt (FixitySig noExt lnames' fixity)+  MinimalSig _ src (L l s) -> do     s' <- traverse renameL s-    return $ MinimalSig src (L l s')+    return $ MinimalSig noExt src (L l s')   -- we have filtered out all other kinds of signatures in Interface.Create   _ -> error "expected TypeSig"   renameForD :: ForeignDecl GhcRn -> RnM (ForeignDecl DocNameI)-renameForD (ForeignImport lname ltype co x) = do+renameForD (ForeignImport _ lname ltype x) = do   lname' <- renameL lname   ltype' <- renameLSigType ltype-  return (ForeignImport lname' ltype' co x)-renameForD (ForeignExport lname ltype co x) = do+  return (ForeignImport noExt lname' ltype' x)+renameForD (ForeignExport _ lname ltype x) = do   lname' <- renameL lname   ltype' <- renameLSigType ltype-  return (ForeignExport lname' ltype' co x)+  return (ForeignExport noExt lname' ltype' x)+renameForD (XForeignDecl _) = panic "haddock:renameForD"   renameInstD :: InstDecl GhcRn -> RnM (InstDecl DocNameI) renameInstD (ClsInstD { cid_inst = d }) = do   d' <- renameClsInstD d-  return (ClsInstD { cid_inst = d' })+  return (ClsInstD { cid_d_ext = noExt, cid_inst = d' }) renameInstD (TyFamInstD { tfid_inst = d }) = do   d' <- renameTyFamInstD d-  return (TyFamInstD { tfid_inst = d' })+  return (TyFamInstD { tfid_ext = noExt, tfid_inst = d' }) renameInstD (DataFamInstD { dfid_inst = d }) = do   d' <- renameDataFamInstD d-  return (DataFamInstD { dfid_inst = d' })+  return (DataFamInstD { dfid_ext = noExt, dfid_inst = d' })+renameInstD (XInstDecl _) = panic "haddock:renameInstD"  renameDerivD :: DerivDecl GhcRn -> RnM (DerivDecl DocNameI) renameDerivD (DerivDecl { deriv_type = ty                         , deriv_strategy = strat                         , deriv_overlap_mode = omode }) = do-  ty' <- renameLSigType ty-  return (DerivDecl { deriv_type = ty'-                    , deriv_strategy = strat+  ty'    <- renameLSigWcType ty+  strat' <- mapM (mapM renameDerivStrategy) strat+  return (DerivDecl { deriv_ext = noExt+                    , deriv_type = ty'+                    , 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@@ -552,10 +581,11 @@   ltype' <- renameLSigType ltype   lATs'  <- mapM (mapM renameTyFamInstD) lATs   lADTs' <- mapM (mapM renameDataFamInstD) lADTs-  return (ClsInstDecl { cid_overlap_mode = omode+  return (ClsInstDecl { cid_ext = noExt, cid_overlap_mode = omode                       , cid_poly_ty = ltype', cid_binds = emptyBag                       , cid_sigs = []                       , cid_tyfam_insts = lATs', cid_datafam_insts = lADTs' })+renameClsInstD (XClsInstDecl _) = panic "haddock:renameClsInstD"   renameTyFamInstD :: TyFamInstDecl GhcRn -> RnM (TyFamInstDecl DocNameI)@@ -575,10 +605,12 @@       = do { tc' <- renameL tc            ; pats' <- mapM renameLType pats            ; rhs' <- renameLType rhs-           ; return (FamEqn { feqn_tycon  = tc'+           ; return (FamEqn { feqn_ext    = noExt+                            , feqn_tycon  = tc'                             , feqn_pats   = pats'                             , feqn_fixity = fixity                             , feqn_rhs    = rhs' }) }+    rename_ty_fam_eqn (XFamEqn _) = panic "haddock:renameTyFamInstEqn"  renameLTyFamDefltEqn :: LTyFamDefltEqn GhcRn -> RnM (LTyFamDefltEqn DocNameI) renameLTyFamDefltEqn (L loc (FamEqn { feqn_tycon = tc, feqn_pats = tvs@@ -586,10 +618,12 @@   = do { tc'  <- renameL tc        ; tvs' <- renameLHsQTyVars tvs        ; rhs' <- renameLType rhs-       ; return (L loc (FamEqn { feqn_tycon  = tc'+       ; return (L loc (FamEqn { feqn_ext    = noExt+                               , feqn_tycon  = tc'                                , feqn_pats   = tvs'                                , feqn_fixity = fixity                                , feqn_rhs    = rhs' })) }+renameLTyFamDefltEqn (L _ (XFamEqn _)) = panic "haddock:renameLTyFamDefltEqn"  renameDataFamInstD :: DataFamInstDecl GhcRn -> RnM (DataFamInstDecl DocNameI) renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn })@@ -604,10 +638,12 @@       = do { tc' <- renameL tc            ; pats' <- mapM renameLType pats            ; defn' <- renameDataDefn defn-           ; return (FamEqn { feqn_tycon  = tc'+           ; return (FamEqn { feqn_ext    = noExt+                            , feqn_tycon  = tc'                             , feqn_pats   = pats'                             , feqn_fixity = fixity                             , feqn_rhs    = defn' }) }+    rename_data_fam_eqn (XFamEqn _) = panic "haddock:renameDataFamInstD"  renameImplicit :: (in_thing -> RnM out_thing)                -> HsImplicitBndrs GhcRn in_thing@@ -615,8 +651,8 @@ renameImplicit rn_thing (HsIB { hsib_body = thing })   = do { thing' <- rn_thing thing        ; return (HsIB { hsib_body = thing'-                      , hsib_vars = PlaceHolder-                      , hsib_closed = PlaceHolder }) }+                      , hsib_ext = noExt }) }+renameImplicit _ (XHsImplicitBndrs _) = panic "haddock:renameImplicit"  renameWc :: (in_thing -> RnM out_thing)          -> HsWildCardBndrs GhcRn in_thing@@ -624,7 +660,8 @@ renameWc rn_thing (HsWC { hswc_body = thing })   = do { thing' <- rn_thing thing        ; return (HsWC { hswc_body = thing'-                      , hswc_wcs = PlaceHolder }) }+                      , hswc_ext = noExt }) }+renameWc _ (XHsWildCardBndrs _) = panic "haddock:renameWc"  renameDocInstance :: DocInstance GhcRn -> RnM (DocInstance DocNameI) renameDocInstance (inst, idoc, L l n, m) = do
haddock-api/src/Haddock/Interface/Specialize.hs view
@@ -28,20 +28,18 @@ import qualified Data.Set as Set  -- | Instantiate all occurrences of given names with corresponding types.-specialize :: forall name a. (Ord (IdP name), DataId name, NamedThing (IdP name))-            => Data a-            => [(IdP name, HsType name)] -> a -> a+specialize :: Data a => [(Name, HsType GhcRn)] -> a -> a specialize specs = go spec_map0   where-    go :: forall x. Data x => Map (IdP name) (HsType name) -> x -> x-    go spec_map = everywhereButType @name $ mkT $ sugar . strip_kind_sig . specialize_ty_var spec_map+    go :: forall x. Data x => Map Name (HsType GhcRn) -> x -> x+    go spec_map = everywhereButType @Name $ mkT $ sugar . strip_kind_sig . specialize_ty_var spec_map      strip_kind_sig :: HsType name -> HsType name-    strip_kind_sig (HsKindSig (L _ t) _) = t+    strip_kind_sig (HsKindSig _ (L _ t) _) = t     strip_kind_sig typ = typ -    specialize_ty_var :: Map (IdP name) (HsType name) -> HsType name -> HsType name-    specialize_ty_var spec_map (HsTyVar _ (L _ name'))+    specialize_ty_var :: Map Name (HsType GhcRn) -> HsType GhcRn -> HsType GhcRn+    specialize_ty_var spec_map (HsTyVar _ _ (L _ name'))       | Just t <- Map.lookup name' spec_map = t     specialize_ty_var _ typ = typ @@ -54,35 +52,33 @@ -- -- Again, it is just a convenience function around 'specialize'. Note that -- length of type list should be the same as the number of binders.-specializeTyVarBndrs :: (Ord (IdP name), DataId name, NamedThing (IdP name))-                     => Data a-                     => LHsQTyVars name -> [HsType name]+specializeTyVarBndrs :: Data a+                     => LHsQTyVars GhcRn -> [HsType GhcRn]                      -> a -> a specializeTyVarBndrs bndrs typs =     specialize $ zip bndrs' typs   where     bndrs' = map (bname . unLoc) . hsq_explicit $ bndrs-    bname (UserTyVar (L _ name)) = name-    bname (KindedTyVar (L _ name) _) = name+    bname (UserTyVar _ (L _ name)) = name+    bname (KindedTyVar _ (L _ name) _) = name+    bname (XTyVarBndr _) = error "haddock:specializeTyVarBndrs"  -specializePseudoFamilyDecl :: (Ord (IdP name), DataId name, NamedThing (IdP name))-                           => LHsQTyVars name -> [HsType name]-                           -> PseudoFamilyDecl name-                           -> PseudoFamilyDecl name+specializePseudoFamilyDecl :: LHsQTyVars GhcRn -> [HsType GhcRn]+                           -> PseudoFamilyDecl GhcRn+                           -> PseudoFamilyDecl GhcRn specializePseudoFamilyDecl bndrs typs decl =   decl {pfdTyVars = map (specializeTyVarBndrs bndrs typs) (pfdTyVars decl)} -specializeSig :: forall name . (Ord (IdP name), DataId name, SetName (IdP name), NamedThing (IdP name))-              => LHsQTyVars name -> [HsType name]-              -> Sig name-              -> Sig name-specializeSig bndrs typs (TypeSig lnames typ) =-  TypeSig lnames (typ {hswc_body = (hswc_body typ) {hsib_body = noLoc typ'}})+specializeSig :: LHsQTyVars GhcRn -> [HsType GhcRn]+              -> Sig GhcRn+              -> Sig GhcRn+specializeSig bndrs typs (TypeSig _ lnames typ) =+  TypeSig noExt lnames (typ {hswc_body = (hswc_body typ) {hsib_body = noLoc typ'}})   where-    true_type :: HsType name+    true_type :: HsType GhcRn     true_type = unLoc (hsSigWcType typ)-    typ' :: HsType name+    typ' :: HsType GhcRn     typ' = rename fv $ specializeTyVarBndrs bndrs typs true_type     fv = foldr Set.union Set.empty . map freeVariables $ typs specializeSig _ _ sig = sig@@ -90,8 +86,7 @@  -- | Make all details of instance head (signatures, associated types) -- specialized to that particular instance type.-specializeInstHead :: (Ord (IdP name), DataId name, SetName (IdP name), NamedThing (IdP name))-                   => InstHead name -> InstHead name+specializeInstHead :: InstHead GhcRn -> InstHead GhcRn specializeInstHead ihd@InstHead { ihdInstType = clsi@ClassInst { .. }, .. } =     ihd { ihdInstType = instType' }   where@@ -110,27 +105,26 @@ -- and tuple literals resulting in types like @[] a@ or @(,,) a b c@. This -- can be fixed using 'sugar' function, that will turn such types into @[a]@ -- and @(a, b, c)@.-sugar :: forall name. (NamedThing (IdP name), DataId name)-      => HsType name -> HsType name+sugar :: HsType GhcRn -> HsType GhcRn sugar = sugarOperators . sugarTuples . sugarLists -sugarLists :: NamedThing (IdP name) => HsType name -> HsType name-sugarLists (HsAppTy (L _ (HsTyVar _ (L _ name))) ltyp)-    | isBuiltInSyntax name' && strName == "[]" = HsListTy ltyp+sugarLists :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p)+sugarLists (HsAppTy _ (L _ (HsTyVar _ _ (L _ name))) ltyp)+    | isBuiltInSyntax name' && strName == "[]" = HsListTy NoExt ltyp   where     name' = getName name     strName = occNameString . nameOccName $ name' sugarLists typ = typ  -sugarTuples :: NamedThing (IdP name) => HsType name -> HsType name+sugarTuples :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p) sugarTuples typ =     aux [] typ   where-    aux apps (HsAppTy (L _ ftyp) atyp) = aux (atyp:apps) ftyp-    aux apps (HsParTy (L _ typ')) = aux apps typ'-    aux apps (HsTyVar _ (L _ name))-        | isBuiltInSyntax name' && suitable = HsTupleTy HsBoxedTuple apps+    aux apps (HsAppTy _ (L _ ftyp) atyp) = aux (atyp:apps) ftyp+    aux apps (HsParTy _ (L _ typ')) = aux apps typ'+    aux apps (HsTyVar _ _ (L _ name))+        | isBuiltInSyntax name' && suitable = HsTupleTy NoExt HsBoxedTuple apps       where         name' = getName name         strName = occNameString . nameOccName $ name'@@ -140,10 +134,10 @@     aux _ _ = typ  -sugarOperators :: NamedThing (IdP name) => HsType name -> HsType name-sugarOperators (HsAppTy (L _ (HsAppTy (L _ (HsTyVar _ (L l name))) la)) lb)+sugarOperators :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p)+sugarOperators (HsAppTy _ (L _ (HsAppTy _ (L _ (HsTyVar _ _ (L l name))) la)) lb)     | isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb-    | isBuiltInSyntax name' && getOccString name == "(->)" = HsFunTy la lb+    | isBuiltInSyntax name' && getOccString name == "(->)" = HsFunTy NoExt la lb   where     name' = getName name sugarOperators typ = typ@@ -208,15 +202,14 @@   -- | Compute set of free variables of given type.-freeVariables :: forall name. (NamedThing (IdP name), DataId name)-              => HsType name -> Set Name+freeVariables :: HsType GhcRn -> Set Name freeVariables =     everythingWithState Set.empty Set.union query   where-    query term ctx = case cast term :: Maybe (HsType name) of-        Just (HsForAllTy bndrs _) ->+    query term ctx = case cast term :: Maybe (HsType GhcRn) of+        Just (HsForAllTy _ bndrs _) ->             (Set.empty, Set.union ctx (bndrsNames bndrs))-        Just (HsTyVar _ (L _ name))+        Just (HsTyVar _ _ (L _ name))             | getName name `Set.member` ctx -> (Set.empty, ctx)             | otherwise -> (Set.singleton $ getName name, ctx)         _ -> (Set.empty, ctx)@@ -231,8 +224,7 @@ -- different type variable than latter one. Applying 'rename' function -- will fix that type to be visually unambiguous again (making it something -- like @(a -> b0) -> b@).-rename :: (Eq (IdP name), DataId name, SetName (IdP name))-       => Set Name-> HsType name -> HsType name+rename :: Set Name -> HsType GhcRn -> HsType GhcRn rename fv typ = evalState (renameType typ) env   where     env = RenameEnv@@ -252,63 +244,56 @@   }  -renameType :: (Eq (IdP name), SetName (IdP name))-           => HsType name -> Rename (IdP name) (HsType name)-renameType (HsForAllTy bndrs lt) =-    HsForAllTy+renameType :: HsType GhcRn -> Rename (IdP GhcRn) (HsType GhcRn)+renameType (HsForAllTy x bndrs lt) =+    HsForAllTy x         <$> mapM (located renameBinder) bndrs         <*> renameLType lt-renameType (HsQualTy lctxt lt) =-    HsQualTy+renameType (HsQualTy x lctxt lt) =+    HsQualTy x         <$> located renameContext lctxt         <*> renameLType lt-renameType (HsTyVar ip name) = HsTyVar ip <$> located renameName name-renameType (HsAppTy lf la) = HsAppTy <$> renameLType lf <*> renameLType la-renameType (HsFunTy la lr) = HsFunTy <$> renameLType la <*> renameLType lr-renameType (HsListTy lt) = HsListTy <$> renameLType lt-renameType (HsPArrTy lt) = HsPArrTy <$> renameLType lt-renameType (HsTupleTy srt lt) = HsTupleTy srt <$> mapM renameLType lt-renameType (HsSumTy lt) = HsSumTy <$> mapM renameLType lt-renameType (HsOpTy la lop lb) =-    HsOpTy <$> renameLType la <*> located renameName lop <*> renameLType lb-renameType (HsParTy lt) = HsParTy <$> renameLType lt-renameType (HsIParamTy ip lt) = HsIParamTy ip <$> renameLType lt-renameType (HsEqTy la lb) = HsEqTy <$> renameLType la <*> renameLType lb-renameType (HsKindSig lt lk) = HsKindSig <$> renameLType lt <*> pure lk+renameType (HsTyVar x ip name) = HsTyVar x ip <$> located renameName name+renameType t@(HsStarTy _ _) = pure t+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 (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) =+    HsOpTy x <$> renameLType la <*> located renameName lop <*> renameLType lb+renameType (HsParTy x lt) = HsParTy x <$> renameLType lt+renameType (HsIParamTy x ip lt) = HsIParamTy x ip <$> renameLType lt+renameType (HsKindSig x lt lk) = HsKindSig x <$> renameLType lt <*> pure lk renameType t@(HsSpliceTy _ _) = pure t-renameType (HsDocTy lt doc) = HsDocTy <$> renameLType lt <*> pure doc-renameType (HsBangTy bang lt) = HsBangTy bang <$> renameLType lt-renameType t@(HsRecTy _) = pure t-renameType t@(HsCoreTy _) = pure t-renameType (HsExplicitListTy ip ph ltys) =-    HsExplicitListTy ip ph <$> renameLTypes ltys-renameType (HsExplicitTupleTy phs ltys) =-    HsExplicitTupleTy phs <$> renameLTypes ltys-renameType t@(HsTyLit _) = pure t+renameType (HsDocTy x lt doc) = HsDocTy x <$> renameLType lt <*> pure doc+renameType (HsBangTy x bang lt) = HsBangTy x bang <$> renameLType lt+renameType t@(HsRecTy _ _) = pure t+renameType t@(XHsType (NHsCoreTy _)) = pure t+renameType (HsExplicitListTy x ip ltys) =+    HsExplicitListTy x ip <$> renameLTypes ltys+renameType (HsExplicitTupleTy x ltys) =+    HsExplicitTupleTy x <$> renameLTypes ltys+renameType t@(HsTyLit _ _) = pure t renameType (HsWildCardTy wc) = pure (HsWildCardTy wc)-renameType (HsAppsTy _) = error "HsAppsTy: Only used before renaming"  -renameLType :: (Eq (IdP name), SetName (IdP name))-            => LHsType name -> Rename (IdP name) (LHsType name)+renameLType :: LHsType GhcRn -> Rename (IdP GhcRn) (LHsType GhcRn) renameLType = located renameType  -renameLTypes :: (Eq (IdP name), SetName (IdP name))-             => [LHsType name] -> Rename (IdP name) [LHsType name]+renameLTypes :: [LHsType GhcRn] -> Rename (IdP GhcRn) [LHsType GhcRn] renameLTypes = mapM renameLType  -renameContext :: (Eq (IdP name), SetName (IdP name))-              => HsContext name -> Rename (IdP name) (HsContext name)+renameContext :: HsContext GhcRn -> Rename (IdP GhcRn) (HsContext GhcRn) renameContext = renameLTypes -renameBinder :: (Eq (IdP name), SetName (IdP name))-             => HsTyVarBndr name -> Rename (IdP name) (HsTyVarBndr name)-renameBinder (UserTyVar lname) = UserTyVar <$> located renameName lname-renameBinder (KindedTyVar lname lkind) =-  KindedTyVar <$> located renameName lname <*> located renameType lkind-+renameBinder :: HsTyVarBndr GhcRn -> Rename (IdP GhcRn) (HsTyVarBndr GhcRn)+renameBinder (UserTyVar x lname) = UserTyVar x <$> located renameName lname+renameBinder (KindedTyVar x lname lkind) =+  KindedTyVar x <$> located renameName lname <*> located renameType lkind+renameBinder (XTyVarBndr _) = error "haddock:renameBinder"  -- | Core renaming logic. renameName :: (Eq name, SetName name) => name -> Rename name name@@ -363,5 +348,6 @@   tyVarName :: HsTyVarBndr name -> IdP name-tyVarName (UserTyVar name) = unLoc name-tyVarName (KindedTyVar (L _ name) _) = name+tyVarName (UserTyVar _ name) = unLoc name+tyVarName (KindedTyVar _ (L _ name) _) = name+tyVarName (XTyVarBndr _ ) = error "haddock:tyVarName"
haddock-api/src/Haddock/InterfaceFile.hs view
@@ -82,7 +82,7 @@ -- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion] -- binaryInterfaceVersion :: Word16-#if (__GLASGOW_HASKELL__ >= 803) && (__GLASGOW_HASKELL__ < 805)+#if (__GLASGOW_HASKELL__ >= 805) && (__GLASGOW_HASKELL__ < 807) binaryInterfaceVersion = 33  binaryInterfaceVersionCompatibility :: [Word16]
haddock-api/src/Haddock/Types.hs view
@@ -28,6 +28,7 @@ import Control.Exception import Control.Arrow hiding ((<+>)) import Control.DeepSeq+import Control.Monad.IO.Class (MonadIO(..)) import Data.Typeable import Data.Map (Map) import Data.Data (Data)@@ -38,8 +39,6 @@ import GHC hiding (NoLink) import DynFlags (Language) import qualified GHC.LanguageExtensions as LangExt-import Coercion-import NameSet import OccName import Outputable import Control.Applicative (Applicative(..))@@ -347,7 +346,7 @@   | TypeInst  (Maybe (HsType name)) -- ^ Body (right-hand side)   | DataInst (TyClDecl name)        -- ^ Data constructors -instance (SourceTextX a, OutputableBndrId a)+instance (a ~ GhcPass p,OutputableBndrId a)          => Outputable (InstType a) where   ppr (ClassInst { .. }) = text "ClassInst"       <+> ppr clsiCtx@@ -372,7 +371,7 @@     }  -mkPseudoFamilyDecl :: FamilyDecl name -> PseudoFamilyDecl name+mkPseudoFamilyDecl :: FamilyDecl (GhcPass p) -> PseudoFamilyDecl (GhcPass p) mkPseudoFamilyDecl (FamilyDecl { .. }) = PseudoFamilyDecl     { pfdInfo = fdInfo     , pfdLName = fdLName@@ -380,11 +379,13 @@     , pfdKindSig = fdResultSig     }   where-    mkType (KindedTyVar (L loc name) lkind) =-        HsKindSig tvar lkind+    mkType (KindedTyVar _ (L loc name) lkind) =+        HsKindSig NoExt tvar lkind       where-        tvar = L loc (HsTyVar NotPromoted (L loc name))-    mkType (UserTyVar name) = HsTyVar NotPromoted name+        tvar = L loc (HsTyVar NoExt NotPromoted (L loc name))+    mkType (UserTyVar _ name) = HsTyVar NoExt NotPromoted name+    mkType (XTyVarBndr _ ) = panic "haddock:mkPseudoFamilyDecl"+mkPseudoFamilyDecl (XFamilyDecl {}) = panic "haddock:mkPseudoFamilyDecl"   -- | An instance head that may have documentation and a source location.@@ -661,19 +662,83 @@   m >>= k = WriterGhc $ runWriterGhc m >>= \ (a, msgs1) ->                fmap (second (msgs1 ++)) (runWriterGhc (k a)) +instance MonadIO ErrMsgGhc where+  liftIO m = WriterGhc (fmap (\x -> (x, [])) (liftIO m))  ----------------------------------------------------------------------------- -- * Pass sensitive types ----------------------------------------------------------------------------- -type instance PostRn DocNameI NameSet        = PlaceHolder-type instance PostRn DocNameI Fixity         = PlaceHolder-type instance PostRn DocNameI Bool           = PlaceHolder-type instance PostRn DocNameI Name           = DocName-type instance PostRn DocNameI (Located Name) = Located DocName-type instance PostRn DocNameI [Name]         = PlaceHolder-type instance PostRn DocNameI DocName        = DocName+type instance XForAllTy        DocNameI = NoExt+type instance XQualTy          DocNameI = NoExt+type instance XTyVar           DocNameI = NoExt+type instance XStarTy          DocNameI = NoExt+type instance XAppTy           DocNameI = NoExt+type instance XFunTy           DocNameI = NoExt+type instance XListTy          DocNameI = NoExt+type instance XTupleTy         DocNameI = NoExt+type instance XSumTy           DocNameI = NoExt+type instance XOpTy            DocNameI = NoExt+type instance XParTy           DocNameI = NoExt+type instance XIParamTy        DocNameI = NoExt+type instance XKindSig         DocNameI = NoExt+type instance XSpliceTy        DocNameI = NoExt+type instance XDocTy           DocNameI = NoExt+type instance XBangTy          DocNameI = NoExt+type instance XRecTy           DocNameI = NoExt+type instance XExplicitListTy  DocNameI = NoExt+type instance XExplicitTupleTy DocNameI = NoExt+type instance XTyLit           DocNameI = NoExt+type instance XWildCardTy      DocNameI = HsWildCardInfo+type instance XXType           DocNameI = NewHsTypeX -type instance PostTc DocNameI Kind     = PlaceHolder-type instance PostTc DocNameI Type     = PlaceHolder-type instance PostTc DocNameI Coercion = PlaceHolder+type instance XUserTyVar    DocNameI = NoExt+type instance XKindedTyVar  DocNameI = NoExt+type instance XXTyVarBndr   DocNameI = NoExt++type instance XCFieldOcc   DocNameI = DocName+type instance XXFieldOcc   DocNameI = NoExt++type instance XFixitySig   DocNameI = NoExt+type instance XFixSig      DocNameI = NoExt+type instance XPatSynSig   DocNameI = NoExt+type instance XClassOpSig  DocNameI = NoExt+type instance XTypeSig     DocNameI = NoExt+type instance XMinimalSig  DocNameI = NoExt++type instance XForeignExport  DocNameI = NoExt+type instance XForeignImport  DocNameI = NoExt+type instance XConDeclGADT    DocNameI = NoExt+type instance XConDeclH98     DocNameI = NoExt++type instance XDerivD     DocNameI = NoExt+type instance XInstD      DocNameI = NoExt+type instance XForD       DocNameI = NoExt+type instance XSigD       DocNameI = NoExt+type instance XTyClD      DocNameI = NoExt++type instance XNoSig      DocNameI = NoExt+type instance XCKindSig   DocNameI = NoExt+type instance XTyVarSig   DocNameI = NoExt++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+type instance XCHsDataDefn  DocNameI = NoExt+type instance XCFamilyDecl  DocNameI = NoExt+type instance XClassDecl    DocNameI = NoExt+type instance XDataDecl     DocNameI = NoExt+type instance XSynDecl      DocNameI = NoExt+type instance XFamDecl      DocNameI = NoExt++type instance XHsIB      DocNameI _ = NoExt+type instance XHsWC      DocNameI _ = NoExt++type instance XHsQTvs        DocNameI = NoExt+type instance XConDeclField  DocNameI = NoExt+
haddock-api/src/Haddock/Utils.hs view
@@ -62,8 +62,8 @@  import GHC import Name-import NameSet ( emptyNameSet )-import HsTypes (selectorFieldOcc)+import HsTypes (extFieldOcc)+import Outputable ( panic )  import Control.Monad ( liftM ) import Data.Char ( isAlpha, isAlphaNum, isAscii, ord, chr )@@ -131,16 +131,19 @@  addClassContext :: Name -> LHsQTyVars GhcRn -> LSig GhcRn -> LSig GhcRn -- Add the class context to a class-op signature-addClassContext cls tvs0 (L pos (ClassOpSig _ lname ltype))-  = L pos (TypeSig lname (mkEmptySigWcType (go (hsSigType ltype))))+addClassContext cls tvs0 (L pos (ClassOpSig _ _ lname ltype))+  = L pos (TypeSig noExt lname (mkEmptySigWcType (go (hsSigType ltype))))           -- The mkEmptySigWcType is suspicious   where     go (L loc (HsForAllTy { hst_bndrs = tvs, hst_body = ty }))-       = L loc (HsForAllTy { hst_bndrs = tvs, hst_body = go ty })+       = L loc (HsForAllTy { hst_xforall = noExt+                           , hst_bndrs = tvs, hst_body = go ty })     go (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty }))-       = L loc (HsQualTy { hst_ctxt = add_ctxt ctxt, hst_body = ty })+       = L loc (HsQualTy { hst_xqual = noExt+                         , hst_ctxt = add_ctxt ctxt, hst_body = ty })     go (L loc ty)-       = L loc (HsQualTy { hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty })+       = L loc (HsQualTy { hst_xqual = noExt+                         , hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty })      extra_pred = nlHsTyConApp cls (lHsQTyVarsToTypes tvs0)     add_ctxt (L loc preds) = L loc (extra_pred : preds)@@ -149,7 +152,7 @@  lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsType GhcRn] lHsQTyVarsToTypes tvs-  = [ noLoc (HsTyVar NotPromoted (noLoc (hsLTyVarName tv)))+  = [ noLoc (HsTyVar NoExt NotPromoted (noLoc (hsLTyVarName tv)))     | tv <- hsQTvExplicit tvs ]  --------------------------------------------------------------------------------@@ -159,10 +162,10 @@  restrictTo :: [Name] -> LHsDecl GhcRn -> LHsDecl GhcRn restrictTo names (L loc decl) = L loc $ case decl of-  TyClD d | isDataDecl d  ->-    TyClD (d { tcdDataDefn = restrictDataDefn names (tcdDataDefn d) })-  TyClD d | isClassDecl d ->-    TyClD (d { tcdSigs = restrictDecls names (tcdSigs d),+  TyClD x d | isDataDecl d  ->+    TyClD x (d { tcdDataDefn = restrictDataDefn names (tcdDataDefn d) })+  TyClD x d | isClassDecl d ->+    TyClD x (d { tcdSigs = restrictDecls names (tcdSigs d),                tcdATs = restrictATs names (tcdATs d) })   _ -> decl @@ -175,42 +178,28 @@       []    -> defn { dd_ND = DataType, dd_cons = [] }       [con] -> defn { dd_cons = [con] }       _ -> error "Should not happen"+restrictDataDefn _ (XHsDataDefn _) = error "restrictDataDefn"  restrictCons :: [Name] -> [LConDecl GhcRn] -> [LConDecl GhcRn] restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]   where     keep d | any (\n -> n `elem` names) (map unLoc $ getConNames d) =-      case getConDetails h98d of+      case con_args d of         PrefixCon _ -> Just d         RecCon fields           | all field_avail (unL fields) -> Just d-          | otherwise -> Just (h98d { con_details = PrefixCon (field_types (map unL (unL fields))) })+          | otherwise -> Just (d { con_args = PrefixCon (field_types (map unL (unL fields))) })           -- if we have *all* the field names available, then           -- keep the record declaration.  Otherwise degrade to           -- a constructor declaration.  This isn't quite right, but           -- it's the best we can do.         InfixCon _ _ -> Just d       where-        h98d = h98ConDecl d-        h98ConDecl c@ConDeclH98{} = c-        h98ConDecl c@ConDeclGADT{} = c'-          where-            (details,_res_ty,cxt,tvs) = gadtDeclDetails (con_type c)-            c' :: ConDecl GhcRn-            c' = ConDeclH98-                   { con_name = head (con_names c)-                   , con_qvars = Just $ HsQTvs { hsq_implicit = mempty-                                               , hsq_explicit = tvs-                                               , hsq_dependent = emptyNameSet }-                   , con_cxt = Just cxt-                   , con_details = details-                   , con_doc = con_doc c-                   }-         field_avail :: LConDeclField GhcRn -> Bool-        field_avail (L _ (ConDeclField fs _ _))-            = all (\f -> selectorFieldOcc (unLoc f) `elem` names) fs-        field_types flds = [ t | ConDeclField _ t _ <- flds ]+        field_avail (L _ (ConDeclField _ fs _ _))+            = all (\f -> extFieldOcc (unLoc f) `elem` names) fs+        field_avail (L _ (XConDeclField _)) = panic "haddock:field_avail"+        field_types flds = [ t | ConDeclField _ _ t _ <- flds ]      keep _ = Nothing @@ -221,13 +210,14 @@ restrictATs :: [Name] -> [LFamilyDecl GhcRn] -> [LFamilyDecl GhcRn] restrictATs names ats = [ at | at <- ats , unL (fdLName (unL at)) `elem` names ] -emptyHsQTvs :: LHsQTyVars Name+emptyHsQTvs :: LHsQTyVars GhcRn -- This function is here, rather than in HsTypes, because it *renamed*, but -- does not necessarily have all the rigt kind variables.  It is used -- in Haddock just for printing, so it doesn't matter-emptyHsQTvs = HsQTvs { hsq_implicit = error "haddock:emptyHsQTvs"-                     , hsq_explicit = []-                     , hsq_dependent = error "haddock:emptyHsQTvs" }+emptyHsQTvs = HsQTvs { hsq_ext = HsQTvsRn+                       { hsq_implicit = error "haddock:emptyHsQTvs"+                       , hsq_dependent = error "haddock:emptyHsQTvs" }+                     , hsq_explicit = [] }   --------------------------------------------------------------------------------
haddock-library/src/Documentation/Haddock/Parser.hs view
@@ -16,27 +16,35 @@ -- to be -- -- @'toRegular' . '_doc' . 'parseParas'@-module Documentation.Haddock.Parser ( parseString, parseParas-                                    , overIdentifier, toRegular, Identifier-                                    ) where+module Documentation.Haddock.Parser (+  parseString,+  parseParas,+  overIdentifier,+  toRegular,+  Identifier+) where  import           Control.Applicative import           Control.Arrow (first) import           Control.Monad-import qualified Data.ByteString.Char8 as BS-import           Data.Char (chr, isUpper, isAlpha, isAlphaNum)-import           Data.List (stripPrefix, intercalate, unfoldr, elemIndex)+import           Data.Char (chr, isUpper, isAlpha, isAlphaNum, isSpace)+import           Data.List (intercalate, unfoldr, elemIndex, notElem) import           Data.Maybe (fromMaybe, mapMaybe) import           Data.Monoid import qualified Data.Set as Set import           Documentation.Haddock.Doc-import           Documentation.Haddock.Parser.Monad hiding (take, endOfLine)+import           Documentation.Haddock.Parser.Monad import           Documentation.Haddock.Parser.Util import           Documentation.Haddock.Types-import           Documentation.Haddock.Utf8 import           Prelude hiding (takeWhile) import qualified Prelude as P +import qualified Text.Parsec as Parsec+import           Text.Parsec (try)++import qualified Data.Text as T+import           Data.Text (Text)+ #if MIN_VERSION_base(4,9,0) import           Text.Read.Lex                      (isSymbolChar) #else@@ -56,7 +64,7 @@     ModifierSymbol       -> True     OtherSymbol          -> True     DashPunctuation      -> True-    OtherPunctuation     -> not (c `elem` ("'\"" :: String))+    OtherPunctuation     -> c `notElem` ("'\"" :: String)     ConnectorPunctuation -> c /= '_'     _                    -> False   where@@ -109,8 +117,14 @@     g (DocHeader (Header l x)) = DocHeader . Header l $ g x     g (DocTable (Table h b)) = DocTable (Table (map (fmap g) h) (map (fmap g) b)) -parse :: Parser a -> BS.ByteString -> (ParserState, a)-parse p = either err id . parseOnly (p <* endOfInput)++choice' :: [Parser a] -> Parser a+choice' [] = empty+choice' [p] = p+choice' (p : ps) = try p <|> choice' ps++parse :: Parser a -> Text -> (ParserState, a)+parse p = either err id . parseOnly (p <* Parsec.eof)   where     err = error . ("Haddock.Parser.parse: " ++) @@ -127,31 +141,46 @@                         }  parseParasState :: String -> (ParserState, DocH mod Identifier)-parseParasState =-    parse (p <* skipSpace) . encodeUtf8 . (++ "\n") . filter (/= '\r')+parseParasState = parse (emptyLines *> p) . T.pack . (++ "\n") . filter (/= '\r')   where     p :: Parser (DocH mod Identifier)-    p = docConcat <$> paragraph `sepBy` many (skipHorizontalSpace *> "\n")+    p = docConcat <$> many (paragraph <* emptyLines) +    emptyLines :: Parser ()+    emptyLines = void $ many (try (skipHorizontalSpace *> "\n"))+ parseParagraphs :: String -> Parser (DocH mod Identifier) parseParagraphs input = case parseParasState input of-  (state, a) -> setParserState state >> return a+  (state, a) -> Parsec.putState state *> pure a --- | Parse a text paragraph. Actually just a wrapper over 'parseStringBS' which--- drops leading whitespace and encodes the string to UTF8 first.+-- | Variant of 'parseText' for 'String' instead of 'Text' parseString :: String -> DocH mod Identifier-parseString = parseStringBS . encodeUtf8 . dropWhile isSpace . filter (/= '\r')+parseString = parseText . T.pack -parseStringBS :: BS.ByteString -> DocH mod Identifier-parseStringBS = snd . parse p+-- | Parse a text paragraph. Actually just a wrapper over 'parseParagraph' which+-- drops leading whitespace.+parseText :: Text -> DocH mod Identifier+parseText = parseParagraph . T.dropWhile isSpace . T.filter (/= '\r')++parseParagraph :: Text -> DocH mod Identifier+parseParagraph = snd . parse p   where     p :: Parser (DocH mod Identifier)-    p = docConcat <$> many (monospace <|> anchor <|> identifier <|> moduleName-                            <|> picture <|> mathDisplay <|> mathInline-                            <|> markdownImage-                            <|> hyperlink <|> bold-                            <|> emphasis <|> encodedChar <|> string'-                            <|> skipSpecialChar)+    p = docConcat <$> many (choice' [ monospace+                                    , anchor+                                    , identifier+                                    , moduleName+                                    , picture+                                    , mathDisplay+                                    , mathInline+                                    , markdownImage+                                    , hyperlink+                                    , bold+                                    , emphasis+                                    , encodedChar+                                    , string'+                                    , skipSpecialChar+                                    ])  -- | Parses and processes -- <https://en.wikipedia.org/wiki/Numeric_character_reference Numeric character references>@@ -175,7 +204,7 @@ -- to ensure that we have already given a chance to more meaningful parsers -- before capturing their characers. string' :: Parser (DocH mod a)-string' = DocString . unescape . decodeUtf8 <$> takeWhile1_ (notInClass specialChar)+string' = DocString . unescape . T.unpack <$> takeWhile1_ (`notElem` specialChar)   where     unescape "" = ""     unescape ('\\':x:xs) = x : unescape xs@@ -185,45 +214,45 @@ -- This is done to skip over any special characters belonging to other -- elements but which were not deemed meaningful at their positions. skipSpecialChar :: Parser (DocH mod a)-skipSpecialChar = DocString . return <$> satisfy (inClass specialChar)+skipSpecialChar = DocString . return <$> Parsec.oneOf specialChar  -- | Emphasis parser. -- -- >>> parseString "/Hello world/" -- DocEmphasis (DocString "Hello world") emphasis :: Parser (DocH mod Identifier)-emphasis = DocEmphasis . parseStringBS <$>-  mfilter ('\n' `BS.notElem`) ("/" *> takeWhile1_ (/= '/') <* "/")+emphasis = DocEmphasis . parseParagraph <$>+  disallowNewline ("/" *> takeWhile1_ (/= '/') <* "/")  -- | Bold parser. -- -- >>> parseString "__Hello world__" -- DocBold (DocString "Hello world") bold :: Parser (DocH mod Identifier)-bold = DocBold . parseStringBS <$> disallowNewline ("__" *> takeUntil "__")+bold = DocBold . parseParagraph <$> disallowNewline ("__" *> takeUntil "__") -disallowNewline :: Parser BS.ByteString -> Parser BS.ByteString-disallowNewline = mfilter ('\n' `BS.notElem`)+disallowNewline :: Parser Text -> Parser Text+disallowNewline = mfilter (T.all (/= '\n'))  -- | Like `takeWhile`, but unconditionally take escaped characters.-takeWhile_ :: (Char -> Bool) -> Parser BS.ByteString-takeWhile_ p = scan False p_+takeWhile_ :: (Char -> Bool) -> Parser Text+takeWhile_ p = scan p_ False   where     p_ escaped c       | escaped = Just False       | not $ p c = Nothing       | otherwise = Just (c == '\\') --- | Like `takeWhile1`, but unconditionally take escaped characters.-takeWhile1_ :: (Char -> Bool) -> Parser BS.ByteString-takeWhile1_ = mfilter (not . BS.null) . takeWhile_+-- | Like 'takeWhile1', but unconditionally take escaped characters.+takeWhile1_ :: (Char -> Bool) -> Parser Text+takeWhile1_ = mfilter (not . T.null) . takeWhile_  -- | Text anchors to allow for jumping around the generated documentation. -- -- >>> parseString "#Hello world#" -- DocAName "Hello world" anchor :: Parser (DocH mod a)-anchor = DocAName . decodeUtf8 <$>+anchor = DocAName . T.unpack <$>          disallowNewline ("#" *> takeWhile1_ (/= '#') <* "#")  -- | Monospaced strings.@@ -231,7 +260,7 @@ -- >>> parseString "@cruel@" -- DocMonospaced (DocString "cruel") monospace :: Parser (DocH mod Identifier)-monospace = DocMonospaced . parseStringBS+monospace = DocMonospaced . parseParagraph             <$> ("@" *> takeWhile1_ (/= '@') <* "@")  -- | Module names.@@ -239,14 +268,14 @@ -- Note that we allow '#' and '\' to support anchors (old style anchors are of -- the form "SomeModule\#anchor"). moduleName :: Parser (DocH mod a)-moduleName = DocModule <$> (char '"' *> modid <* char '"')+moduleName = DocModule <$> ("\"" *> modid <* "\"")   where-    modid = intercalate "." <$> conid `sepBy1` "."+    modid = intercalate "." <$> conid `Parsec.sepBy1` "."     conid = (:)-      <$> satisfyUnicode (\c -> isAlpha c && isUpper c)-      <*> many (satisfyUnicode conChar <|> char '\\' <|> char '#')+      <$> Parsec.satisfy (\c -> isAlpha c && isUpper c)+      <*> many (conChar <|> Parsec.oneOf "\\#") -    conChar c = isAlphaNum c || c == '_'+    conChar = Parsec.alphaNum <|> Parsec.char '_'  -- | Picture parser, surrounded by \<\< and \>\>. It's possible to specify -- a title for the picture.@@ -256,7 +285,7 @@ -- >>> parseString "<<hello.png world>>" -- DocPic (Picture {pictureUri = "hello.png", pictureTitle = Just "world"}) picture :: Parser (DocH mod a)-picture = DocPic . makeLabeled Picture . decodeUtf8+picture = DocPic . makeLabeled Picture           <$> disallowNewline ("<<" *> takeUntil ">>")  -- | Inline math parser, surrounded by \\( and \\).@@ -264,7 +293,7 @@ -- >>> parseString "\\(\\int_{-\\infty}^{\\infty} e^{-x^2/2} = \\sqrt{2\\pi}\\)" -- DocMathInline "\\int_{-\\infty}^{\\infty} e^{-x^2/2} = \\sqrt{2\\pi}" mathInline :: Parser (DocH mod a)-mathInline = DocMathInline . decodeUtf8+mathInline = DocMathInline . T.unpack               <$> disallowNewline  ("\\(" *> takeUntil "\\)")  -- | Display math parser, surrounded by \\[ and \\].@@ -272,7 +301,7 @@ -- >>> parseString "\\[\\int_{-\\infty}^{\\infty} e^{-x^2/2} = \\sqrt{2\\pi}\\]" -- DocMathDisplay "\\int_{-\\infty}^{\\infty} e^{-x^2/2} = \\sqrt{2\\pi}" mathDisplay :: Parser (DocH mod a)-mathDisplay = DocMathDisplay . decodeUtf8+mathDisplay = DocMathDisplay . T.unpack                <$> ("\\[" *> takeUntil "\\]")  markdownImage :: Parser (DocH mod a)@@ -282,20 +311,21 @@  -- | Paragraph parser, called by 'parseParas'. paragraph :: Parser (DocH mod Identifier)-paragraph = examples <|> table <|> do-  indent <- takeIndent-  choice-    [ since-    , unorderedList indent-    , orderedList indent-    , birdtracks-    , codeblock-    , property-    , header-    , textParagraphThatStartsWithMarkdownLink-    , definitionList indent-    , docParagraph <$> textParagraph-    ]+paragraph = choice' [ examples+                    , table+                    , do indent <- takeIndent+                         choice' [ since+                                 , unorderedList indent+                                 , orderedList indent+                                 , birdtracks+                                 , codeblock+                                 , property+                                 , header+                                 , textParagraphThatStartsWithMarkdownLink+                                 , definitionList indent+                                 , docParagraph <$> textParagraph+                                 ]+                    ]  -- | Provides support for grid tables. --@@ -317,45 +347,45 @@ table = do     -- first we parse the first row, which determines the width of the table     firstRow <- parseFirstRow-    let len = BS.length firstRow+    let len = T.length firstRow      -- then we parse all consequtive rows starting and ending with + or |,     -- of the width `len`.-    restRows <- many (parseRestRows len)+    restRows <- many (try (parseRestRows len))      -- Now we gathered the table block, the next step is to split the block     -- into cells.     DocTable <$> tableStepTwo len (firstRow : restRows)   where-    parseFirstRow :: Parser BS.ByteString+    parseFirstRow :: Parser Text     parseFirstRow = do         skipHorizontalSpace         -- upper-left corner is +-        c <- char '+'-        cs <- many1 (char '-' <|> char '+')+        c <- Parsec.char '+'+        cs <- some (Parsec.char '-' <|> Parsec.char '+')          -- upper right corner is + too         guard (last cs == '+')          -- trailing space         skipHorizontalSpace-        _ <- char '\n'+        _ <- Parsec.newline -        return (BS.cons c $ BS.pack cs)+        return (T.cons c $ T.pack cs) -    parseRestRows :: Int -> Parser BS.ByteString+    parseRestRows :: Int -> Parser Text     parseRestRows l = do         skipHorizontalSpace -        c <- char '|' <|> char '+'-        bs <- scan (l - 2) predicate-        c2 <- char '|' <|> char '+'+        c <- Parsec.char '|' <|> Parsec.char '+'+        bs <- scan predicate (l - 2)+        c2 <- Parsec.char '|' <|> Parsec.char '+'          -- trailing space         skipHorizontalSpace-        _ <- char '\n'+        _ <- Parsec.newline -        return (BS.cons c (BS.snoc bs c2))+        return (T.cons c (T.snoc bs c2))       where         predicate n c             | n <= 0    = Nothing@@ -366,22 +396,22 @@ -- and changes to '=' to '-'. tableStepTwo     :: Int              -- ^ width-    -> [BS.ByteString]  -- ^ rows+    -> [Text]           -- ^ rows     -> Parser (Table (DocH mod Identifier)) tableStepTwo width = go 0 [] where     go _ left [] = tableStepThree width (reverse left) Nothing     go n left (r : rs)-        | BS.all (`elem` ['+', '=']) r =+        | T.all (`elem` ['+', '=']) r =             tableStepThree width (reverse left ++ r' : rs) (Just n)         | otherwise =             go (n + 1) (r :  left) rs       where-        r' = BS.map (\c -> if c == '=' then '-' else c) r+        r' = T.map (\c -> if c == '=' then '-' else c) r  -- Third step recognises cells in the table area, returning a list of TC, cells. tableStepThree     :: Int              -- ^ width-    -> [BS.ByteString]  -- ^ rows+    -> [Text]           -- ^ rows     -> Maybe Int        -- ^ index of header separator     -> Parser (Table (DocH mod Identifier)) tableStepThree width rs hdrIndex = do@@ -408,32 +438,32 @@     scanRight :: Int -> Int -> Maybe (Int, Int)     scanRight x y = go (x + 1) where         bs = rs !! y-        go x' | x' >= width           = fail "overflow right "-              | BS.index bs x' == '+' = scanDown x y x' <|> go (x' + 1)-              | BS.index bs x' == '-' = go (x' + 1)-              | otherwise             = fail $ "not a border (right) " ++ show (x,y,x')+        go x' | x' >= width          = fail "overflow right "+              | T.index bs x' == '+' = scanDown x y x' <|> go (x' + 1)+              | T.index bs x' == '-' = go (x' + 1)+              | otherwise            = fail $ "not a border (right) " ++ show (x,y,x')      -- scan down looking for +     scanDown :: Int -> Int -> Int -> Maybe (Int, Int)     scanDown x y x2 = go (y + 1) where-        go y' | y' >= height                  = fail "overflow down"-              | BS.index (rs !! y') x2 == '+' = scanLeft x y x2 y' <|> go (y' + 1)-              | BS.index (rs !! y') x2 == '|' = go (y' + 1)-              | otherwise                     = fail $ "not a border (down) " ++ show (x,y,x2,y')+        go y' | y' >= height                 = fail "overflow down"+              | T.index (rs !! y') x2 == '+' = scanLeft x y x2 y' <|> go (y' + 1)+              | T.index (rs !! y') x2 == '|' = go (y' + 1)+              | otherwise                    = fail $ "not a border (down) " ++ show (x,y,x2,y')      -- check that at y2 x..x2 characters are '+' or '-'     scanLeft :: Int -> Int -> Int -> Int -> Maybe (Int, Int)     scanLeft x y x2 y2-        | all (\x' -> BS.index bs x' `elem` ['+', '-']) [x..x2] = scanUp x y x2 y2-        | otherwise                                             = fail $ "not a border (left) " ++ show (x,y,x2,y2)+        | all (\x' -> T.index bs x' `elem` ['+', '-']) [x..x2] = scanUp x y x2 y2+        | otherwise                                            = fail $ "not a border (left) " ++ show (x,y,x2,y2)       where         bs = rs !! y2      -- check that at y2 x..x2 characters are '+' or '-'     scanUp :: Int -> Int -> Int -> Int -> Maybe (Int, Int)     scanUp x y x2 y2-        | all (\y' -> BS.index (rs !! y') x `elem` ['+', '|']) [y..y2] = return (x2, y2)-        | otherwise                                                    = fail $ "not a border (up) " ++ show (x,y,x2,y2)+        | all (\y' -> T.index (rs !! y') x `elem` ['+', '|']) [y..y2] = return (x2, y2)+        | otherwise                                                   = fail $ "not a border (up) " ++ show (x,y,x2,y2)  -- | table cell: top left bottom right data TC = TC !Int !Int !Int !Int@@ -446,7 +476,7 @@ tcYS (TC y _ y2 _) = [y, y2]  -- | Fourth step. Given the locations of cells, forms 'Table' structure.-tableStepFour :: [BS.ByteString] -> Maybe Int -> [TC] -> Parser (Table (DocH mod Identifier))+tableStepFour :: [Text] -> Maybe Int -> [TC] -> Parser (Table (DocH mod Identifier)) tableStepFour rs hdrIndex cells =  case hdrIndex of     Nothing -> return $ Table [] rowsDoc     Just i  -> case elemIndex i yTabStops of@@ -464,7 +494,7 @@     init' [_]      = []     init' (x : xs) = x : init' xs -    rowsDoc = (fmap . fmap) parseStringBS rows+    rowsDoc = (fmap . fmap) parseParagraph rows      rows = map makeRow (init' yTabStops)       where@@ -477,9 +507,9 @@             yts = length $ P.takeWhile (< y2) $ dropWhile (< y) yTabStops      -- extract cell contents given boundaries-    extract :: Int -> Int -> Int -> Int -> BS.ByteString-    extract x y x2 y2 = BS.intercalate "\n"-        [ BS.take (x2 - x + 1) $ BS.drop x $ rs !! y'+    extract :: Int -> Int -> Int -> Int -> Text+    extract x y x2 y2 = T.intercalate "\n"+        [ T.take (x2 - x + 1) $ T.drop x $ rs !! y'         | y' <- [y .. y2]         ] @@ -487,7 +517,7 @@ since :: Parser (DocH mod a) since = ("@since " *> version <* skipHorizontalSpace <* endOfLine) >>= setSince >> return DocEmpty   where-    version = decimal `sepBy1'` "."+    version = decimal `Parsec.sepBy1` "."  -- | Headers inside the comment denoted with @=@ signs, up to 6 levels -- deep.@@ -498,38 +528,39 @@ -- Right (DocHeader (Header {headerLevel = 2, headerTitle = DocString "World"})) header :: Parser (DocH mod Identifier) header = do-  let psers = map (string . encodeUtf8 . concat . flip replicate "=") [6, 5 .. 1]-      pser = foldl1 (<|>) psers-  delim <- decodeUtf8 <$> pser-  line <- skipHorizontalSpace *> nonEmptyLine >>= return . parseString-  rest <- paragraph <|> return DocEmpty+  let psers = map (string . flip T.replicate "=") [6, 5 .. 1]+      pser = choice' psers+  delim <- T.unpack <$> pser+  line <- skipHorizontalSpace *> nonEmptyLine >>= return . parseText+  rest <- try paragraph <|> return DocEmpty   return $ DocHeader (Header (length delim) line) `docAppend` rest  textParagraph :: Parser (DocH mod Identifier)-textParagraph = parseString . intercalate "\n" <$> many1 nonEmptyLine+textParagraph = parseText . T.intercalate "\n" <$> some nonEmptyLine  textParagraphThatStartsWithMarkdownLink :: Parser (DocH mod Identifier) textParagraphThatStartsWithMarkdownLink = docParagraph <$> (docAppend <$> markdownLink <*> optionalTextParagraph)   where     optionalTextParagraph :: Parser (DocH mod Identifier)-    optionalTextParagraph = (docAppend <$> whitespace <*> textParagraph) <|> pure DocEmpty+    optionalTextParagraph = choice' [ docAppend <$> whitespace <*> textParagraph+                                    , pure DocEmpty ]      whitespace :: Parser (DocH mod a)     whitespace = DocString <$> (f <$> takeHorizontalSpace <*> optional "\n")       where-        f :: BS.ByteString -> Maybe BS.ByteString -> String+        f :: Text -> Maybe Text -> String         f xs (fromMaybe "" -> x)-          | BS.null (xs <> x) = ""+          | T.null (xs <> x) = ""           | otherwise = " "  -- | Parses unordered (bullet) lists.-unorderedList :: BS.ByteString -> Parser (DocH mod Identifier)+unorderedList :: Text -> Parser (DocH mod Identifier) unorderedList indent = DocUnorderedList <$> p   where     p = ("*" <|> "-") *> innerList indent p  -- | Parses ordered lists (numbered or dashed).-orderedList :: BS.ByteString -> Parser (DocH mod Identifier)+orderedList :: Text -> Parser (DocH mod Identifier) orderedList indent = DocOrderedList <$> p   where     p = (paren <|> dot) *> innerList indent p@@ -541,104 +572,110 @@ -- same paragraph. Usually used as -- -- > someListFunction = listBeginning *> innerList someListFunction-innerList :: BS.ByteString -> Parser [DocH mod Identifier]+innerList :: Text -> Parser [DocH mod Identifier]           -> Parser [DocH mod Identifier] innerList indent item = do   c <- takeLine   (cs, items) <- more indent item-  let contents = docParagraph . parseString . dropNLs . unlines $ c : cs+  let contents = docParagraph . parseText . dropNLs . T.unlines $ c : cs   return $ case items of     Left p -> [contents `docAppend` p]     Right i -> contents : i  -- | Parses definition lists.-definitionList :: BS.ByteString -> Parser (DocH mod Identifier)+definitionList :: Text -> Parser (DocH mod Identifier) definitionList indent = DocDefList <$> p   where     p = do-      label <- "[" *> (parseStringBS <$> takeWhile1_ (notInClass "]\n")) <* ("]" <* optional ":")+      label <- "[" *> (parseParagraph <$> takeWhile1_ (`notElem` ("]\n" :: String))) <* ("]" <* optional ":")       c <- takeLine       (cs, items) <- more indent p-      let contents = parseString . dropNLs . unlines $ c : cs+      let contents = parseText . dropNLs . T.unlines $ c : cs       return $ case items of         Left x -> [(label, contents `docAppend` x)]         Right i -> (label, contents) : i  -- | Drops all trailing newlines.-dropNLs :: String -> String-dropNLs = reverse . dropWhile (== '\n') . reverse+dropNLs :: Text -> Text +dropNLs = T.dropWhileEnd (== '\n')  -- | Main worker for 'innerList' and 'definitionList'. -- We need the 'Either' here to be able to tell in the respective functions -- whether we're dealing with the next list or a nested paragraph.-more :: Monoid a => BS.ByteString -> Parser a-     -> Parser ([String], Either (DocH mod Identifier) a)-more indent item = innerParagraphs indent-               <|> moreListItems indent item-               <|> moreContent indent item-               <|> pure ([], Right mempty)+more :: Monoid a => Text -> Parser a+     -> Parser ([Text], Either (DocH mod Identifier) a)+more indent item = choice' [ innerParagraphs indent+                           , moreListItems indent item+                           , moreContent indent item+                           , pure ([], Right mempty)+                           ]  -- | Used by 'innerList' and 'definitionList' to parse any nested paragraphs.-innerParagraphs :: BS.ByteString-                -> Parser ([String], Either (DocH mod Identifier) a)+innerParagraphs :: Text+                -> Parser ([Text], Either (DocH mod Identifier) a) innerParagraphs indent = (,) [] . Left <$> ("\n" *> indentedParagraphs indent)  -- | Attempts to fetch the next list if possibly. Used by 'innerList' and -- 'definitionList' to recursively grab lists that aren't separated by a whole -- paragraph.-moreListItems :: BS.ByteString -> Parser a-              -> Parser ([String], Either (DocH mod Identifier) a)+moreListItems :: Text -> Parser a+              -> Parser ([Text], Either (DocH mod Identifier) a) moreListItems indent item = (,) [] . Right <$> indentedItem   where-    indentedItem = string indent *> skipSpace *> item+    indentedItem = string indent *> Parsec.spaces *> item  -- | Helper for 'innerList' and 'definitionList' which simply takes -- a line of text and attempts to parse more list content with 'more'.-moreContent :: Monoid a => BS.ByteString -> Parser a-            -> Parser ([String], Either (DocH mod Identifier) a)+moreContent :: Monoid a => Text -> Parser a+            -> Parser ([Text], Either (DocH mod Identifier) a) moreContent indent item = first . (:) <$> nonEmptyLine <*> more indent item  -- | Parses an indented paragraph. -- The indentation is 4 spaces.-indentedParagraphs :: BS.ByteString -> Parser (DocH mod Identifier)+indentedParagraphs :: Text -> Parser (DocH mod Identifier) indentedParagraphs indent =-    (concat <$> dropFrontOfPara indent') >>= parseParagraphs+    (T.unpack . T.concat <$> dropFrontOfPara indent') >>= parseParagraphs   where-    indent' = string $ BS.append indent "    "+    indent' = string $ indent <> "    "  -- | Grab as many fully indented paragraphs as we can.-dropFrontOfPara :: Parser BS.ByteString -> Parser [String]+dropFrontOfPara :: Parser Text -> Parser [Text] dropFrontOfPara sp = do-  currentParagraph <- some (sp *> takeNonEmptyLine)+  currentParagraph <- some (try (sp *> takeNonEmptyLine))   followingParagraphs <--    skipHorizontalSpace *> nextPar -- we have more paragraphs to take-    <|> skipHorizontalSpace *> nlList -- end of the ride, remember the newline-    <|> endOfInput *> return [] -- nothing more to take at all+    choice' [ skipHorizontalSpace *> nextPar -- we have more paragraphs to take+            , skipHorizontalSpace *> nlList -- end of the ride, remember the newline+            , Parsec.eof *> return []       -- nothing more to take at all+            ]   return (currentParagraph ++ followingParagraphs)   where     nextPar = (++) <$> nlList <*> dropFrontOfPara sp     nlList = "\n" *> return ["\n"] -nonSpace :: BS.ByteString -> Parser BS.ByteString+nonSpace :: Text -> Parser Text nonSpace xs-  | not $ any (not . isSpace) $ decodeUtf8 xs = fail "empty line"+  | T.all isSpace xs = fail "empty line"   | otherwise = return xs  -- | Takes a non-empty, not fully whitespace line. -- --  Doesn't discard the trailing newline.-takeNonEmptyLine :: Parser String+takeNonEmptyLine :: Parser Text takeNonEmptyLine = do-    (++ "\n") . decodeUtf8 <$> (takeWhile1 (/= '\n') >>= nonSpace) <* "\n"+    l <- takeWhile1 (Parsec.noneOf "\n") >>= nonSpace+    _ <- "\n"+    pure (l <> "\n")  -- | Takes indentation of first non-empty line. -- -- More precisely: skips all whitespace-only lines and returns indentation -- (horizontal space, might be empty) of that non-empty line.-takeIndent :: Parser BS.ByteString+takeIndent :: Parser Text  takeIndent = do   indent <- takeHorizontalSpace-  "\n" *> takeIndent <|> return indent+  choice' [ "\n" *> takeIndent+          , return indent+          ]  -- | Blocks of text of the form: --@@ -647,97 +684,98 @@ -- >> baz -- birdtracks :: Parser (DocH mod a)-birdtracks = DocCodeBlock . DocString . intercalate "\n" . stripSpace <$> many1 line+birdtracks = DocCodeBlock . DocString . T.unpack . T.intercalate "\n" . stripSpace <$> some line   where-    line = skipHorizontalSpace *> ">" *> takeLine+    line = try (skipHorizontalSpace *> ">" *> takeLine) -stripSpace :: [String] -> [String]+stripSpace :: [Text] -> [Text] stripSpace = fromMaybe <*> mapM strip'   where-    strip' (' ':xs') = Just xs'-    strip' "" = Just ""-    strip' _  = Nothing+    strip' t = case T.uncons t of+                 Nothing -> Just ""+                 Just (' ',t') -> Just t'+                 _ -> Nothing  -- | Parses examples. Examples are a paragraph level entitity (separated by an empty line). -- Consecutive examples are accepted. examples :: Parser (DocH mod a)-examples = DocExamples <$> (many (skipHorizontalSpace *> "\n") *> go)+examples = DocExamples <$> (many (try (skipHorizontalSpace *> "\n")) *> go)   where     go :: Parser [Example]     go = do-      prefix <- decodeUtf8 <$> takeHorizontalSpace <* ">>>"+      prefix <- takeHorizontalSpace <* ">>>"       expr <- takeLine       (rs, es) <- resultAndMoreExamples       return (makeExample prefix expr rs : es)       where-        resultAndMoreExamples :: Parser ([String], [Example])-        resultAndMoreExamples = moreExamples <|> result <|> pure ([], [])+        resultAndMoreExamples :: Parser ([Text], [Example])+        resultAndMoreExamples = choice' [ moreExamples, result, pure ([], []) ]           where-            moreExamples :: Parser ([String], [Example])+            moreExamples :: Parser ([Text], [Example])             moreExamples = (,) [] <$> go -            result :: Parser ([String], [Example])+            result :: Parser ([Text], [Example])             result = first . (:) <$> nonEmptyLine <*> resultAndMoreExamples -    makeExample :: String -> String -> [String] -> Example+    makeExample :: Text -> Text -> [Text] -> Example     makeExample prefix expression res =-      Example (strip expression) result+      Example (T.unpack (T.strip expression)) result       where-        result = map (substituteBlankLine . tryStripPrefix) res+        result = map (T.unpack . substituteBlankLine . tryStripPrefix) res -        tryStripPrefix xs = fromMaybe xs (stripPrefix prefix xs)+        tryStripPrefix xs = fromMaybe xs (T.stripPrefix prefix xs)          substituteBlankLine "<BLANKLINE>" = ""         substituteBlankLine xs = xs -nonEmptyLine :: Parser String-nonEmptyLine = mfilter (any (not . isSpace)) takeLine+nonEmptyLine :: Parser Text +nonEmptyLine = try (mfilter (T.any (not . isSpace)) takeLine) -takeLine :: Parser String-takeLine = decodeUtf8 <$> takeWhile (/= '\n') <* endOfLine+takeLine :: Parser Text+takeLine = try (takeWhile (Parsec.noneOf "\n") <* endOfLine)  endOfLine :: Parser ()-endOfLine = void "\n" <|> endOfInput+endOfLine = void "\n" <|> Parsec.eof   -- | Property parser. -- -- >>> snd <$> parseOnly property "prop> hello world" -- Right (DocProperty "hello world") property :: Parser (DocH mod a)-property = DocProperty . strip . decodeUtf8 <$> ("prop>" *> takeWhile1 (/= '\n'))+property = DocProperty . T.unpack . T.strip <$> ("prop>" *> takeWhile1 (Parsec.noneOf "\n"))  -- | -- Paragraph level codeblock. Anything between the two delimiting \@ is parsed -- for markup. codeblock :: Parser (DocH mod Identifier) codeblock =-  DocCodeBlock . parseStringBS . dropSpaces+  DocCodeBlock . parseParagraph . dropSpaces   <$> ("@" *> skipHorizontalSpace *> "\n" *> block' <* "@")   where     dropSpaces xs =-      let rs = decodeUtf8 xs-      in case splitByNl rs of+      case splitByNl xs of         [] -> xs-        ys -> case last ys of-          ' ':_ -> case mapM dropSpace ys of-            Nothing -> xs-            Just zs -> encodeUtf8 $ intercalate "\n" zs+        ys -> case T.uncons (last ys) of+          Just (' ',_) -> case mapM dropSpace ys of+                            Nothing -> xs+                            Just zs -> T.intercalate "\n" zs           _ -> xs      -- This is necessary because ‘lines’ swallows up a trailing newline     -- and we lose information about whether the last line belongs to @ or to     -- text which we need to decide whether we actually want to be dropping     -- anything at all.-    splitByNl = unfoldr (\x -> case x of-                                 '\n':s -> Just (span (/= '\n') s)-                                 _      -> Nothing)-                . ('\n' :)+    splitByNl = unfoldr (\x -> case T.uncons x of+                                 Just ('\n',x') -> Just (T.span (/= '\n') x')+                                 _ -> Nothing)+                . ("\n" <>) -    dropSpace "" = Just ""-    dropSpace (' ':xs) = Just xs-    dropSpace _ = Nothing+    dropSpace t = case T.uncons t of+                    Nothing -> Just ""+                    Just (' ',t') -> Just t'+                    _ -> Nothing -    block' = scan False p+    block' = scan p False       where         p isNewline c           | isNewline && c == '@' = Nothing@@ -745,11 +783,11 @@           | otherwise = Just $ c == '\n'  hyperlink :: Parser (DocH mod a)-hyperlink = angleBracketLink <|> markdownLink <|> autoUrl+hyperlink = choice' [ angleBracketLink, markdownLink, autoUrl ]  angleBracketLink :: Parser (DocH mod a) angleBracketLink =-    DocHyperlink . makeLabeled Hyperlink . decodeUtf8+    DocHyperlink . makeLabeled Hyperlink      <$> disallowNewline ("<" *> takeUntil ">")  markdownLink :: Parser (DocH mod a)@@ -759,7 +797,7 @@ linkParser = flip Hyperlink <$> label <*> (whitespace *> url)   where     label :: Parser (Maybe String)-    label = Just . strip . decode <$> ("[" *> takeUntil "]")+    label = Just . decode . T.strip <$> ("[" *> takeUntil "]")      whitespace :: Parser ()     whitespace = skipHorizontalSpace <* optional ("\n" *> skipHorizontalSpace)@@ -770,34 +808,40 @@     rejectWhitespace :: MonadPlus m => m String -> m String     rejectWhitespace = mfilter (all (not . isSpace)) -    decode :: BS.ByteString -> String-    decode = removeEscapes . decodeUtf8+    decode :: Text -> String+    decode = T.unpack . removeEscapes  -- | Looks for URL-like things to automatically hyperlink even if they -- weren't marked as links. autoUrl :: Parser (DocH mod a) autoUrl = mkLink <$> url   where-    url = mappend <$> ("http://" <|> "https://" <|> "ftp://") <*> takeWhile1 (not . isSpace)-    mkLink :: BS.ByteString -> DocH mod a-    mkLink s = case unsnoc s of-      Just (xs, x) | inClass ",.!?" x -> DocHyperlink (Hyperlink (decodeUtf8 xs) Nothing) `docAppend` DocString [x]-      _ -> DocHyperlink (Hyperlink (decodeUtf8 s) Nothing)+    url = mappend <$> choice' [ "http://", "https://", "ftp://"] <*> takeWhile1 (Parsec.satisfy (not . isSpace))+    +    mkLink :: Text -> DocH mod a+    mkLink s = case T.unsnoc s of+      Just (xs,x) | x `elem` (",.!?" :: String) -> DocHyperlink (mkHyperlink xs) `docAppend` DocString [x]+      _ -> DocHyperlink (mkHyperlink s) +    mkHyperlink :: Text -> Hyperlink+    mkHyperlink lnk = Hyperlink (T.unpack lnk) Nothing+++ -- | Parses strings between identifier delimiters. Consumes all input that it -- deems to be valid in an identifier. Note that it simply blindly consumes -- characters and does no actual validation itself. parseValid :: Parser String parseValid = p some   where-    idChar = satisfyUnicode (\c -> isAlphaNum c || isSymbolChar c || c == '_')+    idChar = Parsec.satisfy (\c -> isAlphaNum c || isSymbolChar c || c == '_')      p p' = do       vs <- p' idChar       c <- peekChar'       case c of         '`' -> return vs-        '\'' -> (\x -> vs ++ "'" ++ x) <$> ("'" *> p many') <|> return vs+        '\'' -> choice' [ (\x -> vs ++ "'" ++ x) <$> ("'" *> p many), return vs ]         _ -> fail "outofvalid"  -- | Parses identifiers with help of 'parseValid'. Asks GHC for@@ -809,4 +853,4 @@   e <- idDelim   return $ DocIdentifier (o, vid, e)   where-    idDelim = satisfy (\c -> c == '\'' || c == '`')+    idDelim = Parsec.satisfy (\c -> c == '\'' || c == '`')
haddock-library/src/Documentation/Haddock/Parser/Monad.hs view
@@ -1,49 +1,26 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies #-}-module Documentation.Haddock.Parser.Monad (-  module Documentation.Haddock.Parser.Monad-, Attoparsec.isDigit-, Attoparsec.isDigit_w8-, Attoparsec.isAlpha_iso8859_15-, Attoparsec.isAlpha_ascii-, Attoparsec.isSpace-, Attoparsec.isSpace_w8-, Attoparsec.inClass-, Attoparsec.notInClass-, Attoparsec.isEndOfLine-, Attoparsec.isHorizontalSpace-, Attoparsec.choice-, Attoparsec.count-, Attoparsec.option-, Attoparsec.many'-, Attoparsec.many1-, Attoparsec.many1'-, Attoparsec.manyTill-, Attoparsec.manyTill'-, Attoparsec.sepBy-, Attoparsec.sepBy'-, Attoparsec.sepBy1-, Attoparsec.sepBy1'-, Attoparsec.skipMany-, Attoparsec.skipMany1-, Attoparsec.eitherP-) where+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TypeSynonymInstances #-} -import           Control.Applicative-import           Control.Monad-import           Data.String-import           Data.ByteString (ByteString, length)-import qualified Data.ByteString.Lazy as LB-import qualified Data.Attoparsec.ByteString.Char8 as Attoparsec-import qualified Data.Attoparsec.Combinator as Attoparsec-import           Control.Monad.Trans.State-import qualified Control.Monad.Trans.Class as Trans-import           Data.Word-import           Data.Bits-import           Data.Tuple+module Documentation.Haddock.Parser.Monad where -import           Documentation.Haddock.Types (Version)-import           Documentation.Haddock.Utf8  (encodeUtf8, decodeUtf8)+import qualified Text.Parsec.Char as Parsec+import qualified Text.Parsec as Parsec +import qualified Data.Text as T+import           Data.Text                   ( Text )++import           Data.String                 ( IsString(..) )+import           Data.Bits                   ( Bits(..) )+import           Data.Char                   ( ord )+import           Data.List                   ( foldl' )+import           Control.Applicative as App++import           Documentation.Haddock.Types ( Version )+ newtype ParserState = ParserState {   parserStateSince :: Maybe Version } deriving (Eq, Show)@@ -51,120 +28,65 @@ initialParserState :: ParserState initialParserState = ParserState Nothing -newtype Parser a = Parser (StateT ParserState Attoparsec.Parser a)-  deriving (Functor, Applicative, Alternative, Monad, MonadPlus)--instance (a ~ ByteString) => IsString (Parser a) where-  fromString = lift . fromString--parseOnly :: Parser a -> ByteString -> Either String (ParserState, a)-parseOnly (Parser p) = fmap swap . Attoparsec.parseOnly (runStateT p initialParserState)--lift :: Attoparsec.Parser a -> Parser a-lift = Parser . Trans.lift--setParserState :: ParserState -> Parser ()-setParserState = Parser . put- setSince :: Version -> Parser ()-setSince since = Parser $ modify (\st -> st {parserStateSince = Just since})--char :: Char -> Parser Char-char = lift . Attoparsec.char--char8 :: Char -> Parser Word8-char8 = lift . Attoparsec.char8---- | Peek a unicode character and return the number of bytes that it took up-peekUnicode :: Parser (Char, Int)-peekUnicode = lift $ Attoparsec.lookAhead $ do-  -  -- attoparsec's take fails on shorter inputs rather than truncate-  bs <- Attoparsec.choice (map Attoparsec.take [4,3,2,1])-  -  let c = head . decodeUtf8 $ bs-      n = Data.ByteString.length . encodeUtf8 $ [c]-  pure (c, fromIntegral n)---- | Like 'satisfy', but consuming a unicode character-satisfyUnicode :: (Char -> Bool) -> Parser Char-satisfyUnicode predicate = do-  (c,n) <- peekUnicode-  if predicate c-    then Documentation.Haddock.Parser.Monad.take n *> pure c-    else fail "satsifyUnicode"+setSince since = Parsec.modifyState (\st -> st {parserStateSince = Just since}) -anyChar :: Parser Char-anyChar = lift Attoparsec.anyChar+type Parser = Parsec.Parsec Text ParserState -notChar :: Char -> Parser Char-notChar = lift . Attoparsec.notChar+instance (a ~ Text) => IsString (Parser a) where+  fromString = fmap T.pack . Parsec.string -satisfy :: (Char -> Bool) -> Parser Char-satisfy = lift . Attoparsec.satisfy+parseOnly :: Parser a -> Text -> Either String (ParserState, a)+parseOnly p t = case Parsec.runParser p' initialParserState "<haddock>" t of+                  Left e -> Left (show e)+                  Right (x,s) -> Right (s,x)+  where p' = (,) <$> p <*> Parsec.getState +-- | Always succeeds, but returns 'Nothing' if at the end of input. Does not+-- consume input. peekChar :: Parser (Maybe Char)-peekChar = lift Attoparsec.peekChar+peekChar = Parsec.optionMaybe . Parsec.try . Parsec.lookAhead $ Parsec.anyChar +-- | Fails if at the end of input. Does not consume input. peekChar' :: Parser Char-peekChar' = lift Attoparsec.peekChar'--digit :: Parser Char-digit = lift Attoparsec.digit--letter_iso8859_15 :: Parser Char-letter_iso8859_15 = lift Attoparsec.letter_iso8859_15--letter_ascii :: Parser Char-letter_ascii = lift Attoparsec.letter_ascii--space :: Parser Char-space = lift Attoparsec.space--string :: ByteString -> Parser ByteString-string = lift . Attoparsec.string--stringCI :: ByteString -> Parser ByteString-stringCI = lift . Attoparsec.stringCI--skipSpace :: Parser ()-skipSpace = lift Attoparsec.skipSpace--skipWhile :: (Char -> Bool) -> Parser ()-skipWhile = lift . Attoparsec.skipWhile--take :: Int -> Parser ByteString-take = lift . Attoparsec.take--scan :: s -> (s -> Char -> Maybe s) -> Parser ByteString-scan s = lift . Attoparsec.scan s--takeWhile :: (Char -> Bool) -> Parser ByteString-takeWhile = lift . Attoparsec.takeWhile--takeWhile1 :: (Char -> Bool) -> Parser ByteString-takeWhile1 = lift . Attoparsec.takeWhile1+peekChar' = Parsec.lookAhead Parsec.anyChar  -takeTill :: (Char -> Bool) -> Parser ByteString-takeTill = lift . Attoparsec.takeTill+-- | Parses the given string. Returns the parsed string.+string :: Text -> Parser Text+string t = Parsec.string (T.unpack t) *> App.pure t -takeByteString :: Parser ByteString-takeByteString = lift Attoparsec.takeByteString+-- | Scan the input text, accumulating characters as long as the scanning+-- function returns true.+scan :: (s -> Char -> Maybe s) -- ^ scan function+     -> s                      -- ^ initial state+     -> Parser Text +scan f = fmap T.pack . go+  where go s1 = do { cOpt <- peekChar+                   ; case cOpt >>= f s1 of+                       Nothing -> pure ""+                       Just s2 -> (:) <$> Parsec.anyChar <*> go s2+                   } -takeLazyByteString :: Parser LB.ByteString-takeLazyByteString = lift Attoparsec.takeLazyByteString+-- | Apply a parser for a character zero or more times and collect the result in+-- a string.+takeWhile :: Parser Char -> Parser Text+takeWhile = fmap T.pack . Parsec.many -endOfLine :: Parser ()-endOfLine = lift Attoparsec.endOfLine+-- | Apply a parser for a character one or more times and collect the result in+-- a string.+takeWhile1 :: Parser Char -> Parser Text+takeWhile1 =  fmap T.pack . Parsec.many1 +-- | Parse a decimal number. decimal :: Integral a => Parser a-decimal = lift Attoparsec.decimal+decimal = foldl' step 0 `fmap` Parsec.many1 Parsec.digit+  where step a c = a * 10 + fromIntegral (ord c - 48) +-- | Parse a hexadecimal number. hexadecimal :: (Integral a, Bits a) => Parser a-hexadecimal = lift Attoparsec.hexadecimal--endOfInput :: Parser ()-endOfInput = lift Attoparsec.endOfInput--atEnd :: Parser Bool-atEnd = lift Attoparsec.atEnd+hexadecimal = foldl' step 0 `fmap` Parsec.many1 Parsec.hexDigit +  where+  step a c | w >= 48 && w <= 57  = (a `shiftL` 4) .|. fromIntegral (w - 48)+           | w >= 97             = (a `shiftL` 4) .|. fromIntegral (w - 87)+           | otherwise           = (a `shiftL` 4) .|. fromIntegral (w - 55)+    where w = ord c
haddock-library/src/Documentation/Haddock/Parser/Util.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-} -- | -- Module      :  Documentation.Haddock.Parser.Util -- Copyright   :  (c) Mateusz Kowalczyk 2013-2014,@@ -11,62 +11,59 @@ -- -- Various utility functions used by the parser. module Documentation.Haddock.Parser.Util (-  unsnoc-, strip-, takeUntil-, removeEscapes-, makeLabeled-, takeHorizontalSpace-, skipHorizontalSpace+  takeUntil,+  removeEscapes,+  makeLabeled,+  takeHorizontalSpace,+  skipHorizontalSpace, ) where +import qualified Text.Parsec as Parsec++import qualified Data.Text as T+import           Data.Text (Text)+ import           Control.Applicative import           Control.Monad (mfilter)-import           Documentation.Haddock.Parser.Monad hiding (isHorizontalSpace)-import           Data.ByteString.Char8 (ByteString)-import qualified Data.ByteString.Char8 as BS+import           Documentation.Haddock.Parser.Monad import           Prelude hiding (takeWhile) -#if MIN_VERSION_bytestring(0,10,2)-import           Data.ByteString.Char8 (unsnoc)-#else-unsnoc :: ByteString -> Maybe (ByteString, Char)-unsnoc bs-  | BS.null bs = Nothing-  | otherwise = Just (BS.init bs, BS.last bs)-#endif---- | Remove all leading and trailing whitespace-strip :: String -> String-strip = (\f -> f . f) $ dropWhile isSpace . reverse+import           Data.Char (isSpace) -isHorizontalSpace :: Char -> Bool-isHorizontalSpace = inClass " \t\f\v\r"+-- | Characters that count as horizontal space+horizontalSpace :: [Char]+horizontalSpace = " \t\f\v\r" +-- | Skip and ignore leading horizontal space skipHorizontalSpace :: Parser ()-skipHorizontalSpace = skipWhile isHorizontalSpace+skipHorizontalSpace = Parsec.skipMany (Parsec.oneOf horizontalSpace) -takeHorizontalSpace :: Parser BS.ByteString-takeHorizontalSpace = takeWhile isHorizontalSpace+-- | Take leading horizontal space+takeHorizontalSpace :: Parser Text +takeHorizontalSpace = takeWhile (Parsec.oneOf horizontalSpace) -makeLabeled :: (String -> Maybe String -> a) -> String -> a-makeLabeled f input = case break isSpace $ removeEscapes $ strip input of-  (uri, "")    -> f uri Nothing-  (uri, label) -> f uri (Just $ dropWhile isSpace label)+makeLabeled :: (String -> Maybe String -> a) -> Text -> a+makeLabeled f input = case T.break isSpace $ removeEscapes $ T.strip input of+  (uri, "")    -> f (T.unpack uri) Nothing+  (uri, label) -> f (T.unpack uri) (Just . T.unpack $ T.stripStart label)  -- | Remove escapes from given string. -- -- Only do this if you do not process (read: parse) the input any further.-removeEscapes :: String -> String-removeEscapes "" = ""-removeEscapes ('\\':'\\':xs) = '\\' : removeEscapes xs-removeEscapes ('\\':xs) = removeEscapes xs-removeEscapes (x:xs) = x : removeEscapes xs+removeEscapes :: Text -> Text+removeEscapes = T.unfoldr go+  where+  go :: Text -> Maybe (Char, Text)+  go xs = case T.uncons xs of+            Just ('\\',ys) -> T.uncons ys+            unconsed -> unconsed -takeUntil :: ByteString -> Parser ByteString-takeUntil end_ = dropEnd <$> requireEnd (scan (False, end) p) >>= gotSome+-- | Consume characters from the input up to and including the given pattern.+-- Return everything consumed except for the end pattern itself.+takeUntil :: Text -> Parser Text +takeUntil end_ = T.dropEnd (T.length end_) <$> requireEnd (scan p (False, end)) >>= gotSome   where-    end = BS.unpack end_+    end = T.unpack end_       p :: (Bool, String) -> Char -> Maybe (Bool, String)     p acc c = case acc of@@ -75,9 +72,8 @@       (_, x:xs) | x == c -> Just (False, xs)       _ -> Just (c == '\\', end) -    dropEnd = BS.reverse . BS.drop (length end) . BS.reverse-    requireEnd = mfilter (BS.isSuffixOf end_)+    requireEnd = mfilter (T.isSuffixOf end_)      gotSome xs-      | BS.null xs = fail "didn't get any content"+      | T.null xs = fail "didn't get any content"       | otherwise = return xs
haddock-library/src/Documentation/Haddock/Types.hs view
@@ -107,8 +107,10 @@   | DocParagraph (DocH mod id)   | DocIdentifier id   | DocIdentifierUnchecked mod+  -- ^ A qualified identifier that couldn't be resolved.   | DocModule String   | DocWarning (DocH mod id)+  -- ^ This constructor has no counterpart in Haddock markup.   | DocEmphasis (DocH mod id)   | DocMonospaced (DocH mod id)   | DocBold (DocH mod id)@@ -121,6 +123,7 @@   | DocMathInline String   | DocMathDisplay String   | DocAName String+  -- ^ A (HTML) anchor.   | DocProperty String   | DocExamples [Example]   | DocHeader (Header (DocH mod id))
− haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec.hs 
@@ -1,23 +0,0 @@--- |--- Module      :  Data.Attoparsec--- Copyright   :  Bryan O'Sullivan 2007-2015--- License     :  BSD3------ Maintainer  :  bos@serpentine.com--- Stability   :  experimental--- Portability :  unknown------ Simple, efficient combinator parsing for--- 'Data.ByteString.ByteString' strings, loosely based on the Parsec--- library.------ This module is deprecated. Use "Data.Attoparsec.ByteString"--- instead.--module Data.Attoparsec-    {-# DEPRECATED "This module will be removed in the next major release." #-}-    (-      module Data.Attoparsec.ByteString-    ) where--import Data.Attoparsec.ByteString
− haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/ByteString.hs 
@@ -1,230 +0,0 @@-{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#endif--- |--- Module      :  Data.Attoparsec.ByteString--- Copyright   :  Bryan O'Sullivan 2007-2015--- License     :  BSD3------ Maintainer  :  bos@serpentine.com--- Stability   :  experimental--- Portability :  unknown------ Simple, efficient combinator parsing for 'B.ByteString' strings,--- loosely based on the Parsec library.--module Data.Attoparsec.ByteString-    (-    -- * Differences from Parsec-    -- $parsec--    -- * Incremental input-    -- $incremental--    -- * Performance considerations-    -- $performance--    -- * Parser types-      I.Parser-    , Result-    , T.IResult(..)-    , I.compareResults--    -- * Running parsers-    , parse-    , feed-    , I.parseOnly-    , parseWith-    , parseTest--    -- ** Result conversion-    , maybeResult-    , eitherResult--    -- * Parsing individual bytes-    , I.word8-    , I.anyWord8-    , I.notWord8-    , I.satisfy-    , I.satisfyWith-    , I.skip--    -- ** Lookahead-    , I.peekWord8-    , I.peekWord8'--    -- ** Byte classes-    , I.inClass-    , I.notInClass--    -- * Efficient string handling-    , I.string-    , I.skipWhile-    , I.take-    , I.scan-    , I.runScanner-    , I.takeWhile-    , I.takeWhile1-    , I.takeTill--    -- ** Consume all remaining input-    , I.takeByteString-    , I.takeLazyByteString--    -- * Combinators-    , try-    , (<?>)-    , choice-    , count-    , option-    , many'-    , many1-    , many1'-    , manyTill-    , manyTill'-    , sepBy-    , sepBy'-    , sepBy1-    , sepBy1'-    , skipMany-    , skipMany1-    , eitherP-    , I.match-    -- * State observation and manipulation functions-    , I.endOfInput-    , I.atEnd-    ) where--import Data.Attoparsec.Combinator-import Data.List (intercalate)-import qualified Data.Attoparsec.ByteString.Internal as I-import qualified Data.Attoparsec.Internal as I-import qualified Data.ByteString as B-import Data.Attoparsec.ByteString.Internal (Result, parse)-import qualified Data.Attoparsec.Internal.Types as T---- $parsec------ Compared to Parsec 3, attoparsec makes several tradeoffs.  It is--- not intended for, or ideal for, all possible uses.------ * While attoparsec can consume input incrementally, Parsec cannot.---   Incremental input is a huge deal for efficient and secure network---   and system programming, since it gives much more control to users---   of the library over matters such as resource usage and the I/O---   model to use.------ * Much of the performance advantage of attoparsec is gained via---   high-performance parsers such as 'I.takeWhile' and 'I.string'.---   If you use complicated combinators that return lists of bytes or---   characters, there is less performance difference between the two---   libraries.------ * Unlike Parsec 3, attoparsec does not support being used as a---   monad transformer.------ * attoparsec is specialised to deal only with strict 'B.ByteString'---   input.  Efficiency concerns rule out both lists and lazy---   bytestrings.  The usual use for lazy bytestrings would be to---   allow consumption of very large input without a large footprint.---   For this need, attoparsec's incremental input provides an---   excellent substitute, with much more control over when input---   takes place.  If you must use lazy bytestrings, see the---   "Data.Attoparsec.ByteString.Lazy" module, which feeds lazy chunks---   to a regular parser.------ * Parsec parsers can produce more helpful error messages than---   attoparsec parsers.  This is a matter of focus: attoparsec avoids---   the extra book-keeping in favour of higher performance.---- $incremental------ attoparsec supports incremental input, meaning that you can feed it--- a bytestring that represents only part of the expected total amount--- of data to parse. If your parser reaches the end of a fragment of--- input and could consume more input, it will suspend parsing and--- return a 'T.Partial' continuation.------ Supplying the 'T.Partial' continuation with a bytestring will--- resume parsing at the point where it was suspended, with the--- bytestring you supplied used as new input at the end of the--- existing input. You must be prepared for the result of the resumed--- parse to be another 'T.Partial' continuation.------ To indicate that you have no more input, supply the 'T.Partial'--- continuation with an empty bytestring.------ Remember that some parsing combinators will not return a result--- until they reach the end of input.  They may thus cause 'T.Partial'--- results to be returned.------ If you do not need support for incremental input, consider using--- the 'I.parseOnly' function to run your parser.  It will never--- prompt for more input.------ /Note/: incremental input does /not/ imply that attoparsec will--- release portions of its internal state for garbage collection as it--- proceeds.  Its internal representation is equivalent to a single--- 'ByteString': if you feed incremental input to a parser, it will--- require memory proportional to the amount of input you supply.--- (This is necessary to support arbitrary backtracking.)---- $performance------ If you write an attoparsec-based parser carefully, it can be--- realistic to expect it to perform similarly to a hand-rolled C--- parser (measuring megabytes parsed per second).------ To actually achieve high performance, there are a few guidelines--- that it is useful to follow.------ Use the 'B.ByteString'-oriented parsers whenever possible,--- e.g. 'I.takeWhile1' instead of 'many1' 'I.anyWord8'.  There is--- about a factor of 100 difference in performance between the two--- kinds of parser.------ For very simple byte-testing predicates, write them by hand instead--- of using 'I.inClass' or 'I.notInClass'.  For instance, both of--- these predicates test for an end-of-line byte, but the first is--- much faster than the second:------ >endOfLine_fast w = w == 13 || w == 10--- >endOfLine_slow   = inClass "\r\n"------ Make active use of benchmarking and profiling tools to measure,--- find the problems with, and improve the performance of your parser.---- | Run a parser and print its result to standard output.-parseTest :: (Show a) => I.Parser a -> B.ByteString -> IO ()-parseTest p s = print (parse p s)---- | Run a parser with an initial input string, and a monadic action--- that can supply more input if needed.-parseWith :: Monad m =>-             (m B.ByteString)-          -- ^ An action that will be executed to provide the parser-          -- with more input, if necessary.  The action must return an-          -- 'B.empty' string when there is no more input available.-          -> I.Parser a-          -> B.ByteString-          -- ^ Initial input for the parser.-          -> m (Result a)-parseWith refill p s = step $ parse p s-  where step (T.Partial k) = (step . k) =<< refill-        step r             = return r-{-# INLINE parseWith #-}---- | Convert a 'Result' value to a 'Maybe' value. A 'T.Partial' result--- is treated as failure.-maybeResult :: Result r -> Maybe r-maybeResult (T.Done _ r) = Just r-maybeResult _            = Nothing---- | Convert a 'Result' value to an 'Either' value. A 'T.Partial'--- result is treated as failure.-eitherResult :: Result r -> Either String r-eitherResult (T.Done _ r)        = Right r-eitherResult (T.Fail _ [] msg)   = Left msg-eitherResult (T.Fail _ ctxs msg) = Left (intercalate " > " ctxs ++ ": " ++ msg)-eitherResult _                   = Left "Result: incomplete input"
− haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/ByteString/Buffer.hs 
@@ -1,156 +0,0 @@-{-# LANGUAGE BangPatterns #-}--- |--- Module      :  Data.Attoparsec.ByteString.Buffer--- Copyright   :  Bryan O'Sullivan 2007-2015--- License     :  BSD3------ Maintainer  :  bos@serpentine.com--- Stability   :  experimental--- Portability :  GHC------ An "immutable" buffer that supports cheap appends.------ A Buffer is divided into an immutable read-only zone, followed by a--- mutable area that we've preallocated, but not yet written to.------ We overallocate at the end of a Buffer so that we can cheaply--- append.  Since a user of an existing Buffer cannot see past the end--- of its immutable zone into the data that will change during an--- append, this is safe.------ Once we run out of space at the end of a Buffer, we do the usual--- doubling of the buffer size.------ The fact of having a mutable buffer really helps with performance,--- but it does have a consequence: if someone misuses the Partial API--- that attoparsec uses by calling the same continuation repeatedly--- (which never makes sense in practice), they could overwrite data.------ Since the API *looks* pure, it should *act* pure, too, so we use--- two generation counters (one mutable, one immutable) to track the--- number of appends to a mutable buffer. If the counters ever get out--- of sync, someone is appending twice to a mutable buffer, so we--- duplicate the entire buffer in order to preserve the immutability--- of its older self.------ While we could go a step further and gain protection against API--- abuse on a multicore system, by use of an atomic increment--- instruction to bump the mutable generation counter, that would be--- very expensive, and feels like it would also be in the realm of the--- ridiculous.  Clients should never call a continuation more than--- once; we lack a linear type system that could enforce this; and--- there's only so far we should go to accommodate broken uses.--module Data.Attoparsec.ByteString.Buffer-    (-      Buffer-    , buffer-    , unbuffer-    , pappend-    , length-    , unsafeIndex-    , substring-    , unsafeDrop-    ) where--import Control.Exception (assert)-import Data.ByteString.Internal (ByteString(..), memcpy, nullForeignPtr)-import Data.Attoparsec.Internal.Fhthagn (inlinePerformIO)-import Data.List (foldl1')-import Data.Monoid as Mon (Monoid(..))-import Data.Semigroup (Semigroup(..))-import Data.Word (Word8)-import Foreign.ForeignPtr (ForeignPtr, withForeignPtr)-import Foreign.Ptr (castPtr, plusPtr)-import Foreign.Storable (peek, peekByteOff, poke, sizeOf)-import GHC.ForeignPtr (mallocPlainForeignPtrBytes)-import Prelude hiding (length)---- If _cap is zero, this buffer is empty.-data Buffer = Buf {-      _fp  :: {-# UNPACK #-} !(ForeignPtr Word8)-    , _off :: {-# UNPACK #-} !Int-    , _len :: {-# UNPACK #-} !Int-    , _cap :: {-# UNPACK #-} !Int-    , _gen :: {-# UNPACK #-} !Int-    }--instance Show Buffer where-    showsPrec p = showsPrec p . unbuffer---- | The initial 'Buffer' has no mutable zone, so we can avoid all--- copies in the (hopefully) common case of no further input being fed--- to us.-buffer :: ByteString -> Buffer-buffer (PS fp off len) = Buf fp off len len 0--unbuffer :: Buffer -> ByteString-unbuffer (Buf fp off len _ _) = PS fp off len--instance Semigroup Buffer where-    (Buf _ _ _ 0 _) <> b                    = b-    a               <> (Buf _ _ _ 0 _)      = a-    buf             <> (Buf fp off len _ _) = append buf fp off len--instance Monoid Buffer where-    mempty = Buf nullForeignPtr 0 0 0 0--    mappend = (<>)--    mconcat [] = Mon.mempty-    mconcat xs = foldl1' mappend xs--pappend :: Buffer -> ByteString -> Buffer-pappend (Buf _ _ _ 0 _) bs  = buffer bs-pappend buf (PS fp off len) = append buf fp off len--append :: Buffer -> ForeignPtr a -> Int -> Int -> Buffer-append (Buf fp0 off0 len0 cap0 gen0) !fp1 !off1 !len1 =-  inlinePerformIO . withForeignPtr fp0 $ \ptr0 ->-    withForeignPtr fp1 $ \ptr1 -> do-      let genSize = sizeOf (0::Int)-          newlen  = len0 + len1-      gen <- if gen0 == 0-             then return 0-             else peek (castPtr ptr0)-      if gen == gen0 && newlen <= cap0-        then do-          let newgen = gen + 1-          poke (castPtr ptr0) newgen-          memcpy (ptr0 `plusPtr` (off0+len0))-                 (ptr1 `plusPtr` off1)-                 (fromIntegral len1)-          return (Buf fp0 off0 newlen cap0 newgen)-        else do-          let newcap = newlen * 2-          fp <- mallocPlainForeignPtrBytes (newcap + genSize)-          withForeignPtr fp $ \ptr_ -> do-            let ptr    = ptr_ `plusPtr` genSize-                newgen = 1-            poke (castPtr ptr_) newgen-            memcpy ptr (ptr0 `plusPtr` off0) (fromIntegral len0)-            memcpy (ptr `plusPtr` len0) (ptr1 `plusPtr` off1)-                   (fromIntegral len1)-            return (Buf fp genSize newlen newcap newgen)--length :: Buffer -> Int-length (Buf _ _ len _ _) = len-{-# INLINE length #-}--unsafeIndex :: Buffer -> Int -> Word8-unsafeIndex (Buf fp off len _ _) i = assert (i >= 0 && i < len) .-    inlinePerformIO . withForeignPtr fp $ flip peekByteOff (off+i)-{-# INLINE unsafeIndex #-}--substring :: Int -> Int -> Buffer -> ByteString-substring s l (Buf fp off len _ _) =-  assert (s >= 0 && s <= len) .-  assert (l >= 0 && l <= len-s) $-  PS fp (off+s) l-{-# INLINE substring #-}--unsafeDrop :: Int -> Buffer -> ByteString-unsafeDrop s (Buf fp off len _ _) =-  assert (s >= 0 && s <= len) $-  PS fp (off+s) (len-s)-{-# INLINE unsafeDrop #-}
− haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/ByteString/Char8.hs 
@@ -1,464 +0,0 @@-{-# LANGUAGE BangPatterns, CPP, FlexibleInstances, TypeFamilies,-    TypeSynonymInstances, GADTs #-}-#if __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-} -- Imports internal modules-#endif-{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-warnings-deprecations #-}---- |--- Module      :  Data.Attoparsec.ByteString.Char8--- Copyright   :  Bryan O'Sullivan 2007-2015--- License     :  BSD3------ Maintainer  :  bos@serpentine.com--- Stability   :  experimental--- Portability :  unknown------ Simple, efficient, character-oriented combinator parsing for--- 'B.ByteString' strings, loosely based on the Parsec library.--module Data.Attoparsec.ByteString.Char8-    (-    -- * Character encodings-    -- $encodings--    -- * Parser types-      Parser-    , A.Result-    , A.IResult(..)-    , I.compareResults--    -- * Running parsers-    , A.parse-    , A.feed-    , A.parseOnly-    , A.parseWith-    , A.parseTest--    -- ** Result conversion-    , A.maybeResult-    , A.eitherResult--    -- * Parsing individual characters-    , char-    , char8-    , anyChar-    , notChar-    , satisfy--    -- ** Lookahead-    , peekChar-    , peekChar'--    -- ** Special character parsers-    , digit-    , letter_iso8859_15-    , letter_ascii-    , space--    -- ** Fast predicates-    , isDigit-    , isDigit_w8-    , isAlpha_iso8859_15-    , isAlpha_ascii-    , isSpace-    , isSpace_w8--    -- *** Character classes-    , inClass-    , notInClass--    -- * Efficient string handling-    , I.string-    , I.stringCI-    , skipSpace-    , skipWhile-    , I.take-    , scan-    , takeWhile-    , takeWhile1-    , takeTill--    -- ** String combinators-    -- $specalt-    , (.*>)-    , (<*.)--    -- ** Consume all remaining input-    , I.takeByteString-    , I.takeLazyByteString--    -- * Text parsing-    , I.endOfLine-    , isEndOfLine-    , isHorizontalSpace--    -- * Numeric parsers-    , decimal-    , hexadecimal-    , signed--    -- * Combinators-    , try-    , (<?>)-    , choice-    , count-    , option-    , many'-    , many1-    , many1'-    , manyTill-    , manyTill'-    , sepBy-    , sepBy'-    , sepBy1-    , sepBy1'-    , skipMany-    , skipMany1-    , eitherP-    , I.match-    -- * State observation and manipulation functions-    , I.endOfInput-    , I.atEnd-    ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative (pure, (*>), (<*), (<$>))-import Data.Word (Word)-#endif-import Control.Applicative ((<|>))-import Data.Attoparsec.ByteString.FastSet (charClass, memberChar)-import Data.Attoparsec.ByteString.Internal (Parser)-import Data.Attoparsec.Combinator-import Data.Bits (Bits, (.|.), shiftL)-import Data.ByteString.Internal (c2w, w2c)-import Data.Int (Int8, Int16, Int32, Int64)-import Data.String (IsString(..))-import Data.Word (Word8, Word16, Word32, Word64)-import Prelude hiding (takeWhile)-import qualified Data.Attoparsec.ByteString as A-import qualified Data.Attoparsec.ByteString.Internal as I-import qualified Data.Attoparsec.Internal as I-import qualified Data.ByteString as B8-import qualified Data.ByteString.Char8 as B--instance (a ~ B.ByteString) => IsString (Parser a) where-    fromString = I.string . B.pack---- $encodings------ This module is intended for parsing text that is--- represented using an 8-bit character set, e.g. ASCII or--- ISO-8859-15.  It /does not/ make any attempt to deal with character--- encodings, multibyte characters, or wide characters.  In--- particular, all attempts to use characters above code point U+00FF--- will give wrong answers.------ Code points below U+0100 are simply translated to and from their--- numeric values, so e.g. the code point U+00A4 becomes the byte--- @0xA4@ (which is the Euro symbol in ISO-8859-15, but the generic--- currency sign in ISO-8859-1).  Haskell 'Char' values above U+00FF--- are truncated, so e.g. U+1D6B7 is truncated to the byte @0xB7@.---- | Consume input as long as the predicate returns 'True', and return--- the consumed input.------ This parser requires the predicate to succeed on at least one byte--- of input: it will fail if the predicate never returns 'True' or if--- there is no input left.-takeWhile1 :: (Char -> Bool) -> Parser B.ByteString-takeWhile1 p = I.takeWhile1 (p . w2c)-{-# INLINE takeWhile1 #-}---- | The parser @satisfy p@ succeeds for any byte for which the--- predicate @p@ returns 'True'. Returns the byte that is actually--- parsed.------ >digit = satisfy isDigit--- >    where isDigit c = c >= '0' && c <= '9'-satisfy :: (Char -> Bool) -> Parser Char-satisfy = I.satisfyWith w2c-{-# INLINE satisfy #-}---- | Match a letter, in the ISO-8859-15 encoding.-letter_iso8859_15 :: Parser Char-letter_iso8859_15 = satisfy isAlpha_iso8859_15 <?> "letter_iso8859_15"-{-# INLINE letter_iso8859_15 #-}---- | Match a letter, in the ASCII encoding.-letter_ascii :: Parser Char-letter_ascii = satisfy isAlpha_ascii <?> "letter_ascii"-{-# INLINE letter_ascii #-}---- | A fast alphabetic predicate for the ISO-8859-15 encoding------ /Note/: For all character encodings other than ISO-8859-15, and--- almost all Unicode code points above U+00A3, this predicate gives--- /wrong answers/.-isAlpha_iso8859_15 :: Char -> Bool-isAlpha_iso8859_15 c = (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') ||-                       (c >= '\166' && moby c)-  where moby = notInClass "\167\169\171-\179\182\183\185\187\191\215\247"-        {-# NOINLINE moby #-}-{-# INLINE isAlpha_iso8859_15 #-}---- | A fast alphabetic predicate for the ASCII encoding------ /Note/: For all character encodings other than ASCII, and--- almost all Unicode code points above U+007F, this predicate gives--- /wrong answers/.-isAlpha_ascii :: Char -> Bool-isAlpha_ascii c = (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')-{-# INLINE isAlpha_ascii #-}---- | Parse a single digit.-digit :: Parser Char-digit = satisfy isDigit <?> "digit"-{-# INLINE digit #-}---- | A fast digit predicate.-isDigit :: Char -> Bool-isDigit c = c >= '0' && c <= '9'-{-# INLINE isDigit #-}---- | A fast digit predicate.-isDigit_w8 :: Word8 -> Bool-isDigit_w8 w = w - 48 <= 9-{-# INLINE isDigit_w8 #-}---- | Match any character.-anyChar :: Parser Char-anyChar = satisfy $ const True-{-# INLINE anyChar #-}---- | Match any character, to perform lookahead. Returns 'Nothing' if--- end of input has been reached. Does not consume any input.------ /Note/: Because this parser does not fail, do not use it with--- combinators such as 'many', because such parsers loop until a--- failure occurs.  Careless use will thus result in an infinite loop.-peekChar :: Parser (Maybe Char)-peekChar = (fmap w2c) `fmap` I.peekWord8-{-# INLINE peekChar #-}---- | Match any character, to perform lookahead.  Does not consume any--- input, but will fail if end of input has been reached.-peekChar' :: Parser Char-peekChar' = w2c `fmap` I.peekWord8'-{-# INLINE peekChar' #-}---- | Fast predicate for matching ASCII space characters.------ /Note/: This predicate only gives correct answers for the ASCII--- encoding.  For instance, it does not recognise U+00A0 (non-breaking--- space) as a space character, even though it is a valid ISO-8859-15--- byte. For a Unicode-aware and only slightly slower predicate,--- use 'Data.Char.isSpace'-isSpace :: Char -> Bool-isSpace c = (c == ' ') || ('\t' <= c && c <= '\r')-{-# INLINE isSpace #-}---- | Fast 'Word8' predicate for matching ASCII space characters.-isSpace_w8 :: Word8 -> Bool-isSpace_w8 w = w == 32 || w - 9 <= 4-{-# INLINE isSpace_w8 #-}----- | Parse a space character.------ /Note/: This parser only gives correct answers for the ASCII--- encoding.  For instance, it does not recognise U+00A0 (non-breaking--- space) as a space character, even though it is a valid ISO-8859-15--- byte.-space :: Parser Char-space = satisfy isSpace <?> "space"-{-# INLINE space #-}---- | Match a specific character.-char :: Char -> Parser Char-char c = satisfy (== c) <?> [c]-{-# INLINE char #-}---- | Match a specific character, but return its 'Word8' value.-char8 :: Char -> Parser Word8-char8 c = I.satisfy (== c2w c) <?> [c]-{-# INLINE char8 #-}---- | Match any character except the given one.-notChar :: Char -> Parser Char-notChar c = satisfy (/= c) <?> "not " ++ [c]-{-# INLINE notChar #-}---- | Match any character in a set.------ >vowel = inClass "aeiou"------ Range notation is supported.------ >halfAlphabet = inClass "a-nA-N"------ To add a literal \'-\' to a set, place it at the beginning or end--- of the string.-inClass :: String -> Char -> Bool-inClass s = (`memberChar` mySet)-    where mySet = charClass s-{-# INLINE inClass #-}---- | Match any character not in a set.-notInClass :: String -> Char -> Bool-notInClass s = not . inClass s-{-# INLINE notInClass #-}---- | Consume input as long as the predicate returns 'True', and return--- the consumed input.------ This parser does not fail.  It will return an empty string if the--- predicate returns 'False' on the first byte of input.------ /Note/: Because this parser does not fail, do not use it with--- combinators such as 'many', because such parsers loop until a--- failure occurs.  Careless use will thus result in an infinite loop.-takeWhile :: (Char -> Bool) -> Parser B.ByteString-takeWhile p = I.takeWhile (p . w2c)-{-# INLINE takeWhile #-}---- | A stateful scanner.  The predicate consumes and transforms a--- state argument, and each transformed state is passed to successive--- invocations of the predicate on each byte of the input until one--- returns 'Nothing' or the input ends.------ This parser does not fail.  It will return an empty string if the--- predicate returns 'Nothing' on the first byte of input.------ /Note/: Because this parser does not fail, do not use it with--- combinators such as 'many', because such parsers loop until a--- failure occurs.  Careless use will thus result in an infinite loop.-scan :: s -> (s -> Char -> Maybe s) -> Parser B.ByteString-scan s0 p = I.scan s0 (\s -> p s . w2c)-{-# INLINE scan #-}---- | Consume input as long as the predicate returns 'False'--- (i.e. until it returns 'True'), and return the consumed input.------ This parser does not fail.  It will return an empty string if the--- predicate returns 'True' on the first byte of input.------ /Note/: Because this parser does not fail, do not use it with--- combinators such as 'many', because such parsers loop until a--- failure occurs.  Careless use will thus result in an infinite loop.-takeTill :: (Char -> Bool) -> Parser B.ByteString-takeTill p = I.takeTill (p . w2c)-{-# INLINE takeTill #-}---- | Skip past input for as long as the predicate returns 'True'.-skipWhile :: (Char -> Bool) -> Parser ()-skipWhile p = I.skipWhile (p . w2c)-{-# INLINE skipWhile #-}---- | Skip over white space.-skipSpace :: Parser ()-skipSpace = I.skipWhile isSpace_w8-{-# INLINE skipSpace #-}---- $specalt------ If you enable the @OverloadedStrings@ language extension, you can--- use the '*>' and '<*' combinators to simplify the common task of--- matching a statically known string, then immediately parsing--- something else.------ Instead of writing something like this:------ @---'I.string' \"foo\" '*>' wibble--- @------ Using @OverloadedStrings@, you can omit the explicit use of--- 'I.string', and write a more compact version:------ @--- \"foo\" '*>' wibble--- @------ (Note: the '.*>' and '<*.' combinators that were originally--- provided for this purpose are obsolete and unnecessary, and will be--- removed in the next major version.)---- | /Obsolete/. A type-specialized version of '*>' for--- 'B.ByteString'. Use '*>' instead.-(.*>) :: B.ByteString -> Parser a -> Parser a-s .*> f = I.string s *> f-{-# DEPRECATED (.*>) "This is no longer necessary, and will be removed. Use '*>' instead." #-}---- | /Obsolete/. A type-specialized version of '<*' for--- 'B.ByteString'. Use '<*' instead.-(<*.) :: Parser a -> B.ByteString -> Parser a-f <*. s = f <* I.string s-{-# DEPRECATED (<*.) "This is no longer necessary, and will be removed. Use '<*' instead." #-}---- | A predicate that matches either a carriage return @\'\\r\'@ or--- newline @\'\\n\'@ character.-isEndOfLine :: Word8 -> Bool-isEndOfLine w = w == 13 || w == 10-{-# INLINE isEndOfLine #-}---- | A predicate that matches either a space @\' \'@ or horizontal tab--- @\'\\t\'@ character.-isHorizontalSpace :: Word8 -> Bool-isHorizontalSpace w = w == 32 || w == 9-{-# INLINE isHorizontalSpace #-}---- | Parse and decode an unsigned hexadecimal number.  The hex digits--- @\'a\'@ through @\'f\'@ may be upper or lower case.------ This parser does not accept a leading @\"0x\"@ string.-hexadecimal :: (Integral a, Bits a) => Parser a-hexadecimal = B8.foldl' step 0 `fmap` I.takeWhile1 isHexDigit-  where-    isHexDigit w = (w >= 48 && w <= 57) ||-                   (w >= 97 && w <= 102) ||-                   (w >= 65 && w <= 70)-    step a w | w >= 48 && w <= 57  = (a `shiftL` 4) .|. fromIntegral (w - 48)-             | w >= 97             = (a `shiftL` 4) .|. fromIntegral (w - 87)-             | otherwise           = (a `shiftL` 4) .|. fromIntegral (w - 55)-{-# SPECIALISE hexadecimal :: Parser Int #-}-{-# SPECIALISE hexadecimal :: Parser Int8 #-}-{-# SPECIALISE hexadecimal :: Parser Int16 #-}-{-# SPECIALISE hexadecimal :: Parser Int32 #-}-{-# SPECIALISE hexadecimal :: Parser Int64 #-}-{-# SPECIALISE hexadecimal :: Parser Integer #-}-{-# SPECIALISE hexadecimal :: Parser Word #-}-{-# SPECIALISE hexadecimal :: Parser Word8 #-}-{-# SPECIALISE hexadecimal :: Parser Word16 #-}-{-# SPECIALISE hexadecimal :: Parser Word32 #-}-{-# SPECIALISE hexadecimal :: Parser Word64 #-}---- | Parse and decode an unsigned decimal number.-decimal :: Integral a => Parser a-decimal = B8.foldl' step 0 `fmap` I.takeWhile1 isDigit_w8-  where step a w = a * 10 + fromIntegral (w - 48)-{-# SPECIALISE decimal :: Parser Int #-}-{-# SPECIALISE decimal :: Parser Int8 #-}-{-# SPECIALISE decimal :: Parser Int16 #-}-{-# SPECIALISE decimal :: Parser Int32 #-}-{-# SPECIALISE decimal :: Parser Int64 #-}-{-# SPECIALISE decimal :: Parser Integer #-}-{-# SPECIALISE decimal :: Parser Word #-}-{-# SPECIALISE decimal :: Parser Word8 #-}-{-# SPECIALISE decimal :: Parser Word16 #-}-{-# SPECIALISE decimal :: Parser Word32 #-}-{-# SPECIALISE decimal :: Parser Word64 #-}---- | Parse a number with an optional leading @\'+\'@ or @\'-\'@ sign--- character.-signed :: Num a => Parser a -> Parser a-{-# SPECIALISE signed :: Parser Int -> Parser Int #-}-{-# SPECIALISE signed :: Parser Int8 -> Parser Int8 #-}-{-# SPECIALISE signed :: Parser Int16 -> Parser Int16 #-}-{-# SPECIALISE signed :: Parser Int32 -> Parser Int32 #-}-{-# SPECIALISE signed :: Parser Int64 -> Parser Int64 #-}-{-# SPECIALISE signed :: Parser Integer -> Parser Integer #-}-signed p = (negate <$> (char8 '-' *> p))-       <|> (char8 '+' *> p)-       <|> p-
− haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/ByteString/FastSet.hs 
@@ -1,115 +0,0 @@-{-# LANGUAGE BangPatterns, MagicHash #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Attoparsec.ByteString.FastSet--- Copyright   :  Bryan O'Sullivan 2007-2015--- License     :  BSD3------ Maintainer  :  bos@serpentine.com--- Stability   :  experimental--- Portability :  unknown------ Fast set membership tests for 'Word8' and 8-bit 'Char' values.  The--- set representation is unboxed for efficiency.  For small sets, we--- test for membership using a binary search.  For larger sets, we use--- a lookup table.----------------------------------------------------------------------------------module Data.Attoparsec.ByteString.FastSet-    (-    -- * Data type-      FastSet-    -- * Construction-    , fromList-    , set-    -- * Lookup-    , memberChar-    , memberWord8-    -- * Debugging-    , fromSet-    -- * Handy interface-    , charClass-    ) where--import Data.Bits ((.&.), (.|.))-import Foreign.Storable (peekByteOff, pokeByteOff)-import GHC.Base (Int(I#), iShiftRA#, narrow8Word#, shiftL#)-import GHC.Word (Word8(W8#))-import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as B8-import qualified Data.ByteString.Internal as I-import qualified Data.ByteString.Unsafe as U--data FastSet = Sorted { fromSet :: !B.ByteString }-             | Table  { fromSet :: !B.ByteString }-    deriving (Eq, Ord)--instance Show FastSet where-    show (Sorted s) = "FastSet Sorted " ++ show (B8.unpack s)-    show (Table _) = "FastSet Table"---- | The lower bound on the size of a lookup table.  We choose this to--- balance table density against performance.-tableCutoff :: Int-tableCutoff = 8---- | Create a set.-set :: B.ByteString -> FastSet-set s | B.length s < tableCutoff = Sorted . B.sort $ s-      | otherwise                = Table . mkTable $ s--fromList :: [Word8] -> FastSet-fromList = set . B.pack--data I = I {-# UNPACK #-} !Int {-# UNPACK #-} !Word8--shiftR :: Int -> Int -> Int-shiftR (I# x#) (I# i#) = I# (x# `iShiftRA#` i#)--shiftL :: Word8 -> Int -> Word8-shiftL (W8# x#) (I# i#) = W8# (narrow8Word# (x# `shiftL#` i#))--index :: Int -> I-index i = I (i `shiftR` 3) (1 `shiftL` (i .&. 7))-{-# INLINE index #-}---- | Check the set for membership.-memberWord8 :: Word8 -> FastSet -> Bool-memberWord8 w (Table t)  =-    let I byte bit = index (fromIntegral w)-    in  U.unsafeIndex t byte .&. bit /= 0-memberWord8 w (Sorted s) = search 0 (B.length s - 1)-    where search lo hi-              | hi < lo = False-              | otherwise =-                  let mid = (lo + hi) `quot` 2-                  in case compare w (U.unsafeIndex s mid) of-                       GT -> search (mid + 1) hi-                       LT -> search lo (mid - 1)-                       _ -> True---- | Check the set for membership.  Only works with 8-bit characters:--- characters above code point 255 will give wrong answers.-memberChar :: Char -> FastSet -> Bool-memberChar c = memberWord8 (I.c2w c)-{-# INLINE memberChar #-}--mkTable :: B.ByteString -> B.ByteString-mkTable s = I.unsafeCreate 32 $ \t -> do-            _ <- I.memset t 0 32-            U.unsafeUseAsCStringLen s $ \(p, l) ->-              let loop n | n == l = return ()-                         | otherwise = do-                    c <- peekByteOff p n :: IO Word8-                    let I byte bit = index (fromIntegral c)-                    prev <- peekByteOff t byte :: IO Word8-                    pokeByteOff t byte (prev .|. bit)-                    loop (n + 1)-              in loop 0--charClass :: String -> FastSet-charClass = set . B8.pack . go-    where go (a:'-':b:xs) = [a..b] ++ go xs-          go (x:xs) = x : go xs-          go _ = ""
− haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/ByteString/Internal.hs 
@@ -1,536 +0,0 @@-{-# LANGUAGE BangPatterns, CPP, GADTs, OverloadedStrings, RankNTypes,-    RecordWildCards #-}--- |--- Module      :  Data.Attoparsec.ByteString.Internal--- Copyright   :  Bryan O'Sullivan 2007-2015--- License     :  BSD3------ Maintainer  :  bos@serpentine.com--- Stability   :  experimental--- Portability :  unknown------ Simple, efficient parser combinators for 'ByteString' strings,--- loosely based on the Parsec library.--module Data.Attoparsec.ByteString.Internal-    (-    -- * Parser types-      Parser-    , Result--    -- * Running parsers-    , parse-    , parseOnly--    -- * Combinators-    , module Data.Attoparsec.Combinator--    -- * Parsing individual bytes-    , satisfy-    , satisfyWith-    , anyWord8-    , skip-    , word8-    , notWord8--    -- ** Lookahead-    , peekWord8-    , peekWord8'--    -- ** Byte classes-    , inClass-    , notInClass--    -- * Parsing more complicated structures-    , storable--    -- * Efficient string handling-    , skipWhile-    , string-    , stringCI-    , take-    , scan-    , runScanner-    , takeWhile-    , takeWhile1-    , takeTill--    -- ** Consume all remaining input-    , takeByteString-    , takeLazyByteString--    -- * Utilities-    , endOfLine-    , endOfInput-    , match-    , atEnd-    ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))-#endif-import Control.Applicative ((<|>))-import Control.Monad (when)-import Data.Attoparsec.ByteString.Buffer (Buffer, buffer)-import Data.Attoparsec.ByteString.FastSet (charClass, memberWord8)-import Data.Attoparsec.Combinator ((<?>))-import Data.Attoparsec.Internal-import Data.Attoparsec.Internal.Fhthagn (inlinePerformIO)-import Data.Attoparsec.Internal.Types hiding (Parser, Failure, Success)-import Data.ByteString (ByteString)-import Data.List (intercalate)-import Data.Word (Word8)-import Foreign.ForeignPtr (withForeignPtr)-import Foreign.Ptr (castPtr, minusPtr, plusPtr)-import Foreign.Storable (Storable(peek, sizeOf))-import Prelude hiding (getChar, succ, take, takeWhile)-import qualified Data.Attoparsec.ByteString.Buffer as Buf-import qualified Data.Attoparsec.Internal.Types as T-import qualified Data.ByteString as B8-import qualified Data.ByteString.Char8 as B-import qualified Data.ByteString.Internal as B-import qualified Data.ByteString.Lazy as L-import qualified Data.ByteString.Unsafe as B--type Parser = T.Parser ByteString-type Result = IResult ByteString-type Failure r = T.Failure ByteString Buffer r-type Success a r = T.Success ByteString Buffer a r---- | The parser @satisfy p@ succeeds for any byte for which the--- predicate @p@ returns 'True'. Returns the byte that is actually--- parsed.------ >digit = satisfy isDigit--- >    where isDigit w = w >= 48 && w <= 57-satisfy :: (Word8 -> Bool) -> Parser Word8-satisfy p = do-  h <- peekWord8'-  if p h-    then advance 1 >> return h-    else fail "satisfy"-{-# INLINE satisfy #-}---- | The parser @skip p@ succeeds for any byte for which the predicate--- @p@ returns 'True'.------ >skipDigit = skip isDigit--- >    where isDigit w = w >= 48 && w <= 57-skip :: (Word8 -> Bool) -> Parser ()-skip p = do-  h <- peekWord8'-  if p h-    then advance 1-    else fail "skip"---- | The parser @satisfyWith f p@ transforms a byte, and succeeds if--- the predicate @p@ returns 'True' on the transformed value. The--- parser returns the transformed byte that was parsed.-satisfyWith :: (Word8 -> a) -> (a -> Bool) -> Parser a-satisfyWith f p = do-  h <- peekWord8'-  let c = f h-  if p c-    then advance 1 >> return c-    else fail "satisfyWith"-{-# INLINE satisfyWith #-}--storable :: Storable a => Parser a-storable = hack undefined- where-  hack :: Storable b => b -> Parser b-  hack dummy = do-    (fp,o,_) <- B.toForeignPtr `fmap` take (sizeOf dummy)-    return . inlinePerformIO . withForeignPtr fp $ \p ->-        peek (castPtr $ p `plusPtr` o)---- | Consume exactly @n@ bytes of input.-take :: Int -> Parser ByteString-take n0 = do-  let n = max n0 0-  s <- ensure n-  advance n >> return s-{-# INLINE take #-}---- | @string s@ parses a sequence of bytes that identically match--- @s@. Returns the parsed string (i.e. @s@).  This parser consumes no--- input if it fails (even if a partial match).------ /Note/: The behaviour of this parser is different to that of the--- similarly-named parser in Parsec, as this one is all-or-nothing.--- To illustrate the difference, the following parser will fail under--- Parsec given an input of @\"for\"@:------ >string "foo" <|> string "for"------ The reason for its failure is that the first branch is a--- partial match, and will consume the letters @\'f\'@ and @\'o\'@--- before failing.  In attoparsec, the above parser will /succeed/ on--- that input, because the failed first branch will consume nothing.-string :: ByteString -> Parser ByteString-string s = string_ (stringSuspended id) id s-{-# INLINE string #-}---- ASCII-specific but fast, oh yes.-toLower :: Word8 -> Word8-toLower w | w >= 65 && w <= 90 = w + 32-          | otherwise          = w---- | Satisfy a literal string, ignoring case.-stringCI :: ByteString -> Parser ByteString-stringCI s = string_ (stringSuspended lower) lower s-  where lower = B8.map toLower-{-# INLINE stringCI #-}--string_ :: (forall r. ByteString -> ByteString -> Buffer -> Pos -> More-            -> Failure r -> Success ByteString r -> Result r)-        -> (ByteString -> ByteString)-        -> ByteString -> Parser ByteString-string_ suspended f s0 = T.Parser $ \t pos more lose succ ->-  let n = B.length s-      s = f s0-  in if lengthAtLeast pos n t-     then let t' = substring pos (Pos n) t-          in if s == f t'-             then succ t (pos + Pos n) more t'-             else lose t pos more [] "string"-     else let t' = Buf.unsafeDrop (fromPos pos) t-          in if f t' `B.isPrefixOf` s-             then suspended s (B.drop (B.length t') s) t pos more lose succ-             else lose t pos more [] "string"-{-# INLINE string_ #-}--stringSuspended :: (ByteString -> ByteString)-                -> ByteString -> ByteString -> Buffer -> Pos -> More-                -> Failure r-                -> Success ByteString r-                -> Result r-stringSuspended f s0 s t pos more lose succ =-    runParser (demandInput_ >>= go) t pos more lose succ-  where go s'0   = T.Parser $ \t' pos' more' lose' succ' ->-          let m  = B.length s-              s' = f s'0-              n  = B.length s'-          in if n >= m-             then if B.unsafeTake m s' == s-                  then let o = Pos (B.length s0)-                       in succ' t' (pos' + o) more'-                          (substring pos' o t')-                  else lose' t' pos' more' [] "string"-             else if s' == B.unsafeTake n s-                  then stringSuspended f s0 (B.unsafeDrop n s)-                       t' pos' more' lose' succ'-                  else lose' t' pos' more' [] "string"---- | Skip past input for as long as the predicate returns 'True'.-skipWhile :: (Word8 -> Bool) -> Parser ()-skipWhile p = go- where-  go = do-    t <- B8.takeWhile p <$> get-    continue <- inputSpansChunks (B.length t)-    when continue go-{-# INLINE skipWhile #-}---- | Consume input as long as the predicate returns 'False'--- (i.e. until it returns 'True'), and return the consumed input.------ This parser does not fail.  It will return an empty string if the--- predicate returns 'True' on the first byte of input.------ /Note/: Because this parser does not fail, do not use it with--- combinators such as 'Control.Applicative.many', because such--- parsers loop until a failure occurs.  Careless use will thus result--- in an infinite loop.-takeTill :: (Word8 -> Bool) -> Parser ByteString-takeTill p = takeWhile (not . p)-{-# INLINE takeTill #-}---- | Consume input as long as the predicate returns 'True', and return--- the consumed input.------ This parser does not fail.  It will return an empty string if the--- predicate returns 'False' on the first byte of input.------ /Note/: Because this parser does not fail, do not use it with--- combinators such as 'Control.Applicative.many', because such--- parsers loop until a failure occurs.  Careless use will thus result--- in an infinite loop.-takeWhile :: (Word8 -> Bool) -> Parser ByteString-takeWhile p = do-    s <- B8.takeWhile p <$> get-    continue <- inputSpansChunks (B.length s)-    if continue-      then takeWhileAcc p [s]-      else return s-{-# INLINE takeWhile #-}--takeWhileAcc :: (Word8 -> Bool) -> [ByteString] -> Parser ByteString-takeWhileAcc p = go- where-  go acc = do-    s <- B8.takeWhile p <$> get-    continue <- inputSpansChunks (B.length s)-    if continue-      then go (s:acc)-      else return $ concatReverse (s:acc)-{-# INLINE takeWhileAcc #-}--takeRest :: Parser [ByteString]-takeRest = go []- where-  go acc = do-    input <- wantInput-    if input-      then do-        s <- get-        advance (B.length s)-        go (s:acc)-      else return (reverse acc)---- | Consume all remaining input and return it as a single string.-takeByteString :: Parser ByteString-takeByteString = B.concat `fmap` takeRest---- | Consume all remaining input and return it as a single string.-takeLazyByteString :: Parser L.ByteString-takeLazyByteString = L.fromChunks `fmap` takeRest--data T s = T {-# UNPACK #-} !Int s--scan_ :: (s -> [ByteString] -> Parser r) -> s -> (s -> Word8 -> Maybe s)-         -> Parser r-scan_ f s0 p = go [] s0- where-  go acc s1 = do-    let scanner (B.PS fp off len) =-          withForeignPtr fp $ \ptr0 -> do-            let start = ptr0 `plusPtr` off-                end   = start `plusPtr` len-                inner ptr !s-                  | ptr < end = do-                    w <- peek ptr-                    case p s w of-                      Just s' -> inner (ptr `plusPtr` 1) s'-                      _       -> done (ptr `minusPtr` start) s-                  | otherwise = done (ptr `minusPtr` start) s-                done !i !s = return (T i s)-            inner start s1-    bs <- get-    let T i s' = inlinePerformIO $ scanner bs-        !h = B.unsafeTake i bs-    continue <- inputSpansChunks i-    if continue-      then go (h:acc) s'-      else f s' (h:acc)-{-# INLINE scan_ #-}---- | A stateful scanner.  The predicate consumes and transforms a--- state argument, and each transformed state is passed to successive--- invocations of the predicate on each byte of the input until one--- returns 'Nothing' or the input ends.------ This parser does not fail.  It will return an empty string if the--- predicate returns 'Nothing' on the first byte of input.------ /Note/: Because this parser does not fail, do not use it with--- combinators such as 'Control.Applicative.many', because such--- parsers loop until a failure occurs.  Careless use will thus result--- in an infinite loop.-scan :: s -> (s -> Word8 -> Maybe s) -> Parser ByteString-scan = scan_ $ \_ chunks -> return $! concatReverse chunks-{-# INLINE scan #-}---- | Like 'scan', but generalized to return the final state of the--- scanner.-runScanner :: s -> (s -> Word8 -> Maybe s) -> Parser (ByteString, s)-runScanner = scan_ $ \s xs -> let !sx = concatReverse xs in return (sx, s)-{-# INLINE runScanner #-}---- | Consume input as long as the predicate returns 'True', and return--- the consumed input.------ This parser requires the predicate to succeed on at least one byte--- of input: it will fail if the predicate never returns 'True' or if--- there is no input left.-takeWhile1 :: (Word8 -> Bool) -> Parser ByteString-takeWhile1 p = do-  (`when` demandInput) =<< endOfChunk-  s <- B8.takeWhile p <$> get-  let len = B.length s-  if len == 0-    then fail "takeWhile1"-    else do-      advance len-      eoc <- endOfChunk-      if eoc-        then takeWhileAcc p [s]-        else return s-{-# INLINE takeWhile1 #-}---- | Match any byte in a set.------ >vowel = inClass "aeiou"------ Range notation is supported.------ >halfAlphabet = inClass "a-nA-N"------ To add a literal @\'-\'@ to a set, place it at the beginning or end--- of the string.-inClass :: String -> Word8 -> Bool-inClass s = (`memberWord8` mySet)-    where mySet = charClass s-          {-# NOINLINE mySet #-}-{-# INLINE inClass #-}---- | Match any byte not in a set.-notInClass :: String -> Word8 -> Bool-notInClass s = not . inClass s-{-# INLINE notInClass #-}---- | Match any byte.-anyWord8 :: Parser Word8-anyWord8 = satisfy $ const True-{-# INLINE anyWord8 #-}---- | Match a specific byte.-word8 :: Word8 -> Parser Word8-word8 c = satisfy (== c) <?> show c-{-# INLINE word8 #-}---- | Match any byte except the given one.-notWord8 :: Word8 -> Parser Word8-notWord8 c = satisfy (/= c) <?> "not " ++ show c-{-# INLINE notWord8 #-}---- | Match any byte, to perform lookahead. Returns 'Nothing' if end of--- input has been reached. Does not consume any input.------ /Note/: Because this parser does not fail, do not use it with--- combinators such as 'Control.Applicative.many', because such--- parsers loop until a failure occurs.  Careless use will thus result--- in an infinite loop.-peekWord8 :: Parser (Maybe Word8)-peekWord8 = T.Parser $ \t pos@(Pos pos_) more _lose succ ->-  case () of-    _| pos_ < Buf.length t ->-       let !w = Buf.unsafeIndex t pos_-       in succ t pos more (Just w)-     | more == Complete ->-       succ t pos more Nothing-     | otherwise ->-       let succ' t' pos' more' = let !w = Buf.unsafeIndex t' pos_-                                 in succ t' pos' more' (Just w)-           lose' t' pos' more' = succ t' pos' more' Nothing-       in prompt t pos more lose' succ'-{-# INLINE peekWord8 #-}---- | Match any byte, to perform lookahead.  Does not consume any--- input, but will fail if end of input has been reached.-peekWord8' :: Parser Word8-peekWord8' = T.Parser $ \t pos more lose succ ->-    if lengthAtLeast pos 1 t-    then succ t pos more (Buf.unsafeIndex t (fromPos pos))-    else let succ' t' pos' more' bs' = succ t' pos' more' $! B.unsafeHead bs'-         in ensureSuspended 1 t pos more lose succ'-{-# INLINE peekWord8' #-}---- | Match either a single newline character @\'\\n\'@, or a carriage--- return followed by a newline character @\"\\r\\n\"@.-endOfLine :: Parser ()-endOfLine = (word8 10 >> return ()) <|> (string "\r\n" >> return ())---- | Terminal failure continuation.-failK :: Failure a-failK t (Pos pos) _more stack msg = Fail (Buf.unsafeDrop pos t) stack msg-{-# INLINE failK #-}---- | Terminal success continuation.-successK :: Success a a-successK t (Pos pos) _more a = Done (Buf.unsafeDrop pos t) a-{-# INLINE successK #-}---- | Run a parser.-parse :: Parser a -> ByteString -> Result a-parse m s = T.runParser m (buffer s) (Pos 0) Incomplete failK successK-{-# INLINE parse #-}---- | Run a parser that cannot be resupplied via a 'Partial' result.------ This function does not force a parser to consume all of its input.--- Instead, any residual input will be discarded.  To force a parser--- to consume all of its input, use something like this:------ @---'parseOnly' (myParser 'Control.Applicative.<*' 'endOfInput')--- @-parseOnly :: Parser a -> ByteString -> Either String a-parseOnly m s = case T.runParser m (buffer s) (Pos 0) Complete failK successK of-                  Fail _ [] err   -> Left err-                  Fail _ ctxs err -> Left (intercalate " > " ctxs ++ ": " ++ err)-                  Done _ a        -> Right a-                  _               -> error "parseOnly: impossible error!"-{-# INLINE parseOnly #-}--get :: Parser ByteString-get = T.Parser $ \t pos more _lose succ ->-  succ t pos more (Buf.unsafeDrop (fromPos pos) t)-{-# INLINE get #-}--endOfChunk :: Parser Bool-endOfChunk = T.Parser $ \t pos more _lose succ ->-  succ t pos more (fromPos pos == Buf.length t)-{-# INLINE endOfChunk #-}--inputSpansChunks :: Int -> Parser Bool-inputSpansChunks i = T.Parser $ \t pos_ more _lose succ ->-  let pos = pos_ + Pos i-  in if fromPos pos < Buf.length t || more == Complete-     then succ t pos more False-     else let lose' t' pos' more' = succ t' pos' more' False-              succ' t' pos' more' = succ t' pos' more' True-          in prompt t pos more lose' succ'-{-# INLINE inputSpansChunks #-}--advance :: Int -> Parser ()-advance n = T.Parser $ \t pos more _lose succ ->-  succ t (pos + Pos n) more ()-{-# INLINE advance #-}--ensureSuspended :: Int -> Buffer -> Pos -> More-                -> Failure r-                -> Success ByteString r-                -> Result r-ensureSuspended n t pos more lose succ =-    runParser (demandInput >> go) t pos more lose succ-  where go = T.Parser $ \t' pos' more' lose' succ' ->-          if lengthAtLeast pos' n t'-          then succ' t' pos' more' (substring pos (Pos n) t')-          else runParser (demandInput >> go) t' pos' more' lose' succ'---- | If at least @n@ elements of input are available, return the--- current input, otherwise fail.-ensure :: Int -> Parser ByteString-ensure n = T.Parser $ \t pos more lose succ ->-    if lengthAtLeast pos n t-    then succ t pos more (substring pos (Pos n) t)-    -- The uncommon case is kept out-of-line to reduce code size:-    else ensureSuspended n t pos more lose succ-{-# INLINE ensure #-}---- | Return both the result of a parse and the portion of the input--- that was consumed while it was being parsed.-match :: Parser a -> Parser (ByteString, a)-match p = T.Parser $ \t pos more lose succ ->-  let succ' t' pos' more' a =-        succ t' pos' more' (substring pos (pos'-pos) t', a)-  in runParser p t pos more lose succ'--lengthAtLeast :: Pos -> Int -> Buffer -> Bool-lengthAtLeast (Pos pos) n bs = Buf.length bs >= pos + n-{-# INLINE lengthAtLeast #-}--substring :: Pos -> Pos -> Buffer -> ByteString-substring (Pos pos) (Pos n) = Buf.substring pos n-{-# INLINE substring #-}
− haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/Combinator.hs 
@@ -1,233 +0,0 @@-{-# LANGUAGE BangPatterns, CPP #-}-#if __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-} -- Imports internal modules-#endif--- |--- Module      :  Data.Attoparsec.Combinator--- Copyright   :  Daan Leijen 1999-2001, Bryan O'Sullivan 2007-2015--- License     :  BSD3------ Maintainer  :  bos@serpentine.com--- Stability   :  experimental--- Portability :  portable------ Useful parser combinators, similar to those provided by Parsec.-module Data.Attoparsec.Combinator-    (-    -- * Combinators-      try-    , (<?>)-    , choice-    , count-    , option-    , many'-    , many1-    , many1'-    , manyTill-    , manyTill'-    , sepBy-    , sepBy'-    , sepBy1-    , sepBy1'-    , skipMany-    , skipMany1-    , eitherP-    , feed-    , satisfyElem-    , endOfInput-    , atEnd-    , lookAhead-    ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative (Applicative(..), (<$>))-import Data.Monoid (Monoid(mappend))-#endif-import Control.Applicative (Alternative(..), empty, liftA2, many, (<|>))-import Control.Monad (MonadPlus(..))-import Data.Attoparsec.Internal.Types (Parser(..), IResult(..))-import Data.Attoparsec.Internal (endOfInput, atEnd, satisfyElem)-import Data.ByteString (ByteString)-import Prelude hiding (succ)---- | Attempt a parse, and if it fails, rewind the input so that no--- input appears to have been consumed.------ This combinator is provided for compatibility with Parsec.--- attoparsec parsers always backtrack on failure.-try :: Parser i a -> Parser i a-try p = p-{-# INLINE try #-}---- | Name the parser, in case failure occurs.-(<?>) :: Parser i a-      -> String                 -- ^ the name to use if parsing fails-      -> Parser i a-p <?> msg0 = Parser $ \t pos more lose succ ->-             let lose' t' pos' more' strs msg = lose t' pos' more' (msg0:strs) msg-             in runParser p t pos more lose' succ-{-# INLINE (<?>) #-}-infix 0 <?>---- | @choice ps@ tries to apply the actions in the list @ps@ in order,--- until one of them succeeds. Returns the value of the succeeding--- action.-choice :: Alternative f => [f a] -> f a-choice = foldr (<|>) empty-{-# SPECIALIZE choice :: [Parser ByteString a]-                      -> Parser ByteString a #-}---- | @option x p@ tries to apply action @p@. If @p@ fails without--- consuming input, it returns the value @x@, otherwise the value--- returned by @p@.------ > priority  = option 0 (digitToInt <$> digit)-option :: Alternative f => a -> f a -> f a-option x p = p <|> pure x-{-# SPECIALIZE option :: a -> Parser ByteString a -> Parser ByteString a #-}---- | A version of 'liftM2' that is strict in the result of its first--- action.-liftM2' :: (Monad m) => (a -> b -> c) -> m a -> m b -> m c-liftM2' f a b = do-  !x <- a-  y <- b-  return (f x y)-{-# INLINE liftM2' #-}---- | @many' p@ applies the action @p@ /zero/ or more times. Returns a--- list of the returned values of @p@. The value returned by @p@ is--- forced to WHNF.------ >  word  = many' letter-many' :: (MonadPlus m) => m a -> m [a]-many' p = many_p-  where many_p = some_p `mplus` return []-        some_p = liftM2' (:) p many_p-{-# INLINE many' #-}---- | @many1 p@ applies the action @p@ /one/ or more times. Returns a--- list of the returned values of @p@.------ >  word  = many1 letter-many1 :: Alternative f => f a -> f [a]-many1 p = liftA2 (:) p (many p)-{-# INLINE many1 #-}---- | @many1' p@ applies the action @p@ /one/ or more times. Returns a--- list of the returned values of @p@. The value returned by @p@ is--- forced to WHNF.------ >  word  = many1' letter-many1' :: (MonadPlus m) => m a -> m [a]-many1' p = liftM2' (:) p (many' p)-{-# INLINE many1' #-}---- | @sepBy p sep@ applies /zero/ or more occurrences of @p@, separated--- by @sep@. Returns a list of the values returned by @p@.------ > commaSep p  = p `sepBy` (char ',')-sepBy :: Alternative f => f a -> f s -> f [a]-sepBy p s = liftA2 (:) p ((s *> sepBy1 p s) <|> pure []) <|> pure []-{-# SPECIALIZE sepBy :: Parser ByteString a -> Parser ByteString s-                     -> Parser ByteString [a] #-}---- | @sepBy' p sep@ applies /zero/ or more occurrences of @p@, separated--- by @sep@. Returns a list of the values returned by @p@. The value--- returned by @p@ is forced to WHNF.------ > commaSep p  = p `sepBy'` (char ',')-sepBy' :: (MonadPlus m) => m a -> m s -> m [a]-sepBy' p s = scan `mplus` return []-  where scan = liftM2' (:) p ((s >> sepBy1' p s) `mplus` return [])-{-# SPECIALIZE sepBy' :: Parser ByteString a -> Parser ByteString s-                      -> Parser ByteString [a] #-}---- | @sepBy1 p sep@ applies /one/ or more occurrences of @p@, separated--- by @sep@. Returns a list of the values returned by @p@.------ > commaSep p  = p `sepBy1` (char ',')-sepBy1 :: Alternative f => f a -> f s -> f [a]-sepBy1 p s = scan-    where scan = liftA2 (:) p ((s *> scan) <|> pure [])-{-# SPECIALIZE sepBy1 :: Parser ByteString a -> Parser ByteString s-                      -> Parser ByteString [a] #-}---- | @sepBy1' p sep@ applies /one/ or more occurrences of @p@, separated--- by @sep@. Returns a list of the values returned by @p@. The value--- returned by @p@ is forced to WHNF.------ > commaSep p  = p `sepBy1'` (char ',')-sepBy1' :: (MonadPlus m) => m a -> m s -> m [a]-sepBy1' p s = scan-    where scan = liftM2' (:) p ((s >> scan) `mplus` return [])-{-# SPECIALIZE sepBy1' :: Parser ByteString a -> Parser ByteString s-                       -> Parser ByteString [a] #-}---- | @manyTill p end@ applies action @p@ /zero/ or more times until--- action @end@ succeeds, and returns the list of values returned by--- @p@.  This can be used to scan comments:------ >  simpleComment   = string "<!--" *> manyTill anyChar (string "-->")------ (Note the overlapping parsers @anyChar@ and @string \"-->\"@.--- While this will work, it is not very efficient, as it will cause a--- lot of backtracking.)-manyTill :: Alternative f => f a -> f b -> f [a]-manyTill p end = scan-    where scan = (end *> pure []) <|> liftA2 (:) p scan-{-# SPECIALIZE manyTill :: Parser ByteString a -> Parser ByteString b-                        -> Parser ByteString [a] #-}---- | @manyTill' p end@ applies action @p@ /zero/ or more times until--- action @end@ succeeds, and returns the list of values returned by--- @p@.  This can be used to scan comments:------ >  simpleComment   = string "<!--" *> manyTill' anyChar (string "-->")------ (Note the overlapping parsers @anyChar@ and @string \"-->\"@.--- While this will work, it is not very efficient, as it will cause a--- lot of backtracking.)------ The value returned by @p@ is forced to WHNF.-manyTill' :: (MonadPlus m) => m a -> m b -> m [a]-manyTill' p end = scan-    where scan = (end >> return []) `mplus` liftM2' (:) p scan-{-# SPECIALIZE manyTill' :: Parser ByteString a -> Parser ByteString b-                         -> Parser ByteString [a] #-}---- | Skip zero or more instances of an action.-skipMany :: Alternative f => f a -> f ()-skipMany p = scan-    where scan = (p *> scan) <|> pure ()-{-# SPECIALIZE skipMany :: Parser ByteString a -> Parser ByteString () #-}---- | Skip one or more instances of an action.-skipMany1 :: Alternative f => f a -> f ()-skipMany1 p = p *> skipMany p-{-# SPECIALIZE skipMany1 :: Parser ByteString a -> Parser ByteString () #-}---- | Apply the given action repeatedly, returning every result.-count :: Monad m => Int -> m a -> m [a]-count n p = sequence (replicate n p)-{-# INLINE count #-}---- | Combine two alternatives.-eitherP :: (Alternative f) => f a -> f b -> f (Either a b)-eitherP a b = (Left <$> a) <|> (Right <$> b)-{-# INLINE eitherP #-}---- | If a parser has returned a 'T.Partial' result, supply it with more--- input.-feed :: Monoid i => IResult i r -> i -> IResult i r-feed (Fail t ctxs msg) d = Fail (mappend t d) ctxs msg-feed (Partial k) d    = k d-feed (Done t r) d     = Done (mappend t d) r-{-# INLINE feed #-}---- | Apply a parser without consuming any input.-lookAhead :: Parser i a -> Parser i a-lookAhead p = Parser $ \t pos more lose succ ->-  let succ' t' _pos' more' = succ t' pos more'-  in runParser p t pos more lose succ'-{-# INLINE lookAhead #-}
− haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/Internal.hs 
@@ -1,157 +0,0 @@-{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables #-}--- |--- Module      :  Data.Attoparsec.Internal--- Copyright   :  Bryan O'Sullivan 2007-2015--- License     :  BSD3------ Maintainer  :  bos@serpentine.com--- Stability   :  experimental--- Portability :  unknown------ Simple, efficient parser combinators, loosely based on the Parsec--- library.--module Data.Attoparsec.Internal-    ( compareResults-    , prompt-    , demandInput-    , demandInput_-    , wantInput-    , endOfInput-    , atEnd-    , satisfyElem-    , concatReverse-    ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))-import Data.Monoid (Monoid, mconcat)-#endif-import Data.Attoparsec.Internal.Types-import Data.ByteString (ByteString)-import Prelude hiding (succ)---- | Compare two 'IResult' values for equality.------ If both 'IResult's are 'Partial', the result will be 'Nothing', as--- they are incomplete and hence their equality cannot be known.--- (This is why there is no 'Eq' instance for 'IResult'.)-compareResults :: (Eq i, Eq r) => IResult i r -> IResult i r -> Maybe Bool-compareResults (Fail t0 ctxs0 msg0) (Fail t1 ctxs1 msg1) =-    Just (t0 == t1 && ctxs0 == ctxs1 && msg0 == msg1)-compareResults (Done t0 r0) (Done t1 r1) =-    Just (t0 == t1 && r0 == r1)-compareResults (Partial _) (Partial _) = Nothing-compareResults _ _ = Just False---- | Ask for input.  If we receive any, pass the augmented input to a--- success continuation, otherwise to a failure continuation.-prompt :: Chunk t-       => State t -> Pos -> More-       -> (State t -> Pos -> More -> IResult t r)-       -> (State t -> Pos -> More -> IResult t r)-       -> IResult t r-prompt t pos _more lose succ = Partial $ \s ->-  if nullChunk s-  then lose t pos Complete-  else succ (pappendChunk t s) pos Incomplete-{-# SPECIALIZE prompt :: State ByteString -> Pos -> More-                      -> (State ByteString -> Pos -> More-                          -> IResult ByteString r)-                      -> (State ByteString -> Pos -> More-                          -> IResult ByteString r)-                      -> IResult ByteString r #-}---- | Immediately demand more input via a 'Partial' continuation--- result.-demandInput :: Chunk t => Parser t ()-demandInput = Parser $ \t pos more lose succ ->-  case more of-    Complete -> lose t pos more [] "not enough input"-    _ -> let lose' _ pos' more' = lose t pos' more' [] "not enough input"-             succ' t' pos' more' = succ t' pos' more' ()-         in prompt t pos more lose' succ'-{-# SPECIALIZE demandInput :: Parser ByteString () #-}---- | Immediately demand more input via a 'Partial' continuation--- result.  Return the new input.-demandInput_ :: Chunk t => Parser t t-demandInput_ = Parser $ \t pos more lose succ ->-  case more of-    Complete -> lose t pos more [] "not enough input"-    _ -> Partial $ \s ->-         if nullChunk s-         then lose t pos Complete [] "not enough input"-         else succ (pappendChunk t s) pos more s-{-# SPECIALIZE demandInput_ :: Parser ByteString ByteString #-}---- | This parser always succeeds.  It returns 'True' if any input is--- available either immediately or on demand, and 'False' if the end--- of all input has been reached.-wantInput :: forall t . Chunk t => Parser t Bool-wantInput = Parser $ \t pos more _lose succ ->-  case () of-    _ | pos < atBufferEnd (undefined :: t) t -> succ t pos more True-      | more == Complete -> succ t pos more False-      | otherwise       -> let lose' t' pos' more' = succ t' pos' more' False-                               succ' t' pos' more' = succ t' pos' more' True-                           in prompt t pos more lose' succ'-{-# INLINE wantInput #-}---- | Match only if all input has been consumed.-endOfInput :: forall t . Chunk t => Parser t ()-endOfInput = Parser $ \t pos more lose succ ->-  case () of-    _| pos < atBufferEnd (undefined :: t) t -> lose t pos more [] "endOfInput"-     | more == Complete -> succ t pos more ()-     | otherwise ->-       let lose' t' pos' more' _ctx _msg = succ t' pos' more' ()-           succ' t' pos' more' _a = lose t' pos' more' [] "endOfInput"-       in  runParser demandInput t pos more lose' succ'-{-# SPECIALIZE endOfInput :: Parser ByteString () #-}---- | Return an indication of whether the end of input has been--- reached.-atEnd :: Chunk t => Parser t Bool-atEnd = not <$> wantInput-{-# INLINE atEnd #-}--satisfySuspended :: forall t r . Chunk t-                 => (ChunkElem t -> Bool)-                 -> State t -> Pos -> More-                 -> Failure t (State t) r-                 -> Success t (State t) (ChunkElem t) r-                 -> IResult t r-satisfySuspended p t pos more lose succ =-    runParser (demandInput >> go) t pos more lose succ-  where go = Parser $ \t' pos' more' lose' succ' ->-          case bufferElemAt (undefined :: t) pos' t' of-            Just (e, l) | p e -> succ' t' (pos' + Pos l) more' e-                        | otherwise -> lose' t' pos' more' [] "satisfyElem"-            Nothing -> runParser (demandInput >> go) t' pos' more' lose' succ'-{-# SPECIALIZE satisfySuspended :: (ChunkElem ByteString -> Bool)-                                -> State ByteString -> Pos -> More-                                -> Failure ByteString (State ByteString) r-                                -> Success ByteString (State ByteString)-                                           (ChunkElem ByteString) r-                                -> IResult ByteString r #-}---- | The parser @satisfyElem p@ succeeds for any chunk element for which the--- predicate @p@ returns 'True'. Returns the element that is--- actually parsed.-satisfyElem :: forall t . Chunk t-            => (ChunkElem t -> Bool) -> Parser t (ChunkElem t)-satisfyElem p = Parser $ \t pos more lose succ ->-    case bufferElemAt (undefined :: t) pos t of-      Just (e, l) | p e -> succ t (pos + Pos l) more e-                  | otherwise -> lose t pos more [] "satisfyElem"-      Nothing -> satisfySuspended p t pos more lose succ-{-# INLINE satisfyElem #-}---- | Concatenate a monoid after reversing its elements.  Used to--- glue together a series of textual chunks that have been accumulated--- \"backwards\".-concatReverse :: Monoid m => [m] -> m-concatReverse [x] = x-concatReverse xs  = mconcat (reverse xs)-{-# INLINE concatReverse #-}
− haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/Internal/Fhthagn.hs 
@@ -1,18 +0,0 @@-{-# LANGUAGE BangPatterns, Rank2Types, OverloadedStrings,-    RecordWildCards, MagicHash, UnboxedTuples #-}--module Data.Attoparsec.Internal.Fhthagn-    (-      inlinePerformIO-    ) where--import GHC.Base (realWorld#)-import GHC.IO (IO(IO))---- | Just like unsafePerformIO, but we inline it. Big performance gains as--- it exposes lots of things to further inlining. /Very unsafe/. In--- particular, you should do no memory allocation inside an--- 'inlinePerformIO' block. On Hugs this is just @unsafePerformIO@.-inlinePerformIO :: IO a -> a-inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r-{-# INLINE inlinePerformIO #-}
− haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/Internal/Types.hs 
@@ -1,243 +0,0 @@-{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving, OverloadedStrings,-    Rank2Types, RecordWildCards, TypeFamilies #-}--- |--- Module      :  Data.Attoparsec.Internal.Types--- Copyright   :  Bryan O'Sullivan 2007-2015--- License     :  BSD3------ Maintainer  :  bos@serpentine.com--- Stability   :  experimental--- Portability :  unknown------ Simple, efficient parser combinators, loosely based on the Parsec--- library.--module Data.Attoparsec.Internal.Types-    (-      Parser(..)-    , State-    , Failure-    , Success-    , Pos(..)-    , IResult(..)-    , More(..)-    , (<>)-    , Chunk(..)-    ) where--import Control.Applicative as App (Applicative(..), (<$>))-import Control.Applicative (Alternative(..))-import Control.DeepSeq (NFData(rnf))-import Control.Monad (MonadPlus(..))-import qualified Control.Monad.Fail as Fail (MonadFail(..))-import Data.Monoid as Mon (Monoid(..))-import Data.Semigroup  (Semigroup(..))-import Data.Word (Word8)-import Data.ByteString (ByteString)-import qualified Data.ByteString as BS-import Data.ByteString.Internal (w2c)-import Prelude hiding (getChar, succ)-import qualified Data.Attoparsec.ByteString.Buffer as B--newtype Pos = Pos { fromPos :: Int }-            deriving (Eq, Ord, Show, Num)---- | The result of a parse.  This is parameterised over the type @i@--- of string that was processed.------ This type is an instance of 'Functor', where 'fmap' transforms the--- value in a 'Done' result.-data IResult i r =-    Fail i [String] String-    -- ^ The parse failed.  The @i@ parameter is the input that had-    -- not yet been consumed when the failure occurred.  The-    -- @[@'String'@]@ is a list of contexts in which the error-    -- occurred.  The 'String' is the message describing the error, if-    -- any.-  | Partial (i -> IResult i r)-    -- ^ Supply this continuation with more input so that the parser-    -- can resume.  To indicate that no more input is available, pass-    -- an empty string to the continuation.-    ---    -- __Note__: if you get a 'Partial' result, do not call its-    -- continuation more than once.-  | Done i r-    -- ^ The parse succeeded.  The @i@ parameter is the input that had-    -- not yet been consumed (if any) when the parse succeeded.--instance (Show i, Show r) => Show (IResult i r) where-    showsPrec d ir = showParen (d > 10) $-      case ir of-        (Fail t stk msg) -> showString "Fail" . f t . f stk . f msg-        (Partial _)      -> showString "Partial _"-        (Done t r)       -> showString "Done" . f t . f r-      where f :: Show a => a -> ShowS-            f x = showChar ' ' . showsPrec 11 x--instance (NFData i, NFData r) => NFData (IResult i r) where-    rnf (Fail t stk msg) = rnf t `seq` rnf stk `seq` rnf msg-    rnf (Partial _)  = ()-    rnf (Done t r)   = rnf t `seq` rnf r-    {-# INLINE rnf #-}--instance Functor (IResult i) where-    fmap _ (Fail t stk msg) = Fail t stk msg-    fmap f (Partial k)      = Partial (fmap f . k)-    fmap f (Done t r)   = Done t (f r)---- | The core parser type.  This is parameterised over the type @i@--- of string being processed.------ This type is an instance of the following classes:------ * 'Monad', where 'fail' throws an exception (i.e. fails) with an---   error message.------ * 'Functor' and 'Applicative', which follow the usual definitions.------ * 'MonadPlus', where 'mzero' fails (with no error message) and---   'mplus' executes the right-hand parser if the left-hand one---   fails.  When the parser on the right executes, the input is reset---   to the same state as the parser on the left started with. (In---   other words, attoparsec is a backtracking parser that supports---   arbitrary lookahead.)------ * 'Alternative', which follows 'MonadPlus'.-newtype Parser i a = Parser {-      runParser :: forall r.-                   State i -> Pos -> More-                -> Failure i (State i)   r-                -> Success i (State i) a r-                -> IResult i r-    }--type family State i-type instance State ByteString = B.Buffer--type Failure i t   r = t -> Pos -> More -> [String] -> String-                       -> IResult i r-type Success i t a r = t -> Pos -> More -> a -> IResult i r---- | Have we read all available input?-data More = Complete | Incomplete-            deriving (Eq, Show)--instance Semigroup More where-    c@Complete <> _ = c-    _          <> m = m--instance Mon.Monoid More where-    mappend = (<>)-    mempty  = Incomplete--instance Monad (Parser i) where-    fail = Fail.fail-    {-# INLINE fail #-}--    return = App.pure-    {-# INLINE return #-}--    m >>= k = Parser $ \t !pos more lose succ ->-        let succ' t' !pos' more' a = runParser (k a) t' pos' more' lose succ-        in runParser m t pos more lose succ'-    {-# INLINE (>>=) #-}--    (>>) = (*>)-    {-# INLINE (>>) #-}---instance Fail.MonadFail (Parser i) where-    fail err = Parser $ \t pos more lose _succ -> lose t pos more [] msg-      where msg = "Failed reading: " ++ err-    {-# INLINE fail #-}--plus :: Parser i a -> Parser i a -> Parser i a-plus f g = Parser $ \t pos more lose succ ->-  let lose' t' _pos' more' _ctx _msg = runParser g t' pos more' lose succ-  in runParser f t pos more lose' succ--instance MonadPlus (Parser i) where-    mzero = fail "mzero"-    {-# INLINE mzero #-}-    mplus = plus--instance Functor (Parser i) where-    fmap f p = Parser $ \t pos more lose succ ->-      let succ' t' pos' more' a = succ t' pos' more' (f a)-      in runParser p t pos more lose succ'-    {-# INLINE fmap #-}--apP :: Parser i (a -> b) -> Parser i a -> Parser i b-apP d e = do-  b <- d-  a <- e-  return (b a)-{-# INLINE apP #-}--instance Applicative (Parser i) where-    pure v = Parser $ \t pos more _lose succ -> succ t pos more v-    {-# INLINE pure #-}-    (<*>)  = apP-    {-# INLINE (<*>) #-}-    m *> k = m >>= \_ -> k-    {-# INLINE (*>) #-}-    x <* y = x >>= \a -> y >> pure a-    {-# INLINE (<*) #-}--instance Semigroup (Parser i a) where-    (<>) = plus-    {-# INLINE (<>) #-}--instance Monoid (Parser i a) where-    mempty  = fail "mempty"-    {-# INLINE mempty #-}-    mappend = (<>)-    {-# INLINE mappend #-}--instance Alternative (Parser i) where-    empty = fail "empty"-    {-# INLINE empty #-}--    (<|>) = plus-    {-# INLINE (<|>) #-}--    many v = many_v-        where many_v = some_v <|> pure []-              some_v = (:) App.<$> v <*> many_v-    {-# INLINE many #-}--    some v = some_v-      where-        many_v = some_v <|> pure []-        some_v = (:) <$> v <*> many_v-    {-# INLINE some #-}---- | A common interface for input chunks.-class Monoid c => Chunk c where-  type ChunkElem c-  -- | Test if the chunk is empty.-  nullChunk :: c -> Bool-  -- | Append chunk to a buffer.-  pappendChunk :: State c -> c -> State c-  -- | Position at the end of a buffer. The first argument is ignored.-  atBufferEnd :: c -> State c -> Pos-  -- | Return the buffer element at the given position along with its length.-  bufferElemAt :: c -> Pos -> State c -> Maybe (ChunkElem c, Int)-  -- | Map an element to the corresponding character.-  --   The first argument is ignored.-  chunkElemToChar :: c -> ChunkElem c -> Char--instance Chunk ByteString where-  type ChunkElem ByteString = Word8-  nullChunk = BS.null-  {-# INLINE nullChunk #-}-  pappendChunk = B.pappend-  {-# INLINE pappendChunk #-}-  atBufferEnd _ = Pos . B.length-  {-# INLINE atBufferEnd #-}-  bufferElemAt _ (Pos i) buf-    | i < B.length buf = Just (B.unsafeIndex buf i, 1)-    | otherwise = Nothing-  {-# INLINE bufferElemAt #-}-  chunkElemToChar _ = w2c-  {-# INLINE chunkElemToChar #-}
− haddock-library/vendor/attoparsec-0.13.1.0/Data/Attoparsec/Number.hs 
@@ -1,137 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}--- |--- Module      :  Data.Attoparsec.Number--- Copyright   :  Bryan O'Sullivan 2007-2015--- License     :  BSD3------ Maintainer  :  bos@serpentine.com--- Stability   :  experimental--- Portability :  unknown------ This module is deprecated, and both the module and 'Number' type--- will be removed in the next major release.  Use the--- <http://hackage.haskell.org/package/scientific scientific> package--- and the 'Data.Scientific.Scientific' type instead.------ A simple number type, useful for parsing both exact and inexact--- quantities without losing much precision.-module Data.Attoparsec.Number-    {-# DEPRECATED "This module will be removed in the next major release." #-}-    (-      Number(..)-    ) where--import Control.DeepSeq (NFData(rnf))-import Data.Data (Data)-import Data.Function (on)-import Data.Typeable (Typeable)---- | A numeric type that can represent integers accurately, and--- floating point numbers to the precision of a 'Double'.------ /Note/: this type is deprecated, and will be removed in the next--- major release.  Use the 'Data.Scientific.Scientific' type instead.-data Number = I !Integer-            | D {-# UNPACK #-} !Double-              deriving (Typeable, Data)-{-# DEPRECATED Number "Use Scientific instead." #-}--instance Show Number where-    show (I a) = show a-    show (D a) = show a--instance NFData Number where-    rnf (I _) = ()-    rnf (D _) = ()-    {-# INLINE rnf #-}--binop :: (Integer -> Integer -> a) -> (Double -> Double -> a)-      -> Number -> Number -> a-binop _ d (D a) (D b) = d a b-binop i _ (I a) (I b) = i a b-binop _ d (D a) (I b) = d a (fromIntegral b)-binop _ d (I a) (D b) = d (fromIntegral a) b-{-# INLINE binop #-}--instance Eq Number where-    (==) = binop (==) (==)-    {-# INLINE (==) #-}--    (/=) = binop (/=) (/=)-    {-# INLINE (/=) #-}--instance Ord Number where-    (<) = binop (<) (<)-    {-# INLINE (<) #-}--    (<=) = binop (<=) (<=)-    {-# INLINE (<=) #-}--    (>) = binop (>) (>)-    {-# INLINE (>) #-}--    (>=) = binop (>=) (>=)-    {-# INLINE (>=) #-}--    compare = binop compare compare-    {-# INLINE compare #-}--instance Num Number where-    (+) = binop (((I$!).) . (+)) (((D$!).) . (+))-    {-# INLINE (+) #-}--    (-) = binop (((I$!).) . (-)) (((D$!).) . (-))-    {-# INLINE (-) #-}--    (*) = binop (((I$!).) . (*)) (((D$!).) . (*))-    {-# INLINE (*) #-}--    abs (I a) = I $! abs a-    abs (D a) = D $! abs a-    {-# INLINE abs #-}--    negate (I a) = I $! negate a-    negate (D a) = D $! negate a-    {-# INLINE negate #-}--    signum (I a) = I $! signum a-    signum (D a) = D $! signum a-    {-# INLINE signum #-}--    fromInteger = (I$!) . fromInteger-    {-# INLINE fromInteger #-}--instance Real Number where-    toRational (I a) = fromIntegral a-    toRational (D a) = toRational a-    {-# INLINE toRational #-}--instance Fractional Number where-    fromRational = (D$!) . fromRational-    {-# INLINE fromRational #-}--    (/) = binop (((D$!).) . (/) `on` fromIntegral)-                (((D$!).) . (/))-    {-# INLINE (/) #-}--    recip (I a) = D $! recip (fromIntegral a)-    recip (D a) = D $! recip a-    {-# INLINE recip #-}--instance RealFrac Number where-    properFraction (I a) = (fromIntegral a,0)-    properFraction (D a) = case properFraction a of-                             (i,d) -> (i,D d)-    {-# INLINE properFraction #-}-    truncate (I a) = fromIntegral a-    truncate (D a) = truncate a-    {-# INLINE truncate #-}-    round (I a) = fromIntegral a-    round (D a) = round a-    {-# INLINE round #-}-    ceiling (I a) = fromIntegral a-    ceiling (D a) = ceiling a-    {-# INLINE ceiling #-}-    floor (I a) = fromIntegral a-    floor (D a) = floor a-    {-# INLINE floor #-}
haddock.cabal view
@@ -1,6 +1,6 @@ cabal-version:        2.0 name:                 haddock-version:              2.20.0+version:              2.21.0 synopsis:             A documentation-generation tool for Haskell libraries description:   This is Haddock, a tool for automatically generating documentation@@ -23,17 +23,17 @@   without any documentation annotations, Haddock can generate useful documentation   from your source code.   .-  <<https://cdn.rawgit.com/haskell/haddock/v2.20/doc/cheatsheet/haddocks.svg>>+  <<https://cdn.rawgit.com/haskell/haddock/ghc-8.6/doc/cheatsheet/haddocks.svg>> license:              BSD3 license-file:         LICENSE author:               Simon Marlow, David Waern-maintainer:           Alex Biehl <alexbiehl@gmail.com>, Simon Hengel <sol@typeful.net>, Mateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk>+maintainer:           Alec Theriault <alec.theriault@gmail.com>, Alex Biehl <alexbiehl@gmail.com>, Simon Hengel <sol@typeful.net>, Mateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk> homepage:             http://www.haskell.org/haddock/ bug-reports:          https://github.com/haskell/haddock/issues copyright:            (c) Simon Marlow, David Waern category:             Documentation build-type:           Simple-tested-with:          GHC==8.4.*+tested-with:          GHC==8.6.*  extra-source-files:   CHANGES.md@@ -42,7 +42,6 @@   doc/README.md   doc/*.rst   doc/conf.py-  driver-test/*.hs   haddock-api/src/haddock.sh   html-test/src/*.hs   html-test/ref/*.html@@ -63,11 +62,12 @@   hs-source-dirs:       driver   ghc-options:          -funbox-strict-fields -Wall -fwarn-tabs -O2 -threaded -  -- haddock typically only supports a single GHC major version+  -- haddock typically only supports a single GHC major version    build-depends:-    base ^>= 4.11.0+    base ^>= 4.12.0+   if flag(in-ghc-tree)-    hs-source-dirs: haddock-api/src, haddock-library/vendor/attoparsec-0.13.1.0, haddock-library/src+    hs-source-dirs: haddock-api/src,  haddock-library/src     cpp-options: -DIN_GHC_TREE     build-depends:       filepath,@@ -78,28 +78,17 @@       xhtml >= 3000.2 && < 3000.3,       Cabal >= 1.10,       ghc-boot,-      ghc == 8.4.*,+      ghc == 8.6.*,       bytestring,+      parsec,+      text,       transformers      other-modules:-      ResponseFile,-       Documentation.Haddock.Parser       Documentation.Haddock.Parser.Monad       Documentation.Haddock.Types       Documentation.Haddock.Doc-      Data.Attoparsec-      Data.Attoparsec.ByteString-      Data.Attoparsec.ByteString.Buffer-      Data.Attoparsec.ByteString.Char8-      Data.Attoparsec.ByteString.FastSet-      Data.Attoparsec.ByteString.Internal-      Data.Attoparsec.Combinator-      Data.Attoparsec.Internal-      Data.Attoparsec.Internal.Fhthagn-      Data.Attoparsec.Internal.Types-      Data.Attoparsec.Number       Documentation.Haddock.Utf8       Documentation.Haddock.Parser.Util       Documentation.Haddock.Markup@@ -144,7 +133,7 @@       Haddock.GhcUtils       Haddock.Syb       Haddock.Convert-      +       Paths_haddock      autogen-modules:@@ -153,21 +142,7 @@   else     -- in order for haddock's advertised version number to have proper meaning,     -- we pin down to a single haddock-api version.-    build-depends:  haddock-api == 2.20.0--    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+    build-depends:  haddock-api == 2.21.0  test-suite html-test   type:             exitcode-stdio-1.0
html-test/ref/Bug26.html view
@@ -71,7 +71,11 @@ 	      > a <span class="keyword" 	      >where</span 	      ><ul class="subs"-	      ></ul+	      ><li+		><a href="#"+		  >c_f</a+		  > :: a</li+		></ul 	      ></li 	    ></ul 	  ></details@@ -124,14 +128,6 @@ 	    ><p 	    ><em 	      >Since: 1.0</em-	      ></p-	    ></div-	  ><div class="subs minimal"-	  ><p class="caption"-	    >Minimal complete definition</p-	    ><p class="src"-	    ><a href="#" title="Bug26"-	      >c_f</a 	      ></p 	    ></div 	  ><div class="subs methods"
html-test/ref/Bug294.html view
@@ -171,9 +171,9 @@ 	><p class="src" 	  ><a id="v:gadtField" class="def" 	    >gadtField</a-	    > :: ({..} -&gt; GADT <a href="#" title="Bug294"+	    > :: GADT <a href="#" title="Bug294" 	    >A</a-	    >) -&gt; <a href="#" title="Bug294"+	    > -&gt; <a href="#" title="Bug294" 	    >A</a 	    > <a href="#" class="selflink" 	    >#</a@@ -185,9 +185,7 @@ 	    >data family</span 	    > <a id="t:TP" class="def" 	    >TP</a-	    > t :: <a href="#" title="Data.Kind"-	    >*</a-	    > <a href="#" class="selflink"+	    > t :: * <a href="#" class="selflink" 	    >#</a 	    ></p 	  ><div class="subs instances"@@ -247,9 +245,7 @@ 	    >data family</span 	    > <a id="t:DP" class="def" 	    >DP</a-	    > t :: <a href="#" title="Data.Kind"-	    >*</a-	    > <a href="#" class="selflink"+	    > t :: * <a href="#" class="selflink" 	    >#</a 	    ></p 	  ><div class="subs instances"@@ -309,9 +305,7 @@ 	    >data family</span 	    > <a id="t:TO-39-" class="def" 	    >TO'</a-	    > t :: <a href="#" title="Data.Kind"-	    >*</a-	    > <a href="#" class="selflink"+	    > t :: * <a href="#" class="selflink" 	    >#</a 	    ></p 	  ><div class="subs instances"
html-test/ref/Bug310.html view
html-test/ref/Bug548.html view
@@ -48,11 +48,11 @@ 	    > <a id="t:WrappedArrow" class="def" 	    >WrappedArrow</a 	    > (a :: <a href="#" title="Data.Kind"-	    >*</a+	    >Type</a 	    > -&gt; <a href="#" title="Data.Kind"-	    >*</a+	    >Type</a 	    > -&gt; <a href="#" title="Data.Kind"-	    >*</a+	    >Type</a 	    >) b c <a href="#" class="selflink" 	    >#</a 	    ></p@@ -103,9 +103,9 @@ 		      > (<a href="#" title="Bug548" 		      >WrappedArrow</a 		      > a b :: <a href="#" title="Data.Kind"-		      >*</a+		      >Type</a 		      > -&gt; <a href="#" title="Data.Kind"-		      >*</a+		      >Type</a 		      >)</span 		    ></td 		  ><td class="doc empty"@@ -131,7 +131,7 @@ 			  > (<a href="#" title="Bug548" 			  >WrappedArrow</a 			  > a b) :: k -&gt; <a href="#" title="Data.Kind"-			  >*</a+			  >Type</a 			  > <a href="#" class="selflink" 			  >#</a 			  ></p@@ -427,9 +427,9 @@ 			  > (<a href="#" title="Bug548" 			  >WrappedArrow</a 			  > a b c) :: <a href="#" title="Data.Kind"-			  >*</a+			  >Type</a 			  > -&gt; <a href="#" title="Data.Kind"-			  >*</a+			  >Type</a 			  > <a href="#" class="selflink" 			  >#</a 			  ></p@@ -477,13 +477,17 @@ 		      > (<a href="#" title="Bug548" 		      >WrappedArrow</a 		      > a b :: <a href="#" title="Data.Kind"-		      >*</a+		      >Type</a 		      > -&gt; <a href="#" title="Data.Kind"-		      >*</a+		      >Type</a 		      >)</span 		    ></td-		  ><td class="doc empty"-		  ></td+		  ><td class="doc"+		  ><p+		    ><em+		      >Since: base-4.7.0.0</em+		      ></p+		    ></td 		  ></tr 		><tr 		><td colspan="2"@@ -502,9 +506,9 @@ 			> (<a href="#" title="Bug548" 			>WrappedArrow</a 			> a b :: <a href="#" title="Data.Kind"-			>*</a+			>Type</a 			> -&gt; <a href="#" title="Data.Kind"-			>*</a+			>Type</a 			>) = <a href="#" title="GHC.Generics" 			>D1</a 			> (<a href="#" title="GHC.Generics"@@ -523,7 +527,7 @@ 			>S1</a 			> (<a href="#" title="GHC.Generics" 			>MetaSel</a-			> (<a href="#" title="Data.Maybe"+			> (<a href="#" title="GHC.Maybe" 			>Just</a 			> &quot;unwrapArrow&quot;) <a href="#" title="GHC.Generics" 			>NoSourceUnpackedness</a@@ -550,8 +554,12 @@ 		      >WrappedArrow</a 		      > a b c)</span 		    ></td-		  ><td class="doc empty"-		  ></td+		  ><td class="doc"+		  ><p+		    ><em+		      >Since: base-4.7.0.0</em+		      ></p+		    ></td 		  ></tr 		><tr 		><td colspan="2"@@ -587,7 +595,7 @@ 			>S1</a 			> (<a href="#" title="GHC.Generics" 			>MetaSel</a-			> (<a href="#" title="Data.Maybe"+			> (<a href="#" title="GHC.Maybe" 			>Just</a 			> &quot;unwrapArrow&quot;) <a href="#" title="GHC.Generics" 			>NoSourceUnpackedness</a
+ html-test/ref/Bug574.html view
@@ -0,0 +1,86 @@+<html xmlns="http://www.w3.org/1999/xhtml"+><head+  ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"+     /><title+    >Bug574</title+    ><link href="#" rel="stylesheet" type="text/css" title="Ocean"+     /><link rel="stylesheet" type="text/css" href="#"+     /><script src="haddock-bundle.min.js" async="async" type="text/javascript"+    ></script+    ><script src="https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.0/MathJax.js?config=TeX-AMS-MML_HTMLorMML" type="text/javascript"+    ></script+    ></head+  ><body+  ><div id="package-header"+    ><ul class="links" id="page-menu"+      ><li+	><a href="#"+	  >Contents</a+	  ></li+	><li+	><a href="#"+	  >Index</a+	  ></li+	></ul+      ><p class="caption empty"+      ></p+      ></div+    ><div id="content"+    ><div id="module-header"+      ><table class="info"+	><tr+	  ><th+	    >Safe Haskell</th+	    ><td+	    >None</td+	    ></tr+	  ></table+	><p class="caption"+	>Bug574</p+	></div+      ><div id="synopsis"+      ><details id="syn"+	><summary+	  >Synopsis</summary+	  ><ul class="details-toggle" data-details-id="syn"+	  ><li class="src short"+	    ><a href="#"+	      >foo</a+	      > :: <a href="#" title="Data.Int"+	      >Int</a+	      > -&gt; <a href="#" title="Data.Int"+	      >Int</a+	      > -&gt; <a href="#" title="Data.Int"+	      >Int</a+	      ></li+	    ></ul+	  ></details+	></div+      ><div id="interface"+      ><h1+	>Documentation</h1+	><div class="top"+	><p class="src"+	  ><a id="v:foo" class="def"+	    >foo</a+	    > :: <a href="#" title="Data.Int"+	    >Int</a+	    > -&gt; <a href="#" title="Data.Int"+	    >Int</a+	    > -&gt; <a href="#" title="Data.Int"+	    >Int</a+	    > <a href="#" class="selflink"+	    >#</a+	    ></p+	  ><div class="doc"+	  ><p+	    >Somthing with a spliced type</p+	    ></div+	  ></div+	></div+      ></div+    ><div id="footer"+    ></div+    ></body+  ></html+>
html-test/ref/Bug613.html view
@@ -51,7 +51,11 @@ 	      > f <span class="keyword" 	      >where</span 	      ><ul class="subs"-	      ></ul+	      ><li+		><a href="#"+		  >fmap</a+		  > :: (a -&gt; b) -&gt; f a -&gt; f b</li+		></ul 	      ></li 	    ><li class="src short" 	    ><span class="keyword"@@ -78,14 +82,6 @@ 	    > <a href="#" class="selflink" 	    >#</a 	    ></p-	  ><div class="subs minimal"-	  ><p class="caption"-	    >Minimal complete definition</p-	    ><p class="src"-	    ><a href="#" title="Bug613"-	      >fmap</a-	      ></p-	    ></div 	  ><div class="subs methods" 	  ><p class="caption" 	    >Methods</p
html-test/ref/Bug647.html view
@@ -52,14 +52,6 @@ 	    > <a href="#" class="selflink" 	    >#</a 	    ></p-	  ><div class="subs minimal"-	  ><p class="caption"-	    >Minimal complete definition</p-	    ><p class="src"-	    ><a href="#" title="Bug647"-	      >f</a-	      ></p-	    ></div 	  ><div class="subs methods" 	  ><p class="caption" 	    >Methods</p
html-test/ref/Bug679.html view
@@ -126,14 +126,6 @@ 	    > <a href="#" class="selflink" 	    >#</a 	    ></p-	  ><div class="subs minimal"-	  ><p class="caption"-	    >Minimal complete definition</p-	    ><p class="src"-	    ><a href="#" title="Bug679"-	      >foo</a-	      ></p-	    ></div 	  ><div class="subs methods" 	  ><p class="caption" 	    >Methods</p
html-test/ref/Bug85.html view
@@ -47,15 +47,7 @@ 	    >data</span 	    > <a id="t:Foo" class="def" 	    >Foo</a-	    > :: (<a href="#" title="Data.Kind"-	    >*</a-	    > -&gt; <a href="#" title="Data.Kind"-	    >*</a-	    >) -&gt; <a href="#" title="Data.Kind"-	    >*</a-	    > -&gt; <a href="#" title="Data.Kind"-	    >*</a-	    > <span class="keyword"+	    > :: (* -&gt; *) -&gt; * -&gt; * <span class="keyword" 	    >where</span 	    > <a href="#" class="selflink" 	    >#</a@@ -83,9 +75,7 @@ 	    >data</span 	    > <a id="t:Baz" class="def" 	    >Baz</a-	    > :: <a href="#" title="Data.Kind"-	    >*</a-	    > <span class="keyword"+	    > :: * <span class="keyword" 	    >where</span 	    > <a href="#" class="selflink" 	    >#</a
html-test/ref/BundledPatterns.html view
@@ -50,11 +50,7 @@ 	      >Vec</a 	      > :: <a href="#" title="GHC.TypeNats" 	      >Nat</a-	      > -&gt; <a href="#" title="Data.Kind"-	      >*</a-	      > -&gt; <a href="#" title="Data.Kind"-	      >*</a-	      > <span class="keyword"+	      > -&gt; * -&gt; * <span class="keyword" 	      >where</span 	      ><ul class="subs" 	      ><li@@ -84,11 +80,7 @@ 	      >RTree</a 	      > :: <a href="#" title="GHC.TypeNats" 	      >Nat</a-	      > -&gt; <a href="#" title="Data.Kind"-	      >*</a-	      > -&gt; <a href="#" title="Data.Kind"-	      >*</a-	      > <span class="keyword"+	      > -&gt; * -&gt; * <span class="keyword" 	      >where</span 	      ><ul class="subs" 	      ><li@@ -129,11 +121,7 @@ 	    >Vec</a 	    > :: <a href="#" title="GHC.TypeNats" 	    >Nat</a-	    > -&gt; <a href="#" title="Data.Kind"-	    >*</a-	    > -&gt; <a href="#" title="Data.Kind"-	    >*</a-	    > <span class="keyword"+	    > -&gt; * -&gt; * <span class="keyword" 	    >where</span 	    > <a href="#" class="selflink" 	    >#</a@@ -295,11 +283,7 @@ 	    >RTree</a 	    > :: <a href="#" title="GHC.TypeNats" 	    >Nat</a-	    > -&gt; <a href="#" title="Data.Kind"-	    >*</a-	    > -&gt; <a href="#" title="Data.Kind"-	    >*</a-	    > <span class="keyword"+	    > -&gt; * -&gt; * <span class="keyword" 	    >where</span 	    > <a href="#" class="selflink" 	    >#</a
html-test/ref/BundledPatterns2.html view
@@ -50,11 +50,7 @@ 	      >Vec</a 	      > :: <a href="#" title="GHC.TypeNats" 	      >Nat</a-	      > -&gt; <a href="#" title="Data.Kind"-	      >*</a-	      > -&gt; <a href="#" title="Data.Kind"-	      >*</a-	      > <span class="keyword"+	      > -&gt; * -&gt; * <span class="keyword" 	      >where</span 	      ><ul class="subs" 	      ><li@@ -86,11 +82,7 @@ 	      >RTree</a 	      > :: <a href="#" title="GHC.TypeNats" 	      >Nat</a-	      > -&gt; <a href="#" title="Data.Kind"-	      >*</a-	      > -&gt; <a href="#" title="Data.Kind"-	      >*</a-	      > <span class="keyword"+	      > -&gt; * -&gt; * <span class="keyword" 	      >where</span 	      ><ul class="subs" 	      ><li@@ -131,11 +123,7 @@ 	    >Vec</a 	    > :: <a href="#" title="GHC.TypeNats" 	    >Nat</a-	    > -&gt; <a href="#" title="Data.Kind"-	    >*</a-	    > -&gt; <a href="#" title="Data.Kind"-	    >*</a-	    > <span class="keyword"+	    > -&gt; * -&gt; * <span class="keyword" 	    >where</span 	    > <a href="#" class="selflink" 	    >#</a@@ -293,11 +281,7 @@ 	    >RTree</a 	    > :: <a href="#" title="GHC.TypeNats" 	    >Nat</a-	    > -&gt; <a href="#" title="Data.Kind"-	    >*</a-	    > -&gt; <a href="#" title="Data.Kind"-	    >*</a-	    > <span class="keyword"+	    > -&gt; * -&gt; * <span class="keyword" 	    >where</span 	    > <a href="#" class="selflink" 	    >#</a
+ html-test/ref/ConstructorArgs.html view
@@ -0,0 +1,720 @@+<html xmlns="http://www.w3.org/1999/xhtml"+><head+  ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"+     /><title+    >ConstructorArgs</title+    ><link href="#" rel="stylesheet" type="text/css" title="Ocean"+     /><link rel="stylesheet" type="text/css" href="#"+     /><script src="haddock-bundle.min.js" async="async" type="text/javascript"+    ></script+    ><script src="https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.0/MathJax.js?config=TeX-AMS-MML_HTMLorMML" type="text/javascript"+    ></script+    ></head+  ><body+  ><div id="package-header"+    ><ul class="links" id="page-menu"+      ><li+	><a href="#"+	  >Contents</a+	  ></li+	><li+	><a href="#"+	  >Index</a+	  ></li+	></ul+      ><p class="caption empty"+      ></p+      ></div+    ><div id="content"+    ><div id="module-header"+      ><table class="info"+	><tr+	  ><th+	    >Safe Haskell</th+	    ><td+	    >Safe</td+	    ></tr+	  ></table+	><p class="caption"+	>ConstructorArgs</p+	></div+      ><div id="synopsis"+      ><details id="syn"+	><summary+	  >Synopsis</summary+	  ><ul class="details-toggle" data-details-id="syn"+	  ><li class="src short"+	    ><span class="keyword"+	      >data</span+	      > <a href="#"+	      >Foo</a+	      ><ul class="subs"+	      ><li+		>= <a href="#"+		  >Rec</a+		  > { <ul class="subs"+		  ><li+		    ><a href="#"+		      >x</a+		      > :: <a href="#" title="Data.String"+		      >String</a+		      ></li+		    ><li+		    ><a href="#"+		      >y</a+		      > :: <a href="#" title="Data.String"+		      >String</a+		      ></li+		    ></ul+		  > }</li+		><li+		>| <a href="#"+		  >Baz</a+		  > <a href="#" title="Data.Int"+		  >Int</a+		  > <a href="#" title="Data.String"+		  >String</a+		  ></li+		><li+		>| <a href="#"+		  >Boa</a+		  > !<a href="#" title="Data.Int"+		  >Int</a+		  > !<a href="#" title="Data.String"+		  >String</a+		  ></li+		><li+		>| <a href="#" title="Data.Int"+		  >Int</a+		  > <a href="#"+		  >:|</a+		  > <a href="#" title="Data.String"+		  >String</a+		  ></li+		><li+		>| <a href="#" title="Data.Int"+		  >Int</a+		  > <a href="#"+		  >:*</a+		  > <a href="#" title="Data.String"+		  >String</a+		  ></li+		></ul+	      ></li+	    ><li class="src short"+	    ><span class="keyword"+	      >data</span+	      > <a href="#"+	      >Boo</a+	      > <span class="keyword"+	      >where</span+	      ><ul class="subs"+	      ><li+		><a href="#"+		  >Foo</a+		  > :: <a href="#" title="Data.Int"+		  >Int</a+		  > -&gt; <a href="#" title="Data.String"+		  >String</a+		  > -&gt; <a href="#" title="ConstructorArgs"+		  >Boo</a+		  ></li+		><li+		><a href="#"+		  >Foa</a+		  > :: <a href="#" title="Data.Int"+		  >Int</a+		  > -&gt; <a href="#" title="ConstructorArgs"+		  >Boo</a+		  ></li+		><li+		><span class="keyword"+		  >pattern</span+		  > <a href="#"+		  >Fo</a+		  > :: <a href="#" title="Data.Int"+		  >Int</a+		  > -&gt; <a href="#" title="Data.String"+		  >String</a+		  > -&gt; <a href="#" title="ConstructorArgs"+		  >Boo</a+		  ></li+		><li+		><span class="keyword"+		  >pattern</span+		  > <a href="#"+		  >Fo'</a+		  > :: <a href="#" title="ConstructorArgs"+		  >Boo</a+		  ></li+		></ul+	      ></li+	    ><li class="src short"+	    ><span class="keyword"+	      >pattern</span+	      > <a href="#"+	      >Bo</a+	      > :: <a href="#" title="Data.Int"+	      >Int</a+	      > -&gt; <a href="#" title="Data.String"+	      >String</a+	      > -&gt; <a href="#" title="ConstructorArgs"+	      >Boo</a+	      ></li+	    ><li class="src short"+	    ><span class="keyword"+	      >pattern</span+	      > <a href="#"+	      >Bo'</a+	      > :: <a href="#" title="Data.Int"+	      >Int</a+	      > -&gt; <a href="#" title="Data.String"+	      >String</a+	      > -&gt; <a href="#" title="ConstructorArgs"+	      >Boo</a+	      ></li+	    ></ul+	  ></details+	></div+      ><div id="interface"+      ><h1+	>Documentation</h1+	><div class="top"+	><p class="src"+	  ><span class="keyword"+	    >data</span+	    > <a id="t:Foo" class="def"+	    >Foo</a+	    > <span class="fixity"+	    >infixr 1</span+	    ><span class="rightedge"+	    ></span+	    > <a href="#" class="selflink"+	    >#</a+	    ></p+	  ><div class="subs constructors"+	  ><p class="caption"+	    >Constructors</p+	    ><table+	    ><tr+	      ><td class="src"+		><a id="v:Rec" class="def"+		  >Rec</a+		  ></td+		><td class="doc"+		><p+		  >doc on a record</p+		  ></td+		></tr+	      ><tr+	      ><td colspan="2"+		><div class="subs fields"+		  ><p class="caption"+		    >Fields</p+		    ><ul+		    ><li+		      ><dfn class="src"+			><a id="v:x" class="def"+			  >x</a+			  > :: <a href="#" title="Data.String"+			  >String</a+			  ></dfn+			><div class="doc"+			><p+			  >doc on the <code+			    ><a href="#" title="Data.String"+			      >String</a+			      ></code+			    > field of <code+			    ><a href="#" title="ConstructorArgs"+			      >Rec</a+			      ></code+			    ></p+			  ></div+			></li+		      ><li+		      ><dfn class="src"+			><a id="v:y" class="def"+			  >y</a+			  > :: <a href="#" title="Data.String"+			  >String</a+			  ></dfn+			><div class="doc"+			><p+			  >doc on the <code+			    ><a href="#" title="Data.String"+			      >String</a+			      ></code+			    > field of <code+			    ><a href="#" title="ConstructorArgs"+			      >Rec</a+			      ></code+			    ></p+			  ></div+			></li+		      ></ul+		    ></div+		  ></td+		></tr+	      ><tr+	      ><td class="src"+		><a id="v:Baz" class="def"+		  >Baz</a+		  > <a href="#" title="Data.Int"+		  >Int</a+		  > <a href="#" title="Data.String"+		  >String</a+		  ></td+		><td class="doc"+		><p+		  >old prefix doc style</p+		  ></td+		></tr+	      ><tr+	      ><td class="src"+		><a id="v:Boa" class="def"+		  >Boa</a+		  > <span class="fixity"+		  >infixr 2</span+		  ><span class="rightedge"+		  ></span+		  ></td+		><td class="doc"+		><p+		  >doc on the <code+		    ><a href="#" title="ConstructorArgs"+		      >Boa</a+		      ></code+		    > constrictor</p+		  ></td+		></tr+	      ><tr+	      ><td colspan="2"+		><div class="subs fields"+		  ><p class="caption"+		    >Fields</p+		    ><ul+		    ><li+		      ><dfn class="src"+			>!<a href="#" title="Data.Int"+			  >Int</a+			  ></dfn+			><div class="doc"+			><p+			  >doc on the <code+			    ><a href="#" title="Data.Int"+			      >Int</a+			      ></code+			    > field of <code+			    ><a href="#" title="ConstructorArgs"+			      >Boa</a+			      ></code+			    ></p+			  ></div+			></li+		      ><li+		      ><dfn class="src"+			>!<a href="#" title="Data.String"+			  >String</a+			  ></dfn+			><div class="doc"+			><p+			  >doc on the <code+			    ><a href="#" title="Data.String"+			      >String</a+			      ></code+			    > field of <code+			    ><a href="#" title="ConstructorArgs"+			      >Boa</a+			      ></code+			    ></p+			  ></div+			></li+		      ></ul+		    ></div+		  ></td+		></tr+	      ><tr+	      ><td class="src"+		><a href="#" title="Data.Int"+		  >Int</a+		  > <a id="v::-124-" class="def"+		  >:|</a+		  > <a href="#" title="Data.String"+		  >String</a+		  ></td+		><td class="doc"+		><p+		  >old infix doc style</p+		  ></td+		></tr+	      ><tr+	      ><td class="src"+		><a id="v::-42-" class="def"+		  >(:*)</a+		  > <span class="fixity"+		  >infixr 3</span+		  ><span class="rightedge"+		  ></span+		  ></td+		><td class="doc"+		><p+		  >doc on the <code+		    ><a href="#" title="ConstructorArgs"+		      >:*</a+		      ></code+		    > constructor</p+		  ></td+		></tr+	      ><tr+	      ><td colspan="2"+		><div class="subs fields"+		  ><p class="caption"+		    >Fields</p+		    ><ul+		    ><li+		      ><dfn class="src"+			><a href="#" title="Data.Int"+			  >Int</a+			  ></dfn+			><div class="doc"+			><p+			  >doc on the <code+			    ><a href="#" title="Data.Int"+			      >Int</a+			      ></code+			    > field of the <code+			    ><a href="#" title="ConstructorArgs"+			      >:*</a+			      ></code+			    > constructor</p+			  ></div+			></li+		      ><li+		      ><dfn class="src"+			><a href="#" title="Data.String"+			  >String</a+			  ></dfn+			><div class="doc"+			><p+			  >doc on the <code+			    ><a href="#" title="Data.String"+			      >String</a+			      ></code+			    > field of the <code+			    ><a href="#" title="ConstructorArgs"+			      >:*</a+			      ></code+			    > constructor</p+			  ></div+			></li+		      ></ul+		    ></div+		  ></td+		></tr+	      ></table+	    ></div+	  ></div+	><div class="top"+	><p class="src"+	  ><span class="keyword"+	    >data</span+	    > <a id="t:Boo" class="def"+	    >Boo</a+	    > <span class="keyword"+	    >where</span+	    > <span class="fixity"+	    >infixr 4</span+	    ><span class="rightedge"+	    ></span+	    > <a href="#" class="selflink"+	    >#</a+	    ></p+	  ><div class="subs constructors"+	  ><p class="caption"+	    >Constructors</p+	    ><table+	    ><tr+	      ><td class="src"+		><a id="v:Foo" class="def"+		  >Foo</a+		  > <span class="fixity"+		  >infixr 1</span+		  ><span class="rightedge"+		  ></span+		  ></td+		><td class="doc"+		><p+		  >Info about a <code+		    ><a href="#" title="ConstructorArgs"+		      >Foo</a+		      ></code+		    ></p+		  ></td+		></tr+	      ><tr+	      ><td colspan="2"+		><div class="subs fields"+		  ><p class="caption"+		    >Fields</p+		    ><ul+		    ><li+		      ><dfn class="src"+			>:: <a href="#" title="Data.Int"+			  >Int</a+			  ></dfn+			><div class="doc"+			><p+			  ><code+			    ><a href="#" title="Data.Int"+			      >Int</a+			      ></code+			    > field of <code+			    ><a href="#" title="ConstructorArgs"+			      >Foo</a+			      ></code+			    ></p+			  ></div+			></li+		      ><li+		      ><dfn class="src"+			>-&gt; <a href="#" title="Data.String"+			  >String</a+			  ></dfn+			><div class="doc"+			><p+			  ><code+			    ><a href="#" title="Data.String"+			      >String</a+			      ></code+			    > field of <code+			    ><a href="#" title="ConstructorArgs"+			      >Foo</a+			      ></code+			    ></p+			  ></div+			></li+		      ><li+		      ><dfn class="src"+			>-&gt; <a href="#" title="ConstructorArgs"+			  >Boo</a+			  ></dfn+			><div class="doc"+			><p+			  >Make a <code+			    ><a href="#" title="ConstructorArgs"+			      >Boo</a+			      ></code+			    ></p+			  ></div+			></li+		      ></ul+		    ></div+		  ></td+		></tr+	      ><tr+	      ><td class="src"+		><a id="v:Foa" class="def"+		  >Foa</a+		  > :: <a href="#" title="Data.Int"+		  >Int</a+		  > -&gt; <a href="#" title="ConstructorArgs"+		  >Boo</a+		  ></td+		><td class="doc"+		><p+		  >no argument docs GADT</p+		  ></td+		></tr+	      ></table+	    ></div+	  ><div class="subs bundled-patterns"+	  ><p class="caption"+	    >Bundled Patterns</p+	    ><table+	    ><tr+	      ><td class="src"+		><span class="keyword"+		  >pattern</span+		  > <a id="v:Fo" class="def"+		  >Fo</a+		  > <span class="fixity"+		  >infixr 5</span+		  ><span class="rightedge"+		  ></span+		  ></td+		><td class="doc"+		><p+		  >Info about bundled <code+		    ><a href="#" title="ConstructorArgs"+		      >Fo</a+		      ></code+		    ></p+		  ></td+		></tr+	      ><tr+	      ><td colspan="2"+		><div class="subs fields"+		  ><p class="caption"+		    >Fields</p+		    ><ul+		    ><li+		      ><dfn class="src"+			>:: <a href="#" title="Data.Int"+			  >Int</a+			  ></dfn+			><div class="doc"+			><p+			  >an <code+			    ><a href="#" title="Data.Int"+			      >Int</a+			      ></code+			    ></p+			  ></div+			></li+		      ><li+		      ><dfn class="src"+			>-&gt; <a href="#" title="Data.String"+			  >String</a+			  ></dfn+			><div class="doc"+			><p+			  >a <code+			    ><a href="#" title="Data.String"+			      >String</a+			      ></code+			    ></p+			  ></div+			></li+		      ><li+		      ><dfn class="src"+			>-&gt; <a href="#" title="ConstructorArgs"+			  >Boo</a+			  ></dfn+			><div class="doc"+			><p+			  >a <code+			    ><a href="#" title="ConstructorArgs"+			      >Boo</a+			      ></code+			    ></p+			  ></div+			></li+		      ></ul+		    ></div+		  ></td+		></tr+	      ><tr+	      ><td class="src"+		><span class="keyword"+		  >pattern</span+		  > <a id="v:Fo-39-" class="def"+		  >Fo'</a+		  > :: <a href="#" title="ConstructorArgs"+		  >Boo</a+		  ></td+		><td class="doc"+		><p+		  >Bundled and no argument docs</p+		  ></td+		></tr+	      ></table+	    ></div+	  ></div+	><div class="top"+	><p class="src"+	  ><span class="keyword"+	    >pattern</span+	    > <a id="v:Bo" class="def"+	    >Bo</a+	    > <span class="fixity"+	    >infixr 6</span+	    ><span class="rightedge"+	    ></span+	    > <a href="#" class="selflink"+	    >#</a+	    ></p+	  ><div class="subs arguments"+	  ><p class="caption"+	    >Arguments</p+	    ><table+	    ><tr+	      ><td class="src"+		>:: <a href="#" title="Data.Int"+		  >Int</a+		  ></td+		><td class="doc"+		><p+		  >an <code+		    ><a href="#" title="Data.Int"+		      >Int</a+		      ></code+		    ></p+		  ></td+		></tr+	      ><tr+	      ><td class="src"+		>-&gt; <a href="#" title="Data.String"+		  >String</a+		  ></td+		><td class="doc"+		><p+		  >a <code+		    ><a href="#" title="Data.String"+		      >String</a+		      ></code+		    ></p+		  ></td+		></tr+	      ><tr+	      ><td class="src"+		>-&gt; <a href="#" title="ConstructorArgs"+		  >Boo</a+		  ></td+		><td class="doc"+		><p+		  >a <code+		    ><a href="#" title="ConstructorArgs"+		      >Boo</a+		      ></code+		    > pattern</p+		  ></td+		></tr+	      ></table+	    ></div+	  ><div class="doc"+	  ><p+	    >Info about not-bundled <code+	      ><a href="#" title="ConstructorArgs"+		>Bo</a+		></code+	      ></p+	    ></div+	  ></div+	><div class="top"+	><p class="src"+	  ><span class="keyword"+	    >pattern</span+	    > <a id="v:Bo-39-" class="def"+	    >Bo'</a+	    > :: <a href="#" title="Data.Int"+	    >Int</a+	    > -&gt; <a href="#" title="Data.String"+	    >String</a+	    > -&gt; <a href="#" title="ConstructorArgs"+	    >Boo</a+	    > <a href="#" class="selflink"+	    >#</a+	    ></p+	  ><div class="doc"+	  ><p+	    >Not bunded and no argument docs</p+	    ></div+	  ></div+	></div+      ></div+    ><div id="footer"+    ></div+    ></body+  ></html+>
html-test/ref/ConstructorPatternExport.html view
@@ -97,13 +97,9 @@ 	    >pattern</span 	    > <a id="v:MyGADTCons" class="def" 	    >MyGADTCons</a-	    > :: () =&gt; <span class="keyword"-	    >forall</span-	    > a. <a href="#" title="Data.Eq"-	    >Eq</a-	    > a =&gt; a -&gt; <a href="#" title="Data.Int"+	    > :: a -&gt; <a href="#" title="Data.Int" 	    >Int</a-	    > -&gt; MyGADT (<a href="#" title="Data.Maybe"+	    > -&gt; MyGADT (<a href="#" title="GHC.Maybe" 	    >Maybe</a 	    > <a href="#" title="Data.String" 	    >String</a
html-test/ref/DeprecatedClass.html view
@@ -51,7 +51,11 @@ 	      > a <span class="keyword" 	      >where</span 	      ><ul class="subs"-	      ></ul+	      ><li+		><a href="#"+		  >foo</a+		  > :: a -&gt; a</li+		></ul 	      ></li 	    ><li class="src short" 	    ><span class="keyword"@@ -61,7 +65,11 @@ 	      > a <span class="keyword" 	      >where</span 	      ><ul class="subs"-	      ></ul+	      ><li+		><a href="#"+		  >bar</a+		  > :: a -&gt; a</li+		></ul 	      ></li 	    ></ul 	  ></details@@ -88,14 +96,6 @@ 	    ><p 	    >some class</p 	    ></div-	  ><div class="subs minimal"-	  ><p class="caption"-	    >Minimal complete definition</p-	    ><p class="src"-	    ><a href="#" title="DeprecatedClass"-	      >foo</a-	      ></p-	    ></div 	  ><div class="subs methods" 	  ><p class="caption" 	    >Methods</p@@ -131,14 +131,6 @@ 	    ><p 	      >Deprecated: SomeOtherClass</p 	      ></div-	    ></div-	  ><div class="subs minimal"-	  ><p class="caption"-	    >Minimal complete definition</p-	    ><p class="src"-	    ><a href="#" title="DeprecatedClass"-	      >bar</a-	      ></p 	    ></div 	  ><div class="subs methods" 	  ><p class="caption"
html-test/ref/DeprecatedTypeFamily.html view
@@ -48,21 +48,13 @@ 	      >data family</span 	      > <a href="#" 	      >SomeTypeFamily</a-	      > k :: <a href="#" title="Data.Kind"-	      >*</a-	      > -&gt; <a href="#" title="Data.Kind"-	      >*</a-	      ></li+	      > k :: * -&gt; *</li 	    ><li class="src short" 	    ><span class="keyword" 	      >data family</span 	      > <a href="#" 	      >SomeOtherTypeFamily</a-	      > k :: <a href="#" title="Data.Kind"-	      >*</a-	      > -&gt; <a href="#" title="Data.Kind"-	      >*</a-	      ></li+	      > k :: * -&gt; *</li 	    ></ul 	  ></details 	></div@@ -75,11 +67,7 @@ 	    >data family</span 	    > <a id="t:SomeTypeFamily" class="def" 	    >SomeTypeFamily</a-	    > k :: <a href="#" title="Data.Kind"-	    >*</a-	    > -&gt; <a href="#" title="Data.Kind"-	    >*</a-	    > <a href="#" class="selflink"+	    > k :: * -&gt; * <a href="#" class="selflink" 	    >#</a 	    ></p 	  ><div class="doc"@@ -97,11 +85,7 @@ 	    >data family</span 	    > <a id="t:SomeOtherTypeFamily" class="def" 	    >SomeOtherTypeFamily</a-	    > k :: <a href="#" title="Data.Kind"-	    >*</a-	    > -&gt; <a href="#" title="Data.Kind"-	    >*</a-	    > <a href="#" class="selflink"+	    > k :: * -&gt; * <a href="#" class="selflink" 	    >#</a 	    ></p 	  ><div class="doc"
html-test/ref/GADTRecords.html view
@@ -136,12 +136,6 @@ 	      ><td class="src" 		><a id="v:C3" class="def" 		  >C3</a-		  > :: {..} -&gt; <a href="#" title="GADTRecords"-		  >H1</a-		  > <a href="#" title="Data.Int"-		  >Int</a-		  > <a href="#" title="Data.Int"-		  >Int</a 		  ></td 		><td class="doc empty" 		></td@@ -154,7 +148,7 @@ 		    ><ul 		    ><li 		      ><dfn class="src"-			><a id="v:field" class="def"+			>:: { <a id="v:field" class="def" 			  >field</a 			  > :: <a href="#" title="Data.Int" 			  >Int</a@@ -164,6 +158,18 @@ 			  >hello docs</p 			  ></div 			></li+		      ><li+		      ><dfn class="src"+			>} -&gt; <a href="#" title="GADTRecords"+			  >H1</a+			  > <a href="#" title="Data.Int"+			  >Int</a+			  > <a href="#" title="Data.Int"+			  >Int</a+			  ></dfn+			><div class="doc empty"+			></div+			></li 		      ></ul 		    ></div 		  ></td@@ -172,11 +178,7 @@ 	      ><td class="src" 		><a id="v:C4" class="def" 		  >C4</a-		  > :: {..} -&gt; <a href="#" title="GADTRecords"-		  >H1</a-		  > <a href="#" title="Data.Int"-		  >Int</a-		  > a</td+		  ></td 		><td class="doc empty" 		></td 		></tr@@ -188,13 +190,23 @@ 		    ><ul 		    ><li 		      ><dfn class="src"-			><a id="v:field2" class="def"+			>:: { <a id="v:field2" class="def" 			  >field2</a 			  > :: a</dfn 			><div class="doc" 			><p 			  >hello2 docs</p 			  ></div+			></li+		      ><li+		      ><dfn class="src"+			>} -&gt; <a href="#" title="GADTRecords"+			  >H1</a+			  > <a href="#" title="Data.Int"+			  >Int</a+			  > a</dfn+			><div class="doc empty"+			></div 			></li 		      ></ul 		    ></div
+ html-test/ref/GadtConstructorArgs.html view
@@ -0,0 +1,192 @@+<html xmlns="http://www.w3.org/1999/xhtml"+><head+  ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"+     /><title+    >GadtConstructorArgs</title+    ><link href="#" rel="stylesheet" type="text/css" title="Ocean"+     /><link rel="stylesheet" type="text/css" href="#"+     /><script src="haddock-bundle.min.js" async="async" type="text/javascript"+    ></script+    ><script src="https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.0/MathJax.js?config=TeX-AMS-MML_HTMLorMML" type="text/javascript"+    ></script+    ></head+  ><body+  ><div id="package-header"+    ><ul class="links" id="page-menu"+      ><li+	><a href="#"+	  >Contents</a+	  ></li+	><li+	><a href="#"+	  >Index</a+	  ></li+	></ul+      ><p class="caption empty"+      ></p+      ></div+    ><div id="content"+    ><div id="module-header"+      ><table class="info"+	><tr+	  ><th+	    >Safe Haskell</th+	    ><td+	    >Safe</td+	    ></tr+	  ></table+	><p class="caption"+	>GadtConstructorArgs</p+	></div+      ><div id="interface"+      ><h1+	>Documentation</h1+	><div class="top"+	><p class="src"+	  ><span class="keyword"+	    >data</span+	    > <a id="t:Boo" class="def"+	    >Boo</a+	    > <span class="keyword"+	    >where</span+	    > <a href="#" class="selflink"+	    >#</a+	    ></p+	  ><div class="subs constructors"+	  ><p class="caption"+	    >Constructors</p+	    ><table+	    ><tr+	      ><td class="src"+		><a id="v:Fot" class="def"+		  >Fot</a+		  ></td+		><td class="doc empty"+		></td+		></tr+	      ><tr+	      ><td colspan="2"+		><div class="subs fields"+		  ><p class="caption"+		    >Fields</p+		    ><ul+		    ><li+		      ><dfn class="src"+			>:: { <a id="v:x" class="def"+			  >x</a+			  > :: <a href="#" title="Data.Int"+			  >Int</a+			  ></dfn+			><div class="doc"+			><p+			  >an <code+			    ><a href="#" title="GadtConstructorArgs"+			      >x</a+			      ></code+			    ></p+			  ></div+			></li+		      ><li+		      ><dfn class="src"+			>, <a id="v:y" class="def"+			  >y</a+			  > :: <a href="#" title="Data.Int"+			  >Int</a+			  ></dfn+			><div class="doc"+			><p+			  >a <code+			    ><a href="#" title="GadtConstructorArgs"+			      >y</a+			      ></code+			    ></p+			  ></div+			></li+		      ><li+		      ><dfn class="src"+			>} -&gt; <a href="#" title="GadtConstructorArgs"+			  >Boo</a+			  ></dfn+			><div class="doc empty"+			></div+			></li+		      ></ul+		    ></div+		  ></td+		></tr+	      ><tr+	      ><td class="src"+		><a id="v:Fob" class="def"+		  >Fob</a+		  ></td+		><td class="doc"+		><p+		  >Record GADT with docs</p+		  ></td+		></tr+	      ><tr+	      ><td colspan="2"+		><div class="subs fields"+		  ><p class="caption"+		    >Fields</p+		    ><ul+		    ><li+		      ><dfn class="src"+			>:: { <a id="v:w" class="def"+			  >w</a+			  > :: <a href="#" title="Data.Int"+			  >Int</a+			  ></dfn+			><div class="doc"+			><p+			  >a <code+			    ><a href="#" title="GadtConstructorArgs"+			      >w</a+			      ></code+			    ></p+			  ></div+			></li+		      ><li+		      ><dfn class="src"+			>, <a id="v:z" class="def"+			  >z</a+			  > :: <a href="#" title="Data.Int"+			  >Int</a+			  ></dfn+			><div class="doc"+			><p+			  >a <code+			    ><a href="#" title="GadtConstructorArgs"+			      >z</a+			      ></code+			    ></p+			  ></div+			></li+		      ><li+		      ><dfn class="src"+			>} -&gt; <a href="#" title="GadtConstructorArgs"+			  >Boo</a+			  ></dfn+			><div class="doc"+			><p+			  >a <code+			    ><a href="#" title="GadtConstructorArgs"+			      >Boo</a+			      ></code+			    ></p+			  ></div+			></li+		      ></ul+		    ></div+		  ></td+		></tr+	      ></table+	    ></div+	  ></div+	></div+      ></div+    ><div id="footer"+    ></div+    ></body+  ></html+>
html-test/ref/Hash.html view
@@ -115,7 +115,7 @@ 	      >Hash</a 	      > key =&gt; key -&gt; <a href="#" title="System.IO" 	      >IO</a-	      > (<a href="#" title="Data.Maybe"+	      > (<a href="#" title="GHC.Maybe" 	      >Maybe</a 	      > val)</li 	    ><li class="src short"@@ -126,7 +126,13 @@ 	      > a <span class="keyword" 	      >where</span 	      ><ul class="subs"-	      ></ul+	      ><li+		><a href="#"+		  >hash</a+		  > :: a -&gt; <a href="#" title="Data.Int"+		  >Int</a+		  ></li+		></ul 	      ></li 	    ></ul 	  ></details@@ -217,7 +223,7 @@ 	    >Hash</a 	    > key =&gt; key -&gt; <a href="#" title="System.IO" 	    >IO</a-	    > (<a href="#" title="Data.Maybe"+	    > (<a href="#" title="GHC.Maybe" 	    >Maybe</a 	    > val) <a href="#" class="selflink" 	    >#</a@@ -226,13 +232,13 @@ 	  ><p 	    >Looks up a key in the hash table, returns <code 	      ><code-		><a href="#" title="Data.Maybe"+		><a href="#" title="GHC.Maybe" 		  >Just</a 		  ></code 		> val</code 	      > if the key  was found, or <code-	      ><a href="#" title="Data.Maybe"+	      ><a href="#" title="GHC.Maybe" 		>Nothing</a 		></code 	      > otherwise.</p@@ -258,14 +264,6 @@ 	  ><div class="doc" 	  ><p 	    >A class of types which can be hashed.</p-	    ></div-	  ><div class="subs minimal"-	  ><p class="caption"-	    >Minimal complete definition</p-	    ><p class="src"-	    ><a href="#" title="Hash"-	      >hash</a-	      ></p 	    ></div 	  ><div class="subs methods" 	  ><p class="caption"
html-test/ref/Instances.html view
@@ -146,6 +146,12 @@ 	    > <a href="#" class="selflink" 	    >#</a 	    ></p+	  ><div class="subs minimal"+	  ><p class="caption"+	    >Minimal complete definition</p+	    ><p class="src"+	    >Nothing</p+	    ></div 	  ><div class="subs methods" 	  ><p class="caption" 	    >Methods</p@@ -228,7 +234,7 @@ 		      ></span 		      > <a href="#" title="Instances" 		      >Foo</a-		      > <a href="#" title="Data.Maybe"+		      > <a href="#" title="GHC.Maybe" 		      >Maybe</a 		      ></span 		    > <a href="#" class="selflink"@@ -252,11 +258,11 @@ 			><p class="src" 			><a href="#" 			  >foo</a-			  > :: <a href="#" title="Data.Maybe"+			  > :: <a href="#" title="GHC.Maybe" 			  >Maybe</a 			  > <a href="#" title="Data.Int" 			  >Int</a-			  > -&gt; a -&gt; <a href="#" title="Data.Maybe"+			  > -&gt; a -&gt; <a href="#" title="GHC.Maybe" 			  >Maybe</a 			  > a <a href="#" class="selflink" 			  >#</a@@ -264,15 +270,15 @@ 			><p class="src" 			><a href="#" 			  >foo'</a-			  > :: <a href="#" title="Data.Maybe"+			  > :: <a href="#" title="GHC.Maybe" 			  >Maybe</a-			  > (<a href="#" title="Data.Maybe"+			  > (<a href="#" title="GHC.Maybe" 			  >Maybe</a 			  > a) -&gt; <a href="#" title="Data.Int" 			  >Int</a-			  > -&gt; <a href="#" title="Data.Maybe"+			  > -&gt; <a href="#" title="GHC.Maybe" 			  >Maybe</a-			  > (<a href="#" title="Data.Maybe"+			  > (<a href="#" title="GHC.Maybe" 			  >Maybe</a 			  > <a href="#" title="Data.Int" 			  >Int</a@@ -581,9 +587,9 @@ 		      > <a href="#" title="Instances" 		      >Foo</a 		      > ((-&gt;) a :: <a href="#" title="Data.Kind"-		      >*</a+		      >Type</a 		      > -&gt; <a href="#" title="Data.Kind"-		      >*</a+		      >Type</a 		      >)</span 		    > <a href="#" class="selflink" 		    >#</a@@ -614,11 +620,11 @@ 			><p class="src" 			><a href="#" 			  >foo'</a-			  > :: (a -&gt; a -&gt; a0) -&gt; <a href="#" title="Data.Int"+			  > :: (a -&gt; (a -&gt; a0)) -&gt; <a href="#" title="Data.Int" 			  >Int</a-			  > -&gt; a -&gt; a -&gt; <a href="#" title="Data.Int"+			  > -&gt; a -&gt; (a -&gt; <a href="#" title="Data.Int" 			  >Int</a-			  > <a href="#" class="selflink"+			  >) <a href="#" class="selflink" 			  >#</a 			  ></p 			></div@@ -642,6 +648,12 @@ 	    > <a href="#" class="selflink" 	    >#</a 	    ></p+	  ><div class="subs minimal"+	  ><p class="caption"+	    >Minimal complete definition</p+	    ><p class="src"+	    >Nothing</p+	    ></div 	  ><div class="subs methods" 	  ><p class="caption" 	    >Methods</p@@ -684,7 +696,7 @@ 		      ></span 		      > <a href="#" title="Instances" 		      >Bar</a-		      > <a href="#" title="Data.Maybe"+		      > <a href="#" title="GHC.Maybe" 		      >Maybe</a 		      > <a href="#" title="Data.Bool" 		      >Bool</a@@ -710,11 +722,11 @@ 			><p class="src" 			><a href="#" 			  >bar</a-			  > :: <a href="#" title="Data.Maybe"+			  > :: <a href="#" title="GHC.Maybe" 			  >Maybe</a 			  > <a href="#" title="Data.Bool" 			  >Bool</a-			  > -&gt; <a href="#" title="Data.Maybe"+			  > -&gt; <a href="#" title="GHC.Maybe" 			  >Maybe</a 			  > <a href="#" title="Data.Bool" 			  >Bool</a@@ -726,17 +738,17 @@ 			><p class="src" 			><a href="#" 			  >bar'</a-			  > :: <a href="#" title="Data.Maybe"+			  > :: <a href="#" title="GHC.Maybe" 			  >Maybe</a-			  > (<a href="#" title="Data.Maybe"+			  > (<a href="#" title="GHC.Maybe" 			  >Maybe</a 			  > <a href="#" title="Data.Bool" 			  >Bool</a-			  >) -&gt; <a href="#" title="Data.Maybe"+			  >) -&gt; <a href="#" title="GHC.Maybe" 			  >Maybe</a-			  > (<a href="#" title="Data.Maybe"+			  > (<a href="#" title="GHC.Maybe" 			  >Maybe</a-			  > (<a href="#" title="Data.Maybe"+			  > (<a href="#" title="GHC.Maybe" 			  >Maybe</a 			  > b)) <a href="#" class="selflink" 			  >#</a@@ -744,17 +756,17 @@ 			><p class="src" 			><a href="#" 			  >bar0</a-			  > :: (<a href="#" title="Data.Maybe"+			  > :: (<a href="#" title="GHC.Maybe" 			  >Maybe</a 			  > <a href="#" title="Data.Bool" 			  >Bool</a-			  >, <a href="#" title="Data.Maybe"+			  >, <a href="#" title="GHC.Maybe" 			  >Maybe</a 			  > <a href="#" title="Data.Bool" 			  >Bool</a-			  >) -&gt; (<a href="#" title="Data.Maybe"+			  >) -&gt; (<a href="#" title="GHC.Maybe" 			  >Maybe</a-			  > b, <a href="#" title="Data.Maybe"+			  > b, <a href="#" title="GHC.Maybe" 			  >Maybe</a 			  > c) <a href="#" class="selflink" 			  >#</a@@ -762,17 +774,17 @@ 			><p class="src" 			><a href="#" 			  >bar1</a-			  > :: (<a href="#" title="Data.Maybe"+			  > :: (<a href="#" title="GHC.Maybe" 			  >Maybe</a 			  > <a href="#" title="Data.Bool" 			  >Bool</a-			  >, <a href="#" title="Data.Maybe"+			  >, <a href="#" title="GHC.Maybe" 			  >Maybe</a 			  > <a href="#" title="Data.Bool" 			  >Bool</a-			  >) -&gt; (<a href="#" title="Data.Maybe"+			  >) -&gt; (<a href="#" title="GHC.Maybe" 			  >Maybe</a-			  > b, <a href="#" title="Data.Maybe"+			  > b, <a href="#" title="GHC.Maybe" 			  >Maybe</a 			  > c) <a href="#" class="selflink" 			  >#</a@@ -788,7 +800,7 @@ 		      ></span 		      > <a href="#" title="Instances" 		      >Bar</a-		      > <a href="#" title="Data.Maybe"+		      > <a href="#" title="GHC.Maybe" 		      >Maybe</a 		      > [a]</span 		    > <a href="#" class="selflink"@@ -812,9 +824,9 @@ 			><p class="src" 			><a href="#" 			  >bar</a-			  > :: <a href="#" title="Data.Maybe"+			  > :: <a href="#" title="GHC.Maybe" 			  >Maybe</a-			  > [a] -&gt; <a href="#" title="Data.Maybe"+			  > [a] -&gt; <a href="#" title="GHC.Maybe" 			  >Maybe</a 			  > <a href="#" title="Data.Bool" 			  >Bool</a@@ -824,15 +836,15 @@ 			><p class="src" 			><a href="#" 			  >bar'</a-			  > :: <a href="#" title="Data.Maybe"+			  > :: <a href="#" title="GHC.Maybe" 			  >Maybe</a-			  > (<a href="#" title="Data.Maybe"+			  > (<a href="#" title="GHC.Maybe" 			  >Maybe</a-			  > [a]) -&gt; <a href="#" title="Data.Maybe"+			  > [a]) -&gt; <a href="#" title="GHC.Maybe" 			  >Maybe</a-			  > (<a href="#" title="Data.Maybe"+			  > (<a href="#" title="GHC.Maybe" 			  >Maybe</a-			  > (<a href="#" title="Data.Maybe"+			  > (<a href="#" title="GHC.Maybe" 			  >Maybe</a 			  > b)) <a href="#" class="selflink" 			  >#</a@@ -840,13 +852,13 @@ 			><p class="src" 			><a href="#" 			  >bar0</a-			  > :: (<a href="#" title="Data.Maybe"+			  > :: (<a href="#" title="GHC.Maybe" 			  >Maybe</a-			  > [a], <a href="#" title="Data.Maybe"+			  > [a], <a href="#" title="GHC.Maybe" 			  >Maybe</a-			  > [a]) -&gt; (<a href="#" title="Data.Maybe"+			  > [a]) -&gt; (<a href="#" title="GHC.Maybe" 			  >Maybe</a-			  > b, <a href="#" title="Data.Maybe"+			  > b, <a href="#" title="GHC.Maybe" 			  >Maybe</a 			  > c) <a href="#" class="selflink" 			  >#</a@@ -854,13 +866,13 @@ 			><p class="src" 			><a href="#" 			  >bar1</a-			  > :: (<a href="#" title="Data.Maybe"+			  > :: (<a href="#" title="GHC.Maybe" 			  >Maybe</a-			  > [a], <a href="#" title="Data.Maybe"+			  > [a], <a href="#" title="GHC.Maybe" 			  >Maybe</a-			  > [a]) -&gt; (<a href="#" title="Data.Maybe"+			  > [a]) -&gt; (<a href="#" title="GHC.Maybe" 			  >Maybe</a-			  > b, <a href="#" title="Data.Maybe"+			  > b, <a href="#" title="GHC.Maybe" 			  >Maybe</a 			  > c) <a href="#" class="selflink" 			  >#</a@@ -1196,6 +1208,12 @@ 	    > <a href="#" class="selflink" 	    >#</a 	    ></p+	  ><div class="subs minimal"+	  ><p class="caption"+	    >Minimal complete definition</p+	    ><p class="src"+	    >Nothing</p+	    ></div 	  ><div class="subs methods" 	  ><p class="caption" 	    >Methods</p@@ -1922,6 +1940,12 @@ 	    > <a href="#" class="selflink" 	    >#</a 	    ></p+	  ><div class="subs minimal"+	  ><p class="caption"+	    >Minimal complete definition</p+	    ><p class="src"+	    >Nothing</p+	    ></div 	  ><div class="subs associated-types" 	  ><p class="caption" 	    >Associated Types</p@@ -1999,7 +2023,7 @@ 			  > c <a href="#" title="Data.Bool" 			  >Bool</a 			  > :: <a href="#" title="Data.Kind"-			  >*</a+			  >Type</a 			  > <a href="#" class="selflink" 			  >#</a 			  ></p@@ -2011,7 +2035,7 @@ 			  > <a href="#" title="Data.Int" 			  >Int</a 			  > c :: <a href="#" title="Data.Kind"-			  >*</a+			  >Type</a 			  > <a href="#" class="selflink" 			  >#</a 			  ></p@@ -2073,7 +2097,7 @@ 			  > <a href="#" title="Instances" 			  >Plugh</a 			  > [a] c [b] :: <a href="#" title="Data.Kind"-			  >*</a+			  >Type</a 			  > <a href="#" class="selflink" 			  >#</a 			  ></p@@ -2083,7 +2107,7 @@ 			  > <a href="#" title="Instances" 			  >Thud</a 			  > [a] c :: <a href="#" title="Data.Kind"-			  >*</a+			  >Type</a 			  > <a href="#" class="selflink" 			  >#</a 			  ></p
html-test/ref/Minimal.html view
@@ -128,6 +128,26 @@ 	    > <a href="#" class="selflink" 	    >#</a 	    ></p+	  ><div class="subs minimal"+	  ><p class="caption"+	    >Minimal complete definition</p+	    ><p class="src"+	    >(<a href="#" title="Minimal"+	      >a</a+	      >, <a href="#" title="Minimal"+	      >b</a+	      >, <a href="#" title="Minimal"+	      >c</a+	      > | (<a href="#" title="Minimal"+	      >d</a+	      > | <a href="#" title="Minimal"+	      >e</a+	      >, (<a href="#" title="Minimal"+	      >f</a+	      > | <a href="#" title="Minimal"+	      >g</a+	      >)))</p+	    ></div 	  ><div class="subs methods" 	  ><p class="caption" 	    >Methods</p@@ -230,16 +250,6 @@ 	    > <a href="#" class="selflink" 	    >#</a 	    ></p-	  ><div class="subs minimal"-	  ><p class="caption"-	    >Minimal complete definition</p-	    ><p class="src"-	    ><a href="#" title="Minimal"-	      >aaa</a-	      >, <a href="#" title="Minimal"-	      >bbb</a-	      ></p-	    ></div 	  ><div class="subs methods" 	  ><p class="caption" 	    >Methods</p@@ -298,6 +308,12 @@ 	    > <a href="#" class="selflink" 	    >#</a 	    ></p+	  ><div class="subs minimal"+	  ><p class="caption"+	    >Minimal complete definition</p+	    ><p class="src"+	    >Nothing</p+	    ></div 	  ><div class="subs methods" 	  ><p class="caption" 	    >Methods</p
html-test/ref/Operators.html view
@@ -136,15 +136,29 @@ 		  >type</span 		  > a <a href="#" 		  >&lt;&gt;&lt;</a-		  > b :: <a href="#" title="Data.Kind"-		  >*</a-		  ></li+		  > b :: *</li 		><li 		><span class="keyword" 		  >data</span 		  > a <a href="#" 		  >&gt;&lt;&lt;</a 		  > b</li+		><li+		><a href="#"+		  >(&gt;&gt;&lt;)</a+		  >, <a href="#"+		  >(&lt;&lt;&gt;)</a+		  > :: a -&gt; b -&gt; ()</li+		><li+		><a href="#"+		  >(**&gt;)</a+		  >, <a href="#"+		  >(**&lt;)</a+		  >, <a href="#"+		  >(&gt;**)</a+		  >, <a href="#"+		  >(&lt;**)</a+		  > :: a -&gt; a -&gt; ()</li 		></ul 	      ></li 	    ><li class="src short"@@ -376,24 +390,6 @@ 	  ><p 	    >Class with fixity, including associated types</p 	    ></div-	  ><div class="subs minimal"-	  ><p class="caption"-	    >Minimal complete definition</p-	    ><p class="src"-	    ><a href="#" title="Operators"-	      >(&gt;&gt;&lt;)</a-	      >, <a href="#" title="Operators"-	      >(&lt;&lt;&gt;)</a-	      >, <a href="#" title="Operators"-	      >(**&gt;)</a-	      >, <a href="#" title="Operators"-	      >(**&lt;)</a-	      >, <a href="#" title="Operators"-	      >(&gt;**)</a-	      >, <a href="#" title="Operators"-	      >(&lt;**)</a-	      ></p-	    ></div 	  ><div class="subs associated-types" 	  ><p class="caption" 	    >Associated Types</p@@ -402,9 +398,7 @@ 	      >type</span 	      > a <a id="t:-60--62--60-" class="def" 	      >&lt;&gt;&lt;</a-	      > b :: <a href="#" title="Data.Kind"-	      >*</a-	      > <span class="fixity"+	      > b :: * <span class="fixity" 	      >infixl 2</span 	      ><span class="rightedge" 	      ></span
html-test/ref/OrphanInstancesClass.html view
@@ -52,14 +52,6 @@ 	    > <a href="#" class="selflink" 	    >#</a 	    ></p-	  ><div class="subs minimal"-	  ><p class="caption"-	    >Minimal complete definition</p-	    ><p class="src"-	    ><a href="#" title="OrphanInstancesClass"-	      >aClass</a-	      ></p-	    ></div 	  ><div class="subs methods" 	  ><p class="caption" 	    >Methods</p
html-test/ref/PatternSyns.html view
@@ -120,9 +120,7 @@ 	    ><li class="src short" 	    ><span class="keyword" 	      >data</span-	      > (a :: <a href="#" title="Data.Kind"-	      >*</a-	      >) <a href="#"+	      > (a :: *) <a href="#" 	      >&gt;&lt;</a 	      > b = <a href="#" 	      >Empty</a@@ -311,9 +309,7 @@ 	><p class="src" 	  ><span class="keyword" 	    >data</span-	    > (a :: <a href="#" title="Data.Kind"-	    >*</a-	    >) <a id="t:-62--60-" class="def"+	    > (a :: *) <a id="t:-62--60-" class="def" 	    >&gt;&lt;</a 	    > b <a href="#" class="selflink" 	    >#</a
html-test/ref/PromotedTypes.html view
@@ -81,11 +81,7 @@ 	    >data</span 	    > <a id="t:Pattern" class="def" 	    >Pattern</a-	    > :: [<a href="#" title="Data.Kind"-	    >*</a-	    >] -&gt; <a href="#" title="Data.Kind"-	    >*</a-	    > <span class="keyword"+	    > :: [*] -&gt; * <span class="keyword" 	    >where</span 	    > <a href="#" class="selflink" 	    >#</a@@ -108,7 +104,7 @@ 	      ><td class="src" 		><a id="v:Cons" class="def" 		  >Cons</a-		  > :: <a href="#" title="Data.Maybe"+		  > :: <a href="#" title="GHC.Maybe" 		  >Maybe</a 		  > h -&gt; <a href="#" title="PromotedTypes" 		  >Pattern</a@@ -129,11 +125,7 @@ 	    >RevPattern</a 	    > :: <a href="#" title="PromotedTypes" 	    >RevList</a-	    > <a href="#" title="Data.Kind"-	    >*</a-	    > -&gt; <a href="#" title="Data.Kind"-	    >*</a-	    > <span class="keyword"+	    > * -&gt; * <span class="keyword" 	    >where</span 	    > <a href="#" class="selflink" 	    >#</a@@ -158,7 +150,7 @@ 	      ><td class="src" 		><a id="v:RevCons" class="def" 		  >RevCons</a-		  > :: <a href="#" title="Data.Maybe"+		  > :: <a href="#" title="GHC.Maybe" 		  >Maybe</a 		  > h -&gt; <a href="#" title="PromotedTypes" 		  >RevPattern</a@@ -179,13 +171,7 @@ 	    >data</span 	    > <a id="t:Tuple" class="def" 	    >Tuple</a-	    > :: (<a href="#" title="Data.Kind"-	    >*</a-	    >, <a href="#" title="Data.Kind"-	    >*</a-	    >) -&gt; <a href="#" title="Data.Kind"-	    >*</a-	    > <span class="keyword"+	    > :: (*, *) -&gt; * <span class="keyword" 	    >where</span 	    > <a href="#" class="selflink" 	    >#</a
+ html-test/ref/QuantifiedConstraints.html view
@@ -0,0 +1,100 @@+<html xmlns="http://www.w3.org/1999/xhtml"+><head+  ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"+     /><title+    >QuantifiedConstraints</title+    ><link href="#" rel="stylesheet" type="text/css" title="Ocean"+     /><link rel="stylesheet" type="text/css" href="#"+     /><script src="haddock-bundle.min.js" async="async" type="text/javascript"+    ></script+    ><script src="https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.0/MathJax.js?config=TeX-AMS-MML_HTMLorMML" type="text/javascript"+    ></script+    ></head+  ><body+  ><div id="package-header"+    ><ul class="links" id="page-menu"+      ><li+	><a href="#"+	  >Contents</a+	  ></li+	><li+	><a href="#"+	  >Index</a+	  ></li+	></ul+      ><p class="caption empty"+      ></p+      ></div+    ><div id="content"+    ><div id="module-header"+      ><table class="info"+	><tr+	  ><th+	    >Safe Haskell</th+	    ><td+	    >Safe</td+	    ></tr+	  ></table+	><p class="caption"+	>QuantifiedConstraints</p+	></div+      ><div id="interface"+      ><h1+	>Documentation</h1+	><div class="top"+	><p class="src"+	  ><span class="keyword"+	    >class</span+	    > <a id="t:Foo" class="def"+	    >Foo</a+	    > a <span class="keyword"+	    >where</span+	    > <a href="#" class="selflink"+	    >#</a+	    ></p+	  ><div class="subs methods"+	  ><p class="caption"+	    >Methods</p+	    ><p class="src"+	    ><a id="v:fooed" class="def"+	      >fooed</a+	      > :: a <a href="#" class="selflink"+	      >#</a+	      ></p+	    ></div+	  ></div+	><div class="top"+	><p class="src"+	  ><a id="v:needsParensAroundContext" class="def"+	    >needsParensAroundContext</a+	    > :: (<span class="keyword"+	    >forall</span+	    > x. <a href="#" title="QuantifiedConstraints"+	    >Foo</a+	    > (f x)) =&gt; f <a href="#" title="Data.Int"+	    >Int</a+	    > <a href="#" class="selflink"+	    >#</a+	    ></p+	  ></div+	><div class="top"+	><p class="src"+	  ><a id="v:needsNoParensAroundContext" class="def"+	    >needsNoParensAroundContext</a+	    > :: <a href="#" title="QuantifiedConstraints"+	    >Foo</a+	    > (f <a href="#" title="Data.Int"+	    >Int</a+	    >) =&gt; f <a href="#" title="Data.Int"+	    >Int</a+	    > <a href="#" class="selflink"+	    >#</a+	    ></p+	  ></div+	></div+      ></div+    ><div id="footer"+    ></div+    ></body+  ></html+>
html-test/ref/SpuriousSuperclassConstraints.html view
@@ -73,11 +73,7 @@ 	    >data</span 	    > <a id="t:SomeType" class="def" 	    >SomeType</a-	    > (f :: <a href="#" title="Data.Kind"-	    >*</a-	    > -&gt; <a href="#" title="Data.Kind"-	    >*</a-	    >) a <a href="#" class="selflink"+	    > (f :: * -&gt; *) a <a href="#" class="selflink" 	    >#</a 	    ></p 	  ><div class="subs instances"
html-test/ref/Test.html view
@@ -167,7 +167,7 @@ 		  >A</a 		  > <a href="#" title="Data.Int" 		  >Int</a-		  > (<a href="#" title="Data.Maybe"+		  > (<a href="#" title="GHC.Maybe" 		  >Maybe</a 		  > <a href="#" title="Prelude" 		  >Float</a@@ -478,7 +478,17 @@ 	      > a <span class="keyword" 	      >where</span 	      ><ul class="subs"-	      ></ul+	      ><li+		><a href="#"+		  >a</a+		  > :: <a href="#" title="System.IO"+		  >IO</a+		  > a</li+		><li+		><a href="#"+		  >b</a+		  > :: [a]</li+		></ul 	      ></li 	    ><li class="src short" 	    ><span class="keyword"@@ -488,7 +498,17 @@ 	      > a <span class="keyword" 	      >where</span 	      ><ul class="subs"-	      ></ul+	      ><li+		><a href="#"+		  >d</a+		  > :: <a href="#" title="Test"+		  >T</a+		  > a b</li+		><li+		><a href="#"+		  >e</a+		  > :: (a, a)</li+		></ul 	      ></li 	    ><li class="src short" 	    ><span class="keyword"@@ -504,7 +524,11 @@ 	      > a <span class="keyword" 	      >where</span 	      ><ul class="subs"-	      ></ul+	      ><li+		><a href="#"+		  >ff</a+		  > :: a</li+		></ul 	      ></li 	    ><li class="src short" 	    ><a href="#"@@ -688,7 +712,7 @@ 		  >A</a 		  > <a href="#" title="Data.Int" 		  >Int</a-		  > (<a href="#" title="Data.Maybe"+		  > (<a href="#" title="GHC.Maybe" 		  >Maybe</a 		  > <a href="#" title="Prelude" 		  >Float</a@@ -1558,16 +1582,6 @@ 		></code 	      > class)</p 	    ></div-	  ><div class="subs minimal"-	  ><p class="caption"-	    >Minimal complete definition</p-	    ><p class="src"-	    ><a href="#" title="Test"-	      >a</a-	      >, <a href="#" title="Test"-	      >b</a-	      ></p-	    ></div 	  ><div class="subs methods" 	  ><p class="caption" 	    >Methods</p@@ -1618,16 +1632,6 @@ 	  ><p 	    >This is a class declaration with no separate docs for the methods</p 	    ></div-	  ><div class="subs minimal"-	  ><p class="caption"-	    >Minimal complete definition</p-	    ><p class="src"-	    ><a href="#" title="Test"-	      >d</a-	      >, <a href="#" title="Test"-	      >e</a-	      ></p-	    ></div 	  ><div class="subs methods" 	  ><p class="caption" 	    >Methods</p@@ -1790,14 +1794,6 @@ 	    > <a href="#" class="selflink" 	    >#</a 	    ></p-	  ><div class="subs minimal"-	  ><p class="caption"-	    >Minimal complete definition</p-	    ><p class="src"-	    ><a href="#" title="Test"-	      >ff</a-	      ></p-	    ></div 	  ><div class="subs methods" 	  ><p class="caption" 	    >Methods</p
html-test/ref/Ticket61.html view
@@ -52,14 +52,6 @@ 	    > <a href="#" class="selflink" 	    >#</a 	    ></p-	  ><div class="subs minimal"-	  ><p class="caption"-	    >Minimal complete definition</p-	    ><p class="src"-	    ><a href="#" title="Ticket61"-	      >f</a-	      ></p-	    ></div 	  ><div class="subs methods" 	  ><p class="caption" 	    >Methods</p
html-test/ref/TypeFamilies.html view
@@ -110,9 +110,7 @@ 	      >data family</span 	      > <a href="#" 	      >Bat</a-	      > (a :: k) :: <a href="#" title="Data.Kind"-	      >*</a-	      ></li+	      > (a :: k) :: *</li 	    ><li class="src short" 	    ><span class="keyword" 	      >class</span@@ -126,17 +124,13 @@ 		  >data</span 		  > <a href="#" 		  >AssocD</a-		  > a :: <a href="#" title="Data.Kind"-		  >*</a-		  ></li+		  > a :: *</li 		><li 		><span class="keyword" 		  >type</span 		  > <a href="#" 		  >AssocT</a-		  > a :: <a href="#" title="Data.Kind"-		  >*</a-		  ></li+		  > a :: *</li 		></ul 	      ></li 	    ><li class="src short"@@ -287,7 +281,7 @@ 			  > <a href="#" title="TypeFamilies" 			  >X</a 			  > :: <a href="#" title="Data.Kind"-			  >*</a+			  >Type</a 			  > <a href="#" class="selflink" 			  >#</a 			  ></p@@ -299,7 +293,7 @@ 			  > <a href="#" title="TypeFamilies" 			  >X</a 			  > :: <a href="#" title="Data.Kind"-			  >*</a+			  >Type</a 			  > <a href="#" class="selflink" 			  >#</a 			  ></p@@ -352,8 +346,10 @@ 		    > <a href="#" class="selflink" 		    >#</a 		    ></td-		  ><td class="doc empty"-		  ></td+		  ><td class="doc"+		  ><p+		    >External instance</p+		    ></td 		  ></tr 		><tr 		><td colspan="2"@@ -500,7 +496,7 @@ 			> <a href="#" title="TypeFamilies" 			>X</a 			> :: <a href="#" title="Data.Kind"-			>*</a+			>Type</a 			>)</div 		      ></details 		    ></td@@ -586,8 +582,10 @@ 		    > <a href="#" class="selflink" 		    >#</a 		    ></td-		  ><td class="doc empty"-		  ></td+		  ><td class="doc"+		  ><p+		    >Doc for: type instance Foo X = Y</p+		    ></td 		  ></tr 		><tr 		><td colspan="2"@@ -623,7 +621,7 @@ 		      > <a href="#" title="TypeFamilies" 		      >&lt;&gt;</a 		      > (a :: <a href="#" title="Data.Kind"-		      >*</a+		      >Type</a 		      >)</span 		    > <a href="#" class="selflink" 		    >#</a@@ -648,7 +646,7 @@ 			> <a href="#" title="TypeFamilies" 			>&lt;&gt;</a 			> (a :: <a href="#" title="Data.Kind"-			>*</a+			>Type</a 			>) = <a href="#" title="TypeFamilies" 			>X</a 			></div@@ -715,7 +713,7 @@ 			  > <a href="#" title="TypeFamilies" 			  >Y</a 			  > :: <a href="#" title="Data.Kind"-			  >*</a+			  >Type</a 			  > <a href="#" class="selflink" 			  >#</a 			  ></p@@ -727,7 +725,7 @@ 			  > <a href="#" title="TypeFamilies" 			  >Y</a 			  > :: <a href="#" title="Data.Kind"-			  >*</a+			  >Type</a 			  > <a href="#" class="selflink" 			  >#</a 			  ></p@@ -944,8 +942,10 @@ 		    > <a href="#" class="selflink" 		    >#</a 		    ></td-		  ><td class="doc empty"-		  ></td+		  ><td class="doc"+		  ><p+		    >Doc for: type instance Foo Y = X</p+		    ></td 		  ></tr 		><tr 		><td colspan="2"@@ -981,7 +981,7 @@ 		      > <a href="#" title="TypeFamilies" 		      >&lt;&gt;</a 		      > (a :: <a href="#" title="Data.Kind"-		      >*</a+		      >Type</a 		      >)</span 		    > <a href="#" class="selflink" 		    >#</a@@ -1006,7 +1006,7 @@ 			> <a href="#" title="TypeFamilies" 			>&lt;&gt;</a 			> (a :: <a href="#" title="Data.Kind"-			>*</a+			>Type</a 			>) = a</div 		      ></details 		    ></td@@ -1097,7 +1097,13 @@ 			><li class="inst" 			  ><a id="v:BatZ1" class="def" 			    >BatZ1</a-			    > :: <a href="#" title="TypeFamilies"+			    > :: <span class="keyword"+			    >forall</span+			    > (z :: <a href="#" title="TypeFamilies"+			    >Z</a+			    >). <a href="#" title="TypeFamilies"+			    >Z</a+			    > -&gt; <a href="#" title="TypeFamilies" 			    >Bat</a 			    > <a href="#" title="TypeFamilies" 			    >ZA</a@@ -1105,7 +1111,11 @@ 			  ><li class="inst" 			  ><a id="v:BatZ2" class="def" 			    >BatZ2</a-			    > :: <a href="#" title="TypeFamilies"+			    > :: <span class="keyword"+			    >forall</span+			    > (z :: <a href="#" title="TypeFamilies"+			    >Z</a+			    >). {..} -&gt; <a href="#" title="TypeFamilies" 			    >Bat</a 			    > <a href="#" title="TypeFamilies" 			    >ZB</a@@ -1234,8 +1244,10 @@ 		    > <a href="#" class="selflink" 		    >#</a 		    ></td-		  ><td class="doc empty"-		  ></td+		  ><td class="doc"+		  ><p+		    >Doc for: type instance Foo Y = X</p+		    ></td 		  ></tr 		><tr 		><td colspan="2"@@ -1274,8 +1286,10 @@ 		    > <a href="#" class="selflink" 		    >#</a 		    ></td-		  ><td class="doc empty"-		  ></td+		  ><td class="doc"+		  ><p+		    >Doc for: type instance Foo X = Y</p+		    ></td 		  ></tr 		><tr 		><td colspan="2"@@ -1309,9 +1323,7 @@ 	    >data family</span 	    > <a id="t:Bat" class="def" 	    >Bat</a-	    > (a :: k) :: <a href="#" title="Data.Kind"-	    >*</a-	    > <a href="#" class="selflink"+	    > (a :: k) :: * <a href="#" class="selflink" 	    >#</a 	    ></p 	  ><div class="doc"@@ -1365,7 +1377,13 @@ 			><li class="inst" 			  ><a id="v:BatZ1" class="def" 			    >BatZ1</a-			    > :: <a href="#" title="TypeFamilies"+			    > :: <span class="keyword"+			    >forall</span+			    > (z :: <a href="#" title="TypeFamilies"+			    >Z</a+			    >). <a href="#" title="TypeFamilies"+			    >Z</a+			    > -&gt; <a href="#" title="TypeFamilies" 			    >Bat</a 			    > <a href="#" title="TypeFamilies" 			    >ZA</a@@ -1373,7 +1391,11 @@ 			  ><li class="inst" 			  ><a id="v:BatZ2" class="def" 			    >BatZ2</a-			    > :: <a href="#" title="TypeFamilies"+			    > :: <span class="keyword"+			    >forall</span+			    > (z :: <a href="#" title="TypeFamilies"+			    >Z</a+			    >). {..} -&gt; <a href="#" title="TypeFamilies" 			    >Bat</a 			    > <a href="#" title="TypeFamilies" 			    >ZB</a@@ -1518,9 +1540,7 @@ 	      >data</span 	      > <a id="t:AssocD" class="def" 	      >AssocD</a-	      > a :: <a href="#" title="Data.Kind"-	      >*</a-	      > <a href="#" class="selflink"+	      > a :: * <a href="#" class="selflink" 	      >#</a 	      ></p 	    ><div class="doc"@@ -1532,9 +1552,7 @@ 	      >type</span 	      > <a id="t:AssocT" class="def" 	      >AssocT</a-	      > a :: <a href="#" title="Data.Kind"-	      >*</a-	      > <a href="#" class="selflink"+	      > a :: * <a href="#" class="selflink" 	      >#</a 	      ></p 	    ><div class="doc"@@ -1585,7 +1603,7 @@ 			  > <a href="#" title="TypeFamilies" 			  >Y</a 			  > :: <a href="#" title="Data.Kind"-			  >*</a+			  >Type</a 			  > <a href="#" class="selflink" 			  >#</a 			  ></p@@ -1597,7 +1615,7 @@ 			  > <a href="#" title="TypeFamilies" 			  >Y</a 			  > :: <a href="#" title="Data.Kind"-			  >*</a+			  >Type</a 			  > <a href="#" class="selflink" 			  >#</a 			  ></p@@ -1643,7 +1661,7 @@ 			  > <a href="#" title="TypeFamilies" 			  >X</a 			  > :: <a href="#" title="Data.Kind"-			  >*</a+			  >Type</a 			  > <a href="#" class="selflink" 			  >#</a 			  ></p@@ -1655,7 +1673,7 @@ 			  > <a href="#" title="TypeFamilies" 			  >X</a 			  > :: <a href="#" title="Data.Kind"-			  >*</a+			  >Type</a 			  > <a href="#" class="selflink" 			  >#</a 			  ></p@@ -1781,7 +1799,7 @@ 		      > <a href="#" title="TypeFamilies" 		      >&lt;&gt;</a 		      > (a :: <a href="#" title="Data.Kind"-		      >*</a+		      >Type</a 		      >)</span 		    > <a href="#" class="selflink" 		    >#</a@@ -1806,7 +1824,7 @@ 			> <a href="#" title="TypeFamilies" 			>&lt;&gt;</a 			> (a :: <a href="#" title="Data.Kind"-			>*</a+			>Type</a 			>) = a</div 		      ></details 		    ></td@@ -1823,7 +1841,7 @@ 		      > <a href="#" title="TypeFamilies" 		      >&lt;&gt;</a 		      > (a :: <a href="#" title="Data.Kind"-		      >*</a+		      >Type</a 		      >)</span 		    > <a href="#" class="selflink" 		    >#</a@@ -1848,7 +1866,7 @@ 			> <a href="#" title="TypeFamilies" 			>&lt;&gt;</a 			> (a :: <a href="#" title="Data.Kind"-			>*</a+			>Type</a 			>) = <a href="#" title="TypeFamilies" 			>X</a 			></div
html-test/ref/TypeFamilies2.html view
@@ -142,8 +142,10 @@ 		    > <a href="#" class="selflink" 		    >#</a 		    ></td-		  ><td class="doc empty"-		  ></td+		  ><td class="doc"+		  ><p+		    >Should be visible, but with a hidden right hand side</p+		    ></td 		  ></tr 		><tr 		><td colspan="2"@@ -202,8 +204,10 @@ 		    > <a href="#" class="selflink" 		    >#</a 		    ></td-		  ><td class="doc empty"-		  ></td+		  ><td class="doc"+		  ><p+		    >Should be visible, but with a hidden right hand side</p+		    ></td 		  ></tr 		><tr 		><td colspan="2"@@ -240,8 +244,10 @@ 		    > <a href="#" class="selflink" 		    >#</a 		    ></td-		  ><td class="doc empty"-		  ></td+		  ><td class="doc"+		  ><p+		    >External instance</p+		    ></td 		  ></tr 		><tr 		><td colspan="2"
+ html-test/ref/Unicode2.html view
@@ -0,0 +1,100 @@+<html xmlns="http://www.w3.org/1999/xhtml"+><head+  ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"+     /><title+    >Unicode2</title+    ><link href="#" rel="stylesheet" type="text/css" title="Ocean"+     /><link rel="stylesheet" type="text/css" href="#"+     /><script src="haddock-bundle.min.js" async="async" type="text/javascript"+    ></script+    ><script src="https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.0/MathJax.js?config=TeX-AMS-MML_HTMLorMML" type="text/javascript"+    ></script+    ></head+  ><body+  ><div id="package-header"+    ><ul class="links" id="page-menu"+      ><li+	><a href="#"+	  >Contents</a+	  ></li+	><li+	><a href="#"+	  >Index</a+	  ></li+	></ul+      ><p class="caption empty"+      ></p+      ></div+    ><div id="content"+    ><div id="module-header"+      ><table class="info"+	><tr+	  ><th+	    >Safe Haskell</th+	    ><td+	    >Safe</td+	    ></tr+	  ></table+	><p class="caption"+	>Unicode2</p+	></div+      ><div id="synopsis"+      ><details id="syn"+	><summary+	  >Synopsis</summary+	  ><ul class="details-toggle" data-details-id="syn"+	  ><li class="src short"+	    ><a href="#"+	      >&#252;</a+	      > :: ()</li+	    ></ul+	  ></details+	></div+      ><div id="interface"+      ><h1+	>Documentation</h1+	><div class="top"+	><p class="src"+	  ><a id="v:-252-" class="def"+	    >&#252;</a+	    > :: () <a href="#" class="selflink"+	    >#</a+	    ></p+	  ><div class="doc"+	  ><p+	    >All of the following work with a unicode character &#252;:</p+	    ><ul+	    ><li+	      >an italicized <em+		>&#252;</em+		></li+	      ><li+	      >inline code <code+		>&#252;</code+		></li+	      ><li+	      >a code block:</li+	      ></ul+	    ><pre+	    >&#252;</pre+	    ><ul+	    ><li+	      >a url <a href="#"+		>https://www.google.com/search?q=&#252;</a+		></li+	      ><li+	      >a link to <code+		><a href="#" title="Unicode2"+		  >&#252;</a+		  ></code+		></li+	      ></ul+	    ></div+	  ></div+	></div+      ></div+    ><div id="footer"+    ></div+    ></body+  ></html+>
+ html-test/src/Bug745.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}++module Bug574 where+-- See https://github.com/haskell/haddock/issues/574++-- | Somthing with a spliced type+foo :: Int -> $(let i = [t| Int |] in [t| $i -> $i |])+foo x y = x + y
+ html-test/src/ConstructorArgs.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE GADTs, PatternSynonyms #-}++module ConstructorArgs (Foo(..), Boo(Foo, Foa, Fo, Fo'), pattern Bo, pattern Bo') where++data Foo+  = Rec             -- ^ doc on a record+     { x :: String  -- ^ doc on the `String` field of `Rec`+     , y :: String  -- ^ doc on the `String` field of `Rec`+     }+   | Baz Int String  -- ^ old prefix doc style+   | Boa             -- ^ doc on the `Boa` constrictor+       !Int          -- ^ doc on the `Int` field of `Boa`+       !String       -- ^ doc on the `String` field of `Boa`+   | Int :| String   -- ^ old infix doc style+   | Int             -- ^ doc on the `Int` field of the `:*` constructor+       :*            -- ^ doc on the `:*` constructor+     String          -- ^ doc on the `String` field of the `:*` constructor++infixr 1 `Foo`+infixr 2 `Boa`+infixr 3 :*++data Boo where+  -- | Info about a 'Foo'+  Foo :: Int    -- ^ `Int` field of `Foo`+      -> String -- ^ `String` field of `Foo`+      -> Boo    -- ^ Make a `Boo`++  -- | no argument docs GADT+  Foa :: Int -> Boo++infixr 4 `Boo`++-- | Info about bundled 'Fo'+pattern Fo :: Int    -- ^ an 'Int'+           -> String -- ^ a 'String'+           -> Boo    -- ^ a 'Boo'+pattern Fo x y = Foo x y++-- | Bundled and no argument docs+pattern Fo' :: Boo+pattern Fo' = Foo 1 "hi"++infixr 5 `Fo`++-- | Info about not-bundled 'Bo'+pattern Bo :: Int    -- ^ an 'Int'+           -> String -- ^ a 'String'+           -> Boo -- ^ a 'Boo' pattern+pattern Bo x y = Foo x y++-- | Not bunded and no argument docs+pattern Bo' :: Int -> String -> Boo+pattern Bo' x y = Foo x y++infixr 6 `Bo`
+ html-test/src/GadtConstructorArgs.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE GADTs, PatternSynonyms #-}++module GadtConstructorArgs (Boo(..)) where++data Boo where+  Fot :: { x :: Int  -- ^ an 'x'+         , y :: Int  -- ^ a 'y'+         } -> Boo++  -- | Record GADT with docs+  Fob :: { w :: Int  -- ^ a 'w'+         , z :: Int  -- ^ a 'z'+         } -> Boo    -- ^ a 'Boo'
+ html-test/src/QuantifiedConstraints.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE QuantifiedConstraints #-}+module QuantifiedConstraints where++class Foo a where+  fooed :: a++needsParensAroundContext :: (forall x. Foo (f x)) => f Int+needsParensAroundContext = fooed++needsNoParensAroundContext :: Foo (f Int) => f Int+needsNoParensAroundContext = fooed
+ html-test/src/Unicode2.hs view
@@ -0,0 +1,18 @@+module Unicode2 where++-- | All of the following work with a unicode character ü:+--+--   * an italicized /ü/+--   +--   * inline code @ü@+--+--   * a code block:+--+--   > ü+--+--   * a url <https://www.google.com/search?q=ü>+-- +--   * a link to 'ü'+--+ü :: ()+ü = ()
+ hypsrc-test/ref/src/CPP.html view
@@ -0,0 +1,216 @@+<html xmlns="http://www.w3.org/1999/xhtml"+><head+  ><link rel="stylesheet" type="text/css" href="style.css"+     /><script type="text/javascript" src="highlight.js"+    ></script+    ></head+  ><body+  ><pre+    ><span class="hs-pragma"+      >{-# LANGUAGE CPP #-}</span+      ><span+      >+</span+      ><a name="line-2"+      ></a+      ><span class="hs-keyword"+      >module</span+      ><span+      > </span+      ><span class="hs-identifier"+      >CPP</span+      ><span+      > </span+      ><span class="hs-keyword"+      >where</span+      ><span+      >+</span+      ><a name="line-3"+      ></a+      ><span+      >+</span+      ><a name="line-4"+      ></a+      ><span class="hs-cpp"+      >#define SOMETHING1+</span+      ><span+      >+</span+      ><a name="line-6"+      ></a+      ><span class="hs-identifier"+      >foo</span+      ><span+      > </span+      ><span class="hs-glyph"+      >::</span+      ><span+      > </span+      ><span class="hs-identifier hs-type"+      >String</span+      ><span+      >+</span+      ><a name="line-7"+      ></a+      ><a name="foo"+      ><a href="CPP.html#foo"+	><span class="hs-identifier"+	  >foo</span+	  ></a+	></a+      ><span+      > </span+      ><span class="hs-glyph"+      >=</span+      ><span+      > </span+      ><span class="hs-comment"+      >{-  &quot; single quotes are fine in block comments+          {- nested block comments are fine -}+       -}</span+      ><span+      > </span+      ><span class="hs-string"+      >&quot;foo&quot;</span+      ><span+      >+</span+      ><a name="line-10"+      ></a+      ><span+      >+</span+      ><a name="line-11"+      ></a+      ><span class="hs-cpp"+      >#define SOMETHING2+</span+      ><span+      >+</span+      ><a name="line-13"+      ></a+      ><span class="hs-identifier"+      >bar</span+      ><span+      > </span+      ><span class="hs-glyph"+      >::</span+      ><span+      > </span+      ><span class="hs-identifier hs-type"+      >String</span+      ><span+      >+</span+      ><a name="line-14"+      ></a+      ><a name="bar"+      ><a href="CPP.html#bar"+	><span class="hs-identifier"+	  >bar</span+	  ></a+	></a+      ><span+      > </span+      ><span class="hs-glyph"+      >=</span+      ><span+      > </span+      ><span class="hs-string"+      >&quot;block comment in a string is not a comment {- &quot;</span+      ><span+      >+</span+      ><a name="line-15"+      ></a+      ><span+      >+</span+      ><a name="line-16"+      ></a+      ><span class="hs-cpp"+      >#define SOMETHING3+</span+      ><span+      >+</span+      ><a name="line-18"+      ></a+      ><span class="hs-comment"+      >-- &quot; single quotes are fine in line comments</span+      ><span+      >+</span+      ><a name="line-19"+      ></a+      ><span class="hs-comment"+      >-- {- unclosed block comments are fine in line comments</span+      ><span+      >+</span+      ><a name="line-20"+      ></a+      ><span+      >+</span+      ><a name="line-21"+      ></a+      ><span class="hs-comment"+      >-- Multiline CPP is also fine</span+      ><span+      >+</span+      ><a name="line-22"+      ></a+      ><span class="hs-cpp"+      >#define FOO\+  1+</span+      ><span+      >+</span+      ><a name="line-25"+      ></a+      ><span class="hs-identifier"+      >baz</span+      ><span+      > </span+      ><span class="hs-glyph"+      >::</span+      ><span+      > </span+      ><span class="hs-identifier hs-type"+      >String</span+      ><span+      >+</span+      ><a name="line-26"+      ></a+      ><a name="baz"+      ><a href="CPP.html#baz"+	><span class="hs-identifier"+	  >baz</span+	  ></a+	></a+      ><span+      > </span+      ><span class="hs-glyph"+      >=</span+      ><span+      > </span+      ><span class="hs-string"+      >&quot;line comment in a string is not a comment --&quot;</span+      ><span+      >+</span+      ><a name="line-27"+      ></a+      ></pre+    ></body+  ></html+>
+ hypsrc-test/src/CPP.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE CPP #-}+module CPP where++#define SOMETHING1++foo :: String+foo = {-  " single quotes are fine in block comments+          {- nested block comments are fine -}+       -} "foo"++#define SOMETHING2++bar :: String+bar = "block comment in a string is not a comment {- "++#define SOMETHING3++-- " single quotes are fine in line comments+-- {- unclosed block comments are fine in line comments++-- Multiline CPP is also fine+#define FOO\+  1++baz :: String+baz = "line comment in a string is not a comment --"