diff options
Diffstat (limited to 'haddock-api/src/Haddock/Interface')
| -rw-r--r-- | haddock-api/src/Haddock/Interface/AttachInstances.hs | 34 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Interface/Create.hs | 82 |
2 files changed, 70 insertions, 46 deletions
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 { |