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

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

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

import GHC
import HieTypes     ( HieAST(..), HieType(..), HieArgs(..), TypeIndex, HieTypeFlat )
import IfaceType
import Name         ( getOccFS, getOccString )
import Outputable   ( showSDoc )
import Var          ( VarBndr(..) )

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

import qualified Data.Array as A


{-# INLINE hypSrcDir #-}
hypSrcDir :: FilePath
hypSrcDir :: FilePath
hypSrcDir = FilePath
"src"

{-# INLINE hypSrcModuleFile #-}
hypSrcModuleFile :: Module -> FilePath
hypSrcModuleFile :: Module -> FilePath
hypSrcModuleFile Module
m = ModuleName -> FilePath
moduleNameString (Module -> ModuleName
moduleName Module
m) FilePath -> FilePath -> FilePath
<.> FilePath
"html"

hypSrcModuleFile' :: ModuleName -> FilePath
hypSrcModuleFile' :: ModuleName -> FilePath
hypSrcModuleFile' ModuleName
mdl = Maybe FilePath
-> Maybe ModuleName
-> Maybe Name
-> Maybe SrcSpan
-> FilePath
-> FilePath
spliceURL'
    Maybe FilePath
forall a. Maybe a
Nothing (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 FilePath
moduleFormat

hypSrcModuleUrl :: Module -> String
hypSrcModuleUrl :: Module -> FilePath
hypSrcModuleUrl = Module -> FilePath
hypSrcModuleFile

hypSrcModuleUrl' :: ModuleName -> String
hypSrcModuleUrl' :: ModuleName -> FilePath
hypSrcModuleUrl' = ModuleName -> FilePath
hypSrcModuleFile'

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

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

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

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

hypSrcModuleUrlFormat :: String
hypSrcModuleUrlFormat :: FilePath
hypSrcModuleUrlFormat = FilePath
hypSrcDir FilePath -> FilePath -> FilePath
</> FilePath
moduleFormat

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

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

moduleFormat :: String
moduleFormat :: FilePath
moduleFormat = FilePath
"%{MODULE}.html"

nameFormat :: String
nameFormat :: FilePath
nameFormat = FilePath
"%{NAME}"

lineFormat :: String
lineFormat :: FilePath
lineFormat = FilePath
"line-%{LINE}"


-- * HIE file procesddsing

-- This belongs in GHC's HieUtils...

-- | 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 Int HieTypeFlat -> HieAST Int -> HieAST FilePath
recoverFullIfaceTypes DynFlags
df Array Int HieTypeFlat
flattened HieAST Int
ast = (Int -> FilePath) -> HieAST Int -> HieAST FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Array Int FilePath
printed Array Int FilePath -> Int -> FilePath
forall i e. Ix i => Array i e -> i -> e
A.!) HieAST Int
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 Int FilePath
printed = (IfaceType -> FilePath)
-> Array Int IfaceType -> Array Int FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (DynFlags -> SDoc -> FilePath
showSDoc DynFlags
df (SDoc -> FilePath) -> (IfaceType -> SDoc) -> IfaceType -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IfaceType -> SDoc
pprIfaceType) Array Int 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 Int IfaceType
unflattened = (HieTypeFlat -> IfaceType)
-> Array Int HieTypeFlat -> Array Int IfaceType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\HieTypeFlat
flatTy -> HieType IfaceType -> IfaceType
go ((Int -> IfaceType) -> HieTypeFlat -> HieType IfaceType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Array Int IfaceType
unflattened Array Int IfaceType -> Int -> IfaceType
forall i e. Ix i => Array i e -> i -> e
A.!) HieTypeFlat
flatTy)) Array Int 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),ArgFlag
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 -> ArgFlag -> IfaceForAllBndr
forall var argf. var -> argf -> VarBndr var argf
Bndr ((IfLclName, IfaceType) -> IfaceBndr
IfaceTvBndr (IfLclName, IfaceType)
b) ArgFlag
af) IfaceType
t
    go (HFunTy IfaceType
a IfaceType
b) = AnonArgFlag -> IfaceType -> IfaceType -> IfaceType
IfaceFunTy AnonArgFlag
VisArg IfaceType
a IfaceType
b
    go (HQualTy IfaceType
con IfaceType
b) = AnonArgFlag -> IfaceType -> IfaceType -> IfaceType
IfaceFunTy AnonArgFlag
InvisArg IfaceType
con IfaceType
b
    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 -> ArgFlag -> IfaceAppArgs -> IfaceAppArgs
IA_Arg IfaceType
x ArgFlag
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 -> ArgFlag -> IfaceAppArgs -> IfaceAppArgs
IA_Arg IfaceType
x ArgFlag
Specified (IfaceAppArgs -> IfaceAppArgs) -> IfaceAppArgs -> IfaceAppArgs
forall a b. (a -> b) -> a -> b
$ [(Bool, IfaceType)] -> IfaceAppArgs
go' [(Bool, IfaceType)]
xs