diff options
Diffstat (limited to 'haddock-api/src')
-rw-r--r-- | haddock-api/src/Haddock/Interface.hs | 55 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Interface/AttachInstances.hs | 34 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Interface/Create.hs | 82 |
3 files changed, 98 insertions, 73 deletions
diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index 16643d0e..b42ae1a3 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -34,43 +34,44 @@ module Haddock.Interface ( ) where -import Haddock.GhcUtils -import Haddock.InterfaceFile -import Haddock.Interface.Create -import Haddock.Interface.AttachInstances -import Haddock.Interface.Rename +import Haddock.GhcUtils (moduleString, pretty) +import Haddock.Interface.AttachInstances (attachInstances) +import Haddock.Interface.Create (createInterface1, runIfM) +import Haddock.Interface.Rename (renameInterface) +import Haddock.InterfaceFile (InterfaceFile, ifInstalledIfaces, ifLinkEnv) import Haddock.Options hiding (verbosity) -import Haddock.Types -import Haddock.Utils - -import Control.Monad -import Control.Monad.IO.Class ( MonadIO ) -import Data.IORef +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 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 -import GHC.Unit.Module.Env (mkModuleSet, emptyModuleSet, unionModuleSet, ModuleSet) -import GHC.Unit.Module.ModSummary -import GHC.Unit.Module.Graph -import GHC.Unit.Types -import GHC.Data.Graph.Directed -import GHC.Driver.Session hiding (verbosity) import GHC hiding (verbosity) -import GHC.Driver.Env -import GHC.Driver.Monad import GHC.Data.FastString (unpackFS) -import GHC.Utils.Error -import GHC.Tc.Types (TcM, TcGblEnv(..)) -import GHC.Tc.Utils.Monad (getTopEnv, setGblEnv) +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.HsToCore.Docs (getMainDeclBinder) +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 (getTopEnv, setGblEnv) import GHC.Types.Name (nameIsFromExternalPackage, nameOccName) import GHC.Types.Name.Occurrence (isTcOcc) -import GHC.Types.Name.Reader (unQualOK, greMangledName, globalRdrEnvElts) -import GHC.HsToCore.Docs -import GHC.Plugins (Outputable, StaticPlugin(..), Plugin(..), PluginWithArgs(..), - defaultPlugin, keepRenamedSource) +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 (withTiming) #if defined(mingw32_HOST_OS) import System.IO diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index 317258eb..6bc8b8c8 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -28,6 +28,7 @@ import Data.Maybe ( maybeToList, mapMaybe, fromMaybe ) import qualified Data.Map as Map import qualified Data.Set as Set +import GHC.Data.FastString (unpackFS) import GHC.Core.Class import GHC.Driver.Session import GHC.Core (isOrphan) @@ -178,19 +179,30 @@ findFixity iface ifaceMap instIfaceMap = \name -> -- Collecting and sorting instances -------------------------------------------------------------------------------- +-- | Stable name for stable comparisons. GHC's `Name` uses unstable +-- ordering based on their `Unique`'s. +newtype SName = SName Name + +instance Eq SName where + SName n1 == SName n2 = n1 `stableNameCmp` n2 == EQ + +instance Ord SName where + SName n1 `compare` SName n2 = n1 `stableNameCmp` n2 -- | Simplified type for sorting types, ignoring qualification (not visible -- in Haddock output) and unifying special tycons with normal ones. -- For the benefit of the user (looks nice and predictable) and the -- tests (which prefer output to be deterministic). -data SimpleType = SimpleType Name [SimpleType] - | SimpleTyLit TyLit +data SimpleType = SimpleType SName [SimpleType] + | SimpleIntTyLit Integer + | SimpleStringTyLit String + | SimpleCharTyLit Char deriving (Eq,Ord) -instHead :: ([TyVar], [PredType], Class, [Type]) -> ([Int], Name, [SimpleType]) +instHead :: ([TyVar], [PredType], Class, [Type]) -> ([Int], SName, [SimpleType]) instHead (_, _, cls, args) - = (map argCount args, className cls, map simplify args) + = (map argCount args, SName (className cls), map simplify args) argCount :: Type -> Int argCount (AppTy t _) = argCount t + 1 @@ -201,14 +213,16 @@ argCount (CastTy t _) = argCount t argCount _ = 0 simplify :: Type -> SimpleType -simplify (FunTy _ _ t1 t2) = SimpleType funTyConName [simplify t1, simplify t2] +simplify (FunTy _ _ t1 t2) = SimpleType (SName funTyConName) [simplify t1, simplify t2] simplify (ForAllTy _ t) = simplify t simplify (AppTy t1 t2) = SimpleType s (ts ++ maybeToList (simplify_maybe t2)) where (SimpleType s ts) = simplify t1 -simplify (TyVarTy v) = SimpleType (tyVarName v) [] -simplify (TyConApp tc ts) = SimpleType (tyConName tc) +simplify (TyVarTy v) = SimpleType (SName (tyVarName v)) [] +simplify (TyConApp tc ts) = SimpleType (SName (tyConName tc)) (mapMaybe simplify_maybe ts) -simplify (LitTy l) = SimpleTyLit l +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" @@ -217,9 +231,9 @@ simplify_maybe (CoercionTy {}) = Nothing simplify_maybe ty = Just (simplify ty) -- Used for sorting -instFam :: FamInst -> ([Int], Name, [SimpleType], Int, SimpleType) +instFam :: FamInst -> ([Int], SName, [SimpleType], Int, SimpleType) instFam FamInst { fi_fam = n, fi_tys = ts, fi_rhs = t } - = (map argCount ts, n, map simplify ts, argCount t, simplify t) + = (map argCount ts, SName n, map simplify ts, argCount t, simplify t) -------------------------------------------------------------------------------- diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 4357cb79..02fc86d9 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -1,8 +1,17 @@ -{-# LANGUAGE StandaloneDeriving, FlexibleInstances, MultiParamTypeClasses, CPP, TupleSections, BangPatterns, LambdaCase, NamedFieldPuns, ScopedTypeVariables, RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wwarn #-} ----------------------------------------------------------------------------- -- | @@ -23,48 +32,49 @@ module Haddock.Interface.Create (IfM, runIfM, createInterface1) where import Documentation.Haddock.Doc (metaDocAppend) +import Haddock.Convert (PrintRuntimeReps (..), tyThingToLHsDecl) +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.Options -import Haddock.GhcUtils -import Haddock.Utils -import Haddock.Convert -import Haddock.Interface.LexParseRn +import Haddock.Utils (replace) -import Control.Monad.Reader +import Control.Monad.Reader (MonadReader (..), ReaderT, asks, runReaderT) import Control.Monad.Writer.Strict hiding (tell) -import Data.Bitraversable -import qualified Data.Map as M +import Data.Bitraversable (bitraverse) +import Data.List (find, foldl') import Data.Map (Map) -import Data.List -import Data.Maybe -import Data.Traversable -import GHC.Stack +import qualified Data.Map as M +import Data.Maybe (catMaybes, fromJust, isJust, mapMaybe, maybeToList) +import Data.Traversable (for) +import GHC hiding (lookupName) +import GHC.Core.Class (ClassMinimalDef, classMinimalDef) +import GHC.Core.ConLike (ConLike (..)) +import GHC.Data.FastString (bytesFS, unpackFS) +import GHC.Driver.Ppr (showSDoc) +import GHC.HsToCore.Docs hiding (mkMaps) +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 qualified GHC.Unit.Module as Module -import GHC.Unit.Module.ModSummary +import qualified GHC.Types.Avail as Avail +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, 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 GHC.Types.SourceFile -import GHC.Core.Class -import GHC.Core.ConLike (ConLike(..)) -import GHC hiding (lookupName) -import GHC.Driver.Ppr -import GHC.Types.Name -import GHC.Types.Name.Set -import GHC.Types.Name.Env -import GHC.Unit.State -import GHC.Types.Name.Reader -import GHC.Tc.Types hiding (IfM) -import GHC.Data.FastString ( unpackFS, bytesFS ) -import GHC.Types.Basic ( PromotionFlag(..) ) -import GHC.Types.SourceText +import qualified GHC.Unit.Module as Module +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 -import GHC.Utils.Panic -import GHC.HsToCore.Docs hiding (mkMaps) -import GHC.Parser.Annotation (IsUnicodeSyntax(..)) -import GHC.Unit.Module.Warnings +import GHC.Utils.Panic (pprPanic) newtype IfEnv m = IfEnv { |