{-# LANGUAGE OverloadedStrings #-}
module Haddock.Backends.Hyperlinker.Utils
    ( hypSrcDir, hypSrcModuleFile, hypSrcModuleFile'
    , hypSrcModuleUrl, hypSrcModuleUrl'
    , hypSrcNameUrl
    , hypSrcLineUrl
    , hypSrcModuleNameUrl, hypSrcModuleLineUrl
    , hypSrcModuleUrlFormat
    , hypSrcModuleNameUrlFormat, hypSrcModuleLineUrlFormat
    , spliceURL, spliceURL'
    , hypSrcModuleUrlToNameFormat
    , hypSrcPkgUrlToModuleFormat

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

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

import GHC
import GHC.Iface.Ext.Types ( HieAST(..), HieType(..), HieArgs(..), TypeIndex, HieTypeFlat )
import GHC.Iface.Type
import GHC.Types.Name      ( getOccFS, getOccString )
import GHC.Driver.Ppr      ( showSDoc )
import GHC.Types.Var       ( VarBndr(..), visArg, invisArg, TypeOrConstraint(..) )

import System.FilePath.Posix ((</>), (<.>))

import qualified Data.Array as A


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

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
  :: DynFlags
  -> A.Array TypeIndex HieTypeFlat -- ^ flat types
  -> HieAST TypeIndex              -- ^ flattened AST
  -> HieAST PrintedType       -- ^ full AST
recoverFullIfaceTypes :: DynFlags
-> Array TypeIndex HieTypeFlat -> HieAST TypeIndex -> HieAST [Char]
recoverFullIfaceTypes DynFlags
df Array TypeIndex HieTypeFlat
flattened HieAST TypeIndex
ast = (TypeIndex -> [Char]) -> HieAST TypeIndex -> HieAST [Char]
forall a b. (a -> b) -> HieAST a -> HieAST b
forall (f :: * -> *) 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 :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (DynFlags -> SDoc -> [Char]
showSDoc DynFlags
df (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 :: * -> *) 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 :: * -> *) 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 (Name -> IfLclName
forall a. NamedThing a => a -> IfLclName
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 = (Name -> IfLclName
forall a. NamedThing a => a -> IfLclName
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
"<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