diff --git a/haddock-api.cabal b/haddock-api.cabal --- a/haddock-api.cabal +++ b/haddock-api.cabal @@ -1,19 +1,19 @@ cabal-version: 2.0 name: haddock-api -version: 2.25.1 +version: 2.26.0 synopsis: A documentation-generation tool for Haskell libraries description: Haddock is a documentation-generation tool for Haskell libraries license: BSD2 license-file: LICENSE author: Simon Marlow, David Waern -maintainer: Hécate Moonlight , Alex Biehl +maintainer: Alec Theriault , Alex Biehl , Simon Hengel , Mateusz Kowalczyk homepage: http://www.haskell.org/haddock/ bug-reports: https://github.com/haskell/haddock/issues copyright: (c) Simon Marlow, David Waern category: Documentation build-type: Simple -tested-with: GHC==9.0.* +tested-with: GHC==9.2.* extra-source-files: CHANGES.md @@ -43,12 +43,11 @@ default-language: Haskell2010 -- this package typically supports only single major versions - build-depends: base ^>= 4.15.0 - , ghc ^>= 9.0 + build-depends: base ^>= 4.16.0 + , ghc ^>= 9.2 , ghc-paths ^>= 0.1.0.9 - , haddock-library ^>= 1.10.0 + , haddock-library ^>= 1.9.0 , xhtml ^>= 3000.2.2 - , parsec ^>= 3.1.13.0 -- Versions for the dependencies below are transitively pinned by -- the non-reinstallable `ghc` package and hence need no version @@ -94,8 +93,6 @@ Haddock.Parser Haddock.Utils Haddock.Utils.Json - Haddock.Utils.Json.Types - Haddock.Utils.Json.Parser Haddock.Backends.Xhtml Haddock.Backends.Xhtml.Decl Haddock.Backends.Xhtml.DocMarkup @@ -172,20 +169,17 @@ Haddock.Types Haddock.Utils Haddock.Utils.Json - Haddock.Utils.Json.Types - Haddock.Utils.Json.Parser Haddock.Version Paths_haddock_api Haddock.Backends.Hyperlinker.ParserSpec Haddock.Backends.Hyperlinker.Parser Haddock.Backends.Hyperlinker.Types - build-depends: ghc ^>= 9.0 + build-depends: ghc ^>= 9.2 , ghc-paths ^>= 0.1.0.12 - , haddock-library ^>= 1.10.0 + , haddock-library ^>= 1.9.0 , xhtml ^>= 3000.2.2 - , hspec >= 2.4.4 && < 2.8 - , parsec ^>= 3.1.13.0 + , hspec ^>= 2.8 , QuickCheck >= 2.11 && ^>= 2.14 -- Versions for the dependencies below are transitively pinned by @@ -200,11 +194,12 @@ , exceptions , filepath , ghc-boot + , ghc-boot-th , mtl , transformers build-tool-depends: - hspec-discover:hspec-discover >= 2.4.4 && < 2.8 + hspec-discover:hspec-discover ^>= 2.8 source-repository head type: git diff --git a/resources/html/haddock-bundle.min.js b/resources/html/haddock-bundle.min.js --- a/resources/html/haddock-bundle.min.js +++ b/resources/html/haddock-bundle.min.js @@ -1,2 +1,2 @@ -!function i(s,a,l){function c(t,e){if(!a[t]){if(!s[t]){var n="function"==typeof require&&require;if(!e&&n)return n(t,!0);if(u)return u(t,!0);var o=new Error("Cannot find module '"+t+"'");throw o.code="MODULE_NOT_FOUND",o}var r=a[t]={exports:{}};s[t][0].call(r.exports,function(e){return c(s[t][1][e]||e)},r,r.exports,i,s,a,l)}return a[t].exports}for(var u="function"==typeof require&&require,e=0;e element with id '"+e+"'");return t}function x(){return u.defaultInstanceState==i.Open}function w(e){for(var t=S(e.target.id),n=t.element.open,o=0,r=t.toggles;owindow.innerHeight?this.searchResults.scrollTop+=e.bottom-window.innerHeight+80:e.topn)return u(e,this.pattern,o);var r=this.options,i=r.location,s=r.distance,a=r.threshold,l=r.findAllMatches,c=r.minMatchCharLength;return d(e,this.pattern,this.patternAlphabet,{location:i,distance:s,threshold:a,findAllMatches:l,minMatchCharLength:c})}}]),y}();e.exports=r},function(e,t,n){"use strict";var u=n(0);e.exports=function(e,t){return function e(t,n,o){if(n){var r=n.indexOf("."),i=n,s=null;-1!==r&&(i=n.slice(0,r),s=n.slice(r+1));var a=t[i];if(null!=a)if(s||"string"!=typeof a&&"number"!=typeof a)if(u(a))for(var l=0,c=a.length;l 0 and <= 1");p=p.name}else a[p]={weight:1};this._analyze({key:p,value:this.options.getFn(u,p),record:u,index:l},{resultMap:o,results:r,tokenSearchers:e,fullSearcher:t})}return{weights:a,results:r}}},{key:"_analyze",value:function(e,t){var n=e.key,o=e.arrayIndex,r=void 0===o?-1:o,i=e.value,s=e.record,a=e.index,l=t.tokenSearchers,c=void 0===l?[]:l,u=t.fullSearcher,d=void 0===u?[]:u,h=t.resultMap,p=void 0===h?{}:h,f=t.results,v=void 0===f?[]:f;if(null!=i){var g=!1,m=-1,y=0;if("string"==typeof i){this._log("\nKey: "+(""===n?"-":n));var _=d.search(i);if(this._log('Full text: "'+i+'", score: '+_.score),this.options.tokenize){for(var b=i.split(this.options.tokenSeparator),k=[],S=0;S=c.length;if(this._log("\nCheck Matches: "+T),(g||_.isMatch)&&T){var N=p[a];N?N.output.push({key:n,arrayIndex:r,value:i,score:A,matchedIndices:_.matchedIndices}):(p[a]={item:s,output:[{key:n,arrayIndex:r,value:i,score:A,matchedIndices:_.matchedIndices}]},v.push(p[a]))}}else if(V(i))for(var P=0,j=i.length;P element with id '"+e+"'");return t}function x(){return u.defaultInstanceState==i.Open}function w(e){for(var t=S(e.target.id),n=t.element.open,o=0,r=t.toggles;owindow.innerHeight?this.searchResults.scrollTop+=e.bottom-window.innerHeight+80:e.topn)return u(e,this.pattern,o);var r=this.options,i=r.location,s=r.distance,a=r.threshold,l=r.findAllMatches,c=r.minMatchCharLength;return d(e,this.pattern,this.patternAlphabet,{location:i,distance:s,threshold:a,findAllMatches:l,minMatchCharLength:c})}}]),y}();e.exports=r},function(e,t,n){"use strict";var u=n(0);e.exports=function(e,t){return function e(t,n,o){if(n){var r=n.indexOf("."),i=n,s=null;-1!==r&&(i=n.slice(0,r),s=n.slice(r+1));var a=t[i];if(null!=a)if(s||"string"!=typeof a&&"number"!=typeof a)if(u(a))for(var l=0,c=a.length;l 0 and <= 1");p=p.name}else a[p]={weight:1};this._analyze({key:p,value:this.options.getFn(u,p),record:u,index:l},{resultMap:o,results:r,tokenSearchers:e,fullSearcher:t})}return{weights:a,results:r}}},{key:"_analyze",value:function(e,t){var n=e.key,o=e.arrayIndex,r=void 0===o?-1:o,i=e.value,s=e.record,a=e.index,l=t.tokenSearchers,c=void 0===l?[]:l,u=t.fullSearcher,d=void 0===u?[]:u,h=t.resultMap,p=void 0===h?{}:h,f=t.results,v=void 0===f?[]:f;if(null!=i){var g=!1,m=-1,y=0;if("string"==typeof i){this._log("\nKey: "+(""===n?"-":n));var _=d.search(i);if(this._log('Full text: "'+i+'", score: '+_.score),this.options.tokenize){for(var b=i.split(this.options.tokenSeparator),k=[],S=0;S=c.length;if(this._log("\nCheck Matches: "+T),(g||_.isMatch)&&T){var N=p[a];N?N.output.push({key:n,arrayIndex:r,value:i,score:A,matchedIndices:_.matchedIndices}):(p[a]={item:s,output:[{key:n,arrayIndex:r,value:i,score:A,matchedIndices:_.matchedIndices}]},v.push(p[a]))}}else if(V(i))for(var P=0,j=i.length;P getSession forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do mIfaceFile <- readInterfaceFiles freshNameCache [(("", Nothing), path)] noChecks - forM_ mIfaceFile $ \(_, _, ifaceFile) -> do - logOutput dflags $ withPprStyle defaultUserStyle (renderJson (jsonInterfaceFile ifaceFile)) + forM_ mIfaceFile $ \(_, ifaceFile) -> do + putMsg logger dflags $ renderJson (jsonInterfaceFile ifaceFile) if not (null files) then do (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files @@ -206,7 +203,7 @@ } -- Render the interfaces. - liftIO $ renderStep dflags flags sinceQual qual packages ifaces + liftIO $ renderStep logger dflags unit_state flags sinceQual qual packages ifaces else do when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $ @@ -216,7 +213,7 @@ packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags) noChecks -- Render even though there are no input files (usually contents/index). - liftIO $ renderStep dflags flags sinceQual qual packages [] + liftIO $ renderStep logger dflags unit_state flags sinceQual qual packages [] -- | Run the GHC action using a temporary output directory withTempOutputDir :: Ghc a -> Ghc a @@ -252,65 +249,48 @@ readPackagesAndProcessModules :: [Flag] -> [String] - -> Ghc ([(DocPaths, FilePath, InterfaceFile)], [Interface], LinkEnv) + -> Ghc ([(DocPaths, InterfaceFile)], [Interface], LinkEnv) readPackagesAndProcessModules flags files = do -- Get packages supplied with --read-interface. let noChecks = Flag_BypassInterfaceVersonCheck `elem` flags packages <- readInterfaceFiles nameCacheFromGhc (readIfaceArgs flags) noChecks -- Create the interfaces -- this is the core part of Haddock. - let ifaceFiles = map (\(_, _, ifaceFile) -> ifaceFile) packages + let ifaceFiles = map snd packages (ifaces, homeLinks) <- processModules (verbosity flags) files flags ifaceFiles return (packages, ifaces, homeLinks) -renderStep :: DynFlags -> [Flag] -> SinceQual -> QualOption - -> [(DocPaths, FilePath, InterfaceFile)] -> [Interface] -> IO () -renderStep dflags flags sinceQual nameQual pkgs interfaces = do - updateHTMLXRefs (map (\(docPath, _ifaceFilePath, ifaceFile) -> - ( case baseUrl flags of - Nothing -> fst docPath - Just url -> Debug.traceShowId $ - url packageName (unitState dflags) (ifUnitId ifaceFile) - , ifaceFile)) pkgs) +renderStep :: Logger -> DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption + -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO () +renderStep logger dflags unit_state flags sinceQual nameQual pkgs interfaces = do + updateHTMLXRefs pkgs let - installedIfaces = - concatMap - (\(_, ifaceFilePath, ifaceFile) - -> (ifaceFilePath,) <$> ifInstalledIfaces ifaceFile) - pkgs + ifaceFiles = map snd pkgs + installedIfaces = concatMap ifInstalledIfaces ifaceFiles extSrcMap = Map.fromList $ do - ((_, Just path), _, ifile) <- pkgs + ((_, Just path), ifile) <- pkgs iface <- ifInstalledIfaces ifile return (instMod iface, path) - render dflags flags sinceQual nameQual interfaces installedIfaces extSrcMap - where - -- get package name from unit-id - packageName :: UnitState -> Unit -> String - packageName state unit = - case lookupUnit state unit of - Nothing -> show unit - Just pkg -> unitPackageNameString pkg + render logger dflags unit_state flags sinceQual nameQual interfaces installedIfaces extSrcMap -- | Render the interfaces with whatever backend is specified in the flags. -render :: DynFlags -> [Flag] -> SinceQual -> QualOption -> [Interface] - -> [(FilePath, InstalledInterface)] -> Map Module FilePath -> IO () -render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do +render :: Logger -> DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption -> [Interface] + -> [InstalledInterface] -> Map Module FilePath -> IO () +render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extSrcMap = do let title = fromMaybe "" (optTitle flags) unicode = Flag_UseUnicode `elem` flags pretty = Flag_PrettyHtml `elem` flags opt_wiki_urls = wikiUrls flags - opt_base_url = baseUrl flags opt_contents_url = optContentsUrl flags opt_index_url = optIndexUrl flags odir = outputDir flags opt_latex_style = optLaTeXStyle flags opt_source_css = optSourceCssFile flags opt_mathjax = optMathjax flags - pkgs = unitState dflags dflags' | unicode = gopt_set dflags Opt_PrintUnicodeSyntax | otherwise = dflags @@ -318,13 +298,13 @@ visibleIfaces = [ i | i <- ifaces, OptHide `notElem` ifaceOptions i ] -- /All/ visible interfaces including external package modules. - allIfaces = map toInstalledIface ifaces ++ map snd installedIfaces + allIfaces = map toInstalledIface ifaces ++ installedIfaces allVisibleIfaces = [ i | i <- allIfaces, OptHide `notElem` instOptions i ] pkgMod = fmap ifaceMod (listToMaybe ifaces) pkgKey = fmap moduleUnit pkgMod pkgStr = fmap unitString pkgKey - pkgNameVer = modulePackageInfo dflags flags pkgMod + pkgNameVer = modulePackageInfo unit_state flags pkgMod pkgName = fmap (unpackFS . (\(PackageName n) -> n)) (fst pkgNameVer) sincePkg = case sinceQual of External -> pkgName @@ -363,13 +343,13 @@ sourceUrls' = (srcBase, srcModule', pkgSrcMap', pkgSrcLMap') installedMap :: Map Module InstalledInterface - installedMap = Map.fromList [ (unwire (instMod iface), iface) | (_, iface) <- installedIfaces ] + installedMap = Map.fromList [ (unwire (instMod iface), iface) | iface <- installedIfaces ] -- The user gives use base-4.9.0.0, but the InstalledInterface -- records the *wired in* identity base. So untranslate it -- so that we can service the request. unwire :: Module -> Module - unwire m = m { moduleUnit = unwireUnit (unitState dflags) (moduleUnit m) } + unwire m = m { moduleUnit = unwireUnit unit_state (moduleUnit m) } reexportedIfaces <- concat `fmap` (for (reexportFlags flags) $ \mod_str -> do let warn = hPutStrLn stderr . ("Warning: " ++) @@ -386,53 +366,38 @@ themes <- getThemes libDir flags >>= either bye return let withQuickjump = Flag_QuickJumpIndex `elem` flags - withBaseURL = isJust - . find (\flag -> case flag of - Flag_BaseURL base_url -> - base_url /= "." && base_url /= "./" - _ -> False - ) - $ flags when (Flag_GenIndex `elem` flags) $ do - withTiming dflags' "ppHtmlIndex" (const ()) $ do + withTiming logger dflags' "ppHtmlIndex" (const ()) $ do _ <- {-# SCC ppHtmlIndex #-} ppHtmlIndex odir title pkgStr themes opt_mathjax opt_contents_url sourceUrls' opt_wiki_urls allVisibleIfaces pretty return () - unless withBaseURL $ - copyHtmlBits odir libDir themes withQuickjump + copyHtmlBits odir libDir themes withQuickjump when (Flag_GenContents `elem` flags) $ do - withTiming dflags' "ppHtmlContents" (const ()) $ do + withTiming logger dflags' "ppHtmlContents" (const ()) $ do _ <- {-# SCC ppHtmlContents #-} - ppHtmlContents pkgs odir title pkgStr + ppHtmlContents unit_state odir title pkgStr themes opt_mathjax opt_index_url sourceUrls' opt_wiki_urls allVisibleIfaces True prologue pretty sincePkg (makeContentsQual qual) return () copyHtmlBits odir libDir themes withQuickjump - when withQuickjump $ void $ - ppJsonIndex odir sourceUrls' opt_wiki_urls - unicode Nothing qual - ifaces - (nub $ map fst installedIfaces) - when (Flag_Html `elem` flags) $ do - withTiming dflags' "ppHtml" (const ()) $ do + withTiming logger dflags' "ppHtml" (const ()) $ do _ <- {-# SCC ppHtml #-} - ppHtml pkgs title pkgStr visibleIfaces reexportedIfaces odir + ppHtml unit_state title pkgStr visibleIfaces reexportedIfaces odir prologue - themes opt_mathjax sourceUrls' opt_wiki_urls opt_base_url + themes opt_mathjax sourceUrls' opt_wiki_urls opt_contents_url opt_index_url unicode sincePkg qual pretty withQuickjump return () - unless withBaseURL $ do - copyHtmlBits odir libDir themes withQuickjump - writeHaddockMeta odir withQuickjump + copyHtmlBits odir libDir themes withQuickjump + writeHaddockMeta odir withQuickjump -- TODO: we throw away Meta for both Hoogle and LaTeX right now, -- might want to fix that if/when these two get some work on them @@ -445,7 +410,7 @@ pkgVer = fromMaybe (makeVersion []) mpkgVer - in ppHoogle dflags' pkgNameStr pkgVer title (fmap _doc prologue) + in ppHoogle dflags' unit_state pkgNameStr pkgVer title (fmap _doc prologue) visibleIfaces odir _ -> putStrLn . unlines $ [ "haddock: Unable to find a package providing module " @@ -458,14 +423,14 @@ ] when (Flag_LaTeX `elem` flags) $ do - withTiming dflags' "ppLatex" (const ()) $ do + withTiming logger 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 dflags' "ppHyperlinkedSource" (const ()) $ do + withTiming logger dflags' "ppHyperlinkedSource" (const ()) $ do _ <- {-# SCC ppHyperlinkedSource #-} ppHyperlinkedSource (verbosity flags) odir libDir opt_source_css pretty srcMap ifaces return () @@ -480,7 +445,7 @@ => NameCacheAccessor m -> [(DocPaths, FilePath)] -> Bool - -> m [(DocPaths, FilePath, InterfaceFile)] + -> m [(DocPaths, InterfaceFile)] readInterfaceFiles name_cache_accessor pairs bypass_version_check = do catMaybes `liftM` mapM ({-# SCC readInterfaceFile #-} tryReadIface) pairs where @@ -492,7 +457,7 @@ putStrLn (" " ++ err) putStrLn "Skipping this interface." return Nothing - Right f -> return (Just (paths, file, f)) + Right f -> return $ Just (paths, f) ------------------------------------------------------------------------------- @@ -504,7 +469,8 @@ -- compilation and linking. Then run the given 'Ghc' action. withGhc' :: String -> Bool -> [String] -> (DynFlags -> Ghc a) -> IO a withGhc' libDir needHieFiles flags ghcActs = runGhc (Just libDir) $ do - dynflags' <- parseGhcFlags =<< getSessionDynFlags + logger <- getLogger + dynflags' <- parseGhcFlags logger =<< getSessionDynFlags -- We disable pattern match warnings because than can be very -- expensive to check @@ -528,20 +494,20 @@ go arg func True = arg : func True - parseGhcFlags :: MonadIO m => DynFlags -> m DynFlags - parseGhcFlags dynflags = do + parseGhcFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags + parseGhcFlags logger dynflags = do -- TODO: handle warnings? let extra_opts | needHieFiles = [Opt_WriteHie, Opt_Haddock] | otherwise = [Opt_Haddock] dynflags' = (foldl' gopt_set dynflags extra_opts) - { hscTarget = HscNothing - , ghcMode = CompManager - , ghcLink = NoLink + { backend = NoBackend + , ghcMode = CompManager + , ghcLink = NoLink } flags' = filterRtsFlags flags - (dynflags'', rest, _) <- parseDynamicFlags dynflags' (map noLoc flags') + (dynflags'', rest, _) <- parseDynamicFlags logger dynflags' (map noLoc flags') if not (null rest) then throwE ("Couldn't parse GHC options: " ++ unwords flags') else return dynflags'' @@ -712,12 +678,12 @@ isSourceCssFlag _ = False -updateHTMLXRefs :: [(FilePath, InterfaceFile)] -> IO () +updateHTMLXRefs :: [(DocPaths, InterfaceFile)] -> IO () updateHTMLXRefs packages = do writeIORef html_xrefs_ref (Map.fromList mapping) writeIORef html_xrefs_ref' (Map.fromList mapping') where - mapping = [ (instMod iface, html) | (html, ifaces) <- packages + mapping = [ (instMod iface, html) | ((html, _), ifaces) <- packages , iface <- ifInstalledIfaces ifaces ] mapping' = [ (moduleName m, html) | (m, html) <- mapping ] diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs --- a/src/Haddock/Backends/Hoogle.hs +++ b/src/Haddock/Backends/Hoogle.hs @@ -18,8 +18,9 @@ ppHoogle ) where -import GHC.Types.Basic ( OverlapFlag(..), OverlapMode(..), SourceText(..) - , PromotionFlag(..), TopLevelFlag(..) ) +import GHC.Types.Basic ( OverlapFlag(..), OverlapMode(..), + PromotionFlag(..), TopLevelFlag(..) ) +import GHC.Types.SourceText import GHC.Core.InstEnv (ClsInst(..)) import Documentation.Haddock.Markup import Haddock.GhcUtils @@ -27,8 +28,11 @@ import Haddock.Utils hiding (out) import GHC +import GHC.Driver.Ppr import GHC.Utils.Outputable as Outputable +import GHC.Utils.Panic import GHC.Parser.Annotation (IsUnicodeSyntax(..)) +import GHC.Unit.State import Data.Char import Data.List (intercalate, isPrefixOf) @@ -37,15 +41,14 @@ import System.Directory import System.FilePath - prefix :: [String] prefix = ["-- Hoogle documentation, generated by Haddock" ,"-- See Hoogle, http://www.haskell.org/hoogle/" ,""] -ppHoogle :: DynFlags -> String -> Version -> String -> Maybe (Doc RdrName) -> [Interface] -> FilePath -> IO () -ppHoogle dflags package version synopsis prologue ifaces odir = do +ppHoogle :: DynFlags -> UnitState -> String -> Version -> String -> Maybe (Doc RdrName) -> [Interface] -> FilePath -> IO () +ppHoogle dflags unit_state package version synopsis prologue ifaces odir = do let -- Since Hoogle is line based, we want to avoid breaking long lines. dflags' = dflags{ pprCols = maxBound } filename = package ++ ".txt" @@ -54,44 +57,47 @@ ["@package " ++ package] ++ ["@version " ++ showVersion version | not (null (versionBranch version)) ] ++ - concat [ppModule dflags' i | i <- ifaces, OptHide `notElem` ifaceOptions i] + concat [ppModule dflags' unit_state i | i <- ifaces, OptHide `notElem` ifaceOptions i] createDirectoryIfMissing True odir writeUtf8File (odir filename) (unlines contents) -ppModule :: DynFlags -> Interface -> [String] -ppModule dflags iface = +ppModule :: DynFlags -> UnitState -> Interface -> [String] +ppModule dflags unit_state iface = "" : ppDocumentation dflags (ifaceDoc iface) ++ ["module " ++ moduleString (ifaceMod iface)] ++ concatMap (ppExport dflags) (ifaceExportItems iface) ++ - concatMap (ppInstance dflags) (ifaceInstances iface) + concatMap (ppInstance dflags unit_state) (ifaceInstances iface) --------------------------------------------------------------------- -- Utility functions -dropHsDocTy :: HsType a -> HsType a -dropHsDocTy = f +dropHsDocTy :: HsSigType GhcRn -> HsSigType GhcRn +dropHsDocTy = drop_sig_ty where - g (L src x) = L src (f x) - f (HsForAllTy x a e) = HsForAllTy x a (g e) - f (HsQualTy x a e) = HsQualTy x a (g e) - f (HsBangTy x a b) = HsBangTy x a (g b) - f (HsAppTy x a b) = HsAppTy x (g a) (g b) - f (HsAppKindTy x a b) = HsAppKindTy x (g a) (g b) - f (HsFunTy x w a b) = HsFunTy x w (g a) (g b) - f (HsListTy x a) = HsListTy x (g a) - f (HsTupleTy x a b) = HsTupleTy x a (map g b) - f (HsOpTy x a b c) = HsOpTy x (g a) b (g c) - f (HsParTy x a) = HsParTy x (g a) - f (HsKindSig x a b) = HsKindSig x (g a) b - f (HsDocTy _ a _) = f $ unLoc a - f x = x + drop_sig_ty (HsSig x a b) = HsSig x a (drop_lty b) + drop_sig_ty x@XHsSigType{} = x -outHsType :: (OutputableBndrId p) - => DynFlags -> HsType (GhcPass p) -> String -outHsType dflags = out dflags . reparenType . dropHsDocTy + drop_lty (L src x) = L src (drop_ty x) + drop_ty (HsForAllTy x a e) = HsForAllTy x a (drop_lty e) + drop_ty (HsQualTy x a e) = HsQualTy x a (drop_lty e) + drop_ty (HsBangTy x a b) = HsBangTy x a (drop_lty b) + drop_ty (HsAppTy x a b) = HsAppTy x (drop_lty a) (drop_lty b) + drop_ty (HsAppKindTy x a b) = HsAppKindTy x (drop_lty a) (drop_lty b) + drop_ty (HsFunTy x w a b) = HsFunTy x w (drop_lty a) (drop_lty b) + drop_ty (HsListTy x a) = HsListTy x (drop_lty a) + drop_ty (HsTupleTy x a b) = HsTupleTy x a (map drop_lty b) + drop_ty (HsOpTy x a b c) = HsOpTy x (drop_lty a) b (drop_lty c) + drop_ty (HsParTy x a) = HsParTy x (drop_lty a) + drop_ty (HsKindSig x a b) = HsKindSig x (drop_lty a) b + drop_ty (HsDocTy _ a _) = drop_ty $ unL a + drop_ty x = x +outHsSigType :: DynFlags -> HsSigType GhcRn -> String +outHsSigType dflags = out dflags . reparenSigType . dropHsDocTy + + dropComment :: String -> String dropComment (' ':'-':'-':' ':_) = [] dropComment (x:xs) = x : dropComment xs @@ -106,14 +112,14 @@ f [] = [] out :: Outputable a => DynFlags -> a -> String -out dflags = outWith $ showSDocUnqual dflags +out dflags = outWith $ showSDoc dflags operator :: String -> String operator (x:xs) | not (isAlphaNum x) && x `notElem` "_' ([{" = '(' : x:xs ++ ")" operator x = x commaSeparate :: Outputable a => DynFlags -> [a] -> String -commaSeparate dflags = showSDocUnqual dflags . interpp'SP +commaSeparate dflags = showSDoc dflags . interpp'SP --------------------------------------------------------------------- -- How to print each export @@ -133,8 +139,8 @@ f (TyClD _ d@SynDecl{}) = ppSynonym dflags d f (TyClD _ d@ClassDecl{}) = ppClass dflags d subdocs f (TyClD _ (FamDecl _ d)) = ppFam dflags d - f (ForD _ (ForeignImport _ name typ _)) = [pp_sig dflags [name] (hsSigType typ)] - f (ForD _ (ForeignExport _ name typ _)) = [pp_sig dflags [name] (hsSigType typ)] + f (ForD _ (ForeignImport _ name typ _)) = [pp_sig dflags [name] typ] + f (ForD _ (ForeignExport _ name typ _)) = [pp_sig dflags [name] typ] f (SigD _ sig) = ppSig dflags sig f _ = [] @@ -143,19 +149,19 @@ ppSigWithDoc :: DynFlags -> Sig GhcRn -> [(Name, DocForDecl Name)] -> [String] ppSigWithDoc dflags sig subdocs = case sig of - TypeSig _ names t -> concatMap (mkDocSig "" (hsSigWcType t)) names - PatSynSig _ names t -> concatMap (mkDocSig "pattern " (hsSigType t)) names + TypeSig _ names t -> concatMap (mkDocSig "" (dropWildCards t)) names + PatSynSig _ names t -> concatMap (mkDocSig "pattern " t) names _ -> [] where - mkDocSig leader typ n = mkSubdoc dflags n subdocs - [leader ++ pp_sig dflags [n] typ] + mkDocSig leader typ n = mkSubdocN dflags n subdocs + [leader ++ pp_sig dflags [n] typ] ppSig :: DynFlags -> Sig GhcRn -> [String] ppSig dflags x = ppSigWithDoc dflags x [] -pp_sig :: DynFlags -> [Located Name] -> LHsType GhcRn -> String +pp_sig :: DynFlags -> [LocatedN Name] -> LHsSigType GhcRn -> String pp_sig dflags names (L _ typ) = - operator prettyNames ++ " :: " ++ outHsType dflags typ + operator prettyNames ++ " :: " ++ outHsSigType dflags typ where prettyNames = intercalate ", " $ map (out dflags) names @@ -173,14 +179,14 @@ ppTyFams | null $ tcdATs decl = "" - | otherwise = (" " ++) . showSDocUnqual dflags . whereWrapper $ concat + | otherwise = (" " ++) . showSDoc dflags . whereWrapper $ concat [ map pprTyFam (tcdATs decl) , map (pprTyFamInstDecl NotTopLevel . unLoc) (tcdATDefs decl) ] pprTyFam :: LFamilyDecl GhcRn -> SDoc pprTyFam (L _ at) = vcat' $ map text $ - mkSubdoc dflags (fdLName at) subdocs (ppFam dflags at) + mkSubdocN dflags (fdLName at) subdocs (ppFam dflags at) whereWrapper elems = vcat' [ text "where" <+> lbrace @@ -198,9 +204,9 @@ ClosedTypeFamily{} -> decl { fdInfo = OpenTypeFamily } _ -> decl -ppInstance :: DynFlags -> ClsInst -> [String] -ppInstance dflags x = - [dropComment $ outWith (showSDocForUser dflags alwaysQualify) cls] +ppInstance :: DynFlags -> UnitState -> ClsInst -> [String] +ppInstance dflags unit_state x = + [dropComment $ outWith (showSDocForUser dflags unit_state alwaysQualify) cls] where -- As per #168, we don't want safety information about the class -- in Hoogle output. The easiest way to achieve this is to set the @@ -215,7 +221,7 @@ ppData :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> [String] ppData dflags decl@(DataDecl { tcdDataDefn = defn }) subdocs - = showData decl{ tcdDataDefn = defn { dd_cons=[],dd_derivs=noLoc [] }} : + = showData decl{ tcdDataDefn = defn { dd_cons=[],dd_derivs=[] }} : concatMap (ppCtor dflags decl subdocs . unLoc) (dd_cons defn) where @@ -228,50 +234,61 @@ ppData _ _ _ = panic "ppData" -- | for constructors, and named-fields... -lookupCon :: DynFlags -> [(Name, DocForDecl Name)] -> Located Name -> [String] +lookupCon :: DynFlags -> [(Name, DocForDecl Name)] -> LocatedN Name -> [String] lookupCon dflags subdocs (L _ name) = case lookup name subdocs of Just (d, _) -> ppDocumentation dflags d _ -> [] ppCtor :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> ConDecl GhcRn -> [String] -ppCtor dflags dat subdocs con@ConDeclH98 {} +ppCtor dflags dat subdocs con@ConDeclH98 { con_args = con_args' } -- AZ:TODO get rid of the concatMap - = concatMap (lookupCon dflags subdocs) [con_name con] ++ f (getConArgs con) + = concatMap (lookupCon dflags subdocs) [con_name con] ++ f con_args' where - f (PrefixCon args) = [typeSig name $ (map hsScaledThing args) ++ [resType]] - f (InfixCon a1 a2) = f $ PrefixCon [a1,a2] - f (RecCon (L _ recs)) = f (PrefixCon $ map (hsLinear . cd_fld_type . unLoc) recs) ++ concat - [(concatMap (lookupCon dflags subdocs . noLoc . extFieldOcc . unLoc) (cd_fld_names r)) ++ + f (PrefixCon _ args) = [typeSig name $ (map hsScaledThing args) ++ [resType]] + f (InfixCon a1 a2) = f $ PrefixCon [] [a1,a2] + f (RecCon (L _ recs)) = f (PrefixCon [] $ map (hsLinear . cd_fld_type . unLoc) recs) ++ concat + [(concatMap (lookupCon dflags subdocs . noLocA . extFieldOcc . unLoc) (cd_fld_names r)) ++ [out dflags (map (extFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]] | r <- map unLoc recs] - funs = foldr1 (\x y -> reL $ HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) x y) + funs = foldr1 (\x y -> reL $ HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) x y) apps = foldl1 (\x y -> reL $ HsAppTy noExtField x y) - typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds) + typeSig nm flds = operator nm ++ " :: " ++ + outHsSigType dflags (unL $ mkEmptySigType $ funs flds) -- We print the constructors as comma-separated list. See GHC -- docs for con_names on why it is a list to begin with. - name = commaSeparate dflags . map unLoc $ getConNames con + name = commaSeparate dflags . map unL $ getConNames con - tyVarArg (UserTyVar _ _ n) = HsTyVar noExtField NotPromoted n - tyVarArg (KindedTyVar _ _ n lty) = HsKindSig noExtField (reL (HsTyVar noExtField NotPromoted n)) lty + tyVarArg (UserTyVar _ _ n) = HsTyVar noAnn NotPromoted n + tyVarArg (KindedTyVar _ _ n lty) = HsKindSig noAnn (reL (HsTyVar noAnn NotPromoted n)) lty tyVarArg _ = panic "ppCtor" resType = apps $ map reL $ - (HsTyVar noExtField NotPromoted (reL (tcdName dat))) : + (HsTyVar noAnn NotPromoted (reL (tcdName dat))) : map (tyVarArg . unLoc) (hsQTvExplicit $ tyClDeclTyVars dat) -ppCtor dflags _dat subdocs con@(ConDeclGADT { }) - = concatMap (lookupCon dflags subdocs) (getConNames con) ++ f +ppCtor dflags _dat subdocs (ConDeclGADT { con_names = names + , con_bndrs = L _ outer_bndrs + , con_mb_cxt = mcxt + , con_g_args = args + , con_res_ty = res_ty }) + = concatMap (lookupCon dflags subdocs) names ++ [typeSig] where - f = [typeSig name (getGADTConTypeG con)] - - typeSig nm ty = operator nm ++ " :: " ++ outHsType dflags (unLoc ty) - name = out dflags $ map unLoc $ getConNames con + typeSig = operator name ++ " :: " ++ outHsSigType dflags con_sig_ty + name = out dflags $ map unL names + con_sig_ty = HsSig noExtField outer_bndrs theta_ty where + theta_ty = case mcxt of + Just theta -> noLocA (HsQualTy { hst_xqual = noExtField, hst_ctxt = Just theta, hst_body = tau_ty }) + Nothing -> tau_ty + tau_ty = foldr mkFunTy res_ty $ + case args of PrefixConGADT pos_args -> map hsScaledThing pos_args + RecConGADT (L _ flds) -> map (cd_fld_type . unL) flds + mkFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) a b) ppFixity :: DynFlags -> (Name, Fixity) -> [String] -ppFixity dflags (name, fixity) = [out dflags ((FixitySig noExtField [noLoc name] fixity) :: FixitySig GhcRn)] +ppFixity dflags (name, fixity) = [out dflags ((FixitySig noExtField [noLocA name] fixity) :: FixitySig GhcRn)] --------------------------------------------------------------------- @@ -294,7 +311,10 @@ lines header ++ ["" | header /= "" && isJust d] ++ maybe [] (showTags . markup (markupTag dflags)) d -mkSubdoc :: DynFlags -> Located Name -> [(Name, DocForDecl Name)] -> [String] -> [String] +mkSubdocN :: DynFlags -> LocatedN Name -> [(Name, DocForDecl Name)] -> [String] -> [String] +mkSubdocN dflags n subdocs s = mkSubdoc dflags (n2l n) subdocs s + +mkSubdoc :: DynFlags -> LocatedA Name -> [(Name, DocForDecl Name)] -> [String] -> [String] mkSubdoc dflags n subdocs s = concatMap (ppDocumentation dflags) getDoc ++ s where getDoc = maybe [] (return . fst) (lookup (unLoc n) subdocs) diff --git a/src/Haddock/Backends/Hyperlinker.hs b/src/Haddock/Backends/Hyperlinker.hs --- a/src/Haddock/Backends/Hyperlinker.hs +++ b/src/Haddock/Backends/Hyperlinker.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} module Haddock.Backends.Hyperlinker ( ppHyperlinkedSource , module Haddock.Backends.Hyperlinker.Types @@ -18,7 +19,7 @@ import System.Directory import System.FilePath -import GHC.Iface.Ext.Types ( HieFile(..), HieASTs(..), HieAST(..), SourcedNodeInfo(..) ) +import GHC.Iface.Ext.Types ( pattern HiePath, HieFile(..), HieASTs(..), HieAST(..), SourcedNodeInfo(..) ) import GHC.Iface.Ext.Binary ( readHieFile, hie_file_result, NameCacheUpdater(..)) import GHC.Types.SrcLoc ( realSrcLocSpan, mkRealSrcLoc ) import Data.Map as M @@ -70,10 +71,10 @@ -- Get the AST and tokens corresponding to the source file we want let fileFs = mkFastString file mast | M.size asts == 1 = snd <$> M.lookupMin asts - | otherwise = M.lookup fileFs asts + | otherwise = M.lookup (HiePath (mkFastString file)) asts + tokens = parse df file rawSrc ast = fromMaybe (emptyHieAst fileFs) mast fullAst = recoverFullIfaceTypes df types ast - tokens = parse df file rawSrc -- Warn if we didn't find an AST, but there were still ASTs if M.null asts diff --git a/src/Haddock/Backends/Hyperlinker/Parser.hs b/src/Haddock/Backends/Hyperlinker/Parser.hs --- a/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -10,15 +10,18 @@ import qualified Data.ByteString as BS -import GHC.Types.Basic ( IntegralLit(..) ) +import GHC.Types.SourceText import GHC.Driver.Session -import GHC.Utils.Error ( pprLocErrMsg ) +import GHC.Utils.Error ( pprLocMsgEnvelope ) import GHC.Data.FastString ( mkFastString ) +import GHC.Parser.Errors.Ppr ( pprError ) import GHC.Parser.Lexer as Lexer ( P(..), ParseResult(..), PState(..), Token(..) - , mkPStatePure, lexer, mkParserFlags', getErrorMessages) + , initParserState, lexer, mkParserOpts, getErrorMessages) import GHC.Data.Bag ( bagToList ) -import GHC.Utils.Outputable ( showSDoc, panic, text, ($$) ) +import GHC.Utils.Outputable ( text, ($$) ) +import GHC.Utils.Panic ( panic ) +import GHC.Driver.Ppr ( showSDoc ) import GHC.Types.SrcLoc import GHC.Data.StringBuffer ( StringBuffer, atEnd ) @@ -37,17 +40,16 @@ parse dflags fpath bs = case unP (go False []) initState of POk _ toks -> reverse toks PFailed pst -> - let err:_ = bagToList (getErrorMessages pst dflags) in + let err:_ = bagToList (fmap pprError (getErrorMessages pst)) in panic $ showSDoc dflags $ - text "Hyperlinker parse error:" $$ pprLocErrMsg err + text "Hyperlinker parse error:" $$ pprLocMsgEnvelope err where - initState = mkPStatePure pflags buf start + initState = initParserState pflags buf start buf = stringBufferFromByteString bs start = mkRealSrcLoc (mkFastString fpath) 1 1 - pflags = mkParserFlags' (warningFlags dflags) + pflags = mkParserOpts (warningFlags dflags) (extensionFlags dflags) - (homeUnitId dflags) (safeImportsOn dflags) False -- lex Haddocks as comment tokens True -- produce comment tokens @@ -240,7 +242,6 @@ ITline_prag {} -> TkPragma ITcolumn_prag {} -> TkPragma ITscc_prag {} -> TkPragma - ITgenerated_prag {} -> TkPragma ITunpack_prag {} -> TkPragma ITnounpack_prag {} -> TkPragma ITann_prag {} -> TkPragma @@ -273,6 +274,7 @@ ITprefixminus -> TkGlyph ITbang -> TkGlyph ITdot -> TkOperator + ITproj {} -> TkOperator ITstar {} -> TkOperator ITtypeApp -> TkGlyph ITpercent -> TkGlyph @@ -358,7 +360,7 @@ -- the GHC lexer for more), so we have to manually reverse this. The -- following is a hammer: it smashes _all_ pragma-like block comments into -- pragmas. - ITblockComment c + ITblockComment c _ | isPrefixOf "{-#" c , isSuffixOf "#-}" c -> TkPragma | otherwise -> TkComment @@ -381,7 +383,6 @@ ITline_prag {} -> True ITcolumn_prag {} -> True ITscc_prag {} -> True - ITgenerated_prag {} -> True ITunpack_prag {} -> True ITnounpack_prag {} -> True ITann_prag {} -> True diff --git a/src/Haddock/Backends/Hyperlinker/Utils.hs b/src/Haddock/Backends/Hyperlinker/Utils.hs --- a/src/Haddock/Backends/Hyperlinker/Utils.hs +++ b/src/Haddock/Backends/Hyperlinker/Utils.hs @@ -21,7 +21,7 @@ import GHC.Iface.Ext.Types ( HieAST(..), HieType(..), HieArgs(..), TypeIndex, HieTypeFlat ) import GHC.Iface.Type import GHC.Types.Name ( getOccFS, getOccString ) -import GHC.Utils.Outputable( showSDoc ) +import GHC.Driver.Ppr ( showSDoc ) import GHC.Types.Var ( VarBndr(..) ) import System.FilePath.Posix ((), (<.>)) diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs --- a/src/Haddock/Backends/LaTeX.hs +++ b/src/Haddock/Backends/LaTeX.hs @@ -25,13 +25,13 @@ import qualified GHC.Utils.Ppr as Pretty import GHC.Types.Basic ( PromotionFlag(..) ) -import GHC +import GHC hiding (fromMaybeContext ) import GHC.Types.Name.Occurrence import GHC.Types.Name ( nameOccName ) import GHC.Types.Name.Reader ( rdrNameOcc ) import GHC.Core.Type ( Specificity(..) ) import GHC.Data.FastString ( unpackFS ) -import GHC.Utils.Outputable ( panic) +import GHC.Utils.Panic ( panic) import qualified Data.Map as Map import System.Directory @@ -108,7 +108,7 @@ -- | Default way of rendering a 'LaTeX'. The width is 90 by default (since 100 -- often overflows the line). latex2String :: LaTeX -> String -latex2String = fullRender PageMode 90 1 txtPrinter "" +latex2String = fullRender (PageMode True) 90 1 txtPrinter "" ppLaTeXTop :: String @@ -177,7 +177,7 @@ body = processExports exports -- - writeUtf8File (odir moduleLaTeXFile mdl) (show tex) + writeUtf8File (odir moduleLaTeXFile mdl) (fullRender (PageMode True) 80 1 txtPrinter "" tex) -- | Prints out an entry in a module export list. exportListItem :: ExportItem DocNameI -> LaTeX @@ -215,10 +215,10 @@ processExport e $$ processExports es -isSimpleSig :: ExportItem DocNameI -> Maybe ([DocName], HsType DocNameI) +isSimpleSig :: ExportItem DocNameI -> Maybe ([DocName], HsSigType DocNameI) isSimpleSig ExportDecl { expItemDecl = L _ (SigD _ (TypeSig _ lnames t)) , expItemMbDoc = (Documentation Nothing Nothing, argDocs) } - | Map.null argDocs = Just (map unLoc lnames, unLoc (hsSigWcType t)) + | Map.null argDocs = Just (map unLoc lnames, unLoc (dropWildCards t)) isSimpleSig _ = Nothing @@ -301,7 +301,7 @@ -- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode -- Family instances happen via FamInst now TyClD _ d@ClassDecl{} -> ppClassDecl instances doc subdocs d unicode - SigD _ (TypeSig _ lnames ty) -> ppFunSig Nothing (doc, fnArgsDoc) (map unLoc lnames) (hsSigWcType ty) unicode + SigD _ (TypeSig _ lnames ty) -> ppFunSig Nothing (doc, fnArgsDoc) (map unLoc lnames) (dropWildCards ty) unicode SigD _ (PatSynSig _ lnames ty) -> ppLPatSig (doc, fnArgsDoc) (map unLoc lnames) ty unicode ForD _ d -> ppFor (doc, fnArgsDoc) d unicode InstD _ _ -> empty @@ -313,7 +313,7 @@ ppFor :: DocForDecl DocName -> ForeignDecl DocNameI -> Bool -> LaTeX ppFor doc (ForeignImport _ (L _ name) typ _) unicode = - ppFunSig Nothing doc [name] (hsSigTypeI typ) unicode + ppFunSig Nothing doc [name] typ unicode ppFor _ _ _ = error "ppFor error in Haddock.Backends.LaTeX" -- error "foreign declarations are currently not supported by --latex" @@ -350,9 +350,9 @@ -- Individual equations of a closed type family ppFamDeclEqn :: TyFamInstEqn DocNameI -> LaTeX - ppFamDeclEqn (HsIB { hsib_body = FamEqn { feqn_tycon = L _ n - , feqn_rhs = rhs - , feqn_pats = ts } }) + ppFamDeclEqn (FamEqn { feqn_tycon = L _ n + , feqn_rhs = rhs + , feqn_pats = ts }) = hsep [ ppAppNameTypeArgs n ts unicode , equals , ppType unicode (unLoc rhs) @@ -390,10 +390,11 @@ injAnn = case injectivity of Nothing -> empty - Just (L _ (InjectivityAnn lhs rhs)) -> hsep ( decltt (text "|") - : ppLDocName lhs - : arrow unicode - : map ppLDocName rhs) + Just (L _ (InjectivityAnn _ lhs rhs)) -> hsep ( decltt (text "|") + : ppLDocName lhs + : arrow unicode + : map ppLDocName rhs) + Just _ -> empty @@ -407,7 +408,7 @@ ppTySyn doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars , tcdRhs = ltype }) unicode - = ppTypeOrFunSig (unLoc ltype) doc (full, hdr, char '=') unicode + = ppTypeOrFunSig (mkHsImplicitSigTypeI ltype) doc (full, hdr, char '=') unicode where hdr = hsep (keyword "type" : ppDocBinder name @@ -426,7 +427,7 @@ :: Maybe LaTeX -- ^ a prefix to put right before the signature -> DocForDecl DocName -- ^ documentation -> [DocName] -- ^ pattern names in the pattern signature - -> LHsType DocNameI -- ^ type of the pattern synonym + -> LHsSigType DocNameI -- ^ type of the pattern synonym -> Bool -- ^ unicode -> LaTeX ppFunSig leader doc docnames (L _ typ) unicode = @@ -447,11 +448,11 @@ -> Bool -- ^ unicode -> LaTeX ppLPatSig doc docnames ty unicode - = ppFunSig (Just (keyword "pattern")) doc docnames (hsSigTypeI ty) unicode + = ppFunSig (Just (keyword "pattern")) doc docnames ty unicode -- | Pretty-print a type, adding documentation to the whole type and its -- arguments as needed. -ppTypeOrFunSig :: HsType DocNameI +ppTypeOrFunSig :: HsSigType DocNameI -> DocForDecl DocName -- ^ documentation -> ( LaTeX -- first-line (no-argument docs only) , LaTeX -- first-line (argument docs only) @@ -471,13 +472,24 @@ -- to the arguments. The output is a list of (leader/seperator, argument and -- its doc) ppSubSigLike :: Bool -- ^ unicode - -> HsType DocNameI -- ^ type signature + -> HsSigType DocNameI -- ^ type signature -> FnArgsDoc DocName -- ^ docs to add -> [(DocName, DocForDecl DocName)] -- ^ all subdocs (useful when we have `HsRecTy`) -> LaTeX -- ^ seperator (beginning of first line) -> [(LaTeX, LaTeX)] -- ^ arguments (leader/sep, type) -ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ +ppSubSigLike unicode typ argDocs subdocs leader = do_sig_args 0 leader typ where + do_sig_args :: Int -> LaTeX -> HsSigType DocNameI -> [(LaTeX, LaTeX)] + do_sig_args n leader (HsSig { sig_bndrs = outer_bndrs, sig_body = ltype }) = + case outer_bndrs of + HsOuterExplicit{hso_bndrs = bndrs} -> + [ ( decltt leader + , decltt (ppHsForAllTelescope (mkHsForAllInvisTeleI bndrs) unicode) + <+> ppLType unicode ltype + ) ] + HsOuterImplicit{} -> do_largs n leader ltype + + do_largs :: Int -> LaTeX -> LHsType DocNameI -> [(LaTeX, LaTeX)] do_largs n leader (L _ t) = do_args n leader t arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs @@ -515,12 +527,16 @@ gadtOpen = char '{' -ppTypeSig :: [Name] -> HsType DocNameI -> Bool -> LaTeX +ppTypeSig :: [Name] -> HsSigType DocNameI -> Bool -> LaTeX ppTypeSig nms ty unicode = hsep (punctuate comma $ map ppSymName nms) <+> dcolon unicode - <+> ppType unicode ty + <+> ppSigType unicode ty +ppHsOuterTyVarBndrs :: HsOuterTyVarBndrs flag DocNameI -> Bool -> LaTeX +ppHsOuterTyVarBndrs (HsOuterImplicit{}) _ = empty +ppHsOuterTyVarBndrs (HsOuterExplicit{hso_bndrs = bndrs}) unicode = + hsep (forallSymbol unicode : ppTyVars bndrs) <> dot ppHsForAllTelescope :: HsForAllTelescope DocNameI -> Bool -> LaTeX ppHsForAllTelescope tele unicode = case tele of @@ -582,23 +598,25 @@ ------------------------------------------------------------------------------- -ppClassHdr :: Bool -> Located [LHsType DocNameI] -> DocName - -> LHsQTyVars DocNameI -> [Located ([Located DocName], [Located DocName])] +ppClassHdr :: Bool -> Maybe (LocatedC [LHsType DocNameI]) -> DocName + -> LHsQTyVars DocNameI -> [LHsFunDep DocNameI] -> Bool -> LaTeX ppClassHdr summ lctxt n tvs fds unicode = keyword "class" - <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode else empty) + <+> (if not (null $ fromMaybeContext lctxt) then ppLContext lctxt unicode else empty) <+> ppAppDocNameNames summ n (tyvarNames tvs) <+> ppFds fds unicode - -ppFds :: [Located ([Located DocName], [Located DocName])] -> Bool -> LaTeX +-- ppFds :: [Located ([LocatedA DocName], [LocatedA DocName])] -> Bool -> LaTeX +ppFds :: [LHsFunDep DocNameI] -> Bool -> LaTeX ppFds fds unicode = if null fds then empty else char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds)) where - fundep (vars1,vars2) = hsep (map (ppDocName . unLoc) vars1) <+> arrow unicode <+> + fundep (FunDep _ vars1 vars2) + = hsep (map (ppDocName . unLoc) vars1) <+> arrow unicode <+> hsep (map (ppDocName . unLoc) vars2) + fundep (XFunDep _) = error "ppFds" -- TODO: associated type defaults, docs on default methods @@ -635,7 +653,7 @@ methodTable = text "\\haddockpremethods{}" <> emph (text "Methods") $$ - vcat [ ppFunSig leader doc names (hsSigTypeI typ) unicode + vcat [ ppFunSig leader doc names typ unicode | L _ (ClassOpSig _ is_def lnames typ) <- lsigs , let doc | is_def = noDocForDecl | otherwise = lookupAnySubdoc (head names) subdocs @@ -789,13 +807,13 @@ decl = case con of ConDeclH98{ con_args = det , con_ex_tvs = tyVars - , con_forall = L _ forall_ + , con_forall = forall_ , con_mb_cxt = cxt - } -> let context = unLoc (fromMaybe (noLoc []) cxt) + } -> let context = fromMaybeContext cxt header_ = ppConstrHdr forall_ tyVars context unicode in case det of -- Prefix constructor, e.g. 'Just a' - PrefixCon args + PrefixCon _ args | hasArgDocs -> header_ <+> ppOcc | otherwise -> hsep [ header_ , ppOcc @@ -819,23 +837,25 @@ | otherwise -> hsep [ ppOcc , dcolon unicode -- ++AZ++ make this prepend "{..}" when it is a record style GADT - , ppLType unicode (getGADTConType con) + , ppLSigType unicode (getGADTConType con) ] - fieldPart = case (con, getConArgsI con) of - -- Record style GADTs - (ConDeclGADT{}, RecCon _) -> doConstrArgsWithDocs [] - - -- Regular record declarations - (_, RecCon (L _ fields)) -> doRecordFields fields - - -- Any GADT or a regular H98 prefix data constructor - (_, PrefixCon args) | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing args) - - -- An infix H98 data constructor - (_, InfixCon arg1 arg2) | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing [arg1,arg2]) + fieldPart = case con of + ConDeclGADT{con_g_args = con_args'} -> case con_args' of + -- GADT record declarations + RecConGADT _ -> doConstrArgsWithDocs [] + -- GADT prefix data constructors + PrefixConGADT args | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing args) + _ -> empty - _ -> empty + ConDeclH98{con_args = con_args'} -> case con_args' of + -- H98 record declarations + RecCon (L _ fields) -> doRecordFields fields + -- H98 prefix data constructors + PrefixCon _ args | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing args) + -- H98 infix data constructor + InfixCon arg1 arg2 | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing [arg1,arg2]) + _ -> empty doRecordFields fields = vcat [ empty <-> tt (text begin) <+> ppSideBySideField subdocs unicode field <+> nl @@ -876,7 +896,7 @@ -- | Pretty-print a bundled pattern synonym -ppSideBySidePat :: [Located DocName] -- ^ pattern name(s) +ppSideBySidePat :: [LocatedN DocName] -- ^ pattern name(s) -> LHsSigType DocNameI -- ^ type of pattern(s) -> DocForDecl DocName -- ^ doc map -> Bool -- ^ unicode @@ -892,18 +912,16 @@ | otherwise = hsep [ keyword "pattern" , ppOcc , dcolon unicode - , ppLType unicode (hsSigTypeI typ) + , ppLSigType unicode typ ] fieldPart | not hasArgDocs = empty | otherwise = vcat [ empty <-> text "\\qquad" <+> l <+> text "\\enspace" <+> r - | (l,r) <- ppSubSigLike unicode (unLoc patTy) argDocs [] (dcolon unicode) + | (l,r) <- ppSubSigLike unicode (unLoc typ) argDocs [] (dcolon unicode) ] - patTy = hsSigTypeI typ - mDoc = fmap _doc $ combineDocumentation doc @@ -965,9 +983,11 @@ ------------------------------------------------------------------------------- -ppLContext, ppLContextNoArrow :: Located (HsContext DocNameI) -> Bool -> LaTeX -ppLContext = ppContext . unLoc -ppLContextNoArrow = ppContextNoArrow . unLoc +ppLContext, ppLContextNoArrow :: Maybe (LHsContext DocNameI) -> Bool -> LaTeX +ppLContext Nothing _ = empty +ppLContext (Just ctxt) unicode = ppContext (unLoc ctxt) unicode +ppLContextNoArrow Nothing _ = empty +ppLContextNoArrow (Just ctxt) unicode = ppContextNoArrow (unLoc ctxt) unicode ppContextNoLocsMaybe :: [HsType DocNameI] -> Bool -> Maybe LaTeX ppContextNoLocsMaybe [] _ = Nothing @@ -1019,17 +1039,23 @@ -- Stolen from Html and tweaked for LaTeX generation ------------------------------------------------------------------------------- -ppLType, ppLParendType, ppLFunLhType :: Bool -> Located (HsType DocNameI) -> LaTeX +ppLType, ppLParendType, ppLFunLhType :: Bool -> LHsType DocNameI -> LaTeX ppLType unicode y = ppType unicode (unLoc y) ppLParendType unicode y = ppParendType unicode (unLoc y) ppLFunLhType unicode y = ppFunLhType unicode (unLoc y) +ppLSigType :: Bool -> LHsSigType DocNameI -> LaTeX +ppLSigType unicode y = ppSigType unicode (unLoc y) + ppType, ppParendType, ppFunLhType, ppCtxType :: Bool -> HsType DocNameI -> LaTeX ppType unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode -ppParendType unicode ty = ppr_mono_ty (reparenTypePrec PREC_CON ty) unicode +ppParendType unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode ppFunLhType unicode ty = ppr_mono_ty (reparenTypePrec PREC_FUN ty) unicode ppCtxType unicode ty = ppr_mono_ty (reparenTypePrec PREC_CTX ty) unicode +ppSigType :: Bool -> HsSigType DocNameI -> LaTeX +ppSigType unicode sig_ty = ppr_sig_ty (reparenSigType sig_ty) unicode + ppLHsTypeArg :: Bool -> LHsTypeArg DocNameI -> LaTeX ppLHsTypeArg unicode (HsValArg ty) = ppLParendType unicode ty ppLHsTypeArg unicode (HsTypeArg _ ki) = atSign unicode <> @@ -1061,6 +1087,11 @@ -- Drop top-level for-all type variables in user style -- since they are implicit in Haskell +ppr_sig_ty :: HsSigType DocNameI -> Bool -> LaTeX +ppr_sig_ty (HsSig { sig_bndrs = outer_bndrs, sig_body = ltype }) unicode + = sep [ ppHsOuterTyVarBndrs outer_bndrs unicode + , ppr_mono_lty ltype unicode ] + ppr_mono_lty :: LHsType DocNameI -> Bool -> LaTeX ppr_mono_lty ty unicode = ppr_mono_ty (unLoc ty) unicode @@ -1076,9 +1107,9 @@ = sep [ ppr_mono_lty ty1 u , arr <+> ppr_mono_lty ty2 u ] where arr = case mult of - HsLinearArrow _ -> lollipop u + HsLinearArrow _ _ -> lollipop u HsUnrestrictedArrow _ -> arrow u - HsExplicitMult _ m -> multAnnotation <> ppr_mono_lty m u <+> arrow u + HsExplicitMult _ _ m -> multAnnotation <> ppr_mono_lty m u <+> arrow u ppr_mono_ty (HsBangTy _ b ty) u = ppBang b <> ppLParendType u ty ppr_mono_ty (HsTyVar _ NotPromoted (L _ name)) _ = ppDocName name @@ -1090,7 +1121,7 @@ ppr_mono_ty (HsIParamTy _ (L _ n) ty) u = ppIPName n <+> dcolon u <+> ppr_mono_lty ty u ppr_mono_ty (HsSpliceTy v _) _ = absurd v ppr_mono_ty (HsRecTy {}) _ = text "{..}" -ppr_mono_ty (XHsType (NHsCoreTy {})) _ = error "ppr_mono_ty HsCoreTy" +ppr_mono_ty (XHsType {}) _ = error "ppr_mono_ty HsCoreTy" ppr_mono_ty (HsExplicitListTy _ IsPromoted tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys ppr_mono_ty (HsExplicitListTy _ NotPromoted tys) u = brackets $ hsep $ punctuate comma $ map (ppLType u) tys ppr_mono_ty (HsExplicitTupleTy _ tys) u = Pretty.quote $ parenList $ map (ppLType u) tys @@ -1123,6 +1154,7 @@ ppr_tylit :: HsTyLit -> Bool -> LaTeX ppr_tylit (HsNumTy _ n) _ = integer n ppr_tylit (HsStrTy _ s) _ = text (show s) +ppr_tylit (HsCharTy _ c) _ = text (show c) -- XXX: Ok in verbatim, but not otherwise -- XXX: Do something with Unicode parameter? @@ -1158,7 +1190,7 @@ ppDocName :: DocName -> LaTeX ppDocName = ppOccName . nameOccName . getName -ppLDocName :: Located DocName -> LaTeX +ppLDocName :: GenLocated l DocName -> LaTeX ppLDocName (L _ d) = ppDocName d diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs --- a/src/Haddock/Backends/Xhtml.hs +++ b/src/Haddock/Backends/Xhtml.hs @@ -11,11 +11,10 @@ -- Stability : experimental -- Portability : portable ----------------------------------------------------------------------------- -{-# LANGUAGE CPP, NamedFieldPuns, TupleSections, TypeApplications #-} +{-# LANGUAGE CPP, NamedFieldPuns #-} module Haddock.Backends.Xhtml ( ppHtml, copyHtmlBits, ppHtmlIndex, ppHtmlContents, - ppJsonIndex ) where @@ -39,22 +38,18 @@ import Control.Monad ( when, unless ) import qualified Data.ByteString.Builder as Builder -import Data.Bifunctor ( bimap ) import Data.Char ( toUpper, isSpace ) -import Data.Either ( partitionEithers ) -import Data.Foldable ( traverse_) import Data.List ( sortBy, isPrefixOf, intersperse ) import Data.Maybe import System.Directory import System.FilePath hiding ( () ) import qualified System.IO as IO -import qualified System.FilePath as FilePath import Data.Map ( Map ) import qualified Data.Map as Map hiding ( Map ) import qualified Data.Set as Set hiding ( Set ) import Data.Ord ( comparing ) -import GHC hiding ( NoLink, moduleInfo,LexicalFixity(..) ) +import GHC hiding ( NoLink, moduleInfo,LexicalFixity(..), anchor ) import GHC.Types.Name import GHC.Unit.State @@ -73,7 +68,6 @@ -> Maybe String -- ^ The mathjax URL (--mathjax) -> SourceURLs -- ^ The source URL (--source) -> WikiURLs -- ^ The wiki URL (--wiki) - -> BaseURL -- ^ The base URL (--base-url) -> Maybe String -- ^ The contents URL (--use-contents) -> Maybe String -- ^ The index URL (--use-index) -> Bool -- ^ Whether to use unicode in output (--use-unicode) @@ -85,7 +79,7 @@ ppHtml state doctitle maybe_package ifaces reexported_ifaces odir prologue themes maybe_mathjax_url maybe_source_url maybe_wiki_url - maybe_base_url maybe_contents_url maybe_index_url unicode + maybe_contents_url maybe_index_url unicode pkg qual debug withQuickjump = do let visible_ifaces = filter visible ifaces @@ -103,12 +97,12 @@ themes maybe_mathjax_url maybe_contents_url maybe_source_url maybe_wiki_url (map toInstalledIface visible_ifaces ++ reexported_ifaces) debug - when withQuickjump $ - ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual - visible_ifaces [] + when withQuickjump $ + ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual + visible_ifaces mapM_ (ppHtmlModule odir doctitle themes - maybe_mathjax_url maybe_source_url maybe_wiki_url maybe_base_url + maybe_mathjax_url maybe_source_url maybe_wiki_url maybe_contents_url maybe_index_url unicode pkg qual debug) visible_ifaces @@ -125,23 +119,16 @@ return () -headHtml :: String -> Themes -> Maybe String -> Maybe String -> Html -headHtml docTitle themes mathjax_url base_url = - header ! (maybe [] (\url -> [identifier "head", strAttr "data-base-url" url ]) base_url) - << +headHtml :: String -> Themes -> Maybe String -> Html +headHtml docTitle themes mathjax_url = + header << [ meta ! [ httpequiv "Content-Type", content "text/html; charset=UTF-8"] , meta ! [ XHtml.name "viewport", content "width=device-width, initial-scale=1"] , thetitle << docTitle - , styleSheet base_url themes - , thelink ! [ rel "stylesheet" - , thetype "text/css" - , href (withBaseURL base_url quickJumpCssFile) ] - << noHtml + , styleSheet themes + , thelink ! [ rel "stylesheet", thetype "text/css", href quickJumpCssFile] << noHtml , thelink ! [ rel "stylesheet", thetype "text/css", href fontUrl] << noHtml - , script ! [ src (withBaseURL base_url haddockJsFile) - , emptyAttr "async" - , thetype "text/javascript" ] - << noHtml + , script ! [src haddockJsFile, emptyAttr "async", thetype "text/javascript"] << noHtml , script ! [thetype "text/x-mathjax-config"] << primHtml mjConf , script ! [src mjUrl, thetype "text/javascript"] << noHtml ] @@ -294,7 +281,7 @@ | iface <- ifaces , instIsSig iface] html = - headHtml doctitle themes mathjax_url Nothing +++ + headHtml doctitle themes mathjax_url +++ bodyHtml doctitle Nothing maybe_source_url maybe_wiki_url Nothing maybe_index_url << [ @@ -374,35 +361,6 @@ -- * Generate the index -------------------------------------------------------------------------------- -data JsonIndexEntry = JsonIndexEntry { - jieHtmlFragment :: String, - jieName :: String, - jieModule :: String, - jieLink :: String - } - deriving Show - -instance ToJSON JsonIndexEntry where - toJSON JsonIndexEntry - { jieHtmlFragment - , jieName - , jieModule - , jieLink } = - Object - [ "display_html" .= String jieHtmlFragment - , "name" .= String jieName - , "module" .= String jieModule - , "link" .= String jieLink - ] - -instance FromJSON JsonIndexEntry where - parseJSON = withObject "JsonIndexEntry" $ \v -> - JsonIndexEntry - <$> v .: "display_html" - <*> v .: "name" - <*> v .: "module" - <*> v .: "link" - ppJsonIndex :: FilePath -> SourceURLs -- ^ The source URL (--source) -> WikiURLs -- ^ The wiki URL (--wiki) @@ -410,50 +368,34 @@ -> Maybe Package -> QualOption -> [Interface] - -> [FilePath] -- ^ file paths to interface files - -- (--read-interface) -> IO () -ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces installedIfacesPaths = do +ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces = do createDirectoryIfMissing True odir - (errors, installedIndexes) <- - partitionEithers - <$> traverse - (\ifaceFile -> - let indexFile = takeDirectory ifaceFile - FilePath. "doc-index.json" in - bimap (indexFile,) (map (fixLink ifaceFile)) - <$> eitherDecodeFile @[JsonIndexEntry] indexFile) - installedIfacesPaths - traverse_ (\(indexFile, err) -> putStrLn $ "haddock: Coudn't parse " ++ indexFile ++ ": " ++ err) - errors - IO.withBinaryFile (joinPath [odir, indexJsonFile]) IO.WriteMode $ \h -> - Builder.hPutBuilder - h (encodeToBuilder (encodeIndexes (concat installedIndexes))) + IO.withBinaryFile (joinPath [odir, indexJsonFile]) IO.WriteMode $ \h -> do + Builder.hPutBuilder h (encodeToBuilder modules) where - encodeIndexes :: [JsonIndexEntry] -> Value - encodeIndexes installedIndexes = - toJSON - (concatMap fromInterface ifaces - ++ installedIndexes) + modules :: Value + modules = Array (concatMap goInterface ifaces) - fromInterface :: Interface -> [JsonIndexEntry] - fromInterface iface = - mkIndex mdl qual `mapMaybe` ifaceRnExportItems iface + goInterface :: Interface -> [Value] + goInterface iface = + concatMap (goExport mdl qual) (ifaceRnExportItems iface) where aliases = ifaceModuleAliases iface qual = makeModuleQual qual_opt aliases mdl mdl = ifaceMod iface - mkIndex :: Module -> Qualification -> ExportItem DocNameI -> Maybe JsonIndexEntry - mkIndex mdl qual item + goExport :: Module -> Qualification -> ExportItem DocNameI -> [Value] + goExport mdl qual item | Just item_html <- processExport True links_info unicode pkg qual item - = Just JsonIndexEntry - { jieHtmlFragment = showHtmlFragment item_html - , jieName = unwords (map getOccString names) - , jieModule = moduleString mdl - , jieLink = fromMaybe "" (listToMaybe (map (nameLink mdl) names)) - } - | otherwise = Nothing + = [ Object + [ "display_html" .= String (showHtmlFragment item_html) + , "name" .= String (unwords (map getOccString names)) + , "module" .= String (moduleString mdl) + , "link" .= String (fromMaybe "" (listToMaybe (map (nameLink mdl) names))) + ] + ] + | otherwise = [] where names = exportName item ++ exportSubs item @@ -471,13 +413,6 @@ links_info = (maybe_source_url, maybe_wiki_url) - -- update link using relative path to output directory - fixLink :: FilePath - -> JsonIndexEntry -> JsonIndexEntry - fixLink ifaceFile jie = - jie { jieLink = makeRelative odir (takeDirectory ifaceFile) - FilePath. jieLink jie } - ppHtmlIndex :: FilePath -> String -> Maybe String @@ -506,7 +441,7 @@ where indexPage showLetters ch items = - headHtml (doctitle ++ " (" ++ indexName ch ++ ")") themes maybe_mathjax_url Nothing +++ + headHtml (doctitle ++ " (" ++ indexName ch ++ ")") themes maybe_mathjax_url +++ bodyHtml doctitle Nothing maybe_source_url maybe_wiki_url maybe_contents_url Nothing << [ @@ -606,11 +541,11 @@ ppHtmlModule :: FilePath -> String -> Themes - -> Maybe String -> SourceURLs -> WikiURLs -> BaseURL + -> Maybe String -> SourceURLs -> WikiURLs -> Maybe String -> Maybe String -> Bool -> Maybe Package -> QualOption -> Bool -> Interface -> IO () ppHtmlModule odir doctitle themes - maybe_mathjax_url maybe_source_url maybe_wiki_url maybe_base_url + maybe_mathjax_url maybe_source_url maybe_wiki_url maybe_contents_url maybe_index_url unicode pkg qual debug iface = do let mdl = ifaceMod iface @@ -628,7 +563,7 @@ = toHtml mdl_str real_qual = makeModuleQual qual aliases mdl html = - headHtml mdl_str_annot themes maybe_mathjax_url maybe_base_url +++ + headHtml mdl_str_annot themes maybe_mathjax_url +++ bodyHtml doctitle (Just iface) maybe_source_url maybe_wiki_url maybe_contents_url maybe_index_url << [ diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs --- a/src/Haddock/Backends/Xhtml/Decl.hs +++ b/src/Haddock/Backends/Xhtml/Decl.hs @@ -37,7 +37,7 @@ import GHC.Core.Type ( Specificity(..) ) import GHC.Types.Basic (PromotionFlag(..), isPromoted) -import GHC hiding (LexicalFixity(..)) +import GHC hiding (LexicalFixity(..), fromMaybeContext) import GHC.Exts import GHC.Types.Name import GHC.Data.BooleanFormula @@ -58,40 +58,40 @@ -> Qualification -> Html ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode pkg qual = case decl of - TyClD _ (FamDecl _ d) -> ppFamDecl summ False links instances fixities loc mbDoc d splice unicode pkg qual - TyClD _ d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d pats splice unicode pkg qual - TyClD _ d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode pkg qual - TyClD _ d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode pkg qual - SigD _ (TypeSig _ lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames - (hsSigWcType lty) fixities splice unicode pkg qual - SigD _ (PatSynSig _ lnames lty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames - (hsSigTypeI lty) fixities splice unicode pkg qual - ForD _ d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode pkg qual + TyClD _ (FamDecl _ d) -> ppFamDecl summ False links instances fixities (locA loc) mbDoc d splice unicode pkg qual + TyClD _ d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs (locA loc) mbDoc d pats splice unicode pkg qual + TyClD _ d@(SynDecl {}) -> ppTySyn summ links fixities (locA loc) (mbDoc, fnArgsDoc) d splice unicode pkg qual + TyClD _ d@(ClassDecl {}) -> ppClassDecl summ links instances fixities (locA loc) mbDoc subdocs d splice unicode pkg qual + SigD _ (TypeSig _ lnames lty) -> ppLFunSig summ links (locA loc) (mbDoc, fnArgsDoc) lnames + (dropWildCards lty) fixities splice unicode pkg qual + SigD _ (PatSynSig _ lnames lty) -> ppLPatSig summ links (locA loc) (mbDoc, fnArgsDoc) lnames + lty fixities splice unicode pkg qual + ForD _ d -> ppFor summ links (locA loc) (mbDoc, fnArgsDoc) d fixities splice unicode pkg qual InstD _ _ -> noHtml DerivD _ _ -> noHtml _ -> error "declaration not supported by ppDecl" ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> - [Located DocName] -> LHsType DocNameI -> [(DocName, Fixity)] -> + [LocatedN DocName] -> LHsSigType DocNameI -> [(DocName, Fixity)] -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppLFunSig summary links loc doc lnames lty fixities splice unicode pkg qual = ppFunSig summary links loc noHtml doc (map unLoc lnames) lty fixities splice unicode pkg qual ppFunSig :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName -> - [DocName] -> LHsType DocNameI -> [(DocName, Fixity)] -> + [DocName] -> LHsSigType DocNameI -> [(DocName, Fixity)] -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppFunSig summary links loc leader doc docnames typ fixities splice unicode pkg qual = ppSigLike summary links loc leader doc docnames fixities (unLoc typ, pp_typ) splice unicode pkg qual HideEmptyContexts where - pp_typ = ppLType unicode qual HideEmptyContexts typ + pp_typ = ppLSigType unicode qual HideEmptyContexts typ -- | Pretty print a pattern synonym ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName - -> [Located DocName] -- ^ names of patterns in declaration - -> LHsType DocNameI -- ^ type of patterns in declaration + -> [LocatedN DocName] -- ^ names of patterns in declaration + -> LHsSigType DocNameI -- ^ type of patterns in declaration -> [(DocName, Fixity)] -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppLPatSig summary links loc doc lnames typ fixities splice unicode pkg qual = @@ -102,7 +102,7 @@ ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName -> - [DocName] -> [(DocName, Fixity)] -> (HsType DocNameI, Html) -> + [DocName] -> [(DocName, Fixity)] -> (HsSigType DocNameI, Html) -> Splice -> Unicode -> Maybe Package -> Qualification -> HideEmptyContexts -> Html ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ) splice unicode pkg qual emptyCtxts = @@ -119,7 +119,7 @@ | otherwise = html <+> ppFixities fixities qual -ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsType DocNameI +ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsSigType DocNameI -> DocForDecl DocName -> (Html, Html, Html) -> Splice -> Unicode -> Maybe Package -> Qualification -> HideEmptyContexts -> Html @@ -140,15 +140,24 @@ -- If one passes in a list of the available subdocs, any top-level `HsRecTy` -- found will be expanded out into their fields. ppSubSigLike :: Unicode -> Qualification - -> HsType DocNameI -- ^ type signature + -> HsSigType DocNameI -- ^ type signature -> FnArgsDoc DocName -- ^ docs to add -> [(DocName, DocForDecl DocName)] -- ^ all subdocs (useful when -- we expand an `HsRecTy`) -> Html -> HideEmptyContexts -> [SubDecl] -ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_args 0 sep typ +ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_sig_args 0 sep typ where + do_sig_args :: Int -> Html -> HsSigType DocNameI -> [SubDecl] + do_sig_args n leader (HsSig { sig_bndrs = outer_bndrs, sig_body = ltype }) = + case outer_bndrs of + HsOuterExplicit{hso_bndrs = bndrs} -> do_largs n (leader' bndrs) ltype + HsOuterImplicit{} -> do_largs n leader ltype + where + leader' bndrs = leader <+> ppForAllPart unicode qual (mkHsForAllInvisTeleI bndrs) + argDoc n = Map.lookup n argDocs + do_largs :: Int -> Html -> LHsType DocNameI -> [SubDecl] do_largs n leader (L _ t) = do_args n leader t do_args :: Int -> Html -> HsType DocNameI -> [SubDecl] @@ -158,7 +167,7 @@ leader' = leader <+> ppForAllPart unicode qual tele do_args n leader (HsQualTy _ lctxt ltype) - | null (unLoc lctxt) + | null (fromMaybeContext lctxt) = do_largs n leader ltype | otherwise = (leader <+> ppLContextNoArrow lctxt unicode qual emptyCtxts, Nothing, []) @@ -222,7 +231,7 @@ -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppFor summary links loc doc (ForeignImport _ (L _ name) typ _) fixities splice unicode pkg qual - = ppFunSig summary links loc noHtml doc [name] (hsSigTypeI typ) fixities splice unicode pkg qual + = ppFunSig summary links loc noHtml doc [name] typ fixities splice unicode pkg qual ppFor _ _ _ _ _ _ _ _ _ _ = error "ppFor" @@ -233,13 +242,14 @@ ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars , tcdRhs = ltype }) splice unicode pkg qual - = ppTypeOrFunSig summary links loc [name] (unLoc ltype) doc + = ppTypeOrFunSig summary links loc [name] sig_type doc (full <+> fixs, hdr <+> fixs, spaceHtml +++ equals) splice unicode pkg qual ShowEmptyToplevelContexts where + sig_type = mkHsImplicitSigTypeI ltype hdr = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars unicode qual (hsQTvExplicit ltyvars)) - full = hdr <+> equals <+> ppPatSigType unicode qual ltype + full = hdr <+> equals <+> ppPatSigType unicode qual (noLocA sig_type) occ = nameOccName . getName $ name fixs | summary = noHtml @@ -253,15 +263,14 @@ where htmlNames = intersperse (stringToHtml ", ") $ map (ppBinder summary) nms - ppSimpleSig :: LinksInfo -> Splice -> Unicode -> Qualification -> HideEmptyContexts -> SrcSpan - -> [DocName] -> HsType DocNameI + -> [DocName] -> HsSigType DocNameI -> Html ppSimpleSig links splice unicode qual emptyCtxts loc names typ = topDeclElem' names $ ppTypeSig True occNames ppTyp unicode where topDeclElem' = topDeclElem links loc splice - ppTyp = ppType unicode qual emptyCtxts typ + ppTyp = ppSigType unicode qual emptyCtxts typ occNames = map getOccName names @@ -301,9 +310,9 @@ -- Individual equation of a closed type family ppFamDeclEqn :: TyFamInstEqn DocNameI -> SubDecl - ppFamDeclEqn (HsIB { hsib_body = FamEqn { feqn_tycon = L _ n - , feqn_rhs = rhs - , feqn_pats = ts } }) + ppFamDeclEqn (FamEqn { feqn_tycon = L _ n + , feqn_rhs = rhs + , feqn_pats = ts }) = ( ppAppNameTypeArgs n ts unicode qual <+> equals <+> ppType unicode qual HideEmptyContexts (unLoc rhs) , Nothing @@ -321,7 +330,7 @@ , pfdTyVars = tvs , pfdLName = L loc name }) unicode qual = - topDeclElem links loc splice [name] leader + topDeclElem links (locA loc) splice [name] leader where leader = hsep [ ppFamilyLeader True info , ppAppNameTypes name (map unLoc tvs) unicode qual @@ -352,10 +361,11 @@ injAnn = case injectivity of Nothing -> noHtml - Just (L _ (InjectivityAnn lhs rhs)) -> hsep ( keyword "|" - : ppLDocName qual Raw lhs - : arrow unicode - : map (ppLDocName qual Raw) rhs) + Just (L _ (InjectivityAnn _ lhs rhs)) -> hsep ( keyword "|" + : ppLDocName qual Raw lhs + : arrow unicode + : map (ppLDocName qual Raw) rhs) + Just _ -> error "ppFamHeader:XInjectivityAnn" -- | Print the keywords that begin the family declaration ppFamilyLeader :: Bool -> FamilyInfo DocNameI -> Html @@ -426,10 +436,12 @@ ------------------------------------------------------------------------------- -ppLContext, ppLContextNoArrow :: Located (HsContext DocNameI) -> Unicode +ppLContext, ppLContextNoArrow :: Maybe (LHsContext DocNameI) -> Unicode -> Qualification -> HideEmptyContexts -> Html -ppLContext = ppContext . unLoc -ppLContextNoArrow = ppContextNoArrow . unLoc +ppLContext Nothing u q h = ppContext [] u q h +ppLContext (Just c) u q h = ppContext (unLoc c) u q h +ppLContextNoArrow Nothing u q h = ppContextNoArrow [] u q h +ppLContextNoArrow (Just c) u q h = ppContextNoArrow (unLoc c) u q h ppContextNoArrow :: HsContext DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html ppContextNoArrow cxt unicode qual emptyCtxts = fromMaybe noHtml $ @@ -463,22 +475,23 @@ ------------------------------------------------------------------------------- -ppClassHdr :: Bool -> Located [LHsType DocNameI] -> DocName - -> LHsQTyVars DocNameI -> [Located ([Located DocName], [Located DocName])] +ppClassHdr :: Bool -> Maybe (LocatedC [LHsType DocNameI]) -> DocName + -> LHsQTyVars DocNameI -> [LHsFunDep DocNameI] -> Unicode -> Qualification -> Html ppClassHdr summ lctxt n tvs fds unicode qual = keyword "class" - <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode qual HideEmptyContexts else noHtml) + <+> (if not (null $ fromMaybeContext lctxt) then ppLContext lctxt unicode qual HideEmptyContexts else noHtml) <+> ppAppDocNameTyVarBndrs summ unicode qual n (hsQTvExplicit tvs) <+> ppFds fds unicode qual -ppFds :: [Located ([Located DocName], [Located DocName])] -> Unicode -> Qualification -> Html +ppFds :: [LHsFunDep DocNameI] -> Unicode -> Qualification -> Html ppFds fds unicode qual = if null fds then noHtml else char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds)) where - fundep (vars1,vars2) = ppVars vars1 <+> arrow unicode <+> ppVars vars2 + fundep (FunDep _ vars1 vars2) = ppVars vars1 <+> arrow unicode <+> ppVars vars2 + fundep (XFunDep _) = error "ppFds" ppVars = hsep . map ((ppDocName qual Prefix True) . unLoc) ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocNameI -> SrcSpan @@ -497,7 +510,7 @@ -- ToDo: add associated type defaults - [ ppFunSig summary links loc noHtml doc names (hsSigTypeI typ) + [ ppFunSig summary links loc noHtml doc names typ [] splice unicode pkg qual | L _ (ClassOpSig _ False lnames typ) <- sigs , let doc = lookupAnySubdoc (head names) subdocs @@ -561,14 +574,14 @@ lookupDAT name = Map.lookup (getName name) defaultAssocTys defaultAssocTys = Map.fromList [ (getName name, (vs, typ)) - | L _ (TyFamInstDecl (HsIB _ (FamEqn { feqn_rhs = typ - , feqn_tycon = L _ name - , feqn_pats = vs }))) <- atsDefs + | L _ (TyFamInstDecl _ (FamEqn { feqn_rhs = typ + , feqn_tycon = L _ name + , feqn_pats = vs })) <- atsDefs ] -- Methods methodBit = subMethods - [ ppFunSig summary links loc noHtml doc [name] (hsSigTypeI typ) + [ ppFunSig summary links loc noHtml doc [name] typ subfixs splice unicode pkg qual <+> subDefaults (maybeToList defSigs) @@ -583,7 +596,7 @@ -- Default methods ppDefaultFunSig n (t, d') = ppFunSig summary links loc (keyword "default") - d' [n] (hsSigTypeI t) [] splice unicode pkg qual + d' [n] t [] splice unicode pkg qual lookupDM name = Map.lookup (getOccString name) defaultMethods defaultMethods = Map.fromList @@ -634,13 +647,11 @@ -- force Splice = True to use line URLs where instName = getOccString origin - instDecl :: Int -> DocInstance DocNameI -> (String, SubDecl, Maybe Module, Located DocName) + instDecl :: Int -> DocInstance DocNameI -> (SubDecl, Maybe Module, Located DocName) instDecl no (inst, mdoc, loc, mdl) = - (instanceAnchor, mModule, mdl, loc) - where - instanceAnchor = getOccString (ihdClsName inst) <> "_" <> show no <> ":" - mModule = ppInstHead links splice unicode qual mdoc origin False no inst mdl + ((ppInstHead links splice unicode qual mdoc origin False no inst mdl), mdl, loc) + ppOrphanInstances :: LinksInfo -> [DocInstance DocNameI] -> Splice -> Unicode -> Maybe Package -> Qualification @@ -651,12 +662,9 @@ instOrigin :: InstHead name -> InstOrigin (IdP name) instOrigin inst = OriginClass (ihdClsName inst) - instDecl :: Int -> DocInstance DocNameI -> (String, SubDecl, Maybe Module, Located DocName) + instDecl :: Int -> DocInstance DocNameI -> (SubDecl, Maybe Module, Located DocName) instDecl no (inst, mdoc, loc, mdl) = - (instanceAnchor, mModule, mdl, loc) - where - instanceAnchor = getOccString (ihdClsName inst) <> "_" <> show no <> ":" - mModule = ppInstHead links splice unicode qual mdoc (instOrigin inst) True no inst Nothing + ((ppInstHead links splice unicode qual mdoc (instOrigin inst) True no inst Nothing), mdl, loc) ppInstHead :: LinksInfo -> Splice -> Unicode -> Qualification @@ -714,10 +722,10 @@ ppInstanceSigs links splice unicode qual sigs = do TypeSig _ lnames typ <- sigs let names = map unLoc lnames - L _ rtyp = hsSigWcType typ + L _ rtyp = dropWildCards typ -- Instance methods signatures are synified and thus don't have a useful -- SrcSpan value. Use the methods name location instead. - return $ ppSimpleSig links splice unicode qual HideEmptyContexts (getLoc $ head $ lnames) names rtyp + return $ ppSimpleSig links splice unicode qual HideEmptyContexts (getLocA $ head $ lnames) names rtyp lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2 @@ -777,7 +785,7 @@ pats1 = [ hsep [ keyword "pattern" , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames , dcolon unicode - , ppPatSigType unicode qual (hsSigTypeI typ) + , ppPatSigType unicode qual typ ] | (SigD _ (PatSynSig _ lnames typ),_) <- pats ] @@ -822,7 +830,7 @@ [ ppSideBySideConstr subdocs subfixs unicode pkg qual c | c <- cons , let subfixs = filter (\(n,_) -> any (\cn -> cn == n) - (map unLoc (getConNamesI (unLoc c)))) fixities + (map unL (getConNamesI (unLoc c)))) fixities ] patternBit = subPatterns pkg qual @@ -849,14 +857,14 @@ = case con of ConDeclH98{ con_args = det , con_ex_tvs = tyVars - , con_forall = L _ forall_ + , con_forall = forall_ , con_mb_cxt = cxt - } -> let context = unLoc (fromMaybe (noLoc []) cxt) + } -> let context = fromMaybeContext cxt header_ = ppConstrHdr forall_ tyVars context unicode qual in case det of -- Prefix constructor, e.g. 'Just a' - PrefixCon args -> + PrefixCon _ args -> ( header_ <+> hsep (ppOcc : map (ppLParendType unicode qual HideEmptyContexts . hsScaledThing) args) , noHtml , noHtml @@ -883,13 +891,13 @@ -- GADT constructor, e.g. 'Foo :: Int -> Foo' ConDeclGADT {} -> - ( hsep [ ppOcc, dcolon unicode, ppLType unicode qual HideEmptyContexts (getGADTConType con) ] + ( hsep [ ppOcc, dcolon unicode, ppLSigType unicode qual HideEmptyContexts (getGADTConType con) ] , noHtml , noHtml ) where - occ = map (nameOccName . getName . unLoc) $ getConNamesI con + occ = map (nameOccName . getName . unL) $ getConNamesI con ppOcc = hsep (punctuate comma (map (ppBinder summary) occ)) ppOccInfix = hsep (punctuate comma (map (ppBinderInfix summary) occ)) @@ -906,10 +914,10 @@ ) where -- Find the name of a constructors in the decl (`getConName` always returns a non-empty list) - aConName = unLoc (head (getConNamesI con)) + aConName = unL (head (getConNamesI con)) fixity = ppFixities fixities qual - occ = map (nameOccName . getName . unLoc) $ getConNamesI con + occ = map (nameOccName . getName . unL) $ getConNamesI con ppOcc = hsep (punctuate comma (map (ppBinder False) occ)) ppOccInfix = hsep (punctuate comma (map (ppBinderInfix False) occ)) @@ -921,13 +929,13 @@ decl = case con of ConDeclH98{ con_args = det , con_ex_tvs = tyVars - , con_forall = L _ forall_ + , con_forall = forall_ , con_mb_cxt = cxt - } -> let context = unLoc (fromMaybe (noLoc []) cxt) + } -> let context = fromMaybeContext cxt header_ = ppConstrHdr forall_ tyVars context unicode qual in case det of -- Prefix constructor, e.g. 'Just a' - PrefixCon args + PrefixCon _ args | hasArgDocs -> header_ <+> ppOcc <+> fixity | otherwise -> hsep [ header_ <+> ppOcc , hsep (map (ppLParendType unicode qual HideEmptyContexts . hsScaledThing) args) @@ -952,24 +960,26 @@ | otherwise -> hsep [ ppOcc , dcolon unicode -- ++AZ++ make this prepend "{..}" when it is a record style GADT - , ppLType unicode qual HideEmptyContexts (getGADTConType con) + , ppLSigType unicode qual HideEmptyContexts (getGADTConType con) , fixity ] - fieldPart = case (con, getConArgsI con) of - -- Record style GADTs - (ConDeclGADT{}, RecCon _) -> [ doConstrArgsWithDocs [] ] - - -- Regular record declarations - (_, RecCon (L _ fields)) -> [ doRecordFields fields ] - - -- Any GADT or a regular H98 prefix data constructor - (_, PrefixCon args) | hasArgDocs -> [ doConstrArgsWithDocs args ] - - -- An infix H98 data constructor - (_, InfixCon arg1 arg2) | hasArgDocs -> [ doConstrArgsWithDocs [arg1,arg2] ] + fieldPart = case con of + ConDeclGADT{con_g_args = con_args'} -> case con_args' of + -- GADT record declarations + RecConGADT _ -> [ doConstrArgsWithDocs [] ] + -- GADT prefix data constructors + PrefixConGADT args | hasArgDocs -> [ doConstrArgsWithDocs args ] + _ -> [] - _ -> [] + ConDeclH98{con_args = con_args'} -> case con_args' of + -- H98 record declarations + RecCon (L _ fields) -> [ doRecordFields fields ] + -- H98 prefix data constructors + PrefixCon _ args | hasArgDocs -> [ doConstrArgsWithDocs args ] + -- H98 infix data constructor + InfixCon arg1 arg2 | hasArgDocs -> [ doConstrArgsWithDocs [arg1,arg2] ] + _ -> [] doRecordFields fields = subFields pkg qual (map (ppSideBySideField subdocs unicode qual) (map unLoc fields)) @@ -986,7 +996,7 @@ -- 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 $ getConNamesI con) subdocs >>= + mbDoc = lookup (unL $ head $ getConNamesI con) subdocs >>= combineDocumentation . fst @@ -1036,7 +1046,7 @@ -- | Pretty print an expanded pattern (for bundled patterns) ppSideBySidePat :: [(DocName, Fixity)] -> Unicode -> Qualification - -> [Located DocName] -- ^ pattern name(s) + -> [LocatedN DocName] -- ^ pattern name(s) -> LHsSigType DocNameI -- ^ type of pattern(s) -> DocForDecl DocName -- ^ doc map -> SubDecl @@ -1054,18 +1064,17 @@ | otherwise = hsep [ keyword "pattern" , ppOcc , dcolon unicode - , ppPatSigType unicode qual (hsSigTypeI typ) + , ppPatSigType unicode qual typ , fixity ] fieldPart | not hasArgDocs = [] - | otherwise = [ subFields Nothing qual (ppSubSigLike unicode qual (unLoc patTy) + | otherwise = [ subFields Nothing qual (ppSubSigLike unicode qual (unLoc typ) argDocs [] (dcolon unicode) emptyCtxt) ] - patTy = hsSigTypeI typ - emptyCtxt = patSigContext patTy + emptyCtxt = patSigContext typ -- | Print the LHS of a data\/newtype declaration. @@ -1114,11 +1123,14 @@ -- * Rendering of HsType -------------------------------------------------------------------------------- -ppLType, ppLParendType, ppLFunLhType :: Unicode -> Qualification -> HideEmptyContexts -> Located (HsType DocNameI) -> Html +ppLType, ppLParendType, ppLFunLhType :: Unicode -> Qualification -> HideEmptyContexts -> LHsType DocNameI -> Html ppLType unicode qual emptyCtxts y = ppType unicode qual emptyCtxts (unLoc y) ppLParendType unicode qual emptyCtxts y = ppParendType unicode qual emptyCtxts (unLoc y) ppLFunLhType unicode qual emptyCtxts y = ppFunLhType unicode qual emptyCtxts (unLoc y) +ppLSigType :: Unicode -> Qualification -> HideEmptyContexts -> LHsSigType DocNameI -> Html +ppLSigType unicode qual emptyCtxts y = ppSigType unicode qual emptyCtxts (unLoc y) + ppCtxType :: Unicode -> Qualification -> HsType DocNameI -> Html ppCtxType unicode qual ty = ppr_mono_ty (reparenTypePrec PREC_CTX ty) unicode qual HideEmptyContexts @@ -1127,6 +1139,9 @@ ppParendType unicode qual emptyCtxts ty = ppr_mono_ty (reparenTypePrec PREC_CON ty) unicode qual emptyCtxts ppFunLhType unicode qual emptyCtxts ty = ppr_mono_ty (reparenTypePrec PREC_FUN ty) unicode qual emptyCtxts +ppSigType :: Unicode -> Qualification -> HideEmptyContexts -> HsSigType DocNameI -> Html +ppSigType unicode qual emptyCtxts sig_ty = ppr_sig_ty (reparenSigType sig_ty) unicode qual emptyCtxts + ppLHsTypeArg :: Unicode -> Qualification -> HideEmptyContexts -> LHsTypeArg DocNameI -> Html ppLHsTypeArg unicode qual emptyCtxts (HsValArg ty) = ppLParendType unicode qual emptyCtxts ty ppLHsTypeArg unicode qual emptyCtxts (HsTypeArg _ ki) = atSign unicode <> @@ -1140,7 +1155,7 @@ ppHsTyVarBndr _ qual (UserTyVar _ _ (L _ name)) = ppDocName qual Raw False name ppHsTyVarBndr unicode qual (KindedTyVar _ _ name kind) = - parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+> + parens (ppDocName qual Raw False (unL name) <+> dcolon unicode <+> ppLKind unicode qual kind) instance RenderableBndrFlag Specificity where @@ -1149,10 +1164,10 @@ ppHsTyVarBndr _ qual (UserTyVar _ InferredSpec (L _ name)) = braces $ ppDocName qual Raw False name ppHsTyVarBndr unicode qual (KindedTyVar _ SpecifiedSpec name kind) = - parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+> + parens (ppDocName qual Raw False (unL name) <+> dcolon unicode <+> ppLKind unicode qual kind) ppHsTyVarBndr unicode qual (KindedTyVar _ InferredSpec name kind) = - braces (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+> + braces (ppDocName qual Raw False (unL name) <+> dcolon unicode <+> ppLKind unicode qual kind) ppLKind :: Unicode -> Qualification -> LHsKind DocNameI -> Html @@ -1161,32 +1176,38 @@ ppKind :: Unicode -> Qualification -> HsKind DocNameI -> Html ppKind unicode qual ki = ppr_mono_ty (reparenTypePrec PREC_TOP ki) unicode qual HideEmptyContexts -patSigContext :: LHsType name -> HideEmptyContexts -patSigContext typ | hasNonEmptyContext typ && isFirstContextEmpty typ = ShowEmptyToplevelContexts - | otherwise = HideEmptyContexts +patSigContext :: LHsSigType DocNameI -> HideEmptyContexts +patSigContext sig_typ | hasNonEmptyContext typ && isFirstContextEmpty typ = ShowEmptyToplevelContexts + | otherwise = HideEmptyContexts where - hasNonEmptyContext :: LHsType name -> Bool + typ = sig_body (unLoc sig_typ) + hasNonEmptyContext t = case unLoc t of HsForAllTy _ _ s -> hasNonEmptyContext s - HsQualTy _ cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True + HsQualTy _ cxt s -> if null (fromMaybeContext 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) + HsQualTy _ cxt _ -> null (fromMaybeContext cxt) HsFunTy _ _ _ s -> isFirstContextEmpty s _ -> False -- | Pretty-print a pattern signature (all this does over 'ppLType' is slot in -- the right 'HideEmptyContext' value) -ppPatSigType :: Unicode -> Qualification -> LHsType DocNameI -> Html +ppPatSigType :: Unicode -> Qualification -> LHsSigType DocNameI -> Html ppPatSigType unicode qual typ = - let emptyCtxts = patSigContext typ in ppLType unicode qual emptyCtxts typ + let emptyCtxts = patSigContext typ in ppLSigType unicode qual emptyCtxts typ +ppHsOuterTyVarBndrs :: RenderableBndrFlag flag + => Unicode -> Qualification -> HsOuterTyVarBndrs flag DocNameI -> Html +ppHsOuterTyVarBndrs unicode qual outer_bndrs = case outer_bndrs of + HsOuterImplicit{} -> noHtml + HsOuterExplicit{hso_bndrs = bndrs} -> + hsep (forallSymbol unicode : ppTyVars unicode qual bndrs) +++ dot ppForAllPart :: Unicode -> Qualification -> HsForAllTelescope DocNameI -> Html ppForAllPart unicode qual tele = case tele of @@ -1196,6 +1217,10 @@ HsForAllInvis { hsf_invis_bndrs = bndrs } -> hsep (forallSymbol unicode : ppTyVars unicode qual bndrs) +++ dot +ppr_sig_ty :: HsSigType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html +ppr_sig_ty (HsSig { sig_bndrs = outer_bndrs, sig_body = ltype }) unicode qual emptyCtxts + = ppHsOuterTyVarBndrs unicode qual outer_bndrs <+> ppr_mono_lty ltype unicode qual emptyCtxts + ppr_mono_lty :: LHsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html ppr_mono_lty ty = ppr_mono_ty (unLoc ty) @@ -1223,9 +1248,9 @@ , arr <+> ppr_mono_lty ty2 u q e ] where arr = case mult of - HsLinearArrow _ -> lollipop u + HsLinearArrow _ _ -> lollipop u HsUnrestrictedArrow _ -> arrow u - HsExplicitMult _ m -> multAnnotation <> ppr_mono_lty m u q e <+> arrow u + HsExplicitMult _ _ m -> multAnnotation <> ppr_mono_lty m u q e <+> arrow u ppr_mono_ty (HsTupleTy _ con tys) u q _ = tupleParens con (map (ppLType u q HideEmptyContexts) tys) @@ -1241,7 +1266,7 @@ -- Can now legally occur in ConDeclGADT, the output here is to provide a -- placeholder in the signature, which is followed by the field -- declarations. -ppr_mono_ty (XHsType (NHsCoreTy {})) _ _ _ = error "ppr_mono_ty HsCoreTy" +ppr_mono_ty (XHsType {}) _ _ _ = error "ppr_mono_ty HsCoreTy" ppr_mono_ty (HsExplicitListTy _ IsPromoted tys) u q _ = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys ppr_mono_ty (HsExplicitListTy _ NotPromoted tys) u q _ = brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys ppr_mono_ty (HsExplicitTupleTy _ tys) u q _ = promoQuote $ parenList $ map (ppLType u q HideEmptyContexts) tys @@ -1260,7 +1285,7 @@ -- `(:)` is valid in type signature only as constructor to promoted list -- and needs to be quoted in code so we explicitly quote it here too. ppr_op - | (getOccString . getName . unLoc) op == ":" = promoQuote ppr_op' + | (getOccString . getName . unL) op == ":" = promoQuote ppr_op' | otherwise = ppr_op' ppr_op' = ppLDocName qual Infix op @@ -1277,3 +1302,4 @@ ppr_tylit :: HsTyLit -> Html ppr_tylit (HsNumTy _ n) = toHtml (show n) ppr_tylit (HsStrTy _ s) = toHtml (show s) +ppr_tylit (HsCharTy _ c) = toHtml (show c) diff --git a/src/Haddock/Backends/Xhtml/DocMarkup.hs b/src/Haddock/Backends/Xhtml/DocMarkup.hs --- a/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -31,7 +31,7 @@ import Text.XHtml hiding ( name, p, quote ) import Data.Maybe (fromMaybe) -import GHC +import GHC hiding (anchor) import GHC.Types.Name diff --git a/src/Haddock/Backends/Xhtml/Layout.hs b/src/Haddock/Backends/Xhtml/Layout.hs --- a/src/Haddock/Backends/Xhtml/Layout.hs +++ b/src/Haddock/Backends/Xhtml/Layout.hs @@ -51,7 +51,7 @@ import Data.Maybe (fromMaybe) import GHC.Data.FastString ( unpackFS ) -import GHC +import GHC hiding (anchor) import GHC.Types.Name (nameOccName) -------------------------------------------------------------------------------- @@ -153,16 +153,16 @@ -- | Sub table with source information (optional). subTableSrc :: Maybe Package -> Qualification -> LinksInfo -> Bool - -> [(String, SubDecl, Maybe Module, Located DocName)] -> Maybe Html + -> [(SubDecl, Maybe Module, Located DocName)] -> Maybe Html subTableSrc _ _ _ _ [] = Nothing subTableSrc pkg qual lnks splice decls = Just $ table << aboves (concatMap subRow decls) where - subRow (instanchor, (decl, mdoc, subs), mdl, L loc dn) = + subRow ((decl, mdoc, subs), mdl, L loc dn) = (td ! [theclass "src clearfix"] << (thespan ! [theclass "inst-left"] << decl) <+> linkHtml loc mdl dn <-> - docElement td << fmap (docToHtml (Just instanchor) pkg qual) mdoc + docElement td << fmap (docToHtml Nothing pkg qual) mdoc ) : map (cell . (td <<)) subs @@ -201,7 +201,7 @@ subInstances :: Maybe Package -> Qualification -> String -- ^ Class name, used for anchor generation -> LinksInfo -> Bool - -> [(String, SubDecl, Maybe Module, Located DocName)] -> Html + -> [(SubDecl, Maybe Module, Located DocName)] -> Html subInstances pkg qual nm lnks splice = maybe noHtml wrap . instTable where wrap contents = subSection (hdr +++ collapseDetails id_ DetailsOpen (summary +++ contents)) @@ -214,7 +214,7 @@ subOrphanInstances :: Maybe Package -> Qualification -> LinksInfo -> Bool - -> [(String, SubDecl, Maybe Module, Located DocName)] -> Html + -> [(SubDecl, Maybe Module, Located DocName)] -> Html subOrphanInstances pkg qual lnks splice = maybe noHtml wrap . instTable where wrap = ((h1 << "Orphan instances") +++) diff --git a/src/Haddock/Backends/Xhtml/Names.hs b/src/Haddock/Backends/Xhtml/Names.hs --- a/src/Haddock/Backends/Xhtml/Names.hs +++ b/src/Haddock/Backends/Xhtml/Names.hs @@ -27,7 +27,7 @@ import qualified Data.Map as M import Data.List ( stripPrefix ) -import GHC hiding (LexicalFixity(..)) +import GHC hiding (LexicalFixity(..), anchor) import GHC.Types.Name import GHC.Types.Name.Reader import GHC.Data.FastString (unpackFS) @@ -57,8 +57,9 @@ occHtml = toHtml (showWrapped (occNameString . snd) x) -- TODO: apply ppQualifyName -- The Bool indicates if it is to be rendered in infix notation -ppLDocName :: Qualification -> Notation -> Located DocName -> Html +ppLDocName :: Qualification -> Notation -> GenLocated l DocName -> Html ppLDocName qual notation (L _ d) = ppDocName qual notation True d + ppDocName :: Qualification -> Notation -> Bool -> DocName -> Html ppDocName qual notation insertAnchors docName = diff --git a/src/Haddock/Backends/Xhtml/Themes.hs b/src/Haddock/Backends/Xhtml/Themes.hs --- a/src/Haddock/Backends/Xhtml/Themes.hs +++ b/src/Haddock/Backends/Xhtml/Themes.hs @@ -17,7 +17,6 @@ where import Haddock.Options -import Haddock.Backends.Xhtml.Types ( BaseURL, withBaseURL ) import Control.Monad (liftM) import Data.Char (toLower) @@ -177,13 +176,13 @@ cssFiles ts = nub $ concatMap themeFiles ts -styleSheet :: BaseURL -> Themes -> Html -styleSheet base_url ts = toHtml $ zipWith mkLink rels ts +styleSheet :: Themes -> Html +styleSheet ts = toHtml $ zipWith mkLink rels ts where rels = "stylesheet" : repeat "alternate stylesheet" mkLink aRel t = thelink - ! [ href (withBaseURL base_url (themeHref t)), rel aRel, thetype "text/css", + ! [ href (themeHref t), rel aRel, thetype "text/css", XHtml.title (themeName t) ] << noHtml diff --git a/src/Haddock/Backends/Xhtml/Types.hs b/src/Haddock/Backends/Xhtml/Types.hs --- a/src/Haddock/Backends/Xhtml/Types.hs +++ b/src/Haddock/Backends/Xhtml/Types.hs @@ -12,8 +12,6 @@ ----------------------------------------------------------------------------- module Haddock.Backends.Xhtml.Types ( SourceURLs, WikiURLs, - BaseURL, - withBaseURL, LinksInfo, Splice, Unicode, @@ -22,21 +20,12 @@ import Data.Map import GHC -import qualified System.FilePath as FilePath -- the base, module and entity URLs for the source code and wiki links. type SourceURLs = (Maybe FilePath, Maybe FilePath, Map Unit FilePath, Map Unit FilePath) type WikiURLs = (Maybe FilePath, Maybe FilePath, Maybe FilePath) --- | base url for loading js, json, css resources. The default is "." --- -type BaseURL = Maybe String - --- TODO: we shouldn't use 'FilePath.' -withBaseURL :: BaseURL -> String -> String -withBaseURL Nothing uri = uri -withBaseURL (Just baseUrl) uri = baseUrl FilePath. uri -- The URL for source and wiki links type LinksInfo = (SourceURLs, WikiURLs) diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs --- a/src/Haddock/Convert.hs +++ b/src/Haddock/Convert.hs @@ -22,8 +22,9 @@ #include "HsVersions.h" import GHC.Data.Bag ( emptyBag ) -import GHC.Types.Basic ( TupleSort(..), SourceText(..), LexicalFixity(..) - , PromotionFlag(..), DefMethSpec(..) ) +import GHC.Types.Basic ( TupleSort(..), PromotionFlag(..), DefMethSpec(..), TopLevelFlag(..) ) +import GHC.Types.SourceText (SourceText(..)) +import GHC.Types.Fixity (LexicalFixity(..)) import GHC.Core.Class import GHC.Core.Coercion.Axiom import GHC.Core.ConLike @@ -31,6 +32,7 @@ import GHC.Core.DataCon import GHC.Core.FamInstEnv import GHC.Hs +import GHC.Types.TyThing import GHC.Types.Name import GHC.Types.Name.Set ( emptyNameSet ) import GHC.Types.Name.Reader ( mkVarUnqual ) @@ -43,19 +45,18 @@ import GHC.Builtin.Types ( eqTyConName, listTyConName, liftedTypeKindTyConName , unitTy, promotedNilDataCon, promotedConsDataCon ) import GHC.Builtin.Names ( hasKey, eqTyConKey, ipClassKey, tYPETyConKey - , liftedRepDataConKey ) + , liftedDataConKey, boxedRepDataConKey ) import GHC.Types.Unique ( getUnique ) import GHC.Utils.Misc ( chkAppend, debugIsOn, dropList, equalLength , filterByList, filterOut ) -import GHC.Utils.Outputable ( assertPanic ) +import GHC.Utils.Panic ( assertPanic ) import GHC.Types.Var import GHC.Types.Var.Set import GHC.Types.SrcLoc -import GHC.Parser.Annotation (IsUnicodeSyntax(..)) import Haddock.Types import Haddock.Interface.Specialize -import Haddock.GhcUtils ( orderedFVs, defaultRuntimeRepVars ) +import Haddock.GhcUtils ( orderedFVs, defaultRuntimeRepVars, mkEmptySigType ) import Data.Maybe ( catMaybes, mapMaybe, maybeToList ) @@ -90,26 +91,26 @@ extractFamilyDecl _ = Left "tyThingToLHsDecl: impossible associated tycon" - cvt (UserTyVar _ _ n) = HsTyVar noExtField NotPromoted n - cvt (KindedTyVar _ _ (L name_loc n) kind) = HsKindSig noExtField - (L name_loc (HsTyVar noExtField NotPromoted (L name_loc n))) kind - cvt (XTyVarBndr nec) = noExtCon nec + cvt :: HsTyVarBndr flag GhcRn -> HsType GhcRn + -- Without this signature, we trigger GHC#18932 + cvt (UserTyVar _ _ n) = HsTyVar noAnn NotPromoted n + cvt (KindedTyVar _ _ (L name_loc n) kind) = HsKindSig noAnn + (L (na2la name_loc) (HsTyVar noAnn NotPromoted (L name_loc n))) kind -- | Convert a LHsTyVarBndr to an equivalent LHsType. - hsLTyVarBndrToType :: LHsTyVarBndr flag (GhcPass p) -> LHsType (GhcPass p) + hsLTyVarBndrToType :: LHsTyVarBndr flag GhcRn -> LHsType GhcRn hsLTyVarBndrToType = mapLoc cvt extractFamDefDecl :: FamilyDecl GhcRn -> Type -> TyFamDefltDecl GhcRn extractFamDefDecl fd rhs = - TyFamInstDecl $ HsIB { hsib_ext = hsq_ext (fdTyVars fd) - , hsib_body = FamEqn - { feqn_ext = noExtField + TyFamInstDecl noAnn $ FamEqn + { feqn_ext = noAnn , feqn_tycon = fdLName fd - , feqn_bndrs = Nothing + , feqn_bndrs = HsOuterImplicit{hso_ximplicit = hsq_ext (fdTyVars fd)} , 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 @@ -117,8 +118,8 @@ extractAtItem (ATI at_tc def) = do tyDecl <- synifyTyCon prr Nothing at_tc famDecl <- extractFamilyDecl tyDecl - let defEqnTy = fmap (noLoc . extractFamDefDecl famDecl . fst) def - pure (noLoc famDecl, defEqnTy) + let defEqnTy = fmap (noLocA . extractFamDefDecl famDecl . fst) def + pure (noLocA famDecl, defEqnTy) atTyClDecls = map extractAtItem (classATItems cl) (atFamDecls, atDefFamDecls) = unzip (rights atTyClDecls) @@ -126,14 +127,14 @@ in withErrs (lefts atTyClDecls) . TyClD noExtField $ ClassDecl { tcdCtxt = synifyCtx (classSCTheta cl) - , tcdLName = synifyName cl + , tcdLName = synifyNameN cl , tcdTyVars = synifyTyVars vs , tcdFixity = synifyFixity cl - , tcdFDs = map (\ (l,r) -> noLoc - (map (noLoc . getName) l, map (noLoc . getName) r) ) $ + , tcdFDs = map (\ (l,r) -> noLocA + (FunDep noAnn (map (noLocA . getName) l) (map (noLocA . getName) r)) ) $ snd $ classTvsFds cl - , tcdSigs = noLoc (MinimalSig noExtField NoSourceText . noLoc . fmap noLoc $ classMinimalDef cl) : - [ noLoc tcdSig + , tcdSigs = noLocA (MinimalSig noAnn NoSourceText . noLocA . fmap noLocA $ classMinimalDef cl) : + [ noLocA tcdSig | clsOp <- classOpItems cl , tcdSig <- synifyTcIdSig vs clsOp ] , tcdMeths = emptyBag --ignore default method definitions, they don't affect signature @@ -150,30 +151,30 @@ ACoAxiom ax -> synifyAxiom ax >>= allOK -- a data-constructor alone just gets rendered as a function: - AConLike (RealDataCon dc) -> allOK $ SigD noExtField (TypeSig noExtField [synifyName dc] + AConLike (RealDataCon dc) -> allOK $ SigD noExtField (TypeSig noAnn [synifyNameN dc] (synifySigWcType ImplicitizeForAll [] (dataConWrapperType dc))) AConLike (PatSynCon ps) -> - allOK . SigD noExtField $ PatSynSig noExtField [synifyName ps] (synifyPatSynSigType ps) + allOK . SigD noExtField $ PatSynSig noAnn [synifyNameN ps] (synifyPatSynSigType ps) where withErrs e x = return (e, x) allOK x = return (mempty, x) synifyAxBranch :: TyCon -> CoAxBranch -> TyFamInstEqn GhcRn synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs }) - = let name = synifyName tc + = let name = synifyNameN tc args_types_only = filterOutInvisibleTypes tc args typats = map (synifyType WithinType []) args_types_only 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 = noExtField - , feqn_tycon = name - , feqn_bndrs = Nothing + outer_bndrs = HsOuterImplicit{hso_ximplicit = map tyVarName tkvs} -- TODO: this must change eventually - , feqn_pats = map HsValArg annot_typats - , feqn_fixity = synifyFixity name - , feqn_rhs = hs_rhs } } + in FamEqn { feqn_ext = noAnn + , feqn_tycon = name + , feqn_bndrs = outer_bndrs + , feqn_pats = map HsValArg annot_typats + , feqn_fixity = synifyFixity name + , feqn_rhs = hs_rhs } where args_poly = tyConArgsPolyKinded tc @@ -183,7 +184,7 @@ , Just branch <- coAxiomSingleBranch_maybe ax = return $ InstD noExtField $ TyFamInstD noExtField - $ TyFamInstDecl { tfid_eqn = synifyAxBranch tc branch } + $ TyFamInstDecl { tfid_xtn = noAnn, tfid_eqn = synifyAxBranch tc branch } | Just ax' <- isClosedSynFamilyTyConWithAxiom_maybe tc , getUnique ax' == getUnique ax -- without the getUniques, type error @@ -201,7 +202,7 @@ synifyTyCon prr _coax tc | isFunTyCon tc || isPrimTyCon tc = return $ - DataDecl { tcdLName = synifyName tc + DataDecl { tcdLName = synifyNameN tc , tcdTyVars = HsQTvs { hsq_ext = [] -- No kind polymorphism , hsq_explicit = zipWith mk_hs_tv (map scaledThing tyVarKinds) @@ -213,21 +214,21 @@ , tcdDataDefn = HsDataDefn { dd_ext = noExtField , dd_ND = DataType -- arbitrary lie, they are neither -- algebraic data nor newtype: - , dd_ctxt = noLoc [] + , dd_ctxt = Nothing , dd_cType = Nothing , dd_kindSig = synifyDataTyConReturnKind tc -- we have their kind accurately: , dd_cons = [] -- No constructors - , dd_derivs = noLoc [] } + , dd_derivs = [] } , tcdDExt = DataDeclRn False emptyNameSet } where -- tyConTyVars doesn't work on fun/prim, but we can make them up: mk_hs_tv realKind fakeTyVar - | isLiftedTypeKind realKind = noLoc $ UserTyVar noExtField () (noLoc (getName fakeTyVar)) - | otherwise = noLoc $ KindedTyVar noExtField () (noLoc (getName fakeTyVar)) (synifyKindSig realKind) + | isLiftedTypeKind realKind = noLocA $ UserTyVar noAnn () (noLocA (getName fakeTyVar)) + | otherwise = noLocA $ KindedTyVar noAnn () (noLocA (getName fakeTyVar)) (synifyKindSig realKind) conKind = defaultType prr (tyConKind tc) - tyVarKinds = fst . splitFunTys . snd . splitPiTysInvisible $ conKind + tyVarKinds = fst . splitFunTys . snd . splitInvisPiTys $ conKind synifyTyCon _prr _coax tc | Just flav <- famTyConFlav_maybe tc @@ -237,7 +238,7 @@ ClosedSynFamilyTyCon mb | Just (CoAxiom { co_ax_branches = branches }) <- mb -> mkFamDecl $ ClosedTypeFamily $ Just - $ map (noLoc . synifyAxBranch tc) (fromBranches branches) + $ map (noLocA . synifyAxBranch tc) (fromBranches branches) | otherwise -> mkFamDecl $ ClosedTypeFamily $ Just [] BuiltInSynFamTyCon {} @@ -249,9 +250,10 @@ where resultVar = famTcResVar tc mkFamDecl i = return $ FamDecl noExtField $ - FamilyDecl { fdExt = noExtField + FamilyDecl { fdExt = noAnn , fdInfo = i - , fdLName = synifyName tc + , fdTopLevel = TopLevel + , fdLName = synifyNameN tc , fdTyVars = synifyTyVars (tyConVisibleTyVars tc) , fdFixity = synifyFixity tc , fdResultSig = @@ -264,7 +266,7 @@ synifyTyCon _prr coax tc | Just ty <- synTyConRhs_maybe tc = return $ SynDecl { tcdSExt = emptyNameSet - , tcdLName = synifyName tc + , tcdLName = synifyNameN tc , tcdTyVars = synifyTyVars (tyConVisibleTyVars tc) , tcdFixity = synifyFixity tc , tcdRhs = synifyType WithinType [] ty } @@ -274,9 +276,9 @@ alg_nd = if isNewTyCon tc then NewType else DataType alg_ctx = synifyCtx (tyConStupidTheta tc) name = case coax of - Just a -> synifyName a -- Data families are named according to their + Just a -> synifyNameN a -- Data families are named according to their -- CoAxioms, not their TyCons - _ -> synifyName tc + _ -> synifyNameN tc tyvars = synifyTyVars (tyConVisibleTyVars tc) kindSig = synifyDataTyConReturnKind tc -- The data constructors. @@ -299,7 +301,7 @@ consRaw = map (synifyDataCon use_gadt_syntax) (tyConDataCons tc) cons = rights consRaw -- "deriving" doesn't affect the signature, no need to specify any. - alg_deriv = noLoc [] + alg_deriv = [] defn = HsDataDefn { dd_ext = noExtField , dd_ND = alg_nd , dd_ctxt = alg_ctx @@ -340,15 +342,15 @@ synifyInjectivityAnn Nothing _ _ = Nothing synifyInjectivityAnn _ _ NotInjective = Nothing synifyInjectivityAnn (Just lhs) tvs (Injective inj) = - let rhs = map (noLoc . tyVarName) (filterByList inj tvs) - in Just $ noLoc $ InjectivityAnn (noLoc lhs) rhs + let rhs = map (noLocA . tyVarName) (filterByList inj tvs) + in Just $ noLoc $ InjectivityAnn noAnn (noLocA lhs) rhs synifyFamilyResultSig :: Maybe Name -> Kind -> LFamilyResultSig GhcRn synifyFamilyResultSig Nothing kind | isLiftedTypeKind kind = noLoc $ NoSig noExtField | otherwise = noLoc $ KindSig noExtField (synifyKindSig kind) synifyFamilyResultSig (Just name) kind = - noLoc $ TyVarSig noExtField (noLoc $ KindedTyVar noExtField () (noLoc name) (synifyKindSig kind)) + noLoc $ TyVarSig noExtField (noLocA $ KindedTyVar noAnn () (noLocA 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,59 +364,77 @@ -- infix *syntax*. use_infix_syntax = dataConIsInfix dc use_named_field_syntax = not (null field_tys) - name = synifyName dc + name = synifyNameN dc -- con_qvars means a different thing depending on gadt-syntax (_univ_tvs, ex_tvs, _eq_spec, theta, arg_tys, res_ty) = dataConFullSig dc user_tvbndrs = dataConUserTyVarBinders dc -- Used for GADT data constructors + outer_bndrs | null user_tvbndrs + = HsOuterImplicit { hso_ximplicit = [] } + | otherwise + = HsOuterExplicit { hso_xexplicit = noExtField + , hso_bndrs = map synifyTyVarBndr user_tvbndrs } + -- skip any EqTheta, use 'orig'inal syntax ctx | null theta = Nothing - | otherwise = Just $ synifyCtx theta + | otherwise = synifyCtx theta linear_tys = zipWith (\ty bang -> let tySyn = synifyType WithinType [] (scaledThing ty) in case bang of (HsSrcBang _ NoSrcUnpack NoSrcStrict) -> tySyn - bang' -> noLoc $ HsBangTy noExtField bang' tySyn) + bang' -> noLocA $ HsBangTy noAnn bang' tySyn) arg_tys (dataConSrcBangs dc) field_tys = zipWith con_decl_field (dataConFieldLabels dc) linear_tys - con_decl_field fl synTy = noLoc $ - ConDeclField noExtField [noLoc $ FieldOcc (flSelector fl) (noLoc $ mkVarUnqual $ flLabel fl)] synTy + con_decl_field fl synTy = noLocA $ + ConDeclField noAnn [noLoc $ FieldOcc (flSelector fl) (noLocA $ mkVarUnqual $ flLabel fl)] synTy Nothing - hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of - (True,True) -> Left "synifyDataCon: contradiction!" - (True,False) -> return $ RecCon (noLoc field_tys) - (False,False) -> return $ PrefixCon (map hsUnrestricted linear_tys) - (False,True) -> case linear_tys of - [a,b] -> return $ InfixCon (hsUnrestricted a) (hsUnrestricted b) - _ -> Left "synifyDataCon: infix with non-2 args?" + + mk_h98_arg_tys :: Either ErrMsg (HsConDeclH98Details GhcRn) + mk_h98_arg_tys = case (use_named_field_syntax, use_infix_syntax) of + (True,True) -> Left "synifyDataCon: contradiction!" + (True,False) -> return $ RecCon (noLocA field_tys) + (False,False) -> return $ PrefixCon noTypeArgs (map hsUnrestricted linear_tys) + (False,True) -> case linear_tys of + [a,b] -> return $ InfixCon (hsUnrestricted a) (hsUnrestricted b) + _ -> Left "synifyDataCon: infix with non-2 args?" + + mk_gadt_arg_tys :: HsConDeclGADTDetails GhcRn + mk_gadt_arg_tys + | use_named_field_syntax = RecConGADT (noLocA field_tys) + | otherwise = PrefixConGADT (map hsUnrestricted linear_tys) + -- finally we get synifyDataCon's result! - in hs_arg_tys >>= - \hat -> - if use_gadt_syntax - then return $ noLoc $ - ConDeclGADT { con_g_ext = [] - , con_names = [name] - , con_forall = noLoc $ not $ null user_tvbndrs - , con_qvars = map synifyTyVarBndr user_tvbndrs - , con_mb_cxt = ctx - , con_args = hat - , con_res_ty = synifyType WithinType [] res_ty - , con_doc = Nothing } - else return $ noLoc $ - ConDeclH98 { con_ext = noExtField - , con_name = name - , con_forall = noLoc False - , con_ex_tvs = map (synifyTyVarBndr . (mkTyCoVarBinder InferredSpec)) ex_tvs - , con_mb_cxt = ctx - , con_args = hat - , con_doc = Nothing } + in if use_gadt_syntax + then do + let hat = mk_gadt_arg_tys + return $ noLocA $ ConDeclGADT + { con_g_ext = noAnn + , con_names = [name] + , con_bndrs = noLocA outer_bndrs + , con_mb_cxt = ctx + , con_g_args = hat + , con_res_ty = synifyType WithinType [] res_ty + , con_doc = Nothing } + else do + hat <- mk_h98_arg_tys + return $ noLocA $ ConDeclH98 + { con_ext = noAnn + , con_name = name + , con_forall = False + , con_ex_tvs = map (synifyTyVarBndr . (mkTyCoVarBinder InferredSpec)) ex_tvs + , con_mb_cxt = ctx + , con_args = hat + , con_doc = Nothing } -synifyName :: NamedThing n => n -> Located Name -synifyName n = L (srcLocSpan (getSrcLoc n)) (getName n) +synifyNameN :: NamedThing n => n -> LocatedN Name +synifyNameN n = L (noAnnSrcSpan $ srcLocSpan (getSrcLoc n)) (getName n) +-- synifyName :: NamedThing n => n -> LocatedA Name +-- synifyName n = L (noAnnSrcSpan $ srcLocSpan (getSrcLoc n)) (getName n) + -- | Guess the fixity of a something with a name. This isn't quite right, since -- a user can always declare an infix name in prefix form or a prefix name in -- infix form. Unfortunately, that is not something we can usually reconstruct. @@ -428,7 +448,7 @@ -> [TyVar] -- ^ free variables in the type to convert -> Id -- ^ the 'Id' from which to get the type signature -> Sig GhcRn -synifyIdSig prr s vs i = TypeSig noExtField [synifyName i] (synifySigWcType s vs t) +synifyIdSig prr s vs i = TypeSig noAnn [synifyNameN i] (synifySigWcType s vs t) where t = defaultType prr (varType i) @@ -437,15 +457,15 @@ -- 'ClassOpSig'. synifyTcIdSig :: [TyVar] -> ClassOpItem -> [Sig GhcRn] synifyTcIdSig vs (i, dm) = - [ ClassOpSig noExtField False [synifyName i] (mainSig (varType i)) ] ++ - [ ClassOpSig noExtField True [noLoc dn] (defSig dt) + [ ClassOpSig noAnn False [synifyNameN i] (mainSig (varType i)) ] ++ + [ ClassOpSig noAnn True [noLocA dn] (defSig dt) | Just (dn, GenericDM dt) <- [dm] ] where mainSig t = synifySigType DeleteTopLevelQuantification vs t defSig t = synifySigType ImplicitizeForAll vs t -synifyCtx :: [PredType] -> LHsContext GhcRn -synifyCtx = noLoc . map (synifyType WithinType []) +synifyCtx :: [PredType] -> Maybe (LHsContext GhcRn) +synifyCtx ts = Just (noLocA ( map (synifyType WithinType []) ts)) synifyTyVars :: [TyVar] -> LHsQTyVars GhcRn @@ -466,8 +486,8 @@ synify_ty_var :: VarSet -> flag -> TyVar -> LHsTyVarBndr flag GhcRn synify_ty_var no_kinds flag tv | isLiftedTypeKind kind || tv `elemVarSet` no_kinds - = noLoc (UserTyVar noExtField flag (noLoc name)) - | otherwise = noLoc (KindedTyVar noExtField flag (noLoc name) (synifyKindSig kind)) + = noLocA (UserTyVar noAnn flag (noLocA name)) + | otherwise = noLocA (KindedTyVar noAnn flag (noLocA name) (synifyKindSig kind)) where kind = tyVarKind tv name = getName tv @@ -484,7 +504,7 @@ | not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType ty = let ki = typeKind ty hs_ki = synifyType WithinType [] ki - in noLoc (HsKindSig noExtField hs_ty hs_ki) + in noLocA (HsKindSig noAnn hs_ty hs_ki) annotHsType _ _ hs_ty = hs_ty -- | For every argument type that a type constructor accepts, @@ -526,17 +546,17 @@ synifySigType :: SynifyTypeState -> [TyVar] -> Type -> LHsSigType GhcRn --- The empty binders is a bit suspicious; --- what if the type has free variables? -synifySigType s vs ty = mkEmptyImplicitBndrs (synifyType s vs ty) +-- The use of mkEmptySigType (which uses empty binders in OuterImplicit) +-- is a bit suspicious; what if the type has free variables? +synifySigType s vs ty = mkEmptySigType (synifyType s vs ty) synifySigWcType :: SynifyTypeState -> [TyVar] -> Type -> LHsSigWcType GhcRn -- Ditto (see synifySigType) -synifySigWcType s vs ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs (synifyType s vs ty)) +synifySigWcType s vs ty = mkEmptyWildCardBndrs (mkEmptySigType (synifyType s vs ty)) synifyPatSynSigType :: PatSyn -> LHsSigType GhcRn -- Ditto (see synifySigType) -synifyPatSynSigType ps = mkEmptyImplicitBndrs (synifyPatSynType ps) +synifyPatSynSigType ps = mkEmptySigType (synifyPatSynType ps) -- | Depending on the first argument, try to default all type variables of kind -- 'RuntimeRep' to 'LiftedType'. @@ -550,7 +570,7 @@ -> [TyVar] -- ^ free variables in the type to convert -> Type -- ^ the type to convert -> LHsType GhcRn -synifyType _ _ (TyVarTy tv) = noLoc $ HsTyVar noExtField NotPromoted $ noLoc (getName tv) +synifyType _ _ (TyVarTy tv) = noLocA $ HsTyVar noAnn NotPromoted $ noLocA (getName tv) synifyType _ vs (TyConApp tc tys) = maybe_sig res_ty where @@ -558,65 +578,66 @@ res_ty -- Use */# instead of TYPE 'Lifted/TYPE 'Unlifted (#473) | tc `hasKey` tYPETyConKey - , [TyConApp lev []] <- tys - , lev `hasKey` liftedRepDataConKey - = noLoc (HsTyVar noExtField NotPromoted (noLoc liftedTypeKindTyConName)) + , [TyConApp rep [TyConApp lev []]] <- tys + , rep `hasKey` boxedRepDataConKey + , lev `hasKey` liftedDataConKey + = noLocA (HsTyVar noAnn NotPromoted (noLocA liftedTypeKindTyConName)) -- Use non-prefix tuple syntax where possible, because it looks nicer. | Just sort <- tyConTuple_maybe tc , tyConArity tc == tys_len - = noLoc $ HsTupleTy noExtField + = noLocA $ HsTupleTy noAnn (case sort of - BoxedTuple -> HsBoxedTuple - ConstraintTuple -> HsConstraintTuple + BoxedTuple -> HsBoxedOrConstraintTuple + ConstraintTuple -> HsBoxedOrConstraintTuple UnboxedTuple -> HsUnboxedTuple) (map (synifyType WithinType vs) vis_tys) - | isUnboxedSumTyCon tc = noLoc $ HsSumTy noExtField (map (synifyType WithinType vs) vis_tys) + | isUnboxedSumTyCon tc = noLocA $ HsSumTy noAnn (map (synifyType WithinType vs) vis_tys) | Just dc <- isPromotedDataCon_maybe tc , isTupleDataCon dc , dataConSourceArity dc == length vis_tys - = noLoc $ HsExplicitTupleTy noExtField (map (synifyType WithinType vs) vis_tys) + = noLocA $ HsExplicitTupleTy noExtField (map (synifyType WithinType vs) vis_tys) -- ditto for lists | getName tc == listTyConName, [ty] <- vis_tys = - noLoc $ HsListTy noExtField (synifyType WithinType vs ty) + noLocA $ HsListTy noAnn (synifyType WithinType vs ty) | tc == promotedNilDataCon, [] <- vis_tys - = noLoc $ HsExplicitListTy noExtField IsPromoted [] + = noLocA $ 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 noExtField IsPromoted (hTy : tTy') + -> noLocA $ HsExplicitListTy noExtField IsPromoted (hTy : tTy') | otherwise - -> noLoc $ HsOpTy noExtField hTy (noLoc $ getName tc) tTy + -> noLocA $ HsOpTy noExtField hTy (noLocA $ getName tc) tTy -- ditto for implicit parameter tycons | tc `hasKey` ipClassKey , [name, ty] <- tys , Just x <- isStrLitTy name - = noLoc $ HsIParamTy noExtField (noLoc $ HsIPName x) (synifyType WithinType vs ty) + = noLocA $ HsIParamTy noAnn (noLoc $ HsIPName x) (synifyType WithinType vs ty) -- and equalities | tc `hasKey` eqTyConKey , [ty1, ty2] <- tys - = noLoc $ HsOpTy noExtField + = noLocA $ HsOpTy noExtField (synifyType WithinType vs ty1) - (noLoc eqTyConName) + (noLocA eqTyConName) (synifyType WithinType vs ty2) -- and infix type operators | isSymOcc (nameOccName (getName tc)) , ty1:ty2:tys_rest <- vis_tys = mk_app_tys (HsOpTy noExtField (synifyType WithinType vs ty1) - (noLoc $ getName tc) + (noLocA $ getName tc) (synifyType WithinType vs ty2)) tys_rest -- Most TyCons: | otherwise - = mk_app_tys (HsTyVar noExtField prom $ noLoc (getName tc)) + = mk_app_tys (HsTyVar noAnn prom $ noLocA (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 noExtField t1 t2) - (noLoc ty_app) + foldl (\t1 t2 -> noLocA $ HsAppTy noExtField t1 t2) + (noLocA ty_app) (map (synifyType WithinType vs) $ filterOut isCoercionTy ty_args) @@ -628,7 +649,7 @@ | tyConAppNeedsKindSig False tc tys_len = let full_kind = typeKind (mkTyConApp tc tys) full_kind' = synifyType WithinType vs full_kind - in noLoc $ HsKindSig noExtField ty' full_kind' + in noLocA $ HsKindSig noAnn ty' full_kind' | otherwise = ty' synifyType _ vs ty@(AppTy {}) = let @@ -638,19 +659,19 @@ filterOut isCoercionTy $ filterByList (map isVisibleArgFlag $ appTyArgFlags ty_head ty_args) ty_args - in foldl (\t1 t2 -> noLoc $ HsAppTy noExtField t1 t2) ty_head' ty_args' + in foldl (\t1 t2 -> noLocA $ HsAppTy noExtField t1 t2) ty_head' ty_args' synifyType s vs funty@(FunTy InvisArg _ _ _) = synifySigmaType s vs funty synifyType _ vs (FunTy VisArg w t1 t2) = let s1 = synifyType WithinType vs t1 s2 = synifyType WithinType vs t2 w' = synifyMult vs w - in noLoc $ HsFunTy noExtField w' s1 s2 + in noLocA $ HsFunTy noAnn w' s1 s2 synifyType s vs forallty@(ForAllTy (Bndr _ argf) _ty) = case argf of Required -> synifyVisForAllType vs forallty Invisible _ -> synifySigmaType s vs forallty -synifyType _ _ (LitTy t) = noLoc $ HsTyLit noExtField $ synifyTyLit t +synifyType _ _ (LitTy t) = noLocA $ HsTyLit noExtField $ synifyTyLit t synifyType s vs (CastTy t _) = synifyType s vs t synifyType _ _ (CoercionTy {}) = error "synifyType:Coercion" @@ -668,9 +689,9 @@ -- absence of an explicit forall tvs' = orderedFVs (mkVarSet vs) [rho] - in noLoc $ HsForAllTy { hst_tele = mkHsForAllVisTele sTvs - , hst_xforall = noExtField - , hst_body = synifyType WithinType (tvs' ++ vs) rho } + in noLocA $ HsForAllTy { hst_tele = mkHsForAllVisTele noAnn sTvs + , hst_xforall = noExtField + , hst_body = synifyType WithinType (tvs' ++ vs) rho } -- | Process a 'Type' which starts with an invisible @forall@ or a constraint -- into an 'HsType' @@ -685,9 +706,9 @@ , hst_xqual = noExtField , hst_body = synifyType WithinType (tvs' ++ vs) tau } - sTy = HsForAllTy { hst_tele = mkHsForAllInvisTele sTvs + sTy = HsForAllTy { hst_tele = mkHsForAllInvisTele noAnn sTvs , hst_xforall = noExtField - , hst_body = noLoc sPhi } + , hst_body = noLocA sPhi } sTvs = map synifyTyVarBndr tvs @@ -700,8 +721,8 @@ -- Put a forall in if there are any type variables WithinType - | not (null tvs) -> noLoc sTy - | otherwise -> noLoc sPhi + | not (null tvs) -> noLocA sTy + | otherwise -> noLocA sPhi ImplicitizeForAll -> implicitForAll [] vs tvs ctx (synifyType WithinType) tau @@ -717,9 +738,9 @@ -> Type -- ^ inner type -> LHsType GhcRn implicitForAll tycons vs tvs ctx synInner tau - | any (isHsKindedTyVar . unLoc) sTvs = noLoc sTy - | tvs' /= (binderVars tvs) = noLoc sTy - | otherwise = noLoc sPhi + | any (isHsKindedTyVar . unLoc) sTvs = noLocA sTy + | tvs' /= (binderVars tvs) = noLocA sTy + | otherwise = noLocA sPhi where sRho = synInner (tvs' ++ vs) tau sPhi | null ctx = unLoc sRho @@ -727,9 +748,9 @@ = HsQualTy { hst_ctxt = synifyCtx ctx , hst_xqual = noExtField , hst_body = synInner (tvs' ++ vs) tau } - sTy = HsForAllTy { hst_tele = mkHsForAllInvisTele sTvs + sTy = HsForAllTy { hst_tele = mkHsForAllInvisTele noAnn sTvs , hst_xforall = noExtField - , hst_body = noLoc sPhi } + , hst_body = noLocA sPhi } no_kinds_needed = noKindTyVars tycons tau sTvs = map (synifyTyVarBndr' no_kinds_needed) tvs @@ -778,9 +799,9 @@ synifyMult :: [TyVar] -> Mult -> HsArrow GhcRn synifyMult vs t = case t of - One -> HsLinearArrow NormalSyntax + One -> HsLinearArrow NormalSyntax Nothing Many -> HsUnrestrictedArrow NormalSyntax - ty -> HsExplicitMult NormalSyntax (synifyType WithinType vs ty) + ty -> HsExplicitMult NormalSyntax Nothing (synifyType WithinType vs ty) @@ -804,6 +825,7 @@ synifyTyLit :: TyLit -> HsTyLit synifyTyLit (NumTyLit n) = HsNumTy NoSourceText n synifyTyLit (StrTyLit s) = HsStrTy NoSourceText s +synifyTyLit (CharTyLit c) = HsCharTy NoSourceText c synifyKindSig :: Kind -> LHsKind GhcRn synifyKindSig k = synifyType WithinType [] k diff --git a/src/Haddock/GhcUtils.hs b/src/Haddock/GhcUtils.hs --- a/src/Haddock/GhcUtils.hs +++ b/src/Haddock/GhcUtils.hs @@ -1,5 +1,8 @@ {-# LANGUAGE BangPatterns, StandaloneDeriving, FlexibleInstances, ViewPatterns #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -21,17 +24,19 @@ import Control.Arrow import Data.Char ( isSpace ) -import Data.Maybe ( mapMaybe ) +import Data.Maybe ( mapMaybe, fromMaybe ) -import Haddock.Types( DocName, DocNameI ) +import Haddock.Types( DocName, DocNameI, XRecCond ) import GHC.Utils.FV as FV -import GHC.Utils.Outputable ( Outputable, panic, showPpr ) -import GHC.Types.Basic (PromotionFlag(..)) +import GHC.Utils.Outputable ( Outputable ) +import GHC.Utils.Panic ( panic ) +import GHC.Driver.Ppr (showPpr ) import GHC.Types.Name import GHC.Unit.Module import GHC import GHC.Driver.Session +import GHC.Types.Basic import GHC.Types.SrcLoc ( advanceSrcLoc ) import GHC.Types.Var ( Specificity, VarBndr(..), TyVarBinder , tyVarKind, updateTyVarKind, isInvisibleArgFlag ) @@ -39,8 +44,7 @@ import GHC.Types.Var.Env ( TyVarEnv, extendVarEnv, elemVarEnv, emptyVarEnv ) import GHC.Core.TyCo.Rep ( Type(..) ) import GHC.Core.Type ( isRuntimeRepVar ) -import GHC.Builtin.Types( liftedRepDataConTyCon ) -import GHC.Parser.Annotation (IsUnicodeSyntax(..)) +import GHC.Builtin.Types( liftedRepTy ) import GHC.Data.StringBuffer ( StringBuffer ) import qualified GHC.Data.StringBuffer as S @@ -49,6 +53,8 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Internal as BS +import GHC.HsToCore.Docs + moduleString :: Module -> String moduleString = moduleNameString . moduleName @@ -68,45 +74,32 @@ filterSigNames p (FixSig _ (FixitySig _ ns ty)) = case filter (p . unLoc) ns of [] -> Nothing - filtered -> Just (FixSig noExtField (FixitySig noExtField filtered ty)) + filtered -> Just (FixSig noAnn (FixitySig noExtField filtered ty)) filterSigNames _ orig@(MinimalSig _ _ _) = Just orig filterSigNames p (TypeSig _ ns ty) = case filter (p . unLoc) ns of [] -> Nothing - filtered -> Just (TypeSig noExtField filtered ty) + filtered -> Just (TypeSig noAnn filtered ty) filterSigNames p (ClassOpSig _ is_default ns ty) = case filter (p . unLoc) ns of [] -> Nothing - filtered -> Just (ClassOpSig noExtField is_default filtered ty) + filtered -> Just (ClassOpSig noAnn is_default filtered ty) filterSigNames p (PatSynSig _ ns ty) = case filter (p . unLoc) ns of [] -> Nothing - filtered -> Just (PatSynSig noExtField filtered ty) + filtered -> Just (PatSynSig noAnn filtered ty) filterSigNames _ _ = Nothing ifTrueJust :: Bool -> name -> Maybe name ifTrueJust True = Just ifTrueJust False = const Nothing -sigName :: LSig name -> [IdP name] +sigName :: LSig GhcRn -> [IdP GhcRn] sigName (L _ sig) = sigNameNoLoc sig -sigNameNoLoc :: Sig name -> [IdP name] -sigNameNoLoc (TypeSig _ ns _) = map unLoc ns -sigNameNoLoc (ClassOpSig _ _ ns _) = map unLoc ns -sigNameNoLoc (PatSynSig _ ns _) = map unLoc ns -sigNameNoLoc (SpecSig _ n _ _) = [unLoc n] -sigNameNoLoc (InlineSig _ n _) = [unLoc n] -sigNameNoLoc (FixSig _ (FixitySig _ ns _)) = map unLoc ns -sigNameNoLoc _ = [] - -- | 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 :: forall p. UnXRec p => LSig p -> Bool +isUserLSig = isUserSig . unXRec @p isClassD :: HsDecl a -> Bool isClassD (TyClD _ d) = isClassDecl d @@ -121,10 +114,10 @@ -- instantiated at DocNameI instead of (GhcPass _). -- | Like 'hsTyVarName' from GHC API, but not instantiated at (GhcPass _) -hsTyVarBndrName :: (XXTyVarBndr n ~ NoExtCon) => HsTyVarBndr flag n -> IdP n -hsTyVarBndrName (UserTyVar _ _ name) = unLoc name -hsTyVarBndrName (KindedTyVar _ _ (L _ name) _) = name -hsTyVarBndrName (XTyVarBndr nec) = noExtCon nec +hsTyVarBndrName :: forall flag n. (XXTyVarBndr n ~ NoExtCon, UnXRec n) + => HsTyVarBndr flag n -> IdP n +hsTyVarBndrName (UserTyVar _ _ name) = unXRec @n name +hsTyVarBndrName (KindedTyVar _ _ name _) = unXRec @n name hsTyVarNameI :: HsTyVarBndr flag DocNameI -> DocName hsTyVarNameI (UserTyVar _ _ (L _ n)) = n @@ -133,50 +126,62 @@ hsLTyVarNameI :: LHsTyVarBndr flag DocNameI -> DocName hsLTyVarNameI = hsTyVarNameI . unLoc -getConNamesI :: ConDecl DocNameI -> [Located DocName] +getConNamesI :: ConDecl DocNameI -> [LocatedN DocName] getConNamesI ConDeclH98 {con_name = name} = [name] getConNamesI ConDeclGADT {con_names = names} = names -hsImplicitBodyI :: HsImplicitBndrs DocNameI thing -> thing -hsImplicitBodyI (HsIB { hsib_body = body }) = body - hsSigTypeI :: LHsSigType DocNameI -> LHsType DocNameI -hsSigTypeI = hsImplicitBodyI +hsSigTypeI = sig_body . unLoc +mkEmptySigType :: LHsType GhcRn -> LHsSigType GhcRn +-- Dubious, because the implicit binders are empty even +-- though the type might have free varaiables +mkEmptySigType lty@(L loc ty) = L loc $ case ty of + HsForAllTy { hst_tele = HsForAllInvis { hsf_invis_bndrs = bndrs } + , hst_body = body } + -> HsSig { sig_ext = noExtField + , sig_bndrs = HsOuterExplicit { hso_xexplicit = noExtField + , hso_bndrs = bndrs } + , sig_body = body } + _ -> HsSig { sig_ext = noExtField + , sig_bndrs = HsOuterImplicit{hso_ximplicit = []} + , sig_body = lty } + mkHsForAllInvisTeleI :: [LHsTyVarBndr Specificity DocNameI] -> HsForAllTelescope DocNameI mkHsForAllInvisTeleI invis_bndrs = HsForAllInvis { hsf_xinvis = noExtField, hsf_invis_bndrs = invis_bndrs } -getConArgsI :: ConDecl DocNameI -> HsConDeclDetails DocNameI -getConArgsI d = con_args d +mkHsImplicitSigTypeI :: LHsType DocNameI -> HsSigType DocNameI +mkHsImplicitSigTypeI body = + HsSig { sig_ext = noExtField + , sig_bndrs = HsOuterImplicit{hso_ximplicit = noExtField} + , sig_body = body } -getGADTConType :: ConDecl DocNameI -> LHsType DocNameI +getGADTConType :: ConDecl DocNameI -> LHsSigType DocNameI -- The full type of a GADT data constructor We really only get this in -- order to pretty-print it, and currently only in Haddock's code. So -- we are cavalier about locations and extensions, hence the -- 'undefined's -getGADTConType (ConDeclGADT { con_forall = L _ has_forall - , con_qvars = qtvs - , con_mb_cxt = mcxt, con_args = args +getGADTConType (ConDeclGADT { con_bndrs = L _ outer_bndrs + , con_mb_cxt = mcxt, con_g_args = args , con_res_ty = res_ty }) - | has_forall = noLoc (HsForAllTy { hst_xforall = noExtField - , hst_tele = mkHsForAllInvisTeleI qtvs - , hst_body = theta_ty }) - | otherwise = theta_ty + = noLocA (HsSig { sig_ext = noExtField + , sig_bndrs = outer_bndrs + , sig_body = theta_ty }) where theta_ty | Just theta <- mcxt - = noLoc (HsQualTy { hst_xqual = noExtField, hst_ctxt = theta, hst_body = tau_ty }) + = noLocA (HsQualTy { hst_xqual = noAnn, hst_ctxt = Just theta, hst_body = tau_ty }) | otherwise = tau_ty -- tau_ty :: LHsType DocNameI tau_ty = case args of - RecCon flds -> mkFunTy (noLoc (HsRecTy noExtField (unLoc flds))) res_ty - PrefixCon pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args) - InfixCon arg1 arg2 -> (hsScaledThing arg1) `mkFunTy` ((hsScaledThing arg2) `mkFunTy` res_ty) + RecConGADT flds -> mkFunTy (noLocA (HsRecTy noAnn (unLoc flds))) res_ty + PrefixConGADT pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args) - mkFunTy a b = noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) a b) + mkFunTy :: LHsType DocNameI -> LHsType DocNameI -> LHsType DocNameI + mkFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) a b) getGADTConType (ConDeclH98 {}) = panic "getGADTConType" -- Should only be called on ConDeclGADT @@ -184,7 +189,7 @@ getMainDeclBinderI :: HsDecl DocNameI -> [IdP DocNameI] getMainDeclBinderI (TyClD _ d) = [tcdNameI d] getMainDeclBinderI (ValD _ d) = - case collectHsBindBinders d of + case collectHsBindBinders CollNoDictBinders d of [] -> [] (name:_) -> [name] getMainDeclBinderI (SigD _ d) = sigNameNoLoc d @@ -192,10 +197,10 @@ getMainDeclBinderI (ForD _ (ForeignExport _ _ _ _)) = [] getMainDeclBinderI _ = [] -familyDeclLNameI :: FamilyDecl DocNameI -> Located DocName +familyDeclLNameI :: FamilyDecl DocNameI -> LocatedN DocName familyDeclLNameI (FamilyDecl { fdLName = n }) = n -tyClDeclLNameI :: TyClDecl DocNameI -> Located DocName +tyClDeclLNameI :: TyClDecl DocNameI -> LocatedN DocName tyClDeclLNameI (FamDecl { tcdFam = fd }) = familyDeclLNameI fd tyClDeclLNameI (SynDecl { tcdLName = ln }) = ln tyClDeclLNameI (DataDecl { tcdLName = ln }) = ln @@ -204,73 +209,35 @@ tcdNameI :: TyClDecl DocNameI -> DocName tcdNameI = unLoc . tyClDeclLNameI --- ------------------------------------- - -getGADTConTypeG :: ConDecl GhcRn -> LHsType GhcRn --- The full type of a GADT data constructor We really only get this in --- order to pretty-print it, and currently only in Haddock's code. So --- we are cavalier about locations and extensions, hence the --- 'undefined's -getGADTConTypeG (ConDeclGADT { con_forall = L _ has_forall - , con_qvars = qtvs - , con_mb_cxt = mcxt, con_args = args - , con_res_ty = res_ty }) - | has_forall = noLoc (HsForAllTy { hst_xforall = noExtField - , hst_tele = mkHsForAllInvisTele qtvs - , hst_body = theta_ty }) - | otherwise = theta_ty - where - theta_ty | Just theta <- mcxt - = noLoc (HsQualTy { hst_xqual = noExtField, hst_ctxt = theta, hst_body = tau_ty }) - | otherwise - = tau_ty - --- tau_ty :: LHsType DocNameI - tau_ty = case args of - RecCon flds -> mkFunTy (noLoc (HsRecTy noExtField (unLoc flds))) res_ty - PrefixCon pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args) - InfixCon arg1 arg2 -> (hsScaledThing arg1) `mkFunTy` ((hsScaledThing arg2) `mkFunTy` res_ty) - - -- mkFunTy :: LHsType DocNameI -> LHsType DocNameI -> LHsType DocNameI - mkFunTy a b = noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) a b) - -getGADTConTypeG (ConDeclH98 {}) = panic "getGADTConTypeG" - -- Should only be called on ConDeclGADT - - -mkEmptySigWcType :: LHsType GhcRn -> LHsSigWcType GhcRn --- Dubious, because the implicit binders are empty even --- though the type might have free varaiables -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 noExtField lname (mkEmptySigWcType (go (hsSigType ltype)))) - -- The mkEmptySigWcType is suspicious + = L pos (TypeSig noAnn lname (mkEmptyWildCardBndrs (go_sig_ty ltype))) where - go (L loc (HsForAllTy { hst_tele = tele, hst_body = ty })) - = L loc (HsForAllTy { hst_tele = tele, hst_xforall = noExtField - , hst_body = go ty }) - go (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty })) + go_sig_ty (L loc (HsSig { sig_bndrs = bndrs, sig_body = ty })) + = L loc (HsSig { sig_ext = noExtField + , sig_bndrs = bndrs, sig_body = go_ty ty }) + + go_ty (L loc (HsForAllTy { hst_tele = tele, hst_body = ty })) + = L loc (HsForAllTy { hst_xforall = noExtField + , hst_tele = tele, hst_body = go_ty ty }) + go_ty (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty })) = L loc (HsQualTy { hst_xqual = noExtField , hst_ctxt = add_ctxt ctxt, hst_body = ty }) - go (L loc ty) + go_ty (L loc ty) = L loc (HsQualTy { hst_xqual = noExtField - , hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty }) + , hst_ctxt = add_ctxt Nothing, hst_body = L loc ty }) - extra_pred :: LHsType GhcRn - extra_pred = nlHsTyConApp Prefix cls (map HsValArg (lHsQTyVarsToTypes tvs0)) + extra_pred = nlHsTyConApp Prefix cls (lHsQTyVarsToTypes tvs0) - add_ctxt :: LHsContext GhcRn -> LHsContext GhcRn - add_ctxt (L loc preds) = L loc (extra_pred : preds) + add_ctxt Nothing = Just $ noLocA [extra_pred] + add_ctxt (Just (L loc preds)) = Just $ L loc (extra_pred : preds) addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine -lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsType GhcRn] +lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsTypeArg GhcRn] lHsQTyVarsToTypes tvs - = [ noLoc (HsTyVar noExtField NotPromoted (noLoc (hsLTyVarName tv))) + = [ HsValArg $ noLocA (HsTyVar noAnn NotPromoted (noLocA (hsLTyVarName tv))) | tv <- hsQTvExplicit tvs ] @@ -278,7 +245,6 @@ -- * Making abstract declarations -------------------------------------------------------------------------------- - restrictTo :: [Name] -> LHsDecl GhcRn -> LHsDecl GhcRn restrictTo names (L loc decl) = L loc $ case decl of TyClD x d | isDataDecl d -> @@ -301,17 +267,27 @@ restrictCons :: [Name] -> [LConDecl GhcRn] -> [LConDecl GhcRn] restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] where - keep d | any (\n -> n `elem` names) (map unLoc $ getConNames d) = - case con_args d of - PrefixCon _ -> Just d - RecCon fields - | all field_avail (unLoc fields) -> Just d - | otherwise -> Just (d { con_args = PrefixCon (field_types $ unLoc fields) }) - -- if we have *all* the field names available, then - -- keep the record declaration. Otherwise degrade to - -- a constructor declaration. This isn't quite right, but - -- it's the best we can do. - InfixCon _ _ -> Just d + keep :: ConDecl GhcRn -> Maybe (ConDecl GhcRn) + keep d + | any (\n -> n `elem` names) (map unLoc $ getConNames d) = + case d of + ConDeclH98 { con_args = con_args' } -> case con_args' of + PrefixCon {} -> Just d + RecCon fields + | all field_avail (unLoc fields) -> Just d + | otherwise -> Just (d { con_args = PrefixCon [] (field_types $ unLoc fields) }) + -- if we have *all* the field names available, then + -- keep the record declaration. Otherwise degrade to + -- a constructor declaration. This isn't quite right, but + -- it's the best we can do. + InfixCon _ _ -> Just d + + ConDeclGADT { con_g_args = con_args' } -> case con_args' of + PrefixConGADT {} -> Just d + RecConGADT fields + | all field_avail (unLoc fields) -> Just d + | otherwise -> Just (d { con_g_args = PrefixConGADT (field_types $ unLoc fields) }) + -- see above where field_avail :: LConDeclField GhcRn -> Bool field_avail (L _ (ConDeclField _ fs _ _)) @@ -356,17 +332,18 @@ -- -- 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 ~ NoExtField) => Precedence -> HsType a -> HsType a +reparenTypePrec :: forall a. (XRecCond a) + => Precedence -> HsType a -> HsType a reparenTypePrec = go where -- Shorter name for 'reparenType' - go :: (XParTy a ~ NoExtField) => Precedence -> HsType a -> HsType a + go :: XParTy a ~ EpAnn AnnParen => Precedence -> HsType a -> HsType a go _ (HsBangTy x b ty) = HsBangTy x b (reparenLType ty) go _ (HsTupleTy x con tys) = HsTupleTy x con (map reparenLType tys) go _ (HsSumTy x tys) = HsSumTy x (map reparenLType tys) go _ (HsListTy x ty) = HsListTy x (reparenLType ty) - go _ (HsRecTy x flds) = HsRecTy x (map (fmap reparenConDeclField) flds) + go _ (HsRecTy x flds) = HsRecTy x (map (mapXRec @a reparenConDeclField) flds) go p (HsDocTy x ty d) = HsDocTy x (goL p ty) d go _ (HsExplicitListTy x p tys) = HsExplicitListTy x p (map reparenLType tys) go _ (HsExplicitTupleTy x tys) = HsExplicitTupleTy x (map reparenLType tys) @@ -379,7 +356,11 @@ go p (HsQualTy x ctxt ty) = let p' [_] = PREC_CTX p' _ = PREC_TOP -- parens will get added anyways later... - in paren p PREC_CTX $ HsQualTy x (fmap (\xs -> map (goL (p' xs)) xs) ctxt) (goL PREC_TOP ty) + ctxt' = case ctxt of + Nothing -> Nothing + Just c -> Just $ mapXRec @a (\xs -> map (goL (p' xs)) xs) c + in paren p PREC_CTX $ HsQualTy x ctxt' (goL PREC_TOP ty) + -- = paren p PREC_FUN $ HsQualTy x (fmap (mapXRec @a (map reparenLType)) ctxt) (reparenLType ty) go p (HsFunTy x w ty1 ty2) = paren p PREC_FUN $ HsFunTy x w (goL PREC_FUN ty1) (goL PREC_TOP ty2) go p (HsAppTy x fun_ty arg_ty) @@ -388,7 +369,7 @@ = paren p PREC_CON $ HsAppKindTy x (goL PREC_FUN fun_ty) (goL PREC_CON arg_ki) go p (HsOpTy x ty1 op ty2) = paren p PREC_FUN $ HsOpTy x (goL PREC_OP ty1) op (goL PREC_OP ty2) - go p (HsParTy _ t) = unLoc $ goL p t -- pretend the paren doesn't exist - it will be added back if needed + go p (HsParTy _ t) = unXRec @a $ goL p t -- pretend the paren doesn't exist - it will be added back if needed go _ t@HsTyVar{} = t go _ t@HsStarTy{} = t go _ t@HsSpliceTy{} = t @@ -397,43 +378,58 @@ go _ t@XHsType{} = t -- Located variant of 'go' - goL :: (XParTy a ~ NoExtField) => Precedence -> LHsType a -> LHsType a - goL ctxt_prec = fmap (go ctxt_prec) + goL :: XParTy a ~ EpAnn AnnParen => Precedence -> LHsType a -> LHsType a + goL ctxt_prec = mapXRec @a (go ctxt_prec) -- Optionally wrap a type in parens - paren :: (XParTy a ~ NoExtField) + paren :: XParTy a ~ EpAnn AnnParen => 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 noExtField . noLoc + paren ctxt_prec op_prec | ctxt_prec >= op_prec = HsParTy noAnn . wrapXRec @a | otherwise = id -- | Add parenthesis around the types in a 'HsType' (see 'reparenTypePrec') -reparenType :: (XParTy a ~ NoExtField) => HsType a -> HsType a +reparenType :: XRecCond a => HsType a -> HsType a reparenType = reparenTypePrec PREC_TOP -- | Add parenthesis around the types in a 'LHsType' (see 'reparenTypePrec') -reparenLType :: (XParTy a ~ NoExtField) => LHsType a -> LHsType a -reparenLType = fmap reparenType +reparenLType :: forall a. (XRecCond a) => LHsType a -> LHsType a +reparenLType = mapXRec @a reparenType +-- | Add parentheses around the types in an 'HsSigType' (see 'reparenTypePrec') +reparenSigType :: forall a. ( XRecCond a ) + => HsSigType a -> HsSigType a +reparenSigType (HsSig x bndrs body) = + HsSig x (reparenOuterTyVarBndrs bndrs) (reparenLType body) +reparenSigType v@XHsSigType{} = v + +-- | Add parentheses around the types in an 'HsOuterTyVarBndrs' (see 'reparenTypePrec') +reparenOuterTyVarBndrs :: forall flag a. ( XRecCond a ) + => HsOuterTyVarBndrs flag a -> HsOuterTyVarBndrs flag a +reparenOuterTyVarBndrs imp@HsOuterImplicit{} = imp +reparenOuterTyVarBndrs (HsOuterExplicit x exp_bndrs) = + HsOuterExplicit x (map (mapXRec @(NoGhcTc a) reparenTyVar) exp_bndrs) +reparenOuterTyVarBndrs v@XHsOuterTyVarBndrs{} = v + -- | Add parentheses around the types in an 'HsForAllTelescope' (see 'reparenTypePrec') -reparenHsForAllTelescope :: (XParTy a ~ NoExtField) +reparenHsForAllTelescope :: forall a. (XRecCond a ) => HsForAllTelescope a -> HsForAllTelescope a reparenHsForAllTelescope (HsForAllVis x bndrs) = - HsForAllVis x (map (fmap reparenTyVar) bndrs) + HsForAllVis x (map (mapXRec @a reparenTyVar) bndrs) reparenHsForAllTelescope (HsForAllInvis x bndrs) = - HsForAllInvis x (map (fmap reparenTyVar) bndrs) + HsForAllInvis x (map (mapXRec @a reparenTyVar) bndrs) reparenHsForAllTelescope v@XHsForAllTelescope{} = v -- | Add parenthesis around the types in a 'HsTyVarBndr' (see 'reparenTypePrec') -reparenTyVar :: (XParTy a ~ NoExtField) => HsTyVarBndr flag a -> HsTyVarBndr flag a +reparenTyVar :: (XRecCond a) => HsTyVarBndr flag a -> HsTyVarBndr flag a reparenTyVar (UserTyVar x flag n) = UserTyVar x flag n reparenTyVar (KindedTyVar x flag n kind) = KindedTyVar x flag n (reparenLType kind) reparenTyVar v@XTyVarBndr{} = v -- | Add parenthesis around the types in a 'ConDeclField' (see 'reparenTypePrec') -reparenConDeclField :: (XParTy a ~ NoExtField) => ConDeclField a -> ConDeclField a +reparenConDeclField :: (XRecCond a) => ConDeclField a -> ConDeclField a reparenConDeclField (ConDeclField x n t d) = ConDeclField x n (reparenLType t) d reparenConDeclField c@XConDeclField{} = c @@ -443,13 +439,15 @@ ------------------------------------------------------------------------------- -unL :: Located a -> a +unL :: GenLocated l a -> a unL (L _ x) = x - -reL :: a -> Located a +reL :: a -> GenLocated l a reL = L undefined +mapMA :: Monad m => (a -> m b) -> LocatedAn an a -> m (Located b) +mapMA f (L al a) = L (locA al) <$> f a + ------------------------------------------------------------------------------- -- * NamedThing instances ------------------------------------------------------------------------------- @@ -469,10 +467,9 @@ instance Parent (ConDecl GhcRn) where children con = - case con_args con of - RecCon fields -> map (extFieldOcc . unLoc) $ - concatMap (cd_fld_names . unLoc) (unLoc fields) - _ -> [] + case getRecConArgs_maybe con of + Nothing -> [] + Just flds -> map (extFieldOcc . unLoc) $ concatMap (cd_fld_names . unLoc) (unLoc flds) instance Parent (TyClDecl GhcRn) where children d @@ -738,7 +735,7 @@ go subs (TyVarTy tv) | tv `elemVarEnv` subs - = TyConApp liftedRepDataConTyCon [] + = liftedRepTy | otherwise = TyVarTy (updateTyVarKind (go subs) tv) @@ -756,3 +753,6 @@ go _ ty@(LitTy {}) = ty go _ ty@(CoercionTy {}) = ty + +fromMaybeContext :: Maybe (LHsContext DocNameI) -> HsContext DocNameI +fromMaybeContext mctxt = unLoc $ fromMaybe (noLocA []) mctxt diff --git a/src/Haddock/Interface.hs b/src/Haddock/Interface.hs --- a/src/Haddock/Interface.hs +++ b/src/Haddock/Interface.hs @@ -43,39 +43,40 @@ import Haddock.Types (DocOption (..), Documentation (..), ExportItem (..), IfaceMap, InstIfaceMap, Interface, LinkEnv, expItemDecl, expItemMbDoc, ifaceDoc, ifaceExportItems, ifaceExports, ifaceHaddockCoverage, ifaceInstances, ifaceMod, ifaceOptions, ifaceVisibleExports, instMod, runWriter, throwE) -import Haddock.Utils (Verbosity, normal, out, verbose) +import Haddock.Utils (Verbosity (..), normal, out, verbose) import Control.Monad (unless, when) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.IORef (atomicModifyIORef', newIORef, readIORef) import Data.List (foldl', isPrefixOf, nub) +import Text.Printf (printf) import qualified Data.Map as Map import qualified Data.Set as Set -import Text.Printf (printf) import GHC hiding (verbosity) import GHC.Data.FastString (unpackFS) -import GHC.Data.Graph.Directed -import GHC.Driver.Monad (modifySession) +import GHC.Data.Graph.Directed (flattenSCCs) +import GHC.Driver.Env (hsc_dflags, hsc_home_unit, hsc_logger, hsc_static_plugins, hsc_units) +import GHC.Driver.Monad (modifySession, withTimingM) import GHC.Driver.Session hiding (verbosity) -import GHC.Driver.Types (isBootSummary) import GHC.HsToCore.Docs (getMainDeclBinder) -import GHC.Plugins (HscEnv (..), Outputable, Plugin (..), PluginWithArgs (..), StaticPlugin (..), defaultPlugin, - keepRenamedSource) +import GHC.Plugins (Outputable, Plugin (..), PluginWithArgs (..), StaticPlugin (..), defaultPlugin, keepRenamedSource) import GHC.Tc.Types (TcGblEnv (..), TcM) import GHC.Tc.Utils.Env (tcLookupGlobal) -import GHC.Tc.Utils.Monad (setGblEnv) +import GHC.Tc.Utils.Monad (getTopEnv, setGblEnv) import GHC.Types.Name (nameIsFromExternalPackage, nameOccName) import GHC.Types.Name.Occurrence (isTcOcc) -import GHC.Types.Name.Reader (globalRdrEnvElts, gre_name, unQualOK) +import GHC.Types.Name.Reader (globalRdrEnvElts, greMangledName, unQualOK) import GHC.Unit.Module.Env (ModuleSet, emptyModuleSet, mkModuleSet, unionModuleSet) +import GHC.Unit.Module.Graph (ModuleGraphNode (..)) +import GHC.Unit.Module.ModSummary (emsModSummary, isBootSummary) import GHC.Unit.Types (IsBootInterface (..)) -import GHC.Utils.Error (withTimingD) +import GHC.Utils.Error (withTiming) #if defined(mingw32_HOST_OS) -import GHC.IO.Encoding.CodePage (mkLocaleEncoding) -import GHC.IO.Encoding.Failure (CodingFailureMode (TransliterateCodingFailure)) import System.IO +import GHC.IO.Encoding.CodePage (mkLocaleEncoding) +import GHC.IO.Encoding.Failure (CodingFailureMode(TransliterateCodingFailure)) #endif -- | Create 'Interface's and a link environment by typechecking the list of @@ -112,7 +113,7 @@ mods = Set.fromList $ map ifaceMod interfaces out verbosity verbose "Attaching instances..." interfaces' <- {-# SCC attachInstances #-} - withTimingD "attachInstances" (const ()) $ do + withTimingM "attachInstances" (const ()) $ do attachInstances (exportedNames, mods) interfaces instIfaceMap ms out verbosity verbose "Building cross-linking environment..." @@ -146,10 +147,10 @@ installHaddockPlugin :: HscEnv -> HscEnv installHaddockPlugin hsc_env = hsc_env { - hsc_dflags = (gopt_set (hsc_dflags hsc_env) Opt_PluginTrustworthy) - { - staticPlugins = haddockPlugin : staticPlugins (hsc_dflags hsc_env) - } + hsc_dflags = + gopt_set (hsc_dflags hsc_env) Opt_PluginTrustworthy + , hsc_static_plugins = + haddockPlugin : hsc_static_plugins hsc_env } -- Note that we would rather use withTempSession but as long as we @@ -160,7 +161,7 @@ targets <- mapM (\filePath -> guessTarget filePath Nothing) modules setTargets targets - loadOk <- withTimingD "load" (const ()) $ + loadOk <- withTimingM "load" (const ()) $ {-# SCC load #-} GHC.load LoadAllTargets case loadOk of @@ -176,9 +177,9 @@ ifaces = [ Map.findWithDefault (error "haddock:iface") - (ms_mod ms) + (ms_mod (emsModSummary ems)) ifaceMap - | ms <- flattenSCCs $ topSortModuleGraph True modGraph Nothing + | ModuleNode ems <- flattenSCCs $ topSortModuleGraph True modGraph Nothing ] return (ifaces, moduleSet) @@ -209,9 +210,11 @@ | IsBoot <- isBootSummary mod_summary = pure () | otherwise = do + hsc_env <- getTopEnv ifaces <- liftIO $ readIORef ifaceMapRef - (iface, modules) <- withTimingD "processModule" (const ()) $ - processModule1 verbosity flags ifaces instIfaceMap mod_summary tc_gbl_env + (iface, modules) <- withTiming (hsc_logger hsc_env) (hsc_dflags hsc_env) + "processModule" (const ()) $ + processModule1 verbosity flags ifaces instIfaceMap hsc_env mod_summary tc_gbl_env liftIO $ do atomicModifyIORef' ifaceMapRef $ \xs -> @@ -249,44 +252,50 @@ -> [Flag] -> IfaceMap -> InstIfaceMap + -> HscEnv -> ModSummary -> TcGblEnv -> TcM (Interface, ModuleSet) -processModule1 verbosity flags ifaces inst_ifaces mod_summary tc_gbl_env = do +processModule1 verbosity flags ifaces inst_ifaces hsc_env mod_summary tc_gbl_env = do out verbosity verbose "Creating interface..." let TcGblEnv { tcg_rdr_env } = tc_gbl_env - (!interface, messages) <- {-# SCC createInterface #-} - withTimingD "createInterface" (const ()) $ runIfM (fmap Just . tcLookupGlobal) $ - createInterface1 flags mod_summary tc_gbl_env ifaces inst_ifaces + unit_state = hsc_units hsc_env + (!interface, messages) <- do + logger <- getLogger + dflags <- getDynFlags + {-# SCC createInterface #-} + withTiming logger dflags "createInterface" (const ()) $ runIfM (fmap Just . tcLookupGlobal) $ + createInterface1 flags unit_state mod_summary tc_gbl_env + ifaces inst_ifaces + -- We need to keep track of which modules were somehow in scope so that when -- Haddock later looks for instances, it also looks in these modules too. -- -- See https://github.com/haskell/haddock/issues/469. - dflags <- getDynFlags let mods :: ModuleSet !mods = mkModuleSet [ nameModule name | gre <- globalRdrEnvElts tcg_rdr_env - , let name = gre_name gre - , nameIsFromExternalPackage (homeUnit dflags) name + , let name = greMangledName gre + , nameIsFromExternalPackage (hsc_home_unit hsc_env) name , isTcOcc (nameOccName name) -- Types and classes only , unQualOK gre -- In scope unqualified ] liftIO $ mapM_ putStrLn (nub messages) + dflags <- getDynFlags let (haddockable, haddocked) = ifaceHaddockCoverage interface percentage :: Int - percentage = - round (fromIntegral haddocked * 100 / fromIntegral haddockable :: Double) + percentage = div (haddocked * 100) haddockable modString :: String modString = moduleString (ifaceMod interface) @@ -302,7 +311,7 @@ undocumentedExports :: [String] undocumentedExports = - [ formatName s n + [ formatName (locA s) n | ExportDecl { expItemDecl = L s n , expItemMbDoc = (Documentation Nothing _, _) } <- ifaceExportItems interface diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs --- a/src/Haddock/Interface/AttachInstances.hs +++ b/src/Haddock/Interface/AttachInstances.hs @@ -30,14 +30,11 @@ import GHC.Data.FastString (unpackFS) import GHC.Core.Class -import GHC.Driver.Session import GHC.Core (isOrphan) -import GHC.Utils.Error import GHC.Core.FamInstEnv import GHC import GHC.Core.InstEnv import GHC.Unit.Module.Env ( ModuleSet, moduleSetElts ) -import GHC.Utils.Monad (liftIO) import GHC.Types.Name import GHC.Types.Name.Env import GHC.Utils.Outputable (text, sep, (<+>)) @@ -104,7 +101,7 @@ fam_instances = maybeToList mb_instances >>= snd fam_insts = [ ( synFamInst , getInstDoc n - , spanNameE n synFamInst (L eSpan (tcdName d)) + , spanNameE n synFamInst (L (locA eSpan) (tcdName d)) , nameModule_maybe n ) | i <- sortBy (comparing instFam) fam_instances @@ -116,7 +113,7 @@ ] cls_insts = [ ( synClsInst , getInstDoc n - , spanName n synClsInst (L eSpan (tcdName d)) + , spanName n synClsInst (L (locA eSpan) (tcdName d)) , nameModule_maybe n ) | let is = [ (instanceSig i, getName i) | i <- cls_instances ] @@ -128,9 +125,8 @@ cleanFamInsts = [ (fi, n, L l r, m) | (Right fi, n, L l (Right r), m) <- fam_insts ] famInstErrs = [ errm | (Left errm, _, _, _) <- fam_insts ] in do - dfs <- getDynFlags let mkBug = (text "haddock-bug:" <+>) . text - liftIO $ putMsg dfs (sep $ map mkBug famInstErrs) + putMsgM (sep $ map mkBug famInstErrs) return $ cls_insts ++ cleanFamInsts return $ e { expItemInstances = insts } e -> return e @@ -197,6 +193,7 @@ data SimpleType = SimpleType SName [SimpleType] | SimpleIntTyLit Integer | SimpleStringTyLit String + | SimpleCharTyLit Char deriving (Eq,Ord) @@ -222,6 +219,7 @@ (mapMaybe simplify_maybe ts) simplify (LitTy (NumTyLit n)) = SimpleIntTyLit n simplify (LitTy (StrTyLit s)) = SimpleStringTyLit (unpackFS s) +simplify (LitTy (CharTyLit c)) = SimpleCharTyLit c simplify (CastTy ty _) = simplify ty simplify (CoercionTy _) = error "simplify:Coercion" diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -6,6 +6,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} @@ -32,50 +33,54 @@ import Documentation.Haddock.Doc (metaDocAppend) import Haddock.Convert (PrintRuntimeReps (..), tyThingToLHsDecl) -import Haddock.GhcUtils (addClassContext, filterSigNames, lHsQTyVarsToTypes, mkEmptySigWcType, moduleString, parents, - pretty, restrictTo, sigName) -import Haddock.Interface.LexParseRn +import Haddock.GhcUtils (addClassContext, filterSigNames, lHsQTyVarsToTypes, mkEmptySigType, moduleString, parents, + pretty, restrictTo, sigName, unL) +import Haddock.Interface.LexParseRn (processDocString, processDocStringParas, processDocStrings, processModuleHeader) import Haddock.Options (Flag (..), modulePackageInfo) import Haddock.Types hiding (liftErrMsg) import Haddock.Utils (replace) -import Control.Monad.Catch (MonadCatch, MonadThrow) -import Control.Monad.Reader (MonadReader (..), ReaderT (..), asks) +import Control.Applicative ((<|>)) +import Control.Monad.Reader (MonadReader (..), ReaderT, asks, runReaderT) import Control.Monad.Writer.Strict hiding (tell) import Data.Bitraversable (bitraverse) import Data.List (find, foldl') +import qualified Data.IntMap as IM +import Data.IntMap (IntMap) import Data.Map (Map) import qualified Data.Map as M import Data.Maybe (catMaybes, fromJust, isJust, mapMaybe, maybeToList) import Data.Traversable (for) -import GHC.Stack (HasCallStack) import GHC hiding (lookupName) import GHC.Core.Class (ClassMinimalDef, classMinimalDef) import GHC.Core.ConLike (ConLike (..)) import GHC.Data.FastString (bytesFS, unpackFS) -import GHC.Driver.Types (HscSource (..), WarningTxt (..), Warnings (..), msHsFilePath) +import GHC.Driver.Ppr (showSDoc) import GHC.HsToCore.Docs hiding (mkMaps) +import GHC.IORef (readIORef) import GHC.Parser.Annotation (IsUnicodeSyntax (..)) +import GHC.Stack (HasCallStack) import GHC.Tc.Types hiding (IfM) import GHC.Tc.Utils.Monad (finalSafeMode) import GHC.Types.Avail hiding (avail) import qualified GHC.Types.Avail as Avail -import GHC.Types.Basic (PromotionFlag (..), SourceText (..), StringLiteral (..)) +import GHC.Types.Basic (PromotionFlag (..)) import GHC.Types.Name (getOccString, getSrcSpan, isDataConName, isValName, nameIsLocalOrFrom, nameOccName) import GHC.Types.Name.Env (lookupNameEnv) -import GHC.Types.Name.Reader (GlobalRdrEnv, globalRdrEnvElts, gre_name, gresToAvailInfo, isLocalGRE, lookupGlobalRdrEnv) +import GHC.Types.Name.Reader (GlobalRdrEnv, greMangledName, lookupGlobalRdrEnv) import GHC.Types.Name.Set (elemNameSet, mkNameSet) +import GHC.Types.SourceFile (HscSource (..)) +import GHC.Types.SourceText (SourceText (..), sl_fs) import qualified GHC.Types.SrcLoc as SrcLoc import qualified GHC.Unit.Module as Module -import GHC.Unit.State +import GHC.Unit.Module.ModSummary (msHsFilePath) +import GHC.Unit.Module.Warnings (WarningTxt (..), Warnings (..)) +import GHC.Unit.State (PackageName (..), UnitState, lookupModuleInAllUnits) import qualified GHC.Utils.Outputable as O - - -mkExceptionContext :: ModSummary -> String -mkExceptionContext = - ("creating Haddock interface for " ++) . moduleNameString . ms_mod_name - +import GHC.Utils.Panic (pprPanic) +import GHC.HsToCore.Docs hiding (mkMaps) +import GHC.Unit.Module.Warnings newtype IfEnv m = IfEnv { @@ -92,14 +97,13 @@ -- over the Ghc specific clarifies where side effects happen. newtype IfM m a = IfM { unIfM :: ReaderT (IfEnv m) (WriterT [ErrMsg] m) a } + deriving newtype instance Functor m => Functor (IfM m) deriving newtype instance Applicative m => Applicative (IfM m) deriving newtype instance Monad m => Monad (IfM m) deriving newtype instance MonadIO m => MonadIO (IfM m) deriving newtype instance Monad m => MonadReader (IfEnv m) (IfM m) deriving newtype instance Monad m => MonadWriter [ErrMsg] (IfM m) -deriving newtype instance (MonadThrow m) => MonadThrow (IfM m) -deriving newtype instance (MonadCatch m) => MonadCatch (IfM m) -- | Run an `IfM` action. @@ -132,15 +136,15 @@ createInterface1 - :: (MonadIO m, MonadCatch m) + :: MonadIO m => [Flag] + -> UnitState -> ModSummary -> TcGblEnv -> IfaceMap -> InstIfaceMap -> IfM m Interface -createInterface1 flags mod_sum tc_gbl_env ifaces inst_ifaces = - withExceptionContext (mkExceptionContext mod_sum) $ do +createInterface1 flags unit_state mod_sum tc_gbl_env ifaces inst_ifaces = do let ModSummary @@ -171,6 +175,7 @@ , tcg_rn_exports , tcg_rn_decls + , tcg_th_docs , tcg_doc_hdr } = tc_gbl_env @@ -179,7 +184,7 @@ is_sig = tcg_src == HsigFile (pkg_name_fs, _) = - modulePackageInfo dflags flags (Just tcg_mod) + modulePackageInfo unit_state flags (Just tcg_mod) pkg_name :: Maybe Package pkg_name = @@ -197,7 +202,7 @@ loc_splices :: [SrcSpan] loc_splices = case tcg_rn_decls of Nothing -> [] - Just HsGroup { hs_splcds } -> [ loc | L loc _ <- hs_splcds ] + Just HsGroup { hs_splcds } -> [ locA loc | L loc _ <- hs_splcds ] decls <- case tcg_rn_decls of Nothing -> do @@ -221,16 +226,9 @@ Nothing -- All the exported Names of this module. - actual_exports :: [AvailInfo] - actual_exports - | OptIgnoreExports `elem` doc_opts = - gresToAvailInfo $ filter isLocalGRE $ globalRdrEnvElts tcg_rdr_env - | otherwise = - tcg_exports - exported_names :: [Name] exported_names = - concatMap availNamesWithSelectors actual_exports + concatMap availNamesWithSelectors tcg_exports -- Module imports of the form `import X`. Note that there is -- a) no qualification and @@ -253,9 +251,13 @@ -- Infer module safety safety <- liftIO (finalSafeMode ms_hspp_opts tc_gbl_env) + -- The docs added via Template Haskell's putDoc + thDocs@ExtractedTHDocs { ethd_mod_header = thMbDocStr } <- + liftIO $ extractTHDocs <$> readIORef tcg_th_docs + -- Process the top-level module header documentation. (!info, header_doc) <- liftErrMsg $ processModuleHeader dflags pkg_name - tcg_rdr_env safety tcg_doc_hdr + tcg_rdr_env safety (thMbDocStr <|> (unLoc <$> tcg_doc_hdr)) -- Warnings on declarations in this module decl_warnings <- liftErrMsg (mkWarningMap dflags tcg_warns tcg_rdr_env exported_names) @@ -269,11 +271,11 @@ warnings = M.unions (decl_warnings : map ifaceWarningMap (M.elems ifaces)) maps@(!docs, !arg_docs, !decl_map, _) <- - liftErrMsg (mkMaps dflags pkg_name tcg_rdr_env local_instances decls) + liftErrMsg (mkMaps dflags pkg_name tcg_rdr_env local_instances decls thDocs) export_items <- mkExportItems is_sig ifaces pkg_name tcg_mod tcg_semantic_mod warnings tcg_rdr_env exported_names (map fst decls) maps fixities - imported_modules loc_splices export_list actual_exports inst_ifaces dflags + imported_modules loc_splices export_list tcg_exports inst_ifaces dflags let visible_names :: [Name] @@ -290,7 +292,7 @@ !coverage = (haddockable, haddocked) aliases :: Map Module ModuleName - aliases = mkAliasMap (unitState dflags) tcg_rn_imports + aliases = mkAliasMap unit_state tcg_rn_imports return $! Interface { @@ -365,7 +367,7 @@ -- -- With our mapping we know that we can display exported modules M1 and M2. -- -unrestrictedModuleImports :: [ImportDecl name] -> M.Map ModuleName [ModuleName] +unrestrictedModuleImports :: [ImportDecl GhcRn] -> M.Map ModuleName [ModuleName] unrestrictedModuleImports idecls = M.map (map (unLoc . ideclName)) $ M.filter (all isInteresting) impModMap @@ -414,7 +416,7 @@ let ws' = [ (n, w) | (occ, w) <- ws , elt <- lookupGlobalRdrEnv gre occ - , let n = gre_name elt, n `elem` exps ] + , let n = greMangledName elt, n `elem` exps ] in M.fromList <$> traverse (bitraverse pure (parseWarning dflags gre)) ws' moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings -> ErrMsgM (Maybe (Doc Name)) @@ -481,11 +483,14 @@ -> GlobalRdrEnv -> [Name] -> [(LHsDecl GhcRn, [HsDocString])] + -> ExtractedTHDocs -- ^ Template Haskell putDoc docs -> ErrMsgM Maps -mkMaps dflags pkgName gre instances decls = do +mkMaps dflags pkgName gre instances decls thDocs = do (a, b, c) <- unzip3 <$> traverse mappings decls - pure ( f' (map (nubByName fst) a) - , f (filterMapping (not . M.null) b) + (th_a, th_b) <- thMappings + pure ( th_a `M.union` f' (map (nubByName fst) a) + , fmap intmap2mapint $ + th_b `unionArgMaps` (f (filterMapping (not . IM.null) b)) , f (filterMapping (not . null) c) , instanceMap ) @@ -499,14 +504,37 @@ filterMapping :: (b -> Bool) -> [[(a, b)]] -> [[(a, b)]] filterMapping p = map (filter (p . snd)) + -- Convert IntMap -> IntMap + -- TODO: should ArgMap eventually be switched over to IntMap? + intmap2mapint = M.fromList . IM.toList + + -- | Extract the mappings from template haskell. + -- No DeclMap/InstMap is needed since we already have access to the + -- doc strings + thMappings :: ErrMsgM (Map Name (MDoc Name), Map Name (IntMap (MDoc Name))) + thMappings = do + let ExtractedTHDocs + _ + (DeclDocMap declDocs) + (ArgDocMap argDocs) + (DeclDocMap instDocs) = thDocs + ds2mdoc :: HsDocString -> ErrMsgM (MDoc Name) + ds2mdoc = processDocStringParas dflags pkgName gre + + declDocs' <- mapM ds2mdoc declDocs + argDocs' <- mapM (mapM ds2mdoc) argDocs + instDocs' <- mapM ds2mdoc instDocs + return (declDocs' <> instDocs', argDocs') + + mappings :: (LHsDecl GhcRn, [HsDocString]) -> ErrMsgM ( [(Name, MDoc Name)] - , [(Name, Map Int (MDoc Name))] + , [(Name, IntMap (MDoc Name))] , [(Name, [LHsDecl GhcRn])] ) - mappings (ldecl@(L (RealSrcSpan l _) decl), docStrs) = do - let declDoc :: [HsDocString] -> Map Int HsDocString - -> ErrMsgM (Maybe (MDoc Name), Map Int (MDoc Name)) + mappings (ldecl@(L (SrcSpanAnn _ (RealSrcSpan l _)) decl), docStrs) = do + let declDoc :: [HsDocString] -> IntMap HsDocString + -> ErrMsgM (Maybe (MDoc Name), IntMap (MDoc Name)) declDoc strs m = do doc' <- processDocStrings dflags pkgName gre strs m' <- traverse (processDocStringParas dflags pkgName gre) m @@ -515,7 +543,7 @@ (doc, args) <- declDoc docStrs (declTypeDocs decl) let - subs :: [(Name, [HsDocString], Map Int HsDocString)] + subs :: [(Name, [HsDocString], IntMap HsDocString)] subs = subordinates instanceMap decl (subDocs, subArgs) <- unzip <$> traverse (\(_, strs, m) -> declDoc strs m) subs @@ -533,7 +561,7 @@ seqList subDocs `seq` seqList subArgs `seq` pure (dm, am, cm) - mappings (L (UnhelpfulSpan _) _, _) = pure ([], [], []) + mappings (L (SrcSpanAnn _ (UnhelpfulSpan _)) _, _) = pure ([], [], []) instanceMap :: Map RealSrcSpan Name instanceMap = M.fromList [(l, n) | n <- instances, RealSrcSpan l _ <- [getSrcSpan n] ] @@ -544,7 +572,7 @@ -- The CoAx's loc is the whole line, but only for TFs. The -- workaround is to dig into the family instance declaration and -- get the identifier with the right location. - TyFamInstD _ (TyFamInstDecl d') -> getLoc (feqn_tycon (hsib_body d')) + TyFamInstD _ (TyFamInstDecl _ d') -> getLocA (feqn_tycon d') _ -> getInstLoc d names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See note [2]. names _ decl = getMainDeclBinder decl @@ -578,7 +606,7 @@ -- We create the export items even if the module is hidden, since they -- might be useful when creating the export items for other modules. mkExportItems - :: (Monad m) + :: Monad m => Bool -- is it a signature -> IfaceMap -> Maybe Package -- this package @@ -617,7 +645,7 @@ return [ExportDoc doc] lookupExport (IEDocNamed _ str, _) = liftErrMsg $ - findNamedDoc str [ unLoc d | d <- decls ] >>= \case + findNamedDoc str [ unL d | d <- decls ] >>= \case Nothing -> return [] Just docStr -> do doc <- processDocStringParas dflags pkgName gre docStr @@ -675,18 +703,19 @@ let t = availName avail r <- findDecl avail case r of - ([L l (ValD _ _)], (doc, _)) -> do + ([L l' (ValD _ _)], (doc, _)) -> do + let l = locA l' -- Top-level binding without type signature export <- hiValExportItem dflags t l doc (l `elem` splices) $ M.lookup t fixMap return [export] (ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds -> - let declNames = getMainDeclBinder (unLoc decl) + let declNames = getMainDeclBinder (unL decl) in case () of _ -- We should not show a subordinate by itself if any of its -- parents is also exported. See note [1]. | t `notElem` declNames, - Just p <- find isExported (parents t $ unLoc decl) -> + Just p <- find isExported (parents t $ unL decl) -> do liftErrMsg $ tell [ "Warning: " ++ moduleString thisMod ++ ": " ++ pretty dflags (nameOccName t) ++ " is exported separately but " ++ @@ -706,11 +735,11 @@ let newDecl = L loc . SigD noExtField . fromJust $ filterSigNames (== t) sig in availExportDecl avail newDecl docs_ - L loc (TyClD _ cl@ClassDecl{}) -> do + L loc (TyClD _ ClassDecl {..}) -> do mdef <- minimalDef t - let sig = maybeToList $ fmap (noLoc . MinimalSig noExtField NoSourceText . noLoc . fmap noLoc) mdef + let sig = maybeToList $ fmap (noLocA . MinimalSig noAnn NoSourceText . noLocA . fmap noLocA) mdef availExportDecl avail - (L loc $ TyClD noExtField cl { tcdSigs = sig ++ tcdSigs cl }) docs_ + (L loc $ TyClD noExtField ClassDecl { tcdSigs = sig ++ tcdSigs, .. }) docs_ _ -> availExportDecl avail decl docs_ @@ -744,7 +773,7 @@ synifiedDeclOpt <- hiDecl dflags declName case synifiedDeclOpt of Just synifiedDecl -> pure synifiedDecl - Nothing -> O.pprPanic "availExportItem" (O.text err) + Nothing -> pprPanic "availExportItem" (O.text err) availExportDecl :: AvailInfo -> LHsDecl GhcRn -> (DocForDecl Name, [(Name, DocForDecl Name)]) @@ -842,16 +871,8 @@ constructor_names = filter isDataConName (availSubordinates avail) --- this heavily depends on the invariants stated in Avail -availExportsDecl :: AvailInfo -> Bool -availExportsDecl (AvailTC ty_name names _) - | n : _ <- names = ty_name == n - | otherwise = False -availExportsDecl _ = True - availSubordinates :: AvailInfo -> [Name] -availSubordinates avail = - filter (/= availName avail) (availNamesWithSelectors avail) +availSubordinates = map greNameMangledName . availSubordinateGreNames availNoDocs :: AvailInfo -> [(Name, DocForDecl Name)] availNoDocs avail = @@ -864,7 +885,6 @@ | Module.isHoleModule m = mkModule this_uid (moduleName m) | otherwise = m --- | Reify a declaration from the GHC internal 'TyThing' representation. hiDecl :: Monad m => DynFlags -> Name -> IfM m (Maybe (LHsDecl GhcRn)) hiDecl dflags t = do mayTyThing <- lookupName t @@ -875,12 +895,12 @@ Just x -> case tyThingToLHsDecl ShowRuntimeRep x of Left m -> liftErrMsg (tell [bugWarn m]) >> return Nothing Right (m, t') -> liftErrMsg (tell $ map bugWarn m) - >> return (Just $ noLoc t') + >> return (Just $ noLocA t') where warnLine x = O.text "haddock-bug:" O.<+> O.text x O.<> O.comma O.<+> O.quotes (O.ppr t) O.<+> O.text "-- Please report this on Haddock issue tracker!" - bugWarn = O.showSDoc dflags . warnLine + bugWarn = showSDoc dflags . warnLine -- | This function is called for top-level bindings without type signatures. -- It gets the type signature from GHC and that means it's not going to @@ -895,7 +915,7 @@ Nothing -> return (ExportNoDecl name []) Just decl -> return (ExportDecl (fixSpan decl) [] doc [] [] fixities splice) where - fixSpan (L l t) = L (SrcLoc.combineSrcSpans l nLoc) t + fixSpan (L (SrcSpanAnn a l) t) = L (SrcSpanAnn a (SrcLoc.combineSrcSpans l nLoc)) t fixities = case fixity of Just f -> [(name, f)] Nothing -> [] @@ -996,7 +1016,7 @@ doc <- liftErrMsg (processDocStringParas dflags pkgName gre docStr) return [[ExportDoc doc]] (L _ (ValD _ valDecl)) - | name:_ <- collectHsBindBinders valDecl + | name:_ <- collectHsBindBinders CollNoDictBinders valDecl , Just (L _ SigD{}:_) <- filter isSigD <$> M.lookup name declMap -> return [] _ -> @@ -1011,7 +1031,6 @@ isSigD (L _ SigD{}) = True isSigD _ = False - -- | Sometimes the declaration we want to export is not the "main" declaration: -- it might be an individual record selector or a class method. In these -- cases we have to extract the required declaration (and somehow cobble @@ -1062,7 +1081,7 @@ TyClD _ d@DataDecl { tcdLName = L _ dataNm , tcdDataDefn = HsDataDefn { dd_cons = dataCons } } -> do - let ty_args = map HsValArg (lHsQTyVarsToTypes (tyClDeclTyVars d)) + let ty_args = lHsQTyVarsToTypes (tyClDeclTyVars d) lsig <- if isDataConName name then extractPatternSyn name dataNm ty_args dataCons else extractRecSel name dataNm ty_args dataCons @@ -1072,43 +1091,42 @@ | isValName name , Just (famInst:_) <- M.lookup name declMap -> extractDecl declMap name famInst - InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body = - FamEqn { feqn_tycon = L _ famName - , feqn_pats = ty_args - , feqn_rhs = HsDataDefn { dd_cons = dataCons } }}))) -> do - lsig <- if isDataConName name - then extractPatternSyn name famName ty_args dataCons - else extractRecSel name famName ty_args dataCons - pure (SigD noExtField <$> lsig) + InstD _ (DataFamInstD _ (DataFamInstDecl + (FamEqn { feqn_tycon = L _ n + , feqn_pats = tys + , feqn_rhs = defn }))) -> + if isDataConName name + then fmap (SigD noExtField) <$> extractPatternSyn name n tys (dd_cons defn) + else fmap (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 = - FamEqn { feqn_rhs = HsDataDefn { dd_cons = dataCons } - } - })) <- insts - , name `elem` map unLoc (concatMap (getConNames . unLoc) dataCons) + let matches = [ d' | L _ d'@(DataFamInstDecl (FamEqn { feqn_rhs = dd })) <- insts + , name `elem` map unLoc (concatMap (getConNames . unLoc) (dd_cons dd)) ] in case matches of - [d0] -> extractDecl declMap name (noLoc (InstD noExtField (DataFamInstD noExtField d0))) + [d0] -> extractDecl declMap name (noLocA (InstD noExtField (DataFamInstD noExtField d0))) _ -> Left "internal: extractDecl (ClsInstD)" | otherwise -> - let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body = d })) + let matches = [ d' | L _ d'@(DataFamInstDecl d ) <- insts -- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (feqn_rhs d) - , RecCon rec <- map (getConArgs . unLoc) (dd_cons (feqn_rhs d)) + , Just rec <- map (getRecConArgs_maybe . unLoc) (dd_cons (feqn_rhs d)) , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec) , L _ n <- ns , extFieldOcc n == name ] in case matches of - [d0] -> extractDecl declMap name (noLoc . InstD noExtField $ DataFamInstD noExtField d0) + [d0] -> extractDecl declMap name (noLocA . InstD noExtField $ DataFamInstD noExtField d0) _ -> Left "internal: extractDecl (ClsInstD)" _ -> Left ("extractDecl: Unhandled decl for " ++ getOccString name) -extractPatternSyn :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] -> Either ErrMsg (LSig GhcRn) +extractPatternSyn :: HasCallStack + => Name -> Name + -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] + -> Either ErrMsg (LSig GhcRn) extractPatternSyn nm t tvs cons = case filter matches cons of - [] -> Left . O.showSDocUnsafe $ + [] -> Left . O.showSDocOneLine O.defaultSDocContext $ O.text "constructor pattern " O.<+> O.ppr nm O.<+> O.text "not found in type" O.<+> O.ppr t con:_ -> pure (extract <$> con) where @@ -1117,37 +1135,41 @@ extract :: ConDecl GhcRn -> Sig GhcRn extract con = let args = - case getConArgs con of - PrefixCon args' -> (map hsScaledThing args') - RecCon (L _ fields) -> cd_fld_type . unLoc <$> fields - InfixCon arg1 arg2 -> map hsScaledThing [arg1, arg2] + case con of + ConDeclH98 { con_args = con_args' } -> case con_args' of + PrefixCon _ args' -> map hsScaledThing args' + RecCon (L _ fields) -> cd_fld_type . unLoc <$> fields + InfixCon arg1 arg2 -> map hsScaledThing [arg1, arg2] + ConDeclGADT { con_g_args = con_args' } -> case con_args' of + PrefixConGADT args' -> map hsScaledThing args' + RecConGADT (L _ fields) -> cd_fld_type . unLoc <$> fields typ = longArrow args (data_ty con) typ' = case con of - ConDeclH98 { con_mb_cxt = Just cxt } -> noLoc (HsQualTy noExtField cxt typ) + ConDeclH98 { con_mb_cxt = Just cxt } -> noLocA (HsQualTy noExtField (Just cxt) typ) _ -> typ - typ'' = noLoc (HsQualTy noExtField (noLoc []) typ') - in PatSynSig noExtField [noLoc nm] (mkEmptyImplicitBndrs typ'') + typ'' = noLocA (HsQualTy noExtField Nothing typ') + in PatSynSig noAnn [noLocA nm] (mkEmptySigType typ'') longArrow :: [LHsType GhcRn] -> LHsType GhcRn -> LHsType GhcRn - longArrow inputs output = foldr (\x y -> noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) x y)) output inputs + longArrow inputs output = foldr (\x y -> noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) x y)) output inputs data_ty con | ConDeclGADT{} <- con = con_res_ty con - | otherwise = foldl' (\x y -> noLoc (mkAppTyArg x y)) (noLoc (HsTyVar noExtField NotPromoted (noLoc t))) tvs + | otherwise = foldl' (\x y -> noLocA (mkAppTyArg x y)) (noLocA (HsTyVar noAnn NotPromoted (noLocA t))) tvs where mkAppTyArg :: LHsType GhcRn -> LHsTypeArg GhcRn -> HsType GhcRn mkAppTyArg f (HsValArg ty) = HsAppTy noExtField f ty mkAppTyArg f (HsTypeArg l ki) = HsAppKindTy l f ki - mkAppTyArg f (HsArgPar _) = HsParTy noExtField f + mkAppTyArg f (HsArgPar _) = HsParTy noAnn f extractRecSel :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] -> Either ErrMsg (LSig GhcRn) extractRecSel _ _ _ [] = Left "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 -> - pure (L l (TypeSig noExtField [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) data_ty (getBangType ty)))))) + case getRecConArgs_maybe con of + Just (L _ fields) | ((l,L _ (ConDeclField _ _nn ty _)) : _) <- matching_fields fields -> + pure (L (noAnnSrcSpan l) (TypeSig noAnn [noLocA nm] (mkEmptyWildCardBndrs $ mkEmptySigType (noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) data_ty (getBangType ty)))))) _ -> extractRecSel nm t tvs rest where matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)] @@ -1156,11 +1178,11 @@ data_ty -- ResTyGADT _ ty <- con_res con = ty | ConDeclGADT{} <- con = con_res_ty con - | otherwise = foldl' (\x y -> noLoc (mkAppTyArg x y)) (noLoc (HsTyVar noExtField NotPromoted (noLoc t))) tvs + | otherwise = foldl' (\x y -> noLocA (mkAppTyArg x y)) (noLocA (HsTyVar noAnn NotPromoted (noLocA t))) tvs where mkAppTyArg :: LHsType GhcRn -> LHsTypeArg GhcRn -> HsType GhcRn mkAppTyArg f (HsValArg ty) = HsAppTy noExtField f ty mkAppTyArg f (HsTypeArg l ki) = HsAppKindTy l f ki - mkAppTyArg f (HsArgPar _) = HsParTy noExtField f + mkAppTyArg f (HsArgPar _) = HsParTy noAnn f -- | Keep export items with docs. pruneExportItems :: [ExportItem GhcRn] -> [ExportItem GhcRn] diff --git a/src/Haddock/Interface/Json.hs b/src/Haddock/Interface/Json.hs --- a/src/Haddock/Interface/Json.hs +++ b/src/Haddock/Interface/Json.hs @@ -5,7 +5,7 @@ , renderJson ) where -import GHC.Types.Basic +import GHC.Types.Fixity import GHC.Utils.Json import GHC.Unit.Module import GHC.Types.Name diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs --- a/src/Haddock/Interface/LexParseRn.hs +++ b/src/Haddock/Interface/LexParseRn.hs @@ -22,8 +22,8 @@ import Control.Arrow import Control.Monad -import Data.Functor (($>)) -import Data.List (maximumBy, (\\)) +import Data.Functor +import Data.List ((\\), maximumBy) import Data.Ord import Documentation.Haddock.Doc (metaDocConcat) import GHC.Driver.Session (languageExtensions) @@ -33,8 +33,9 @@ import Haddock.Parser import Haddock.Types import GHC.Types.Name +import GHC.Types.Avail ( availName ) import GHC.Parser.PostProcess -import GHC.Utils.Outputable ( showPpr, showSDoc ) +import GHC.Driver.Ppr ( showPpr, showSDoc ) import GHC.Types.Name.Reader import GHC.Data.EnumSet as EnumSet @@ -57,13 +58,13 @@ processDocString dflags gre hds = rename dflags gre $ parseString dflags (unpackHDS hds) -processModuleHeader :: DynFlags -> Maybe Package -> GlobalRdrEnv -> SafeHaskellMode -> Maybe LHsDocString +processModuleHeader :: DynFlags -> Maybe Package -> GlobalRdrEnv -> SafeHaskellMode -> Maybe HsDocString -> ErrMsgM (HaddockModInfo Name, Maybe (MDoc Name)) processModuleHeader dflags pkgName gre safety mayStr = do (hmi, doc) <- case mayStr of Nothing -> return failure - Just (L _ hds) -> do + Just hds -> do let str = unpackHDS hds (hmi, doc) = parseModuleHeader dflags pkgName str !descr <- case hmi_description hmi of @@ -135,7 +136,7 @@ -- There is only one name in the environment that matches so -- use it. - [a] -> pure (DocIdentifier (i $> gre_name a)) + [a] -> pure $ DocIdentifier (i $> greMangledName a) -- There are multiple names available. gres -> ambiguous dflags i gres @@ -200,9 +201,10 @@ -> [GlobalRdrElt] -- ^ More than one @gre@s sharing the same `RdrName` above. -> ErrMsgM (Doc Name) ambiguous dflags x gres = do - let dflt = maximumBy (comparing (gre_lcl &&& isTyConName . gre_name)) gres + let noChildren = map availName (gresToAvailInfo gres) + dflt = maximumBy (comparing (isLocalName &&& isTyConName)) noChildren msg = "Warning: " ++ showNsRdrName dflags x ++ " is ambiguous. It is defined\n" ++ - concatMap (\n -> " * " ++ defnLoc n ++ "\n") gres ++ + concatMap (\n -> " * " ++ defnLoc n ++ "\n") (map greMangledName gres) ++ " You may be able to disambiguate the identifier by qualifying it or\n" ++ " by specifying the type/value namespace explicitly.\n" ++ " Defaulting to the one defined " ++ defnLoc dflt @@ -211,10 +213,12 @@ -- of the same name, but not the only constructor. -- For example, for @data D = C | D@, someone may want to reference the @D@ -- constructor. - when (length (gresToAvailInfo gres) > 1) $ tell [msg] - pure (DocIdentifier (x $> gre_name dflt)) + when (length noChildren > 1) $ tell [msg] + pure (DocIdentifier (x $> dflt)) where - defnLoc = showSDoc dflags . pprNameDefnLoc . gre_name + isLocalName (nameSrcLoc -> RealSrcLoc {}) = True + isLocalName _ = False + defnLoc = showSDoc dflags . pprNameDefnLoc -- | Handle value-namespaced names that cannot be for values. -- diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -34,6 +34,7 @@ import qualified Data.Set as Set import Prelude hiding (mapM) import GHC.HsToCore.Docs +import GHC.Types.Basic ( TopLevelFlag(..) ) -- | Traverse docstrings and ASTs in the Haddock interface, renaming 'Name' to -- 'DocName'. @@ -173,10 +174,9 @@ rename = lookupRn -renameL :: Located Name -> RnM (Located DocName) +renameL :: GenLocated l Name -> RnM (GenLocated l DocName) renameL = mapM rename - renameExportItems :: [ExportItem GhcRn] -> RnM [ExportItem DocNameI] renameExportItems = mapM renameExportItem @@ -213,10 +213,10 @@ renameLTypeArg (HsArgPar sp) = return $ HsArgPar sp renameLSigType :: LHsSigType GhcRn -> RnM (LHsSigType DocNameI) -renameLSigType = renameImplicit renameLType +renameLSigType = mapM renameSigType renameLSigWcType :: LHsSigWcType GhcRn -> RnM (LHsSigWcType DocNameI) -renameLSigWcType = renameWc (renameImplicit renameLType) +renameLSigWcType = renameWc renameLSigType renameLKind :: LHsKind GhcRn -> RnM (LHsKind DocNameI) renameLKind = renameLType @@ -235,10 +235,10 @@ ; return (L loc (TyVarSig noExtField bndr')) } renameInjectivityAnn :: LInjectivityAnn GhcRn -> RnM (LInjectivityAnn DocNameI) -renameInjectivityAnn (L loc (InjectivityAnn lhs rhs)) +renameInjectivityAnn (L loc (InjectivityAnn _ lhs rhs)) = do { lhs' <- renameL lhs ; rhs' <- mapM renameL rhs - ; return (L loc (InjectivityAnn lhs' rhs')) } + ; return (L loc (InjectivityAnn noExtField lhs' rhs')) } renameMaybeInjectivityAnn :: Maybe (LInjectivityAnn GhcRn) -> RnM (Maybe (LInjectivityAnn DocNameI)) @@ -246,76 +246,82 @@ renameArrow :: HsArrow GhcRn -> RnM (HsArrow DocNameI) renameArrow (HsUnrestrictedArrow u) = return (HsUnrestrictedArrow u) -renameArrow (HsLinearArrow u) = return (HsLinearArrow u) -renameArrow (HsExplicitMult u p) = HsExplicitMult u <$> renameLType p +renameArrow (HsLinearArrow u a) = return (HsLinearArrow u a) +renameArrow (HsExplicitMult u a p) = HsExplicitMult u a <$> renameLType p renameType :: HsType GhcRn -> RnM (HsType DocNameI) renameType t = case t of HsForAllTy { hst_tele = tele, hst_body = ltype } -> do tele' <- renameHsForAllTelescope tele ltype' <- renameLType ltype - return (HsForAllTy { hst_xforall = noExtField + return (HsForAllTy { hst_xforall = noAnn , hst_tele = tele', hst_body = ltype' }) HsQualTy { hst_ctxt = lcontext , hst_body = ltype } -> do - lcontext' <- renameLContext lcontext + lcontext' <- traverse renameLContext lcontext ltype' <- renameLType ltype - return (HsQualTy { hst_xqual = noExtField, hst_ctxt = lcontext', hst_body = ltype' }) + return (HsQualTy { hst_xqual = noAnn, hst_ctxt = lcontext', hst_body = ltype' }) - HsTyVar _ ip (L l n) -> return . HsTyVar noExtField ip . L l =<< rename n - HsBangTy _ b ltype -> return . HsBangTy noExtField b =<< renameLType ltype + HsTyVar _ ip (L l n) -> return . HsTyVar noAnn ip . L l =<< rename n + HsBangTy _ b ltype -> return . HsBangTy noAnn b =<< renameLType ltype - HsStarTy _ isUni -> return (HsStarTy noExtField isUni) + HsStarTy _ isUni -> return (HsStarTy noAnn isUni) HsAppTy _ a b -> do a' <- renameLType a b' <- renameLType b - return (HsAppTy noExtField a' b') + return (HsAppTy noAnn a' b') HsAppKindTy _ a b -> do a' <- renameLType a b' <- renameLKind b - return (HsAppKindTy noExtField a' b') + return (HsAppKindTy noAnn a' b') HsFunTy _ w a b -> do a' <- renameLType a b' <- renameLType b w' <- renameArrow w - return (HsFunTy noExtField w' a' b') + return (HsFunTy noAnn w' a' b') - HsListTy _ ty -> return . (HsListTy noExtField) =<< renameLType ty - HsIParamTy _ n ty -> liftM (HsIParamTy noExtField n) (renameLType ty) + HsListTy _ ty -> return . (HsListTy noAnn) =<< renameLType ty + HsIParamTy _ n ty -> liftM (HsIParamTy noAnn n) (renameLType ty) - HsTupleTy _ b ts -> return . HsTupleTy noExtField b =<< mapM renameLType ts - HsSumTy _ ts -> HsSumTy noExtField <$> mapM renameLType ts + HsTupleTy _ b ts -> return . HsTupleTy noAnn b =<< mapM renameLType ts + HsSumTy _ ts -> HsSumTy noAnn <$> mapM renameLType ts HsOpTy _ a (L loc op) b -> do op' <- rename op a' <- renameLType a b' <- renameLType b - return (HsOpTy noExtField a' (L loc op') b') + return (HsOpTy noAnn a' (L loc op') b') - HsParTy _ ty -> return . (HsParTy noExtField) =<< renameLType ty + HsParTy _ ty -> return . (HsParTy noAnn) =<< renameLType ty HsKindSig _ ty k -> do ty' <- renameLType ty k' <- renameLKind k - return (HsKindSig noExtField ty' k') + return (HsKindSig noAnn ty' k') HsDocTy _ ty doc -> do ty' <- renameLType ty doc' <- renameLDocHsSyn doc - return (HsDocTy noExtField ty' doc') + return (HsDocTy noAnn ty' doc') - HsTyLit _ x -> return (HsTyLit noExtField x) + HsTyLit _ x -> return (HsTyLit noAnn x) - 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 + HsRecTy _ a -> HsRecTy noAnn <$> mapM renameConDeclFieldField a + XHsType a -> pure (XHsType a) + HsExplicitListTy _ a b -> HsExplicitListTy noAnn a <$> mapM renameLType b + HsExplicitTupleTy _ b -> HsExplicitTupleTy noAnn <$> mapM renameLType b HsSpliceTy _ s -> renameHsSpliceTy s - HsWildCardTy a -> pure (HsWildCardTy a) + HsWildCardTy _ -> pure (HsWildCardTy noAnn) +renameSigType :: HsSigType GhcRn -> RnM (HsSigType DocNameI) +renameSigType (HsSig { sig_bndrs = bndrs, sig_body = body }) = do + bndrs' <- renameOuterTyVarBndrs bndrs + body' <- renameLType body + pure $ HsSig { sig_ext = noExtField, sig_bndrs = bndrs', sig_body = body' } + -- | Rename splices, but _only_ those that turn out to be for types. -- I think this is actually safe for our possible inputs: -- @@ -335,21 +341,21 @@ renameHsForAllTelescope :: HsForAllTelescope GhcRn -> RnM (HsForAllTelescope DocNameI) renameHsForAllTelescope tele = case tele of - HsForAllVis x bndrs -> do bndrs' <- mapM renameLTyVarBndr bndrs - pure $ HsForAllVis x bndrs' - HsForAllInvis x bndrs -> do bndrs' <- mapM renameLTyVarBndr bndrs - pure $ HsForAllInvis x bndrs' + HsForAllVis _ bndrs -> do bndrs' <- mapM renameLTyVarBndr bndrs + pure $ HsForAllVis noExtField bndrs' + HsForAllInvis _ bndrs -> do bndrs' <- mapM renameLTyVarBndr bndrs + pure $ HsForAllInvis noExtField bndrs' renameLTyVarBndr :: LHsTyVarBndr flag GhcRn -> RnM (LHsTyVarBndr flag DocNameI) -renameLTyVarBndr (L loc (UserTyVar x fl (L l n))) +renameLTyVarBndr (L loc (UserTyVar _ fl (L l n))) = do { n' <- rename n - ; return (L loc (UserTyVar x fl (L l n'))) } -renameLTyVarBndr (L loc (KindedTyVar x fl (L lv n) kind)) + ; return (L loc (UserTyVar noExtField fl (L l n'))) } +renameLTyVarBndr (L loc (KindedTyVar _ fl (L lv n) kind)) = do { n' <- rename n ; kind' <- renameLKind kind - ; return (L loc (KindedTyVar x fl (L lv n') kind')) } + ; return (L loc (KindedTyVar noExtField fl (L lv n') kind')) } -renameLContext :: Located [LHsType GhcRn] -> RnM (Located [LHsType DocNameI]) +renameLContext :: LocatedC [LHsType GhcRn] -> RnM (LocatedC [LHsType DocNameI]) renameLContext (L loc context) = do context' <- mapM renameLType context return (L loc context') @@ -400,8 +406,8 @@ return (DerivD noExtField d') _ -> error "renameDecl" -renameLThing :: (a GhcRn -> RnM (a DocNameI)) -> Located (a GhcRn) -> RnM (Located (a DocNameI)) -renameLThing fn (L loc x) = return . L loc =<< fn x +renameLThing :: (a GhcRn -> RnM (a DocNameI)) -> LocatedAn an (a GhcRn) -> RnM (Located (a DocNameI)) +renameLThing fn (L loc x) = return . L (locA loc) =<< fn x renameTyClD :: TyClDecl GhcRn -> RnM (TyClDecl DocNameI) renameTyClD d = case d of @@ -426,7 +432,7 @@ ClassDecl { tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars, tcdFixity = fixity , tcdFDs = lfundeps, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs } -> do - lcontext' <- renameLContext lcontext + lcontext' <- traverse renameLContext lcontext lname' <- renameL lname ltyvars' <- renameLHsQTyVars ltyvars lfundeps' <- mapM renameLFunDep lfundeps @@ -440,12 +446,13 @@ , tcdATs = ats', tcdATDefs = at_defs', tcdDocs = [], tcdCExt = noExtField }) where - renameLFunDep (L loc (xs, ys)) = do + renameLFunDep :: LHsFunDep GhcRn -> RnM (LHsFunDep DocNameI) + renameLFunDep (L loc (FunDep _ xs ys)) = do xs' <- mapM rename (map unLoc xs) ys' <- mapM rename (map unLoc ys) - return (L loc (map noLoc xs', map noLoc ys')) + return (L (locA loc) (FunDep noExtField (map noLocA xs') (map noLocA ys'))) - renameLSig (L loc sig) = return . L loc =<< renameSig sig + renameLSig (L loc sig) = return . L (locA loc) =<< renameSig sig renameFamilyDecl :: FamilyDecl GhcRn -> RnM (FamilyDecl DocNameI) renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname @@ -458,7 +465,8 @@ ltyvars' <- renameLHsQTyVars ltyvars result' <- renameFamilyResultSig result injectivity' <- renameMaybeInjectivityAnn injectivity - return (FamilyDecl { fdExt = noExtField, fdInfo = info', fdLName = lname' + return (FamilyDecl { fdExt = noExtField, fdInfo = info', fdTopLevel = TopLevel + , fdLName = lname' , fdTyVars = ltyvars' , fdFixity = fixity , fdResultSig = result' @@ -484,64 +492,73 @@ renameDataDefn :: HsDataDefn GhcRn -> RnM (HsDataDefn DocNameI) renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType , dd_kindSig = k, dd_cons = cons }) = do - lcontext' <- renameLContext lcontext + lcontext' <- traverse renameLContext lcontext k' <- renameMaybeLKind k - cons' <- mapM (mapM renameCon) cons + cons' <- mapM (mapMA renameCon) cons -- I don't think we need the derivings, so we return Nothing return (HsDataDefn { dd_ext = noExtField , dd_ND = nd, dd_ctxt = lcontext', dd_cType = cType , dd_kindSig = k', dd_cons = cons' - , dd_derivs = noLoc [] }) + , dd_derivs = [] }) renameCon :: ConDecl GhcRn -> RnM (ConDecl DocNameI) renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars , con_mb_cxt = lcontext, con_args = details - , con_doc = mbldoc }) = do + , con_doc = mbldoc + , con_forall = forall }) = do lname' <- renameL lname ltyvars' <- mapM renameLTyVarBndr ltyvars lcontext' <- traverse renameLContext lcontext - details' <- renameDetails details + details' <- renameH98Details details mbldoc' <- mapM renameLDocHsSyn mbldoc return (decl { con_ext = noExtField, con_name = lname', con_ex_tvs = ltyvars' , con_mb_cxt = lcontext' + , con_forall = forall -- Remove when #18311 is fixed , con_args = details', con_doc = mbldoc' }) -renameCon decl@(ConDeclGADT { con_names = lnames, con_qvars = ltyvars - , con_mb_cxt = lcontext, con_args = details +renameCon ConDeclGADT { con_names = lnames, con_bndrs = bndrs + , con_mb_cxt = lcontext, con_g_args = details , con_res_ty = res_ty - , con_doc = mbldoc }) = do + , con_doc = mbldoc } = do lnames' <- mapM renameL lnames - ltyvars' <- mapM renameLTyVarBndr ltyvars + bndrs' <- mapM renameOuterTyVarBndrs bndrs lcontext' <- traverse renameLContext lcontext - details' <- renameDetails details + details' <- renameGADTDetails details res_ty' <- renameLType res_ty mbldoc' <- mapM renameLDocHsSyn mbldoc - return (decl { con_g_ext = noExtField, con_names = lnames', con_qvars = ltyvars' - , con_mb_cxt = lcontext', con_args = details' + return (ConDeclGADT + { con_g_ext = noExtField, con_names = lnames', con_bndrs = bndrs' + , con_mb_cxt = lcontext', con_g_args = details' , con_res_ty = res_ty', con_doc = mbldoc' }) renameHsScaled :: HsScaled GhcRn (LHsType GhcRn) -> RnM (HsScaled DocNameI (LHsType DocNameI)) renameHsScaled (HsScaled w ty) = HsScaled <$> renameArrow w <*> renameLType ty -renameDetails :: HsConDeclDetails GhcRn -> RnM (HsConDeclDetails DocNameI) -renameDetails (RecCon (L l fields)) = do +renameH98Details :: HsConDeclH98Details GhcRn + -> RnM (HsConDeclH98Details DocNameI) +renameH98Details (RecCon (L l fields)) = do fields' <- mapM renameConDeclFieldField fields - return (RecCon (L l fields')) - -- This causes an assertion failure ---renameDetails (PrefixCon ps) = -- return . PrefixCon =<< mapM (_renameLType) ps -renameDetails (PrefixCon ps) = PrefixCon <$> mapM renameHsScaled ps -renameDetails (InfixCon a b) = do + return (RecCon (L (locA l) fields')) +renameH98Details (PrefixCon ts ps) = PrefixCon ts <$> mapM renameHsScaled ps +renameH98Details (InfixCon a b) = do a' <- renameHsScaled a b' <- renameHsScaled b return (InfixCon a' b') +renameGADTDetails :: HsConDeclGADTDetails GhcRn + -> RnM (HsConDeclGADTDetails DocNameI) +renameGADTDetails (RecConGADT (L l fields)) = do + fields' <- mapM renameConDeclFieldField fields + return (RecConGADT (L (locA l) fields')) +renameGADTDetails (PrefixConGADT ps) = PrefixConGADT <$> mapM renameHsScaled ps + renameConDeclFieldField :: LConDeclField GhcRn -> RnM (LConDeclField DocNameI) renameConDeclFieldField (L l (ConDeclField _ names t doc)) = do names' <- mapM renameLFieldOcc names t' <- renameLType t doc' <- mapM renameLDocHsSyn doc - return $ L l (ConDeclField noExtField names' t' doc') + return $ L (locA l) (ConDeclField noExtField names' t' doc') renameLFieldOcc :: LFieldOcc GhcRn -> RnM (LFieldOcc DocNameI) renameLFieldOcc (L l (FieldOcc sel lbl)) = do @@ -606,10 +623,10 @@ , deriv_overlap_mode = omode }) renameDerivStrategy :: DerivStrategy GhcRn -> RnM (DerivStrategy DocNameI) -renameDerivStrategy StockStrategy = pure StockStrategy -renameDerivStrategy AnyclassStrategy = pure AnyclassStrategy -renameDerivStrategy NewtypeStrategy = pure NewtypeStrategy -renameDerivStrategy (ViaStrategy ty) = ViaStrategy <$> renameLSigType ty +renameDerivStrategy (StockStrategy a) = pure (StockStrategy a) +renameDerivStrategy (AnyclassStrategy a) = pure (AnyclassStrategy a) +renameDerivStrategy (NewtypeStrategy a) = pure (NewtypeStrategy a) +renameDerivStrategy (ViaStrategy ty) = ViaStrategy <$> renameLSigType ty renameClsInstD :: ClsInstDecl GhcRn -> RnM (ClsInstDecl DocNameI) renameClsInstD (ClsInstDecl { cid_overlap_mode = omode @@ -627,35 +644,29 @@ renameTyFamInstD :: TyFamInstDecl GhcRn -> RnM (TyFamInstDecl DocNameI) renameTyFamInstD (TyFamInstDecl { tfid_eqn = eqn }) = do { eqn' <- renameTyFamInstEqn eqn - ; return (TyFamInstDecl { tfid_eqn = eqn' }) } + ; return (TyFamInstDecl { tfid_xtn = noExtField, tfid_eqn = eqn' }) } renameTyFamInstEqn :: TyFamInstEqn GhcRn -> RnM (TyFamInstEqn DocNameI) -renameTyFamInstEqn eqn - = renameImplicit rename_ty_fam_eqn eqn - where - rename_ty_fam_eqn - :: 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 }) - = do { tc' <- renameL tc - ; bndrs' <- traverse (mapM renameLTyVarBndr) bndrs - ; pats' <- mapM renameLTypeArg pats - ; rhs' <- renameLType rhs - ; return (FamEqn { feqn_ext = noExtField - , feqn_tycon = tc' - , feqn_bndrs = bndrs' - , feqn_pats = pats' - , feqn_fixity = fixity - , feqn_rhs = rhs' }) } +renameTyFamInstEqn (FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs + , feqn_pats = pats, feqn_fixity = fixity + , feqn_rhs = rhs }) + = do { tc' <- renameL tc + ; bndrs' <- renameOuterTyVarBndrs bndrs + ; pats' <- mapM renameLTypeArg pats + ; rhs' <- renameLType rhs + ; return (FamEqn { feqn_ext = noExtField + , feqn_tycon = tc' + , feqn_bndrs = bndrs' + , feqn_pats = pats' + , feqn_fixity = fixity + , feqn_rhs = rhs' }) } renameTyFamDefltD :: TyFamDefltDecl GhcRn -> RnM (TyFamDefltDecl DocNameI) renameTyFamDefltD = renameTyFamInstD renameDataFamInstD :: DataFamInstDecl GhcRn -> RnM (DataFamInstDecl DocNameI) renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn }) - = do { eqn' <- renameImplicit rename_data_fam_eqn eqn + = do { eqn' <- rename_data_fam_eqn eqn ; return (DataFamInstDecl { dfid_eqn = eqn' }) } where rename_data_fam_eqn @@ -665,7 +676,7 @@ , feqn_pats = pats, feqn_fixity = fixity , feqn_rhs = defn }) = do { tc' <- renameL tc - ; bndrs' <- traverse (mapM renameLTyVarBndr) bndrs + ; bndrs' <- renameOuterTyVarBndrs bndrs ; pats' <- mapM renameLTypeArg pats ; defn' <- renameDataDefn defn ; return (FamEqn { feqn_ext = noExtField @@ -675,13 +686,12 @@ , feqn_fixity = fixity , feqn_rhs = defn' }) } -renameImplicit :: (in_thing -> RnM out_thing) - -> HsImplicitBndrs GhcRn in_thing - -> RnM (HsImplicitBndrs DocNameI out_thing) -renameImplicit rn_thing (HsIB { hsib_body = thing }) - = do { thing' <- rn_thing thing - ; return (HsIB { hsib_body = thing' - , hsib_ext = noExtField }) } +renameOuterTyVarBndrs :: HsOuterTyVarBndrs flag GhcRn + -> RnM (HsOuterTyVarBndrs flag DocNameI) +renameOuterTyVarBndrs (HsOuterImplicit{}) = + pure $ HsOuterImplicit{hso_ximplicit = noExtField} +renameOuterTyVarBndrs (HsOuterExplicit{hso_bndrs = exp_bndrs}) = + HsOuterExplicit noExtField <$> mapM renameLTyVarBndr exp_bndrs renameWc :: (in_thing -> RnM out_thing) -> HsWildCardBndrs GhcRn in_thing diff --git a/src/Haddock/Interface/Specialize.hs b/src/Haddock/Interface/Specialize.hs --- a/src/Haddock/Interface/Specialize.hs +++ b/src/Haddock/Interface/Specialize.hs @@ -3,6 +3,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE GADTs #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} module Haddock.Interface.Specialize @@ -18,7 +19,6 @@ import GHC.Types.Name import GHC.Data.FastString import GHC.Builtin.Types ( listTyConName, unrestrictedFunTyConName ) -import GHC.Parser.Annotation (IsUnicodeSyntax(..)) import Control.Monad import Control.Monad.Trans.State @@ -38,7 +38,7 @@ go :: forall x. Data x => Map Name (HsType GhcRn) -> x -> x go spec_map = everywhereButType @Name $ mkT $ sugar . strip_kind_sig . specialize_ty_var spec_map - strip_kind_sig :: HsType name -> HsType name + strip_kind_sig :: HsType GhcRn -> HsType GhcRn strip_kind_sig (HsKindSig _ (L _ t) _) = t strip_kind_sig typ = typ @@ -57,7 +57,7 @@ -- -- Again, it is just a convenience function around 'specialize'. Note that -- length of type list should be the same as the number of binders. -specializeTyVarBndrs :: LHsQTyVars GhcRn -> [HsType GhcRn] -> HsType GhcRn -> HsType GhcRn +specializeTyVarBndrs :: Data a => LHsQTyVars GhcRn -> [HsType GhcRn] -> a -> a specializeTyVarBndrs bndrs typs = specialize $ zip bndrs' typs where bndrs' = map (hsTyVarBndrName . unLoc) . hsq_explicit $ bndrs @@ -74,13 +74,13 @@ -> Sig GhcRn -> Sig GhcRn specializeSig bndrs typs (TypeSig _ lnames typ) = - TypeSig noExtField lnames (typ {hswc_body = (hswc_body typ) {hsib_body = noLoc typ'}}) + TypeSig noAnn lnames (typ {hswc_body = noLocA typ'}) where - true_type :: HsType GhcRn - true_type = unLoc (hsSigWcType typ) - typ' :: HsType GhcRn + true_type :: HsSigType GhcRn + true_type = unLoc (dropWildCards typ) + typ' :: HsSigType GhcRn typ' = rename fv $ specializeTyVarBndrs bndrs typs true_type - fv = foldr Set.union Set.empty . map freeVariables $ typs + fv = foldr Set.union Set.empty . map freeVariablesType $ typs specializeSig _ _ sig = sig @@ -110,7 +110,7 @@ sugarLists :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p) sugarLists (HsAppTy _ (L _ (HsTyVar _ _ (L _ name))) ltyp) - | getName name == listTyConName = HsListTy noExtField ltyp + | getName name == listTyConName = HsListTy noAnn ltyp sugarLists typ = typ @@ -121,7 +121,7 @@ aux apps (HsAppTy _ (L _ ftyp) atyp) = aux (atyp:apps) ftyp aux apps (HsParTy _ (L _ typ')) = aux apps typ' aux apps (HsTyVar _ _ (L _ name)) - | isBuiltInSyntax name' && suitable = HsTupleTy noExtField HsBoxedTuple apps + | isBuiltInSyntax name' && suitable = HsTupleTy noAnn HsBoxedOrConstraintTuple apps where name' = getName name strName = getOccString name @@ -131,10 +131,10 @@ aux _ _ = typ -sugarOperators :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p) +sugarOperators :: HsType GhcRn -> HsType GhcRn sugarOperators (HsAppTy _ (L _ (HsAppTy _ (L _ (HsTyVar _ _ (L l name))) la)) lb) | isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb - | unrestrictedFunTyConName == name' = HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) la lb + | unrestrictedFunTyConName == name' = HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) la lb where name' = getName name sugarOperators typ = typ @@ -176,19 +176,25 @@ -- not converted to 'String' or alike to avoid new allocations. Additionally, -- since it is stored mostly in 'Set', fast comparison of 'FastString' is also -- quite nice. -type NameRep = FastString +newtype NameRep + = NameRep FastString + deriving (Eq) +instance Ord NameRep where + compare (NameRep fs1) (NameRep fs2) = uniqCompareFS fs1 fs2 + + getNameRep :: NamedThing name => name -> NameRep -getNameRep = getOccFS +getNameRep = NameRep . getOccFS nameRepString :: NameRep -> String -nameRepString = unpackFS +nameRepString (NameRep fs) = unpackFS fs stringNameRep :: String -> NameRep -stringNameRep = mkFastString +stringNameRep = NameRep . mkFastString setInternalNameRep :: SetName name => NameRep -> name -> name -setInternalNameRep = setInternalOccName . mkVarOccFS +setInternalNameRep (NameRep fs) = setInternalOccName (mkVarOccFS fs) setInternalOccName :: SetName name => OccName -> name -> name setInternalOccName occ name = @@ -198,25 +204,39 @@ nname' = mkInternalName (nameUnique nname) occ (nameSrcSpan nname) --- | Compute set of free variables of given type. -freeVariables :: HsType GhcRn -> Set Name -freeVariables = - everythingWithState Set.empty Set.union query - where - query term ctx = case cast term :: Maybe (HsType GhcRn) of - Just (HsForAllTy _ tele _) -> - (Set.empty, Set.union ctx (teleNames tele)) - Just (HsTyVar _ _ (L _ name)) - | getName name `Set.member` ctx -> (Set.empty, ctx) - | otherwise -> (Set.singleton $ getName name, ctx) - _ -> (Set.empty, ctx) +-- | Compute set of free variables of a given 'HsType'. +freeVariablesType :: HsType GhcRn -> Set Name +freeVariablesType = + everythingWithState Set.empty Set.union + (mkQ (\ctx -> (Set.empty, ctx)) queryType) +-- | Compute set of free variables of a given 'HsType'. +freeVariablesSigType :: HsSigType GhcRn -> Set Name +freeVariablesSigType = + everythingWithState Set.empty Set.union + (mkQ (\ctx -> (Set.empty, ctx)) queryType `extQ` querySigType) + +queryType :: HsType GhcRn -> Set Name -> (Set Name, Set Name) +queryType term ctx = case term of + HsForAllTy _ tele _ -> + (Set.empty, Set.union ctx (teleNames tele)) + HsTyVar _ _ (L _ name) + | getName name `Set.member` ctx -> (Set.empty, ctx) + | otherwise -> (Set.singleton $ getName name, ctx) + _ -> (Set.empty, ctx) + where + teleNames :: HsForAllTelescope GhcRn -> Set Name teleNames (HsForAllVis _ bndrs) = bndrsNames bndrs teleNames (HsForAllInvis _ bndrs) = bndrsNames bndrs - bndrsNames = Set.fromList . map (getName . hsTyVarBndrName . unLoc) +querySigType :: HsSigType GhcRn -> Set Name -> (Set Name, Set Name) +querySigType (HsSig { sig_bndrs = outer_bndrs }) ctx = + (Set.empty, Set.union ctx (bndrsNames (hsOuterExplicitBndrs outer_bndrs))) +bndrsNames :: [LHsTyVarBndr flag GhcRn] -> Set Name +bndrsNames = Set.fromList . map (getName . tyVarName . unLoc) + -- | Make given type visually unambiguous. -- -- After applying 'specialize' method, some free type variables may become @@ -225,12 +245,12 @@ -- different type variable than latter one. Applying 'rename' function -- will fix that type to be visually unambiguous again (making it something -- like @(a -> b0) -> b@). -rename :: Set Name -> HsType GhcRn -> HsType GhcRn -rename fv typ = evalState (renameType typ) env +rename :: Set Name -> HsSigType GhcRn -> HsSigType GhcRn +rename fv typ = evalState (renameSigType typ) env where env = RenameEnv { rneHeadFVs = Map.fromList . map mkPair . Set.toList $ fv - , rneSigFVs = Set.map getNameRep $ freeVariables typ + , rneSigFVs = Set.map getNameRep $ freeVariablesSigType typ , rneCtx = Map.empty } mkPair name = (getNameRep name, name) @@ -245,6 +265,17 @@ } +renameSigType :: HsSigType GhcRn -> Rename (IdP GhcRn) (HsSigType GhcRn) +renameSigType (HsSig x bndrs body) = + HsSig x <$> renameOuterTyVarBndrs bndrs <*> renameLType body + +renameOuterTyVarBndrs :: HsOuterTyVarBndrs flag GhcRn + -> Rename (IdP GhcRn) (HsOuterTyVarBndrs flag GhcRn) +renameOuterTyVarBndrs (HsOuterImplicit imp_tvs) = + HsOuterImplicit <$> mapM renameName imp_tvs +renameOuterTyVarBndrs (HsOuterExplicit x exp_bndrs) = + HsOuterExplicit x <$> mapM renameLBinder exp_bndrs + renameType :: HsType GhcRn -> Rename (IdP GhcRn) (HsType GhcRn) renameType (HsForAllTy x tele lt) = HsForAllTy x @@ -252,9 +283,9 @@ <*> renameLType lt renameType (HsQualTy x lctxt lt) = HsQualTy x - <$> located renameContext lctxt + <$> renameMContext lctxt <*> renameLType lt -renameType (HsTyVar x ip name) = HsTyVar x ip <$> located renameName name +renameType (HsTyVar x ip name) = HsTyVar x ip <$> locatedN renameName name renameType t@(HsStarTy _ _) = pure t renameType (HsAppTy x lf la) = HsAppTy x <$> renameLType lf <*> renameLType la renameType (HsAppKindTy x lt lk) = HsAppKindTy x <$> renameLType lt <*> renameLKind lk @@ -263,7 +294,7 @@ renameType (HsTupleTy x srt lt) = HsTupleTy x srt <$> mapM renameLType lt renameType (HsSumTy x lt) = HsSumTy x <$> mapM renameLType lt renameType (HsOpTy x la lop lb) = - HsOpTy x <$> renameLType la <*> located renameName lop <*> renameLType lb + HsOpTy x <$> renameLType la <*> locatedN renameName lop <*> renameLType lb renameType (HsParTy x lt) = HsParTy x <$> renameLType lt renameType (HsIParamTy x ip lt) = HsIParamTy x ip <$> renameLType lt renameType (HsKindSig x lt lk) = HsKindSig x <$> renameLType lt <*> pure lk @@ -271,7 +302,7 @@ renameType (HsDocTy x lt doc) = HsDocTy x <$> renameLType lt <*> pure doc renameType (HsBangTy x bang lt) = HsBangTy x bang <$> renameLType lt renameType t@(HsRecTy _ _) = pure t -renameType t@(XHsType (NHsCoreTy _)) = pure t +renameType t@(XHsType _) = pure t renameType (HsExplicitListTy x ip ltys) = HsExplicitListTy x ip <$> renameLTypes ltys renameType (HsExplicitTupleTy x ltys) = @@ -280,7 +311,7 @@ renameType (HsWildCardTy wc) = pure (HsWildCardTy wc) renameHsArrow :: HsArrow GhcRn -> Rename (IdP GhcRn) (HsArrow GhcRn) -renameHsArrow (HsExplicitMult u p) = HsExplicitMult u <$> renameLType p +renameHsArrow (HsExplicitMult u a p) = HsExplicitMult u a <$> renameLType p renameHsArrow mult = pure mult @@ -293,6 +324,11 @@ renameLTypes :: [LHsType GhcRn] -> Rename (IdP GhcRn) [LHsType GhcRn] renameLTypes = mapM renameLType +renameMContext :: Maybe (LHsContext GhcRn) -> Rename (IdP GhcRn) (Maybe (LHsContext GhcRn)) +renameMContext Nothing = return Nothing +renameMContext (Just (L l ctxt)) = do + ctxt' <- renameContext ctxt + return (Just (L l ctxt')) renameContext :: HsContext GhcRn -> Rename (IdP GhcRn) (HsContext GhcRn) renameContext = renameLTypes @@ -305,9 +341,9 @@ HsForAllInvis x <$> mapM renameLBinder bndrs renameBinder :: HsTyVarBndr flag GhcRn -> Rename (IdP GhcRn) (HsTyVarBndr flag GhcRn) -renameBinder (UserTyVar x fl lname) = UserTyVar x fl <$> located renameName lname +renameBinder (UserTyVar x fl lname) = UserTyVar x fl <$> locatedN renameName lname renameBinder (KindedTyVar x fl lname lkind) = - KindedTyVar x fl <$> located renameName lname <*> located renameType lkind + KindedTyVar x fl <$> locatedN renameName lname <*> located renameType lkind renameLBinder :: LHsTyVarBndr flag GhcRn -> Rename (IdP GhcRn) (LHsTyVarBndr flag GhcRn) renameLBinder = located renameBinder @@ -360,5 +396,13 @@ str = nameRepString name -located :: Functor f => (a -> f b) -> Located a -> f (Located b) +located :: Functor f => (a -> f b) -> GenLocated l a -> f (GenLocated l b) located f (L loc e) = L loc <$> f e + +locatedN :: Functor f => (a -> f b) -> LocatedN a -> f (LocatedN b) +locatedN f (L loc e) = L loc <$> f e + + +tyVarName :: HsTyVarBndr flag GhcRn -> IdP GhcRn +tyVarName (UserTyVar _ _ name) = unLoc name +tyVarName (KindedTyVar _ _ (L _ name) _) = name diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs --- a/src/Haddock/InterfaceFile.hs +++ b/src/Haddock/InterfaceFile.hs @@ -38,7 +38,7 @@ import GHC.Data.FastString import GHC hiding (NoLink) import GHC.Driver.Monad (withSession) -import GHC.Driver.Types +import GHC.Driver.Env import GHC.Types.Name.Cache import GHC.Iface.Env import GHC.Types.Name @@ -94,7 +94,7 @@ -- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion] -- binaryInterfaceVersion :: Word16 -#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,1,0) +#if MIN_VERSION_ghc(9,2,0) && !MIN_VERSION_ghc(9,3,0) binaryInterfaceVersion = 38 binaryInterfaceVersionCompatibility :: [Word16] @@ -123,14 +123,12 @@ put_ bh0 symtab_p_p -- Make some intial state - symtab_next <- newFastMutInt - writeFastMutInt symtab_next 0 + symtab_next <- newFastMutInt 0 symtab_map <- newIORef emptyUFM let bin_symtab = BinSymbolTable { bin_symtab_next = symtab_next, bin_symtab_map = symtab_map } - dict_next_ref <- newFastMutInt - writeFastMutInt dict_next_ref 0 + dict_next_ref <- newFastMutInt 0 dict_map_ref <- newIORef emptyUFM let bin_dict = BinDictionary { bin_dict_next = dict_next_ref, diff --git a/src/Haddock/Options.hs b/src/Haddock/Options.hs --- a/src/Haddock/Options.hs +++ b/src/Haddock/Options.hs @@ -24,7 +24,6 @@ optSourceCssFile, sourceUrls, wikiUrls, - baseUrl, optParCount, optDumpInterfaceFile, optShowInterfaceFile, @@ -47,9 +46,8 @@ import Data.Version import Control.Applicative import GHC.Data.FastString -import GHC ( DynFlags, Module, moduleUnit, unitState ) -import GHC.Unit.Info ( PackageName(..), unitPackageName, unitPackageVersion ) -import GHC.Unit.State ( lookupUnit ) +import GHC ( Module, moduleUnit ) +import GHC.Unit.State import Haddock.Types import Haddock.Utils import System.Console.GetOpt @@ -74,7 +72,6 @@ | Flag_SourceEntityURL String | Flag_SourceLEntityURL String | Flag_WikiBaseURL String - | Flag_BaseURL String | Flag_WikiModuleURL String | Flag_WikiEntityURL String | Flag_LaTeX @@ -160,8 +157,6 @@ "URL for a source code link for each entity.\nUsed if name links are unavailable, eg. for TH splices.", Option [] ["comments-base"] (ReqArg Flag_WikiBaseURL "URL") "URL for a comments link on the contents\nand index pages", - Option [] ["base-url"] (ReqArg Flag_BaseURL "URL") - "Base URL for static assets (eg. css, javascript, json files etc.).\nWhen given statis assets will not be copied.", Option [] ["comments-module"] (ReqArg Flag_WikiModuleURL "URL") "URL for a comments link for each module\n(using the %{MODULE} var)", Option [] ["comments-entity"] (ReqArg Flag_WikiEntityURL "URL") @@ -306,9 +301,6 @@ ,optLast [str | Flag_WikiEntityURL str <- flags]) -baseUrl :: [Flag] -> Maybe String -baseUrl flags = optLast [str | Flag_BaseURL str <- flags] - optDumpInterfaceFile :: [Flag] -> Maybe FilePath optDumpInterfaceFile flags = optLast [ str | Flag_DumpInterface str <- flags ] @@ -388,16 +380,16 @@ -- -- The @--package-name@ and @--package-version@ Haddock flags allow the user to -- specify this information manually and it is returned here if present. -modulePackageInfo :: DynFlags +modulePackageInfo :: UnitState -> [Flag] -- ^ Haddock flags are checked as they may contain -- the package name or version provided by the user -- which we prioritise -> Maybe Module -> (Maybe PackageName, Maybe Data.Version.Version) -modulePackageInfo _dflags _flags Nothing = (Nothing, Nothing) -modulePackageInfo dflags flags (Just modu) = +modulePackageInfo _unit_state _flags Nothing = (Nothing, Nothing) +modulePackageInfo unit_state flags (Just modu) = ( optPackageName flags <|> fmap unitPackageName pkgDb , optPackageVersion flags <|> fmap unitPackageVersion pkgDb ) where - pkgDb = lookupUnit (unitState dflags) (moduleUnit modu) + pkgDb = lookupUnit unit_state (moduleUnit modu) diff --git a/src/Haddock/Parser.hs b/src/Haddock/Parser.hs --- a/src/Haddock/Parser.hs +++ b/src/Haddock/Parser.hs @@ -19,8 +19,9 @@ import Haddock.Types import GHC.Driver.Session ( DynFlags ) +import GHC.Driver.Config import GHC.Data.FastString ( fsLit ) -import GHC.Parser.Lexer ( mkPState, unP, ParseResult(POk, PFailed) ) +import GHC.Parser.Lexer ( initParserState, unP, ParseResult(POk, PFailed) ) import GHC.Parser ( parseIdentifier ) import GHC.Types.Name.Occurrence ( occNameString ) import GHC.Types.Name.Reader ( RdrName(..) ) @@ -48,7 +49,7 @@ PFailed{} -> Nothing where realSrcLc = mkRealSrcLoc (fsLit "") 0 0 - pstate str = mkPState dflags (stringToStringBuffer str) realSrcLc + pstate str = initParserState (initParserOpts dflags) (stringToStringBuffer str) realSrcLc (wrap,str1) = case str0 of '(' : s@(c : _) | c /= ',', c /= ')' -- rule out tuple names -> (Parenthesized, init s) diff --git a/src/Haddock/Syb.hs b/src/Haddock/Syb.hs --- a/src/Haddock/Syb.hs +++ b/src/Haddock/Syb.hs @@ -6,7 +6,7 @@ module Haddock.Syb ( everything, everythingButType, everythingWithState , everywhere, everywhereButType - , mkT + , mkT, mkQ, extQ , combine ) where @@ -90,6 +90,21 @@ mkT f = case cast f of Just f' -> f' Nothing -> id + +-- | Create generic query. +-- +-- Another function stolen from SYB package. +mkQ :: (Typeable a, Typeable b) => r -> (b -> r) -> a -> r +(r `mkQ` br) a = case cast a of + Just b -> br b + Nothing -> r + + +-- | Extend a generic query by a type-specific case. +-- +-- Another function stolen from SYB package. +extQ :: (Typeable a, Typeable b) => (a -> q) -> (b -> q) -> a -> q +extQ f g a = maybe (f a) g (cast a) -- | Combine two queries into one using alternative combinator. combine :: Alternative f => (forall a. Data a => a -> f r) diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving, TypeFamilies, RecordWildCards #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] @@ -44,7 +45,9 @@ import Data.Data (Data) import Data.Void (Void) import Documentation.Haddock.Types -import GHC.Types.Basic (Fixity(..), PromotionFlag(..)) +import GHC.Types.Basic (PromotionFlag(..)) +import GHC.Types.Fixity (Fixity(..)) +import GHC.Types.Var (Specificity) import GHC import GHC.Driver.Session (Language) @@ -311,10 +314,12 @@ data DocNameI +type instance NoGhcTc DocNameI = DocNameI + type instance IdP DocNameI = DocName instance CollectPass DocNameI where - collectXXPat _ ext = noExtCon ext + collectXXPat _ _ ext = noExtCon ext instance NamedThing DocName where getName (Documented name _) = name @@ -403,13 +408,13 @@ -- 'PseudoFamilyDecl' type is introduced. data PseudoFamilyDecl name = PseudoFamilyDecl { pfdInfo :: FamilyInfo name - , pfdLName :: Located (IdP name) + , pfdLName :: LocatedN (IdP name) , pfdTyVars :: [LHsType name] , pfdKindSig :: LFamilyResultSig name } -mkPseudoFamilyDecl :: FamilyDecl (GhcPass p) -> PseudoFamilyDecl (GhcPass p) +mkPseudoFamilyDecl :: FamilyDecl GhcRn -> PseudoFamilyDecl GhcRn mkPseudoFamilyDecl (FamilyDecl { .. }) = PseudoFamilyDecl { pfdInfo = fdInfo , pfdLName = fdLName @@ -417,12 +422,12 @@ , pfdKindSig = fdResultSig } where - mkType :: HsTyVarBndr flag (GhcPass p) -> HsType (GhcPass p) + mkType :: HsTyVarBndr flag GhcRn -> HsType GhcRn mkType (KindedTyVar _ _ (L loc name) lkind) = - HsKindSig noExtField tvar lkind + HsKindSig noAnn tvar lkind where - tvar = L loc (HsTyVar noExtField NotPromoted (L loc name)) - mkType (UserTyVar _ _ name) = HsTyVar noExtField NotPromoted name + tvar = L (na2la loc) (HsTyVar noAnn NotPromoted (L loc name)) + mkType (UserTyVar _ _ name) = HsTyVar noAnn NotPromoted name -- | An instance head that may have documentation and a source location. @@ -687,41 +692,71 @@ liftErrMsg :: ErrMsgM a -> ErrMsgGhc a liftErrMsg = writer . runWriter -instance MonadThrow ErrMsgGhc where - throwM e = ErrMsgGhc (throwM e) - -instance MonadCatch ErrMsgGhc where - catch (ErrMsgGhc m) f = ErrMsgGhc (catch m (unErrMsgGhc . f)) - ----------------------------------------------------------------------------- -- * Pass sensitive types ----------------------------------------------------------------------------- -type instance XRec DocNameI f = Located (f DocNameI) +type instance XRec DocNameI a = GenLocated (Anno a) a +instance UnXRec DocNameI where + unXRec = unLoc +instance MapXRec DocNameI where + mapXRec = fmap +instance WrapXRec DocNameI (HsType DocNameI) where + wrapXRec = noLocA -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 Anno DocName = SrcSpanAnnN +type instance Anno (HsTyVarBndr flag DocNameI) = SrcSpanAnnA +type instance Anno [LocatedA (HsType DocNameI)] = SrcSpanAnnC +type instance Anno (HsType DocNameI) = SrcSpanAnnA +type instance Anno (DataFamInstDecl DocNameI) = SrcSpanAnnA +type instance Anno (DerivStrategy DocNameI) = SrcSpan +type instance Anno (FieldOcc DocNameI) = SrcSpan +type instance Anno (ConDeclField DocNameI) = SrcSpan +type instance Anno (Located (ConDeclField DocNameI)) = SrcSpan +type instance Anno [Located (ConDeclField DocNameI)] = SrcSpan +type instance Anno (ConDecl DocNameI) = SrcSpan +type instance Anno (FunDep DocNameI) = SrcSpan +type instance Anno (TyFamInstDecl DocNameI) = SrcSpanAnnA +type instance Anno [LocatedA (TyFamInstDecl DocNameI)] = SrcSpanAnnL +type instance Anno (FamilyDecl DocNameI) = SrcSpan +type instance Anno (Sig DocNameI) = SrcSpan +type instance Anno (InjectivityAnn DocNameI) = SrcSpan +type instance Anno (HsDecl DocNameI) = SrcSpanAnnA +type instance Anno (FamilyResultSig DocNameI) = SrcSpan +type instance Anno (HsOuterTyVarBndrs Specificity DocNameI) = SrcSpanAnnA +type instance Anno (HsSigType DocNameI) = SrcSpanAnnA + +type XRecCond a + = ( XParTy a ~ EpAnn AnnParen + , NoGhcTc a ~ a + , MapXRec a + , UnXRec a + , WrapXRec a (HsType a) + ) + +type instance XForAllTy DocNameI = EpAnn [AddEpAnn] +type instance XQualTy DocNameI = EpAnn [AddEpAnn] +type instance XTyVar DocNameI = EpAnn [AddEpAnn] +type instance XStarTy DocNameI = EpAnn [AddEpAnn] +type instance XAppTy DocNameI = EpAnn [AddEpAnn] +type instance XAppKindTy DocNameI = EpAnn [AddEpAnn] +type instance XFunTy DocNameI = EpAnn [AddEpAnn] +type instance XListTy DocNameI = EpAnn AnnParen +type instance XTupleTy DocNameI = EpAnn AnnParen +type instance XSumTy DocNameI = EpAnn AnnParen +type instance XOpTy DocNameI = EpAnn [AddEpAnn] +type instance XParTy DocNameI = EpAnn AnnParen +type instance XIParamTy DocNameI = EpAnn [AddEpAnn] +type instance XKindSig DocNameI = EpAnn [AddEpAnn] type instance XSpliceTy DocNameI = Void -- see `renameHsSpliceTy` -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 XDocTy DocNameI = EpAnn [AddEpAnn] +type instance XBangTy DocNameI = EpAnn [AddEpAnn] +type instance XRecTy DocNameI = EpAnn [AddEpAnn] +type instance XExplicitListTy DocNameI = EpAnn [AddEpAnn] +type instance XExplicitTupleTy DocNameI = EpAnn [AddEpAnn] +type instance XTyLit DocNameI = EpAnn [AddEpAnn] +type instance XWildCardTy DocNameI = EpAnn [AddEpAnn] +type instance XXType DocNameI = HsCoreTy type instance XHsForAllVis DocNameI = NoExtField type instance XHsForAllInvis DocNameI = NoExtField @@ -763,6 +798,9 @@ type instance XCClsInstDecl DocNameI = NoExtField type instance XCDerivDecl DocNameI = NoExtField +type instance XStockStrategy DocNameI = NoExtField +type instance XAnyClassStrategy DocNameI = NoExtField +type instance XNewtypeStrategy DocNameI = NoExtField type instance XViaStrategy DocNameI = LHsSigType DocNameI type instance XDataFamInstD DocNameI = NoExtField type instance XTyFamInstD DocNameI = NoExtField @@ -776,12 +814,23 @@ type instance XXFamilyDecl DocNameI = NoExtCon type instance XXTyClDecl DocNameI = NoExtCon -type instance XHsIB DocNameI _ = NoExtField -type instance XHsWC DocNameI _ = NoExtField -type instance XXHsImplicitBndrs DocNameI _ = NoExtCon +type instance XHsWC DocNameI _ = NoExtField +type instance XHsOuterExplicit DocNameI _ = NoExtField +type instance XHsOuterImplicit DocNameI = NoExtField +type instance XXHsOuterTyVarBndrs DocNameI = NoExtCon + +type instance XHsSig DocNameI = NoExtField +type instance XXHsSigType DocNameI = NoExtCon + type instance XHsQTvs DocNameI = NoExtField type instance XConDeclField DocNameI = NoExtField type instance XXConDeclField DocNameI = NoExtCon type instance XXPat DocNameI = NoExtCon + +type instance XCInjectivityAnn DocNameI = NoExtField + +type instance XCFunDep DocNameI = NoExtField + +type instance XCTyFamInstDecl DocNameI = NoExtField diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs --- a/src/Haddock/Utils.hs +++ b/src/Haddock/Utils.hs @@ -1,4 +1,7 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Utils diff --git a/src/Haddock/Utils/Json.hs b/src/Haddock/Utils/Json.hs --- a/src/Haddock/Utils/Json.hs +++ b/src/Haddock/Utils/Json.hs @@ -1,6 +1,4 @@ -{-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -- | Minimal JSON / RFC 7159 support -- @@ -14,53 +12,35 @@ , encodeToString , encodeToBuilder , ToJSON(toJSON) - - , Parser(..) - , Result(..) - , FromJSON(parseJSON) - , withObject - , withArray - , withString - , withDouble - , withBool - , fromJSON - , parse - , parseEither - , (.:) - , (.:?) - , decode - , decodeWith - , eitherDecode - , eitherDecodeWith - , decodeFile - , eitherDecodeFile ) where -import Control.Applicative (Alternative (..)) -import Control.Monad (MonadPlus (..), zipWithM, (>=>)) -import qualified Control.Monad as Monad -import qualified Control.Monad.Fail as Fail - -import qualified Data.ByteString.Lazy as BSL -import Data.ByteString.Builder (Builder) -import qualified Data.ByteString.Builder as BB import Data.Char import Data.Int +import Data.String import Data.Word import Data.List (intersperse) import Data.Monoid -import GHC.Natural +import Data.ByteString.Builder (Builder) +import qualified Data.ByteString.Builder as BB -- TODO: We may want to replace 'String' with 'Text' or 'ByteString' -import qualified Text.Parsec.ByteString.Lazy as Parsec.Lazy -import qualified Text.ParserCombinators.Parsec as Parsec +-- | A JSON value represented as a Haskell value. +data Value = Object !Object + | Array [Value] + | String String + | Number !Double + | Bool !Bool + | Null + deriving (Eq, Read, Show) -import Haddock.Utils.Json.Types -import Haddock.Utils.Json.Parser +-- | A key\/value pair for an 'Object' +type Pair = (String, Value) +-- | A JSON \"object\" (key/value map). +type Object = [Pair] infixr 8 .= @@ -68,7 +48,14 @@ (.=) :: ToJSON v => String -> v -> Pair k .= v = (k, toJSON v) +-- | Create a 'Value' from a list of name\/value 'Pair's. +object :: [Pair] -> Value +object = Object +instance IsString Value where + fromString = String + + -- | A type that can be converted to JSON. class ToJSON a where -- | Convert a Haskell value to a JSON-friendly intermediate type. @@ -236,324 +223,3 @@ -- unescaped = %x20-21 / %x23-5B / %x5D-10FFFF needsEscape c = ord c < 0x20 || c `elem` ['\\','"'] - ------------------------------------------------------------------------------- --- FromJSON - --- | Elements of a JSON path used to describe the location of an --- error. -data JSONPathElement - = Key String - -- ^ JSON path element of a key into an object, - -- \"object.key\". - | Index !Int - -- ^ JSON path element of an index into an - -- array, \"array[index]\". - deriving (Eq, Show, Ord) - -type JSONPath = [JSONPathElement] - --- | Failure continuation. -type Failure f r = JSONPath -> String -> f r - --- | Success continuation. -type Success a f r = a -> f r - -newtype Parser a = Parser { - runParser :: forall f r. - JSONPath - -> Failure f r - -> Success a f r - -> f r - } - -modifyFailure :: (String -> String) -> Parser a -> Parser a -modifyFailure f (Parser p) = Parser $ \path kf ks -> - p path (\p' m -> kf p' (f m)) ks - -prependFailure :: String -> Parser a -> Parser a -prependFailure = modifyFailure . (++) - -prependContext :: String -> Parser a -> Parser a -prependContext name = prependFailure ("parsing " ++ name ++ " failed, ") - -typeMismatch :: String -> Value -> Parser a -typeMismatch expected actual = - fail $ "expected " ++ expected ++ ", but encountered " ++ typeOf actual - -instance Monad.Monad Parser where - m >>= g = Parser $ \path kf ks -> - runParser m path kf - (\a -> runParser (g a) path kf ks) - return = pure - -instance Fail.MonadFail Parser where - fail msg = Parser $ \path kf _ks -> kf (reverse path) msg - -instance Functor Parser where - fmap f m = Parser $ \path kf ks -> - let ks' a = ks (f a) - in runParser m path kf ks' - -instance Applicative Parser where - pure a = Parser $ \_path _kf ks -> ks a - (<*>) = apP - -instance Alternative Parser where - empty = fail "empty" - (<|>) = mplus - -instance MonadPlus Parser where - mzero = fail "mzero" - mplus a b = Parser $ \path kf ks -> - runParser a path (\_ _ -> runParser b path kf ks) ks - -instance Semigroup (Parser a) where - (<>) = mplus - -instance Monoid (Parser a) where - mempty = fail "mempty" - mappend = (<>) - -apP :: Parser (a -> b) -> Parser a -> Parser b -apP d e = do - b <- d - b <$> e - -() :: Parser a -> JSONPathElement -> Parser a -p pathElem = Parser $ \path kf ks -> runParser p (pathElem:path) kf ks - -parseIndexedJSON :: (Value -> Parser a) -> Int -> Value -> Parser a -parseIndexedJSON p idx value = p value Index idx - -unexpected :: Value -> Parser a -unexpected actual = fail $ "unexpected " ++ typeOf actual - -withObject :: String -> (Object -> Parser a) -> Value -> Parser a -withObject _ f (Object obj) = f obj -withObject name _ v = prependContext name (typeMismatch "Object" v) - -withArray :: String -> ([Value] -> Parser a) -> Value -> Parser a -withArray _ f (Array arr) = f arr -withArray name _ v = prependContext name (typeMismatch "Array" v) - -withString :: String -> (String -> Parser a) -> Value -> Parser a -withString _ f (String txt) = f txt -withString name _ v = prependContext name (typeMismatch "String" v) - -withDouble :: String -> (Double -> Parser a) -> Value -> Parser a -withDouble _ f (Number duble) = f duble -withDouble name _ v = prependContext name (typeMismatch "Number" v) - -withBool :: String -> (Bool -> Parser a) -> Value -> Parser a -withBool _ f (Bool arr) = f arr -withBool name _ v = prependContext name (typeMismatch "Boolean" v) - -class FromJSON a where - parseJSON :: Value -> Parser a - - parseJSONList :: Value -> Parser [a] - parseJSONList = withArray "[]" (zipWithM (parseIndexedJSON parseJSON) [0..]) - -instance FromJSON Bool where - parseJSON (Bool b) = pure b - parseJSON v = typeMismatch "Bool" v - -instance FromJSON () where - parseJSON = - withArray "()" $ \v -> - if null v - then pure () - else prependContext "()" $ fail "expected an empty array" - -instance FromJSON Char where - parseJSON = withString "Char" parseChar - - parseJSONList (String s) = pure s - parseJSONList v = typeMismatch "String" v - -parseChar :: String -> Parser Char -parseChar t = - if length t == 1 - then pure $ head t - else prependContext "Char" $ fail "expected a string of length 1" - -parseRealFloat :: RealFloat a => String -> Value -> Parser a -parseRealFloat _ (Number s) = pure $ realToFrac s -parseRealFloat _ Null = pure (0/0) -parseRealFloat name v = prependContext name (unexpected v) - -instance FromJSON Double where - parseJSON = parseRealFloat "Double" - -instance FromJSON Float where - parseJSON = parseRealFloat "Float" - -parseNatural :: Integer -> Parser Natural -parseNatural integer = - if integer < 0 then - fail $ "parsing Natural failed, unexpected negative number " <> show integer - else - pure $ fromIntegral integer - -parseIntegralFromDouble :: Integral a => Double -> Parser a -parseIntegralFromDouble d = - let r = toRational d - x = truncate r - in if toRational x == r - then pure $ x - else fail $ "unexpected floating number " <> show d - -parseIntegral :: Integral a => String -> Value -> Parser a -parseIntegral name = withDouble name parseIntegralFromDouble - -instance FromJSON Integer where - parseJSON = parseIntegral "Integer" - -instance FromJSON Natural where - parseJSON = withDouble "Natural" - (parseIntegralFromDouble >=> parseNatural) - -instance FromJSON Int where - parseJSON = parseIntegral "Int" - -instance FromJSON Int8 where - parseJSON = parseIntegral "Int8" - -instance FromJSON Int16 where - parseJSON = parseIntegral "Int16" - -instance FromJSON Int32 where - parseJSON = parseIntegral "Int32" - -instance FromJSON Int64 where - parseJSON = parseIntegral "Int64" - -instance FromJSON Word where - parseJSON = parseIntegral "Word" - -instance FromJSON Word8 where - parseJSON = parseIntegral "Word8" - -instance FromJSON Word16 where - parseJSON = parseIntegral "Word16" - -instance FromJSON Word32 where - parseJSON = parseIntegral "Word32" - -instance FromJSON Word64 where - parseJSON = parseIntegral "Word64" - -instance FromJSON a => FromJSON [a] where - parseJSON = parseJSONList - -data Result a = Error String - | Success a - deriving (Eq, Show) - -fromJSON :: FromJSON a => Value -> Result a -fromJSON = parse parseJSON - -parse :: (a -> Parser b) -> a -> Result b -parse m v = runParser (m v) [] (const Error) Success - -parseEither :: (a -> Parser b) -> a -> Either String b -parseEither m v = runParser (m v) [] onError Right - where onError path msg = Left (formatError path msg) - -formatError :: JSONPath -> String -> String -formatError path msg = "Error in " ++ formatPath path ++ ": " ++ msg - -formatPath :: JSONPath -> String -formatPath path = "$" ++ formatRelativePath path - -formatRelativePath :: JSONPath -> String -formatRelativePath path = format "" path - where - format :: String -> JSONPath -> String - format pfx [] = pfx - format pfx (Index idx:parts) = format (pfx ++ "[" ++ show idx ++ "]") parts - format pfx (Key key:parts) = format (pfx ++ formatKey key) parts - - formatKey :: String -> String - formatKey key - | isIdentifierKey key = "." ++ key - | otherwise = "['" ++ escapeKey key ++ "']" - - isIdentifierKey :: String -> Bool - isIdentifierKey [] = False - isIdentifierKey (x:xs) = isAlpha x && all isAlphaNum xs - - escapeKey :: String -> String - escapeKey = concatMap escapeChar - - escapeChar :: Char -> String - escapeChar '\'' = "\\'" - escapeChar '\\' = "\\\\" - escapeChar c = [c] - -explicitParseField :: (Value -> Parser a) -> Object -> String -> Parser a -explicitParseField p obj key = - case key `lookup` obj of - Nothing -> fail $ "key " ++ key ++ " not found" - Just v -> p v Key key - -(.:) :: FromJSON a => Object -> String -> Parser a -(.:) = explicitParseField parseJSON - -explicitParseFieldMaybe :: (Value -> Parser a) -> Object -> String -> Parser (Maybe a) -explicitParseFieldMaybe p obj key = - case key `lookup` obj of - Nothing -> pure Nothing - Just v -> Just <$> p v Key key - -(.:?) :: FromJSON a => Object -> String -> Parser (Maybe a) -(.:?) = explicitParseFieldMaybe parseJSON - - -decodeWith :: (Value -> Result a) -> BSL.ByteString -> Maybe a -decodeWith decoder bsl = - case Parsec.parse parseJSONValue "" bsl of - Left _ -> Nothing - Right json -> - case decoder json of - Success a -> Just a - Error _ -> Nothing - -decode :: FromJSON a => BSL.ByteString -> Maybe a -decode = decodeWith fromJSON - -eitherDecodeWith :: (Value -> Result a) -> BSL.ByteString -> Either String a -eitherDecodeWith decoder bsl = - case Parsec.parse parseJSONValue "" bsl of - Left parsecError -> Left (show parsecError) - Right json -> - case decoder json of - Success a -> Right a - Error err -> Left err - -eitherDecode :: FromJSON a => BSL.ByteString -> Either String a -eitherDecode = eitherDecodeWith fromJSON - - -decodeFile :: FromJSON a => FilePath -> IO (Maybe a) -decodeFile filePath = do - parsecResult <- Parsec.Lazy.parseFromFile parseJSONValue filePath - case parsecResult of - Right r -> - case fromJSON r of - Success a -> return (Just a) - Error _ -> return Nothing - Left _ -> return Nothing - - -eitherDecodeFile :: FromJSON a => FilePath -> IO (Either String a) -eitherDecodeFile filePath = do - parsecResult <- Parsec.Lazy.parseFromFile parseJSONValue filePath - case parsecResult of - Right r -> - case fromJSON r of - Success a -> return (Right a) - Error err -> return (Left err) - Left err -> return $ Left (show err) - diff --git a/src/Haddock/Utils/Json/Parser.hs b/src/Haddock/Utils/Json/Parser.hs deleted file mode 100644 --- a/src/Haddock/Utils/Json/Parser.hs +++ /dev/null @@ -1,102 +0,0 @@ --- | Json "Parsec" parser, based on --- [json](https://hackage.haskell.org/package/json) package. --- -module Haddock.Utils.Json.Parser - ( parseJSONValue - ) where - -import Prelude hiding (null) - -import Control.Applicative (Alternative (..)) -import Control.Monad (MonadPlus (..)) -import Data.Char (isHexDigit) -import Data.Functor (($>)) -import qualified Data.ByteString.Lazy.Char8 as BSCL -import Numeric -import Text.Parsec.ByteString.Lazy (Parser) -import Text.ParserCombinators.Parsec (()) -import qualified Text.ParserCombinators.Parsec as Parsec - -import Haddock.Utils.Json.Types hiding (object) - -parseJSONValue :: Parser Value -parseJSONValue = Parsec.spaces *> parseValue - -tok :: Parser a -> Parser a -tok p = p <* Parsec.spaces - -parseValue :: Parser Value -parseValue = - parseNull - <|> Bool <$> parseBoolean - <|> Array <$> parseArray - <|> String <$> parseString - <|> Object <$> parseObject - <|> Number <$> parseNumber - "JSON value" - -parseNull :: Parser Value -parseNull = tok - $ Parsec.string "null" - $> Null - -parseBoolean :: Parser Bool -parseBoolean = tok - $ Parsec.string "true" $> True - <|> Parsec.string "false" $> False - -parseArray :: Parser [Value] -parseArray = - Parsec.between - (tok (Parsec.char '[')) - (tok (Parsec.char ']')) - (parseValue `Parsec.sepBy` tok (Parsec.char ',')) - -parseString :: Parser String -parseString = - Parsec.between - (tok (Parsec.char '"')) - (tok (Parsec.char '"')) - (many char) - where - char = (Parsec.char '\\' >> escapedChar) - <|> Parsec.satisfy (\x -> x /= '"' && x /= '\\') - - escapedChar = - Parsec.char '"' $> '"' - <|> Parsec.char '\\' $> '\\' - <|> Parsec.char '/' $> '/' - <|> Parsec.char 'b' $> '\b' - <|> Parsec.char 'f' $> '\f' - <|> Parsec.char 'n' $> '\n' - <|> Parsec.char 'r' $> '\r' - <|> Parsec.char 't' $> '\t' - <|> Parsec.char 'u' *> uni - "escape character" - - uni = check =<< Parsec.count 4 (Parsec.satisfy isHexDigit) - where - check x | code <= max_char = return (toEnum code) - | otherwise = mzero - where code = fst $ head $ readHex x - max_char = fromEnum (maxBound :: Char) - -parseObject :: Parser Object -parseObject = - Parsec.between - (tok (Parsec.char '{')) - (tok (Parsec.char '}')) - (field `Parsec.sepBy` tok (Parsec.char ',')) - where - field :: Parser (String, Value) - field = (,) - <$> parseString - <* tok (Parsec.char ':') - <*> parseValue - -parseNumber :: Parser Double -parseNumber = tok $ do - s <- BSCL.unpack <$> Parsec.getInput - case readSigned readFloat s of - [(n,s')] -> Parsec.setInput (BSCL.pack s') $> n - _ -> mzero diff --git a/src/Haddock/Utils/Json/Types.hs b/src/Haddock/Utils/Json/Types.hs deleted file mode 100644 --- a/src/Haddock/Utils/Json/Types.hs +++ /dev/null @@ -1,42 +0,0 @@ -module Haddock.Utils.Json.Types - ( Value(..) - , typeOf - , Pair - , Object - , object - ) where - -import Data.String - --- TODO: We may want to replace 'String' with 'Text' or 'ByteString' - --- | A JSON value represented as a Haskell value. -data Value = Object !Object - | Array [Value] - | String String - | Number !Double - | Bool !Bool - | Null - deriving (Eq, Read, Show) - -typeOf :: Value -> String -typeOf v = case v of - Object _ -> "Object" - Array _ -> "Array" - String _ -> "String" - Number _ -> "Number" - Bool _ -> "Boolean" - Null -> "Null" - --- | A key\/value pair for an 'Object' -type Pair = (String, Value) - --- | A JSON \"object\" (key/value map). -type Object = [Pair] - --- | Create a 'Value' from a list of name\/value 'Pair's. -object :: [Pair] -> Value -object = Object - -instance IsString Value where - fromString = String