From 3efdc3a8da642d5d76b2c3f10a22f0503f65456a Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Mon, 11 Feb 2019 12:27:41 -0500 Subject: Remove workaround for now-fixed Clang CPP bug (#1028) Before LLVM 6.0.1 (or 10.0 on Apple LLVM), there was a bug where lines that started with an octothorpe but turned out not to lex like pragmas would have an extra line added after them. Since this bug has been fixed upstream and that it doesn't have dire consequences anyways, the workaround is not really worth it anymore - we can just tell people to update their clang version (or re-structure their pragma code). --- .../src/Haddock/Backends/Hyperlinker/Parser.hs | 47 +--------------------- 1 file changed, 2 insertions(+), 45 deletions(-) (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 1d5576cc..0bd467e1 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -6,13 +6,9 @@ import Control.Applicative ( Alternative(..) ) import Data.List ( isPrefixOf, isSuffixOf ) import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BSC - -import GHC.LanguageExtensions.Type import BasicTypes ( IntegralLit(..) ) import DynFlags -import qualified EnumSet as E import ErrUtils ( emptyMessages ) import FastString ( mkFastString ) import Lexer ( P(..), ParseResult(..), PState(..), Token(..) @@ -29,12 +25,11 @@ import Haddock.GhcUtils -- Result should retain original file layout (including comments, -- whitespace, and CPP). parse - :: CompilerInfo -- ^ Underlying CC compiler (whatever expanded CPP) - -> DynFlags -- ^ Flags for this module + :: DynFlags -- ^ Flags for this module -> FilePath -- ^ Path to the source of this module -> BS.ByteString -- ^ Raw UTF-8 encoded source of this module -> [T.Token] -parse comp dflags fpath bs = case unP (go False []) initState of +parse dflags fpath bs = case unP (go False []) initState of POk _ toks -> reverse toks PFailed _ ss errMsg -> panic $ "Hyperlinker parse error at " ++ show ss ++ ": " ++ showSDoc dflags errMsg @@ -43,7 +38,6 @@ parse comp dflags fpath bs = case unP (go False []) initState of initState = mkPStatePure pflags buf start buf = stringBufferFromByteString bs start = mkRealSrcLoc (mkFastString fpath) 1 1 - needPragHack' = needPragHack comp dflags pflags = mkParserFlags' (warningFlags dflags) (extensionFlags dflags) (thisPackage dflags) @@ -125,12 +119,6 @@ parse comp dflags fpath bs = case unP (go False []) initState of pure (bEnd'', False) - -- See 'needPragHack' - ITclose_prag{} - | needPragHack' - , '\n' `BSC.elem` spaceBStr - -> getInput >>= \(b,p) -> setInput (b,advanceSrcLoc p '\n') >> pure (bEnd, False) - _ -> pure (bEnd, inPragDef) let tokBStr = splitStringBuffer bStart bEnd' @@ -155,37 +143,6 @@ parse comp dflags fpath bs = case unP (go False []) initState of pure ([unkTok], False) --- | This is really, really, /really/ gross. Problem: consider a Haskell --- file that looks like: --- --- @ --- {-# LANGUAGE CPP #-} --- module SomeMod where --- --- #define SIX 6 --- --- {-# INLINE foo --- #-} --- foo = 1 --- @ --- --- Clang's CPP replaces the @#define SIX 6@ line with an empty line (as it --- should), but get confused about @#-}@. I'm guessing it /starts/ by --- parsing that as a pre-processor directive and, when it fails to, it just --- leaves the line alone. HOWEVER, it still adds an extra newline. =.= --- --- This function makes sure that the Hyperlinker backend also adds that --- extra newline (or else our spans won't line up with GHC's anymore). -needPragHack :: CompilerInfo -> DynFlags -> Bool -needPragHack comp dflags = isCcClang && E.member Cpp (extensionFlags dflags) - where - isCcClang = case comp of - GCC -> False - Clang -> True - AppleClang -> True - AppleClang51 -> True - UnknownCC -> False - -- | Get the input getInput :: P (StringBuffer, RealSrcLoc) getInput = P $ \p @ PState { buffer = buf, loc = srcLoc } -> POk p (buf, srcLoc) -- cgit v1.2.3 From 5459ca8a76825da59ff4c1c11d74812d1931da50 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Mon, 7 Oct 2019 15:11:22 -0400 Subject: Prefer un-hyperlinked sources to no sources It is possible to fail to extract an HIE ast. This is however not a reason to produce _no_ output - we should still make a colorized HTML page. --- haddock-api/src/Haddock/Backends/Hyperlinker.hs | 38 ++++++++++++++-------- .../src/Haddock/Backends/Hyperlinker/Utils.hs | 2 +- 2 files changed, 26 insertions(+), 14 deletions(-) (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs index 3acd91be..2e665204 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -18,12 +18,13 @@ import Data.Maybe import System.Directory import System.FilePath -import HieTypes ( HieFile(..), HieASTs(..) ) +import HieTypes ( HieFile(..), HieASTs(..), HieAST(..), NodeInfo(..) ) import HieBin ( readHieFile, hie_file_result) import Data.Map as M import FastString ( mkFastString ) import Module ( Module, moduleName ) import NameCache ( initNameCache ) +import SrcLoc ( mkRealSrcLoc, realSrcLocSpan ) import UniqSupply ( mkSplitUniqSupply ) @@ -65,27 +66,38 @@ ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = case ifaceHieFile <$> (readHieFile (initNameCache u []) hfp) -- Get the AST and tokens corresponding to the source file we want - let mast | M.size asts == 1 = snd <$> M.lookupMin asts - | otherwise = M.lookup (mkFastString file) asts + let fileFs = mkFastString file + mast | M.size asts == 1 = snd <$> M.lookupMin asts + | otherwise = M.lookup fileFs asts + ast = fromMaybe (emptyHieAst fileFs) mast + fullAst = recoverFullIfaceTypes df types ast tokens = parse df file rawSrc + -- Warn if we didn't find an AST, but there were still ASTs + if M.null asts + then pure () + else out verbosity verbose $ unwords [ "couldn't find ast for" + , file, show (M.keys asts) ] + -- Produce and write out the hyperlinked sources - case mast of - Just ast -> - let fullAst = recoverFullIfaceTypes df types ast - in writeUtf8File path . renderToString pretty . render' fullAst $ tokens - Nothing - | M.size asts == 0 -> return () - | otherwise -> do - out verbosity verbose $ unwords [ "couldn't find ast for" - , file, show (M.keys asts) ] - return () + writeUtf8File path . renderToString pretty . render' fullAst $ tokens Nothing -> return () where df = ifaceDynFlags iface render' = render (Just srcCssFile) (Just highlightScript) srcs path = srcdir hypSrcModuleFile (ifaceMod iface) + emptyNodeInfo = NodeInfo + { nodeAnnotations = mempty + , nodeType = [] + , nodeIdentifiers = mempty + } + emptyHieAst fileFs = Node + { nodeInfo = emptyNodeInfo + , nodeSpan = realSrcLocSpan (mkRealSrcLoc fileFs 1 0) + , nodeChildren = [] + } + -- | Name of CSS file in output directory. srcCssFile :: FilePath srcCssFile = "style.css" diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs index 4e8b88d2..2c48e00b 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs @@ -102,7 +102,7 @@ type PrintedType = String -- > hieAst -- -- However, this is very inefficient (both in time and space) because the --- mutliple calls to 'recoverFullType' don't share intermediate results. This +-- multiple calls to 'recoverFullType' don't share intermediate results. This -- function fixes that. recoverFullIfaceTypes :: DynFlags -- cgit v1.2.3 From 20098c8951743244bb71b41f470a7546ec31d0f2 Mon Sep 17 00:00:00 2001 From: Vladislav Zavialov Date: Sat, 26 Sep 2020 20:59:49 +0300 Subject: Updates for the new linear types syntax: a %p -> b --- haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 1 + 1 file changed, 1 insertion(+) (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 5fd040a8..72aab285 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -274,6 +274,7 @@ classify tok = ITdot -> TkOperator ITstar {} -> TkOperator ITtypeApp -> TkGlyph + ITpercent -> TkGlyph ITbiglam -> TkGlyph -- cgit v1.2.3 From 96a60e218b35df611ee56c4bdd8408ec4375e6ca Mon Sep 17 00:00:00 2001 From: tomjaguarpaw Date: Tue, 8 Dec 2020 17:00:04 +0000 Subject: Enable two warnings (#1245) because they will be soon be added to -Wall. See https://gitlab.haskell.org/ghc/ghc/-/issues/15656 --- haddock-api/haddock-api.cabal | 2 ++ haddock-api/src/Haddock/Backends/Hoogle.hs | 1 + haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 1 + haddock-api/src/Haddock/GhcUtils.hs | 1 + haddock-api/src/Haddock/Interface/AttachInstances.hs | 2 ++ haddock-api/src/Haddock/Interface/Rename.hs | 1 + haddock-api/src/Haddock/Interface/Specialize.hs | 1 + haddock.cabal | 2 +- 8 files changed, 10 insertions(+), 1 deletion(-) (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker') diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 4abfd984..5fa51905 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -70,6 +70,8 @@ library -Wredundant-constraints -Wnoncanonical-monad-instances -Wmissing-home-modules + -Wincomplete-uni-patterns + -Wincomplete-record-updates exposed-modules: diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 63acb465..4961edc2 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Backends.Hoogle diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 0247d567..0974d6da 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module Haddock.Backends.Hyperlinker.Parser (parse) where import Control.Applicative ( Alternative(..) ) diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 923516b6..0874e7b4 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -2,6 +2,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- -- | diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index 685dca01..ce987b76 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -1,5 +1,7 @@ {-# LANGUAGE MagicHash, BangPatterns #-} {-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.AttachInstances diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index b4ff31e5..78c58581 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -1,5 +1,6 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} ---------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.Rename diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index 492818bd..6e11a859 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -3,6 +3,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} module Haddock.Interface.Specialize ( specializeInstHead diff --git a/haddock.cabal b/haddock.cabal index 1d6ad180..0bf99950 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -62,7 +62,7 @@ executable haddock default-language: Haskell2010 main-is: Main.hs hs-source-dirs: driver - ghc-options: -funbox-strict-fields -Wall -O2 -threaded + ghc-options: -funbox-strict-fields -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -O2 -threaded -- haddock typically only supports a single GHC major version build-depends: -- cgit v1.2.3 From 8dcc6d652c434b6ed9aea7a6019447aa72e7ba28 Mon Sep 17 00:00:00 2001 From: Matthías Páll Gissurarson Date: Fri, 19 Jun 2020 17:47:48 +0200 Subject: Adapt Haddock for QualifiedDo --- haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 0974d6da..285b0ee7 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -176,7 +176,7 @@ classify tok = ITdata -> TkKeyword ITdefault -> TkKeyword ITderiving -> TkKeyword - ITdo -> TkKeyword + ITdo {} -> TkKeyword ITelse -> TkKeyword IThiding -> TkKeyword ITforeign -> TkKeyword @@ -209,7 +209,7 @@ classify tok = ITcapiconv -> TkKeyword ITprimcallconv -> TkKeyword ITjavascriptcallconv -> TkKeyword - ITmdo -> TkKeyword + ITmdo {} -> TkKeyword ITfamily -> TkKeyword ITrole -> TkKeyword ITgroup -> TkKeyword -- cgit v1.2.3