path: root/src/HaskellCodeExplorer/GhcUtils.hs

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# 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 qualified Data.ByteString               as BS
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           Data.Hashable                  ( Hashable
                                                , hash
                                                )
import qualified Data.List                     as L
import           Data.Maybe                     ( fromMaybe
                                                , isJust
                                                , mapMaybe
                                                )
import qualified Data.Text                     as T
import           Documentation.Haddock.Parser   ( overIdentifier
                                                , parseParas
                                                )
import           Documentation.Haddock.Types    ( DocH(..)
                                                , Header(..)
                                                , Namespace
                                                , _doc
                                                )
import           GHC                            ( ClsInstDecl(..)
                                                , CollectFlag(..)
                                                , ConDecl(..)
                                                , ConDeclField(..)
                                                , DataFamInstDecl(..)
                                                , DynFlags
                                                , FamEqn(..)
                                                , FixitySig(..)
                                                , ForeignDecl(..)
                                                , GhcPass
                                                , HsConDetails(..)
                                                , HsDataDefn(..)
                                                , HsDecl(..)
                                                , HsDocString
                                                , HsGroup(..)
                                                , HsPatSynDetails
                                                , HsValBindsLR(..)
                                                , IE(..)
                                                , Id
                                                , InstDecl(..)
                                                , LHsBindLR
                                                , LHsDecl
                                                , LIEWrappedName
                                                , Located
                                                , NHsValBindsLR(..)
                                                , Name
                                                , NewOrData(..)
                                                , NoExtField(..)
                                                , RealSrcSpan(..)
                                                , Sig(..)
                                                , SrcSpan(..)
                                                , TyClDecl(..)
                                                , TyThing(..)
                                                , UnXRec
                                                , collectHsBindBinders
                                                , extFieldOcc
                                                , getConNames
                                                , getLocA
                                                , getRecConArgs_maybe
                                                , idType
                                                , ieLWrappedName
                                                , isDataFamilyDecl
                                                , isExternalName
                                                , isGoodSrcSpan
                                                , isLocalId
                                                , nameSrcSpan
                                                , rdrNameFieldOcc
                                                , reLocN
                                                , recordPatSynField
                                                , recordPatSynPatVar
                                                , sortLocatedA
                                                , srcSpanEndCol
                                                , srcSpanEndLine
                                                , srcSpanFile
                                                , srcSpanStartCol
                                                , srcSpanStartLine
                                                , tcdName
                                                , tfid_eqn
                                                , tyConKind
                                                , tyFamInstDeclName
                                                , unXRec
                                                , unpackHDS
                                                )
import           GHC.Core.ConLike               ( ConLike(..) )
import           GHC.Core.DataCon               ( dataConWorkId )
import           GHC.Data.Bag                   ( bagToList )
import           GHC.Data.FastString            ( mkFastString
                                                , unpackFS
                                                )
import           GHC.HsToCore.Docs              ( collectDocs
                                                , mkDecls
                                                , ungroup
                                                )

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

--------------------------------------------------------------------------------
-- 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 "
        XTyClDecl _ -> ""

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
  JoinId _                         -> Just HCE.JoinId
mbIdDetails _ = Nothing

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

hsGroupVals :: HsGroup GhcRn -> [LHsBindLR 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

unwrapName :: LIEWrappedName a -> Located a
unwrapName = reLocN . ieLWrappedName

ieLocNames :: IE pass -> [Located (IdP pass)]

ieLocNames (XIE _               ) = []
ieLocNames (IEVar      _ n      ) = [unwrapName n]
ieLocNames (IEThingAbs _ n      ) = [unwrapName n]
ieLocNames (IEThingAll _ n      ) = [unwrapName n]
ieLocNames (IEThingWith _ n _ ns) = unwrapName n : (map unwrapName ns)
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@HCE.PackageId { name = pkgIdName } name
  = case nameModule_maybe name of
    Just Module {..} -> case lookupUnit state moduleUnit of
      Just unitInfo ->
        let packageId =
              if (T.pack . unitPackageNameString $ unitInfo) == pkgIdName
                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@HCE.SourceCodeTransformation {..} file
  = let includedFiles = HM.keys $ HCE.fileIndex transformation
        modPath       = HCE.getHaskellModulePath filePath
    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@HCE.SourceCodeTransformation { filePath = modulePath } 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 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.DefinitionSite {..} = location
    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.DefinitionSiteMap { values } -> values) HCE.OccName
      HCE.Typ ->
        lookupLocation (\HCE.DefinitionSiteMap { types } -> types) HCE.OccName
      HCE.Inst -> lookupLocation
        (\HCE.DefinitionSiteMap { instances } -> 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.DefinitionSiteMap { values } -> values)
        HCE.DataName -> lookupDoc (\HCE.DefinitionSiteMap { values } -> values)
        _            -> lookupDoc (\HCE.DefinitionSiteMap { types } -> 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
        )

typeToText :: DynFlags -> Type -> T.Text
typeToText flags = T.pack . showSDoc flags . pprIfaceType . toIfaceType

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 = nonDetEltsUniqSet
  . everything unionUniqSets (emptyVarSet `mkQ` tyCon)
 where
  tyCon :: Type -> VarSet
  tyCon (TyConApp tc _) = unitVarSet $ mkTyVar (tyConName tc) (tyConKind tc)
  tyCon _               = emptyUniqSet

tyVarsOfType :: (Data a) => a -> [Id]
tyVarsOfType = nonDetEltsUniqSet
  . everything unionVarSet (emptyVarSet `mkQ` tyVar)
 where
  tyVar :: Type -> VarSet
  tyVar (TyVarTy ty) = unitVarSet ty
  tyVar _            = emptyVarSet

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

-- available in GHC.HsToCore.Docs
-- collectDocs :: [LHsDecl p] -> [(LHsDecl p, [HsDocString])]
-- ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn]
-- Take a field of declarations from a data structure and create HsDecls using the given constructor
-- mkDecls :: (struct -> [GenLocated l decl]) -> (decl -> hsDecl) -> struct -> [GenLocated l hsDecl]

classDeclDocs :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])]
classDeclDocs class_ = collectDocs . sortLocatedA $ decls
 where
  decls = docs ++ defs ++ sigs ++ ats
  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_


conDeclDocs :: ConDecl GhcRn -> [(Name, [HsDocString], SrcSpan)]
conDeclDocs conDecl =
  map
      (\con ->
        (unLoc con, maybe [] ((: []) . unLoc) $ con_doc conDecl, getLocA con)
      )
    . getConNames
    $ conDecl

selectorDocs :: ConDecl GhcRn -> [(Name, [HsDocString], SrcSpan)]
selectorDocs con = case getRecConArgs_maybe 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@ClassDecl{} ->
      concatMap
          (\(L _ decl, docs) ->
            map (, docs, getLocA lhd) $ getMainDeclBinder decl
          )
        $ classDeclDocs classDecl
    TyClD _ DataDecl {..} ->
      concatMap (\(L _ con) -> conDeclDocs con ++ selectorDocs con)
        $ dd_cons tcdDataDefn
    InstD _ (DataFamInstD _ DataFamInstDecl {..}) ->
      concatMap (conDeclDocs . unLoc) . dd_cons . feqn_rhs $ dfid_eqn
    _ -> []
  )


getMainDeclBinder :: HsDecl GhcRn -> [IdP GhcRn]
getMainDeclBinder (TyClD _ d) = [tcdName d]
getMainDeclBinder (ValD  _ d) = case collectHsBindBinders CollNoDictBinders d of
  []         -> []
  (name : _) -> [name]
getMainDeclBinder (SigD _ d) = sigNameNoLoc d
getMainDeclBinder (ForD _ (ForeignImport _ name _ _)) = [unLoc name]
getMainDeclBinder (ForD _ ForeignExport{}) = []
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

hsDocsToDocH :: DynFlags -> GlobalRdrEnv -> [HsDocString] -> Doc Name
hsDocsToDocH flags rdrEnv =
  rename flags rdrEnv
    . overIdentifier (parseIdent flags)
    . _doc
    . parseParas Nothing
    . concatMap unpackHDS

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)
    DocTable  t                      -> DocTable (rn <$> t)

-- | 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

ghcDL :: GHC.Located a -> GHC.Located a
ghcDL x = x