aboutsummaryrefslogtreecommitdiff
path: root/haddock-api
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api')
-rw-r--r--haddock-api/LICENSE39
-rw-r--r--haddock-api/haddock-api.cabal8
-rw-r--r--haddock-api/src/Haddock.hs160
-rw-r--r--haddock-api/src/Haddock/Backends/HaddockDB.hs15
-rw-r--r--haddock-api/src/Haddock/Backends/Hoogle.hs37
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker.hs2
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs17
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs4
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs4
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs61
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs102
-rw-r--r--haddock-api/src/Haddock/Convert.hs182
-rw-r--r--haddock-api/src/Haddock/GhcUtils.hs114
-rw-r--r--haddock-api/src/Haddock/Interface.hs8
-rw-r--r--haddock-api/src/Haddock/Interface/AttachInstances.hs6
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs92
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs164
-rw-r--r--haddock-api/src/Haddock/Interface/Specialize.hs14
-rw-r--r--haddock-api/src/Haddock/InterfaceFile.hs2
-rw-r--r--haddock-api/src/Haddock/Types.hs177
-rw-r--r--haddock-api/src/Haddock/Utils.hs18
-rw-r--r--haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs2
22 files changed, 626 insertions, 602 deletions
diff --git a/haddock-api/LICENSE b/haddock-api/LICENSE
index 460decfc..d5f0b37c 100644
--- a/haddock-api/LICENSE
+++ b/haddock-api/LICENSE
@@ -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.
diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal
index f8558dca..8ad0ae64 100644
--- a/haddock-api/haddock-api.cabal
+++ b/haddock-api/haddock-api.cabal
@@ -4,7 +4,7 @@ version: 2.23.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>
@@ -42,8 +42,8 @@ library
default-language: Haskell2010
-- this package typically supports only single major versions
- build-depends: base ^>= 4.13.0
- , ghc ^>= 8.8
+ build-depends: base ^>= 4.14.0
+ , ghc ^>= 8.10
, ghc-paths ^>= 0.1.0.9
, haddock-library ^>= 1.8.0
, xhtml ^>= 3000.2.2
@@ -165,7 +165,7 @@ test-suite spec
Haddock.Backends.Hyperlinker.Parser
Haddock.Backends.Hyperlinker.Types
- build-depends: ghc ^>= 8.8
+ build-depends: ghc ^>= 8.10
, ghc-paths ^>= 0.1.0.12
, haddock-library ^>= 1.8.0
, xhtml ^>= 3000.2.2
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 1b49fba3..cf7bd857 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -55,20 +55,14 @@ import qualified Data.Map as Map
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 @@ noCheckWarning = "Warning: `--bypass-interface-version-check' can cause " ++
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 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do
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 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do
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 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do
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 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do
]
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 @@ withGhc' libDir needHieFiles flags ghcActs = runGhc (Just libDir) $ do
-- 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,51 +521,87 @@ unsetPatternMatchWarnings dflags =
-------------------------------------------------------------------------------
-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"
+ ]
+
+ res_dir <- check res_dirs
+ case res_dir of
+ Just p -> return p
+ _ -> die "Haddock's resource directory does not exist!\n"
-getGhcDirs :: [Flag] -> IO (String, String)
+ 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
@@ -586,12 +615,12 @@ shortcutFlags flags = do
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 :: Either String b -> IO b
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
diff --git a/haddock-api/src/Haddock/Backends/HaddockDB.hs b/haddock-api/src/Haddock/Backends/HaddockDB.hs
index 0bdc9057..6c48804a 100644
--- a/haddock-api/src/Haddock/Backends/HaddockDB.hs
+++ b/haddock-api/src/Haddock/Backends/HaddockDB.hs
@@ -104,17 +104,22 @@ ppHsContext context = parenList (map (\ (a,b) -> ppHsQName a <+>
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 "-&gt;", ppHsType b]
ppHsType (HsTyIP n t) = fsep [(char '?' <> ppHsName n), text "::", ppHsType t]
ppHsType t = ppHsBType t
+ppHsForAllSeparator :: ForallVisFlag -> Doc
+ppHsForAllSeparator ForallVis = text "-&gt;"
+ppHsForAllSeparator ForallInvis = text "."
+
ppHsBType (HsTyApp (HsTyCon (Qual (Module "Prelude") (HsTyClsName (HsSpecial "[]")))) b )
= brackets $ ppHsType b
ppHsBType (HsTyApp a b) = fsep [ppHsBType a, ppHsAType b]
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 149f4815..1f98ef9c 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -18,7 +18,7 @@ module Haddock.Backends.Hoogle (
) where
import BasicTypes ( OverlapFlag(..), OverlapMode(..), SourceText(..)
- , PromotionFlag(..) )
+ , PromotionFlag(..), TopLevelFlag(..) )
import InstEnv (ClsInst(..))
import Documentation.Haddock.Markup
import Haddock.GhcUtils
@@ -72,7 +72,7 @@ dropHsDocTy :: HsType a -> HsType a
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 +86,8 @@ dropHsDocTy = f
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 +174,7 @@ ppClass dflags decl subdocs =
| 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 +187,6 @@ ppClass dflags decl subdocs =
, 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 +196,7 @@ ppFam dflags decl@(FamilyDecl { fdInfo = info })
-- 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 +245,8 @@ ppCtor dflags dat subdocs con@ConDeclH98 {}
[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,13 +254,13 @@ ppCtor dflags dat subdocs con@ConDeclH98 {}
-- 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 (UserTyVar _ n) = HsTyVar noExtField NotPromoted n
+ tyVarBndr2Type (KindedTyVar _ n k) = HsKindSig noExtField (reL (HsTyVar noExtField NotPromoted n)) k
tyVarBndr2Type (XTyVarBndr _) = panic "haddock:ppCtor"
ppCtor dflags _dat subdocs con@(ConDeclGADT { })
@@ -279,10 +270,10 @@ ppCtor dflags _dat subdocs con@(ConDeclGADT { })
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)]
---------------------------------------------------------------------
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
index 2e665204..3f5483fe 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
@@ -18,7 +18,7 @@ import Data.Maybe
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 )
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index 0bd467e1..0247d567 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -9,11 +9,12 @@ import qualified Data.ByteString as BS
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 @@ parse
-> [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 @@ parse dflags fpath bs = case unP (go False []) initState of
-- | 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 @@ setInput (buf, srcLoc) = P $ \p -> POk (p { buffer = buf, loc = srcLoc }) ()
-- | 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 }
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index a4dcb77b..404cb9d0 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -88,14 +88,14 @@ renderWithAst srcs Node{..} toks = anchored $ case toks of
-- 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
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
index 2c48e00b..612f3f08 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
@@ -129,8 +129,8 @@ recoverFullIfaceTypes df flattened ast = fmap (printed A.!) ast
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)
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index c62a9311..f2fb1041 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -311,7 +311,7 @@ ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of
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 @@ ppFamDecl associated doc instances decl unicode =
, 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 @@ ppFamHeader :: FamilyDecl DocNameI -- ^ family header to print
-> 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 @@ ppFamHeader (FamilyDecl { fdLName = L _ name
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 @@ ppLPatSig :: DocForDecl DocName -- ^ documentation
-> 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 @@ ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ
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)
@@ -517,6 +517,12 @@ ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ
gadtOpen = char '{'
+ppForAllSeparator :: Bool -> ForallVisFlag -> LaTeX
+ppForAllSeparator unicode fvf =
+ case fvf of
+ ForallVis -> text "\\ " <> arrow unicode
+ ForallInvis -> dot
+
ppTypeSig :: [Name] -> HsType DocNameI -> Bool -> LaTeX
ppTypeSig nms ty unicode =
hsep (punctuate comma $ map ppSymName nms)
@@ -530,7 +536,7 @@ ppTyVars unicode = map (ppHsTyVarBndr unicode . unLoc)
tyvarNames :: LHsQTyVars DocNameI -> [Name]
-tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit
+tyvarNames = map (getName . hsLTyVarNameI) . hsQTvExplicit
declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX
@@ -621,7 +627,7 @@ ppClassDecl instances doc subdocs
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 +636,7 @@ ppClassDecl instances doc subdocs
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 +756,7 @@ ppConstrHdr forall_ tvs ctxt unicode = ppForall <> ppCtxt
where
ppForall
| null tvs || not forall_ = empty
- | otherwise = ppForAllPart unicode tvs
+ | otherwise = ppForAllPart unicode tvs ForallInvis
ppCtxt
| null ctxt = empty
@@ -769,9 +775,9 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
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 +822,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
-- ++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 +856,12 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
[ 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 +876,7 @@ ppSideBySideField subdocs unicode (ConDeclField _ names ltype _) =
-- 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 +896,7 @@ ppSideBySidePat lnames typ (doc, argDocs) unicode =
| otherwise = hsep [ keyword "pattern"
, ppOcc
, dcolon unicode
- , ppLType unicode (hsSigType typ)
+ , ppLType unicode (hsSigTypeI typ)
]
fieldPart
@@ -900,7 +906,7 @@ ppSideBySidePat lnames typ (doc, argDocs) unicode =
| (l,r) <- ppSubSigLike unicode (unLoc patTy) argDocs [] (dcolon unicode)
]
- patTy = hsSigType typ
+ patTy = hsSigTypeI typ
mDoc = fmap _doc $ combineDocumentation doc
@@ -1037,7 +1043,7 @@ ppHsTyVarBndr :: Bool -> HsTyVarBndr DocNameI -> LaTeX
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,8 +1055,13 @@ ppKind unicode ki = ppr_mono_ty (reparenTypePrec PREC_TOP ki) unicode
-- Drop top-level for-all type variables in user style
-- since they are implicit in Haskell
-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
@@ -1058,8 +1069,8 @@ 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
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 40d630b0..c7ae15ca 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -41,7 +41,6 @@ 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 +64,7 @@ ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdoc
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 +151,8 @@ ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_args 0 sep typ
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 +218,7 @@ ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName
-> 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 +305,8 @@ ppFamDecl summary associated links instances fixities loc doc decl splice unicod
, 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 +331,7 @@ ppFamHeader :: Bool -- ^ is a summary
-> 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 +371,7 @@ ppResultSig result unicode qual = case result of
NoSig _ -> noHtml
KindSig _ kind -> dcolon unicode <+> ppLKind unicode qual kind
TyVarSig _ (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr
- XFamilyResultSig _ -> panic "haddock:ppResultSig"
+ XFamilyResultSig nec -> noExtCon nec
--------------------------------------------------------------------------------
@@ -497,7 +496,7 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, t
-- 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 +547,26 @@ ppClassDecl summary links instances fixities loc d subdocs
, 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 +581,7 @@ ppClassDecl summary links instances fixities loc d subdocs
-- 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 +771,7 @@ ppShortDataDecl summary dataInst dataDecl pats unicode qual
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 +817,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats
[ 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 +882,10 @@ ppShortConstrParts summary dataInst con unicode qual
, 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 +902,10 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con)
)
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 +951,7 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con)
, 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 +980,11 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con)
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 +999,7 @@ ppConstrHdr forall_ tvs ctxt unicode qual = ppForall +++ ppCtxt
where
ppForall
| null tvs || not forall_ = noHtml
- | otherwise = ppForAllPart unicode qual tvs
+ | otherwise = ppForAllPart unicode qual tvs ForallInvis
ppCtxt
| null ctxt = noHtml
@@ -1030,14 +1024,14 @@ ppSideBySideField subdocs unicode qual (ConDeclField _ names ltype _) =
-- 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 +1054,7 @@ ppSideBySidePat fixities unicode qual lnames typ (doc, argDocs) =
| otherwise = hsep [ keyword "pattern"
, ppOcc
, dcolon unicode
- , ppPatSigType unicode qual (hsSigType typ)
+ , ppPatSigType unicode qual (hsSigTypeI typ)
, fixity
]
@@ -1070,7 +1064,7 @@ ppSideBySidePat fixities unicode qual lnames typ (doc, argDocs) =
argDocs [] (dcolon unicode)
emptyCtxt) ]
- patTy = hsSigType typ
+ patTy = hsSigTypeI typ
emptyCtxt = patSigContext patTy
@@ -1144,7 +1138,7 @@ ppHsTyVarBndr _ qual (UserTyVar _ (L _ name)) =
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 +1153,16 @@ patSigContext typ | hasNonEmptyContext typ && isFirstContextEmpty typ = ShowEmp
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 +1172,22 @@ ppPatSigType :: Unicode -> Qualification -> LHsType DocNameI -> Html
ppPatSigType unicode qual typ =
let emptyCtxts = patSigContext typ in ppLType unicode qual emptyCtxts typ
-ppForAllPart :: Unicode -> Qualification -> [LHsTyVarBndr DocNameI] -> Html
-ppForAllPart unicode qual tvs = hsep (forallSymbol unicode : ppTyVars unicode qual tvs) +++ dot
+
+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
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 709e20d4..d5fa3667 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -28,7 +28,7 @@ import ConLike
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 TysWiredIn ( eqTyConName, listTyConName, liftedTypeKindTyConName
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 @@ tyThingToLHsDecl prr t = case t of
-- 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 @@ tyThingToLHsDecl prr t = case t of
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 @@ tyThingToLHsDecl prr t = case t of
(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 @@ tyThingToLHsDecl prr t = case t of
, 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 @@ tyThingToLHsDecl prr t = case t of
, 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 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs })
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 :: CoAxiom br -> Either ErrMsg (HsDecl GhcRn)
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 @@ synifyTyCon prr _coax tc
| 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 @@ synifyTyCon prr _coax tc
, 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 @@ synifyTyCon prr _coax tc
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 @@ synifyTyCon _prr _coax tc
-> 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 @@ synifyTyCon _prr coax tc
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 @@ synifyInjectivityAnn (Just lhs) tvs (Injective inj) =
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 @@ synifyDataCon use_gadt_syntax dc =
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 @@ synifyDataCon use_gadt_syntax dc =
\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 @@ synifyDataCon use_gadt_syntax dc =
, 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 @@ synifyIdSig
-> [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 @@ synifyIdSig prr s vs i = TypeSig noExt [synifyName i] (synifySigWcType s vs t)
-- '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 @@ synifyCtx = noLoc . map (synifyType WithinType [])
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 = synifyTyVar' emptyVarSet
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 @@ annotHsType True ty hs_ty
| 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 @@ synifyType
-> [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 @@ synifyType _ vs (TyConApp tc tys)
| 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 @@ synifyType _ vs (TyConApp tc tys)
| 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
-
-synifyType _ _ (LitTy t) = noLoc $ HsTyLit noExt $ synifyTyLit t
+ 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 noExtField $ synifyTyLit t
synifyType s vs (CastTy t _) = synifyType s vs t
synifyType _ _ (CoercionTy {}) = error "synifyType:Coercion"
@@ -633,17 +633,19 @@ synifyType _ _ (CoercionTy {}) = error "synifyType:Coercion"
-- 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 @@ implicitForAll tycons vs tvs ctx synInner tau
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 ty
_ -> 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 @@ synifyPatSynType ps =
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 @@ See https://github.com/haskell/haddock/issues/879 for a bug where this
invariant didn't hold.
-}
--- | A version of 'TcType.tcSplitSigmaTy' that preserves type synonyms.
+-- | 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 @@ tcSplitPhiTyPreserveSynonyms ty0 = split ty0 []
-- | 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
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 5cc005cc..6577e08f 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -21,7 +21,7 @@ module Haddock.GhcUtils where
import Control.Arrow
import Data.Char ( isSpace )
-import Haddock.Types( DocNameI )
+import Haddock.Types( DocName, DocNameI )
import Exception
import FV
@@ -38,7 +38,8 @@ import Var ( VarBndr(..), TyVarBinder, tyVarKind, updateTyVarKind,
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 Data.ByteString ( ByteString )
import qualified Data.ByteString as BS
import qualified Data.ByteString.Internal as BS
-
moduleString :: Module -> String
moduleString = moduleNameString . moduleName
@@ -70,7 +70,7 @@ getMainDeclBinder _ = []
-- Extract the source location where an instance is defined. This is used
-- to correlate InstDecls with their Instance/CoAxiom Names, via the
-- instanceMap.
-getInstLoc :: InstDecl name -> SrcSpan
+getInstLoc :: 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 @@ getInstLoc (TyFamInstD _ (TyFamInstDecl
-- 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 orig@(InlineSig _ n _) = ifTrueJust (p $ unLoc n) orig
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 @@ sigNameNoLoc _ = []
-- | 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,8 +165,28 @@ nubByName f ns = go emptyNameSet ns
-- ---------------------------------------------------------------------
--- 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
@@ -177,26 +197,27 @@ getGADTConType (ConDeclGADT { con_forall = L _ has_forall
, con_qvars = qtvs
, con_mb_cxt = mcxt, con_args = args
, con_res_ty = res_ty })
- | has_forall = noLoc (HsForAllTy { hst_xforall = NoExt
+ | 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 @@ getGADTConTypeG (ConDeclGADT { con_forall = L _ has_forall
, con_qvars = qtvs
, con_mb_cxt = mcxt, con_args = args
, con_res_ty = res_ty })
- | has_forall = noLoc (HsForAllTy { hst_xforall = NoExt
+ | 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 @@ data Precedence
--
-- 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 @@ reparenTypePrec = go
= 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 @@ reparenTypePrec = go
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 @@ tryCppLine !loc !buf = spanSpace (S.prevChar buf '\n' == '\n') loc buf
-- | 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 @@ orderedFVs vs tys =
-- 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' (TyVarTy v) a b c = (FV.unitFV v `unionFV` tyCoFVsOfType'
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 @@ defaultRuntimeRepVars = go emptyVarEnv
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)
diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs
index 336f122a..c2c0d733 100644
--- a/haddock-api/src/Haddock/Interface.hs
+++ b/haddock-api/src/Haddock/Interface.hs
@@ -59,7 +59,7 @@ import TcRnTypes (tcg_rdr_env)
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 @@ processModules verbosity modules flags extIfaces = do
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 @@ createIfaces verbosity modules flags instIfaceMap = do
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 @@ processModule verbosity modsum flags modMap instIfaceMap = do
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
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index dd6c70a5..35f24ee5 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -194,13 +194,13 @@ instHead (_, _, cls, args)
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 @@ isTypeHidden expInfo = typeHidden
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
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index dd1d4eb3..d5cbdaf5 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE CPP, TupleSections, BangPatterns, LambdaCase #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wwarn #-}
-----------------------------------------------------------------------------
-- |
@@ -52,7 +53,7 @@ import Packages ( lookupModuleInAllPackages, PackageName(..) )
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 @@ moduleWarning dflags gre (WarnAll w) = Just <$> parseWarning dflags gre w
parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> ErrMsgM (Doc Name)
parseWarning dflags gre w = case w of
- DeprecatedTxt _ msg -> format "Deprecated: " (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 @@ subordinates instMap decl = case decl of
, 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 :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])]
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 @@ mkFixMap group_ = M.fromList [ (n,f)
-- | 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 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
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 @@ extractDecl declMap name decl
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 @@ extractDecl declMap name decl
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 @@ extractDecl declMap name decl
, 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 @@ extractDecl declMap name decl
, 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 @@ extractDecl declMap name decl
, 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 @@ extractPatternSyn nm t tvs cons =
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 _ _ _ [] = error "extractRecSel: selector not found"
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 @@ extractRecSel nm t tvs (L _ con : rest) =
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]
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index ceea2444..72d063dc 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -204,14 +204,14 @@ renameMaybeLKind = traverse renameLKind
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 +225,64 @@ renameMaybeInjectivityAnn = traverse renameInjectivityAnn
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 +303,9 @@ renameHsSpliceTy _ = error "renameHsSpliceTy: not an HsSpliced"
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 +353,19 @@ renameDecl :: HsDecl GhcRn -> RnM (HsDecl DocNameI)
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 +376,20 @@ renameTyClD d = case d of
-- 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 +400,13 @@ renameTyClD d = case d of
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 +427,12 @@ renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname
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 +458,11 @@ renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType
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 +473,7 @@ renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars
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 +487,10 @@ renameCon decl@(ConDeclGADT { con_names = lnames, con_qvars = ltyvars
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 +507,8 @@ renameConDeclFieldField (L l (ConDeclField _ names t doc)) = do
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 +521,21 @@ renameSig sig = case sig of
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 +544,25 @@ renameForD :: ForeignDecl GhcRn -> RnM (ForeignDecl DocNameI)
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 +570,11 @@ renameDerivD (DerivDecl { deriv_type = ty
, 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 +589,11 @@ renameClsInstD (ClsInstDecl { cid_overlap_mode = omode
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 +606,8 @@ renameTyFamInstEqn eqn
= 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 +615,16 @@ renameTyFamInstEqn eqn
; 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"
-
-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"
+ rename_ty_fam_eqn (XFamEqn nec) = noExtCon nec
+
+renameTyFamDefltD :: TyFamDefltDecl GhcRn -> RnM (TyFamDefltDecl DocNameI)
+renameTyFamDefltD = renameTyFamInstD
renameDataFamInstD :: DataFamInstDecl GhcRn -> RnM (DataFamInstDecl DocNameI)
renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn })
@@ -642,8 +632,8 @@ renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn })
; 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 +641,13 @@ renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn })
; 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 +655,8 @@ renameImplicit :: (in_thing -> RnM out_thing)
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 +664,8 @@ renameWc :: (in_thing -> RnM out_thing)
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
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index 6fd528af..03cc1b7e 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -76,7 +76,7 @@ specializeSig :: LHsQTyVars GhcRn -> [HsType GhcRn]
-> Sig GhcRn
-> Sig GhcRn
specializeSig bndrs typs (TypeSig _ lnames typ) =
- TypeSig noExt lnames (typ {hswc_body = (hswc_body typ) {hsib_body = noLoc typ'}})
+ 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 @@ sugar = sugarOperators . sugarTuples . sugarLists
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 @@ sugarTuples typ =
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 @@ sugarTuples typ =
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 @@ freeVariables =
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 @@ data RenameEnv name = RenameEnv
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) =
diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs
index 7645b1bb..b5be311a 100644
--- a/haddock-api/src/Haddock/InterfaceFile.hs
+++ b/haddock-api/src/Haddock/InterfaceFile.hs
@@ -82,7 +82,7 @@ binaryInterfaceMagic = 0xD0Cface
-- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion]
--
binaryInterfaceVersion :: Word16
-#if (__GLASGOW_HASKELL__ >= 807) && (__GLASGOW_HASKELL__ < 809)
+#if (__GLASGOW_HASKELL__ >= 809) && (__GLASGOW_HASKELL__ < 811)
binaryInterfaceVersion = 35
binaryInterfaceVersionCompatibility :: [Word16]
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index a72247e6..28e3caed 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -374,8 +374,8 @@ data InstType name
| 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 @@ mkPseudoFamilyDecl (FamilyDecl { .. }) = PseudoFamilyDecl
}
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 @@ instance MonadIO ErrMsgGhc where
-- * 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 XFixitySig DocNameI = NoExt
-type instance XFixSig DocNameI = NoExt
-type instance XPatSynSig DocNameI = NoExt
-type instance XClassOpSig DocNameI = NoExt
-type instance XTypeSig DocNameI = NoExt
-type instance XMinimalSig DocNameI = NoExt
-
-type instance XForeignExport DocNameI = NoExt
-type instance XForeignImport DocNameI = NoExt
-type instance XConDeclGADT DocNameI = NoExt
-type instance XConDeclH98 DocNameI = NoExt
-
-type instance XDerivD DocNameI = NoExt
-type instance XInstD DocNameI = NoExt
-type instance XForD DocNameI = NoExt
-type instance XSigD DocNameI = NoExt
-type instance XTyClD DocNameI = NoExt
-
-type instance XNoSig DocNameI = NoExt
-type instance XCKindSig DocNameI = NoExt
-type instance XTyVarSig DocNameI = NoExt
-
-type instance XCFamEqn DocNameI _ _ = NoExt
-
-type instance XCClsInstDecl DocNameI = NoExt
-type instance XCDerivDecl DocNameI = NoExt
+type instance XXFieldOcc DocNameI = NoExtField
+
+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 = 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 = 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 = NoExtField
+type instance XCKindSig DocNameI = NoExtField
+type instance XTyVarSig DocNameI = NoExtField
+type instance XXFamilyResultSig DocNameI = NoExtCon
+
+type instance XCFamEqn DocNameI _ = NoExtField
+type instance XXFamEqn DocNameI _ = NoExtCon
+
+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 XXPat DocNameI = Located (Pat DocNameI)
-
-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
-
-stripSrcSpanPat :: LPat DocNameI -> Pat DocNameI
-stripSrcSpanPat (XPat (L _ p)) = stripSrcSpanPat p
-stripSrcSpanPat p = p
+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 XHsIB DocNameI _ = NoExtField
+type instance XHsWC DocNameI _ = NoExtField
+type instance XXHsImplicitBndrs DocNameI _ = NoExtCon
+
+type instance XHsQTvs DocNameI = NoExtField
+type instance XConDeclField DocNameI = NoExtField
+type instance XXConDeclField DocNameI = NoExtCon
+
+type instance XXPat DocNameI = NoExtCon
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index 7673f02d..79673365 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -150,17 +150,17 @@ mkEmptySigWcType ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs ty)
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 +170,7 @@ addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine
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 +216,7 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]
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 +232,7 @@ emptyHsQTvs :: LHsQTyVars GhcRn
-- This function is here, rather than in HsTypes, because it *renamed*, but
-- does not necessarily have all the rigt kind variables. It is used
-- in Haddock just for printing, so it doesn't matter
-emptyHsQTvs = HsQTvs { hsq_ext = HsQTvsRn
- { hsq_implicit = error "haddock:emptyHsQTvs"
- , hsq_dependent = error "haddock:emptyHsQTvs" }
+emptyHsQTvs = HsQTvs { hsq_ext = error "haddock:emptyHsQTvs"
, hsq_explicit = [] }
diff --git a/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs b/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs
index 1273a45a..6e065dfb 100644
--- a/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs
+++ b/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs
@@ -19,7 +19,7 @@ import Haddock.Backends.Hyperlinker.Types
withDynFlags :: (DynFlags -> IO ()) -> IO ()
withDynFlags cont = do
libDir <- fmap snd (getGhcDirs [])
- runGhc (Just libDir) $ do
+ runGhc libDir $ do
dflags <- getSessionDynFlags
liftIO $ cont dflags