{-# LANGUAGE OverloadedStrings,
             TupleSections,
             DeriveGeneric

  #-}
{- |
  GHCJS linker, collects dependencies from
    the object files (.js_o, js_p_o), which contain linkable
    units with dependency information
-}

module Gen2.Linker where

import           DynFlags
import           Encoding
import           Panic
import           Module ( InstalledUnitId
                        , stringToInstalledUnitId
                        , installedUnitIdString
                        , toInstalledUnitId
                        , mkModuleName, wiredInUnitIds
                        , moduleNameString
                        , primUnitId )
import           PackageConfig ({-sourcePackageId, -}unitId)
-- import           Outputable (ppr, showSDoc)
import qualified Packages

import           Control.Concurrent.MVar
import           Control.DeepSeq
import           Control.Exception        (evaluate)
import           Control.Monad
import           Control.Parallel.Strategies
import Prelude

import           Data.Array
import qualified Data.Aeson               as Aeson
import           Data.Binary
import qualified Data.ByteString          as B
import qualified Data.ByteString.Lazy     as BL
import           Data.Function            (on)
import qualified Data.HashMap.Strict      as HM
import           Data.Int
import           Data.IntSet              (IntSet)
import qualified Data.IntSet              as IS
import           Data.List
  (partition, nub, foldl', intercalate, group, sort, groupBy, isPrefixOf)
import           Data.Map.Strict          (Map)
import qualified Data.Map.Strict          as M
import           Data.Maybe
-- import           Data.Monoid
import           Data.Set                 (Set)
import qualified Data.Set                 as S
import           Data.Text                (Text)
import qualified Data.Text                as T
import qualified Data.Text.Encoding       as TE
import qualified Data.Text.IO             as T
import qualified Data.Text.Lazy           as TL
import qualified Data.Text.Lazy.IO        as TL
import qualified Data.Text.Lazy.Encoding  as TLE
import qualified Data.Vector              as V

import           Data.Yaml                (FromJSON(..), Value(..))
import qualified Data.Yaml                as Yaml

import qualified Distribution.Simple.Utils as Cabal

import           GHC.Generics

import           System.FilePath
  (splitPath, (<.>), (</>), dropExtension, takeFileName)

import System.IO

import           System.Directory
  ( createDirectoryIfMissing, canonicalizePath
  , doesFileExist, getCurrentDirectory, copyFile)
import           Text.PrettyPrint.Leijen.Text (displayT, renderPretty)

import           Compiler.Compat
import           Compiler.Info
import           Compiler.JMacro
import           Compiler.Settings
import           Compiler.Utils

import qualified Gen2.Archive             as Ar
import           Gen2.Base
import           Gen2.ClosureInfo         hiding (Fun)
import qualified Gen2.Compactor           as Compactor
import           Gen2.Object
import           Gen2.Printer             (pretty)
import           Gen2.Rts                 (rtsText, rtsDeclsText)
import           Gen2.RtsTypes
import           Gen2.Shim

import qualified Data.ByteString.Char8 as CS8 (pack, unpack)
import qualified Data.ByteString.Base16.Lazy as B16
import qualified Data.ByteString.Base16 as BS16


import qualified Compiler.Platform as Platform

type LinkableUnit = (Package, Module, Int) -- ^ module and the index of the block in the object file
type Module       = Text

-- number of bytes linked per module
type LinkerStats  = Map (Package, Module) Int64

-- | result of a link pass
data LinkResult = LinkResult
  { linkOut         :: BL.ByteString -- ^ compiled Haskell code
  , linkOutStats    :: LinkerStats   -- ^ statistics about generated code
  , linkOutMetaSize :: Int64         -- ^ size of packed metadata in generated code
  , linkForeignRefs :: [ForeignRef]  -- ^ foreign code references in compiled haskell code
  , linkLibRTS      :: [FilePath]    -- ^ library code to load with the RTS
  , linkLibA        :: [FilePath]    -- ^ library code to load after RTS
  , linkLibAArch    :: [FilePath]    -- ^ library code to load from archives after RTS
  , linkBase        :: Base          -- ^ base metadata to use if we want to link incrementally against this result
  } deriving (Generic)

instance Binary LinkResult


-- | link and write result to disk (jsexe directory)
link :: DynFlags
     -> GhcjsEnv
     -> GhcjsSettings
     -> FilePath                   -- ^ output file/directory
     -> [FilePath]                 -- ^ include path for home package
     -> [InstalledUnitId]          -- ^ packages to link
     -> [LinkedObj]                -- ^ the object files we're linking
     -> [FilePath]                 -- ^ extra js files to include
     -> (Fun -> Bool)              -- ^ functions from the objects to use as roots (include all their deps)
     -> Set Fun                    -- ^ extra symbols to link in
     -> IO ()
link dflags env settings out include pkgs objFiles jsFiles isRootFun extraStaticDeps
  | gsNoJSExecutables settings = return ()
  | otherwise = do
      LinkResult lo lstats lmetasize lfrefs llW lla llarch lbase <-
        link' dflags env settings out include pkgs objFiles jsFiles
              isRootFun extraStaticDeps
      let genBase = isJust (gsGenBase settings)
          jsExt | genBase   = "base.js"
                | otherwise = "js"
      createDirectoryIfMissing False out
      BL.writeFile (out </> "out" <.> jsExt) lo
      unless (gsOnlyOut settings) $ do
        let frefsFile   = if genBase then "out.base.frefs" else "out.frefs"
            jsonFrefs  = Aeson.encode lfrefs
        BL.writeFile (out </> frefsFile <.> "json") jsonFrefs
        BL.writeFile (out </> frefsFile <.> "js")
                     ("h$checkForeignRefs(" <> jsonFrefs <> ");")
        unless (gsNoStats settings) $ do
          let statsFile = if genBase then "out.base.stats" else "out.stats"
          TL.writeFile (out </> statsFile) (linkerStats lmetasize lstats)
        unless (gsNoRts settings) $ do
          withRts <- mapM (tryReadShimFile dflags) llW
          BL.writeFile (out </> "rts.js")
            (TLE.encodeUtf8 rtsDeclsText <>
             BL.fromChunks withRts <>
             TLE.encodeUtf8 (rtsText' dflags $ dfCgSettings dflags))
        lla'    <- mapM (tryReadShimFile dflags) lla
        llarch' <- mapM (readShimsArchive dflags) llarch
        BL.writeFile (out </> "lib" <.> jsExt)
                     (BL.fromChunks $ llarch' ++ lla')
        if genBase
          then generateBase out lbase
          else when (not (gsOnlyOut settings) &&
                     not (gsNoRts settings) &&
                     not (usingBase settings)) $ do
                 combineFiles dflags out
                 writeHtml dflags out
                 writeRunMain dflags out
                 writeRunner settings dflags out
                 writeWebAppManifest dflags out
                 writeExterns out

-- | link in memory
link' :: DynFlags
      -> GhcjsEnv
      -> GhcjsSettings
      -> String                     -- ^ target (for progress message)
      -> [FilePath]                 -- ^ include path for home package
      -> [InstalledUnitId]          -- ^ packages to link
      -> [LinkedObj]                -- ^ the object files we're linking
      -> [FilePath]                 -- ^ extra js files to include
      -> (Fun -> Bool)              -- ^ functions from the objects to use as roots (include all their deps)
      -> Set Fun                    -- ^ extra symbols to link in
      -> IO LinkResult
link' dflags env settings target _include pkgs objFiles jsFiles isRootFun extraStaticDeps = do
      (objDepsMap, objRequiredUnits) <- loadObjDeps objFiles
      let rootSelector | Just baseMod <- gsGenBase settings =
                           \(Fun _p m _s) -> m == T.pack baseMod
                       | otherwise = isRootFun
          roots = S.fromList . filter rootSelector $
            concatMap (M.keys . depsHaskellExported . fst) (M.elems objDepsMap)
          rootMods = map (T.unpack . head) . group . sort . map funModule . S.toList $ roots
          objPkgs = map toPackageKey $ nub (map fst $ M.keys objDepsMap)
      compilationProgressMsg dflags $
        case gsGenBase settings of
          Just baseMod -> "Linking base bundle " ++ target ++ " (" ++ baseMod ++ ")"
          _            -> "Linking " ++ target ++ " (" ++ intercalate "," rootMods ++ ")"
      base <- case gsUseBase settings of
        NoBase        -> return emptyBase
        BaseFile file -> Compactor.loadBase file
        BaseState b   -> return b
      (rdPkgs, rds) <- rtsDeps dflags
      -- c   <- newMVar M.empty
      let rtsPkgs     =  map stringToInstalledUnitId
                             ["@rts", "@rts_" ++ buildTag dflags]
          pkgs' :: [InstalledUnitId]
          pkgs'       = nub (rtsPkgs ++ rdPkgs ++ reverse objPkgs ++ reverse pkgs)
          pkgs''      = filter (not . (isAlreadyLinked base)) pkgs'
          -- pkgLibPaths = mkPkgLibPaths pkgs'
          -- getPkgLibPaths :: InstalledUnitId -> ([FilePath],[String])
          -- getPkgLibPaths k = fromMaybe ([],[]) (lookup k pkgLibPaths)
      (archsDepsMap, archsRequiredUnits) <- loadArchiveDeps env =<<
          getPackageArchives dflags (map snd $ mkPkgLibPaths pkgs')
      pkgArchs <- getPackageArchives dflags (map snd $ mkPkgLibPaths pkgs'')
      (allDeps, code) <-
        collectDeps dflags
                    (objDepsMap `M.union` archsDepsMap)
                    (pkgs' ++ [thisInstalledUnitId dflags])
                    (baseUnits base)
                    (roots `S.union` rds `S.union` extraStaticDeps)
                    (archsRequiredUnits ++ objRequiredUnits)
      let (outJs, metaSize, compactorState, stats) =
             renderLinker settings dflags (baseCompactorState base) rds code
          base'  = Base compactorState (nub $ basePkgs base ++ map mkPackage pkgs'')
                         (allDeps `S.union` baseUnits base)
      (alreadyLinkedBefore, alreadyLinkedAfter) <- getShims dflags [] (filter (isAlreadyLinked base) pkgs')
      (shimsBefore, shimsAfter) <- getShims dflags jsFiles pkgs''
      return $ LinkResult outJs stats metaSize
                 (concatMap (\(_,_,_,_,_,_,r) -> r) code)
                 (filter (`notElem` alreadyLinkedBefore) shimsBefore)
                 (filter (`notElem` alreadyLinkedAfter)  shimsAfter)
                 pkgArchs base'
  where
    isAlreadyLinked :: Base -> InstalledUnitId -> Bool
    isAlreadyLinked b pkg = mkPackage pkg `elem` basePkgs b

    mkPkgLibPaths :: [InstalledUnitId] -> [(InstalledUnitId, ([FilePath],[String]))]
    mkPkgLibPaths
      = map (\k -> ( k
                   , (getInstalledPackageLibDirs dflags k
                     , getInstalledPackageHsLibs dflags k)
                   ))

renderLinker :: GhcjsSettings
             -> DynFlags
             -> CompactorState
             -> Set Fun
             -> [(Package, Module, JStat, Text, [ClosureInfo], [StaticInfo], [ForeignRef])] -- ^ linked code per module
             -> (BL.ByteString, Int64, CompactorState, LinkerStats)
renderLinker settings dflags renamerState rtsDeps code =
  let (renamerState', compacted, meta) = Compactor.compact settings dflags renamerState (map funSymbol $ S.toList rtsDeps) (map (\(_,_,s,_,ci,si,_) -> (s,ci,si)) code)
      pe = TLE.encodeUtf8 . (<>"\n") . displayT . renderPretty 0.8 150 . pretty
      rendered  = parMap rdeepseq pe compacted
      renderedMeta = pe meta
      renderedExports = TLE.encodeUtf8 . TL.fromStrict . T.unlines . filter (not . T.null) $ map (\(_,_,_,rs,_,_,_) -> rs) code
      mkStat (p,m,_,_,_,_,_) b = ((p,m), BL.length b)
  in ( mconcat rendered <> renderedMeta <> renderedExports
     , BL.length renderedMeta
     , renamerState'
     , M.fromList $ zipWith mkStat code rendered
     )

linkerStats :: Int64         -- ^ code size of packed metadata
            -> LinkerStats   -- ^ code size per module
            -> TL.Text
linkerStats meta s =
  TL.intercalate "\n\n" [packageStats, moduleStats, metaStats] <> "\n\n"
  where
    ps = M.fromListWith (+) . map (\((p,_),s) -> (p,s)) . M.toList $ s
    pad n t = let l = TL.length t
              in  if l < n then t <> TL.replicate (n-l) " " else t
    pkgMods = groupBy ((==) `on` (fst . fst)) (M.toList s)
    showMod ((_,m),s) = pad 40 ("    " <> TL.fromStrict m <> ":") <> TL.pack (show s)
    packageStats = "code size summary per package:\n\n" <>
      TL.unlines (map (\(p,s) -> pad 25 (showPkg p <> ":") <> TL.pack (show s)) $ M.toList ps)
    moduleStats = "code size per module:\n\n" <> TL.unlines
      (map (\xs@(((p,_),_):_) -> showPkg p <> "\n" <> TL.unlines (map showMod xs)) pkgMods)
    metaStats = "packed metadata: " <> TL.pack (show meta)

rtsText' :: DynFlags -> CgSettings -> TL.Text
rtsText' = rtsText
{- prerender RTS for faster linking (fixme this results in a build error, why?)
rtsText' debug = if debug
                   then TL.pack $ $(runQ $ litE (StringL . TL.unpack . rtsText $ True))
                   else TL.pack $ $(runQ $ litE (StringL . TL.unpack . rtsText $ False))
-}

splitPath' :: FilePath -> [FilePath]
splitPath' = map (filter (`notElem` ("/\\"::String))) . splitPath

getPackageArchives :: DynFlags -> [([FilePath],[String])] -> IO [FilePath]
getPackageArchives dflags pkgs =
  filterM doesFileExist [ p </> "lib" ++ l ++ profSuff <.> "js_a"
                        | (paths, libs) <- pkgs, p <- paths, l <- libs
                        , not $ "EMCC" `isPrefixOf` l]
  where
    profSuff | WayProf `elem` ways dflags = "_p"
             | otherwise                  = ""

-- fixme the wired-in package id's we get from GHC we have no version
getShims :: DynFlags -> [FilePath] -> [InstalledUnitId] -> IO ([FilePath], [FilePath])
getShims dflags extraFiles pkgDeps = do
  (w,a) <- collectShims (getLibDir dflags </> "shims")
                        (map (convertPkg dflags) pkgDeps)
  extraFiles' <- mapM canonicalizePath extraFiles
  return (w, a++extraFiles')

convertPkg :: DynFlags -> InstalledUnitId -> (Text, Version)
convertPkg dflags p
  = case getInstalledPackageVersion dflags p of
      Just v -> (T.pack (getInstalledPackageName dflags p), v)
      -- special or wired-in
      Nothing -> (T.pack (installedUnitIdString p), Version [])

{- | convenience: combine rts.js, lib.js, out.js to all.js that can be run
     directly with node.js or SpiderMonkey jsshell
 -}
combineFiles :: DynFlags -> FilePath -> IO ()
combineFiles dflags fp = do
  files   <- mapM (B.readFile.(fp</>)) ["rts.js", "lib.js", "out.js"]
  runMain <- if   gopt Opt_NoHsMain dflags
             then pure mempty
             else B.readFile (getLibDir dflags </> "runmain.js")
  writeBinaryFile (fp</>"all.js") (mconcat (files ++ [runMain]))

-- | write the index.html file that loads the program if it does not exit
writeHtml :: DynFlags -> FilePath -> IO ()
writeHtml df out = do
  e <- doesFileExist htmlFile
  unless e $
    B.readFile (getLibDir df </>"template.html") >>= B.writeFile htmlFile
  where
    htmlFile = out </> "index.html"

-- | write the runmain.js file that will be run with defer so that it runs after index.html is loaded
writeRunMain :: DynFlags -> FilePath -> IO ()
writeRunMain df out = do
  e <- doesFileExist runMainFile
  unless e $
    B.readFile (getLibDir df </> "runmain.js") >>= B.writeFile runMainFile
  where
    runMainFile = out </> "runmain.js"

writeRunner :: GhcjsSettings -> DynFlags -> FilePath -> IO ()
writeRunner settings dflags out = when (gsBuildRunner settings) $ do
  cd    <- getCurrentDirectory
  let runner = cd </> addExeExtension (dropExtension out)
      srcFile = out </> "all" <.> "js"
  nodeSettings <- readNodeSettings dflags
  if Platform.isWindows
  then do
    copyFile (topDir dflags </> "bin" </> "wrapper" <.> "exe")
             runner
    T.writeFile (runner <.> "options") $ T.unlines
                [ T.pack (nodeProgram nodeSettings)
                , T.pack ("{{EXEPATH}}" </> out </> "all" <.> "js")
                ]
  else do
    src <- readBinaryFile (cd </> srcFile)
    let pgm = TE.encodeUtf8 (T.pack $ nodeProgram nodeSettings)
    B.writeFile runner ("#!" <> pgm <> "\n" <> src)
    Cabal.setFileExecutable runner

-- | write the manifest.webapp file that for firefox os
writeWebAppManifest :: DynFlags -> FilePath -> IO ()
writeWebAppManifest df out = do
  e <- doesFileExist manifestFile
  unless e $
    B.readFile (getLibDir df </> "manifest.webapp") >>= B.writeFile manifestFile
  where
    manifestFile = out </> "manifest.webapp"

rtsExterns :: Text
rtsExterns =
  "// GHCJS RTS externs for closure compiler ADVANCED_OPTIMIZATIONS\n\n" <>
  mconcat (map (\x -> "/** @type {*} */\nObject.d" <> T.pack (show x) <> ";\n")
               [(7::Int)..16384])

writeExterns :: FilePath -> IO ()
writeExterns out = T.writeFile (out </> "all.js.externs") rtsExterns

-- | get all functions in a module
modFuns :: Deps -> [Fun]
modFuns (Deps _p _m _r e _b) = M.keys e

-- | get all dependencies for a given set of roots
getDeps :: Map (Package,Module) Deps -- ^ loaded deps
        -> Set LinkableUnit -- ^ don't link these blocks
        -> Set Fun          -- ^ start here
        -> [LinkableUnit]   -- ^ and also link these
        -> IO (Set LinkableUnit)
getDeps lookup base fun startlu = go' S.empty (S.fromList startlu) (S.toList fun)
  where
    go :: Set LinkableUnit
       -> Set LinkableUnit
       -> IO (Set LinkableUnit)
    go result open = case S.minView open of
      Nothing -> return result
      Just (lu@(lpkg,lmod,n), open') ->
          let key = (lpkg, lmod)
          in  case M.lookup (lpkg,lmod) lookup of
                Nothing -> error ("getDeps.go: object file not loaded for:  " ++ show key)
                Just (Deps _ _ _ _ b) ->
                  let block = b!n
                      result' = S.insert lu result
                  in go' result'
                         (addOpen result' open' $ map (lpkg,lmod,) (blockBlockDeps block))
                         (blockFunDeps block)

    go' :: Set LinkableUnit
        -> Set LinkableUnit
        -> [Fun]
        -> IO (Set LinkableUnit)
    go' result open [] = go result open
    go' result open (f:fs) =
        let key = (funPackage f, funModule f)
        in  case M.lookup key lookup of
              Nothing -> error ("getDeps.go': object file not loaded for:  " ++ show key)
              Just (Deps _p _m _r e _b) ->
                 let lun :: Int
                     lun = fromMaybe (error $ "exported function not found: " ++ show f)
                                     (M.lookup f e)
                     lu  = (funPackage f, funModule f, lun)
                 in  go' result (addOpen result open [lu]) fs

    addOpen :: Set LinkableUnit -> Set LinkableUnit -> [LinkableUnit]
            -> Set LinkableUnit
    addOpen result open newUnits =
      let alreadyLinked s = S.member s result ||
                            S.member s open   ||
                            S.member s base
      in  open `S.union` (S.fromList $ filter (not . alreadyLinked) newUnits)

-- | collect dependencies for a set of roots
collectDeps :: DynFlags
            -> Map (Package, Module) (Deps, DepsLocation)
            -> [InstalledUnitId]     -- ^ packages, code linked in this order
            -> Set LinkableUnit -- ^ do not include these
            -> Set Fun -- ^ roots
            -> [LinkableUnit] -- ^ more roots
            -> IO ( Set LinkableUnit
                  , [(Package, Module, JStat, Text, [ClosureInfo], [StaticInfo], [ForeignRef])]
                  )
collectDeps _dflags lookup packages base roots units = do
  allDeps <- getDeps (fmap fst lookup) base roots units
  -- read ghc-prim first, since we depend on that for static initialization
  let packages' = uncurry (++) $ partition (==(toInstalledUnitId primUnitId)) (nub packages)
      unitsByModule :: Map (Package, Module) IntSet
      unitsByModule = M.fromListWith IS.union $
                      map (\(p,m,n) -> ((p,m),IS.singleton n)) (S.toList allDeps)
      lookupByPkg :: Map Package [(Deps, DepsLocation)]
      lookupByPkg = M.fromListWith (++) (map (\((p,_m),v) -> (p,[v])) (M.toList lookup))
  code <- fmap (catMaybes . concat) . forM packages' $ \pkg ->
    mapM (uncurry $ extractDeps unitsByModule)
         (fromMaybe [] $ M.lookup (mkPackage pkg) lookupByPkg)
  return (allDeps, code)

extractDeps :: Map (Package, Module) IntSet
            -> Deps
            -> DepsLocation
            -> IO (Maybe (Package, Module, JStat, Text, [ClosureInfo], [StaticInfo], [ForeignRef]))
extractDeps units deps loc =
  case M.lookup (pkg, mod) units of
    Nothing       -> return Nothing
    Just modUnits -> do
      let selector n _  = n `IS.member` modUnits || isGlobalUnit n
      x <- case loc of
        ObjectFile js_o  -> collectCode =<< readObjectFileKeys selector js_o
        ArchiveFile js_a -> collectCode =<<
                            (readObjectKeys (js_a ++ ':':T.unpack mod) selector <$>
                            Ar.readObject (mkModuleName $ T.unpack mod) js_a)
        InMemory n b     -> collectCode $
                            readObjectKeys n selector (BL.fromStrict b)
      evaluate (rnf x)
      return x
  where
    pkg           = depsPackage deps
    mod           = depsModule deps
    collectCode l = let x = ( pkg
                            , mod
                            , mconcat (map oiStat l)
                            , T.unlines (map oiRaw l)
                            , concatMap oiClInfo l
                            , concatMap oiStatic l
                            , concatMap oiFImports l)
                    in evaluate (rnf x) >> return (Just x)

mkPackage :: InstalledUnitId -> Package
mkPackage pk = Package (T.pack $ installedUnitIdString pk)

toPackageKey :: Package -> InstalledUnitId
toPackageKey = stringToInstalledUnitId . T.unpack . unPackage

{- | Static dependencies are symbols that need to be linked regardless
     of whether the linked program refers to them. For example
     depenencies that the RTS uses or symbols that the user program
     refers to directly
 -}
newtype StaticDeps =
  StaticDeps { unStaticDeps :: [(Text, Text, Text)] -- package/module/symbol
             }

noStaticDeps :: StaticDeps
noStaticDeps = StaticDeps []

{- | The input file format for static deps is a yaml document with a
     package/module/symbol tree where symbols can be either a list or
     just a single string, for example:

     base:
       GHC.Conc.Sync:          reportError
       Control.Exception.Base: nonTermination
     ghcjs-prim:
       GHCJS.Prim:
         - JSVal
         - JSException
 -}
instance FromJSON StaticDeps where
  parseJSON (Object v) = StaticDeps . concat <$> mapM (uncurry parseMod) (HM.toList v)
    where
      parseMod p (Object v) = concat <$> mapM (uncurry (parseSymb p)) (HM.toList v)
      parseMod _ _          = mempty
      parseSymb p m (String s) = pure [(p,m,s)]
      parseSymb p m (Array v)  = mapM (parseSingleSymb p m) (V.toList v)
      parseSymb _ _ _          = mempty
      parseSingleSymb p m (String s) = pure (p,m,s)
      parseSingleSymb _ _ _          = mempty
  parseJSON _          = mempty

-- | dependencies for the RTS, these need to be always linked
rtsDeps :: DynFlags -> IO ([InstalledUnitId], Set Fun)
rtsDeps dflags = readSystemDeps dflags
                                "RTS"
                                "linking"
                                "rtsdeps.yaml"

-- | dependencies for the Template Haskell, these need to be linked when running
--   Template Haskell (in addition to the RTS deps)
thDeps :: DynFlags -> IO ([InstalledUnitId], Set Fun)
thDeps dflags = readSystemDeps dflags
                               "Template Haskell"
                               "running Template Haskell"
                               "thdeps.yaml"

readSystemDeps :: DynFlags
               -> String
               -> String
               -> FilePath
               -> IO ([InstalledUnitId], Set Fun)
readSystemDeps dflags depsName requiredFor file = do
  b  <- readBinaryFile (getLibDir dflags </> file)
  wi <- readSystemWiredIn dflags
  case Yaml.decodeEither b of
    Left err -> panic $ "could not read " ++ depsName ++
                        " dependencies from " ++ file ++ ":\n" ++ err
    Right sdeps ->
      let (StaticDeps unresolved, pkgs, funs) = staticDeps dflags wi sdeps
      in  case unresolved of
            ((p,_,_):_) ->
                  panic $ "Package `" ++ T.unpack p ++ "' is required for " ++
                          requiredFor ++ ", but was not found"
            _ ->
              -- putStrLn "system dependencies:"
              -- print (map installedUnitIdString pkgs, funs)
              return (pkgs, funs)



readSystemWiredIn :: DynFlags -> IO [(Text, InstalledUnitId)]
readSystemWiredIn dflags = do
  b <- B.readFile filename
  case Yaml.decodeEither b of
     Left _err -> error $ "could not read wired-in package keys from " ++ filename
     Right m  -> return . M.toList
                        . M.union ghcWiredIn -- GHC wired-in package keys override those in the file
                        . fmap stringToInstalledUnitId $ m
  where
    filename = getLibDir dflags </> "wiredinkeys" <.> "yaml"
    ghcWiredIn :: Map Text InstalledUnitId
    ghcWiredIn = M.fromList $ map (\k -> (T.pack (installedUnitIdString k), k))
                                  (map toInstalledUnitId wiredInUnitIds)
{- | read a static dependencies specification and give the roots

     if dependencies come from a versioned (non-hardwired) package
     that is linked multiple times, then the returned dependencies
     will all come from the same version, but it's undefined which one.
 -}

type SDep = (Text, Text, Text)

staticDeps :: DynFlags
           -> [(Text, InstalledUnitId)]    -- ^ wired-in package names / keys
           -> StaticDeps              -- ^ deps from yaml file
           -> (StaticDeps, [InstalledUnitId], Set Fun)
                                      -- ^ the StaticDeps contains the symbols
                                      --   for which no package could be found
staticDeps dflags wiredin sdeps = mkDeps sdeps
  where
    zenc  = T.pack . zEncodeString . T.unpack
    mkDeps (StaticDeps ds) =
      let (u, p, r) = foldl' resolveDep ([], S.empty, S.empty) ds
      in  (StaticDeps u, S.toList (closePackageDeps dflags p), r)
    resolveDep :: ([SDep], Set InstalledUnitId, Set Fun)
               -> SDep
               -> ([SDep], Set InstalledUnitId, Set Fun)
    resolveDep (unresolved, pkgs, resolved) dep@(p, m, s) =
      case lookup p wiredin of
             Nothing -> ( dep : unresolved, pkgs, resolved)
             Just k  -> case Packages.lookupInstalledPackage dflags k of
               Nothing -> error $ "Package key for wired-in dependency `" ++
                                  T.unpack p ++ "' could not be found: "  ++
                                  installedUnitIdString k
               Just conf ->
                 let k' = unitId conf
                 in  ( unresolved
                     , S.insert k' pkgs
                     , S.insert (Fun (mkPackage k') m $ mkSymb k' m s)
                                resolved
                     )
    mkSymb :: InstalledUnitId -> Text -> Text -> Text
    mkSymb p m s  =
      "h$" <> zenc (T.pack (encodeInstalledUnitId dflags p) <> ":" <> m <> "." <> s)

closePackageDeps :: DynFlags -> Set InstalledUnitId -> Set InstalledUnitId
closePackageDeps dflags pkgs
  | S.size pkgs == S.size pkgs' = pkgs
  | otherwise                   = closePackageDeps dflags pkgs'
  where
    pkgs' = pkgs `S.union` S.fromList (concatMap deps $ S.toList pkgs)
    notFound = error "closePackageDeps: package not found"
    deps :: InstalledUnitId -> [InstalledUnitId]
    deps =
--           map (Packages.resolveInstalledPackageId dflags)
           Packages.depends
         . fromMaybe notFound
         . Packages.lookupInstalledPackage dflags

-- read all dependency data from the to-be-linked files
loadObjDeps :: [LinkedObj] -- ^ object files to link
            -> IO (Map (Package, Module) (Deps, DepsLocation), [LinkableUnit])
loadObjDeps objs = prepareLoadedDeps <$> mapM readDepsFile' objs

loadArchiveDeps :: GhcjsEnv
                -> [FilePath]
                -> IO ( Map (Package, Module) (Deps, DepsLocation)
                      , [LinkableUnit]
                      )
loadArchiveDeps env archives = modifyMVar (linkerArchiveDeps env) $ \m ->
  case M.lookup archives' m of
    Just r  -> return (m, r)
    Nothing -> loadArchiveDeps' archives >>= \r -> return (M.insert archives' r m, r)
  where
     archives' = S.fromList archives

loadArchiveDeps' :: [FilePath]
                 -> IO ( Map (Package, Module) (Deps, DepsLocation)
                       , [LinkableUnit]
                       )
loadArchiveDeps' archives = do
  -- HACK: ignore `libEMCC*` archives.
  -- these are emcc compiled archives by (ghcjs) convention, and thus are useless
  -- for linking in ghcjs.
  let archives' = [ arch | arch <- archives
                         , not $ "libEMCC" `isPrefixOf` (takeFileName arch) ]
  archDeps <- forM archives' $ \file -> do
    Ar.withAllObjects file $ \modulename h _len -> do
        (,ArchiveFile file) <$>
          hReadDeps (file ++ ':':moduleNameString modulename) h
  return (prepareLoadedDeps $ concat archDeps)

prepareLoadedDeps :: [(Deps, DepsLocation)]
                  -> ( Map (Package, Module) (Deps, DepsLocation)
                     , [LinkableUnit]
                     )
prepareLoadedDeps deps =
  let req     = concatMap (requiredUnits . fst) deps
      depsMap = M.fromList $ map (\d -> ((depsPackage (fst d)
                                         ,depsModule (fst d)), d))
                                 deps
  in  (depsMap, req)

requiredUnits :: Deps -> [LinkableUnit]
requiredUnits d = map (depsPackage d, depsModule d,)
                      (IS.toList $ depsRequired d)

-- read dependencies from an object that might have already been into memory
-- pulls in all Deps from an archive
readDepsFile' :: LinkedObj -> IO (Deps, DepsLocation)
readDepsFile' (ObjLoaded name bs) = pure . (,InMemory name bs) $
                                    readDeps name (BL.fromStrict bs)
readDepsFile' (ObjFile file)      =
  (,ObjectFile file) <$> readDepsFile file

generateBase :: FilePath -> Base -> IO ()
generateBase outDir b =
  BL.writeFile (outDir </> "out.base.symbs") (Compactor.renderBase b)
