From 143094b0badbeb217e33e7da4ad4ba669c4e7bd5 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Mon, 7 May 2018 18:53:15 -0700 Subject: Filter out CRLFs in hyperlinker backend (#813) This prevents spurious lines from appearing in the final output. --- haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 34512de8..277634b9 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -24,8 +24,13 @@ import Haddock.Backends.Hyperlinker.Types as T -- (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. -- -- cgit v1.2.3 From 22bfe0a50a63fa2685ed94bd7f3d1ab565f31f6a Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Tue, 8 May 2018 02:15:45 -0700 Subject: Remove 'TokenGroup' from Hyperlinker (#818) Since the hyperlinker backend now relies on the GHC tokenizer, something like 'Bar.Baz.foo' already gets bunched together into one token (as opposed to being spread across 'Bar', '.', 'Baz', '.', and 'foo'). --- .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 64 +++++----------------- 1 file changed, 14 insertions(+), 50 deletions(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index 5291220a..d7ea70a6 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -1,6 +1,5 @@ {-# LANGUAGE RecordWildCards #-} - module Haddock.Backends.Hyperlinker.Renderer (render) where @@ -28,36 +27,10 @@ render :: Maybe FilePath -> Maybe FilePath -> SrcMap -> [RichToken] -> 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 @@ header mcss mjs = , 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 + | otherwise = linked content where - content = mconcat . map (richToken det) $ tokens - - -richToken :: TokenDetails -> Token -> Html -richToken det tok = - tokenSpan tok ! [ multiclass style ] - 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"] -- cgit v1.2.3 From a8840a37976209c5a3c4cf929eff502cdca80ecf Mon Sep 17 00:00:00 2001 From: Simon Jakobi Date: Tue, 8 May 2018 19:48:11 +0200 Subject: Renamer: Warn about out of scope identifiers. (#819) --- haddock-api/src/Haddock/Interface/LexParseRn.hs | 17 +++++++++++------ 1 file changed, 11 insertions(+), 6 deletions(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index 9a978f9f..cbe55dc4 100644 --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -104,7 +104,9 @@ rename dflags gre = rn -- 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,7 +115,7 @@ rename dflags gre = rn -- 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. @@ -154,12 +156,15 @@ rename dflags gre = rn -- 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."] + pure (monospaced a) monospaced a = DocMonospaced (DocString (showPpr dflags a)) -- cgit v1.2.3 From 00ccfecdfedb55d44c84dfa4f0f1de90cfe6fafd Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Thu, 10 May 2018 11:19:47 -0400 Subject: Remove Hoogle backend hack that butchers infix datatype names --- haddock-api/src/Haddock/Backends/Hoogle.hs | 3 +-- hoogle-test/ref/Bug825/test.txt | 9 +++++++++ hoogle-test/src/Bug825/Bug825.hs | 6 ++++++ 3 files changed, 16 insertions(+), 2 deletions(-) create mode 100644 hoogle-test/ref/Bug825/test.txt create mode 100644 hoogle-test/src/Bug825/Bug825.hs (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index e7ce9d30..484841ba 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -225,11 +225,10 @@ ppData dflags decl@(DataDecl { tcdDataDefn = defn }) subdocs -- 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 + 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... diff --git a/hoogle-test/ref/Bug825/test.txt b/hoogle-test/ref/Bug825/test.txt new file mode 100644 index 00000000..a88202dc --- /dev/null +++ b/hoogle-test/ref/Bug825/test.txt @@ -0,0 +1,9 @@ +-- Hoogle documentation, generated by Haddock +-- See Hoogle, http://www.haskell.org/hoogle/ + +@package test +@version 0.0.0 + +module Bug825 +data a :~: b +data (:~~:) a b diff --git a/hoogle-test/src/Bug825/Bug825.hs b/hoogle-test/src/Bug825/Bug825.hs new file mode 100644 index 00000000..bfe07139 --- /dev/null +++ b/hoogle-test/src/Bug825/Bug825.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeOperators #-} +module Bug825 where + +data a :~: b +data (:~~:) a b -- cgit v1.2.3 From 72ff1ba81d29613c8336a7a88c3a01ae540d81d0 Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Thu, 10 May 2018 11:24:38 -0400 Subject: Wibbles --- haddock-api/src/Haddock/Backends/Hoogle.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 484841ba..59a4f53c 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -223,12 +223,12 @@ ppData dflags decl@(DataDecl { tcdDataDefn = defn }) subdocs 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 + -- 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 ppData _ _ _ = panic "ppData" -- | for constructors, and named-fields... -- cgit v1.2.3 From 4f148a9282491d7c9d6fa87dc01e4be4acdec13f Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Wed, 23 May 2018 02:29:05 -0700 Subject: Use `ClassOpSig` instead of `TypeSig` for class methods (#835) * Fix minimal pragma handling Class declarations contain 'ClassOpSig' not 'Typesig'. This should fix #834. * Accept html-test output --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 8 ++-- html-test/ref/Bug26.html | 14 +++---- html-test/ref/Bug613.html | 14 +++---- html-test/ref/Bug647.html | 8 ---- html-test/ref/Bug679.html | 8 ---- html-test/ref/DeprecatedClass.html | 28 +++++-------- html-test/ref/Hash.html | 16 ++++--- html-test/ref/Instances.html | 24 +++++++++++ html-test/ref/Minimal.html | 36 +++++++++++----- html-test/ref/Operators.html | 34 +++++++-------- html-test/ref/OrphanInstancesClass.html | 8 ---- html-test/ref/Test.html | 58 ++++++++++++-------------- html-test/ref/Ticket61.html | 8 ---- 13 files changed, 124 insertions(+), 140 deletions(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 815ecee9..1daf9ace 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -475,9 +475,9 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, t -- 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 @@ -537,12 +537,12 @@ ppClassDecl summary links instances fixities loc d subdocs 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 diff --git a/html-test/ref/Bug26.html b/html-test/ref/Bug26.html index e50169ba..a363fef3 100644 --- a/html-test/ref/Bug26.html +++ b/html-test/ref/Bug26.html @@ -71,7 +71,11 @@ > a where
  • c_f :: a
    • Since: 1.0

    Minimal complete definition

    c_f

    Methods

    f where
    • fmap :: (a -> b) -> f a -> f b
    • #

      Minimal complete definition

      fmap

      Methods

      #

      Minimal complete definition

      f

      Methods

      #

      Minimal complete definition

      foo

      Methods

      a where
      • foo :: a -> a
      • a where
        • bar :: a -> a

          • some class

          Minimal complete definition

          foo

          Methods

          Deprecated: SomeOtherClass

          Minimal complete definition

          bar

          Methods

          a where
          • hash :: a -> Int

            • A class of types which can be hashed.

            Minimal complete definition

            hash

            Methods

            #

            Minimal complete definition

            Nothing

            Methods

            #

            Minimal complete definition

            Nothing

            Methods

            #

            Minimal complete definition

            Nothing

            Methods

            #

            Minimal complete definition

            Nothing

            Associated Types

            #

            Minimal complete definition

            (a, b, c | (d | e, (f | g)))

            Methods

            #

            Minimal complete definition

            aaa, bbb

            Methods

            #

            Minimal complete definition

            Nothing

            Methods

            a ><< b
          • (>><), (<<>) :: a -> b -> ()
          • (**>), (**<), (>**), (<**) :: a -> a -> ()

          • Class with fixity, including associated types

            • Minimal complete definition

            (>><), (<<>), (**>), (**<), (>**), (<**)

            Associated Types

            #

            Minimal complete definition

            aClass

            Methods

            a where
            • a :: IO a
            • b :: [a]
            • a where
              • d :: T a b
              • e :: (a, a)
              • a where
                • ff :: a
                • class)

                  • Minimal complete definition

                  a, b

                  Methods

                  This is a class declaration with no separate docs for the methods

                  Minimal complete definition

                  d, e

                  Methods

                  #

                  Minimal complete definition

                  ff

                  Methods

                  #

                  Minimal complete definition

                  f

                  Methods

                  Date: Tue, 5 Jun 2018 10:47:16 -0700 Subject: Improve hyperlinker's 'spanToNewline' (#846) 'spanToNewline' is used to help break apart the source into lines which can then be partioned into CPP and non-CPP chunks. It is important that 'spanToNewline' not break apart tokens, so it needs to properly handle things like * block comments, possibly nested * string literals, possibly multi-line * CPP macros, possibly multi-line String literals in particular were not being properly handled. The fix is to to fall back in 'Text.Read.lex' to help lex things that are not comments. Fixes #837. --- .../src/Haddock/Backends/Hyperlinker/Parser.hs | 32 ++- hypsrc-test/ref/src/CPP.html | 216 +++++++++++++++++++++ hypsrc-test/src/CPP.hs | 26 +++ 3 files changed, 267 insertions(+), 7 deletions(-) create mode 100644 hypsrc-test/ref/src/CPP.html create mode 100644 hypsrc-test/src/CPP.hs (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 277634b9..456050d1 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -3,6 +3,8 @@ module Haddock.Backends.Hyperlinker.Parser (parse) where 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 @@ -109,12 +111,9 @@ isCPPline :: String -> Bool 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: -- @@ -122,17 +121,36 @@ isCPPline = isPrefixOf "#" . dropWhile (`elem` " \t") . take 5 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) diff --git a/hypsrc-test/ref/src/CPP.html b/hypsrc-test/ref/src/CPP.html new file mode 100644 index 00000000..fb85bd2f --- /dev/null +++ b/hypsrc-test/ref/src/CPP.html @@ -0,0 +1,216 @@ +
                  {-# 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 --"
+
                  \ No newline at end of file diff --git a/hypsrc-test/src/CPP.hs b/hypsrc-test/src/CPP.hs new file mode 100644 index 00000000..f00ce031 --- /dev/null +++ b/hypsrc-test/src/CPP.hs @@ -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 --" -- cgit v1.2.3 From ef16b9f8f73e6a4d639919152925ab83d9b1024f Mon Sep 17 00:00:00 2001 From: Simon Jakobi Date: Fri, 8 Jun 2018 22:20:30 +0200 Subject: Renamer: Warn about ambiguous identifiers (#831) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * Renamer: Warn about ambiguous identifiers Example: Warning: 'elem' is ambiguous. It is defined * in ‘Data.Foldable’ * at /home/simon/tmp/hdk/src/Lib.hs:7:1 You may be able to disambiguate the identifier by qualifying it or by hiding some imports. Defaulting to 'elem' defined at /home/simon/tmp/hdk/src/Lib.hs:7:1 Fixes #830. * Deduplicate warnings Fixes #832. --- haddock-api/src/Haddock/Interface.hs | 4 ++-- haddock-api/src/Haddock/Interface/LexParseRn.hs | 20 +++++++++++++++++--- 2 files changed, 19 insertions(+), 5 deletions(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index 89064a6c..a66745ea 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -184,10 +184,10 @@ processModule verbosity modsum flags modMap instIfaceMap = do 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 + liftIO $ mapM_ putStrLn (nub msgs) dflags <- getDynFlags let (haddockable, haddocked) = ifaceHaddockCoverage interface percentage = round (fromIntegral haddocked * 100 / fromIntegral haddockable :: Double) :: Int diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index cbe55dc4..5d3cf2a6 100644 --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -28,7 +28,7 @@ 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) @@ -120,11 +120,11 @@ rename dflags gre = rn -- 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:b:_ -> ambiguous dflags x (if isTyConName a then a else b) names DocWarning doc -> DocWarning <$> rn doc DocEmphasis doc -> DocEmphasis <$> rn doc @@ -168,3 +168,17 @@ outOfScope dflags x = tell ["Warning: '" ++ showPpr dflags a ++ "' is out of scope."] pure (monospaced a) monospaced a = DocMonospaced (DocString (showPpr dflags a)) + +-- | Warn about an ambiguous identifier. +ambiguous :: DynFlags -> RdrName -> Name -> [Name] -> ErrMsgM (Doc Name) +ambiguous dflags x dflt names = do + tell [msg] + pure (DocIdentifier dflt) + where + msg = "Warning: " ++ x_str ++ " is ambiguous. It is defined\n" ++ + concatMap (\n -> " * " ++ defnLoc n ++ "\n") names ++ + " 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 + x_str = '\'' : showPpr dflags x ++ "'" + defnLoc = showSDoc dflags . pprNameDefnLoc -- cgit v1.2.3 From 88316b972e3d47197b1019111bae0f7f87275fce Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Thu, 5 Jul 2018 10:43:35 -0400 Subject: Export more fixities for Hoogle (#871) This exports fixities for more things, including class methods and type-level operators. --- haddock-api/src/Haddock/Backends/Hoogle.hs | 4 ++-- hoogle-test/ref/Bug722/test.txt | 16 ++++++++++++++++ hoogle-test/src/Bug722/Bug722.hs | 13 +++++++++++++ 3 files changed, 31 insertions(+), 2 deletions(-) create mode 100644 hoogle-test/ref/Bug722/test.txt create mode 100644 hoogle-test/src/Bug722/Bug722.hs (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 59a4f53c..df626c4c 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -123,7 +123,7 @@ ppExport dflags ExportDecl { expItemDecl = L _ decl , 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 @@ -131,7 +131,7 @@ ppExport dflags ExportDecl { expItemDecl = L _ decl 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 ++ ppFixities + f (SigD sig) = ppSig dflags sig f _ = [] ppFixities = concatMap (ppFixity dflags) fixities diff --git a/hoogle-test/ref/Bug722/test.txt b/hoogle-test/ref/Bug722/test.txt new file mode 100644 index 00000000..96f3747b --- /dev/null +++ b/hoogle-test/ref/Bug722/test.txt @@ -0,0 +1,16 @@ +-- Hoogle documentation, generated by Haddock +-- See Hoogle, http://www.haskell.org/hoogle/ + +@package test +@version 0.0.0 + +module Bug722 +class Foo a +(!@#) :: Foo a => a -> a -> a +infixl 4 !@# +type family &* :: * -> * -> * +infixr 3 &* +data a :-& b +(:^&) :: a -> b -> (:-&) a b +infixl 6 :-& +infixl 6 :^& diff --git a/hoogle-test/src/Bug722/Bug722.hs b/hoogle-test/src/Bug722/Bug722.hs new file mode 100644 index 00000000..a33d5b24 --- /dev/null +++ b/hoogle-test/src/Bug722/Bug722.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TypeOperators, TypeFamilies #-} +module Bug722 where + +class Foo a where + (!@#) :: a -> a -> a +infixl 4 !@# + +type family (&*) :: * -> * -> * +infixr 3 &* + +data a :-& b = a :^& b +infixl 6 :-&, :^& + -- cgit v1.2.3 From 657b1b3d519545f8d4ca048c06210d6cbf0f0da0 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Fri, 6 Jul 2018 10:06:32 -0400 Subject: Avoid line breaks due to line length in Hoogle (#868) * Avoid line breaks due to line length in Hoogle Hoogle operates in a line-oriented fashion, so we should avoid ever breaking due to long lines. One way of doing this non-intrusively is to modify the 'DynFlags' that are threaded through the 'Hoogle' module (note this is anyways only passed through for use in the various 'showSDoc' functions). * Amend test case --- haddock-api/src/Haddock/Backends/Hoogle.hs | 8 +++++--- hoogle-test/ref/Bug806/test.txt | 1 + hoogle-test/src/Bug806/Bug806.hs | 1 + 3 files changed, 7 insertions(+), 3 deletions(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index df626c4c..a89ac2c7 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -45,13 +45,15 @@ prefix = ["-- Hoogle documentation, generated by Haddock" 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 diff --git a/hoogle-test/ref/Bug806/test.txt b/hoogle-test/ref/Bug806/test.txt index d9a908b3..67e9fd61 100644 --- a/hoogle-test/ref/Bug806/test.txt +++ b/hoogle-test/ref/Bug806/test.txt @@ -21,4 +21,5 @@ class C a where { -- | AT docs type family AT a; + type AT a = Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy))))))))); } diff --git a/hoogle-test/src/Bug806/Bug806.hs b/hoogle-test/src/Bug806/Bug806.hs index 6efcb5cf..45efda77 100644 --- a/hoogle-test/src/Bug806/Bug806.hs +++ b/hoogle-test/src/Bug806/Bug806.hs @@ -21,3 +21,4 @@ v = 42 class C a where -- | 'AT' docs type AT a + type AT a = Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy))))))))) -- cgit v1.2.3 From c3eb3f0581f69e816f9453b1747a9f2a3ba02bb9 Mon Sep 17 00:00:00 2001 From: Simon Jakobi Date: Thu, 19 Jul 2018 13:36:45 +0200 Subject: tyThingToLHsDecl: Preserve type synonyms that contain a forall (#880) * tyThingToLHsDecls: Preserve type synonyms that contain a forall Fixes #879. * Add Note [Invariant: Never expand type synonyms] * Clarify Note [Invariant: Never expand type synonyms] --- haddock-api/src/Haddock/Convert.hs | 48 ++++++++++++++++++++++++++++++++++++-- 1 file changed, 46 insertions(+), 2 deletions(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 8b227c50..7595f798 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -31,7 +31,7 @@ import NameSet ( emptyNameSet ) import RdrName ( mkVarUnqual ) import PatSyn import SrcLoc ( Located, noLoc, unLoc, GenLocated(..), srcLocSpan ) -import TcType ( tcSplitSigmaTy ) +import TcType import TyCon import Type import TyCoRep @@ -515,7 +515,7 @@ synifyType _ (FunTy t1 t2) = let s2 = synifyType WithinType t2 in noLoc $ HsFunTy 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_body = synifyType WithinType tau } in case s of @@ -610,3 +610,47 @@ synifyFamInst fi opaque = do 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 -- cgit v1.2.3 From 133e9c2c168db19c1135479f7ab144c4e33af2a4 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Fri, 20 Jul 2018 03:01:49 -0700 Subject: Preserve docs on type family instances (#867) * Preserve docs on type family instances The only problem was that the instance location was slightly off for type family instances. * Accept output --- haddock-api/src/Haddock/Interface/Create.hs | 7 +++++-- haddock-api/src/Haddock/Types.hs | 3 +++ html-test/ref/TypeFamilies.html | 30 +++++++++++++++++++---------- html-test/ref/TypeFamilies2.html | 18 +++++++++++------ 4 files changed, 40 insertions(+), 18 deletions(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index a35e2053..ced7cae5 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -419,9 +419,12 @@ mkMaps dflags pkgName gre instances decls = do 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 diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 36ed7baf..5ef5a7b9 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -28,6 +28,7 @@ module Haddock.Types ( 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) @@ -661,6 +662,8 @@ instance Monad ErrMsgGhc where 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 diff --git a/html-test/ref/TypeFamilies.html b/html-test/ref/TypeFamilies.html index 190f376e..1fe20c4b 100644 --- a/html-test/ref/TypeFamilies.html +++ b/html-test/ref/TypeFamilies.html @@ -352,8 +352,10 @@ > #

                  External instance

                  #

                  Doc for: type instance Foo X = Y

                  #

                  Doc for: type instance Foo Y = X

                  #

                  Doc for: type instance Foo Y = X

                  #

                  Doc for: type instance Foo X = Y

                  #

                  Should be visible, but with a hidden right hand side

                  #

                  Should be visible, but with a hidden right hand side

                  #

                  External instance

                  Date: Fri, 20 Jul 2018 03:02:16 -0700 Subject: Fix broken instance source links (#869) The problem manifests itself in instances that are defined in modules other than the module where the class is defined. The fix is just to thread through the 'Module' of the instance further along. Since orphan instances appear to already have been working, I didn't do anything there. --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 8 +++--- haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 33 +++++++++++++----------- 2 files changed, 22 insertions(+), 19 deletions(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 1daf9ace..01380c94 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -572,9 +572,9 @@ ppInstances links origin instances splice unicode pkg qual -- 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 +587,9 @@ ppOrphanInstances links instances splice unicode pkg qual 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 diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs index 501caa4b..1c44ffda 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs @@ -40,7 +40,6 @@ module Haddock.Backends.Xhtml.Layout ( topDeclElem, declElem, ) where - import Haddock.Backends.Xhtml.DocMarkup import Haddock.Backends.Xhtml.Types import Haddock.Backends.Xhtml.Utils @@ -48,6 +47,7 @@ import Haddock.Types 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,20 +151,22 @@ subTable pkg qual decls = Just $ table << aboves (concatMap subRow decls) -- | 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 @@ -197,7 +199,7 @@ subEquations pkg qual = divSubDecls "equations" "Equations" . subTable pkg qual 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 @@ subInstances pkg qual nm lnks splice = maybe noHtml wrap . instTable 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 @@ declElem = paragraph ! [theclass "src"] -- 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 @@ links ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice docName@(Docume -- 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 -- cgit v1.2.3 From 1868443b01232d57ec11dfc831ac0a6915a2b337 Mon Sep 17 00:00:00 2001 From: Yuji Yamamoto Date: Mon, 23 Jul 2018 15:16:01 +0900 Subject: Avoid "invalid argument (invalid character)" on non-unicode Windows (#892) Steps to reproduce and the error message ==== ``` > stack haddock basement ... snip ... Warning: 'A' is out of scope. Warning: 'haddock: internal error: : commitBuffer: invalid argument (invalid character) ``` Environment ==== OS: Windows 10 ver. 1709 haddock: [HEAD of ghc-8.4 when I reproduce the error](https://github.com/haskell/haddock/commit/532b209d127e4cecdbf7e9e3dcf4f653a5605b5a). (I had to use this version to avoid another probrem already fixed in HEAD) GHC: 8.4.3 stack: Version 1.7.1, Git revision 681c800873816c022739ca7ed14755e85a579565 (5807 commits) x86_64 hpack-0.28.2 Related pull request ==== https://github.com/haskell/haddock/pull/566 --- haddock-api/src/Haddock/Interface.hs | 1 + 1 file changed, 1 insertion(+) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index a66745ea..7c7f0e75 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -81,6 +81,7 @@ processModules processModules verbosity modules flags extIfaces = do #if defined(mingw32_HOST_OS) -- Avoid internal error: : hPutChar: invalid argument (invalid character)' non UTF-8 Windows + liftIO $ hSetEncoding stdout $ mkLocaleEncoding TransliterateCodingFailure liftIO $ hSetEncoding stderr $ mkLocaleEncoding TransliterateCodingFailure #endif -- cgit v1.2.3