content: {-# LANGUAGE OverloadedStrings #-}
  
  module Haddock.Backends.Hyperlinker.Utils
    ( hypSrcDir
    , hypSrcModuleFile
    , hypSrcModuleFile'
    , hypSrcModuleUrl
    , hypSrcModuleUrl'
    , hypSrcNameUrl
    , hypSrcLineUrl
    , hypSrcModuleNameUrl
    , 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 = "src"
  
  {-# INLINE hypSrcModuleFile #-}
  hypSrcModuleFile :: Module -> FilePath
  hypSrcModuleFile m = moduleNameString (moduleName m) <.> "html"
  
  hypSrcModuleFile' :: ModuleName -> FilePath
  hypSrcModuleFile' mdl =
    spliceURL'
      (Just mdl)
      Nothing
      Nothing
      moduleFormat
  
  hypSrcModuleUrl :: Module -> String
  hypSrcModuleUrl = hypSrcModuleFile
  
  hypSrcModuleUrl' :: ModuleName -> String
  hypSrcModuleUrl' = hypSrcModuleFile'
  
  {-# INLINE hypSrcNameUrl #-}
  hypSrcNameUrl :: Name -> String
  hypSrcNameUrl = escapeStr . getOccString
  
  {-# INLINE hypSrcLineUrl #-}
  hypSrcLineUrl :: Int -> String
  hypSrcLineUrl line = "line-" ++ show line
  
  {-# INLINE hypSrcModuleNameUrl #-}
  hypSrcModuleNameUrl :: Module -> Name -> String
  hypSrcModuleNameUrl mdl name = hypSrcModuleUrl mdl ++ "#" ++ hypSrcNameUrl name
  
  {-# INLINE hypSrcModuleNameUrl' #-}
  hypSrcModuleNameUrl' :: Module -> Module -> Name -> String
  hypSrcModuleNameUrl' this_mdl mdl name
    | this_mdl == mdl = "#" ++ hypSrcNameUrl name
    | otherwise = hypSrcModuleUrl mdl ++ "#" ++ hypSrcNameUrl name
  
  {-# INLINE hypSrcModuleLineUrl #-}
  hypSrcModuleLineUrl :: Module -> Int -> String
  hypSrcModuleLineUrl mdl line = hypSrcModuleUrl mdl ++ "#" ++ hypSrcLineUrl line
  
  hypSrcModuleUrlFormat :: String
  hypSrcModuleUrlFormat = hypSrcDir </> moduleFormat
  
  hypSrcModuleNameUrlFormat :: String
  hypSrcModuleNameUrlFormat = hypSrcModuleUrlFormat ++ "#" ++ nameFormat
  
  hypSrcModuleLineUrlFormat :: String
  hypSrcModuleLineUrlFormat = hypSrcModuleUrlFormat ++ "#" ++ lineFormat
  
  hypSrcModuleUrlToNameFormat :: String -> String
  hypSrcModuleUrlToNameFormat url = url ++ "#" ++ nameFormat
  
  hypSrcModuleUrlToLineFormat :: String -> String
  hypSrcModuleUrlToLineFormat url = url ++ "#" ++ lineFormat
  
  hypSrcPkgUrlToModuleFormat :: String -> String
  hypSrcPkgUrlToModuleFormat url = url </> moduleFormat
  
  moduleFormat :: String
  moduleFormat = "%{MODULE}.html"
  
  nameFormat :: String
  nameFormat = "%{NAME}"
  
  lineFormat :: String
  lineFormat = "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 flattened ast = fmap (printed A.!) 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 = fmap (Outputable.renderWithContext sDocContext . pprIfaceType) unflattened
  
      -- The recursion in 'unflattened' is crucial - it's what gives us sharing
      -- between the IfaceType's produced
      unflattened :: A.Array TypeIndex IfaceType
      unflattened = fmap (\flatTy -> go (fmap (unflattened A.!) flatTy)) flattened
  
      -- Unfold an 'HieType' whose subterms have already been unfolded
      go :: HieType IfaceType -> IfaceType
      go (HTyVarTy n) = IfaceTyVar (mkIfLclName $ getOccFS n)
      go (HAppTy a b) = IfaceAppTy a (hieToIfaceArgs b)
      go (HLitTy l) = IfaceLitTy l
      go (HForAllTy ((n, k), af) t) =
        let b = (mkIfLclName $ getOccFS n, k)
         in IfaceForAllTy (Bndr (IfaceTvBndr b) af) t
      go (HFunTy w a b) = IfaceFunTy (visArg TypeLike) w a b -- t1 -> t2
      go (HQualTy con b) = IfaceFunTy (invisArg TypeLike) many_ty con b -- c => t
      go (HCastTy a) = a
      go HCoercionTy = IfaceTyVar $ mkIfLclName "<coercion type>"
      go (HTyConApp a xs) = IfaceTyConApp a (hieToIfaceArgs xs)
  
      -- This isn't fully faithful - we can't produce the 'Inferred' case
      hieToIfaceArgs :: HieArgs IfaceType -> IfaceAppArgs
      hieToIfaceArgs (HieArgs args) = go' args
        where
          go' [] = IA_Nil
          go' ((True, x) : xs) = IA_Arg x Required $ go' xs
          go' ((False, x) : xs) = IA_Arg x Specified $ go' xs
  