content: module BinUtil (
                  BinMap, BinFile,
                  HashMap,
                  readImports,
                  readBin, sortImports,
                  replaceImports
                 ) where
  
  import Control.Monad(when, foldM)
  import qualified Data.Map as M
  import Flags(Flags,
               ifcPath,
               enablePoisonPills,
               usePrelude,
               verbose)
  import Position(noPosition)
  import Id
  import PreIds
  import CSyntax
  import ISyntax
  import Prim
  import Error(internalError, ErrMsg(..), ErrorHandle, bsError, bsWarning)
  import PFPrint
  import SCC
  import FileNameUtil(binSuffix)
  import FileIOUtil(readBinFilePath)
  import GenBin(readBinFile)
  import Util(fromJustOrErr, fromMaybeM,
              map_insertManyWith, map_insertManyWithKeyM)
  
  
  -- =========================
  
  -- the contents of the .bo package
  type BinFile a = ( String       -- filename
                   , CSignature   -- signature of user-visible defs)
                   , CSignature   -- signature of all defs
                   , IPackage a   -- the package
                   , String       -- hash
                   )
  
  -- a map of the hashes for a package (associated with the source)
  -- (more than one hash indicates a mismatch error)
  type HashMap = M.Map Id (String, [Id])
  
  -- a map containing the binfiles that have been loaded, indexed by pkg name
  type BinMap a = M.Map String (BinFile a)
  
  
  -- =========================
  
  -- Read all .bo files imported by this package
  readImports :: ErrorHandle -> Flags -> BinMap a -> HashMap -> CPackage ->
                 IO (CPackage, BinMap a, HashMap)
  readImports errh flags binmap0 hashmap0
              (CPackage pkgId exps imps fixs ds includes) = do
    let
        pkgName = getIdString pkgId
  
        -- Replace qualified importing only (True) with unqualified and
        -- qualified (False)
        qualMergeFn newQual oldQual = if (oldQual) then newQual else oldQual
  
        -- load files as necessary, keeping track of what has been loaded
        -- and with what qualifiers they have been imported
        -- (avoids loading packages twice and filters duplicates)
        fn (binmap, hashmap, qualmap) (CImpId q i) =
            do (binmap', hashmap', bininfo, _)
                   <- readBin errh flags (Just pkgName) binmap hashmap i
               let (_, _, _, ipkg, _) = bininfo
               let deps = map (getIdString . fst) $ ipkg_depends ipkg
                   dep_quals = map (\x -> (x,True)) deps
               -- add the dependencies as qualified-only imports
               let qualmap' = map_insertManyWith qualMergeFn dep_quals qualmap
               -- add the current package with the user-specified import
               let qualmap'' = M.insertWith qualMergeFn (getIdString i) q qualmap'
               return (binmap', hashmap', qualmap'')
        fn _ cimp = internalError ("readImports: " ++ ppReadable cimp)
  
    (binmap, hashmap, qualmap)
        <- foldM fn (binmap0, hashmap0, M.empty) (addPrelude flags imps)
  
    let mkCImp (s, q) = case (M.lookup s binmap) of
                          Just (fn, bi_sig, _, _, _) -> CImpSign fn q bi_sig
                          Nothing -> internalError ("mkCImp: " ++ ppReadable s)
    let imps' = map mkCImp (M.toList qualmap)
  
    let sortedImports = sortImports imps'
    let cpkg' = CPackage pkgId exps sortedImports fixs ds includes
  
    return (cpkg', binmap, hashmap)
  
  
  -- helper function that reads in a .bo file, and any .bo files that it needs
  readBin :: ErrorHandle -> Flags -> (Maybe String) ->
             BinMap a -> HashMap -> Id ->
             IO (BinMap a, HashMap, BinFile a, [Id])
  readBin errh flags maybePkgName binmap0 hashmap0 p0 = do
     let
         -- if compiling a source package (that imports p0), detect when p0
         -- imports a bin-file with the same name as the source package
         checkPkgName p =
             case maybePkgName of
               Just pkgName | (getIdString p == pkgName) ->
                   bsError errh
                       [(getPosition p0,
                         ECircularImportsViaBinFile pkgName (getIdString p0))]
               _ -> return ()
  
         fn :: [Id] -> BinMap a -> HashMap -> [Id] ->
               IO (BinMap a, HashMap, [Id])
         fn ps_read binmap hashmap [] = return (binmap, hashmap, reverse ps_read)
         fn ps_read binmap hashmap (p:ps) =
             case (M.lookup (getIdString p) binmap) of
               Just _ -> fn ps_read binmap hashmap ps
               Nothing -> do
                   checkPkgName p
                   (fname, bi_sig, bo_sig, bo_pkg, hash, hashmap', impNames)
                       <- doImport errh flags hashmap p
                   let binmap' = M.insert (getIdBaseString p)
                                          (fname, bi_sig, bo_sig, bo_pkg, hash)
                                          binmap
                   fn (p : ps_read) binmap' hashmap' (impNames ++ ps)
  
     (binmap', hashmap', ps_read) <- fn [] binmap0 hashmap0 [p0]
     let p0_bininfo = fromJustOrErr "readBin" $ M.lookup (getIdString p0) binmap'
     return (binmap', hashmap', p0_bininfo, ps_read)
  
  
  -- Sort signatures topologically: output signature list such that,
  -- if signature s1 comes before signature s2, then s1 does not import s2
  sortImports :: [CImport] -> [CImport]
  sortImports signatures =
      let
          -- We map the signatures to strings and sort a graph of strings,
          -- so that sorting is stable (the Ord instance for the tuple includes
          -- Ids, whose Ord instance depends on when the Id was created)
          sMap = M.fromList [ (getIdString name, sign)
                              | sign@(CImpSign _ _ (CSignature name _  _ _))
                                  <- signatures]
          addImplicitPreludeDependency (name, imports)
              | name == strPrelude = (name, imports)
              | name == strPreludeBSV = (name, imports)
              | otherwise = (name, strPrelude :
                             strPreludeBSV :
                             filter (\ x -> x /= strPrelude && x /= strPreludeBSV)
                                    imports)
              where strPrelude = getIdString idPrelude
                    strPreludeBSV = getIdString idPreludeBSV
          sGraph = [ addImplicitPreludeDependency (getIdString name,
                                                   map getIdString imports)
                     | (CImpSign _ _ (CSignature name imports _ _))
                         <- signatures]
          lookupFn i = case (M.lookup i sMap) of
                         Just s -> s
                         Nothing -> internalError ("sortImports: " ++ i)
      in  case tsort sGraph of
          Left cycle -> internalError ("import cycle:\n" ++ ppString cycle)
          Right order -> map lookupFn order
  
  
  -- Add the Prelude to the list of imports, unless compiling the Prelude itself
  addPrelude :: Flags -> [CImport] -> [CImport]
  addPrelude flags imps | usePrelude flags = CImpId False idPrelude :
                                             CImpId False idPreludeBSV :
                                             imps
                        | otherwise = imps
  
  -- Import one .bo file
  doImport :: ErrorHandle -> Flags -> HashMap -> Id ->
              IO (String, CSignature, CSignature, IPackage a, String,
                  HashMap, [Id])
  doImport errh flags hashmap i = do
      let binname = getIdString i ++ "." ++ binSuffix
          missingErr = (getIdPosition i,
                        EMissingBinFile binname (pfpString i))
          pillMsg = if (enablePoisonPills flags)
                    then bsWarning errh
                    else bsError errh
      (file, name) <- fromMaybeM (bsError errh [missingErr]) $
                        readBinFilePath errh (getIdPosition i)
                            (verbose flags) binname (ifcPath flags)
      (bi_sig, bo_sig, ipkg@(IPackage pi impHashes _ _), hash)
          <- readBinFile errh name file
      when (pi /= i) $
          bsError errh [(noPosition, EBinFilePkgNameMismatch name
                                         (pfpString i) (pfpString pi))]
      when (any hasPoisonPill [ e | IDef _ _ e _ <- ipkg_defs ipkg ]) $
          pillMsg [(getIdPosition pi, WPoisonedDefFile binname)]
      hashmap' <- mergeHashes errh hashmap pi hash impHashes
      let impNames = map fst impHashes
      return (name, bi_sig, bo_sig, ipkg, hash, hashmap', impNames)
  
  hasPoisonPill :: IExpr a -> Bool
  hasPoisonPill (ILam _ _ e)  = hasPoisonPill e
  hasPoisonPill (ILAM _ _ e)  = hasPoisonPill e
  hasPoisonPill (IAps f _ es) = any hasPoisonPill (f:es)
  hasPoisonPill (ICon _ (ICPrim _ p)) = p == PrimPoisonedDef
  hasPoisonPill _ = False
  
  mergeHashes :: ErrorHandle -> HashMap -> Id -> String -> [(Id, String)] ->
                 IO HashMap
  mergeHashes errh hashmap binId binhash impHashes =
    let
        -- a package and its importer disagree about the hash
        mismatchErr1 pkg importer =
            let pkgfile = (pfpString pkg) ++ "." ++ binSuffix
            in  bsError errh
                    [(getIdPosition binId,
                      EBinFileSignatureMismatch pkgfile (pfpString importer))]
  
        -- two packages disagree about an imported file
        -- XXX we could determine which is wrong by loading the file itself
        mismatchErr2 pkg importer1 importer2 =
            let pkgfile = (pfpString pkg) ++ "." ++ binSuffix
            in  bsError errh
                    [(getIdPosition binId,
                      EBinFileSignatureMismatch2 pkgfile
                          (pfpString importer1) (pfpString importer2))]
  
        mergeFn :: Id -> (String, [Id]) -> (String, [Id]) ->
                   IO (String, [Id])
        mergeFn k (new_s, [new_i]) (old_s, old_is@(old_i:_))
            | new_s == old_s = return (old_s, (new_i:old_is))
            | new_i == k
                -- the "old_is" expected a different hash than the
                -- package "new_i" actually has
                = mismatchErr1 new_i old_i
            | k `elem` old_is
                -- the "new_i" is expecting different than the package
                -- actually has (and possibly other "old_is" agree)
                = mismatchErr1 k new_i
            | otherwise
                -- we don't yet know what the package's hash is,
                -- but two users disagree on its hash
                = mismatchErr2 k new_i old_i
        mergeFn _ new_val _ =
            internalError ("mergeHashes: " ++ ppReadable new_val)
  
  
        new_pairs = let mkImpPair (i,s) = (i, (s, [binId]))
                        imp_pairs = map mkImpPair impHashes
                        bin_pair = (binId, (binhash, [binId]))
                    in  (bin_pair : imp_pairs)
    in
        map_insertManyWithKeyM mergeFn new_pairs hashmap
  
  
  -- =========================
  
  -- Replace existing imports in a package with new "internal" ones
  -- (where all defs are visible, not just the ones visible to the user).
  -- This is used to create the full symbol table used for generating a
  -- module.  (XXX can we get rid of this?)
  replaceImports :: CPackage -> [CSignature] -> CPackage
  replaceImports (CPackage i exps imps fixs defs includes) impsigs =
      CPackage i exps imps' fixs defs includes
    where sigMap = M.fromList [(i, sig) | sig@(CSignature i _ _ _) <- impsigs]
          imps' = map replaceSig imps
          replaceSig (CImpSign n q (CSignature i _ _ _)) =
              let errstr = "replaceImports: missing sig: " ++ ppReadable i
              in  CImpSign n q (fromJustOrErr errstr (M.lookup i sigMap))
          replaceSig (CImpId _ i) =
              internalError
                  ("replaceImports: CImpId: " ++ ppReadable i)
  
  -- =========================
  