content: {-# LANGUAGE DoRec #-}
  module Ho.Build (
      module Ho.Type,
      dumpHoFile,
      parseFiles,
      preprocess,
      preprocessHs,
      buildLibrary
      ) where
  
  import Control.Concurrent
  import Control.Monad.Identity
  import Data.IORef
  import Data.List hiding(union)
  import Data.Maybe
  import Data.Monoid(Monoid(..))
  import Data.Tree
  import Data.Version(Version,parseVersion,showVersion)
  import System.FilePath as FP
  import System.Mem
  import Text.Printf
  import qualified Data.ByteString as BS
  import qualified Data.ByteString.Lazy as LBS
  import qualified Data.ByteString.Lazy.UTF8 as LBSU
  import qualified Data.Map as Map
  import qualified Data.Set as Set
  import qualified Text.PrettyPrint.HughesPJ as PPrint
  
  import DataConstructors
  import Doc.DocLike
  import Doc.PPrint
  import Doc.Pretty
  import E.E
  import E.Rules
  import E.Show
  import E.Traverse(emapE)
  import E.TypeCheck()
  import FrontEnd.Class
  import FrontEnd.FrontEnd
  import FrontEnd.HsSyn
  import FrontEnd.Infix
  import FrontEnd.SrcLoc
  import FrontEnd.Warning(warn,processIOErrors,WarnType(..))
  import Ho.Binary
  import Ho.Collected()
  import Ho.Library
  import Ho.ReadSource
  import Ho.Type
  import Name.Name
  import Options
  import PackedString(PackedString,packString,unpackPS)
  import Support.TempDir
  import Util.Gen
  import Util.SetLike
  import Util.YAML
  import Version.Config(version)
  import Version.Version(versionString)
  import qualified FlagDump as FD
  import qualified FlagOpts as FO
  import qualified Support.MD5 as MD5
  import qualified Util.Graph as G
  
  -- Ho File Format
  --
  -- ho files are standard CFF format files (PNG-like) as described in the Support.CFF modules.
  --
  -- the CFF magic for the files is the string "JHC"
  --
  -- JHDR - header info, contains a list of modules contained and dependencies that need to be checked to read the file
  -- LIBR - only present if this is a library, contains library metainfo
  -- IDEP - immutable import information, needed to tell if ho files are up to date
  -- LINK - redirect to another file for file systems without symlinks
  -- DEFS - definitions type checking information
  -- CORE - compiled core and associated data
  -- LDEF - library map of module group name to DEFS
  -- LCOR - library map of module group name to CORE
  -- GRIN - compiled grin code
  -- FILE - Extra file, such as embedded c code.
  
  {-
   - We separate the data into various chunks for logical layout as well as the
   - important property that each chunk is individually compressed and accessable.
   - What this means is that we can skip chunks we don't need. for instance,
   - during the final link we have no need of the haskell type checking
   - information, we are only interested in the compiled code, so we can jump
   - directly to it. If we relied on straight serialization, we would have to
   - parse all preceding information just to discard it right away.  We also lay
   - them out so that we can generate error messages quickly. for instance, we can
   - determine if a symbol is undefined quickly, before it has to load the
   - typechecking data.
   -}
  
  type LibraryName = PackedString
  
  findFirstFile :: [FilePath] -> IO (LBS.ByteString,FilePath)
  findFirstFile [] = fail "findFirstFile: file not found"
  findFirstFile (x:xs) = flip iocatch (\e -> findFirstFile xs) $ do
      bs <- LBS.readFile x
      return (bs,x)
  
  data ModDone
      = ModNotFound
      | ModLibrary !Bool ModuleGroup Library
      | Found SourceCode
  
  data Done = Done {
      hoCache         :: Maybe FilePath,
      knownSourceMap  :: Map.Map SourceHash (Module,[(Module,SrcLoc)]),
      validSources    :: Set.Set SourceHash,
      loadedLibraries :: Map.Map LibraryName Library,
      hosEncountered  :: Map.Map HoHash     (FilePath,HoHeader,HoIDeps,Ho),
      modEncountered  :: Map.Map Module     ModDone
      }
  
  hosEncountered_u f r@Done{hosEncountered  = x} = r{hosEncountered = f x}
  knownSourceMap_u f r@Done{knownSourceMap  = x} = r{knownSourceMap = f x}
  loadedLibraries_u f r@Done{loadedLibraries  = x} = r{loadedLibraries = f x}
  modEncountered_u f r@Done{modEncountered  = x} = r{modEncountered = f x}
  validSources_u f r@Done{validSources  = x} = r{validSources = f x}
  
  replaceSuffix suffix fp = reverse (dropWhile ('.' /=) (reverse fp)) ++ suffix
  
  hoFile :: Maybe FilePath -> FilePath -> Maybe Module -> SourceHash -> FilePath
  hoFile cacheDir fp mm sh = case (cacheDir,optHoDir options) of
      (Nothing,Nothing) -> replaceSuffix "ho" fp
      (Nothing,Just hdir) -> case mm of
          Nothing -> hdir ++ "/" ++ MD5.md5show32 sh ++ ".ho"
          Just m -> hdir ++ "/" ++ map ft (show m) ++ ".ho" where
              ft '/' = '.'
              ft x = x
      (Just hdir,_) -> hdir ++ "/" ++ MD5.md5show32 sh ++ ".ho"
  
  findHoFile :: IORef Done -> FilePath -> Maybe Module -> SourceHash -> IO (Bool,FilePath)
  findHoFile done_ref fp mm sh = do
      done <- readIORef done_ref
      let honame = hoFile (hoCache done) fp mm sh
      writeIORef done_ref (done { validSources = Set.insert sh (validSources done) })
      if sh `Set.member` validSources done || optIgnoreHo options then return (False,honame) else do
      onErr (return (False,honame)) (readHoFile honame) $ \ (hoh,hidep,ho) ->
          case hohHash hoh `Map.lookup` hosEncountered done of
              Just (fn,_,_,a) -> return (True,fn)
              Nothing -> do
                  modifyIORef done_ref (knownSourceMap_u $ (`mappend` (hoIDeps hidep)))
                  modifyIORef done_ref (validSources_u $ Set.union (Set.fromList . map snd $ hoDepends hidep))
                  modifyIORef done_ref (hosEncountered_u $ Map.insert (hohHash hoh) (honame,hoh,hidep,ho))
                  return (True,honame)
  
  onErr :: IO a -> IO b -> (b -> IO a) -> IO a
  onErr err good cont = join $ iocatch (good >>= return . cont) (\_ -> return err)
  
  fetchSource :: Opt -> IORef Done -> [FilePath] -> Maybe (Module,SrcLoc) -> IO Module
  fetchSource _ _ [] _ = fail "No files to load"
  fetchSource modOpt done_ref fs mm = do
      let killMod = case mm of
              Nothing -> fail $ "Could not load file: " ++ show fs
              Just (m,sloc) -> do
                  warn sloc (MissingModule m) $ printf "Module '%s' not found." (show m)
                  modifyIORef done_ref (modEncountered_u $ Map.insert m ModNotFound) >> return m
      onErr killMod (findFirstFile fs) $ \ (lbs,fn) -> do
      let hash = MD5.md5lazy $ (LBSU.fromString version) `mappend` lbs
      (foundho,mho) <- findHoFile done_ref fn (fmap fst mm) hash
      done <- readIORef done_ref
      (mod,m,ds) <- case mlookup hash (knownSourceMap done) of
          Just (m,ds) -> return (Left lbs,m,ds)
          Nothing -> do
              (hmod,_) <- parseHsSource modOpt  fn lbs
              let m = hsModuleName hmod
                  ds = hsModuleRequires hmod
              writeIORef done_ref (knownSourceMap_u (Map.insert hash (m,ds)) done)
              case optAnnotate options of
                  Just _ -> return (Left lbs,m,ds)
                  _ -> return (Right hmod,m,ds)
      case mm of
          Just (m',_) | m /= m' -> do
              putErrLn $ "Skipping file" <+> fn <+> "because its module declaration of" <+> show m <+> "does not equal the expected" <+> show m'
              killMod
          _ -> do
              let sc (Right mod) = SourceParsed sinfo mod
                  sc (Left lbs) = SourceRaw sinfo lbs
                  sinfo = SI { sourceHash = hash, sourceDeps = ds, sourceFP = fn, sourceHoName = mho, sourceModName = m }
              modifyIORef done_ref (modEncountered_u $ Map.insert m (Found (sc mod)))
              fn' <- shortenPath fn
              mho' <- shortenPath mho
              putProgressLn $ if foundho
                  then printf "%-23s [%s] <%s>" (show m) fn' mho'
                  else printf "%-23s [%s]" (show m) fn'
              mapM_ (resolveDeps modOpt done_ref) ds
              return m
  
  resolveDeps :: Opt -> IORef Done -> (Module,SrcLoc) -> IO ()
  resolveDeps modOpt done_ref (m,sloc) = do
      done <- readIORef done_ref
      case m `mlookup` modEncountered done of
          Just (ModLibrary False _ lib) | not ("jhc-prim-" `isPrefixOf` libName lib) -> putErrDie $ printf  "ERROR: Attempt to import module '%s' which is a member of the library '%s'.\nPerhaps you need to add '-p%s' to the command line?" (show m) (libName lib) (libName lib)
          Just _ -> return ()
          Nothing -> fetchSource modOpt done_ref (map fst $ searchPaths modOpt (show m)) (Just (m,sloc)) >> return ()
  
  type LibInfo = (Map.Map Module ModuleGroup, Map.Map ModuleGroup [ModuleGroup], Set.Set Module,Map.Map ModuleGroup HoBuild,Map.Map ModuleGroup HoTcInfo)
  
  data CompNode = CompNode !HoHash [CompNode] {-# UNPACK #-} !(IORef CompLink)
  data CompLink
      = CompLinkUnit CompUnit
      | CompCollected CollectedHo CompUnit
      | CompTcCollected HoTcInfo CompUnit
      | CompLinkLib (ModuleGroup,LibInfo) CompUnit
  
  compLinkCompUnit (CompLinkUnit cu) = cu
  compLinkCompUnit (CompCollected _ cu) = cu
  compLinkCompUnit (CompTcCollected _ cu) = cu
  compLinkCompUnit (CompLinkLib _ cu) = cu
  
  instance MapKey Module where
      showMapKey = show
  instance MapKey MD5.Hash where
      showMapKey = show
  
  dumpDeps targets memap cug = case optDeps options of
      Nothing -> return ()
      Just fp -> do
          let (sfps,sdps,ls) = collectDeps memap cug
          let yaml = Map.fromList [
                  ("Target",toNode targets),
                  ("LibraryDesc",toNode [ fp | BuildHl fp  <- [optMode options]]),
                  ("LibraryDeps",toNode ls),
                  ("ModuleSource",toNode sfps),
                  ("ModuleDeps",toNode sdps)
                  ]
          writeFile fp (showYAML yaml)
  
  collectDeps memap cs = mconcatMap f [ cu | (_,(_,cu)) <- cs] where
      f (CompSources ss) = mconcat [ (Map.singleton (sourceModName s) (sourceFP s),Map.singleton (sourceModName s) (fsts $ sourceDeps s),mempty) | s <- map sourceInfo ss ]
      f (CompLibrary _ lib) = (mempty,mempty,Map.singleton (libHash lib) (libFileName lib))
      f (CompHo _hoh idep _ho) = (Map.fromList [ (sourceModName $ sourceInfo src, sourceFP $ sourceInfo src) | s <- fsts ss, Just (Found src) <- [Map.lookup s memap] ],Map.fromList [ (mms,fsts mms') | s <- snds ss, Just (mms,mms') <- [Map.lookup s (hoIDeps idep)] ],mempty) where
          ss = [ s | s <- hoDepends idep ]
      f _ = mempty
  
  type CompUnitGraph = [(HoHash,([HoHash],CompUnit))]
  
  data CompUnit
      = CompHo HoHeader HoIDeps Ho
      | CompSources [SourceCode]
      | CompTCed ((HoTcInfo,TiData,[(HoHash,HsModule)],[String]))
      | CompDummy
      | CompLibrary Ho Library
  
  instance Show CompUnit where
      showsPrec _ = shows . providesModules
  
  data SourceInfo = SI {
      sourceHash :: SourceHash,
      sourceDeps :: [(Module,SrcLoc)],
      sourceFP :: FilePath,
      sourceModName :: Module,
      sourceHoName :: FilePath
      }
  
  data SourceCode
      = SourceParsed     { sourceInfo :: !SourceInfo, sourceModule :: HsModule }
      | SourceRaw        { sourceInfo :: !SourceInfo, sourceLBS :: LBS.ByteString }
  
  sourceIdent = show . sourceModName . sourceInfo
  
  class ProvidesModules a where
      providesModules :: a -> [Module]
      providesModules _ = []
  
  instance ProvidesModules HoIDeps where
      providesModules = fsts . hoDepends
  
  instance ProvidesModules HoLib where
      providesModules = Map.keys . hoModuleMap
  
  instance ProvidesModules CompUnit where
      providesModules (CompHo _ hoh _)   = providesModules hoh
      providesModules (CompSources ss) = concatMap providesModules ss
      providesModules (CompLibrary ho libr) = libProvides (hoModuleGroup ho) libr
      providesModules CompDummy = []
      providesModules (CompTCed _) = error "providesModules: bad1."
  
  instance ProvidesModules CompLink where
      providesModules (CompLinkUnit cu) = providesModules cu
      providesModules (CompCollected _ cu) = providesModules cu
      providesModules (CompTcCollected _ cu) = providesModules cu
      providesModules (CompLinkLib _ _) = error "providesModules: bad2c."
  
  instance ProvidesModules SourceCode where
      providesModules sp = [sourceModName (sourceInfo sp)]
  
  -- | this walks the loaded modules and ho files, discarding out of
  -- date ho files and organizing modules into their binding groups.
  -- the result is an acyclic graph where the nodes are ho files, sets
  -- of mutually recursive modules, or libraries.
  -- there is a strict ordering of
  -- source >= ho >= library
  -- in terms of dependencies
  
  toCompUnitGraph :: Done -> [Module] -> IO (HoHash,CompUnitGraph)
  toCompUnitGraph done roots = do
      let fs m = map inject $ maybe (error $ "can't find deps for: " ++ show m) (fsts . snd) (Map.lookup m (knownSourceMap done))
          fs' m libr = fromMaybe (error $ "can't find deps for: " ++ show m) (Map.lookup m (hoModuleDeps $ libHoLib libr))
          foundMods = [ ((m,Left (sourceHash $ sourceInfo sc)),fs (sourceHash $ sourceInfo sc)) | (m,Found sc) <- Map.toList (modEncountered done)]
          foundMods' = Map.elems $ Map.fromList [ (mg,((mg,Right lib),fs' mg lib)) | (_,ModLibrary _ mg lib) <- Map.toList (modEncountered done)]
          fullModMap = Map.unions (map libModMap $ Map.elems (loadedLibraries done))
          inject m = Map.findWithDefault m m fullModMap
          gr = G.newGraph  (foundMods ++ foundMods') (fst . fst) snd
          gr' = G.sccGroups gr
          phomap = Map.fromListWith (++) (concat [  [ (m,[hh]) | (m,_) <- hoDepends idep ] | (hh,(_,_,idep,_)) <- Map.toList (hosEncountered done)])
          sources = Map.fromList [ (m,sourceHash $ sourceInfo sc) | (m,Found sc) <- Map.toList (modEncountered done)]
  
      when (dump FD.SccModules) $ do
          mapM_ (putErrLn . show) $ map (map $ fst . fst) gr'
          putErrLn $ drawForest (map (fmap (show . fst . fst)) (G.dff gr))
  
      cug_ref <- newIORef []
      hom_ref <- newIORef (Map.map ((,) False) $ hosEncountered done)
      ms <- forM gr' $ \ns -> do
          r <- newIORef (Left ns)
          return (Map.fromList [ (m,r) | ((m,_),_) <- ns ])
      let mods = Map.unions ms
          lmods m = fromMaybe (error $ "modsLookup: " ++ show m) (Map.lookup m mods)
      let f m = do
              rr <- readIORef (lmods m)
              case rr of
                  Right hh -> return hh
                  Left ns -> g ns
  
          g ms@(((m,Left _),_):_) = do
              let amods = map (fst . fst) ms
              pm (fromMaybe [] (Map.lookup m phomap)) $ do
                  let deps = Set.toList $ Set.fromList (concat $ snds ms) `Set.difference` (Set.fromList amods)
                  deps' <- snub `fmap` mapM f deps
                  let mhash = MD5.md5String (concatMap (show . fst) ms ++ show deps')
                  writeIORef (lmods m) (Right mhash)
                  modifyIORef cug_ref ((mhash,(deps',CompSources $ map fs amods)):)
                  return mhash
          g [((mg,Right lib),ds)] = do
                  let Just hob = Map.lookup mg $ libBuildMap lib
                      Just hot = Map.lookup mg $ libTcMap lib
                      ho = Ho { hoModuleGroup = mg, hoBuild = hob, hoTcInfo = hot }
                      myHash = libMgHash mg lib
                  deps <- snub `fmap` mapM f ds
                  writeIORef (lmods mg) (Right myHash)
                  modifyIORef cug_ref ((myHash,(deps,CompLibrary ho lib)):)
                  return myHash
          g _ = error "Build.toCompUnitGraph: bad."
          pm :: [HoHash] -> IO HoHash -> IO HoHash
          pm [] els = els
          pm (h:hs) els = hvalid h `iocatch` (\_ -> pm hs els)
          hvalid h = do
              ll <- Map.lookup h `fmap` readIORef hom_ref
              case ll of
                  Nothing -> fail "Don't know anything about this hash"
                  Just (True,_) -> return h
                  Just (False,af@(fp,hoh,idep,ho)) -> do
                      fp <- shortenPath fp
                      isGood <- iocatch ( mapM_ cdep (hoDepends idep) >> mapM_ hvalid (hoModDepends idep) >> return True) (\_ -> return False)
                      let isStale = not . null $ map (show . fst) (hoDepends idep) `intersect` optStale options
                          libsGood = all (\ (p,h) -> fmap (libHash) (Map.lookup p (loadedLibraries done)) == Just h) (hohLibDeps hoh)
                          noGood forced = do
                              putProgressLn $ printf "Stale: <%s>%s" fp forced
                              modifyIORef hom_ref (Map.delete h)
                              fail "stale file"
                      case (isStale,isGood && libsGood) of
                          (False,True) -> do
                              putProgressLn $ printf "Fresh: <%s>" fp
                              hs <- mapM f (hoModuleGroupNeeds idep)
                              modifyIORef cug_ref ((h,(hs ++ hoModDepends idep,CompHo hoh idep ho)):)
                              modifyIORef hom_ref (Map.insert h (True,af))
                              return h
                          (True,_) -> noGood " (forced)"
                          (_,False) -> noGood ""
          cdep (_,hash) | hash == MD5.emptyHash = return ()
          cdep (mod,hash) = case Map.lookup mod sources of
              Just hash' | hash == hash' -> return ()
              _ -> fail "Can't verify module up to date"
          fs m = case Map.lookup m (modEncountered done) of
              Just (Found sc) -> sc
              _ -> error $ "fs: " ++ show m
      mapM_ f (map inject roots)
      cug <- readIORef cug_ref
      let (rhash,cug') = mkPhonyCompUnit roots cug
      let gr = G.newGraph cug'  fst (fst . snd)
          gr' = G.transitiveReduction gr
      when (dump FD.SccModules) $ do
          putErrLn "ComponentsDeps:"
          mapM_ (putErrLn . show) [ (snd $ snd v, map (snd . snd) vs) | (v,vs) <- G.fromGraph gr']
      return (rhash,[ (h,([ d | (d,_) <- ns ],cu)) | ((h,(_,cu)),ns) <- G.fromGraph gr' ])
  
  parseFiles
      :: Opt                                                  -- ^ Options to use when parsing files
      -> [FilePath]                                           -- ^ Targets we are building, used when dumping dependencies
      -> [String]                                             -- ^ Extra libraries to load
      -> [Either Module FilePath]                             -- ^ Either a module or filename to find
      -> (CollectedHo -> Ho -> IO CollectedHo)                -- ^ Process initial ho loaded from file
      -> (CollectedHo -> Ho -> TiData -> IO (CollectedHo,Ho)) -- ^ Process set of mutually recursive modules to produce final Ho
      -> IO (CompNode,CollectedHo)                            -- ^ Final accumulated ho
  parseFiles options targets elibs need ifunc func = do
      putProgressLn "Finding Dependencies..."
      (ksm,chash,cug) <- loadModules options targets (snub $
          if optNoAuto options then optHls options ++ elibs else
              optAutoLoads options ++ optHls options ++ elibs) bogusASrcLoc need
      cnode <- processCug cug chash
      when (optStop options == StopParse) exitSuccess
      performGC
      putProgressLn "Typechecking..."
      typeCheckGraph options cnode
      if isJust (optAnnotate options) then exitSuccess else do
      when (optStop options  == StopTypeCheck) exitSuccess
      performGC
      putProgressLn "Compiling..."
      cho <- compileCompNode ifunc func ksm cnode
      return (cnode,cho)
  
  -- this takes a list of modules or files to load, and produces a compunit graph
  loadModules
      :: Opt                      -- ^ Options to use when parsing files
      -> [FilePath]               -- ^ targets
      -> [String]                 -- ^ libraries to load
      -> SrcLoc                   -- ^ where these files are requsted from
      -> [Either Module FilePath] -- ^ a list of modules or filenames
      -> IO (Map.Map SourceHash (Module,[(Module,SrcLoc)]),HoHash,CompUnitGraph)  -- ^ the resulting acyclic graph of compilation units
  loadModules modOpt targets libs sloc need = do
      theCache <- findHoCache
      case theCache of
          Just s -> putProgressLn $ printf "Using Ho Cache: '%s'" s
          Nothing -> return ()
      done_ref <- newIORef Done {
          hoCache = theCache,
          knownSourceMap = Map.empty,
          validSources = Set.empty,
          loadedLibraries = Map.empty,
          hosEncountered = Map.empty,
          modEncountered = Map.empty
          }
      (es,is) <- collectLibraries libs
      let combModMap es = Map.unions [ Map.map ((,) l) (hoModuleMap $ libHoLib l) | l <- es]
          explicitModMap = combModMap es
          implicitModMap = combModMap is
          reexported  = Set.fromList [ m | l <- es, (m,_) <- Map.toList $ hoReexports (libHoLib l) ]
          modEnc exp emap = Map.fromList [ (m,ModLibrary (exp || Set.member m reexported)  mg l) | (m,(l,mg)) <- Map.toList emap ]
  
      modifyIORef done_ref (loadedLibraries_u $ Map.union $ Map.fromList [ (libBaseName lib,lib) | lib <- es ++ is])
      modifyIORef done_ref (modEncountered_u $ Map.union (modEnc True explicitModMap))
      modifyIORef done_ref (modEncountered_u $ Map.union (modEnc False implicitModMap))
  
      forM_ (concatMap libExtraFiles (es ++ is)) $ \ef -> do
          fileInTempDir ("cbits/" ++ unpackPS (extraFileName ef)) $ \fn -> BS.writeFile fn (extraFileData ef)
  
      done <- readIORef done_ref
      forM_ (Map.elems $ loadedLibraries done) $ \ lib -> do
          let libsBad = filter (\ (p,h) -> fmap (libHash) (Map.lookup p (loadedLibraries done)) /= Just h) (hohLibDeps $ libHoHeader lib)
          unless (null libsBad) $ do
              putErr $ printf "Library Dependencies not met. %s needs\n" (libName lib)
              forM_ libsBad $ \ (p,h) -> putErr $ printf "    %s (hash:%s)\n" (unpackPS p) (show h)
              putErrDie "\n"
      ms1 <- forM (rights need) $ \fn -> do
          fetchSource modOpt done_ref [fn] Nothing
      forM_ (map (,sloc) $ lefts need) $ resolveDeps modOpt done_ref
      processIOErrors
      done <- readIORef done_ref
      let needed = (ms1 ++ lefts need)
      (chash,cug) <- toCompUnitGraph done needed
      dumpDeps targets (modEncountered done) cug
      return (Map.filterWithKey (\k _ -> k `Set.member` validSources done) (knownSourceMap done),chash,cug)
  
  -- turn the list of CompUnits into a true mutable graph.
  processCug :: CompUnitGraph -> HoHash -> IO CompNode
  processCug cug root = mdo
      let mmap = Map.fromList xs
          lup x = maybe (error $ "processCug: " ++ show x) id (Map.lookup x mmap)
          f (h,(ds,cu)) = do
              cur <- newIORef (CompLinkUnit cu)
              return $ (h,CompNode h (map lup ds) cur)
      xs <- mapM f cug
      Just x <- return $ Map.lookup root mmap
      return $ x
  
  mkPhonyCompUnit :: [Module] -> CompUnitGraph -> (HoHash,CompUnitGraph)
  mkPhonyCompUnit need cs = (fhash,(fhash,(fdeps,CompDummy)):cs) where
          fhash = MD5.md5String $ show (sort fdeps)
          fdeps = [ h | (h,(_,cu)) <- cs, not . null $ providesModules cu `intersect` need ]
  
  printModProgress :: Int -> Int -> IO Int -> [HsModule] -> IO ()
  printModProgress _ _ _ [] = return ()
  printModProgress _ _ tickProgress ms | not progress = mapM_ (const tickProgress) ms
  printModProgress fmtLen maxModules tickProgress ms = f "[" ms where
      f bl ms = do
          curModule <- tickProgress
          case ms of
              [x] -> g curModule bl "]" x
              (x:xs) -> do g curModule bl "-" x; putErrLn ""; f "-" xs
              _ -> error "Build.printModProgress: bad."
      g curModule bl el modName = putErr $ printf "%s%*d of %*d%s %-17s" bl fmtLen curModule fmtLen maxModules el (show $ hsModuleName modName)
  
  countNodes cn = do
      seen <- newIORef Set.empty
      let h (CompNode hh deps ref) = do
              s <- readIORef seen
              if hh `Set.member` s then return Set.empty else do
                  writeIORef seen (Set.insert hh s)
                  ds <- mapM h deps
                  cm <- readIORef ref >>= g
                  return (Set.unions (cm:ds))
          g cn = case cn of
              CompLinkUnit cu      -> return $ f cu
              CompTcCollected _ cu -> return $ f cu
              CompCollected _ cu   -> return $ f cu
              CompLinkLib _ _      -> error "Build.countNodes: bad."
          f cu = case cu of
              CompTCed (_,_,_,ss) -> Set.fromList ss
              CompSources sc      -> Set.fromList (map sourceIdent sc)
              _                   -> Set.empty
      h cn
  
  typeCheckGraph :: Opt -> CompNode -> IO ()
  typeCheckGraph modOpt cn = do
      cur <- newMVar (1::Int)
      maxModules <- Set.size `fmap` countNodes cn
      let f (CompNode hh deps ref) = readIORef ref >>= \cn -> case cn of
              CompTcCollected ctc _ -> return ctc
              CompLinkUnit lu -> do
                  deps' <- randomPermuteIO deps
                  ctc <- mconcat `fmap` mapM f deps'
                  case lu of
                      CompDummy -> do
                          writeIORef ref (CompTcCollected ctc CompDummy)
                          return ctc
                      CompHo hoh idep ho  -> do
                          let ctc' = hoTcInfo ho `mappend` ctc
                          writeIORef ref (CompTcCollected ctc' lu)
                          return ctc'
                      CompLibrary ho _libr  -> do
                          let ctc' = hoTcInfo ho `mappend` ctc
                          writeIORef ref (CompTcCollected ctc' lu)
                          return ctc'
                      CompSources sc -> do
                          let mods = sort $ map (sourceModName . sourceInfo) sc
                          modules <- forM sc $ \x -> case x of
                              SourceParsed { sourceInfo = si, sourceModule = sm } ->
                                  return (sourceHash si, sm, error "SourceParsed in AnnotateSource")
                              SourceRaw { sourceInfo = si, sourceLBS = lbs } -> do
                                  (mod,lbs') <- parseHsSource modOpt (sourceFP si) lbs
                                  case optAnnotate modOpt of
                                      Just fp -> do
                                          let ann = LBSU.fromString $ unlines [
                                                  "{- --ANNOTATE--",
                                                  "Module: " ++ show (sourceModName si),
                                                  "Deps: " ++ show (sort $ fsts $ sourceDeps si),
                                                  "Siblings: " ++ show mods,
                                                  "-}"]
                                          LBS.writeFile (fp ++ "/" ++ show (hsModuleName mod) ++ ".hs") (ann `LBS.append` lbs')
                                      _ -> return ()
                                  return (sourceHash si,mod,lbs')
                          showProgress (map snd3 modules)
                          (htc,tidata) <- doModules ctc (map snd3 modules)
                          let ctc' = htc `mappend` ctc
                          writeIORef ref (CompTcCollected ctc' (CompTCed ((htc,tidata,[ (x,y) | (x,y,_) <- modules],map (sourceHoName . sourceInfo) sc))))
                          return ctc'
                      _ -> error "Build.typeCheckGraph: bad1."
              _ -> error "Build.typeCheckGraph: bad2."
          showProgress ms = printModProgress fmtLen maxModules tickProgress ms
          fmtLen = ceiling (logBase 10 (fromIntegral maxModules+1) :: Double) :: Int
          tickProgress = modifyMVar cur $ \val -> return (val+1,val)
      f cn
      return ()
  
  compileCompNode :: (CollectedHo -> Ho -> IO CollectedHo)                 -- ^ Process initial ho loaded from file
                  -> (CollectedHo -> Ho -> TiData  -> IO (CollectedHo,Ho)) -- ^ Process set of mutually recursive modules to produce final Ho
                  -> Map.Map SourceHash (Module,[(Module,SrcLoc)])
                  -> CompNode
                  -> IO CollectedHo
  compileCompNode ifunc func ksm cn = do
      cur <- newMVar (1::Int)
      ksm_r <- newIORef ksm
      let tickProgress = modifyMVar cur $ \val -> return (val+1,val)
      maxModules <- Set.size `fmap` countNodes cn
      let showProgress ms = printModProgress fmtLen maxModules tickProgress ms
          fmtLen = ceiling (logBase 10 (fromIntegral maxModules+1) :: Double) :: Int
      let f (CompNode hh deps ref) = readIORef ref >>= g where
              g cn = case cn of
                  CompCollected ch _ -> return ch
                  CompTcCollected _ cl -> h cl
                  CompLinkUnit cu -> h cu
                  _ -> error "Build.compileCompNode: bad."
              h cu = do
                  deps' <- randomPermuteIO deps
                  cho <- mconcat `fmap` mapM f deps'
  
                  case cu of
                      CompDummy -> do
                          writeIORef ref (CompCollected cho CompDummy)
                          return cho
                      (CompHo hoh idep ho) -> do
                          cho <- choLibDeps_u (Map.union $ Map.fromList (hohLibDeps hoh)) `fmap` ifunc cho ho
                          writeIORef ref (CompCollected cho cu)
                          return cho
                      (CompLibrary ho Library { libHoHeader = hoh }) -> do
                          cho <- ifunc cho ho
                          let Right (ln,_) = hohName hoh
                              lh = hohHash hoh
                              cho' = (choLibDeps_u (Map.insert ln lh) cho)
                          writeIORef ref (CompCollected cho' cu)
                          return cho'
                      CompTCed ((htc,tidata,modules,shns))  -> do
                          (hdep,ldep) <- fmap mconcat . forM deps $ \ (CompNode h _ ref) -> do
                              cl <- readIORef ref
                              case compLinkCompUnit cl of
                                  CompLibrary ho _ -> return ([],[hoModuleGroup ho])
                                  CompDummy {} -> return ([],[])
                                  _ -> return ([h],[])
                          showProgress (snds modules)
                          let (mgName:_) = sort $ map (hsModuleName . snd) modules
                          (cho',newHo) <- func cho mempty { hoModuleGroup = mgName, hoTcInfo = htc } tidata
                          modifyIORef ksm_r (Map.union $ Map.fromList [ (h,(hsModuleName mod, hsModuleRequires mod)) | (h,mod) <- modules])
                          ksm <- readIORef ksm_r
                          let hoh = HoHeader {
                                       hohVersion = error "hohVersion",
                                       hohName = Left mgName,
                                       hohHash       = hh,
                                       hohArchDeps = [],
                                       hohLibDeps   = Map.toList (choLibDeps cho')
                                       }
                              idep = HoIDeps {
                                      hoIDeps      = ksm,
                                      hoDepends    = [ (hsModuleName mod,h) | (h,mod) <- modules],
                                      hoModDepends = hdep,
                                      hoModuleGroupNeeds = ldep
                                      }
                          recordHoFile (mapHoBodies eraseE newHo) idep shns hoh
                          writeIORef ref (CompCollected cho' (CompHo hoh idep newHo))
                          return cho'
                      CompSources _ -> error "sources still exist!?"
      f cn
  
  hsModuleRequires x = snub ((toModule "Jhc.Prim.Prim",bogusASrcLoc):ans) where
      noPrelude = FO.Prelude `Set.notMember` optFOptsSet (hsModuleOpt x)
      ans = (if noPrelude then id else ((preludeModule,bogusASrcLoc):)) [  (hsImportDeclModule y,hsImportDeclSrcLoc y) | y <- hsModuleImports x]
  
  searchPaths :: Opt -> String -> [(String,String)]
  searchPaths modOpt m = ans where
      f m | (xs,'.':ys) <- span (/= '.') m = let n = (xs ++ "/" ++ ys) in m:f n
          | otherwise = [m]
      ans = [ (root ++ suf,root ++ ".ho") | i <- optIncdirs modOpt, n <- f m, suf <- [".hs",".lhs",".hsc"], let root = i ++ "/" ++ n]
  
  mapHoBodies  :: (E -> E) -> Ho -> Ho
  mapHoBodies sm ho = ho { hoBuild = g (hoBuild ho) } where
      g ho = ho { hoEs = map f (hoEs ho) , hoRules =  runIdentity (E.Rules.mapBodies (return . sm) (hoRules ho)) }
      f (t,e) = (t,sm e)
  
  eraseE :: E -> E
  eraseE e = runIdentity $ f e where
      f (EVar tv) = return $ EVar  tvr { tvrIdent = tvrIdent tv }
      f e = emapE f e
  
  ---------------------------------
  -- library specific routines
  ---------------------------------
  
  buildLibrary :: (CollectedHo -> Ho -> IO CollectedHo)
               -> (CollectedHo -> Ho -> TiData -> IO (CollectedHo,Ho)) -- ^ Process set of mutually recursive modules to produce final Ho
               -> FilePath
               -> IO ()
  buildLibrary ifunc func = ans where
      ans fp = do
          (desc,name,vers,hmods,emods,modOpts,sources) <- parse fp
          vers <- runReadP parseVersion vers
          let allMods = emodSet `Set.union` hmodSet
              emodSet = Set.fromList emods
              hmodSet = Set.fromList hmods
          let outName = case optOutName modOpts of
                  Nothing -> name ++ "-" ++ showVersion vers ++ ".hl"
                  Just fn -> fn
          -- TODO - must check we depend only on libraries
          (rnode@(CompNode lhash _ _),cho) <- parseFiles modOpts [outName] [] (map Left $ Set.toList allMods) ifunc func
          (_,(mmap,mdeps,prvds,lcor,ldef)) <- let
              f (CompNode hs cd ref) = do
                  cl <- readIORef ref
                  case cl of
                      CompLinkLib l _ -> return l
                      CompCollected _ y -> g hs cd ref y
                      _ -> error "Build.buildLibrary: bad1."
              g hh deps ref cn = do
                  deps <- mapM f deps
                  let (mg,mll) = case cn of
                          CompDummy -> (error "modgroup of dummy",mempty)
                          CompLibrary ho lib -> (hoModuleGroup ho,mempty)
                          CompHo hoh hidep ho -> (mg,(
                                      Map.fromList $ zip (providesModules hidep) (repeat mg),
                                      Map.singleton mg (sort $ fsts deps),
                                      Set.fromList $ providesModules hidep,
                                      Map.singleton mg (hoBuild ho'),
                                      Map.singleton mg (hoTcInfo ho')
                                      )) where
                                          mg = hoModuleGroup ho
                                          ho' = mapHoBodies eraseE ho
                          _ -> error "Build.buildLibrary: bad2."
                      res = (mg,mconcat (snds deps) `mappend` mll)
                  writeIORef ref (CompLinkLib res cn)
                  return res
            in f rnode
          let unknownMods = Set.toList $ Set.filter (`Set.notMember` allMods) prvds
          mapM_ ((putStrLn . ("*** Module depended on in library that is not in export list: " ++)) . show) unknownMods
          mapM_ ((putStrLn . ("*** We are re-exporting the following modules from other libraries: " ++)) . show) $ Set.toList (allMods Set.\\ prvds)
          let hoh =  HoHeader {
                  hohHash = lhash,
                  hohName = Right (packString name,vers),
                  hohLibDeps = Map.toList (choLibDeps cho),
                  hohArchDeps = [],
                  hohVersion = error "hohVersion"
                  }
          let pdesc = [(packString n, packString v) | (n,v) <- ("jhc-hl-filename",outName):("jhc-description-file",fp):("jhc-compiled-by",versionString):desc, n /= "exposed-modules" ]
              libr = HoLib {
                  hoReexports = Map.fromList [ (m,m) | m <- Set.toList $ allMods Set.\\ prvds ],
                  hoMetaInfo = pdesc,
                  hoModuleMap = mmap,
                  hoModuleDeps = mdeps
                  }
          putProgressLn $ "Writing Library: " ++ outName
          efs <- mapM fetchExtraFile sources
          recordHlFile Library { libHoHeader = hoh, libHoLib =  libr, libTcMap = ldef,
              libBuildMap = lcor, libFileName = outName, libExtraFiles = efs }
      -- parse library description file
      parse fp = do
          putProgressLn $ "Creating library from description file: " ++ show fp
          LibDesc dlist dsing <- readDescFile fp
          when verbose2 $ do
              mapM_ print (Map.toList dlist)
              mapM_ print (Map.toList dsing)
          let jfield x = maybe (fail $ "createLibrary: description lacks required field " ++ show x) return $ Map.lookup x dsing
              mfield x = maybe [] id $ Map.lookup x dlist
              --mfield x = maybe [] (words . map (\c -> if c == ',' then ' ' else c)) $ Map.lookup x dlist
          name <- jfield "name"
          vers <- jfield "version"
          let (modOpts,flags) = (lproc bopt,modOptions) where
                  Just bopt = fileOptions options modOptions `mplus` Just options
                  (pfs,nfs,_) = languageFlags (mfield "extensions")
                  lproc opt = opt { optFOptsSet = Set.union pfs (optFOptsSet opt) Set.\\ nfs }
                  dirs = [ "-i" ++ dd x | x <- mfield "hs-source-dirs" ]
                      ++ [ "-I" ++ dd x | x <- mfield "include-dirs" ]
                      ++ [ "-p" ++ x | x <- mfield "build-depends" ]
                  modOptions =  (mfield "options" ++ dirs)
                  dd "." = FP.takeDirectory fp
                  dd ('.':'/':x) = dd x
                  dd x = FP.takeDirectory fp FP.</> x
          when verbose $
              print (flags,optFOptsSet modOpts)
          let hmods = map toModule $ snub $ mfield "hidden-modules"
              emods = map toModule $ snub $ mfield "exposed-modules"
              sources = map (FP.takeDirectory fp FP.</>) $ snub $ mfield "c-sources" ++ mfield "include-sources"
          return (Map.toList dsing,name,vers,hmods,emods,modOpts,sources)
  
  fetchExtraFile fp = do
      c <- BS.readFile fp
      return ExtraFile { extraFileName = packString (FP.takeFileName fp),
                         extraFileData = c }
  
  ------------------------------------
  -- dumping contents of a ho file
  ------------------------------------
  
  instance DocLike d => PPrint d MD5.Hash where
      pprint h = tshow h
  
  instance DocLike d => PPrint d SrcLoc where
      pprint sl = tshow sl
  
  instance DocLike d => PPrint d Version where
      pprint sl = text $ showVersion sl
  
  instance DocLike d => PPrint d PackedString where
      pprint sl = text (unpackPS sl)
  
  {-# NOINLINE dumpHoFile #-}
  dumpHoFile :: String -> IO ()
  dumpHoFile fn = ans where
      ans = do
          putStrLn fn
          case reverse fn of
              'l':'h':'.':_ -> doHl fn
              'o':'h':'.':_ -> doHo fn
              _ -> putErrDie "Error: --show-ho requires a .hl or .ho file"
      vindent xs = vcat (map ("    " ++) xs)
      showList nm xs = when (not $ null xs) $ putStrLn $ (nm ++ ":\n") <>  vindent xs
      doHoh hoh = do
          putStrLn $ "Version:" <+> pprint (hohVersion hoh)
          putStrLn $ "Hash:" <+> pprint (hohHash hoh)
          putStrLn $ "Name:" <+> pprint (hohName hoh)
          showList "LibDeps" (map pprint . sortUnder fst $ hohLibDeps hoh)
          showList "ArchDeps" (map pprint . sortUnder fst $ hohArchDeps hoh)
      doHl fn = do
          l <- readHlFile fn
          doHoh $ libHoHeader l
          showList "MetaInfo" (sort [text (unpackPS k) <> char ':' <+> show v |
                                     (k,v) <- hoMetaInfo (libHoLib l)])
          showList "ModuleMap" (map pprint . sortUnder fst $ Map.toList $ hoModuleMap $ libHoLib l)
          showList "ModuleDeps" (map pprint . sortUnder fst $ Map.toList $ hoModuleDeps $ libHoLib l)
          showList "ModuleReexports" (map pprint . sortUnder fst $ Map.toList $ hoReexports $ libHoLib l)
          forM_ (Map.toList $ libBuildMap l) $ \ (g,hoB) -> do
              print g
              doHoB hoB
      doHo fn = do
          (hoh,idep,ho) <- readHoFile fn
          doHoh hoh
          let hoB = hoBuild ho
              hoE = hoTcInfo ho
          showList "Dependencies" (map pprint . sortUnder fst $ hoDepends idep)
          showList "ModDependencies" (map pprint $ hoModDepends idep)
          showList "IDepCache" (map pprint . sortUnder fst $ Map.toList $ hoIDeps idep)
          putStrLn $ "Modules contained:" <+> tshow (keys $ hoExports hoE)
          putStrLn $ "number of definitions:" <+> tshow (size $ hoDefs hoE)
          putStrLn $ "hoAssumps:" <+> tshow (size $ hoAssumps hoE)
          putStrLn $ "hoFixities:" <+> tshow (size $  hoFixities hoE)
          putStrLn $ "hoKinds:" <+> tshow (size $  hoKinds hoE)
          putStrLn $ "hoClassHierarchy:" <+> tshow (length $ classRecords $ hoClassHierarchy hoE)
          putStrLn $ "hoTypeSynonyms:" <+> tshow (size $  hoTypeSynonyms hoE)
          wdump FD.Exports $ do
              putStrLn "---- exports information ----";
              putStrLn $  (pprint $ hoExports hoE :: String)
          wdump FD.Defs $ do
              putStrLn "---- defs information ----";
              putStrLn $  (pprint $ hoDefs hoE :: String)
          when (dump FD.Kind) $ do
              putStrLn "---- kind information ----";
              putStrLn $  (pprint $ hoKinds hoE :: String)
          when (dump FD.ClassSummary) $ do
              putStrLn "---- class summary ---- "
              printClassSummary (hoClassHierarchy hoE)
          when (dump FD.Class) $
               do {putStrLn "---- class hierarchy ---- ";
                   printClassHierarchy (hoClassHierarchy hoE)}
          wdump FD.Types $ do
              putStrLn " ---- the types of identifiers ---- "
              putStrLn $ PPrint.render $ pprint (hoAssumps hoE)
          doHoB hoB
      doHoB hoB = do
          putStrLn $ "hoDataTable:" <+> tshow (size $  hoDataTable hoB)
          putStrLn $ "hoEs:" <+> tshow (size $  hoEs hoB)
          putStrLn $ "hoRules:" <+> tshow (size $  hoRules hoB)
          let rules = hoRules hoB
          wdump FD.Rules $ putStrLn "  ---- user rules ---- " >> printRules RuleUser rules
          wdump FD.Rules $ putStrLn "  ---- user catalysts ---- " >> printRules RuleCatalyst rules
          wdump FD.RulesSpec $ putStrLn "  ---- specializations ---- " >> printRules RuleSpecialization rules
          wdump FD.Datatable $ do
               putStrLn "  ---- data table ---- "
               putDocM putStr (showDataTable (hoDataTable hoB))
               putChar '\n'
          wdump FD.Core $ do
              putStrLn " ---- lambdacube  ---- "
              mapM_ (\ (v,lc) -> putChar '\n' >> printCheckName'' (hoDataTable hoB) v lc) (hoEs hoB)
      printCheckName'' :: DataTable -> TVr -> E -> IO ()
      printCheckName'' _dataTable tvr e = do
          when (dump FD.EInfo || verbose2) $ putStrLn (show $ tvrInfo tvr)
          putStrLn (render $ hang 4 (pprint tvr <+> text "::" <+> pprint (tvrType tvr)))
          putStrLn (render $ hang 4 (pprint tvr <+> equals <+> pprint e))
  