--
-- Haddock - A Haskell Documentation Tool
--
-- (c) Simon Marlow 2003
--


module Haddock.InterfaceFile (
  InterfaceFile(..),
  readInterfaceFile,
  writeInterfaceFile
) where


import Haddock.Types
import Haddock.Exception

import Data.List
import Data.Word
import Data.Array
import Data.IORef
import qualified Data.Map as Map
import System.IO
import Control.Monad

import GHC hiding (NoLink)
import SrcLoc   (noSrcSpan) -- tmp, GHC now exports this
import Binary
import Name
import UniqSupply
import UniqFM
import IfaceEnv
import Module
import Packages
import HscTypes
import FastMutInt
import InstEnv
import HsDoc


data InterfaceFile = InterfaceFile {
  ifLinkEnv         :: LinkEnv,
  ifInstalledIfaces :: [InstalledInterface]
} 


binaryInterfaceMagic = 0xD0Cface :: Word32
binaryInterfaceVersion = 0 :: Word16


initBinMemSize = (1024*1024) :: Int


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

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

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

  -- Make some intial state
  ud <- newWriteState

  -- put the main thing
  bh <- return $ setUserData bh ud
  put_ bh iface

  -- write the symtab pointer at the fornt 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 (ud_symtab_next ud)
  symtab_map  <- readIORef (ud_symtab_map ud)
  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 (ud_dict_next ud)
  dict_map  <- readIORef (ud_dict_map ud)
  putDictionary bh dict_next dict_map

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

-- | Read a Haddock (@.haddock@) interface file. Return either an 
-- 'InterfaceFile' or an error message. If given a GHC 'Session', the function
-- registers all read names in the name cache of the session.
-- The aim is to be compatible with interface files produced by any Haddock 
-- of version 2.0.0.0 or greater.
readInterfaceFile :: Maybe Session -> FilePath -> IO (Either String InterfaceFile)
readInterfaceFile mbSession filename = do
  bh <- readBinMem filename

  magic   <- get bh
  version <- get bh

  case () of
    _ | magic /= binaryInterfaceMagic -> return . Left $
      "Magic number mismatch: couldn't load interface file: " ++ filename
      | version /= binaryInterfaceVersion -> return . Left $
      "Interface file is of wrong version: " ++ filename
      | otherwise -> do

      -- get the dictionary
      dict_p <- get bh
      data_p <- tellBin bh		
      seekBin bh dict_p
      dict <- getDictionary bh
      seekBin bh data_p		

      -- initialise the user-data field of bh
      ud <- newReadState dict
      bh <- return (setUserData bh ud)

      -- get the name cache from ghc if we have a ghc session,
      -- otherwise create a new one
      (theNC, mbRef) <- case mbSession of
        Just session -> do
          ref <- withSession session (return . hsc_NC)
          nc <- readIORef ref
          return (nc, Just ref)
        Nothing -> do
          -- construct an empty name cache
          u  <- mkSplitUniqSupply 'a' -- ??
          return (initNameCache u [], Nothing)

      -- get the symbol table
      symtab_p <- get bh
      data_p   <- tellBin bh
      seekBin bh symtab_p
      (nc', symtab) <- getSymbolTable bh theNC
      seekBin bh data_p

      -- write back the new name cache if we have a ghc session
      case mbRef of
        Just ref -> writeIORef ref nc'
        Nothing  -> return ()

      -- set the symbol table
      let ud = getUserData bh
      bh <- return $! setUserData bh ud{ud_symtab = symtab}

      -- load the actual data
      iface <- get bh
      return (Right iface)


-------------------------------------------------------------------------------
-- Symbol table
-------------------------------------------------------------------------------

putSymbolTable :: BinHandle -> Int -> UniqFM (Int,Name) -> IO ()
putSymbolTable bh next_off symtab = do
  put_ bh next_off
  let names = elems (array (0,next_off-1) (eltsUFM symtab))
  mapM_ (\n -> serialiseName bh n symtab) names

getSymbolTable :: BinHandle -> NameCache -> IO (NameCache, Array Int Name)
getSymbolTable bh namecache = do
  sz <- get bh
  od_names <- sequence (replicate sz (get bh))
  let 
        arr = listArray (0,sz-1) names
        (namecache', names) =    
                mapAccumR (fromOnDiskName arr) namecache od_names
  --
  return (namecache', arr)

type OnDiskName = (PackageId, ModuleName, OccName)

fromOnDiskName
   :: Array Int Name
   -> NameCache
   -> OnDiskName
   -> (NameCache, Name)
fromOnDiskName arr nc (pid, mod_name, occ) =
  let 
        mod   = mkModule pid mod_name
        cache = nsNames nc
  in
  case lookupOrigNameCache cache  mod occ of
     Just name -> (nc, name)
     Nothing   -> 
        let 
                us        = nsUniqs nc
                uniq      = uniqFromSupply us
                name      = mkExternalName uniq mod occ noSrcSpan
                new_cache = extendNameCache cache mod occ name
        in        
        case splitUniqSupply us of { (us',_) -> 
        ( nc{ nsUniqs = us', nsNames = new_cache }, name )
        }

serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO ()
serialiseName bh name symtab = do
  let mod = nameModule name
  put_ bh (modulePackageId mod, moduleName mod, nameOccName name)


-------------------------------------------------------------------------------
-- GhcBinary instances
-------------------------------------------------------------------------------


instance Binary InterfaceFile where
  put_ bh (InterfaceFile env ifaces) = do
    put_ bh (Map.toList env)
    put_ bh ifaces

  get bh = do
    env    <- get bh
    ifaces <- get bh
    return (InterfaceFile (Map.fromList env) ifaces)


instance Binary InstalledInterface where
  put_ bh (InstalledInterface mod info docMap exps visExps) = do
    put_ bh mod
    put_ bh info
    put_ bh (Map.toList docMap)
    put_ bh exps
    put_ bh visExps

  get bh = do
    mod     <- get bh
    info    <- get bh
    docMap  <- get bh
    exps    <- get bh
    visExps <- get bh
    return (InstalledInterface mod info (Map.fromList docMap) exps visExps)


{-* Generated by DrIFT : Look, but Don't Touch. *-}
instance Binary DocName where
    put_ bh (Link aa) = do
            putByte bh 0
            put_ bh aa
    put_ bh (NoLink ab) = do
            putByte bh 1
            put_ bh ab
    get bh = do
            h <- getByte bh
            case h of
              0 -> do
                    aa <- get bh
                    return (Link aa)
              1 -> do
                    ab <- get bh
                    return (NoLink ab)
              _ -> fail "invalid binary data found"


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
    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
              _ -> fail "invalid binary data found"


{-* Generated by DrIFT : Look, but Don't Touch. *-}
instance (Binary id) => Binary (HsDoc 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 (DocModule af) = do
            putByte bh 5
            put_ bh af
    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 (DocURL am) = do
            putByte bh 12
            put_ bh am
    put_ bh (DocAName an) = do
            putByte bh 13
            put_ bh an
    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)
              5 -> do
                    af <- get bh
                    return (DocModule af)
              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 (DocURL am)
              13 -> do
                    an <- get bh
                    return (DocAName an)
              _ -> fail "invalid binary data found"


instance Binary name => Binary (HaddockModInfo name) where
  put_ bh hmi = do
    put_ bh (hmi_description hmi)
    put_ bh (hmi_portability hmi)
    put_ bh (hmi_stability   hmi)
    put_ bh (hmi_maintainer  hmi)
  
  get bh = do
    descr <- get bh
    porta <- get bh
    stabi <- get bh
    maint <- get bh
    return (HaddockModInfo descr porta stabi maint)