path: root/haddock-api/src/Haddock/InterfaceFile.hs

{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Haddock.InterfaceFile
-- Copyright   :  (c) David Waern       2006-2009,
--                    Mateusz Kowalczyk 2013
-- License     :  BSD-like
--
-- Maintainer  :  haddock@projects.haskell.org
-- Stability   :  experimental
-- Portability :  portable
--
-- Reading and writing the .haddock interface file
-----------------------------------------------------------------------------
module Haddock.InterfaceFile (
  InterfaceFile(..), PackageInfo(..), ifUnitId, ifModule,
  PackageInterfaces(..), mkPackageInterfaces, ppPackageInfo,
  readInterfaceFile, writeInterfaceFile,
  freshNameCache,
  binaryInterfaceVersion, binaryInterfaceVersionCompatibility
) where


import Haddock.Types

import Data.IORef
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Version
import Data.Word
import Text.ParserCombinators.ReadP (readP_to_S)

import GHC.Iface.Binary (getWithUserData, putSymbolTable)
import GHC.Unit.State
import GHC.Utils.Binary
import GHC.Data.FastMutInt
import GHC.Data.FastString
import GHC hiding (NoLink)
import GHC.Types.Name.Cache
import GHC.Types.Unique.FM
import GHC.Types.Unique

import Haddock.Options (Visibility (..))

data InterfaceFile = InterfaceFile {
  ifLinkEnv         :: LinkEnv,
  -- | Package meta data.  Currently it only consist of a package name, which
  -- is not read from the interface file, but inferred from its name.
  --
  -- issue #
  ifPackageInfo     :: PackageInfo,
  ifInstalledIfaces :: [InstalledInterface]
}

data PackageInfo = PackageInfo {
  piPackageName    :: PackageName,
  piPackageVersion :: Data.Version.Version
}

ppPackageInfo :: PackageInfo -> String
ppPackageInfo (PackageInfo name version) | version == makeVersion []
                                         = unpackFS (unPackageName name)
ppPackageInfo (PackageInfo name version) = unpackFS (unPackageName name) ++ "-" ++ showVersion version

data PackageInterfaces = PackageInterfaces {
  piPackageInfo         :: PackageInfo,
  piVisibility          :: Visibility,
  piInstalledInterfaces :: [InstalledInterface]
}

mkPackageInterfaces :: Visibility -> InterfaceFile -> PackageInterfaces
mkPackageInterfaces piVisibility
                    InterfaceFile { ifPackageInfo
                                  , ifInstalledIfaces
                                  } = 
  PackageInterfaces { piPackageInfo = ifPackageInfo
                    , piVisibility
                    , piInstalledInterfaces = ifInstalledIfaces
                    }

ifModule :: InterfaceFile -> Module
ifModule if_ =
  case ifInstalledIfaces if_ of
    [] -> error "empty InterfaceFile"
    iface:_ -> instMod iface

ifUnitId :: InterfaceFile -> Unit
ifUnitId if_ =
  case ifInstalledIfaces if_ of
    [] -> error "empty InterfaceFile"
    iface:_ -> moduleUnit $ instMod iface


binaryInterfaceMagic :: Word32
binaryInterfaceMagic = 0xD0Cface

-- Note [The DocModule story]
--
-- Breaking changes to the DocH type result in Haddock being unable to read
-- existing interfaces. This is especially painful for interfaces shipped
-- with GHC distributions since there is no easy way to regenerate them!
--
-- PR #1315 introduced a breaking change to the DocModule constructor. To
-- maintain backward compatibility we
--
-- Parse the old DocModule constructor format (tag 5) and parse the contained
-- string into a proper ModLink structure. When writing interfaces we exclusively
-- use the new DocModule format (tag 24)

-- IMPORTANT: Since datatypes in the GHC API might change between major
-- versions, and because we store GHC datatypes in our interface files, we need
-- to make sure we version our interface files accordingly.
--
-- If you change the interface file format or adapt Haddock to work with a new
-- major version of GHC (so that the format changes indirectly) *you* need to
-- follow these steps:
--
-- (1) increase `binaryInterfaceVersion`
--
-- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion]
--
binaryInterfaceVersion :: Word16
#if MIN_VERSION_ghc(9,4,0) && !MIN_VERSION_ghc(9,5,0)
binaryInterfaceVersion = 41

binaryInterfaceVersionCompatibility :: [Word16]
binaryInterfaceVersionCompatibility = [binaryInterfaceVersion]
#else
#error Unsupported GHC version
#endif


initBinMemSize :: Int
initBinMemSize = 1024*1024


writeInterfaceFile :: FilePath -> InterfaceFile -> IO ()
writeInterfaceFile filename iface = do
  bh0 <- openBinMem initBinMemSize
  put_ bh0 binaryInterfaceMagic
  put_ bh0 binaryInterfaceVersion

  -- remember where the dictionary pointer will go
  dict_p_p <- tellBin bh0
  put_ bh0 dict_p_p

  -- remember where the symbol table pointer will go
  symtab_p_p <- tellBin bh0
  put_ bh0 symtab_p_p

  -- Make some intial state
  symtab_next <- newFastMutInt 0
  symtab_map <- newIORef emptyUFM
  let bin_symtab = BinSymbolTable {
                      bin_symtab_next = symtab_next,
                      bin_symtab_map  = symtab_map }
  dict_next_ref <- newFastMutInt 0
  dict_map_ref <- newIORef emptyUFM
  let bin_dict = BinDictionary {
                      bin_dict_next = dict_next_ref,
                      bin_dict_map  = dict_map_ref }

  -- put the main thing
  let bh = setUserData bh0 $ newWriteState (putName bin_symtab)
                                           (putName bin_symtab)
                                           (putFastString bin_dict)
  putInterfaceFile_ bh iface

  -- write the symtab pointer at the front of the file
  symtab_p <- tellBin bh
  putAt bh symtab_p_p symtab_p
  seekBin bh symtab_p

  -- write the symbol table itself
  symtab_next' <- readFastMutInt symtab_next
  symtab_map'  <- readIORef symtab_map
  putSymbolTable bh symtab_next' symtab_map'

  -- write the dictionary pointer at the fornt of the file
  dict_p <- tellBin bh
  putAt bh dict_p_p dict_p
  seekBin bh dict_p

  -- write the dictionary itself
  dict_next <- readFastMutInt dict_next_ref
  dict_map  <- readIORef dict_map_ref
  putDictionary bh dict_next dict_map

  -- and send the result to the file
  writeBinMem bh filename
  return ()


freshNameCache :: IO NameCache
freshNameCache = initNameCache 'a' -- ??
                               []

-- | Read a Haddock (@.haddock@) interface file. Return either an
-- 'InterfaceFile' or an error message.
--
-- This function can be called in two ways.  Within a GHC session it will
-- update the use and update the session's name cache.  Outside a GHC session
-- a new empty name cache is used.
readInterfaceFile :: NameCache
                  -> FilePath
                  -> Bool  -- ^ Disable version check. Can cause runtime crash.
                  -> IO (Either String InterfaceFile)
readInterfaceFile name_cache filename bypass_checks = do
  bh <- readBinMem filename

  magic   <- get bh
  if magic /= binaryInterfaceMagic
    then return . Left $ "Magic number mismatch: couldn't load interface file: " ++ filename
    else do
      version <- get bh
      if not bypass_checks && (version `notElem` binaryInterfaceVersionCompatibility)
        then return . Left $ "Interface file is of wrong version: " ++ filename
        else Right <$> getWithUserData name_cache bh

-------------------------------------------------------------------------------
-- * Symbol table
-------------------------------------------------------------------------------


putName :: BinSymbolTable -> BinHandle -> Name -> IO ()
putName BinSymbolTable{
            bin_symtab_map = symtab_map_ref,
            bin_symtab_next = symtab_next }    bh name
  = do
    symtab_map <- readIORef symtab_map_ref
    case lookupUFM symtab_map name of
      Just (off,_) -> put_ bh (fromIntegral off :: Word32)
      Nothing -> do
         off <- readFastMutInt symtab_next
         writeFastMutInt symtab_next (off+1)
         writeIORef symtab_map_ref
             $! addToUFM symtab_map name (off,name)
         put_ bh (fromIntegral off :: Word32)


data BinSymbolTable = BinSymbolTable {
        bin_symtab_next :: !FastMutInt, -- The next index to use
        bin_symtab_map  :: !(IORef (UniqFM Name (Int,Name)))
                                -- indexed by Name
  }


putFastString :: BinDictionary -> BinHandle -> FastString -> IO ()
putFastString BinDictionary { bin_dict_next = j_r,
                              bin_dict_map  = out_r}  bh f
  = do
    out <- readIORef out_r
    let !unique = getUnique f
    case lookupUFM_Directly out unique of
        Just (j, _)  -> put_ bh (fromIntegral j :: Word32)
        Nothing -> do
           j <- readFastMutInt j_r
           put_ bh (fromIntegral j :: Word32)
           writeFastMutInt j_r (j + 1)
           writeIORef out_r $! addToUFM_Directly out unique (j, f)


data BinDictionary = BinDictionary {
        bin_dict_next :: !FastMutInt, -- The next index to use
        bin_dict_map  :: !(IORef (UniqFM FastString (Int,FastString)))
                                -- indexed by FastString
  }

-------------------------------------------------------------------------------
-- * GhcBinary instances
-------------------------------------------------------------------------------


instance (Ord k, Binary k, Binary v) => Binary (Map k v) where
  put_ bh m = put_ bh (Map.toList m)
  get bh = fmap (Map.fromList) (get bh)

instance Binary PackageInfo where
  put_ bh PackageInfo { piPackageName, piPackageVersion } = do
    put_ bh (unPackageName piPackageName)
    put_ bh (showVersion piPackageVersion)
  get bh = do
    name <- PackageName <$> get bh
    versionString <- get bh
    let version = case readP_to_S parseVersion versionString of
          [] -> makeVersion []
          vs -> fst (last vs)
    return $ PackageInfo name version

instance Binary InterfaceFile where
  put_ bh (InterfaceFile env info ifaces) = do
    put_ bh env
    put_ bh info
    put_ bh ifaces

  get bh = do
    env    <- get bh
    info   <- get bh
    ifaces <- get bh
    return (InterfaceFile env info ifaces)


putInterfaceFile_ :: BinHandle -> InterfaceFile -> IO ()
putInterfaceFile_ bh (InterfaceFile env info ifaces) = do
  put_ bh env
  put_ bh info
  put_ bh ifaces

instance Binary InstalledInterface where
  put_ bh (InstalledInterface modu is_sig info docMap argMap
           exps visExps opts fixMap) = do
    put_ bh modu
    put_ bh is_sig
    put_ bh info
    lazyPut bh (docMap, argMap)
    put_ bh exps
    put_ bh visExps
    put_ bh opts
    put_ bh fixMap

  get bh = do
    modu    <- get bh
    is_sig  <- get bh
    info    <- get bh
    ~(docMap, argMap) <- lazyGet bh
    exps    <- get bh
    visExps <- get bh
    opts    <- get bh
    fixMap  <- get bh
    return (InstalledInterface modu is_sig info docMap argMap
            exps visExps opts fixMap)


instance Binary DocOption where
    put_ bh OptHide = do
            putByte bh 0
    put_ bh OptPrune = do
            putByte bh 1
    put_ bh OptIgnoreExports = do
            putByte bh 2
    put_ bh OptNotHome = do
            putByte bh 3
    put_ bh OptShowExtensions = do
            putByte bh 4
    get bh = do
            h <- getByte bh
            case h of
              0 -> do
                    return OptHide
              1 -> do
                    return OptPrune
              2 -> do
                    return OptIgnoreExports
              3 -> do
                    return OptNotHome
              4 -> do
                    return OptShowExtensions
              _ -> fail "invalid binary data found"


instance Binary Example where
    put_ bh (Example expression result) = do
        put_ bh expression
        put_ bh result
    get bh = do
        expression <- get bh
        result <- get bh
        return (Example expression result)

instance Binary a => Binary (Hyperlink a) where
    put_ bh (Hyperlink url label) = do
        put_ bh url
        put_ bh label
    get bh = do
        url <- get bh
        label <- get bh
        return (Hyperlink url label)

instance Binary a => Binary (ModLink a) where
    put_ bh (ModLink m label) = do
        put_ bh m
        put_ bh label
    get bh = do
        m <- get bh
        label <- get bh
        return (ModLink m label)

instance Binary Picture where
    put_ bh (Picture uri title) = do
        put_ bh uri
        put_ bh title
    get bh = do
        uri <- get bh
        title <- get bh
        return (Picture uri title)

instance Binary a => Binary (Header a) where
    put_ bh (Header l t) = do
        put_ bh l
        put_ bh t
    get bh = do
        l <- get bh
        t <- get bh
        return (Header l t)

instance Binary a => Binary (Table a) where
    put_ bh (Table h b) = do
        put_ bh h
        put_ bh b
    get bh = do
        h <- get bh
        b <- get bh
        return (Table h b)

instance Binary a => Binary (TableRow a) where
    put_ bh (TableRow cs) = put_ bh cs
    get bh = do
        cs <- get bh
        return (TableRow cs)

instance Binary a => Binary (TableCell a) where
    put_ bh (TableCell i j c) = do
        put_ bh i
        put_ bh j
        put_ bh c
    get bh = do
        i <- get bh
        j <- get bh
        c <- get bh
        return (TableCell i j c)

instance Binary Meta where
    put_ bh (Meta v p) = do
        put_ bh v
        put_ bh p
    get bh = do
        v <- get bh
        p <- get bh
        return (Meta v p)

instance (Binary mod, Binary id) => Binary (MetaDoc mod id) where
  put_ bh MetaDoc { _meta = m, _doc = d } = do
    put_ bh m
    put_ bh d
  get bh = do
    m <- get bh
    d <- get bh
    return $ MetaDoc { _meta = m, _doc = d }

instance (Binary mod, Binary id) => Binary (DocH mod id) where
    put_ bh DocEmpty = do
            putByte bh 0
    put_ bh (DocAppend aa ab) = do
            putByte bh 1
            put_ bh aa
            put_ bh ab
    put_ bh (DocString ac) = do
            putByte bh 2
            put_ bh ac
    put_ bh (DocParagraph ad) = do
            putByte bh 3
            put_ bh ad
    put_ bh (DocIdentifier ae) = do
            putByte bh 4
            put_ bh ae
    put_ bh (DocEmphasis ag) = do
            putByte bh 6
            put_ bh ag
    put_ bh (DocMonospaced ah) = do
            putByte bh 7
            put_ bh ah
    put_ bh (DocUnorderedList ai) = do
            putByte bh 8
            put_ bh ai
    put_ bh (DocOrderedList aj) = do
            putByte bh 9
            put_ bh aj
    put_ bh (DocDefList ak) = do
            putByte bh 10
            put_ bh ak
    put_ bh (DocCodeBlock al) = do
            putByte bh 11
            put_ bh al
    put_ bh (DocHyperlink am) = do
            putByte bh 12
            put_ bh am
    put_ bh (DocPic x) = do
            putByte bh 13
            put_ bh x
    put_ bh (DocAName an) = do
            putByte bh 14
            put_ bh an
    put_ bh (DocExamples ao) = do
            putByte bh 15
            put_ bh ao
    put_ bh (DocIdentifierUnchecked x) = do
            putByte bh 16
            put_ bh x
    put_ bh (DocWarning ag) = do
            putByte bh 17
            put_ bh ag
    put_ bh (DocProperty x) = do
            putByte bh 18
            put_ bh x
    put_ bh (DocBold x) = do
            putByte bh 19
            put_ bh x
    put_ bh (DocHeader aa) = do
            putByte bh 20
            put_ bh aa
    put_ bh (DocMathInline x) = do
            putByte bh 21
            put_ bh x
    put_ bh (DocMathDisplay x) = do
            putByte bh 22
            put_ bh x
    put_ bh (DocTable x) = do
            putByte bh 23
            put_ bh x
    -- See note [The DocModule story]
    put_ bh (DocModule af) = do
            putByte bh 24
            put_ bh af

    get bh = do
            h <- getByte bh
            case h of
              0 -> do
                    return DocEmpty
              1 -> do
                    aa <- get bh
                    ab <- get bh
                    return (DocAppend aa ab)
              2 -> do
                    ac <- get bh
                    return (DocString ac)
              3 -> do
                    ad <- get bh
                    return (DocParagraph ad)
              4 -> do
                    ae <- get bh
                    return (DocIdentifier ae)
              -- See note [The DocModule story]
              5 -> do
                    af <- get bh
                    return $ DocModule ModLink
                      { modLinkName  = af
                      , modLinkLabel = Nothing
                      }
              6 -> do
                    ag <- get bh
                    return (DocEmphasis ag)
              7 -> do
                    ah <- get bh
                    return (DocMonospaced ah)
              8 -> do
                    ai <- get bh
                    return (DocUnorderedList ai)
              9 -> do
                    aj <- get bh
                    return (DocOrderedList aj)
              10 -> do
                    ak <- get bh
                    return (DocDefList ak)
              11 -> do
                    al <- get bh
                    return (DocCodeBlock al)
              12 -> do
                    am <- get bh
                    return (DocHyperlink am)
              13 -> do
                    x <- get bh
                    return (DocPic x)
              14 -> do
                    an <- get bh
                    return (DocAName an)
              15 -> do
                    ao <- get bh
                    return (DocExamples ao)
              16 -> do
                    x <- get bh
                    return (DocIdentifierUnchecked x)
              17 -> do
                    ag <- get bh
                    return (DocWarning ag)
              18 -> do
                    x <- get bh
                    return (DocProperty x)
              19 -> do
                    x <- get bh
                    return (DocBold x)
              20 -> do
                    aa <- get bh
                    return (DocHeader aa)
              21 -> do
                    x <- get bh
                    return (DocMathInline x)
              22 -> do
                    x <- get bh
                    return (DocMathDisplay x)
              23 -> do
                    x <- get bh
                    return (DocTable x)
              -- See note [The DocModule story]
              24 -> do
                    af <- get bh
                    return (DocModule af)
              _ -> error "invalid binary data found in the interface file"


instance Binary name => Binary (HaddockModInfo name) where
  put_ bh hmi = do
    put_ bh (hmi_description hmi)
    put_ bh (hmi_copyright   hmi)
    put_ bh (hmi_license     hmi)
    put_ bh (hmi_maintainer  hmi)
    put_ bh (hmi_stability   hmi)
    put_ bh (hmi_portability hmi)
    put_ bh (hmi_safety      hmi)
    put_ bh (fromEnum <$> hmi_language hmi)
    put_ bh (map fromEnum $ hmi_extensions hmi)

  get bh = do
    descr <- get bh
    copyr <- get bh
    licen <- get bh
    maint <- get bh
    stabi <- get bh
    porta <- get bh
    safet <- get bh
    langu <- fmap toEnum <$> get bh
    exten <- map toEnum <$> get bh
    return (HaddockModInfo descr copyr licen maint stabi porta safet langu exten)

instance Binary DocName where
  put_ bh (Documented name modu) = do
    putByte bh 0
    put_ bh name
    put_ bh modu
  put_ bh (Undocumented name) = do
    putByte bh 1
    put_ bh name

  get bh = do
    h <- getByte bh
    case h of
      0 -> do
        name <- get bh
        modu <- get bh
        return (Documented name modu)
      1 -> do
        name <- get bh
        return (Undocumented name)
      _ -> error "get DocName: Bad h"

instance Binary n => Binary (Wrap n) where
  put_ bh (Unadorned n) = do
    putByte bh 0
    put_ bh n
  put_ bh (Parenthesized n) = do
    putByte bh 1
    put_ bh n
  put_ bh (Backticked n) = do
    putByte bh 2
    put_ bh n

  get bh = do
    h <- getByte bh
    case h of
      0 -> do
        name <- get bh
        return (Unadorned name)
      1 -> do
        name <- get bh
        return (Parenthesized name)
      2 -> do
        name <- get bh
        return (Backticked name)
      _ -> error "get Wrap: Bad h"