    {-# LANGUAGE OverloadedStrings #-}

    module Haddock.Backends.Hyperlinker.Utils
      ( hypSrcDir
      , hypSrcModuleFile
      , hypSrcModuleFile'
      , hypSrcModuleUrl
      , hypSrcModuleUrl'
      , hypSrcNameUrl
      , hypSrcLineUrl
      , hypSrcModuleNameUrl
      , hypSrcModuleLineUrl
      , hypSrcModuleUrlFormat
      , hypSrcModuleNameUrlFormat
      , hypSrcModuleLineUrlFormat
      , hypSrcModuleUrlToNameFormat
      , hypSrcModuleUrlToLineFormat
      , hypSrcPkgUrlToModuleFormat
      , spliceURL
      , spliceURL'

        -- * HIE file processing
      , PrintedType
      , recoverFullIfaceTypes
      ) where

    import qualified Data.Array as A
    import GHC
    import GHC.Iface.Ext.Types (HieAST (..), HieArgs (..), HieType (..), HieTypeFlat, TypeIndex)
    import GHC.Iface.Type
    import GHC.Types.Name (getOccFS, getOccString)
    import GHC.Types.Var (TypeOrConstraint (..), VarBndr (..), invisArg, visArg)
    import GHC.Utils.Outputable (SDocContext)
    import qualified GHC.Utils.Outputable as Outputable
    import System.FilePath.Posix ((<.>), (</>))

    import Haddock.Backends.Xhtml.Utils
    import Haddock.Utils

    {-# INLINE hypSrcDir #-}
    hypSrcDir :: FilePath
    hypSrcDir :: [Char]
    hypSrcDir = [Char]
    "src"

    {-# INLINE hypSrcModuleFile #-}
    hypSrcModuleFile :: Module -> FilePath
    hypSrcModuleFile :: Module -> [Char]
    hypSrcModuleFile Module
    m = ModuleName -> [Char]
    moduleNameString (Module -> ModuleName
    forall unit. GenModule unit -> ModuleName
    moduleName Module
    m) [Char] -> [Char] -> [Char]
    <.> [Char]
    "html"

    hypSrcModuleFile' :: ModuleName -> FilePath
    hypSrcModuleFile' :: ModuleName -> [Char]
    hypSrcModuleFile' ModuleName
    mdl =
      Maybe ModuleName -> Maybe Name -> Maybe SrcSpan -> [Char] -> [Char]
    spliceURL'
        (ModuleName -> Maybe ModuleName
    forall a. a -> Maybe a
    Just ModuleName
    mdl)
        Maybe Name
    forall a. Maybe a
    Nothing
        Maybe SrcSpan
    forall a. Maybe a
    Nothing
        [Char]
    moduleFormat

    hypSrcModuleUrl :: Module -> String
    hypSrcModuleUrl :: Module -> [Char]
    hypSrcModuleUrl = Module -> [Char]
    hypSrcModuleFile

    hypSrcModuleUrl' :: ModuleName -> String
    hypSrcModuleUrl' :: ModuleName -> [Char]
    hypSrcModuleUrl' = ModuleName -> [Char]
    hypSrcModuleFile'

    {-# INLINE hypSrcNameUrl #-}
    hypSrcNameUrl :: Name -> String
    hypSrcNameUrl :: Name -> [Char]
    hypSrcNameUrl = [Char] -> [Char]
    escapeStr ([Char] -> [Char]) -> (Name -> [Char]) -> Name -> [Char]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Name -> [Char]
    forall a. NamedThing a => a -> [Char]
    getOccString

    {-# INLINE hypSrcLineUrl #-}
    hypSrcLineUrl :: Int -> String
    hypSrcLineUrl :: TypeIndex -> [Char]
    hypSrcLineUrl TypeIndex
    line = [Char]
    "line-" [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ TypeIndex -> [Char]
    forall a. Show a => a -> [Char]
    show TypeIndex
    line

    {-# INLINE hypSrcModuleNameUrl #-}
    hypSrcModuleNameUrl :: Module -> Name -> String
    hypSrcModuleNameUrl :: Module -> Name -> [Char]
    hypSrcModuleNameUrl Module
    mdl Name
    name = Module -> [Char]
    hypSrcModuleUrl Module
    mdl [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ [Char]
    "#" [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ Name -> [Char]
    hypSrcNameUrl Name
    name

    {-# INLINE hypSrcModuleLineUrl #-}
    hypSrcModuleLineUrl :: Module -> Int -> String
    hypSrcModuleLineUrl :: Module -> TypeIndex -> [Char]
    hypSrcModuleLineUrl Module
    mdl TypeIndex
    line = Module -> [Char]
    hypSrcModuleUrl Module
    mdl [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ [Char]
    "#" [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ TypeIndex -> [Char]
    hypSrcLineUrl TypeIndex
    line

    hypSrcModuleUrlFormat :: String
    hypSrcModuleUrlFormat :: [Char]
    hypSrcModuleUrlFormat = [Char]
    hypSrcDir [Char] -> [Char] -> [Char]
    </> [Char]
    moduleFormat

    hypSrcModuleNameUrlFormat :: String
    hypSrcModuleNameUrlFormat :: [Char]
    hypSrcModuleNameUrlFormat = [Char]
    hypSrcModuleUrlFormat [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ [Char]
    "#" [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ [Char]
    nameFormat

    hypSrcModuleLineUrlFormat :: String
    hypSrcModuleLineUrlFormat :: [Char]
    hypSrcModuleLineUrlFormat = [Char]
    hypSrcModuleUrlFormat [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ [Char]
    "#" [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ [Char]
    lineFormat

    hypSrcModuleUrlToNameFormat :: String -> String
    hypSrcModuleUrlToNameFormat :: [Char] -> [Char]
    hypSrcModuleUrlToNameFormat [Char]
    url = [Char]
    url [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ [Char]
    "#" [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ [Char]
    nameFormat

    hypSrcModuleUrlToLineFormat :: String -> String
    hypSrcModuleUrlToLineFormat :: [Char] -> [Char]
    hypSrcModuleUrlToLineFormat [Char]
    url = [Char]
    url [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ [Char]
    "#" [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ [Char]
    lineFormat

    hypSrcPkgUrlToModuleFormat :: String -> String
    hypSrcPkgUrlToModuleFormat :: [Char] -> [Char]
    hypSrcPkgUrlToModuleFormat [Char]
    url = [Char]
    url [Char] -> [Char] -> [Char]
    </> [Char]
    moduleFormat

    moduleFormat :: String
    moduleFormat :: [Char]
    moduleFormat = [Char]
    "%{MODULE}.html"

    nameFormat :: String
    nameFormat :: [Char]
    nameFormat = [Char]
    "%{NAME}"

    lineFormat :: String
    lineFormat :: [Char]
    lineFormat = [Char]
    "line-%{LINE}"

    -- * HIE file processing

    -- This belongs in GHC.Iface.Ext.Utils...

    -- | Pretty-printed type, ready to be turned into HTML by @xhtml@
    type PrintedType = String

    -- | Expand the flattened HIE AST into one where the types printed out and
    -- ready for end-users to look at.
    --
    -- Using just primitives found in GHC's HIE utilities, we could write this as
    -- follows:
    --
    -- > 'recoverFullIfaceTypes' dflags hieTypes hieAst
    -- >     = 'fmap' (\ti -> 'showSDoc' df .
    -- >                      'pprIfaceType' $
    -- >                      'recoverFullType' ti hieTypes)
    -- >       hieAst
    --
    -- However, this is very inefficient (both in time and space) because the
    -- multiple calls to 'recoverFullType' don't share intermediate results. This
    -- function fixes that.
    recoverFullIfaceTypes
      :: SDocContext
      -> A.Array TypeIndex HieTypeFlat
      -- ^ flat types
      -> HieAST TypeIndex
      -- ^ flattened AST
      -> HieAST PrintedType
      -- ^ full AST
    recoverFullIfaceTypes :: SDocContext
    -> Array TypeIndex HieTypeFlat -> HieAST TypeIndex -> HieAST [Char]
    recoverFullIfaceTypes SDocContext
    sDocContext Array TypeIndex HieTypeFlat
    flattened HieAST TypeIndex
    ast = (TypeIndex -> [Char]) -> HieAST TypeIndex -> HieAST [Char]
    forall a b. (a -> b) -> HieAST a -> HieAST b
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    fmap (Array TypeIndex [Char]
    printed Array TypeIndex [Char] -> TypeIndex -> [Char]
    forall i e. Ix i => Array i e -> i -> e
    A.!) HieAST TypeIndex
    ast
      where
        -- Splitting this out into its own array is also important: we don't want
        -- to pretty print the same type many times
        printed :: A.Array TypeIndex PrintedType
        printed :: Array TypeIndex [Char]
    printed = (IfaceType -> [Char])
    -> Array TypeIndex IfaceType -> Array TypeIndex [Char]
    forall a b. (a -> b) -> Array TypeIndex a -> Array TypeIndex b
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    fmap (SDocContext -> SDoc -> [Char]
    Outputable.renderWithContext SDocContext
    sDocContext (SDoc -> [Char]) -> (IfaceType -> SDoc) -> IfaceType -> [Char]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . IfaceType -> SDoc
    pprIfaceType) Array TypeIndex IfaceType
    unflattened

        -- The recursion in 'unflattened' is crucial - it's what gives us sharing
        -- between the IfaceType's produced
        unflattened :: A.Array TypeIndex IfaceType
        unflattened :: Array TypeIndex IfaceType
    unflattened = (HieTypeFlat -> IfaceType)
    -> Array TypeIndex HieTypeFlat -> Array TypeIndex IfaceType
    forall a b. (a -> b) -> Array TypeIndex a -> Array TypeIndex b
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    fmap (\HieTypeFlat
    flatTy -> HieType IfaceType -> IfaceType
    go ((TypeIndex -> IfaceType) -> HieTypeFlat -> HieType IfaceType
    forall a b. (a -> b) -> HieType a -> HieType b
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    fmap (Array TypeIndex IfaceType
    unflattened Array TypeIndex IfaceType -> TypeIndex -> IfaceType
    forall i e. Ix i => Array i e -> i -> e
    A.!) HieTypeFlat
    flatTy)) Array TypeIndex HieTypeFlat
    flattened

        -- Unfold an 'HieType' whose subterms have already been unfolded
        go :: HieType IfaceType -> IfaceType
        go :: HieType IfaceType -> IfaceType
    go (HTyVarTy Name
    n) = IfLclName -> IfaceType
    IfaceTyVar (FastString -> IfLclName
    mkIfLclName (FastString -> IfLclName) -> FastString -> IfLclName
    forall a b. (a -> b) -> a -> b
    $ Name -> FastString
    forall a. NamedThing a => a -> FastString
    getOccFS Name
    n)
        go (HAppTy IfaceType
    a HieArgs IfaceType
    b) = IfaceType -> IfaceAppArgs -> IfaceType
    IfaceAppTy IfaceType
    a (HieArgs IfaceType -> IfaceAppArgs
    hieToIfaceArgs HieArgs IfaceType
    b)
        go (HLitTy IfaceTyLit
    l) = IfaceTyLit -> IfaceType
    IfaceLitTy IfaceTyLit
    l
        go (HForAllTy ((Name
    n, IfaceType
    k), ForAllTyFlag
    af) IfaceType
    t) =
          let b :: (IfLclName, IfaceType)
    b = (FastString -> IfLclName
    mkIfLclName (FastString -> IfLclName) -> FastString -> IfLclName
    forall a b. (a -> b) -> a -> b
    $ Name -> FastString
    forall a. NamedThing a => a -> FastString
    getOccFS Name
    n, IfaceType
    k)
           in IfaceForAllBndr -> IfaceType -> IfaceType
    IfaceForAllTy (IfaceBndr -> ForAllTyFlag -> IfaceForAllBndr
    forall var argf. var -> argf -> VarBndr var argf
    Bndr ((IfLclName, IfaceType) -> IfaceBndr
    IfaceTvBndr (IfLclName, IfaceType)
    b) ForAllTyFlag
    af) IfaceType
    t
        go (HFunTy IfaceType
    w IfaceType
    a IfaceType
    b) = FunTyFlag -> IfaceType -> IfaceType -> IfaceType -> IfaceType
    IfaceFunTy (TypeOrConstraint -> FunTyFlag
    visArg TypeOrConstraint
    TypeLike) IfaceType
    w IfaceType
    a IfaceType
    b -- t1 -> t2
        go (HQualTy IfaceType
    con IfaceType
    b) = FunTyFlag -> IfaceType -> IfaceType -> IfaceType -> IfaceType
    IfaceFunTy (TypeOrConstraint -> FunTyFlag
    invisArg TypeOrConstraint
    TypeLike) IfaceType
    many_ty IfaceType
    con IfaceType
    b -- c => t
        go (HCastTy IfaceType
    a) = IfaceType
    a
        go HieType IfaceType
    HCoercionTy = IfLclName -> IfaceType
    IfaceTyVar (IfLclName -> IfaceType) -> IfLclName -> IfaceType
    forall a b. (a -> b) -> a -> b
    $ FastString -> IfLclName
    mkIfLclName FastString
    "<coercion type>"
        go (HTyConApp IfaceTyCon
    a HieArgs IfaceType
    xs) = IfaceTyCon -> IfaceAppArgs -> IfaceType
    IfaceTyConApp IfaceTyCon
    a (HieArgs IfaceType -> IfaceAppArgs
    hieToIfaceArgs HieArgs IfaceType
    xs)

        -- This isn't fully faithful - we can't produce the 'Inferred' case
        hieToIfaceArgs :: HieArgs IfaceType -> IfaceAppArgs
        hieToIfaceArgs :: HieArgs IfaceType -> IfaceAppArgs
    hieToIfaceArgs (HieArgs [(Bool, IfaceType)]
    args) = [(Bool, IfaceType)] -> IfaceAppArgs
    go' [(Bool, IfaceType)]
    args
          where
            go' :: [(Bool, IfaceType)] -> IfaceAppArgs
    go' [] = IfaceAppArgs
    IA_Nil
            go' ((Bool
    True, IfaceType
    x) : [(Bool, IfaceType)]
    xs) = IfaceType -> ForAllTyFlag -> IfaceAppArgs -> IfaceAppArgs
    IA_Arg IfaceType
    x ForAllTyFlag
    Required (IfaceAppArgs -> IfaceAppArgs) -> IfaceAppArgs -> IfaceAppArgs
    forall a b. (a -> b) -> a -> b
    $ [(Bool, IfaceType)] -> IfaceAppArgs
    go' [(Bool, IfaceType)]
    xs
            go' ((Bool
    False, IfaceType
    x) : [(Bool, IfaceType)]
    xs) = IfaceType -> ForAllTyFlag -> IfaceAppArgs -> IfaceAppArgs
    IA_Arg IfaceType
    x ForAllTyFlag
    Specified (IfaceAppArgs -> IfaceAppArgs) -> IfaceAppArgs -> IfaceAppArgs
    forall a b. (a -> b) -> a -> b
    $ [(Bool, IfaceType)] -> IfaceAppArgs
    go' [(Bool, IfaceType)]
    xs