path: root/src/HaskellCodeExplorer/GhcUtils.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}

module HaskellCodeExplorer.GhcUtils
  ( -- * Pretty-printing
    toText
  , instanceToText
  , instanceDeclToText
  , nameToText
  , tyClDeclPrefix
  , demangleOccName
  , stringBufferToByteString
  , nameSort
  , occNameNameSpace
  , identifierKey
  , nameKey
  , mbIdDetails
    -- * Syntax manipulation
  , hsGroupVals
  , hsPatSynDetails
  , ieLocNames
  , ghcDL  
    -- * Lookups
  , lookupIdInTypeEnv
  , lookupNameModuleAndPackage
    -- * Location info
  , isHsBoot
  , moduleLocationInfo
  , nameLocationInfo
  , occNameLocationInfo
  , nameDocumentation
  , srcSpanToLineAndColNumbers
    -- * Type-related functions
  , tyThingToId
  , tidyIdentifierType
  , patSynId
  , applyWrapper
  , wrapperTypes
  , tyVarsOfType
  , tyConsOfType
  , updateOccNames
  , mkType
    -- * Documentation processing
  , collectDocs
  , ungroup
  , mkDecls
  , getMainDeclBinder
  , classDeclDocs
  , sigNameNoLoc
  , clsInstDeclSrcSpan
  , hsDocsToDocH
  , subordinateNamesWithDocs
  ) where
-- import Bag (bagToList)
import GHC.Data.Bag (bagToList)
-- import ConLike (ConLike(..))
import GHC.Core.ConLike (ConLike(..))
import GHC.HsToCore.Docs
  ( collectDocs
  , ungroup
  , mkDecls
  )
import qualified Data.ByteString as BS
import Data.Hashable (Hashable,hash)
import qualified Data.ByteString.Internal as BSI
import Data.Char (isAlpha, isAlphaNum, isAscii, ord)
import Data.Generics (Data)
import Data.Generics.SYB (everything, everywhere, mkQ, mkT)
import qualified Data.Generics.Uniplate.Data()
import qualified Data.HashMap.Strict as HM
import qualified Data.List as L
import Data.Maybe (fromMaybe, isJust, mapMaybe)
import qualified Data.Text as T
-- import DataCon (dataConWorkId, flSelector)
import GHC.Core.DataCon (dataConWorkId)
import Documentation.Haddock.Parser (overIdentifier, parseParas)
import Documentation.Haddock.Types
  ( DocH(..)
  , Header(..)
  , _doc
  , Namespace
 )
-- import DynFlags ()
-- import FastString (mkFastString, unpackFS)
import GHC.Data.FastString
  ( mkFastString
  , unpackFS
  , FastString
  )
import GHC
  ( DynFlags
  , CollectFlag(..)
  , reLocN
  , unXRec
  , UnXRec
  , GhcPass
  , recordPatSynField
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
  , HsDocString
#else
  , HsDocString (..)
#endif
  , InstDecl(..)
  , Name
  , SrcSpan(..)
  , srcSpanStart
  , srcSpanEnd
  , SrcLoc(..)
  , RealSrcSpan(..)
  , SrcSpanAnnA
  , ClsInstDecl(..)
  , TyClDecl(..)
  , HsDataDefn(..)
  , NewOrData(..)
  , Id
  , rdrNameFieldOcc
  , HsGroup(..)
  , HsBindLR(..)
  , HsValBindsLR(..)
#if MIN_VERSION_GLASGOW_HASKELL(8,4,1,0)
  , HsPatSynDetails
#else
  , HsPatSynDetails(..)
#endif
  , Located
  , IE(..)
  , TyThing(..)
  , LHsDecl
  , HsDecl(..)
  , ConDecl(..)
  , HsConDetails(..)
  , DataFamInstDecl(..)
  , Sig(..)
  , ForeignDecl(..)
  , FixitySig(..)
  , tcdName
  , collectHsBindBinders
  , getLocA
--  , hsSigType
  , getConNames
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
  , NHsValBindsLR(..)
--  , getConArgs
  , unpackHDS
  , NoExtField(..)
--  , NoExt(..)
  , extFieldOcc
#else
  , getConDetails
  , selectorFieldOcc
#endif
#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
  , LIEWrappedName
  , ieLWrappedName
#else
  , tyClGroupConcat
#endif
#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
  , FamEqn(..)
#endif
  , tyConKind
  , nameSrcSpan
  , srcSpanFile
  , srcSpanStartLine
  , srcSpanEndLine
  , srcSpanStartCol
  , srcSpanEndCol
  , isExternalName
--  , recordPatSynSelectorId
  , recordPatSynPatVar
  , isGoodSrcSpan
  , isLocalId
  , isDataFamilyDecl
  , tyFamInstDeclName
  , idType
--  , hsib_body
#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
#else
  , tfe_pats
#endif
  , tfid_eqn
#if MIN_VERSION_ghc(8,8,0)
--  , dL
--  , HasSrcSpan
--  , SrcSpanLess 
#endif
  )

import qualified HaskellCodeExplorer.Types as HCE
-- import HscTypes (TypeEnv, lookupTypeEnv)
import GHC.Types.TypeEnv (TypeEnv, lookupTypeEnv)
#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
-- import HsExtension (GhcRn,IdP)
import GHC.Hs.Extension (GhcRn)
import Language.Haskell.Syntax.Extension (IdP)
#endif
-- import IdInfo (IdDetails(..))
import GHC.Types.Id.Info (IdDetails(..))
-- import InstEnv (ClsInst(..))
import GHC.Core.InstEnv (ClsInst(..))
-- import GHC.Parser.Lexer (ParseResult(POk), mkPState, unP)
import GHC.Parser.Lexer
  ( ParseResult(POk)
  , initParserState
  , unP
  )
-- import Module (Module(..))
-- import Name
import GHC.Types.Name
  ( isDataConNameSpace
  , isDerivedOccName
  , isInternalName
  , isSystemName
  , isTvNameSpace
  , isTyConName
  , isValNameSpace
  , isWiredInName
  , mkInternalName
  , mkOccName
  , nameModule_maybe
  , nameOccName
  , nameUnique
  , occNameFS
  , occNameSpace
  , occNameString
  , wiredInNameTyThing_maybe
  )
-- import OccName (OccName)
import GHC.Types.Name.Occurrence (OccName)
-- import Outputable (Outputable, ppr, showPpr, showSDoc)
import GHC.Utils.Outputable (Outputable, ppr)
import GHC.Utils.Misc (thenCmp)
import GHC.Driver.Config (initParserOpts)
import GHC.Driver.Ppr (showPpr, showSDoc)
-- import PackageConfig (packageVersion)
-- import Packages
import GHC.Unit.State
  ( LookupResult(..)
  , lookupModuleWithSuggestions
  , lookupUnit
--  , lookupPackage
--  , packageNameString
  )
-- import Pair (pSnd)
import GHC.Data.Pair (pSnd)
-- import Parser (parseIdentifier)
import GHC.Parser (parseIdentifier)
-- import PatSyn (PatSyn, patSynMatcher, patSynSig)
import GHC.Core.PatSyn (PatSyn, patSynMatcher, patSynSig)
import Prelude hiding (id, span)
-- import RdrName (GlobalRdrEnv, RdrName(..), gre_name, lookupGRE_RdrName)
import GHC.Types.Name.Reader
  ( GlobalRdrEnv
  , RdrName(..)
  , grePrintableName
  , lookupGRE_RdrName)
-- import RnEnv (dataTcOccs)
import GHC.Rename.Env (dataTcOccs)
-- import SrcLoc (GenLocated(..), mkRealSrcLoc, unLoc)
import GHC.Types.SrcLoc
  ( GenLocated(..)
  , mkRealSrcLoc
  , unLoc
  )
-- import StringBuffer (StringBuffer(..), stringToStringBuffer)
import GHC.Data.StringBuffer (StringBuffer(..), stringToStringBuffer)
import System.FilePath (normalise)
-- import TcEvidence (HsWrapper(..), tcCoercionKind)
import GHC.Tc.Types.Evidence (HsWrapper(..), tcCoercionKind)
-- import TcType (evVarPred)
import GHC.Tc.Utils.TcType (evVarPred)
import GHC.Core.TyCo.Rep
  ( Type(..)
  , mkVisFunTyMany
  , mkVisFunTys
  , mkVisFunTysMany
  , scaledThing
  )
-- import TyCon (tyConName)
import GHC.Core.TyCon (tyConName)
-- import Type
import GHC.Core.Type
  ( coreView
  , expandTypeSynonyms
  , mkForAllTy
  , mkTyCoInvForAllTys
--  , mkFunTys
--  , mkInvForAllTys
  , piResultTy
  , splitFunTy_maybe
  , tidyOpenType
  )
import GHC.Core.TyCo.Ppr (pprSigmaType)
#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
import GHC.CoreToIface
-- import IfaceType
import GHC.Iface.Type
#endif
-- import TysWiredIn (unitTy)
import GHC.Builtin.Types (unitTy)
-- import UniqSet (emptyUniqSet, unionUniqSets,
import GHC.Types.Unique.Set (emptyUniqSet, unionUniqSets,
#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
   nonDetEltsUniqSet
#else
   uniqSetToList
#endif
 )
-- import Unique (getKey)
import GHC.Types.Unique (getKey)
-- import Var
import GHC.Types.Var
  ( idDetails
  , isId
  , mkTyVar
  , mkCoVar
  , setVarType
  , varName
  , varType
  , varUnique
  )
-- import VarEnv (TidyEnv)
import GHC.Types.Var.Env (TidyEnv)
-- import VarSet (VarSet, emptyVarSet, unionVarSet, unitVarSet
import GHC.Types.Var.Set (VarSet, emptyVarSet, unionVarSet, unitVarSet
#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
#else
 ,varSetElems
#endif
 )
import GHC.Unit

--------------------------------------------------------------------------------
-- Pretty-printing
--------------------------------------------------------------------------------

toText :: (Outputable a) => DynFlags -> a -> T.Text
toText flags = T.pack . showSDoc flags . ppr

instanceToText :: DynFlags -> ClsInst -> T.Text
instanceToText flags ClsInst {..} =
  T.append "instance " $ T.pack . showSDoc flags $ pprSigmaType (idType is_dfun)

instanceDeclToText :: DynFlags -> InstDecl GhcRn -> T.Text
instanceDeclToText flags decl =
  case decl of
-- Pattern match has inaccessible right hand side
    -- XInstDecl _ -> ""
    -- ClsInstD _ (XClsInstDecl _) -> ""
    ClsInstD _ ClsInstDecl {..} ->
      T.append "instance " (toText flags cid_poly_ty)
    DataFamInstD _ di ->
      let args =
            T.intercalate " " . map (toText flags) .  feqn_pats  . dfid_eqn $ di
       in T.concat
            ["data instance ", toText flags (unLoc $ feqn_tycon . dfid_eqn $ di), " ", args]
    TyFamInstD _ ti ->
      let args =
            T.intercalate " " .
            map (toText flags) . feqn_pats . tfid_eqn $
            ti
       in T.concat
            ["type instance ", toText flags $ tyFamInstDeclName ti, " ", args]

nameToText :: Name -> T.Text
nameToText = T.pack . unpackFS . occNameFS . nameOccName

tyClDeclPrefix :: TyClDecl a -> T.Text
tyClDeclPrefix tyClDecl =
  let isNewTy :: TyClDecl a -> Bool
      isNewTy DataDecl {tcdDataDefn = HsDataDefn {dd_ND = NewType}} = True
      isNewTy _ = False
   in case tyClDecl of
        FamDecl {}
          | isDataFamilyDecl tyClDecl -> "data family "
          | otherwise -> "type family "
        SynDecl {} -> "type "
        DataDecl {}
          | isNewTy tyClDecl -> "newtype "
          | otherwise -> "data "
        ClassDecl {} -> "class "
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
        XTyClDecl _ -> ""
#endif

demangleOccName :: Name -> T.Text
demangleOccName name
  | isDerivedOccName (nameOccName name) =
    let removePrefix :: T.Text -> T.Text
        removePrefix occName
          | T.isPrefixOf "$sel:" occName =
            fst $ T.breakOn ":" (T.drop 5 occName)
          | T.isPrefixOf "$W" occName = T.drop 2 occName
          | T.isPrefixOf "$w" occName = T.drop 2 occName
          | T.isPrefixOf "$m" occName = T.drop 2 occName
          | T.isPrefixOf "$b" occName = T.drop 2 occName
          | T.isPrefixOf "$dm" occName = T.drop 3 occName
          | T.isPrefixOf "$c" occName = T.drop 2 occName
          | T.isPrefixOf "$d" occName = T.drop 2 occName
          | T.isPrefixOf "$i" occName = T.drop 2 occName
          | T.isPrefixOf "$s" occName = T.drop 2 occName
          | T.isPrefixOf "$f" occName = T.drop 2 occName
          | T.isPrefixOf "$r" occName = T.drop 2 occName
          | T.isPrefixOf "C:" occName = T.drop 2 occName
          | T.isPrefixOf "N:" occName = T.drop 2 occName
          | T.isPrefixOf "D:" occName = T.drop 2 occName
          | T.isPrefixOf "$co" occName = T.drop 3 occName
          | otherwise = occName
     in removePrefix $ nameToText name
  | otherwise = nameToText name

stringBufferToByteString :: StringBuffer -> BS.ByteString
stringBufferToByteString (StringBuffer buf len cur) =
  BSI.fromForeignPtr buf cur len

nameSort :: Name -> HCE.NameSort
nameSort n =
  if isExternalName n
    then HCE.External
    else HCE.Internal

occNameNameSpace :: OccName -> HCE.NameSpace
occNameNameSpace n
  | isDataConNameSpace (occNameSpace n) = HCE.DataName
  | isTvNameSpace (occNameSpace n) = HCE.TvName
  | isValNameSpace (occNameSpace n) = HCE.VarName
  | otherwise = HCE.TcClsName

-- Two 'Id''s may have different types even though they have the same 'Unique'.
identifierKey :: DynFlags -> Id -> T.Text
identifierKey flags id
  | isLocalId id =
    T.concat
      [ T.pack . show . getKey . varUnique $ id
      , "_"
      , T.pack . show . hash . showSDoc flags . ppr . varType $ id
      ]
identifierKey _ id = T.pack . show . getKey . varUnique $ id

nameKey :: Name -> T.Text
nameKey = T.pack . show . getKey . nameUnique

mbIdDetails :: Id -> Maybe HCE.IdDetails
mbIdDetails v
  | isId v =
    case idDetails v of
      VanillaId -> Just HCE.VanillaId
      RecSelId {sel_naughty = False} -> Just HCE.RecSelId
      RecSelId {sel_naughty = True} -> Just HCE.RecSelIdNaughty
      DataConWorkId _ -> Just HCE.DataConWorkId
      DataConWrapId _ -> Just HCE.DataConWrapId
      ClassOpId _ -> Just HCE.ClassOpId
      PrimOpId _ -> Just HCE.PrimOpId
      FCallId _ -> Just HCE.FCallId
      TickBoxOpId _ -> Just HCE.TickBoxOpId
      DFunId _ -> Just HCE.DFunId
      CoVarId -> Just HCE.CoVarId
#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
      JoinId _ -> Just HCE.JoinId
#endif
mbIdDetails _ = Nothing

--------------------------------------------------------------------------------
--  Syntax transformation
--------------------------------------------------------------------------------

hsGroupVals :: HsGroup GhcRn -> [GenLocated SrcSpanAnnA (HsBindLR GhcRn GhcRn)]
hsGroupVals hsGroup =
  filter (isGoodSrcSpan . getLocA) $
  case hs_valds hsGroup of
    XValBindsLR (NValBinds binds _) -> concatMap (bagToList . snd) binds
    _ -> []

hsPatSynDetails :: HsPatSynDetails GhcRn -> [Located Name]
hsPatSynDetails patDetails =
  case patDetails of
    InfixCon name1 name2 -> [reLocN name1, reLocN name2]
    PrefixCon _ fields -> reLocN <$> fields
    RecCon fields -> concatMap
        (\field -> [
            L ((getLocA . rdrNameFieldOcc . recordPatSynField) field)
              (extFieldOcc $ recordPatSynField field),
            reLocN $ recordPatSynPatVar field])
        fields

#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
unwrapName :: LIEWrappedName a -> Located a
unwrapName = reLocN . ieLWrappedName
#elif MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
unwrapName :: LIEWrappedName Name -> Located Name
unwrapName = ieLWrappedName
#else
unwrapName :: Located Name -> Located Name
unwrapName n = n
#endif

#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
ieLocNames :: IE pass -> [Located (IdP pass)]
#else
ieLocNames :: IE Name -> [Located Name]
#endif

#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
ieLocNames (XIE _) = []
ieLocNames (IEVar _ n) =
#else
ieLocNames (IEVar n) =
#endif
  [unwrapName n]
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
ieLocNames (IEThingAbs _ n) =
#else
ieLocNames (IEThingAbs n) =
#endif
  [unwrapName n]
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
ieLocNames (IEThingAll _ n) =
#else
ieLocNames (IEThingAll n) =
#endif
  [unwrapName n]
#if MIN_VERSION_GLASGOW_HASKELL(9,2,1,0)
ieLocNames (IEThingWith _ n _ ns) =
  unwrapName n : (map unwrapName ns)
#elif MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
ieLocNames (IEThingWith _ n _ ns labels) =
  unwrapName n : (map unwrapName ns ++ map (fmap flSelector) labels)
#else
ieLocNames (IEThingWith n _ ns labels) =
  unwrapName n : (map unwrapName ns ++ map (fmap flSelector) labels)
#endif
ieLocNames IEModuleContents {} = []
ieLocNames IEGroup {} = []
ieLocNames IEDoc {} = []
ieLocNames IEDocNamed {} = []

--------------------------------------------------------------------------------
-- Lookups
--------------------------------------------------------------------------------

lookupIdInTypeEnv :: TypeEnv -> Name -> Maybe Id
lookupIdInTypeEnv typeEnv name = do
  let mbTyThing
        | isInternalName name = Nothing
        | isSystemName name = Nothing
        | isWiredInName name = wiredInNameTyThing_maybe name
        | isExternalName name = lookupTypeEnv typeEnv name
        | otherwise = Nothing
  case mbTyThing of
    Just tyThing -> tyThingToId tyThing
    _ -> Nothing

lookupNameModuleAndPackage ::
     UnitState
  -> HCE.PackageId
  -> Name
  -> Either T.Text (HCE.HaskellModuleName, HCE.PackageId)
lookupNameModuleAndPackage state currentPackageId name =
  case nameModule_maybe name of
    Just Module {..} ->
      case lookupUnit state moduleUnit of
        Just unitInfo ->
          let packageId =
                if (T.pack . unitPackageNameString $ unitInfo) ==
                   HCE.name (currentPackageId :: HCE.PackageId)
                  then currentPackageId
                  else HCE.PackageId
                         (T.pack $ unitPackageNameString unitInfo)
                         (unitPackageVersion unitInfo)
           in Right
                ( HCE.HaskellModuleName . T.pack . moduleNameString $ moduleName
                , packageId)
        Nothing ->
          Right
            ( HCE.HaskellModuleName . T.pack . moduleNameString $ moduleName
            , currentPackageId)
    Nothing ->
      Left $ T.concat ["nameModule_maybe ", nameToText name, " is Nothing"]

--------------------------------------------------------------------------------
-- Location info
--------------------------------------------------------------------------------

isHsBoot :: HCE.HaskellModulePath -> Bool
isHsBoot = T.isSuffixOf "-boot" . HCE.getHaskellModulePath

moduleLocationInfo ::
     UnitState
  -> HM.HashMap HCE.HaskellModuleName (HM.HashMap HCE.ComponentId HCE.HaskellModulePath)
  -> HCE.PackageId
  -> HCE.ComponentId
  -> ModuleName
  -> HCE.LocationInfo
moduleLocationInfo unitState moduleNameMap currentPackageId compId moduleName =
  let moduleNameText = T.pack . moduleNameString $ moduleName
      currentPackageLocation =
        HCE.ApproximateLocation
          currentPackageId
          (HCE.HaskellModuleName . T.pack . moduleNameString $ moduleName)
          HCE.Mod
          moduleNameText
          Nothing
          compId
   in case HM.lookup (HCE.HaskellModuleName moduleNameText) moduleNameMap of
        Just modulePathMap
          | Just modulePath <- HM.lookup compId modulePathMap ->
            HCE.ExactLocation
              currentPackageId
              modulePath
              (HCE.HaskellModuleName moduleNameText)
              1
              1
              1
              1
        _ ->
          case lookupModuleWithSuggestions unitState moduleName Nothing of
            LookupFound Module {moduleUnit = unitId} _ ->
              case lookupUnit unitState unitId of
                Just unitInfo ->
                  let packageId =
                        HCE.PackageId
                          (T.pack $ unitPackageNameString unitInfo)
                          (unitPackageVersion unitInfo)
                   in HCE.ApproximateLocation
                        packageId
                        (HCE.HaskellModuleName . T.pack . moduleNameString $
                         moduleName)
                        HCE.Mod
                        moduleNameText
                        Nothing
                        (if packageId == currentPackageId
                           then compId
                           else HCE.ComponentId "lib")
                Nothing -> currentPackageLocation
            _ -> currentPackageLocation

isDefinedInCurrentModule ::
     HCE.SourceCodeTransformation -> HCE.HaskellFilePath -> Bool
isDefinedInCurrentModule transformation file =
  let includedFiles = HM.keys $ HCE.fileIndex transformation
      modPath =
        HCE.getHaskellModulePath $
        HCE.filePath (transformation :: HCE.SourceCodeTransformation)
   in HCE.getHaskellFilePath file == modPath || (file `elem` includedFiles)

nameLocationInfo ::
     UnitState
  -> HCE.PackageId
  -> HCE.ComponentId
  -> HCE.SourceCodeTransformation
  -> HM.HashMap HCE.HaskellFilePath HCE.HaskellModulePath
  -> HM.HashMap HCE.HaskellModulePath HCE.DefinitionSiteMap
  -> Maybe T.Text -- ^ Instance head (when name is a dictionary function)
  -> Maybe SrcSpan -- ^ Only for wired-in names
  -> Name
  -> HCE.LocationInfo
nameLocationInfo unitState currentPackageId compId transformation fileMap defSiteMap mbInstanceHead mbSrcSpan name
  | Just srcSpan <- realSrcSpan name mbSrcSpan =
    let filePath =
          HCE.HaskellFilePath . T.pack . normalise . unpackFS . srcSpanFile $
          srcSpan
        approximateLocation =
          mkApproximateLocation
            unitState
            currentPackageId
            compId
            mbInstanceHead
            name
     in if isDefinedInCurrentModule transformation filePath
          then let eitherStart =
                     HCE.fromOriginalLineNumber
                       transformation
                       (filePath, srcSpanStartLine srcSpan)
                   eitherEnd =
                     HCE.fromOriginalLineNumber
                       transformation
                       (filePath, srcSpanEndLine srcSpan)
                in case (,) eitherStart eitherEnd of
                     (Right startLine,Right endLine) ->
                         let  modulePath = HCE.filePath (transformation :: HCE.SourceCodeTransformation)
                              moduleName =
                                  either
                                    (const $ HCE.HaskellModuleName "")
                                    fst
                                    (lookupNameModuleAndPackage unitState currentPackageId name)
                         in HCE.ExactLocation
                              { packageId = currentPackageId
                              , modulePath = modulePath
                              , moduleName = moduleName
                              , startLine = startLine
                              , endLine = endLine
                              , startColumn = srcSpanStartCol srcSpan
                              , endColumn = srcSpanEndCol srcSpan
                              }
                     _ -> approximateLocation
          else case HM.lookup filePath fileMap of
                 Just haskellModulePath ->
                   case HM.lookup haskellModulePath defSiteMap of
                     Just defSites ->
                       let key = fromMaybe (nameToText name) mbInstanceHead
                        in lookupEntityLocation
                             defSites
                             (mkLocatableEntity name mbInstanceHead)
                             key
                     Nothing -> approximateLocation
                 Nothing -> approximateLocation
  where
    realSrcSpan :: Name -> Maybe SrcSpan -> Maybe RealSrcSpan
    realSrcSpan n mbSpan =
      case nameSrcSpan n of
        RealSrcSpan span _ -> Just span
        _
          | isWiredInName n ->
            case mbSpan of
              Just span ->
                case span of
                  RealSrcSpan s _ -> Just s
                  _ -> Nothing
              _ -> Nothing
        _ -> Nothing
nameLocationInfo unitState currentPackageId compId _transformation _fileMap _defSiteMap mbInstanceHead _mbSrcSpan name =
  mkApproximateLocation unitState currentPackageId compId mbInstanceHead name

mkApproximateLocation ::
     UnitState
  -> HCE.PackageId
  -> HCE.ComponentId
  -> Maybe T.Text
  -> Name
  -> HCE.LocationInfo
mkApproximateLocation unitState currentPackageId compId mbInstanceHead name =
  let haddockAnchor =
        Just . T.pack . makeAnchorId . T.unpack . nameToText $ name
   in case lookupNameModuleAndPackage unitState currentPackageId name of
        Right (moduleName, packageId) ->
          HCE.ApproximateLocation
            { moduleName = moduleName
            , packageId = packageId
            , componentId =
                if packageId == currentPackageId
                  then compId
                  else HCE.ComponentId "lib"
            , entity = mkLocatableEntity name mbInstanceHead
            , haddockAnchorId = haddockAnchor
            , name = fromMaybe (nameToText name) mbInstanceHead
            }
        Left errorMessage -> HCE.UnknownLocation errorMessage

mkLocatableEntity :: Name -> Maybe a -> HCE.LocatableEntity
mkLocatableEntity name mbInstanceHead
  | isJust mbInstanceHead = HCE.Inst
  | otherwise =
    case occNameNameSpace . nameOccName $ name of
      HCE.VarName -> HCE.Val
      HCE.DataName -> HCE.Val
      _ -> HCE.Typ

occNameLocationInfo ::
     DynFlags
  -> HCE.PackageId
  -> HCE.ComponentId
  -> (ModuleName, OccName)
  -> HCE.LocationInfo
occNameLocationInfo flags packageId componentId (modName, occName) =
  HCE.ApproximateLocation
    { packageId = packageId
    , moduleName = HCE.HaskellModuleName $ toText flags modName
    , entity =
        case occNameNameSpace occName of
          HCE.VarName -> HCE.Val
          HCE.DataName -> HCE.Val
          _ -> HCE.Typ
    , name = toText flags occName
    , haddockAnchorId =
        Just . T.pack . makeAnchorId . T.unpack $ toText flags occName
    , componentId = componentId
    }

lookupEntityLocation ::
     HCE.DefinitionSiteMap -> HCE.LocatableEntity -> T.Text -> HCE.LocationInfo
lookupEntityLocation defSiteMap locatableEntity text =
  let errorMessage =
        T.concat
          [ "Cannot find location of "
          , T.pack . show $ locatableEntity
          , " "
          , text
          ]
      defSiteLocation = HCE.location :: HCE.DefinitionSite -> HCE.LocationInfo
      lookupLocation ::
           (Eq a, Hashable a)
        => (HCE.DefinitionSiteMap -> HM.HashMap a HCE.DefinitionSite)
        -> (T.Text -> a)
        -> HCE.LocationInfo
      lookupLocation selector toKey =
        maybe (HCE.UnknownLocation errorMessage) defSiteLocation $
        HM.lookup (toKey text) (selector defSiteMap)
   in case locatableEntity of
        HCE.Val -> lookupLocation HCE.values HCE.OccName
        HCE.Typ -> lookupLocation HCE.types HCE.OccName
        HCE.Inst -> lookupLocation HCE.instances (\t -> t)
        HCE.Mod -> HCE.UnknownLocation errorMessage

nameDocumentation ::
     HCE.SourceCodeTransformation
  -> HM.HashMap HCE.HaskellFilePath HCE.HaskellModulePath
  -> HM.HashMap HCE.HaskellModulePath HCE.DefinitionSiteMap
  -> HCE.DefinitionSiteMap
  -> Name
  -> Maybe T.Text
nameDocumentation transformation fileMap defSiteMap currentModuleDefSiteMap name
  | isExternalName name || isWiredInName name
  , Just file <- srcSpanToFilePath . nameSrcSpan $ name =
    if isDefinedInCurrentModule transformation file
      then lookupNameDocumentation name currentModuleDefSiteMap
      else case HM.lookup file fileMap of
             Just haskellModulePath ->
               case HM.lookup haskellModulePath defSiteMap of
                 Just defSites -> lookupNameDocumentation name defSites
                 Nothing -> Nothing
             Nothing -> Nothing
nameDocumentation _ _ _ _ _ = Nothing

lookupNameDocumentation :: Name -> HCE.DefinitionSiteMap -> Maybe T.Text
lookupNameDocumentation name defSiteMap =
  let key = HCE.OccName $ nameToText name
      lookupDoc ::
           (HCE.DefinitionSiteMap -> HM.HashMap HCE.OccName HCE.DefinitionSite)
        -> Maybe T.Text
      lookupDoc selector =
        maybe Nothing HCE.documentation $
        HM.lookup key (selector (defSiteMap :: HCE.DefinitionSiteMap))
   in case occNameNameSpace . nameOccName $ name of
        HCE.VarName -> lookupDoc HCE.values
        HCE.DataName -> lookupDoc HCE.values
        _ -> lookupDoc HCE.types

srcSpanToFilePath :: SrcSpan -> Maybe HCE.HaskellFilePath
srcSpanToFilePath (RealSrcSpan s _) =
  Just . HCE.HaskellFilePath . T.pack . normalise . unpackFS . srcSpanFile $ s
srcSpanToFilePath (UnhelpfulSpan _) = Nothing

srcSpanToLineAndColNumbers ::
     HCE.SourceCodeTransformation
  -> SrcSpan
  -> Maybe (HCE.HaskellFilePath, (Int, Int), (Int, Int))
-- do we need to do anything with the BufSpan?
srcSpanToLineAndColNumbers transformation (RealSrcSpan s _) =
  let filePath =
        HCE.HaskellFilePath . T.pack . normalise . unpackFS . srcSpanFile $ s
      eitherStart =
        HCE.fromOriginalLineNumber transformation (filePath, srcSpanStartLine s)
      eitherEnd =
        HCE.fromOriginalLineNumber transformation (filePath, srcSpanEndLine s)
   in case (,) eitherStart eitherEnd of
        (Right startLine, Right endLine) ->
          Just
            ( filePath
            , (startLine, srcSpanStartCol s)
            , (endLine, srcSpanEndCol s))
        _ -> Nothing
srcSpanToLineAndColNumbers _ _ = Nothing

--------------------------------------------------------------------------------
-- Type-related functions
--------------------------------------------------------------------------------

tyThingToId :: TyThing -> Maybe Id
tyThingToId tyThing =
  case tyThing of
    AnId id -> Just id
    ATyCon tc -> Just $ mkTyVar (tyConName tc) (tyConKind tc)
    AConLike con ->
      case con of
        RealDataCon dataCon -> Just $ dataConWorkId dataCon
        PatSynCon ps -> Just $ patSynId ps
    ACoAxiom _ -> Nothing

tidyIdentifierType :: TidyEnv -> Id -> (TidyEnv, Id)
tidyIdentifierType tidyEnv identifier =
  let (tidyEnv', typ') = tidyOpenType tidyEnv (varType identifier)
   in (tidyEnv', setVarType identifier typ')

patSynId :: PatSyn -> Id
patSynId patSyn =
  let (univTvs, reqTheta, exTvs, provTheta, argTys, resTy) = patSynSig patSyn
      reqTheta'
        | null reqTheta && not (null provTheta && null exTvs) = [unitTy]
        | otherwise = reqTheta
      --  required => provided => arg_1 -> ... -> arg_n -> res
      patSynTy =
        mkTyCoInvForAllTys univTvs $
        mkVisFunTysMany reqTheta' $
        mkTyCoInvForAllTys exTvs $ mkVisFunTysMany provTheta $ mkVisFunTys argTys resTy
      (name, _, _) = patSynMatcher patSyn
   in mkCoVar name patSynTy

applyWrapper :: HsWrapper -> Type -> Type
applyWrapper wp ty
  | Just ty' <- coreView ty = applyWrapper wp ty'
applyWrapper WpHole t = t
applyWrapper (WpCompose w1 w2) t = applyWrapper w1 . applyWrapper w2 $ t
applyWrapper (WpFun w1 w2 t1 _doc) t =
  mkVisFunTys [t1] (applyWrapper w2 $ piResultTy t
              (applyWrapper w1 $ scaledThing t1))
applyWrapper (WpCast coercion) _t = pSnd $ tcCoercionKind coercion
applyWrapper (WpEvLam v) t = mkVisFunTyMany (evVarPred v) t
applyWrapper (WpEvApp _ev) t = case splitFunTy_maybe t of
  Just (_, _arg,res) -> res
  Nothing -> t
applyWrapper (WpTyLam v) t = mkForAllTy v Required t
applyWrapper (WpTyApp t') t = piResultTy t t'
applyWrapper (WpLet _) t = t
applyWrapper (WpMultCoercion coercion) _ = pSnd $ tcCoercionKind coercion

wrapperTypes :: HsWrapper -> [Type]
wrapperTypes WpHole  = []
wrapperTypes (WpCompose w1 w2) = wrapperTypes w2 ++ wrapperTypes w1
wrapperTypes (WpFun w1 w2 _ _) = wrapperTypes w2 ++ wrapperTypes w1
wrapperTypes (WpCast _)  = []
wrapperTypes (WpEvLam _) = []
wrapperTypes (WpEvApp _) = []
wrapperTypes (WpTyLam _) = []
wrapperTypes (WpTyApp t) = [t]
wrapperTypes (WpLet _) = []
wrapperTypes (WpMultCoercion _) = []

mkType :: DynFlags -> Type -> HCE.Type
mkType flags typ =
  let typeExpanded = expandTypeSynonyms typ
      typeComponents = toTypeComponents flags typ
      typeComponentsExpanded = toTypeComponents flags typeExpanded
   in HCE.Type
        typeComponents
        (if typeComponents /= typeComponentsExpanded
           then Just typeComponentsExpanded
           else Nothing)

#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
typeToText :: DynFlags -> Type -> T.Text
typeToText flags = T.pack . showSDoc flags . pprIfaceType . toIfaceType
#else
typeToText :: DynFlags -> Type -> T.Text
typeToText = toText
#endif

toTypeComponents :: DynFlags -> Type -> [HCE.TypeComponent]
toTypeComponents flags typ =
  let signature =
        typeToText flags $
        updateOccNames (\_unique occName -> ";" ++ drop 2 occName ++ ";") typ
      -- Signature with OccNames and uniques
      signatureWithUniques =
        typeToText flags $
        updateOccNames
          (\unique occName -> ";," ++ occName ++ "," ++ unique ++ ";")
          typ
      -- Dirty but simple way to extract a list of TypeComponent from a type signature.
      -- Assumptions :
      -- 1. Character ';' cannot appear anywhere in a type signature
      -- 2. Character ',' cannot appear in an 'OccName'
      -- 3. length (T.splitOn ";" signature) == length (T.splitOn ";" signatureWithUniques)
      components =
        L.zip (T.splitOn ";" signature) (T.splitOn ";" signatureWithUniques)
   in mapMaybe
        (\(text1, text2) ->
           if T.isPrefixOf "," text2
             then case T.splitOn "," text2 of
                    ["", name, id] ->
                      Just HCE.TyCon {name = name, internalId = HCE.InternalId id}
                    _ -> Just $ HCE.Text text1
             else if T.null text1
                    then Nothing
                    else Just $ HCE.Text text1)
        components

-- | Replaces 'OccName' of each type variable and type constructor in a type.
updateOccNames :: (String -> String -> String) -> Type -> Type
updateOccNames update = everywhere (mkT updateType)
  where
    updateType :: Type -> Type
    updateType (TyVarTy var) = TyVarTy var {varName = updateName (varName var)}
    updateType (TyConApp con args) =
      TyConApp (con {tyConName = updateName (tyConName con)}) args
    updateType other = other
    updateName :: Name -> Name
    updateName oldName =
      let oldOccName = nameOccName oldName
          unique = T.unpack $ nameKey oldName
          newOccName =
            mkOccName
              (occNameSpace oldOccName)
              (update unique (occNameString oldOccName))
       in mkInternalName (nameUnique oldName) newOccName (nameSrcSpan oldName)

-- | This function doesn't look through type synonyms
tyConsOfType :: Type -> [Id]
tyConsOfType =
#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
  nonDetEltsUniqSet . everything unionUniqSets (emptyVarSet `mkQ` tyCon)
#else
  uniqSetToList . everything unionUniqSets (emptyVarSet `mkQ` tyCon)
#endif
  where
    tyCon :: Type -> VarSet
    tyCon (TyConApp tc _) = unitVarSet $ mkTyVar (tyConName tc) (tyConKind tc)
    tyCon _ = emptyUniqSet

tyVarsOfType :: (Data a) => a -> [Id]
#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
tyVarsOfType = nonDetEltsUniqSet . everything unionVarSet (emptyVarSet `mkQ` tyVar)
#else
tyVarsOfType = varSetElems . everything unionVarSet (emptyVarSet `mkQ` tyVar)
#endif
  where
    tyVar :: Type -> VarSet
    tyVar (TyVarTy ty) = unitVarSet ty
    tyVar _ = emptyVarSet

--------------------------------------------------------------------------------
-- Documentation processing
-- Some functions are copied from haddock-api package
--------------------------------------------------------------------------------

-- collectDocs is available in GHC.HsToCore.Docs
-- collectDocs :: [LHsDecl p] -> [(LHsDecl p, [HsDocString])]

-- available in GHC.HsToCore.Docs
-- #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
-- ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn]
-- #else
-- ungroup :: HsGroup Name -> [LHsDecl Name]
-- #endif

-- also available in GHC.HsToCore.Docs
-- mkDecls :: (struct -> [GenLocated l decl]) -> (decl -> hsDecl) -> struct -> [GenLocated l hsDecl]
-- mkDecls :: (a -> [Located b]) -> (b -> c) -> a -> [Located c]
-- mkDecls field con struct = [L loc (con decl) | L loc decl <- field struct]

instance Ord FastString where
  a `compare` b = unpackFS a `compare` unpackFS b

deriving instance () => Ord SrcLoc

instance Ord SrcSpan where
  a `compare` b =
     (srcSpanStart a `compare` srcSpanStart b) `thenCmp`
     (srcSpanEnd   a `compare` srcSpanEnd   b)

sortByLoc :: [GenLocated SrcSpanAnnA a] -> [GenLocated SrcSpanAnnA a]
sortByLoc = L.sortOn getLocA

#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
classDeclDocs :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])]
#else
classDeclDocs :: TyClDecl Name -> [(LHsDecl Name, [HsDocString])]
#endif
classDeclDocs class_ = collectDocs . sortByLoc $ decls
  where
    decls = docs ++ defs ++ sigs ++ ats
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
    docs = mkDecls tcdDocs (DocD NoExtField) class_
    defs = mkDecls (bagToList . tcdMeths) (ValD NoExtField) class_
    sigs = mkDecls tcdSigs (SigD NoExtField) class_
    ats = mkDecls tcdATs ((TyClD NoExtField) . (FamDecl NoExtField)) class_
#else
    docs = mkDecls tcdDocs DocD class_
    defs = mkDecls (bagToList . tcdMeths) ValD class_
    sigs = mkDecls tcdSigs SigD class_
    ats = mkDecls tcdATs (TyClD . FamDecl) class_
#endif


#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
conDeclDocs :: ConDecl GhcRn -> [(Name, [HsDocString], SrcSpan)]
#else
conDeclDocs :: ConDecl Name -> [(Name, [HsDocString], SrcSpan)]
#endif
conDeclDocs conDecl =
  map (\con -> (unLoc con, maybe [] ((: []) . unLoc) $ con_doc conDecl, getLocA con)) .
  getConNames $
  conDecl

-- no longer used by subordinateNamesWithDocs
-- extractRecCon :: ConDecl p -> Maybe (XRec p [LConDeclField p])
-- extractRecCon = undefined

-- no longer used by subordinateNamesWithDocs
-- selectorDocs :: ConDecl GhcRn -> [(Name, [HsDocString], SrcSpan)]
-- selectorDocs con =
--   case extractRecCon con of
--     Just (L _ flds) ->
--       concatMap
--         (\(L _ (ConDeclField _ fieldOccs _ mbDoc)) ->
--            map
--              (\(L span f) ->
--                 (extFieldOcc f, maybe [] ((: []) . unLoc) mbDoc, span))
--              fieldOccs)
--         flds
--     _ -> []

subordinateNamesWithDocs :: [LHsDecl GhcRn] -> [(Name, [HsDocString], SrcSpan)]
subordinateNamesWithDocs =
    concatMap
    (\lhd ->
       case unLoc lhd of
         TyClD _ classDecl ->
           concatMap
             (\(L _ decl, docs) -> map (, docs, getLocA lhd) $ getMainDeclBinder decl) $
           classDeclDocs classDecl
    -- Pattern match is redundant
    --      TyClD _ DataDecl {..} ->
    --        concatMap (\(L _ con) -> conDeclDocs con ++ selectorDocs con) $
    --        dd_cons tcdDataDefn
         InstD _ (DataFamInstD _ DataFamInstDecl {..}) ->
           concatMap (conDeclDocs . unLoc) . dd_cons . feqn_rhs $ dfid_eqn
         _ -> [])


-- no longer needed by ungroup
-- isUserLSig :: forall p. UnXRec p => LSig p -> Bool
-- isUserLSig sig = case unXRec @p sig of
--   TypeSig {} -> True
--   ClassOpSig {} -> True
--   _ -> False

#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
getMainDeclBinder :: HsDecl GhcRn -> [IdP GhcRn]
#else
getMainDeclBinder :: HsDecl name -> [name]
#endif
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
getMainDeclBinder (TyClD _ d) =
#else
getMainDeclBinder (TyClD d) =
#endif
  [tcdName d]
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
getMainDeclBinder (ValD _ d) =
#else
getMainDeclBinder (ValD d) =
#endif
  case collectHsBindBinders CollNoDictBinders d of
    [] -> []
    (name:_) -> [name]
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
getMainDeclBinder (SigD _ d) = sigNameNoLoc d
#else
getMainDeclBinder (SigD d) = sigNameNoLoc d
#endif
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
getMainDeclBinder (ForD _ (ForeignImport _ name _ _)) = [unLoc name]
#else
getMainDeclBinder (ForD (ForeignImport name _ _ _)) = [unLoc name]
#endif
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
getMainDeclBinder (ForD _ ForeignExport {}) = []
#else
getMainDeclBinder (ForD ForeignExport {}) = []
#endif
getMainDeclBinder _ = []

sigNameNoLoc :: forall p. UnXRec p => Sig p -> [IdP p]
sigNameNoLoc (TypeSig _ ns _) = map (unXRec @p) ns
sigNameNoLoc (ClassOpSig _ _ ns _) = map (unXRec @p) ns
sigNameNoLoc (PatSynSig _ ns _) = map (unXRec @p) ns
sigNameNoLoc (SpecSig _ n _ _) = [unXRec @p n]
sigNameNoLoc (InlineSig _ n _) = [unXRec @p n]
sigNameNoLoc (FixSig _ (FixitySig _ ns _)) = map (unXRec @p) ns
sigNameNoLoc _                         = []

clsInstDeclSrcSpan :: ClsInstDecl (GhcPass p) -> SrcSpan
clsInstDeclSrcSpan ClsInstDecl {cid_poly_ty = ty} = getLocA ty
-- Pattern match is redundant
-- #if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
-- clsInstDeclSrcSpan (XClsInstDecl _) = UnhelpfulSpan (UnhelpfulOther "XClsinstdecl")
-- #endif

hsDocsToDocH :: DynFlags -> GlobalRdrEnv -> [HsDocString] -> Doc Name
hsDocsToDocH flags rdrEnv =
  rename flags rdrEnv .
  overIdentifier (parseIdent flags) .
  _doc
#if MIN_VERSION_haddock_library(1,6,0)
    . parseParas Nothing
#else
    . parseParas
#endif
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
    . concatMap unpackHDS
#else
    . concatMap (unpackFS . (\(HsDocString s) -> s))
#endif

parseIdent :: DynFlags -> Namespace -> String -> Maybe RdrName
parseIdent dflags _ str0 =
  let buffer = stringToStringBuffer str0
      realSrcLc = mkRealSrcLoc (mkFastString "<unknown file>") 0 0
      pstate = initParserState (initParserOpts dflags) buffer realSrcLc
  in case unP parseIdentifier pstate of
    POk _ name -> Just (unLoc name)
    _ -> Nothing

type Doc id = DocH (ModuleName, OccName) id

rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> Doc Name
rename dflags gre = rn
  where
    rn :: Doc RdrName -> Doc Name
    rn d = case d of
      DocAppend a b -> DocAppend (rn a) (rn b)
      DocParagraph doc -> DocParagraph (rn doc)
      DocIdentifier x -> do
        -- Generate the choices for the possible kind of thing this
        -- is.
        let choices = dataTcOccs x
        -- Try to look up all the names in the GlobalRdrEnv that match
        -- the names.
        let names = concatMap (\c -> map grePrintableName (lookupGRE_RdrName c gre)) choices

        case names of
          -- We found no names in the env so we start guessing.
          [] ->
            case choices of
              [] -> DocMonospaced (DocString (showPpr dflags x))
              -- There was nothing in the environment so we need to
              -- pick some default from what's available to us. We
              -- diverge here from the old way where we would default
              -- to type constructors as we're much more likely to
              -- actually want anchors to regular definitions than
              -- type constructor names (such as in #253). So now we
              -- only get type constructor links if they are actually
              -- in scope.
              a:_ -> outOfScope dflags a

          -- There is only one name in the environment that matches so
          -- use it.
          [a] -> DocIdentifier a
          -- But when there are multiple names available, default to
          -- type constructors: somewhat awfully GHC returns the
          -- values in the list positionally.
          a:b:_ | isTyConName a -> DocIdentifier a
                | otherwise -> DocIdentifier b

      DocWarning doc -> DocWarning (rn doc)
      DocEmphasis doc -> DocEmphasis (rn doc)
      DocBold doc -> DocBold (rn doc)
      DocMonospaced doc -> DocMonospaced (rn doc)
      DocUnorderedList docs -> DocUnorderedList (map rn docs)
      DocOrderedList docs -> DocOrderedList (map rn docs)
      DocDefList list -> DocDefList [ (rn a, rn b) | (a, b) <- list ]
      DocCodeBlock doc -> DocCodeBlock (rn doc)
      DocIdentifierUnchecked x -> DocIdentifierUnchecked x
      DocModule modLink -> DocModule (rn <$> modLink)
      DocHyperlink hyperLink -> DocHyperlink (rn <$> hyperLink)
      DocPic str -> DocPic str
      DocMathInline str -> DocMathInline str
      DocMathDisplay str -> DocMathDisplay str
      DocAName str -> DocAName str
      DocProperty p -> DocProperty p
      DocExamples e -> DocExamples e
      DocEmpty -> DocEmpty
      DocString str -> DocString str
      DocHeader (Header l t) -> DocHeader $ Header l (rn t)
#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
      DocTable t -> DocTable (rn <$> t)
#endif

-- | Wrap an identifier that's out of scope (i.e. wasn't found in
-- 'GlobalReaderEnv' during 'rename') in an appropriate doc. Currently
-- we simply monospace the identifier in most cases except when the
-- identifier is qualified: if the identifier is qualified then we can
-- still try to guess and generate anchors accross modules but the
-- users shouldn't rely on this doing the right thing. See tickets
-- #253 and #375 on the confusion this causes depending on which
-- default we pick in 'rename'.
outOfScope :: DynFlags -> RdrName -> Doc a
outOfScope dflags x =
  case x of
    Unqual occ -> monospaced occ
    Qual mdl occ -> DocIdentifierUnchecked (mdl, occ)
    Orig _ occ -> monospaced occ
    Exact name -> monospaced name -- Shouldn't happen since x is out of scope
  where
    monospaced :: (Outputable a) => a -> Doc b
    monospaced a = DocMonospaced (DocString (showPpr dflags a))

makeAnchorId :: String -> String
makeAnchorId [] = []
makeAnchorId (f:r) = escape isAlpha f ++ concatMap (escape isLegal) r
  where
    escape p c | p c = [c]
               | otherwise = '-' : show (ord c) ++ "-"
    isLegal ':' = True
    isLegal '_' = True
    isLegal '.' = True
    isLegal c = isAscii c && isAlphaNum c

-- no more HasSrcSpan or SrcSpanLess
-- #if MIN_VERSION_ghc(8,8,0)
-- ghcDL :: GHC.HasSrcSpan a => a -> GHC.Located (GHC.SrcSpanLess a)
-- ghcDL = GHC.dL
-- #else
ghcDL :: GHC.Located a -> GHC.Located a
ghcDL x = x
-- #endif