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