haddock-api 2.23.1 → 2.24.0
raw patch · 25 files changed
+625/−612 lines, 25 filesdep ~basedep ~ghcdep ~haddock-library
Dependency ranges changed: base, ghc, haddock-library
Files
- LICENSE +21/−18
- haddock-api.cabal +8/−7
- src/Haddock.hs +77/−83
- src/Haddock/Backends/HaddockDB.hs +10/−5
- src/Haddock/Backends/Hoogle.hs +16/−26
- src/Haddock/Backends/Hyperlinker.hs +1/−1
- src/Haddock/Backends/Hyperlinker/Parser.hs +10/−7
- src/Haddock/Backends/Hyperlinker/Renderer.hs +2/−2
- src/Haddock/Backends/Hyperlinker/Utils.hs +2/−2
- src/Haddock/Backends/LaTeX.hs +31/−27
- src/Haddock/Backends/Xhtml/Decl.hs +51/−52
- src/Haddock/Backends/Xhtml/DocMarkup.hs +2/−2
- src/Haddock/Convert.hs +91/−89
- src/Haddock/GhcUtils.hs +68/−46
- src/Haddock/Interface.hs +5/−5
- src/Haddock/Interface/AttachInstances.hs +4/−4
- src/Haddock/Interface/Create.hs +53/−41
- src/Haddock/Interface/LexParseRn.hs +1/−1
- src/Haddock/Interface/Rename.hs +76/−88
- src/Haddock/Interface/Specialize.hs +7/−7
- src/Haddock/InterfaceFile.hs +3/−3
- src/Haddock/Types.hs +76/−83
- src/Haddock/Utils.hs +8/−11
- src/Haddock/Utils/Json.hs +1/−1
- test/Haddock/Backends/Hyperlinker/ParserSpec.hs +1/−1
LICENSE view
@@ -1,23 +1,26 @@-Copyright 2002-2010, Simon Marlow. All rights reserved.+Copyright (c) 2002-2010, Simon Marlow+All rights reserved. Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:+modification, are permitted provided that the following conditions are+met: -- Redistributions of source code must retain the above copyright notice,-this list of conditions and the following disclaimer.+1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer. -- Redistributions in binary form must reproduce the above copyright notice,-this list of conditions and the following disclaimer in the documentation-and/or other materials provided with the distribution.+2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the+ distribution. -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY-EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE-IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR-PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE-LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR-CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF-SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR-BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,-WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE-OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN-IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
haddock-api.cabal view
@@ -1,10 +1,10 @@ cabal-version: 2.0 name: haddock-api-version: 2.23.1+version: 2.24.0 synopsis: A documentation-generation tool for Haskell libraries description: Haddock is a documentation-generation tool for Haskell libraries-license: BSD3+license: BSD2 license-file: LICENSE author: Simon Marlow, David Waern maintainer: Alec Theriault <alec.theriault@gmail.com>, Alex Biehl <alexbiehl@gmail.com>, Simon Hengel <sol@typeful.net>, Mateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk>@@ -13,6 +13,7 @@ copyright: (c) Simon Marlow, David Waern category: Documentation build-type: Simple+tested-with: GHC==8.10.* extra-source-files: CHANGES.md@@ -42,10 +43,10 @@ default-language: Haskell2010 -- this package typically supports only single major versions- build-depends: base ^>= 4.13.0- , ghc ^>= 8.8 && >= 8.8.2+ build-depends: base ^>= 4.14.0+ , ghc ^>= 8.10 , ghc-paths ^>= 0.1.0.9- , haddock-library ^>= 1.8.0+ , haddock-library ^>= 1.9.0 , xhtml ^>= 3000.2.2 -- Versions for the dependencies below are transitively pinned by@@ -165,9 +166,9 @@ Haddock.Backends.Hyperlinker.Parser Haddock.Backends.Hyperlinker.Types - build-depends: ghc ^>= 8.8 && >= 8.8.2+ build-depends: ghc ^>= 8.10 , ghc-paths ^>= 0.1.0.12- , haddock-library ^>= 1.8.0+ , haddock-library ^>= 1.9.0 , xhtml ^>= 3000.2.2 , hspec >= 2.4.4 && < 2.8 , QuickCheck >= 2.11 && < 2.14
src/Haddock.hs view
@@ -55,20 +55,14 @@ import System.IO import System.Exit -#if defined(mingw32_HOST_OS)-import Foreign-import Foreign.C-import Data.Int-#endif- #ifdef IN_GHC_TREE import System.FilePath+import System.Environment (getExecutablePath) #else import qualified GHC.Paths as GhcPaths import Paths_haddock_api (getDataDir)-import System.Directory (doesDirectoryExist) #endif-import System.Directory (getTemporaryDirectory)+import System.Directory (doesDirectoryExist, getTemporaryDirectory) import System.FilePath ((</>)) import Text.ParserCombinators.ReadP (readP_to_S)@@ -237,7 +231,7 @@ withGhc :: [Flag] -> Ghc a -> IO a withGhc flags action = do- libDir <- fmap snd (getGhcDirs flags)+ libDir <- fmap (fromMaybe (error "No GhcDir found") . snd) (getGhcDirs flags) -- Catches all GHC source errors, then prints and re-throws them. let handleSrcErrors action' = flip handleSourceError action' $ \err -> do@@ -368,7 +362,7 @@ let withQuickjump = Flag_QuickJumpIndex `elem` flags when (Flag_GenIndex `elem` flags) $ do- withTiming (pure dflags') "ppHtmlIndex" (const ()) $ do+ withTiming dflags' "ppHtmlIndex" (const ()) $ do _ <- {-# SCC ppHtmlIndex #-} ppHtmlIndex odir title pkgStr themes opt_mathjax opt_contents_url sourceUrls' opt_wiki_urls@@ -378,7 +372,7 @@ copyHtmlBits odir libDir themes withQuickjump when (Flag_GenContents `elem` flags) $ do- withTiming (pure dflags') "ppHtmlContents" (const ()) $ do+ withTiming dflags' "ppHtmlContents" (const ()) $ do _ <- {-# SCC ppHtmlContents #-} ppHtmlContents dflags' odir title pkgStr themes opt_mathjax opt_index_url sourceUrls' opt_wiki_urls@@ -388,7 +382,7 @@ copyHtmlBits odir libDir themes withQuickjump when (Flag_Html `elem` flags) $ do- withTiming (pure dflags') "ppHtml" (const ()) $ do+ withTiming dflags' "ppHtml" (const ()) $ do _ <- {-# SCC ppHtml #-} ppHtml dflags' title pkgStr visibleIfaces reexportedIfaces odir prologue@@ -423,14 +417,14 @@ ] when (Flag_LaTeX `elem` flags) $ do- withTiming (pure dflags') "ppLatex" (const ()) $ do+ withTiming dflags' "ppLatex" (const ()) $ do _ <- {-# SCC ppLatex #-} ppLaTeX title pkgStr visibleIfaces odir (fmap _doc prologue) opt_latex_style libDir return () when (Flag_HyperlinkedSource `elem` flags && not (null ifaces)) $ do- withTiming (pure dflags') "ppHyperlinkedSource" (const ()) $ do+ withTiming dflags' "ppHyperlinkedSource" (const ()) $ do _ <- {-# SCC ppHyperlinkedSource #-} ppHyperlinkedSource (verbosity flags) odir libDir opt_source_css pretty srcMap ifaces return ()@@ -474,8 +468,7 @@ -- We disable pattern match warnings because than can be very -- expensive to check let dynflags'' = unsetPatternMatchWarnings $- updOptLevel 0 $- gopt_unset dynflags' Opt_SplitObjs+ updOptLevel 0 dynflags' -- ignore the following return-value, which is a list of packages -- that may need to be re-linked: Haddock doesn't do any -- dynamic or static linking at all!@@ -528,52 +521,88 @@ ------------------------------------------------------------------------------- -getHaddockLibDir :: [Flag] -> IO String+getHaddockLibDir :: [Flag] -> IO FilePath getHaddockLibDir flags = case [str | Flag_Lib str <- flags] of [] -> do #ifdef IN_GHC_TREE- getInTreeDir++ -- When in the GHC tree, we should be able to locate the "lib" folder+ -- based on the location of the current executable.+ base_dir <- getBaseDir -- Provided by GHC+ let res_dirs = [ d | Just d <- [base_dir] ] +++ #else- -- if data directory does not exist we are probably- -- invoking from either ./haddock-api or ./- let res_dirs = [ getDataDir -- provided by Cabal- , pure "resources"- , pure "haddock-api/resources"- ] - check get_path = do- p <- get_path- exists <- doesDirectoryExist p- pure $ if exists then Just p else Nothing+ -- When Haddock was installed by @cabal@, the resources (which are listed+ -- under @data-files@ in the Cabal file) will have been copied to a+ -- special directory.+ data_dir <- getDataDir -- Provided by Cabal+ let res_dirs = [ data_dir ] ++ - dirs <- mapM check res_dirs- case [p | Just p <- dirs] of- (p : _) -> return p- _ -> die "Haddock's resource directory does not exist!\n" #endif- fs -> return (last fs) + -- When Haddock is built locally (eg. regular @cabal new-build@), the data+ -- directory does not exist and we are probably invoking from either+ -- @./haddock-api@ or @./@+ [ "resources"+ , "haddock-api/resources"+ ] -getGhcDirs :: [Flag] -> IO (String, String)+ res_dir <- check res_dirs+ case res_dir of+ Just p -> return p+ _ -> die "Haddock's resource directory does not exist!\n"++ fs -> return (last fs)+ where+ -- Pick the first path that corresponds to a directory that exists+ check :: [FilePath] -> IO (Maybe FilePath)+ check [] = pure Nothing+ check (path : other_paths) = do+ exists <- doesDirectoryExist path+ if exists then pure (Just path) else check other_paths++-- | Find the @lib@ directory for GHC and the path to @ghc@+getGhcDirs :: [Flag] -> IO (Maybe FilePath, Maybe FilePath) getGhcDirs flags = do- case [ dir | Flag_GhcLibDir dir <- flags ] of- [] -> do+ #ifdef IN_GHC_TREE- libDir <- getInTreeDir- return (ghcPath, libDir)+ base_dir <- getBaseDir+ let ghc_path = Nothing #else- return (ghcPath, GhcPaths.libdir)+ let base_dir = Just GhcPaths.libdir+ ghc_path = Just GhcPaths.ghc #endif- xs -> return (ghcPath, last xs)- where++ -- If the user explicitly specifies a lib dir, use that+ let ghc_dir = case [ dir | Flag_GhcLibDir dir <- flags ] of+ [] -> base_dir+ xs -> Just (last xs)++ pure (ghc_path, ghc_dir)++ #ifdef IN_GHC_TREE- ghcPath = "not available"-#else- ghcPath = GhcPaths.ghc-#endif +-- | See 'getBaseDir' in "SysTools.BaseDir"+getBaseDir :: IO (Maybe FilePath)+getBaseDir = do + -- Getting executable path can fail. Turn that into 'Nothing'+ exec_path_opt <- catch (Just <$> getExecutablePath)+ (\(_ :: SomeException) -> pure Nothing)++ -- Check that the path we are about to return actually exists+ case exec_path_opt of+ Nothing -> pure Nothing+ Just exec_path -> do+ let base_dir = takeDirectory (takeDirectory exec_path) </> "lib"+ exists <- doesDirectoryExist base_dir+ pure (if exists then Just base_dir else Nothing)++#endif+ shortcutFlags :: [Flag] -> IO () shortcutFlags flags = do usage <- getUsage@@ -586,12 +615,12 @@ when (Flag_GhcVersion `elem` flags) (bye (cProjectVersion ++ "\n")) when (Flag_PrintGhcPath `elem` flags) $ do- dir <- fmap fst (getGhcDirs flags)- bye $ dir ++ "\n"+ path <- fmap fst (getGhcDirs flags)+ bye $ fromMaybe "not available" path ++ "\n" when (Flag_PrintGhcLibDir `elem` flags) $ do dir <- fmap snd (getGhcDirs flags)- bye $ dir ++ "\n"+ bye $ fromMaybe "not available" dir ++ "\n" when (Flag_UseUnicode `elem` flags && Flag_Html `notElem` flags) $ throwE "Unicode can only be enabled for HTML output."@@ -668,38 +697,3 @@ rightOrThrowE (Left msg) = throwE msg rightOrThrowE (Right x) = pure x --#ifdef IN_GHC_TREE--getInTreeDir :: IO String-getInTreeDir = getExecDir >>= \case- Nothing -> error "No GhcDir found"- Just d -> return (d </> ".." </> "lib")---getExecDir :: IO (Maybe String)-#if defined(mingw32_HOST_OS)-getExecDir = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.- where- try_size size = allocaArray (fromIntegral size) $ \buf -> do- ret <- c_GetModuleFileName nullPtr buf size- case ret of- 0 -> return Nothing- _ | ret < size -> fmap (Just . dropFileName) $ peekCWString buf- | otherwise -> try_size (size * 2)--# if defined(i386_HOST_ARCH)-# define WINDOWS_CCONV stdcall-# elif defined(x86_64_HOST_ARCH)-# define WINDOWS_CCONV ccall-# else-# error Unknown mingw32 arch-# endif--foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW"- c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32-#else-getExecDir = return Nothing-#endif--#endif
src/Haddock/Backends/HaddockDB.hs view
@@ -104,16 +104,21 @@ hsep (map ppHsAType b)) context) ppHsType :: HsType -> Doc-ppHsType (HsForAllType Nothing context htype) =+ppHsType (HsForAllType _ Nothing context htype) = hsep [ ppHsContext context, text "=>", ppHsType htype]-ppHsType (HsForAllType (Just tvs) [] htype) =- hsep (text "forall" : map ppHsName tvs ++ text "." : [ppHsType htype])-ppHsType (HsForAllType (Just tvs) context htype) =- hsep (text "forall" : map ppHsName tvs ++ text "." :+ppHsType (HsForAllType fvf (Just tvs) [] htype) =+ hsep (text "forall" : map ppHsName tvs ++ pprHsForAllSeparator fvf :+ [ppHsType htype])+ppHsType (HsForAllType fvf (Just tvs) context htype) =+ hsep (text "forall" : map ppHsName tvs ++ pprHsForAllSeparator fvf : ppHsContext context : text "=>" : [ppHsType htype]) ppHsType (HsTyFun a b) = fsep [ppHsBType a, text "->", ppHsType b] ppHsType (HsTyIP n t) = fsep [(char '?' <> ppHsName n), text "::", ppHsType t] ppHsType t = ppHsBType t++ppHsForAllSeparator :: ForallVisFlag -> Doc+ppHsForAllSeparator ForallVis = text "->"+ppHsForAllSeparator ForallInvis = text "." ppHsBType (HsTyApp (HsTyCon (Qual (Module "Prelude") (HsTyClsName (HsSpecial "[]")))) b ) = brackets $ ppHsType b
src/Haddock/Backends/Hoogle.hs view
@@ -18,7 +18,7 @@ ) where import BasicTypes ( OverlapFlag(..), OverlapMode(..), SourceText(..)- , PromotionFlag(..) )+ , PromotionFlag(..), TopLevelFlag(..) ) import InstEnv (ClsInst(..)) import Documentation.Haddock.Markup import Haddock.GhcUtils@@ -27,10 +27,9 @@ import GHC import Outputable-import NameSet import Data.Char-import Data.List+import Data.List (isPrefixOf, intercalate) import Data.Maybe import Data.Version @@ -72,7 +71,7 @@ dropHsDocTy = f where g (L src x) = L src (f x)- f (HsForAllTy x a e) = HsForAllTy x a (g e)+ f (HsForAllTy x fvf a e) = HsForAllTy x fvf 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)@@ -86,8 +85,8 @@ f (HsDocTy _ a _) = f $ unL a f x = x -outHsType :: (a ~ GhcPass p, OutputableBndrId a)- => DynFlags -> HsType a -> String+outHsType :: (OutputableBndrId p)+ => DynFlags -> HsType (GhcPass p) -> String outHsType dflags = out dflags . reparenType . dropHsDocTy @@ -174,7 +173,7 @@ | null $ tcdATs decl = "" | otherwise = (" " ++) . showSDocUnqual dflags . whereWrapper $ concat [ map pprTyFam (tcdATs decl)- , map (ppr . tyFamEqnToSyn . unLoc) (tcdATDefs decl)+ , map (pprTyFamInstDecl NotTopLevel . unLoc) (tcdATDefs decl) ] pprTyFam :: LFamilyDecl GhcRn -> SDoc@@ -187,15 +186,6 @@ , rbrace ] - tyFamEqnToSyn :: TyFamDefltEqn GhcRn -> TyClDecl GhcRn- tyFamEqnToSyn tfe = SynDecl- { tcdLName = feqn_tycon tfe- , tcdTyVars = feqn_pats tfe- , tcdFixity = feqn_fixity tfe- , tcdRhs = feqn_rhs tfe- , tcdSExt = emptyNameSet- }- ppFam :: DynFlags -> FamilyDecl GhcRn -> [String] ppFam dflags decl@(FamilyDecl { fdInfo = info }) = [out dflags decl']@@ -205,7 +195,7 @@ -- for Hoogle, so pretend it doesn't have any. ClosedTypeFamily{} -> decl { fdInfo = OpenTypeFamily } _ -> decl-ppFam _ XFamilyDecl {} = panic "ppFam"+ppFam _ (XFamilyDecl nec) = noExtCon nec ppInstance :: DynFlags -> ClsInst -> [String] ppInstance dflags x =@@ -254,8 +244,8 @@ [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 NoExt x y)- apps = foldl1 (\x y -> reL $ HsAppTy NoExt x y)+ funs = foldr1 (\x y -> reL $ HsFunTy noExtField x y)+ apps = foldl1 (\x y -> reL $ HsAppTy noExtField x y) typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds) @@ -263,14 +253,14 @@ -- docs for con_names on why it is a list to begin with. name = commaSeparate dflags . map unL $ getConNames con - resType = let c = HsTyVar NoExt NotPromoted (noLoc (tcdName dat))+ resType = let c = HsTyVar noExtField NotPromoted (reL (tcdName dat)) as = map (tyVarBndr2Type . unLoc) (hsQTvExplicit $ tyClDeclTyVars dat)- in apps (map noLoc (c : as))+ in apps (map reL (c : as)) tyVarBndr2Type :: HsTyVarBndr GhcRn -> HsType GhcRn- tyVarBndr2Type (UserTyVar _ n) = HsTyVar NoExt NotPromoted n- tyVarBndr2Type (KindedTyVar _ n k) = HsKindSig NoExt (noLoc (HsTyVar NoExt NotPromoted n)) k- tyVarBndr2Type (XTyVarBndr _) = panic "haddock:ppCtor"+ tyVarBndr2Type (UserTyVar _ n) = HsTyVar noExtField NotPromoted n+ tyVarBndr2Type (KindedTyVar _ n k) = HsKindSig noExtField (reL (HsTyVar noExtField NotPromoted n)) k+ tyVarBndr2Type (XTyVarBndr nec) = noExtCon nec ppCtor dflags _dat subdocs con@(ConDeclGADT { }) = concatMap (lookupCon dflags subdocs) (getConNames con) ++ f@@ -279,10 +269,10 @@ typeSig nm ty = operator nm ++ " :: " ++ outHsType dflags (unL ty) name = out dflags $ map unL $ getConNames con-ppCtor _ _ _ XConDecl {} = panic "haddock:ppCtor"+ppCtor _ _ _ (XConDecl nec) = noExtCon nec ppFixity :: DynFlags -> (Name, Fixity) -> [String]-ppFixity dflags (name, fixity) = [out dflags ((FixitySig noExt [noLoc name] fixity) :: FixitySig GhcRn)]+ppFixity dflags (name, fixity) = [out dflags ((FixitySig noExtField [noLoc name] fixity) :: FixitySig GhcRn)] ---------------------------------------------------------------------
src/Haddock/Backends/Hyperlinker.hs view
@@ -18,7 +18,7 @@ import System.Directory import System.FilePath -import HieTypes ( HieFile(..), HieASTs(..), HieAST(..), NodeInfo(..) )+import HieTypes ( HieFile(..), HieAST(..), HieASTs(..), NodeInfo(..) ) import HieBin ( readHieFile, hie_file_result) import Data.Map as M import FastString ( mkFastString )
src/Haddock/Backends/Hyperlinker/Parser.hs view
@@ -9,11 +9,12 @@ import BasicTypes ( IntegralLit(..) ) import DynFlags-import ErrUtils ( emptyMessages )+import ErrUtils ( pprLocErrMsg ) import FastString ( mkFastString ) import Lexer ( P(..), ParseResult(..), PState(..), Token(..)- , mkPStatePure, lexer, mkParserFlags' )-import Outputable ( showSDoc, panic )+ , mkPStatePure, lexer, mkParserFlags', getErrorMessages, addFatalError )+import Bag ( bagToList )+import Outputable ( showSDoc, panic, text, ($$) ) import SrcLoc import StringBuffer ( StringBuffer, atEnd ) @@ -31,8 +32,10 @@ -> [T.Token] 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+ PFailed pst ->+ let err:_ = bagToList (getErrorMessages pst dflags) in+ panic $ showSDoc dflags $+ text "Hyperlinker parse error:" $$ pprLocErrMsg err where initState = mkPStatePure pflags buf start@@ -145,7 +148,7 @@ -- | Get the input getInput :: P (StringBuffer, RealSrcLoc)-getInput = P $ \p @ PState { buffer = buf, loc = srcLoc } -> POk p (buf, srcLoc)+getInput = P $ \p@PState { buffer = buf, loc = srcLoc } -> POk p (buf, srcLoc) -- | Set the input setInput :: (StringBuffer, RealSrcLoc) -> P ()@@ -154,7 +157,7 @@ -- | Orphan instance that adds backtracking to 'P' instance Alternative P where- empty = P $ \_ -> PFailed (const emptyMessages) noSrcSpan "Alterative.empty"+ empty = addFatalError noSrcSpan (text "Alterative.empty") P x <|> P y = P $ \s -> case x s of { p@POk{} -> p ; _ -> y s }
src/Haddock/Backends/Hyperlinker/Renderer.hs view
@@ -88,14 +88,14 @@ -- order to make sure these get hyperlinked properly, we intercept these -- special sequences of tokens and merge them into just one identifier or -- operator token.- [BacktickTok s1, tok @ Token{ tkType = TkIdentifier }, BacktickTok s2]+ [BacktickTok s1, tok@Token{ tkType = TkIdentifier }, BacktickTok s2] | realSrcSpanStart s1 == realSrcSpanStart nodeSpan , realSrcSpanEnd s2 == realSrcSpanEnd nodeSpan -> richToken srcs nodeInfo (Token{ tkValue = "`" <> tkValue tok <> "`" , tkType = TkOperator , tkSpan = nodeSpan })- [OpenParenTok s1, tok @ Token{ tkType = TkOperator }, CloseParenTok s2]+ [OpenParenTok s1, tok@Token{ tkType = TkOperator }, CloseParenTok s2] | realSrcSpanStart s1 == realSrcSpanStart nodeSpan , realSrcSpanEnd s2 == realSrcSpanEnd nodeSpan -> richToken srcs nodeInfo
src/Haddock/Backends/Hyperlinker/Utils.hs view
@@ -129,8 +129,8 @@ go (HLitTy l) = IfaceLitTy l go (HForAllTy ((n,k),af) t) = let b = (getOccFS n, k) in IfaceForAllTy (Bndr (IfaceTvBndr b) af) t- go (HFunTy a b) = IfaceFunTy a b- go (HQualTy con b) = IfaceDFunTy con b+ go (HFunTy a b) = IfaceFunTy VisArg a b+ go (HQualTy con b) = IfaceFunTy InvisArg con b go (HCastTy a) = a go HCoercionTy = IfaceTyVar "<coercion type>" go (HTyConApp a xs) = IfaceTyConApp a (hieToIfaceArgs xs)
src/Haddock/Backends/LaTeX.hs view
@@ -38,7 +38,7 @@ import Data.Char import Control.Monad import Data.Maybe-import Data.List+import Data.List ( sort ) import Prelude hiding ((<>)) import Haddock.Doc (combineDocumentation)@@ -311,7 +311,7 @@ ppFor :: DocForDecl DocName -> ForeignDecl DocNameI -> Bool -> LaTeX ppFor doc (ForeignImport _ (L _ name) typ _) unicode =- ppFunSig Nothing doc [name] (hsSigType typ) unicode+ ppFunSig Nothing doc [name] (hsSigTypeI typ) unicode ppFor _ _ _ = error "ppFor error in Haddock.Backends.LaTeX" -- error "foreign declarations are currently not supported by --latex" @@ -355,8 +355,8 @@ , equals , ppType unicode (unLoc rhs) ]- ppFamDeclEqn (XHsImplicitBndrs _) = panic "haddock:ppFamDecl"- ppFamDeclEqn (HsIB { hsib_body = XFamEqn _}) = panic "haddock:ppFamDecl"+ ppFamDeclEqn (XHsImplicitBndrs nec) = noExtCon nec+ ppFamDeclEqn (HsIB { hsib_body = XFamEqn nec}) = noExtCon nec instancesBit = ppDocInstances unicode instances @@ -365,7 +365,7 @@ -> Bool -- ^ unicode -> Bool -- ^ is the family associated? -> LaTeX-ppFamHeader (XFamilyDecl _) _ _ = panic "haddock;ppFamHeader"+ppFamHeader (XFamilyDecl nec) _ _ = noExtCon nec ppFamHeader (FamilyDecl { fdLName = L _ name , fdTyVars = tvs , fdInfo = info@@ -388,7 +388,7 @@ NoSig _ -> empty KindSig _ kind -> dcolon unicode <+> ppLKind unicode kind TyVarSig _ (L _ bndr) -> equals <+> ppHsTyVarBndr unicode bndr- XFamilyResultSig _ -> panic "haddock:ppFamHeader"+ XFamilyResultSig nec -> noExtCon nec injAnn = case injectivity of Nothing -> empty@@ -449,7 +449,7 @@ -> Bool -- ^ unicode -> LaTeX ppLPatSig doc docnames ty unicode- = ppFunSig (Just (keyword "pattern")) doc docnames (hsSigType ty) unicode+ = ppFunSig (Just (keyword "pattern")) doc docnames (hsSigTypeI ty) unicode -- | Pretty-print a type, adding documentation to the whole type and its -- arguments as needed.@@ -485,9 +485,9 @@ arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs do_args :: Int -> LaTeX -> HsType DocNameI -> [(LaTeX, LaTeX)]- do_args _n leader (HsForAllTy _ tvs ltype)+ do_args _n leader (HsForAllTy _ fvf tvs ltype) = [ ( decltt leader- , decltt (ppForAllPart unicode tvs)+ , decltt (ppForAllPart unicode tvs fvf) <+> ppLType unicode ltype ) ] do_args n leader (HsQualTy _ lctxt ltype)@@ -530,7 +530,7 @@ tyvarNames :: LHsQTyVars DocNameI -> [Name]-tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit+tyvarNames = map (getName . hsLTyVarNameI) . hsQTvExplicit declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX@@ -621,7 +621,7 @@ atTable = text "\\haddockpremethods{}" <> emph (text "Associated Types") $$- vcat [ ppFamDecl True (fst doc) [] (FamDecl noExt decl) True+ vcat [ ppFamDecl True (fst doc) [] (FamDecl noExtField decl) True | L _ decl <- ats , let name = unL . fdLName $ decl doc = lookupAnySubdoc name subdocs@@ -630,7 +630,7 @@ methodTable = text "\\haddockpremethods{}" <> emph (text "Methods") $$- vcat [ ppFunSig leader doc names (hsSigType typ) unicode+ vcat [ ppFunSig leader doc names (hsSigTypeI typ) unicode | L _ (ClassOpSig _ is_def lnames typ) <- lsigs , let doc | is_def = noDocForDecl | otherwise = lookupAnySubdoc (head names) subdocs@@ -750,7 +750,7 @@ where ppForall | null tvs || not forall_ = empty- | otherwise = ppForAllPart unicode tvs+ | otherwise = ppForAllPart unicode tvs ForallInvis ppCtxt | null ctxt = empty@@ -769,9 +769,9 @@ where -- Find the name of a constructors in the decl (`getConName` always returns -- a non-empty list)- aConName = unLoc (head (getConNames con))+ aConName = unLoc (head (getConNamesI con)) - occ = map (nameOccName . getName . unLoc) $ getConNames con+ occ = map (nameOccName . getName . unLoc) $ getConNamesI con ppOcc = cat (punctuate comma (map ppBinder occ)) ppOccInfix = cat (punctuate comma (map ppBinderInfix occ))@@ -816,7 +816,7 @@ -- ++AZ++ make this prepend "{..}" when it is a record style GADT , ppLType unicode (getGADTConType con) ]- XConDecl{} -> panic "haddock:ppSideBySideConstr"+ XConDecl nec -> noExtCon nec fieldPart = case (con, getConArgs con) of -- Record style GADTs@@ -850,12 +850,12 @@ [ l <+> text "\\enspace" <+> r | (l,r) <- ppSubSigLike unicode (unLoc (getGADTConType con)) argDocs subdocs (dcolon unicode) ]- XConDecl{} -> panic "haddock:doConstrArgsWithDocs"+ XConDecl nec -> noExtCon nec -- 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+ mbDoc = case getConNamesI con of [] -> panic "empty con_names" (cn:_) -> lookup (unLoc cn) subdocs >>= fmap _doc . combineDocumentation . fst@@ -870,7 +870,7 @@ -- 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 (extFieldOcc $ unLoc $ head names) subdocs >>= fmap _doc . combineDocumentation . fst-ppSideBySideField _ _ (XConDeclField _) = panic "haddock:ppSideBySideField"+ppSideBySideField _ _ (XConDeclField nec) = noExtCon nec -- | Pretty-print a bundled pattern synonym@@ -890,7 +890,7 @@ | otherwise = hsep [ keyword "pattern" , ppOcc , dcolon unicode- , ppLType unicode (hsSigType typ)+ , ppLType unicode (hsSigTypeI typ) ] fieldPart@@ -900,7 +900,7 @@ | (l,r) <- ppSubSigLike unicode (unLoc patTy) argDocs [] (dcolon unicode) ] - patTy = hsSigType typ+ patTy = hsSigTypeI typ mDoc = fmap _doc $ combineDocumentation doc @@ -1037,7 +1037,7 @@ ppHsTyVarBndr _ (UserTyVar _ (L _ name)) = ppDocName name ppHsTyVarBndr unicode (KindedTyVar _ (L _ name) kind) = parens (ppDocName name <+> dcolon unicode <+> ppLKind unicode kind)-ppHsTyVarBndr _ (XTyVarBndr _) = panic "haddock:ppHsTyVarBndr"+ppHsTyVarBndr _ (XTyVarBndr nec) = noExtCon nec ppLKind :: Bool -> LHsKind DocNameI -> LaTeX ppLKind unicode y = ppKind unicode (unLoc y)@@ -1049,17 +1049,21 @@ -- Drop top-level for-all type variables in user style -- since they are implicit in Haskell -ppForAllPart :: Bool -> [LHsTyVarBndr DocNameI] -> LaTeX-ppForAllPart unicode tvs = hsep (forallSymbol unicode : ppTyVars unicode tvs) <> dot-+ppForAllPart :: Bool -> [LHsTyVarBndr DocNameI] -> ForallVisFlag -> LaTeX+ppForAllPart unicode tvs fvf = hsep (forallSymbol unicode : tvs') <> fv+ where+ tvs' = ppTyVars unicode tvs+ fv = case fvf of+ ForallVis -> text "\\ " <> arrow unicode+ ForallInvis -> dot ppr_mono_lty :: LHsType DocNameI -> Bool -> LaTeX ppr_mono_lty ty unicode = ppr_mono_ty (unLoc ty) unicode ppr_mono_ty :: HsType DocNameI -> Bool -> LaTeX-ppr_mono_ty (HsForAllTy _ tvs ty) unicode- = sep [ ppForAllPart unicode tvs+ppr_mono_ty (HsForAllTy _ fvf tvs ty) unicode+ = sep [ ppForAllPart unicode tvs fvf , ppr_mono_lty ty unicode ] ppr_mono_ty (HsQualTy _ ctxt ty) unicode = sep [ ppLContext ctxt unicode
src/Haddock/Backends/Xhtml/Decl.hs view
@@ -36,12 +36,10 @@ import BasicTypes (PromotionFlag(..), isPromoted) import GHC hiding (LexicalFixity(..))-import qualified GHC import GHC.Exts import Name import BooleanFormula import RdrName ( rdrNameOcc )-import Outputable ( panic ) -- | Pretty print a declaration ppDecl :: Bool -- ^ print summary info only@@ -65,7 +63,7 @@ SigD _ (TypeSig _ lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames (hsSigWcType lty) fixities splice unicode pkg qual SigD _ (PatSynSig _ lnames lty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames- (hsSigType lty) fixities splice unicode pkg qual+ (hsSigTypeI lty) fixities splice unicode pkg qual ForD _ d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode pkg qual InstD _ _ -> noHtml DerivD _ _ -> noHtml@@ -152,8 +150,8 @@ 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_largs n (leader <+> ppForAllPart unicode qual tvs) ltype+ do_args n leader (HsForAllTy _ fvf tvs ltype)+ = do_largs n (leader <+> ppForAllPart unicode qual tvs fvf) ltype do_args n leader (HsQualTy _ lctxt ltype) | null (unLoc lctxt)@@ -219,7 +217,7 @@ -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppFor summary links loc doc (ForeignImport _ (L _ name) typ _) fixities splice unicode pkg qual- = ppFunSig summary links loc noHtml doc [name] (hsSigType typ) fixities splice unicode pkg qual+ = ppFunSig summary links loc noHtml doc [name] (hsSigTypeI typ) fixities splice unicode pkg qual ppFor _ _ _ _ _ _ _ _ _ _ = error "ppFor" @@ -306,8 +304,8 @@ , Nothing , [] )- ppFamDeclEqn (XHsImplicitBndrs _) = panic "haddock:ppFamDecl"- ppFamDeclEqn (HsIB { hsib_body = XFamEqn _}) = panic "haddock:ppFamDecl"+ ppFamDeclEqn (XHsImplicitBndrs nec) = noExtCon nec+ ppFamDeclEqn (HsIB { hsib_body = XFamEqn nec}) = noExtCon nec -- | Print a pseudo family declaration@@ -332,7 +330,7 @@ -> Bool -- ^ is an associated type -> FamilyDecl DocNameI -- ^ family declaration -> Unicode -> Qualification -> Html-ppFamHeader _ _ (XFamilyDecl _) _ _ = panic "haddock;ppFamHeader"+ppFamHeader _ _ (XFamilyDecl nec) _ _ = noExtCon nec ppFamHeader summary associated (FamilyDecl { fdInfo = info , fdResultSig = L _ result , fdInjectivityAnn = injectivity@@ -372,7 +370,7 @@ NoSig _ -> noHtml KindSig _ kind -> dcolon unicode <+> ppLKind unicode qual kind TyVarSig _ (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr- XFamilyResultSig _ -> panic "haddock:ppResultSig"+ XFamilyResultSig nec -> noExtCon nec --------------------------------------------------------------------------------@@ -497,7 +495,7 @@ -- ToDo: add associated type defaults - [ ppFunSig summary links loc noHtml doc names (hsSigType typ)+ [ ppFunSig summary links loc noHtml doc names (hsSigTypeI typ) [] splice unicode pkg qual | L _ (ClassOpSig _ False lnames typ) <- sigs , let doc = lookupAnySubdoc (head names) subdocs@@ -548,31 +546,26 @@ , let name = unL . fdLName $ unL at doc = lookupAnySubdoc name subdocs subfixs = filter ((== name) . fst) fixities- defTys = ppDefaultAssocTy name <$> lookupDAT name+ defTys = (declElem . ppDefaultAssocTy name) <$> lookupDAT name ] -- Default associated types- ppDefaultAssocTy n (vs,t,d') = ppTySyn summary links [] loc d' synDecl- splice unicode pkg qual- where- synDecl = SynDecl { tcdSExt = noExt- , tcdLName = noLoc n- , tcdTyVars = vs- , tcdFixity = GHC.Prefix- , tcdRhs = t }+ ppDefaultAssocTy n (vs,rhs) = hsep+ [ keyword "type", ppAppNameTypeArgs n vs unicode qual, equals+ , ppType unicode qual HideEmptyContexts (unLoc rhs)+ ] lookupDAT name = Map.lookup (getName name) defaultAssocTys defaultAssocTys = Map.fromList- [ (getName name, (vs, typ, doc))- | L _ (FamEqn { feqn_rhs = typ- , feqn_tycon = L _ name- , feqn_pats = vs }) <- atsDefs- , let doc = noDocForDecl -- TODO: get docs for associated type defaults+ [ (getName name, (vs, typ))+ | L _ (TyFamInstDecl (HsIB _ (FamEqn { feqn_rhs = typ+ , feqn_tycon = L _ name+ , feqn_pats = vs }))) <- atsDefs ] -- Methods methodBit = subMethods- [ ppFunSig summary links loc noHtml doc [name] (hsSigType typ)+ [ ppFunSig summary links loc noHtml doc [name] (hsSigTypeI typ) subfixs splice unicode pkg qual <+> subDefaults (maybeToList defSigs)@@ -587,7 +580,7 @@ -- Default methods ppDefaultFunSig n (t, d') = ppFunSig summary links loc (keyword "default")- d' [n] (hsSigType t) [] splice unicode pkg qual+ d' [n] (hsSigTypeI t) [] splice unicode pkg qual lookupDM name = Map.lookup (getOccString name) defaultMethods defaultMethods = Map.fromList@@ -777,7 +770,7 @@ pats1 = [ hsep [ keyword "pattern" , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames , dcolon unicode- , ppPatSigType unicode qual (hsSigType typ)+ , ppPatSigType unicode qual (hsSigTypeI typ) ] | (SigD _ (PatSynSig _ lnames typ),_) <- pats ]@@ -823,7 +816,7 @@ [ 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 (getConNamesI (unLoc c)))) fixities ] patternBit = subPatterns pkg qual@@ -888,10 +881,10 @@ , noHtml , noHtml )- XConDecl {} -> panic "haddock:ppShortConstrParts"+ XConDecl nec -> noExtCon nec where- occ = map (nameOccName . getName . unLoc) $ getConNames con+ occ = map (nameOccName . getName . unLoc) $ getConNamesI con ppOcc = hsep (punctuate comma (map (ppBinder summary) occ)) ppOccInfix = hsep (punctuate comma (map (ppBinderInfix summary) occ)) @@ -908,10 +901,10 @@ ) where -- Find the name of a constructors in the decl (`getConName` always returns a non-empty list)- aConName = unLoc (head (getConNames con))+ aConName = unLoc (head (getConNamesI con)) fixity = ppFixities fixities qual- occ = map (nameOccName . getName . unLoc) $ getConNames con+ occ = map (nameOccName . getName . unLoc) $ getConNamesI con ppOcc = hsep (punctuate comma (map (ppBinder False) occ)) ppOccInfix = hsep (punctuate comma (map (ppBinderInfix False) occ))@@ -957,7 +950,7 @@ , ppLType unicode qual HideEmptyContexts (getGADTConType con) , fixity ]- XConDecl{} -> panic "haddock:ppSideBySideConstr"+ XConDecl nec -> noExtCon nec fieldPart = case (con, getConArgs con) of -- Record style GADTs@@ -986,11 +979,11 @@ ConDeclGADT{} -> ppSubSigLike unicode qual (unLoc (getGADTConType con)) argDocs subdocs (dcolon unicode) HideEmptyContexts- XConDecl{} -> panic "haddock:doConstrArgsWithDocs"+ XConDecl nec -> noExtCon nec -- 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 >>=+ mbDoc = lookup (unLoc $ head $ getConNamesI con) subdocs >>= combineDocumentation . fst @@ -1005,7 +998,7 @@ where ppForall | null tvs || not forall_ = noHtml- | otherwise = ppForAllPart unicode qual tvs+ | otherwise = ppForAllPart unicode qual tvs ForallInvis ppCtxt | null ctxt = noHtml@@ -1030,14 +1023,14 @@ -- 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 (extFieldOcc $ unLoc $ head names) subdocs >>= combineDocumentation . fst-ppSideBySideField _ _ _ (XConDeclField _) = panic "haddock:ppSideBySideField"+ppSideBySideField _ _ _ (XConDeclField nec) = noExtCon nec ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocNameI -> Html 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"+ppShortField _ _ _ (XConDeclField nec) = noExtCon nec -- | Pretty print an expanded pattern (for bundled patterns)@@ -1060,7 +1053,7 @@ | otherwise = hsep [ keyword "pattern" , ppOcc , dcolon unicode- , ppPatSigType unicode qual (hsSigType typ)+ , ppPatSigType unicode qual (hsSigTypeI typ) , fixity ] @@ -1070,7 +1063,7 @@ argDocs [] (dcolon unicode) emptyCtxt) ] - patTy = hsSigType typ+ patTy = hsSigTypeI typ emptyCtxt = patSigContext patTy @@ -1144,7 +1137,7 @@ ppHsTyVarBndr unicode qual (KindedTyVar _ name kind) = parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+> ppLKind unicode qual kind)-ppHsTyVarBndr _ _ (XTyVarBndr _) = panic "haddock:ppHsTyVarBndr"+ppHsTyVarBndr _ _ (XTyVarBndr nec) = noExtCon nec ppLKind :: Unicode -> Qualification -> LHsKind DocNameI -> Html ppLKind unicode qual y = ppKind unicode qual (unLoc y)@@ -1159,16 +1152,16 @@ 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 @@ -1178,16 +1171,22 @@ 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 +ppForAllPart :: Unicode -> Qualification -> [LHsTyVarBndr DocNameI] -> ForallVisFlag -> Html+ppForAllPart unicode qual tvs fvf = hsep (forallSymbol unicode : tvs') +++ fv+ where+ tvs' = ppTyVars unicode qual tvs+ fv = case fvf of+ ForallVis -> spaceHtml +++ arrow unicode+ ForallInvis -> dot+ ppr_mono_lty :: LHsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html ppr_mono_lty ty = ppr_mono_ty (unLoc ty) 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 (HsForAllTy _ fvf tvs ty) unicode qual emptyCtxts+ = ppForAllPart unicode qual tvs fvf <+> ppr_mono_lty 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
src/Haddock/Backends/Xhtml/DocMarkup.hs view
@@ -19,7 +19,7 @@ docElement, docSection, docSection_, ) where -import Data.List+import Data.List (intersperse) import Documentation.Haddock.Markup import Haddock.Backends.Xhtml.Names import Haddock.Backends.Xhtml.Utils@@ -182,7 +182,7 @@ UntouchedDoc d -> (markup fmt $ _doc d, [_meta d]) CollapsingHeader (Header lvl titl) par n nm -> let id_ = makeAnchorId $ "ch:" ++ fromMaybe "noid:" nm ++ show n- col' = collapseControl id_ "caption"+ col' = collapseControl id_ "subheading" summary = thesummary ! [ theclass "hide-when-js-enabled" ] << "Expand" instTable contents = collapseDetails id_ DetailsClosed (summary +++ contents) lvs = zip [1 .. ] [h1, h2, h3, h4, h5, h6]
src/Haddock/Convert.hs view
@@ -28,7 +28,7 @@ import Data.Either (lefts, rights) import DataCon import FamInstEnv-import HsSyn+import GHC.Hs import Name import NameSet ( emptyNameSet ) import RdrName ( mkVarUnqual )@@ -44,7 +44,7 @@ import PrelNames ( hasKey, eqTyConKey, ipClassKey, tYPETyConKey , liftedRepDataConKey ) import Unique ( getUnique )-import Util ( chkAppend,dropList, filterByList, filterOut, splitAtList )+import Util ( chkAppend, dropList, filterByList, filterOut ) import Var import VarSet @@ -74,7 +74,7 @@ -- 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 noExt (synifyIdSig prr ImplicitizeForAll [] i)+ AnId i -> allOK $ SigD noExtField (synifyIdSig prr 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.)@@ -85,19 +85,21 @@ extractFamilyDecl _ = Left "tyThingToLHsDecl: impossible associated tycon" - extractFamDefDecl :: FamilyDecl GhcRn -> Type -> TyFamDefltEqn GhcRn- extractFamDefDecl fd rhs = FamEqn- { feqn_ext = noExt+ extractFamDefDecl :: FamilyDecl GhcRn -> Type -> TyFamDefltDecl GhcRn+ extractFamDefDecl fd rhs =+ TyFamInstDecl $ HsIB { hsib_ext = hsq_ext (fdTyVars fd)+ , hsib_body = FamEqn+ { feqn_ext = noExtField , feqn_tycon = fdLName fd- , feqn_bndrs = Nothing- -- TODO: this must change eventually- , feqn_pats = fdTyVars fd+ , feqn_bndrs = Nothing+ , feqn_pats = map (HsValArg . hsLTyVarBndrToType) $+ hsq_explicit $ fdTyVars fd , feqn_fixity = fdFixity fd- , feqn_rhs = synifyType WithinType [] rhs }+ , feqn_rhs = synifyType WithinType [] rhs }} extractAtItem :: ClassATItem- -> Either ErrMsg (LFamilyDecl GhcRn, Maybe (LTyFamDefltEqn GhcRn))+ -> Either ErrMsg (LFamilyDecl GhcRn, Maybe (LTyFamDefltDecl GhcRn)) extractAtItem (ATI at_tc def) = do tyDecl <- synifyTyCon prr Nothing at_tc famDecl <- extractFamilyDecl tyDecl@@ -108,7 +110,7 @@ (atFamDecls, atDefFamDecls) = unzip (rights atTyClDecls) vs = tyConVisibleTyVars (classTyCon cl) - in withErrs (lefts atTyClDecls) . TyClD noExt $ ClassDecl+ in withErrs (lefts atTyClDecls) . TyClD noExtField $ ClassDecl { tcdCtxt = synifyCtx (classSCTheta cl) , tcdLName = synifyName cl , tcdTyVars = synifyTyVars vs@@ -116,7 +118,7 @@ , tcdFDs = map (\ (l,r) -> noLoc (map (noLoc . getName) l, map (noLoc . getName) r) ) $ snd $ classTvsFds cl- , tcdSigs = noLoc (MinimalSig noExt NoSourceText . noLoc . fmap noLoc $ classMinimalDef cl) :+ , tcdSigs = noLoc (MinimalSig noExtField NoSourceText . noLoc . fmap noLoc $ classMinimalDef cl) : [ noLoc tcdSig | clsOp <- classOpItems cl , tcdSig <- synifyTcIdSig vs clsOp ]@@ -127,18 +129,18 @@ , tcdDocs = [] --we don't have any docs at this point , tcdCExt = placeHolderNamesTc } | otherwise- -> synifyTyCon prr Nothing tc >>= allOK . TyClD noExt+ -> synifyTyCon prr Nothing tc >>= allOK . TyClD noExtField -- 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 noExt (TypeSig noExt [synifyName dc]+ AConLike (RealDataCon dc) -> allOK $ SigD noExtField (TypeSig noExtField [synifyName dc] (synifySigWcType ImplicitizeForAll [] (dataConUserType dc))) AConLike (PatSynCon ps) ->- allOK . SigD noExt $ PatSynSig noExt [synifyName ps] (synifyPatSynSigType ps)+ allOK . SigD noExtField $ PatSynSig noExtField [synifyName ps] (synifyPatSynSigType ps) where withErrs e x = return (e, x) allOK x = return (mempty, x)@@ -151,7 +153,7 @@ annot_typats = zipWith3 annotHsType args_poly args_types_only typats hs_rhs = synifyType WithinType [] rhs in HsIB { hsib_ext = map tyVarName tkvs- , hsib_body = FamEqn { feqn_ext = noExt+ , hsib_body = FamEqn { feqn_ext = noExtField , feqn_tycon = name , feqn_bndrs = Nothing -- TODO: this must change eventually@@ -165,13 +167,13 @@ synifyAxiom ax@(CoAxiom { co_ax_tc = tc }) | isOpenTypeFamilyTyCon tc , Just branch <- coAxiomSingleBranch_maybe ax- = return $ InstD noExt- $ TyFamInstD noExt+ = return $ InstD noExtField+ $ TyFamInstD noExtField $ TyFamInstDecl { tfid_eqn = synifyAxBranch tc branch } | Just ax' <- isClosedSynFamilyTyConWithAxiom_maybe tc , getUnique ax' == getUnique ax -- without the getUniques, type error- = synifyTyCon ShowRuntimeRep (Just ax) tc >>= return . TyClD noExt+ = synifyTyCon ShowRuntimeRep (Just ax) tc >>= return . TyClD noExtField | otherwise = Left "synifyAxiom: closed/open family confusion"@@ -186,9 +188,7 @@ | isFunTyCon tc || isPrimTyCon tc = return $ DataDecl { tcdLName = synifyName tc- , tcdTyVars = HsQTvs { hsq_ext =- HsQTvsRn { hsq_implicit = [] -- No kind polymorphism- , hsq_dependent = emptyNameSet }+ , tcdTyVars = HsQTvs { hsq_ext = [] -- No kind polymorphism , hsq_explicit = zipWith mk_hs_tv tyVarKinds alphaTyVars --a, b, c... which are unfortunately all kind *@@ -196,7 +196,7 @@ , tcdFixity = synifyFixity tc - , tcdDataDefn = HsDataDefn { dd_ext = noExt+ , tcdDataDefn = HsDataDefn { dd_ext = noExtField , dd_ND = DataType -- arbitrary lie, they are neither -- algebraic data nor newtype: , dd_ctxt = noLoc []@@ -209,8 +209,8 @@ where -- tyConTyVars doesn't work on fun/prim, but we can make them up: mk_hs_tv realKind fakeTyVar- | isLiftedTypeKind realKind = noLoc $ UserTyVar noExt (noLoc (getName fakeTyVar))- | otherwise = noLoc $ KindedTyVar noExt (noLoc (getName fakeTyVar)) (synifyKindSig realKind)+ | isLiftedTypeKind realKind = noLoc $ UserTyVar noExtField (noLoc (getName fakeTyVar))+ | otherwise = noLoc $ KindedTyVar noExtField (noLoc (getName fakeTyVar)) (synifyKindSig realKind) conKind = defaultType prr (tyConKind tc) tyVarKinds = fst . splitFunTys . snd . splitPiTysInvisible $ conKind@@ -234,8 +234,8 @@ -> mkFamDecl DataFamily where resultVar = famTcResVar tc- mkFamDecl i = return $ FamDecl noExt $- FamilyDecl { fdExt = noExt+ mkFamDecl i = return $ FamDecl noExtField $+ FamilyDecl { fdExt = noExtField , fdInfo = i , fdLName = synifyName tc , fdTyVars = synifyTyVars (tyConVisibleTyVars tc)@@ -286,7 +286,7 @@ cons = rights consRaw -- "deriving" doesn't affect the signature, no need to specify any. alg_deriv = noLoc []- defn = HsDataDefn { dd_ext = noExt+ defn = HsDataDefn { dd_ext = noExtField , dd_ND = alg_nd , dd_ctxt = alg_ctx , dd_cType = Nothing@@ -331,10 +331,10 @@ synifyFamilyResultSig :: Maybe Name -> Kind -> LFamilyResultSig GhcRn synifyFamilyResultSig Nothing kind- | isLiftedTypeKind kind = noLoc $ NoSig noExt- | otherwise = noLoc $ KindSig noExt (synifyKindSig kind)+ | isLiftedTypeKind kind = noLoc $ NoSig noExtField+ | otherwise = noLoc $ KindSig noExtField (synifyKindSig kind) synifyFamilyResultSig (Just name) kind =- noLoc $ TyVarSig noExt (noLoc $ KindedTyVar noExt (noLoc name) (synifyKindSig kind))+ noLoc $ TyVarSig noExtField (noLoc $ KindedTyVar noExtField (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@@ -362,12 +362,12 @@ let tySyn = synifyType WithinType [] ty in case bang of (HsSrcBang _ NoSrcUnpack NoSrcStrict) -> tySyn- bang' -> noLoc $ HsBangTy noExt bang' tySyn)+ bang' -> noLoc $ HsBangTy noExtField bang' tySyn) arg_tys (dataConSrcBangs dc) field_tys = zipWith con_decl_field (dataConFieldLabels dc) linear_tys con_decl_field fl synTy = noLoc $- ConDeclField noExt [noLoc $ FieldOcc (flSelector fl) (noLoc $ mkVarUnqual $ flLabel fl)] synTy+ ConDeclField noExtField [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!"@@ -381,7 +381,7 @@ \hat -> if use_gadt_syntax then return $ noLoc $- ConDeclGADT { con_g_ext = noExt+ ConDeclGADT { con_g_ext = noExtField , con_names = [name] , con_forall = noLoc $ not $ null user_tvs , con_qvars = synifyTyVars user_tvs@@ -390,7 +390,7 @@ , con_res_ty = synifyType WithinType [] res_ty , con_doc = Nothing } else return $ noLoc $- ConDeclH98 { con_ext = noExt+ ConDeclH98 { con_ext = noExtField , con_name = name , con_forall = noLoc False , con_ex_tvs = map synifyTyVar ex_tvs@@ -414,7 +414,7 @@ -> [TyVar] -- ^ free variables in the type to convert -> Id -- ^ the 'Id' from which to get the type signature -> Sig GhcRn-synifyIdSig prr s vs i = TypeSig noExt [synifyName i] (synifySigWcType s vs t)+synifyIdSig prr s vs i = TypeSig noExtField [synifyName i] (synifySigWcType s vs t) where t = defaultType prr (varType i) @@ -423,8 +423,8 @@ -- 'ClassOpSig'. synifyTcIdSig :: [TyVar] -> ClassOpItem -> [Sig GhcRn] synifyTcIdSig vs (i, dm) =- [ ClassOpSig noExt False [synifyName i] (mainSig (varType i)) ] ++- [ ClassOpSig noExt True [noLoc dn] (defSig dt)+ [ ClassOpSig noExtField False [synifyName i] (mainSig (varType i)) ] +++ [ ClassOpSig noExtField True [noLoc dn] (defSig dt) | Just (dn, GenericDM dt) <- [dm] ] where mainSig t = synifySigType DeleteTopLevelQuantification vs t@@ -435,8 +435,7 @@ synifyTyVars :: [TyVar] -> LHsQTyVars GhcRn-synifyTyVars ktvs = HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = []- , hsq_dependent = emptyNameSet }+synifyTyVars ktvs = HsQTvs { hsq_ext = [] , hsq_explicit = map synifyTyVar ktvs } synifyTyVar :: TyVar -> LHsTyVarBndr GhcRn@@ -447,8 +446,8 @@ synifyTyVar' :: VarSet -> TyVar -> LHsTyVarBndr GhcRn synifyTyVar' no_kinds tv | isLiftedTypeKind kind || tv `elemVarSet` no_kinds- = noLoc (UserTyVar noExt (noLoc name))- | otherwise = noLoc (KindedTyVar noExt (noLoc name) (synifyKindSig kind))+ = noLoc (UserTyVar noExtField (noLoc name))+ | otherwise = noLoc (KindedTyVar noExtField (noLoc name) (synifyKindSig kind)) where kind = tyVarKind tv name = getName tv@@ -466,7 +465,7 @@ | not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType ty = let ki = typeKind ty hs_ki = synifyType WithinType [] ki- in noLoc (HsKindSig noExt hs_ty hs_ki)+ in noLoc (HsKindSig noExtField hs_ty hs_ki) annotHsType _ _ hs_ty = hs_ty -- | For every argument type that a type constructor accepts,@@ -532,7 +531,7 @@ -> [TyVar] -- ^ free variables in the type to convert -> Type -- ^ the type to convert -> LHsType GhcRn-synifyType _ _ (TyVarTy tv) = noLoc $ HsTyVar noExt NotPromoted $ noLoc (getName tv)+synifyType _ _ (TyVarTy tv) = noLoc $ HsTyVar noExtField NotPromoted $ noLoc (getName tv) synifyType _ vs (TyConApp tc tys) = maybe_sig res_ty where@@ -542,62 +541,62 @@ | tc `hasKey` tYPETyConKey , [TyConApp lev []] <- tys , lev `hasKey` liftedRepDataConKey- = noLoc (HsTyVar noExt NotPromoted (noLoc liftedTypeKindTyConName))+ = noLoc (HsTyVar noExtField NotPromoted (noLoc liftedTypeKindTyConName)) -- Use non-prefix tuple syntax where possible, because it looks nicer. | Just sort <- tyConTuple_maybe tc , tyConArity tc == tys_len- = noLoc $ HsTupleTy noExt+ = noLoc $ HsTupleTy noExtField (case sort of BoxedTuple -> HsBoxedTuple ConstraintTuple -> HsConstraintTuple UnboxedTuple -> HsUnboxedTuple) (map (synifyType WithinType vs) vis_tys)- | isUnboxedSumTyCon tc = noLoc $ HsSumTy noExt (map (synifyType WithinType vs) vis_tys)+ | isUnboxedSumTyCon tc = noLoc $ HsSumTy noExtField (map (synifyType WithinType vs) vis_tys) | Just dc <- isPromotedDataCon_maybe tc , isTupleDataCon dc , dataConSourceArity dc == length vis_tys- = noLoc $ HsExplicitTupleTy noExt (map (synifyType WithinType vs) vis_tys)+ = noLoc $ HsExplicitTupleTy noExtField (map (synifyType WithinType vs) vis_tys) -- ditto for lists | getName tc == listTyConName, [ty] <- vis_tys =- noLoc $ HsListTy noExt (synifyType WithinType vs ty)+ noLoc $ HsListTy noExtField (synifyType WithinType vs ty) | tc == promotedNilDataCon, [] <- vis_tys- = noLoc $ HsExplicitListTy noExt IsPromoted []+ = noLoc $ HsExplicitListTy noExtField IsPromoted [] | tc == promotedConsDataCon , [ty1, ty2] <- vis_tys = let hTy = synifyType WithinType vs ty1 in case synifyType WithinType vs ty2 of tTy | L _ (HsExplicitListTy _ IsPromoted tTy') <- stripKindSig tTy- -> noLoc $ HsExplicitListTy noExt IsPromoted (hTy : tTy')+ -> noLoc $ HsExplicitListTy noExtField IsPromoted (hTy : tTy') | otherwise- -> noLoc $ HsOpTy noExt hTy (noLoc $ getName tc) tTy+ -> noLoc $ HsOpTy noExtField hTy (noLoc $ getName tc) tTy -- ditto for implicit parameter tycons | tc `hasKey` ipClassKey , [name, ty] <- tys , Just x <- isStrLitTy name- = noLoc $ HsIParamTy noExt (noLoc $ HsIPName x) (synifyType WithinType vs ty)+ = noLoc $ HsIParamTy noExtField (noLoc $ HsIPName x) (synifyType WithinType vs ty) -- and equalities | tc `hasKey` eqTyConKey , [ty1, ty2] <- tys- = noLoc $ HsOpTy noExt+ = noLoc $ HsOpTy noExtField (synifyType WithinType vs ty1) (noLoc eqTyConName) (synifyType WithinType vs ty2) -- and infix type operators | isSymOcc (nameOccName (getName tc)) , ty1:ty2:tys_rest <- vis_tys- = mk_app_tys (HsOpTy noExt+ = mk_app_tys (HsOpTy noExtField (synifyType WithinType vs ty1) (noLoc $ getName tc) (synifyType WithinType vs ty2)) tys_rest -- Most TyCons: | otherwise- = mk_app_tys (HsTyVar noExt prom $ noLoc (getName tc))+ = mk_app_tys (HsTyVar noExtField prom $ noLoc (getName tc)) vis_tys where prom = if isPromotedDataCon tc then IsPromoted else NotPromoted mk_app_tys ty_app ty_args =- foldl (\t1 t2 -> noLoc $ HsAppTy noExt t1 t2)+ foldl (\t1 t2 -> noLoc $ HsAppTy noExtField t1 t2) (noLoc ty_app) (map (synifyType WithinType vs) $ filterOut isCoercionTy ty_args)@@ -610,22 +609,23 @@ | tyConAppNeedsKindSig False tc tys_len = let full_kind = typeKind (mkTyConApp tc tys) full_kind' = synifyType WithinType vs full_kind- in noLoc $ HsKindSig noExt ty' full_kind'+ in noLoc $ HsKindSig noExtField ty' full_kind' | otherwise = ty' synifyType s vs (AppTy t1 (CoercionTy {})) = synifyType s vs t1 synifyType _ vs (AppTy t1 t2) = let s1 = synifyType WithinType vs t1 s2 = synifyType WithinType vs t2- in noLoc $ HsAppTy noExt s1 s2-synifyType s vs funty@(FunTy t1 t2)- | isPredTy t1 = synifyForAllType s vs funty- | otherwise = let s1 = synifyType WithinType vs t1- s2 = synifyType WithinType vs t2- in noLoc $ HsFunTy noExt s1 s2-synifyType s vs forallty@(ForAllTy _tv _ty) = synifyForAllType s vs forallty+ in noLoc $ HsAppTy noExtField s1 s2+synifyType s vs funty@(FunTy InvisArg _ _) = synifyForAllType s Inferred vs funty+synifyType _ vs (FunTy VisArg t1 t2) = let+ s1 = synifyType WithinType vs t1+ s2 = synifyType WithinType vs t2+ in noLoc $ HsFunTy noExtField s1 s2+synifyType s vs forallty@(ForAllTy (Bndr _ argf) _ty) =+ synifyForAllType s argf vs forallty -synifyType _ _ (LitTy t) = noLoc $ HsTyLit noExt $ synifyTyLit t+synifyType _ _ (LitTy t) = noLoc $ HsTyLit noExtField $ synifyTyLit t synifyType s vs (CastTy t _) = synifyType s vs t synifyType _ _ (CoercionTy {}) = error "synifyType:Coercion" @@ -633,17 +633,19 @@ -- an 'HsType' synifyForAllType :: SynifyTypeState -- ^ what to do with the 'forall'+ -> ArgFlag -- ^ the visibility of the @forall@ -> [TyVar] -- ^ free variables in the type to convert -> Type -- ^ the forall type to convert -> LHsType GhcRn-synifyForAllType s vs ty =- let (tvs, ctx, tau) = tcSplitSigmaTyPreserveSynonyms ty+synifyForAllType s argf vs ty =+ let (tvs, ctx, tau) = tcSplitSigmaTySameVisPreserveSynonyms argf ty sPhi = HsQualTy { hst_ctxt = synifyCtx ctx- , hst_xqual = noExt+ , hst_xqual = noExtField , hst_body = synifyType WithinType (tvs' ++ vs) tau } - sTy = HsForAllTy { hst_bndrs = sTvs- , hst_xforall = noExt+ sTy = HsForAllTy { hst_fvf = argToForallVisFlag argf+ , hst_bndrs = sTvs+ , hst_xforall = noExtField , hst_body = noLoc sPhi } sTvs = map synifyTyVar tvs@@ -683,10 +685,11 @@ sPhi | null ctx = unLoc sRho | otherwise = HsQualTy { hst_ctxt = synifyCtx ctx- , hst_xqual = noExt+ , hst_xqual = noExtField , hst_body = synInner (tvs' ++ vs) tau }- sTy = HsForAllTy { hst_bndrs = sTvs- , hst_xforall = noExt+ sTy = HsForAllTy { hst_fvf = ForallInvis+ , hst_bndrs = sTvs+ , hst_xforall = noExtField , hst_body = noLoc sPhi } no_kinds_needed = noKindTyVars tycons tau@@ -728,7 +731,7 @@ _ -> noKindTyVars ts f in unionVarSets (func : args) noKindTyVars ts (ForAllTy _ t) = noKindTyVars ts t-noKindTyVars ts (FunTy t1 t2) = noKindTyVars ts t1 `unionVarSet` noKindTyVars ts t2+noKindTyVars ts (FunTy _ t1 t2) = noKindTyVars ts t1 `unionVarSet` noKindTyVars ts t2 noKindTyVars ts (CastTy t _) = noKindTyVars ts t noKindTyVars _ _ = emptyVarSet @@ -747,7 +750,7 @@ in implicitForAll ts [] (univ_tvs ++ ex_tvs) req_theta' (\vs -> implicitForAll ts vs [] prov_theta (synifyType WithinType))- (mkFunTys arg_tys res_ty)+ (mkVisFunTys arg_tys res_ty) synifyTyLit :: TyLit -> HsTyLit synifyTyLit (NumTyLit n) = HsNumTy NoSourceText n@@ -833,21 +836,22 @@ invariant didn't hold. -} --- | A version of 'TcType.tcSplitSigmaTy' that preserves type synonyms.+-- | A version of 'TcType.tcSplitSigmaTySameVis' that preserves type synonyms. -- -- See Note [Invariant: Never expand type synonyms]-tcSplitSigmaTyPreserveSynonyms :: Type -> ([TyVar], ThetaType, Type)-tcSplitSigmaTyPreserveSynonyms ty =- case tcSplitForAllTysPreserveSynonyms ty of+tcSplitSigmaTySameVisPreserveSynonyms :: ArgFlag -> Type -> ([TyVar], ThetaType, Type)+tcSplitSigmaTySameVisPreserveSynonyms argf ty =+ case tcSplitForAllTysSameVisPreserveSynonyms argf 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 []+tcSplitForAllTysSameVisPreserveSynonyms :: ArgFlag -> Type -> ([TyVar], Type)+tcSplitForAllTysSameVisPreserveSynonyms supplied_argf ty = split ty ty [] where- split _ (ForAllTy (Bndr tv _) ty') tvs = split ty' ty' (tv:tvs)- split orig_ty _ tvs = (reverse tvs, orig_ty)+ split _ (ForAllTy (Bndr tv argf) ty') tvs+ | argf `sameVis` supplied_argf = split ty' ty' (tv:tvs)+ split orig_ty _ tvs = (reverse tvs, orig_ty) -- | See Note [Invariant: Never expand type synonyms] tcSplitPhiTyPreserveSynonyms :: Type -> (ThetaType, Type)@@ -860,7 +864,5 @@ -- | 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+tcSplitPredFunTyPreserveSynonyms_maybe (FunTy InvisArg arg res) = Just (arg, res)+tcSplitPredFunTyPreserveSynonyms_maybe _ = Nothing
src/Haddock/GhcUtils.hs view
@@ -21,7 +21,7 @@ import Control.Arrow import Data.Char ( isSpace ) -import Haddock.Types( DocNameI )+import Haddock.Types( DocName, DocNameI ) import Exception import FV@@ -38,7 +38,8 @@ isInvisibleArgFlag ) import VarSet ( VarSet, emptyVarSet ) import VarEnv ( TyVarEnv, extendVarEnv, elemVarEnv, emptyVarEnv )-import TyCoRep ( Type(..), isRuntimeRepVar )+import TyCoRep ( Type(..) )+import Type ( isRuntimeRepVar ) import TysWiredIn( liftedRepDataConTyCon ) import StringBuffer ( StringBuffer )@@ -48,7 +49,6 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Internal as BS - moduleString :: Module -> String moduleString = moduleNameString . moduleName @@ -70,7 +70,7 @@ -- 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 :: InstDecl (GhcPass p) -> SrcSpan getInstLoc (ClsInstD _ (ClsInstDecl { cid_poly_ty = ty })) = getLoc (hsSigType ty) getInstLoc (DataFamInstD _ (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = L l _ }}})) = l@@ -79,12 +79,12 @@ -- 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"+getInstLoc (ClsInstD _ (XClsInstDecl nec)) = noExtCon nec+getInstLoc (DataFamInstD _ (DataFamInstDecl (HsIB _ (XFamEqn nec)))) = noExtCon nec+getInstLoc (TyFamInstD _ (TyFamInstDecl (HsIB _ (XFamEqn nec)))) = noExtCon nec+getInstLoc (XInstDecl nec) = noExtCon nec+getInstLoc (DataFamInstD _ (DataFamInstDecl (XHsImplicitBndrs nec))) = noExtCon nec+getInstLoc (TyFamInstD _ (TyFamInstDecl (XHsImplicitBndrs nec))) = noExtCon nec @@ -101,20 +101,20 @@ filterSigNames p (FixSig _ (FixitySig _ ns ty)) = case filter (p . unLoc) ns of [] -> Nothing- filtered -> Just (FixSig noExt (FixitySig noExt filtered ty))+ filtered -> Just (FixSig noExtField (FixitySig noExtField filtered ty)) filterSigNames _ orig@(MinimalSig _ _ _) = Just orig filterSigNames p (TypeSig _ ns ty) = case filter (p . unLoc) ns of [] -> Nothing- filtered -> Just (TypeSig noExt filtered ty)+ filtered -> Just (TypeSig noExtField filtered ty) filterSigNames p (ClassOpSig _ is_default ns ty) = case filter (p . unLoc) ns of [] -> Nothing- filtered -> Just (ClassOpSig noExt is_default filtered ty)+ filtered -> Just (ClassOpSig noExtField is_default filtered ty) filterSigNames p (PatSynSig _ ns ty) = case filter (p . unLoc) ns of [] -> Nothing- filtered -> Just (PatSynSig noExt filtered ty)+ filtered -> Just (PatSynSig noExtField filtered ty) filterSigNames _ _ = Nothing ifTrueJust :: Bool -> name -> Maybe name@@ -135,10 +135,10 @@ -- | Was this signature given by the user? isUserLSig :: LSig name -> Bool-isUserLSig (L _(TypeSig {})) = True-isUserLSig (L _(ClassOpSig {})) = True-isUserLSig (L _(PatSynSig {})) = True-isUserLSig _ = False+isUserLSig (L _ (TypeSig {})) = True+isUserLSig (L _ (ClassOpSig {})) = True+isUserLSig (L _ (PatSynSig {})) = True+isUserLSig _ = False isClassD :: HsDecl a -> Bool@@ -165,9 +165,29 @@ -- --------------------------------------------------------------------- --- This function is duplicated as getGADTConType and getGADTConTypeG,--- as I can't get the types to line up otherwise. AZ.+-- These functions are duplicated from the GHC API, as they must be+-- instantiated at DocNameI instead of (GhcPass _). +hsTyVarNameI :: HsTyVarBndr DocNameI -> DocName+hsTyVarNameI (UserTyVar _ (L _ n)) = n+hsTyVarNameI (KindedTyVar _ (L _ n) _) = n+hsTyVarNameI (XTyVarBndr nec) = noExtCon nec++hsLTyVarNameI :: LHsTyVarBndr DocNameI -> DocName+hsLTyVarNameI = hsTyVarNameI . unLoc++getConNamesI :: ConDecl DocNameI -> [Located DocName]+getConNamesI ConDeclH98 {con_name = name} = [name]+getConNamesI ConDeclGADT {con_names = names} = names+getConNamesI (XConDecl nec) = noExtCon nec++hsImplicitBodyI :: HsImplicitBndrs DocNameI thing -> thing+hsImplicitBodyI (HsIB { hsib_body = body }) = body+hsImplicitBodyI (XHsImplicitBndrs nec) = noExtCon nec++hsSigTypeI :: LHsSigType DocNameI -> LHsType DocNameI+hsSigTypeI = hsImplicitBodyI+ 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@@ -177,26 +197,27 @@ , con_qvars = qtvs , con_mb_cxt = mcxt, con_args = args , con_res_ty = res_ty })- | has_forall = noLoc (HsForAllTy { hst_xforall = NoExt+ | has_forall = noLoc (HsForAllTy { hst_fvf = ForallInvis+ , hst_xforall = noExtField , 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 })+ = noLoc (HsQualTy { hst_xqual = noExtField, 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)+ RecCon flds -> noLoc (HsFunTy noExtField (noLoc (HsRecTy noExtField (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)+ mkFunTy a b = noLoc (HsFunTy noExtField a b) getGADTConType (ConDeclH98 {}) = panic "getGADTConType" -- Should only be called on ConDeclGADT-getGADTConType (XConDecl {}) = panic "getGADTConType"+getGADTConType (XConDecl nec) = noExtCon nec -- ------------------------------------- @@ -209,26 +230,27 @@ , con_qvars = qtvs , con_mb_cxt = mcxt, con_args = args , con_res_ty = res_ty })- | has_forall = noLoc (HsForAllTy { hst_xforall = NoExt+ | has_forall = noLoc (HsForAllTy { hst_fvf = ForallInvis+ , hst_xforall = noExtField , 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 })+ = noLoc (HsQualTy { hst_xqual = noExtField, 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)+ RecCon flds -> noLoc (HsFunTy noExtField (noLoc (HsRecTy noExtField (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)+ mkFunTy a b = noLoc (HsFunTy noExtField a b) getGADTConTypeG (ConDeclH98 {}) = panic "getGADTConTypeG" -- Should only be called on ConDeclGADT-getGADTConTypeG (XConDecl {}) = panic "getGADTConTypeG"+getGADTConTypeG (XConDecl nec) = noExtCon nec -------------------------------------------------------------------------------@@ -258,12 +280,12 @@ -- -- 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 :: (XParTy a ~ NoExtField) => Precedence -> HsType a -> HsType a reparenTypePrec = go where -- Shorter name for 'reparenType'- go :: (XParTy a ~ NoExt) => Precedence -> HsType a -> HsType a+ go :: (XParTy a ~ NoExtField) => 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)@@ -276,8 +298,8 @@ = paren p PREC_SIG $ HsKindSig x (goL PREC_SIG ty) (goL PREC_SIG kind) go p (HsIParamTy x n ty) = paren p PREC_SIG $ 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 (HsForAllTy x fvf tvs ty)+ = paren p PREC_CTX $ HsForAllTy x fvf (map (fmap reparenTyVar) tvs) (reparenLType ty) go p (HsQualTy x ctxt ty) = let p' [_] = PREC_CTX p' _ = PREC_TOP -- parens will get added anyways later...@@ -299,34 +321,34 @@ go _ t@XHsType{} = t -- Located variant of 'go'- goL :: (XParTy a ~ NoExt) => Precedence -> LHsType a -> LHsType a+ goL :: (XParTy a ~ NoExtField) => Precedence -> LHsType a -> LHsType a goL ctxt_prec = fmap (go ctxt_prec) -- Optionally wrap a type in parens- paren :: (XParTy a ~ NoExt)+ paren :: (XParTy a ~ NoExtField) => 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+ paren ctxt_prec op_prec | ctxt_prec >= op_prec = HsParTy noExtField . noLoc | otherwise = id -- | Add parenthesis around the types in a 'HsType' (see 'reparenTypePrec')-reparenType :: (XParTy a ~ NoExt) => HsType a -> HsType a+reparenType :: (XParTy a ~ NoExtField) => 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 :: (XParTy a ~ NoExtField) => 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 :: (XParTy a ~ NoExtField) => 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 :: (XParTy a ~ NoExtField) => ConDeclField a -> ConDeclField a reparenConDeclField (ConDeclField x n t d) = ConDeclField x n (reparenLType t) d reparenConDeclField c@XConDeclField{} = c @@ -568,7 +590,7 @@ -- | Get free type variables in a 'Type' in their order of appearance. -- See [Ordering of implicit variables]. orderedFVs- :: VarSet -- ^ free variables to ignore + :: VarSet -- ^ free variables to ignore -> [Type] -- ^ types to traverse (in order) looking for free variables -> [TyVar] -- ^ free type variables, in the order they appear in orderedFVs vs tys =@@ -582,7 +604,7 @@ -- For example, 'tyCoVarsOfTypeList' reports an incorrect order for the type -- of 'const :: a -> b -> a': ----- >>> import Name +-- >>> import Name -- >>> import TyCoRep -- >>> import TysPrim -- >>> import Var@@ -604,7 +626,7 @@ tyCoFVsOfType' (TyConApp _ tys) a b c = tyCoFVsOfTypes' tys a b c tyCoFVsOfType' (LitTy {}) a b c = emptyFV a b c tyCoFVsOfType' (AppTy fun arg) a b c = (tyCoFVsOfType' arg `unionFV` tyCoFVsOfType' fun) a b c-tyCoFVsOfType' (FunTy arg res) a b c = (tyCoFVsOfType' res `unionFV` tyCoFVsOfType' arg) a b c+tyCoFVsOfType' (FunTy _ arg res) a b c = (tyCoFVsOfType' res `unionFV` tyCoFVsOfType' arg) a b c tyCoFVsOfType' (ForAllTy bndr ty) a b c = tyCoFVsBndr' bndr (tyCoFVsOfType' ty) a b c tyCoFVsOfType' (CastTy ty _) a b c = (tyCoFVsOfType' ty) a b c tyCoFVsOfType' (CoercionTy _ ) a b c = emptyFV a b c@@ -650,8 +672,8 @@ go subs (TyConApp tc tc_args) = TyConApp tc (map (go subs) tc_args) - go subs (FunTy arg res)- = FunTy (go subs arg) (go subs res)+ go subs (FunTy af arg res)+ = FunTy af (go subs arg) (go subs res) go subs (AppTy t u) = AppTy (go subs t) (go subs u)
src/Haddock/Interface.hs view
@@ -44,7 +44,7 @@ import Control.Monad import Control.Exception (evaluate)-import Data.List+import Data.List (foldl', isPrefixOf, nub) import qualified Data.Map as Map import qualified Data.Set as Set import Text.Printf@@ -59,7 +59,7 @@ import Name (nameIsFromExternalPackage, nameOccName) import OccName (isTcOcc) import RdrName (unQualOK, gre_name, globalRdrEnvElts)-import ErrUtils (withTiming)+import ErrUtils (withTimingD) import DynamicLoading (initializePlugins) #if defined(mingw32_HOST_OS)@@ -96,7 +96,7 @@ mods = Set.fromList $ map ifaceMod interfaces out verbosity verbose "Attaching instances..." interfaces' <- {-# SCC attachInstances #-}- withTiming getDynFlags "attachInstances" (const ()) $ do+ withTimingD "attachInstances" (const ()) $ do attachInstances (exportedNames, mods) interfaces instIfaceMap ms out verbosity verbose "Building cross-linking environment..."@@ -136,7 +136,7 @@ where f (ifaces, ifaceMap, !ms) modSummary = do x <- {-# SCC processModule #-}- withTiming getDynFlags "processModule" (const ()) $ do+ withTimingD "processModule" (const ()) $ do processModule verbosity modSummary flags ifaceMap instIfaceMap return $ case x of Just (iface, ms') -> ( iface:ifaces@@ -161,7 +161,7 @@ if not $ isBootSummary modsum then do out verbosity verbose "Creating interface..." (interface, msgs) <- {-# SCC createIterface #-}- withTiming getDynFlags "createInterface" (const ()) $ do+ withTimingD "createInterface" (const ()) $ do runWriterGhc $ createInterface tm flags modMap instIfaceMap -- We need to keep track of which modules were somehow in scope so that when
src/Haddock/Interface/AttachInstances.hs view
@@ -21,7 +21,7 @@ import Control.Applicative ((<|>)) import Control.Arrow hiding ((<+>))-import Data.List+import Data.List (sortBy) import Data.Ord (comparing) import Data.Maybe ( maybeToList, mapMaybe, fromMaybe ) import qualified Data.Map as Map@@ -194,13 +194,13 @@ argCount :: Type -> Int argCount (AppTy t _) = argCount t + 1 argCount (TyConApp _ ts) = length ts-argCount (FunTy _ _ ) = 2+argCount (FunTy _ _ _) = 2 argCount (ForAllTy _ t) = argCount t argCount (CastTy t _) = argCount t argCount _ = 0 simplify :: Type -> SimpleType-simplify (FunTy t1 t2) = SimpleType funTyConName [simplify t1, simplify t2]+simplify (FunTy _ t1 t2) = SimpleType funTyConName [simplify t1, simplify t2] simplify (ForAllTy _ t) = simplify t simplify (AppTy t1 t2) = SimpleType s (ts ++ maybeToList (simplify_maybe t2)) where (SimpleType s ts) = simplify t1@@ -255,7 +255,7 @@ case t of TyVarTy {} -> False AppTy t1 t2 -> typeHidden t1 || typeHidden t2- FunTy t1 t2 -> typeHidden t1 || typeHidden t2+ FunTy _ t1 t2 -> typeHidden t1 || typeHidden t2 TyConApp tcon args -> nameHidden (getName tcon) || any typeHidden args ForAllTy bndr ty -> typeHidden (tyVarKind (binderVar bndr)) || typeHidden ty LitTy _ -> False
src/Haddock/Interface/Create.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE CPP, TupleSections, BangPatterns, LambdaCase #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wwarn #-} ----------------------------------------------------------------------------- -- |@@ -31,7 +32,7 @@ import Data.Bitraversable import qualified Data.Map as M import Data.Map (Map)-import Data.List+import Data.List (find, foldl', sortBy) import Data.Maybe import Data.Ord import Control.Applicative@@ -52,7 +53,7 @@ import Bag import RdrName import TcRnTypes-import FastString ( unpackFS, fastStringToByteString)+import FastString ( unpackFS, bytesFS ) import BasicTypes ( StringLiteral(..), SourceText(..), PromotionFlag(..) ) import qualified Outputable as O @@ -297,8 +298,8 @@ parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> ErrMsgM (Doc Name) parseWarning dflags gre w = case w of- DeprecatedTxt _ msg -> format "Deprecated: " (foldMap (fastStringToByteString . sl_fs . unLoc) msg)- WarningTxt _ msg -> format "Warning: " (foldMap (fastStringToByteString . sl_fs . unLoc) msg)+ DeprecatedTxt _ msg -> format "Deprecated: " (foldMap (bytesFS . sl_fs . unLoc) msg)+ WarningTxt _ msg -> format "Warning: " (foldMap (bytesFS . sl_fs . unLoc) msg) where format x bs = DocWarning . DocParagraph . DocAppend (DocString x) <$> processDocString dflags gre (mkHsDocStringUtf8ByteString bs)@@ -468,11 +469,22 @@ , L _ (ConDeclField _ ns _ doc) <- (unLoc flds) , L _ n <- ns ] derivs = [ (instName, [unL doc], M.empty)- | HsIB { hsib_body = L l (HsDocTy _ _ doc) }- <- concatMap (unLoc . deriv_clause_tys . unLoc) $- unLoc $ dd_derivs dd+ | (l, doc) <- mapMaybe (extract_deriv_ty . hsib_body) $+ concatMap (unLoc . deriv_clause_tys . unLoc) $+ unLoc $ dd_derivs dd , Just instName <- [M.lookup l instMap] ] + extract_deriv_ty :: LHsType GhcRn -> Maybe (SrcSpan, LHsDocString)+ extract_deriv_ty ty =+ case dL ty of+ -- deriving (forall a. C a {- ^ Doc comment -})+ L l (HsForAllTy{ hst_fvf = ForallInvis+ , hst_body = dL->L _ (HsDocTy _ _ doc) })+ -> Just (l, doc)+ -- deriving (C a {- ^ Doc comment -})+ L l (HsDocTy _ _ doc) -> Just (l, doc)+ _ -> Nothing+ -- | Extract constructor argument docs from inside constructor decls. conArgDocs :: ConDecl GhcRn -> Map Int HsDocString conArgDocs con = case getConArgs con of@@ -515,10 +527,10 @@ classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls where decls = docs ++ defs ++ sigs ++ ats- 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_+ docs = mkDecls tcdDocs (DocD noExtField) class_+ defs = mkDecls (bagToList . tcdMeths) (ValD noExtField) class_+ sigs = mkDecls tcdSigs (SigD noExtField) class_+ ats = mkDecls tcdATs (TyClD noExtField . FamDecl noExtField) class_ -- | The top-level declarations of a module that we care about,@@ -537,14 +549,14 @@ -- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'. ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn] ungroup 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_+ mkDecls (tyClGroupTyClDecls . hs_tyclds) (TyClD noExtField) group_ +++ mkDecls hs_derivds (DerivD noExtField) group_ +++ mkDecls hs_defds (DefD noExtField) group_ +++ mkDecls hs_fords (ForD noExtField) group_ +++ mkDecls hs_docs (DocD noExtField) group_ +++ mkDecls (tyClGroupInstDecls . hs_tyclds) (InstD noExtField) group_ +++ mkDecls (typesigs . hs_valds) (SigD noExtField) group_ +++ mkDecls (valbinds . hs_valds) (ValD noExtField) group_ where typesigs (XValBindsLR (NValBinds _ sigs)) = filter isUserLSig sigs typesigs _ = error "expected ValBindsOut"@@ -736,14 +748,14 @@ 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 noExt . fromJust $ filterSigNames (== t) sig+ let newDecl = L loc . SigD noExtField . fromJust $ filterSigNames (== t) sig in availExportDecl avail newDecl docs_ L loc (TyClD _ cl@ClassDecl{}) -> do mdef <- liftGhcToErrMsgGhc $ minimalDef t- let sig = maybeToList $ fmap (noLoc . MinimalSig noExt NoSourceText . noLoc . fmap noLoc) mdef+ let sig = maybeToList $ fmap (noLoc . MinimalSig noExtField NoSourceText . noLoc . fmap noLoc) mdef availExportDecl avail- (L loc $ TyClD noExt cl { tcdSigs = sig ++ tcdSigs cl }) docs_+ (L loc $ TyClD noExtField cl { tcdSigs = sig ++ tcdSigs cl }) docs_ _ -> availExportDecl avail decl docs_ @@ -1057,8 +1069,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 noExt sig)- (_, [L pos fam_decl]) -> L pos (TyClD noExt (FamDecl noExt fam_decl))+ in L pos (SigD noExtField sig)+ (_, [L pos fam_decl]) -> L pos (TyClD noExtField (FamDecl noExtField fam_decl)) ([], []) | Just (famInstDecl:_) <- M.lookup name declMap@@ -1070,8 +1082,8 @@ TyClD _ d@DataDecl {} -> let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars d)) in if isDataConName name- then SigD noExt <$> extractPatternSyn name n (map HsValArg tyvar_tys) (dd_cons (tcdDataDefn d))- else SigD noExt <$> extractRecSel name n (map HsValArg tyvar_tys) (dd_cons (tcdDataDefn d))+ then SigD noExtField <$> extractPatternSyn name n (map HsValArg tyvar_tys) (dd_cons (tcdDataDefn d))+ else SigD noExtField <$> extractRecSel name n (map HsValArg tyvar_tys) (dd_cons (tcdDataDefn d)) TyClD _ FamDecl {} | isValName name , Just (famInst:_) <- M.lookup name declMap@@ -1081,8 +1093,8 @@ , feqn_pats = tys , feqn_rhs = defn }}))) -> if isDataConName name- then SigD noExt <$> extractPatternSyn name n tys (dd_cons defn)- else SigD noExt <$> extractRecSel name n tys (dd_cons defn)+ then SigD noExtField <$> extractPatternSyn name n tys (dd_cons defn)+ else SigD noExtField <$> 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 =@@ -1092,7 +1104,7 @@ , name `elem` map unLoc (concatMap (getConNames . unLoc) (dd_cons dd)) ] in case matches of- [d0] -> extractDecl declMap name (noLoc (InstD noExt (DataFamInstD noExt d0)))+ [d0] -> extractDecl declMap name (noLoc (InstD noExtField (DataFamInstD noExtField d0))) _ -> error "internal: extractDecl (ClsInstD)" | otherwise -> let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body = d }))@@ -1104,7 +1116,7 @@ , extFieldOcc n == name ] in case matches of- [d0] -> extractDecl declMap name (noLoc . InstD noExt $ DataFamInstD noExt d0)+ [d0] -> extractDecl declMap name (noLoc . InstD noExtField $ DataFamInstD noExtField d0) _ -> error "internal: extractDecl (ClsInstD)" _ -> O.pprPanic "extractDecl" $ O.text "Unhandled decl for" O.<+> O.ppr name O.<> O.text ":"@@ -1128,21 +1140,21 @@ typ = longArrow args (data_ty con) typ' = case con of- ConDeclH98 { con_mb_cxt = Just cxt } -> noLoc (HsQualTy noExt cxt typ)+ ConDeclH98 { con_mb_cxt = Just cxt } -> noLoc (HsQualTy noExtField cxt typ) _ -> typ- typ'' = noLoc (HsQualTy noExt (noLoc []) typ')- in PatSynSig noExt [noLoc nm] (mkEmptyImplicitBndrs typ'')+ typ'' = noLoc (HsQualTy noExtField (noLoc []) typ')+ in PatSynSig noExtField [noLoc nm] (mkEmptyImplicitBndrs typ'') longArrow :: [LHsType GhcRn] -> LHsType GhcRn -> LHsType GhcRn- longArrow inputs output = foldr (\x y -> noLoc (HsFunTy noExt x y)) output inputs+ longArrow inputs output = foldr (\x y -> noLoc (HsFunTy noExtField x y)) output inputs data_ty con | ConDeclGADT{} <- con = con_res_ty con- | otherwise = foldl' (\x y -> noLoc (mkAppTyArg x y)) (noLoc (HsTyVar noExt NotPromoted (noLoc t))) tvs+ | otherwise = foldl' (\x y -> noLoc (mkAppTyArg x y)) (noLoc (HsTyVar noExtField NotPromoted (noLoc t))) tvs where mkAppTyArg :: LHsType GhcRn -> LHsTypeArg GhcRn -> HsType GhcRn- mkAppTyArg f (HsValArg ty) = HsAppTy noExt f ty+ mkAppTyArg f (HsValArg ty) = HsAppTy noExtField f ty mkAppTyArg f (HsTypeArg l ki) = HsAppKindTy l f ki- mkAppTyArg f (HsArgPar _) = HsParTy noExt f+ mkAppTyArg f (HsArgPar _) = HsParTy noExtField f extractRecSel :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] -> LSig GhcRn@@ -1151,7 +1163,7 @@ extractRecSel nm t tvs (L _ con : rest) = 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)))))+ L l (TypeSig noExtField [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExtField data_ty (getBangType ty))))) _ -> extractRecSel nm t tvs rest where matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)]@@ -1160,11 +1172,11 @@ data_ty -- ResTyGADT _ ty <- con_res con = ty | ConDeclGADT{} <- con = con_res_ty con- | otherwise = foldl' (\x y -> noLoc (mkAppTyArg x y)) (noLoc (HsTyVar noExt NotPromoted (noLoc t))) tvs+ | otherwise = foldl' (\x y -> noLoc (mkAppTyArg x y)) (noLoc (HsTyVar noExtField NotPromoted (noLoc t))) tvs where mkAppTyArg :: LHsType GhcRn -> LHsTypeArg GhcRn -> HsType GhcRn- mkAppTyArg f (HsValArg ty) = HsAppTy noExt f ty+ mkAppTyArg f (HsValArg ty) = HsAppTy noExtField f ty mkAppTyArg f (HsTypeArg l ki) = HsAppKindTy l f ki- mkAppTyArg f (HsArgPar _) = HsParTy noExt f+ mkAppTyArg f (HsArgPar _) = HsParTy noExtField f -- | Keep export items with docs. pruneExportItems :: [ExportItem GhcRn] -> [ExportItem GhcRn]
src/Haddock/Interface/LexParseRn.hs view
@@ -22,7 +22,7 @@ import Control.Arrow import Control.Monad import Data.Functor (($>))-import Data.List+import Data.List (maximumBy, (\\)) import Data.Ord import Documentation.Haddock.Doc (metaDocConcat) import DynFlags (languageExtensions)
src/Haddock/Interface/Rename.hs view
@@ -22,14 +22,12 @@ import Bag (emptyBag) import GHC hiding (NoLink) import Name-import Outputable ( panic ) import RdrName (RdrName(Exact)) import TysWiredIn (eqTyCon_RDR) import Control.Applicative import Control.Arrow ( first ) import Control.Monad hiding (mapM)-import Data.List import qualified Data.Map as Map hiding ( Map ) import Prelude hiding (mapM) @@ -204,14 +202,14 @@ renameFamilyResultSig :: LFamilyResultSig GhcRn -> RnM (LFamilyResultSig DocNameI) renameFamilyResultSig (L loc (NoSig _))- = return (L loc (NoSig noExt))+ = return (L loc (NoSig noExtField)) renameFamilyResultSig (L loc (KindSig _ ki)) = do { ki' <- renameLKind ki- ; return (L loc (KindSig noExt ki')) }+ ; return (L loc (KindSig noExtField ki')) } renameFamilyResultSig (L loc (TyVarSig _ bndr)) = do { bndr' <- renameLTyVarBndr bndr- ; return (L loc (TyVarSig noExt bndr')) }-renameFamilyResultSig (L _ (XFamilyResultSig _)) = panic "haddock:renameFamilyResultSig"+ ; return (L loc (TyVarSig noExtField bndr')) }+renameFamilyResultSig (L _ (XFamilyResultSig nec)) = noExtCon nec renameInjectivityAnn :: LInjectivityAnn GhcRn -> RnM (LInjectivityAnn DocNameI) renameInjectivityAnn (L loc (InjectivityAnn lhs rhs))@@ -225,63 +223,64 @@ renameType :: HsType GhcRn -> RnM (HsType DocNameI) renameType t = case t of- HsForAllTy { hst_bndrs = tyvars, hst_body = ltype } -> do+ HsForAllTy { hst_fvf = fvf, hst_bndrs = tyvars, hst_body = ltype } -> do tyvars' <- mapM renameLTyVarBndr tyvars ltype' <- renameLType ltype- return (HsForAllTy { hst_xforall = NoExt, hst_bndrs = tyvars', hst_body = ltype' })+ return (HsForAllTy { hst_fvf = fvf, hst_xforall = noExtField+ , hst_bndrs = tyvars', hst_body = ltype' }) HsQualTy { hst_ctxt = lcontext , hst_body = ltype } -> do lcontext' <- renameLContext lcontext ltype' <- renameLType ltype- return (HsQualTy { hst_xqual = NoExt, hst_ctxt = lcontext', hst_body = ltype' })+ return (HsQualTy { hst_xqual = noExtField, hst_ctxt = lcontext', hst_body = ltype' }) - HsTyVar _ ip (L l n) -> return . HsTyVar NoExt ip . L l =<< rename n- HsBangTy _ b ltype -> return . HsBangTy NoExt b =<< renameLType ltype+ HsTyVar _ ip (L l n) -> return . HsTyVar noExtField ip . L l =<< rename n+ HsBangTy _ b ltype -> return . HsBangTy noExtField b =<< renameLType ltype - HsStarTy _ isUni -> return (HsStarTy NoExt isUni)+ HsStarTy _ isUni -> return (HsStarTy noExtField isUni) HsAppTy _ a b -> do a' <- renameLType a b' <- renameLType b- return (HsAppTy NoExt a' b')+ return (HsAppTy noExtField a' b') HsAppKindTy _ a b -> do a' <- renameLType a b' <- renameLKind b- return (HsAppKindTy NoExt a' b')+ return (HsAppKindTy noExtField a' b') HsFunTy _ a b -> do a' <- renameLType a b' <- renameLType b- return (HsFunTy NoExt a' b')+ return (HsFunTy noExtField a' b') - HsListTy _ ty -> return . (HsListTy NoExt) =<< renameLType ty- HsIParamTy _ n ty -> liftM (HsIParamTy NoExt n) (renameLType ty)+ HsListTy _ ty -> return . (HsListTy noExtField) =<< renameLType ty+ HsIParamTy _ n ty -> liftM (HsIParamTy noExtField n) (renameLType ty) - HsTupleTy _ b ts -> return . HsTupleTy NoExt b =<< mapM renameLType ts- HsSumTy _ ts -> HsSumTy NoExt <$> mapM renameLType ts+ HsTupleTy _ b ts -> return . HsTupleTy noExtField b =<< mapM renameLType ts+ HsSumTy _ ts -> HsSumTy noExtField <$> mapM renameLType ts HsOpTy _ a (L loc op) b -> do op' <- rename op a' <- renameLType a b' <- renameLType b- return (HsOpTy NoExt a' (L loc op') b')+ return (HsOpTy noExtField a' (L loc op') b') - HsParTy _ ty -> return . (HsParTy NoExt) =<< renameLType ty+ HsParTy _ ty -> return . (HsParTy noExtField) =<< renameLType ty HsKindSig _ ty k -> do ty' <- renameLType ty k' <- renameLKind k- return (HsKindSig NoExt ty' k')+ return (HsKindSig noExtField ty' k') HsDocTy _ ty doc -> do ty' <- renameLType ty doc' <- renameLDocHsSyn doc- return (HsDocTy NoExt ty' doc')+ return (HsDocTy noExtField ty' doc') - HsTyLit _ x -> return (HsTyLit NoExt x)+ HsTyLit _ x -> return (HsTyLit noExtField x) - HsRecTy _ a -> HsRecTy NoExt <$> mapM renameConDeclFieldField a+ HsRecTy _ a -> HsRecTy noExtField <$> 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@@ -302,9 +301,9 @@ renameLHsQTyVars :: LHsQTyVars GhcRn -> RnM (LHsQTyVars DocNameI) renameLHsQTyVars (HsQTvs { hsq_explicit = tvs }) = do { tvs' <- mapM renameLTyVarBndr tvs- ; return (HsQTvs { hsq_ext = noExt+ ; return (HsQTvs { hsq_ext = noExtField , hsq_explicit = tvs' }) }-renameLHsQTyVars (XLHsQTyVars _) = panic "haddock:renameLHsQTyVars"+renameLHsQTyVars (XLHsQTyVars nec) = noExtCon nec renameLTyVarBndr :: LHsTyVarBndr GhcRn -> RnM (LHsTyVarBndr DocNameI) renameLTyVarBndr (L loc (UserTyVar x (L l n)))@@ -352,19 +351,19 @@ renameDecl decl = case decl of TyClD _ d -> do d' <- renameTyClD d- return (TyClD noExt d')+ return (TyClD noExtField d') SigD _ s -> do s' <- renameSig s- return (SigD noExt s')+ return (SigD noExtField s') ForD _ d -> do d' <- renameForD d- return (ForD noExt d')+ return (ForD noExtField d') InstD _ d -> do d' <- renameInstD d- return (InstD noExt d')+ return (InstD noExtField d') DerivD _ d -> do d' <- renameDerivD d- return (DerivD noExt d')+ return (DerivD noExtField d') _ -> error "renameDecl" renameLThing :: (a GhcRn -> RnM (a DocNameI)) -> Located (a GhcRn) -> RnM (Located (a DocNameI))@@ -375,20 +374,20 @@ -- TyFamily flav lname ltyvars kind tckind -> do FamDecl { tcdFam = decl } -> do decl' <- renameFamilyDecl decl- return (FamDecl { tcdFExt = noExt, tcdFam = decl' })+ return (FamDecl { tcdFExt = noExtField, tcdFam = decl' }) SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdRhs = rhs } -> do lname' <- renameL lname tyvars' <- renameLHsQTyVars tyvars rhs' <- renameLType rhs- return (SynDecl { tcdSExt = noExt, tcdLName = lname', tcdTyVars = tyvars'+ return (SynDecl { tcdSExt = noExtField, tcdLName = lname', tcdTyVars = tyvars' , tcdFixity = fixity, tcdRhs = rhs' }) DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdDataDefn = defn } -> do lname' <- renameL lname tyvars' <- renameLHsQTyVars tyvars defn' <- renameDataDefn defn- return (DataDecl { tcdDExt = noExt, tcdLName = lname', tcdTyVars = tyvars'+ return (DataDecl { tcdDExt = noExtField, tcdLName = lname', tcdTyVars = tyvars' , tcdFixity = fixity, tcdDataDefn = defn' }) ClassDecl { tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars, tcdFixity = fixity@@ -399,13 +398,13 @@ lfundeps' <- mapM renameLFunDep lfundeps lsigs' <- mapM renameLSig lsigs ats' <- mapM (renameLThing renameFamilyDecl) ats- at_defs' <- mapM renameLTyFamDefltEqn at_defs+ at_defs' <- mapM (mapM renameTyFamDefltD) at_defs -- we don't need the default methods or the already collected doc entities return (ClassDecl { tcdCtxt = lcontext', tcdLName = lname', tcdTyVars = ltyvars' , tcdFixity = fixity , tcdFDs = lfundeps', tcdSigs = lsigs', tcdMeths= emptyBag- , tcdATs = ats', tcdATDefs = at_defs', tcdDocs = [], tcdCExt = NoExt })- XTyClDecl _ -> panic "haddock:renameTyClD"+ , tcdATs = ats', tcdATDefs = at_defs', tcdDocs = [], tcdCExt = noExtField })+ XTyClDecl nec -> noExtCon nec where renameLFunDep (L loc (xs, ys)) = do@@ -426,12 +425,12 @@ ltyvars' <- renameLHsQTyVars ltyvars result' <- renameFamilyResultSig result injectivity' <- renameMaybeInjectivityAnn injectivity- return (FamilyDecl { fdExt = noExt, fdInfo = info', fdLName = lname'+ return (FamilyDecl { fdExt = noExtField, fdInfo = info', fdLName = lname' , fdTyVars = ltyvars' , fdFixity = fixity , fdResultSig = result' , fdInjectivityAnn = injectivity' })-renameFamilyDecl (XFamilyDecl _) = panic "renameFamilyDecl"+renameFamilyDecl (XFamilyDecl nec) = noExtCon nec renamePseudoFamilyDecl :: PseudoFamilyDecl GhcRn@@ -457,11 +456,11 @@ k' <- renameMaybeLKind k cons' <- mapM (mapM renameCon) cons -- I don't think we need the derivings, so we return Nothing- return (HsDataDefn { dd_ext = noExt+ return (HsDataDefn { dd_ext = noExtField , dd_ND = nd, dd_ctxt = lcontext', dd_cType = cType , dd_kindSig = k', dd_cons = cons' , dd_derivs = noLoc [] })-renameDataDefn (XHsDataDefn _) = panic "haddock:renameDataDefn"+renameDataDefn (XHsDataDefn nec) = noExtCon nec renameCon :: ConDecl GhcRn -> RnM (ConDecl DocNameI) renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars@@ -472,7 +471,7 @@ lcontext' <- traverse renameLContext lcontext details' <- renameDetails details mbldoc' <- mapM renameLDocHsSyn mbldoc- return (decl { con_ext = noExt, con_name = lname', con_ex_tvs = ltyvars'+ return (decl { con_ext = noExtField, con_name = lname', con_ex_tvs = ltyvars' , con_mb_cxt = lcontext' , con_args = details', con_doc = mbldoc' }) @@ -486,10 +485,10 @@ details' <- renameDetails details res_ty' <- renameLType res_ty mbldoc' <- mapM renameLDocHsSyn mbldoc- return (decl { con_g_ext = noExt, con_names = lnames', con_qvars = ltyvars'+ return (decl { con_g_ext = noExtField, 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"+renameCon (XConDecl nec) = noExtCon nec renameDetails :: HsConDeclDetails GhcRn -> RnM (HsConDeclDetails DocNameI) renameDetails (RecCon (L l fields)) = do@@ -506,8 +505,8 @@ names' <- mapM renameLFieldOcc names t' <- renameLType t doc' <- mapM renameLDocHsSyn doc- return $ L l (ConDeclField noExt names' t' doc')-renameConDeclFieldField (L _ (XConDeclField _)) = panic "haddock:renameConDeclFieldField"+ return $ L l (ConDeclField noExtField names' t' doc')+renameConDeclFieldField (L _ (XConDeclField nec)) = noExtCon nec renameLFieldOcc :: LFieldOcc GhcRn -> RnM (LFieldOcc DocNameI) renameLFieldOcc (L l (FieldOcc sel lbl)) = do@@ -520,21 +519,21 @@ TypeSig _ lnames ltype -> do lnames' <- mapM renameL lnames ltype' <- renameLSigWcType ltype- return (TypeSig noExt lnames' ltype')+ return (TypeSig noExtField lnames' ltype') ClassOpSig _ is_default lnames sig_ty -> do lnames' <- mapM renameL lnames ltype' <- renameLSigType sig_ty- return (ClassOpSig noExt is_default lnames' ltype')+ return (ClassOpSig noExtField is_default lnames' ltype') PatSynSig _ lnames sig_ty -> do lnames' <- mapM renameL lnames sig_ty' <- renameLSigType sig_ty- return $ PatSynSig noExt lnames' sig_ty'+ return $ PatSynSig noExtField lnames' sig_ty' FixSig _ (FixitySig _ lnames fixity) -> do lnames' <- mapM renameL lnames- return $ FixSig noExt (FixitySig noExt lnames' fixity)+ return $ FixSig noExtField (FixitySig noExtField lnames' fixity) MinimalSig _ src (L l s) -> do s' <- traverse renameL s- return $ MinimalSig noExt src (L l s')+ return $ MinimalSig noExtField src (L l s') -- we have filtered out all other kinds of signatures in Interface.Create _ -> error "expected TypeSig" @@ -543,25 +542,25 @@ renameForD (ForeignImport _ lname ltype x) = do lname' <- renameL lname ltype' <- renameLSigType ltype- return (ForeignImport noExt lname' ltype' x)+ return (ForeignImport noExtField lname' ltype' x) renameForD (ForeignExport _ lname ltype x) = do lname' <- renameL lname ltype' <- renameLSigType ltype- return (ForeignExport noExt lname' ltype' x)-renameForD (XForeignDecl _) = panic "haddock:renameForD"+ return (ForeignExport noExtField lname' ltype' x)+renameForD (XForeignDecl nec) = noExtCon nec renameInstD :: InstDecl GhcRn -> RnM (InstDecl DocNameI) renameInstD (ClsInstD { cid_inst = d }) = do d' <- renameClsInstD d- return (ClsInstD { cid_d_ext = noExt, cid_inst = d' })+ return (ClsInstD { cid_d_ext = noExtField, cid_inst = d' }) renameInstD (TyFamInstD { tfid_inst = d }) = do d' <- renameTyFamInstD d- return (TyFamInstD { tfid_ext = noExt, tfid_inst = d' })+ return (TyFamInstD { tfid_ext = noExtField, tfid_inst = d' }) renameInstD (DataFamInstD { dfid_inst = d }) = do d' <- renameDataFamInstD d- return (DataFamInstD { dfid_ext = noExt, dfid_inst = d' })-renameInstD (XInstDecl _) = panic "haddock:renameInstD"+ return (DataFamInstD { dfid_ext = noExtField, dfid_inst = d' })+renameInstD (XInstDecl nec) = noExtCon nec renameDerivD :: DerivDecl GhcRn -> RnM (DerivDecl DocNameI) renameDerivD (DerivDecl { deriv_type = ty@@ -569,11 +568,11 @@ , deriv_overlap_mode = omode }) = do ty' <- renameLSigWcType ty strat' <- mapM (mapM renameDerivStrategy) strat- return (DerivDecl { deriv_ext = noExt+ return (DerivDecl { deriv_ext = noExtField , deriv_type = ty' , deriv_strategy = strat' , deriv_overlap_mode = omode })-renameDerivD (XDerivDecl _) = panic "haddock:renameDerivD"+renameDerivD (XDerivDecl nec) = noExtCon nec renameDerivStrategy :: DerivStrategy GhcRn -> RnM (DerivStrategy DocNameI) renameDerivStrategy StockStrategy = pure StockStrategy@@ -588,11 +587,11 @@ ltype' <- renameLSigType ltype lATs' <- mapM (mapM renameTyFamInstD) lATs lADTs' <- mapM (mapM renameDataFamInstD) lADTs- return (ClsInstDecl { cid_ext = noExt, cid_overlap_mode = omode+ return (ClsInstDecl { cid_ext = noExtField, 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"+renameClsInstD (XClsInstDecl nec) = noExtCon nec renameTyFamInstD :: TyFamInstDecl GhcRn -> RnM (TyFamInstDecl DocNameI)@@ -605,8 +604,8 @@ = renameImplicit rename_ty_fam_eqn eqn where rename_ty_fam_eqn- :: FamEqn GhcRn (HsTyPats GhcRn) (LHsType GhcRn)- -> RnM (FamEqn DocNameI (HsTyPats DocNameI) (LHsType DocNameI))+ :: FamEqn GhcRn (LHsType GhcRn)+ -> RnM (FamEqn DocNameI (LHsType DocNameI)) rename_ty_fam_eqn (FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs , feqn_pats = pats, feqn_fixity = fixity , feqn_rhs = rhs })@@ -614,27 +613,16 @@ ; bndrs' <- traverse (mapM renameLTyVarBndr) bndrs ; pats' <- mapM renameLTypeArg pats ; rhs' <- renameLType rhs- ; return (FamEqn { feqn_ext = noExt+ ; return (FamEqn { feqn_ext = noExtField , feqn_tycon = tc' , feqn_bndrs = bndrs' , feqn_pats = pats' , feqn_fixity = fixity , feqn_rhs = rhs' }) }- rename_ty_fam_eqn (XFamEqn _) = panic "haddock:renameTyFamInstEqn"+ rename_ty_fam_eqn (XFamEqn nec) = noExtCon nec -renameLTyFamDefltEqn :: LTyFamDefltEqn GhcRn -> RnM (LTyFamDefltEqn DocNameI)-renameLTyFamDefltEqn (L loc (FamEqn { feqn_tycon = tc, feqn_pats = tvs- , feqn_fixity = fixity, feqn_rhs = rhs }))- = do { tc' <- renameL tc- ; tvs' <- renameLHsQTyVars tvs- ; rhs' <- renameLType rhs- ; return (L loc (FamEqn { feqn_ext = noExt- , feqn_tycon = tc'- , feqn_bndrs = Nothing -- this is always Nothing- , feqn_pats = tvs'- , feqn_fixity = fixity- , feqn_rhs = rhs' })) }-renameLTyFamDefltEqn (L _ (XFamEqn _)) = panic "haddock:renameLTyFamDefltEqn"+renameTyFamDefltD :: TyFamDefltDecl GhcRn -> RnM (TyFamDefltDecl DocNameI)+renameTyFamDefltD = renameTyFamInstD renameDataFamInstD :: DataFamInstDecl GhcRn -> RnM (DataFamInstDecl DocNameI) renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn })@@ -642,8 +630,8 @@ ; return (DataFamInstDecl { dfid_eqn = eqn' }) } where rename_data_fam_eqn- :: FamEqn GhcRn (HsTyPats GhcRn) (HsDataDefn GhcRn)- -> RnM (FamEqn DocNameI (HsTyPats DocNameI) (HsDataDefn DocNameI))+ :: FamEqn GhcRn (HsDataDefn GhcRn)+ -> RnM (FamEqn DocNameI (HsDataDefn DocNameI)) rename_data_fam_eqn (FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs , feqn_pats = pats, feqn_fixity = fixity , feqn_rhs = defn })@@ -651,13 +639,13 @@ ; bndrs' <- traverse (mapM renameLTyVarBndr) bndrs ; pats' <- mapM renameLTypeArg pats ; defn' <- renameDataDefn defn- ; return (FamEqn { feqn_ext = noExt+ ; return (FamEqn { feqn_ext = noExtField , feqn_tycon = tc' , feqn_bndrs = bndrs' , feqn_pats = pats' , feqn_fixity = fixity , feqn_rhs = defn' }) }- rename_data_fam_eqn (XFamEqn _) = panic "haddock:renameDataFamInstD"+ rename_data_fam_eqn (XFamEqn nec) = noExtCon nec renameImplicit :: (in_thing -> RnM out_thing) -> HsImplicitBndrs GhcRn in_thing@@ -665,8 +653,8 @@ renameImplicit rn_thing (HsIB { hsib_body = thing }) = do { thing' <- rn_thing thing ; return (HsIB { hsib_body = thing'- , hsib_ext = noExt }) }-renameImplicit _ (XHsImplicitBndrs _) = panic "haddock:renameImplicit"+ , hsib_ext = noExtField }) }+renameImplicit _ (XHsImplicitBndrs nec) = noExtCon nec renameWc :: (in_thing -> RnM out_thing) -> HsWildCardBndrs GhcRn in_thing@@ -674,8 +662,8 @@ renameWc rn_thing (HsWC { hswc_body = thing }) = do { thing' <- rn_thing thing ; return (HsWC { hswc_body = thing'- , hswc_ext = noExt }) }-renameWc _ (XHsWildCardBndrs _) = panic "haddock:renameWc"+ , hswc_ext = noExtField }) }+renameWc _ (XHsWildCardBndrs nec) = noExtCon nec renameDocInstance :: DocInstance GhcRn -> RnM (DocInstance DocNameI) renameDocInstance (inst, idoc, L l n, m) = do
src/Haddock/Interface/Specialize.hs view
@@ -76,7 +76,7 @@ -> Sig GhcRn -> Sig GhcRn specializeSig bndrs typs (TypeSig _ lnames typ) =- TypeSig noExt lnames (typ {hswc_body = (hswc_body typ) {hsib_body = noLoc typ'}})+ TypeSig noExtField lnames (typ {hswc_body = (hswc_body typ) {hsib_body = noLoc typ'}}) where true_type :: HsType GhcRn true_type = unLoc (hsSigWcType typ)@@ -112,7 +112,7 @@ sugarLists :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p) sugarLists (HsAppTy _ (L _ (HsTyVar _ _ (L _ name))) ltyp)- | getName name == listTyConName = HsListTy NoExt ltyp+ | getName name == listTyConName = HsListTy noExtField ltyp sugarLists typ = typ @@ -123,7 +123,7 @@ 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+ | isBuiltInSyntax name' && suitable = HsTupleTy noExtField HsBoxedTuple apps where name' = getName name strName = getOccString name@@ -136,7 +136,7 @@ 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- | funTyConName == name' = HsFunTy NoExt la lb+ | funTyConName == name' = HsFunTy noExtField la lb where name' = getName name sugarOperators typ = typ@@ -206,7 +206,7 @@ everythingWithState Set.empty Set.union query where query term ctx = case cast term :: Maybe (HsType GhcRn) of- Just (HsForAllTy _ bndrs _) ->+ Just (HsForAllTy _ _ bndrs _) -> (Set.empty, Set.union ctx (bndrsNames bndrs)) Just (HsTyVar _ _ (L _ name)) | getName name `Set.member` ctx -> (Set.empty, ctx)@@ -244,8 +244,8 @@ renameType :: HsType GhcRn -> Rename (IdP GhcRn) (HsType GhcRn)-renameType (HsForAllTy x bndrs lt) =- HsForAllTy x+renameType (HsForAllTy x fvf bndrs lt) =+ HsForAllTy x fvf <$> mapM (located renameBinder) bndrs <*> renameLType lt renameType (HsQualTy x lctxt lt) =
src/Haddock/InterfaceFile.hs view
@@ -26,7 +26,7 @@ import Control.Monad import Data.Array import Data.IORef-import Data.List+import Data.List (mapAccumR) import qualified Data.Map as Map import Data.Map (Map) import Data.Word@@ -82,8 +82,8 @@ -- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion] -- binaryInterfaceVersion :: Word16-#if (__GLASGOW_HASKELL__ >= 807) && (__GLASGOW_HASKELL__ < 809)-binaryInterfaceVersion = 35+#if (__GLASGOW_HASKELL__ >= 809) && (__GLASGOW_HASKELL__ < 811)+binaryInterfaceVersion = 36 binaryInterfaceVersionCompatibility :: [Word16] binaryInterfaceVersionCompatibility = [binaryInterfaceVersion]
src/Haddock/Types.hs view
@@ -374,8 +374,8 @@ | TypeInst (Maybe (HsType name)) -- ^ Body (right-hand side) | DataInst (TyClDecl name) -- ^ Data constructors -instance (a ~ GhcPass p,OutputableBndrId a)- => Outputable (InstType a) where+instance (OutputableBndrId p)+ => Outputable (InstType (GhcPass p)) where ppr (ClassInst { .. }) = text "ClassInst" <+> ppr clsiCtx <+> ppr clsiTyVars@@ -408,12 +408,12 @@ } where mkType (KindedTyVar _ (L loc name) lkind) =- HsKindSig NoExt tvar lkind+ HsKindSig noExtField tvar lkind where- 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"+ tvar = L loc (HsTyVar noExtField NotPromoted (L loc name))+ mkType (UserTyVar _ name) = HsTyVar noExtField NotPromoted name+ mkType (XTyVarBndr nec) = noExtCon nec+mkPseudoFamilyDecl (XFamilyDecl nec) = noExtCon nec -- | An instance head that may have documentation and a source location.@@ -697,93 +697,86 @@ -- * Pass sensitive types ----------------------------------------------------------------------------- -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 XAppKindTy 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 = NoExt+type instance XRec DocNameI f = Located (f DocNameI)++type instance XForAllTy DocNameI = NoExtField+type instance XQualTy DocNameI = NoExtField+type instance XTyVar DocNameI = NoExtField+type instance XStarTy DocNameI = NoExtField+type instance XAppTy DocNameI = NoExtField+type instance XAppKindTy DocNameI = NoExtField+type instance XFunTy DocNameI = NoExtField+type instance XListTy DocNameI = NoExtField+type instance XTupleTy DocNameI = NoExtField+type instance XSumTy DocNameI = NoExtField+type instance XOpTy DocNameI = NoExtField+type instance XParTy DocNameI = NoExtField+type instance XIParamTy DocNameI = NoExtField+type instance XKindSig DocNameI = NoExtField+type instance XSpliceTy DocNameI = NoExtField+type instance XDocTy DocNameI = NoExtField+type instance XBangTy DocNameI = NoExtField+type instance XRecTy DocNameI = NoExtField+type instance XExplicitListTy DocNameI = NoExtField+type instance XExplicitTupleTy DocNameI = NoExtField+type instance XTyLit DocNameI = NoExtField+type instance XWildCardTy DocNameI = NoExtField type instance XXType DocNameI = NewHsTypeX -type instance XUserTyVar DocNameI = NoExt-type instance XKindedTyVar DocNameI = NoExt-type instance XXTyVarBndr DocNameI = NoExt+type instance XUserTyVar DocNameI = NoExtField+type instance XKindedTyVar DocNameI = NoExtField+type instance XXTyVarBndr DocNameI = NoExtCon type instance XCFieldOcc DocNameI = DocName-type instance XXFieldOcc DocNameI = NoExt+type instance XXFieldOcc DocNameI = NoExtField -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 XFixitySig DocNameI = NoExtField+type instance XFixSig DocNameI = NoExtField+type instance XPatSynSig DocNameI = NoExtField+type instance XClassOpSig DocNameI = NoExtField+type instance XTypeSig DocNameI = NoExtField+type instance XMinimalSig DocNameI = NoExtField -type instance XForeignExport DocNameI = NoExt-type instance XForeignImport DocNameI = NoExt-type instance XConDeclGADT DocNameI = NoExt-type instance XConDeclH98 DocNameI = NoExt+type instance XForeignExport DocNameI = NoExtField+type instance XForeignImport DocNameI = NoExtField+type instance XConDeclGADT DocNameI = NoExtField+type instance XConDeclH98 DocNameI = NoExtField+type instance XXConDecl DocNameI = NoExtCon -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 XDerivD DocNameI = NoExtField+type instance XInstD DocNameI = NoExtField+type instance XForD DocNameI = NoExtField+type instance XSigD DocNameI = NoExtField+type instance XTyClD DocNameI = NoExtField -type instance XNoSig DocNameI = NoExt-type instance XCKindSig DocNameI = NoExt-type instance XTyVarSig DocNameI = NoExt+type instance XNoSig DocNameI = NoExtField+type instance XCKindSig DocNameI = NoExtField+type instance XTyVarSig DocNameI = NoExtField+type instance XXFamilyResultSig DocNameI = NoExtCon -type instance XCFamEqn DocNameI _ _ = NoExt+type instance XCFamEqn DocNameI _ = NoExtField+type instance XXFamEqn DocNameI _ = NoExtCon -type instance XCClsInstDecl DocNameI = NoExt-type instance XCDerivDecl DocNameI = NoExt+type instance XCClsInstDecl DocNameI = NoExtField+type instance XCDerivDecl DocNameI = NoExtField 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+type instance XDataFamInstD DocNameI = NoExtField+type instance XTyFamInstD DocNameI = NoExtField+type instance XClsInstD DocNameI = NoExtField+type instance XCHsDataDefn DocNameI = NoExtField+type instance XCFamilyDecl DocNameI = NoExtField+type instance XClassDecl DocNameI = NoExtField+type instance XDataDecl DocNameI = NoExtField+type instance XSynDecl DocNameI = NoExtField+type instance XFamDecl DocNameI = NoExtField+type instance XXFamilyDecl DocNameI = NoExtCon -type instance XXPat DocNameI = Located (Pat DocNameI)+type instance XHsIB DocNameI _ = NoExtField+type instance XHsWC DocNameI _ = NoExtField+type instance XXHsImplicitBndrs DocNameI _ = NoExtCon -type instance SrcSpanLess (LPat DocNameI) = Pat DocNameI-instance HasSrcSpan (LPat DocNameI) where- -- NB: The following chooses the behaviour of the outer location- -- wrapper replacing the inner ones.- composeSrcSpan (L sp p) = if sp == noSrcSpan- then p- else XPat (L sp (stripSrcSpanPat p))- -- NB: The following only returns the top-level location, if any.- decomposeSrcSpan (XPat (L sp p)) = L sp (stripSrcSpanPat p)- decomposeSrcSpan p = L noSrcSpan p+type instance XHsQTvs DocNameI = NoExtField+type instance XConDeclField DocNameI = NoExtField+type instance XXConDeclField DocNameI = NoExtCon -stripSrcSpanPat :: LPat DocNameI -> Pat DocNameI-stripSrcSpanPat (XPat (L _ p)) = stripSrcSpanPat p-stripSrcSpanPat p = p+type instance XXPat DocNameI = NoExtCon
src/Haddock/Utils.hs view
@@ -65,7 +65,6 @@ import Exception (ExceptionMonad) import GHC import Name-import Outputable ( panic ) import Control.Monad ( liftM ) import Data.Char ( isAlpha, isAlphaNum, isAscii, ord, chr )@@ -150,17 +149,17 @@ 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 noExt lname (mkEmptySigWcType (go (hsSigType ltype))))+ = L pos (TypeSig noExtField lname (mkEmptySigWcType (go (hsSigType ltype)))) -- The mkEmptySigWcType is suspicious where- go (L loc (HsForAllTy { hst_bndrs = tvs, hst_body = ty }))- = L loc (HsForAllTy { hst_xforall = noExt+ go (L loc (HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs, hst_body = ty }))+ = L loc (HsForAllTy { hst_fvf = fvf, hst_xforall = noExtField , hst_bndrs = tvs, hst_body = go ty }) go (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty }))- = L loc (HsQualTy { hst_xqual = noExt+ = L loc (HsQualTy { hst_xqual = noExtField , hst_ctxt = add_ctxt ctxt, hst_body = ty }) go (L loc ty)- = L loc (HsQualTy { hst_xqual = noExt+ = L loc (HsQualTy { hst_xqual = noExtField , hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty }) extra_pred = nlHsTyConApp cls (lHsQTyVarsToTypes tvs0)@@ -170,7 +169,7 @@ lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsType GhcRn] lHsQTyVarsToTypes tvs- = [ noLoc (HsTyVar NoExt NotPromoted (noLoc (hsLTyVarName tv)))+ = [ noLoc (HsTyVar noExtField NotPromoted (noLoc (hsLTyVarName tv))) | tv <- hsQTvExplicit tvs ] --------------------------------------------------------------------------------@@ -216,7 +215,7 @@ field_avail :: LConDeclField GhcRn -> Bool field_avail (L _ (ConDeclField _ fs _ _)) = all (\f -> extFieldOcc (unLoc f) `elem` names) fs- field_avail (L _ (XConDeclField _)) = panic "haddock:field_avail"+ field_avail (L _ (XConDeclField nec)) = noExtCon nec field_types flds = [ t | ConDeclField _ _ t _ <- flds ] keep _ = Nothing@@ -232,9 +231,7 @@ -- 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_ext = HsQTvsRn- { hsq_implicit = error "haddock:emptyHsQTvs"- , hsq_dependent = error "haddock:emptyHsQTvs" }+emptyHsQTvs = HsQTvs { hsq_ext = error "haddock:emptyHsQTvs" , hsq_explicit = [] }
src/Haddock/Utils/Json.hs view
@@ -19,7 +19,7 @@ import Data.Int import Data.String import Data.Word-import Data.List+import Data.List (intersperse) import Data.Monoid import Data.ByteString.Builder (Builder)
test/Haddock/Backends/Hyperlinker/ParserSpec.hs view
@@ -19,7 +19,7 @@ withDynFlags :: (DynFlags -> IO ()) -> IO () withDynFlags cont = do libDir <- fmap snd (getGhcDirs [])- runGhc (Just libDir) $ do+ runGhc libDir $ do dflags <- getSessionDynFlags liftIO $ cont dflags