[beginning of new dependency chasing algorithm
John Meacham <john@repetae.net>**20080212105938] hunk ./Ho/Build.hs 5
-    hoToProgram,
+    doDependency,
hunk ./Ho/Build.hs 19
+import Text.Printf
hunk ./Ho/Build.hs 37
-import E.Program
hunk ./Ho/Build.hs 77
--- IDEF - immutable import information
+-- IDEP - immutable import information
+-- RDRT - redirect to another file for systems without symlinks
hunk ./Ho/Build.hs 87
+cff_rdrt  = chunkType "RDRT"
hunk ./Ho/Build.hs 91
-cff_idef  = chunkType "IDEF"
+cff_idep  = chunkType "IDEP"
hunk ./Ho/Build.hs 112
-findFirstFile :: String -> [(String,a)] -> IO (LBS.ByteString,FileName,a)
+findFirstFile :: String -> [(FilePath,a)] -> IO (LBS.ByteString,FileName,a)
hunk ./Ho/Build.hs 136
+type SourceHash = MD5.Hash
+type HoHash     = MD5.Hash
+
+
+data ModDone
+    = ModNotFound
+    | ModLibrary String
+    | Found SourceCode
+
+data Done = Done {
+    knownSourceMap :: Map.Map SourceHash (Module,[Module]),
+    hosEncountered :: Map.Map HoHash     (FilePath,HoHeader,Ho),
+    modEncountered :: Map.Map Module     ModDone
+    }
+    {-! derive: Monoid, update !-}
+
+fileOrModule f = case reverse f of
+                   ('s':'h':'.':_)     -> Right f
+                   ('s':'h':'l':'.':_) -> Right f
+                   _                   -> Left $ Module f
+
+{-# NOINLINE doDependency #-}
+doDependency :: [String] -> IO ()
+doDependency as = do
+    done_ref <- newIORef mempty;
+    let f (Right f) = fetchSource done_ref [f] Nothing >> return ()
+        f (Left m) = resolveDeps done_ref m
+    mapM_ (f . fileOrModule) as
+    sm <- knownSourceMap `fmap` readIORef done_ref
+    mapM_ print $ melems sm
+
+replaceSuffix suffix fp = reverse (dropWhile ('.' /=) (reverse fp)) ++ suffix
+
+findHoFile :: IORef Done -> FilePath -> Maybe Module -> SourceHash -> IO (Maybe FilePath)
+findHoFile done_ref fp _ sh = do
+    done <- readIORef done_ref
+    if sh `Map.member` knownSourceMap done then return Nothing else do
+    let honame = reverse ('o':'h':dropWhile ('.' /=) (reverse fp))
+    onErr (return Nothing) (readHoFile honame) $ \ (hoh,hidep,ho) -> do
+        case hohHash hoh `Map.lookup` hosEncountered done of
+            Just (fn,_,_a) -> return (Just fn)
+            Nothing -> do
+                honame <- shortenPath honame
+                --putVerboseLn $ printf "Found Ho:     %-20s [%s]" "" honame
+                modifyIORef done_ref (knownSourceMap_u $ mappend (hoIDeps hidep))
+                modifyIORef done_ref (hosEncountered_u $ Map.insert (hohHash hoh) (honame,hoh,ho))
+                return (Just honame)
+
+
+
+onErr :: IO a -> IO b -> (b -> IO a) -> IO a
+onErr err good cont = catch (good >>= \c -> return (cont c)) (\_ -> return err) >>= id
+
+fetchSource :: IORef Done -> [FilePath] -> Maybe Module -> IO Module
+fetchSource _ [] _ = fail "No files to load"
+fetchSource done_ref fs mm = do
+    let mod = maybe (head fs) show mm
+        killMod = case mm of
+            Nothing -> fail $ "Could not load file: " ++ show fs
+            Just m -> modifyIORef done_ref (modEncountered_u $ Map.insert m ModNotFound) >> return m
+    onErr killMod (findFirstFile mod [ (f,undefined) | f <- fs]) $ \ (lbs,fn,_) -> do
+    let hash = MD5.md5lazy lbs
+    mho <- findHoFile done_ref fn mm hash
+    done <- readIORef done_ref
+    (mod,m,ds) <- case mlookup hash (knownSourceMap done) of
+        Just (m,ds) -> do return (Left lbs,m,ds)
+        Nothing -> do
+            hmod <- parseHsSource fn lbs
+            let m = hsModuleName hmod
+                ds = hsModuleRequires hmod
+            writeIORef done_ref (knownSourceMap_u (Map.insert hash (m,ds)) done)
+            return (Right hmod,m,ds)
+    case mm of
+        Just m' | m /= m' -> do
+            putErrLn $ "Skipping file" <+> fn <+> "because it's module declaration of" <+> show m <+> "does not equal the expected" <+> show m'
+            killMod
+        _ -> do
+            fn' <- shortenPath fn
+            let sc (Right mod) = SourceParsed hash ds mod fn
+                sc (Left lbs) = SourceRaw hash ds m lbs fn
+            modifyIORef done_ref (modEncountered_u $ Map.insert m (Found (sc mod)))
+            case mho of
+                Nothing -> putVerboseLn $ printf "%-23s [%s]" (show m) fn'
+                Just ho -> putVerboseLn $ printf "%-23s [%s] <%s>" (show m) fn' ho
+            mapM_ (resolveDeps done_ref) ds
+            return m
+
+resolveDeps :: IORef Done -> Module -> IO ()
+resolveDeps done_ref m = do
+    done <- readIORef done_ref
+    if isJust $ m `mlookup` modEncountered done then return () else do
+    fetchSource done_ref (map fst $ searchPaths (show m)) (Just m)
+    return ()
+
+
+
+
hunk ./Ho/Build.hs 266
-    Just (hoh,ho) <- checkForHoFile ho_name
+    Just (hoh,_,ho) <- checkForHoFile ho_name
hunk ./Ho/Build.hs 284
-    putVerboseLn $ "Found ho file:   " <+> ho_name'
+    putVerboseLn $ printf "Found Ho:     [%s]" ho_name'
hunk ./Ho/Build.hs 338
+data SourceCode
+    = SourceParsed { sourceHash :: SourceHash, sourceDeps :: [Module], sourceModule :: HsModule, sourceFP :: FilePath }
+    | SourceRaw    { sourceHash :: SourceHash, sourceDeps :: [Module], sourceModName :: Module, sourceLBS :: LBS.ByteString, sourceFP :: FilePath }
+
+
+sourceIdent SourceParsed { sourceModule = m } = show $ hsModuleName m
+sourceIdent SourceRaw { sourceModName = fp } = show fp
+
+data CompUnit
+    = CompLibrary String
+    | CompHo      (HoHeader,Ho)
+    | CompSources [SourceCode]
+
+type CompUnitGraph = [(HoHash,([HoHash],CompUnit))]
+
+showCUnit (hash,(deps,cu)) = printf "%s : %s" (show hash) (show deps)  ++ "\n" ++ f cu where
+    f (CompLibrary s) = s
+    f (CompHo _) = "ho"
+    f (CompSources ss) = show $ map sourceIdent ss
+
+
+data PUnit
+    = PUnit [((Module,SourceHash),[Module])]
+    | FUnit HoHash
+
+toCompUnitGraph :: Done -> [Module] -> IO CompUnitGraph
+toCompUnitGraph done roots = do
+    let fs m = maybe (error $ "can't find deps for: " ++ show m) snd (Map.lookup m (knownSourceMap done))
+        gr = G.newGraph  [ ((m,sourceHash sc),fs (sourceHash sc)) | (m,Found sc) <- Map.toList (modEncountered done)] (fst . fst) snd
+        gr' = G.sccGroups gr
+        phomap = Map.fromListWith (++) (concat [  [ (m,[hh]) | (m,_) <- hohDepends hoh ] | (hh,(_,hoh,_)) <- Map.toList (hosEncountered done)])
+    putErrLn $ drawForest (map (fmap (show . fst . fst)) (G.dff gr))
+
+    cug_ref <- newIORef []
+    hom_ref <- newIORef (hosEncountered done)
+    ms <- forM gr' $ \ns -> do
+            r <- newIORef (PUnit ns)
+            return [ (m,r) | ((m,_),_) <- ns ]
+    let mods = Map.fromList (concat ms)
+    let f m = do
+            rr <- Map.lookup m mods  >>= readIORef
+            case rr of
+                FUnit hh -> return hh
+                PUnit ns -> g ns
+        g ms@(((m,_),ds):_) = do
+            let amods = map (fst . fst) ms
+            pm (join (Map.lookup m phomap)) $ do
+                let deps = Set.toList $ Set.fromList (concat $ snds ms) `Set.difference` (Set.fromList (map (fst . fst) ms))
+                deps' <- snub `fmap` mapM f deps
+                let mhash = MD5.md5String (concatMap (show . fst) ms ++ show deps')
+                Map.lookup m mods >>= flip writeIORef (FUnit mhash)
+                let cunit = CompSources $ map fs amods
+                modifyIORef cug_ref ((mhash,(deps',cunit)):)
+                return mhash
+        pm :: [HoHash] -> IO HoHash -> IO HoHash
+        pm _ els = els
+        pm [] els = els
+--        pm (h:hs) els = do
+--            ll <- Map.lookup h `fmap` readIORef hom_ref
+--            case ll of
+--                Nothing -> els
+--                Just
+
+
+        fs m = case Map.lookup m (modEncountered done) of
+            Just (Found sc) -> sc
+            _ -> error $ "fs: " ++ show m
+    mapM_ f roots
+    readIORef cug_ref
+
hunk ./Ho/Build.hs 417
+    done_ref <- newIORef mempty
+
+    unless (null $ optHls options) $ putVerboseLn $ "Loading libraries:" <+> show (optHls options)
+    forM_ (optHls options) $ \l -> do
+        (n',fn) <- findLibrary l
+        (hoh,_,ho) <- catch (readHoFile fn) $ \_ ->
+            --putErrLn $ "Error loading library file: " ++ fn
+            fail $ "Error loading library file: " ++ fn
+        putVerboseLn $ printf "%-15s <%s>" n' fn
+        modifyIORef done_ref (hosEncountered_u $ Map.insert (hohHash hoh) (n',hoh,ho))
+        modifyIORef done_ref (modEncountered_u $ Map.union (Map.fromList [ (m,ModLibrary n') | (m,_) <- hohDepends hoh]))
+    ms1 <- forM (rights need) $ \fn -> do
+        fetchSource done_ref [fn] Nothing
+    forM_ (lefts need) $ resolveDeps done_ref
+    processIOErrors
+
+    let roots = ms1 ++ lefts need
+
+    done <- readIORef done_ref
+    cug <- toCompUnitGraph done roots
+    mapM_ (putStrLn . showCUnit) cug
+
+
+    let f ho libHo [] = processIOErrors >> return (ho,mempty,libHo)
+        f ho libHo (sc:scs) = do
+            modules <- forM sc $ \x -> case x of
+                SourceParsed { sourceHash = h,sourceModule = mod } -> return (h,mod)
+                SourceRaw { sourceHash = h,sourceLBS = lbs, sourceFP = fp } -> parseHsSource fp lbs >>= return . (,) h 
+            (cho',newHo) <- func ho (snds modules)
+            let mods = [ hsModuleName hs | hs <- snds modules ]
+                mods' = snub [ m  | hs <- snds modules, m <- hsModuleRequires hs, m `notElem` mods]
+                mdeps = [ (m,dep) | m <- mods', dep <- Map.lookup m (choModules cho')]
+            let hoh = fillInHohHash HoHeader {
+                                 hohDepends    = [ (hsModuleName mod,h) | (h,mod) <- modules],
+                                 hohModDepends = mdeps,
+                                 hohHash = error "fillInHohHash - hoHash",
+                                 hohMetaInfo   = []
+                               }
+            recordHoFile newHo (map (replaceSuffix "ho" . sourceFP) sc) hoh
+            f (cho' `mappend` mempty { choFiles = Map.fromList $ hohDepends hoh, choModules = mprovides hoh }) (libHo `mappend` newHo)  scs
+        mprovides hoh = Map.fromList [ (x,hohHash hoh) | (x,_) <- hohDepends hoh]
+
+    let sccm = G.sccGroups $ G.newGraph cug fst (fst . snd)
+    let readHo = mconcat [ ho | [(_,(_,CompHo (_,ho)))] <- sccm ]
+    cho <- ifunc mempty (mempty { hoBuild = mempty { hoDataTable = dataTablePrims } } `mappend` readHo)
+    f cho mempty [ ss | [(_,(_,CompSources ss))] <- sccm ]
+
+
+    {-
+            Just mp <- Map.lookup m `fmap` readIORef r_dm
+            case mp of
+                ModuleParsed { modParsed = hs, modHash = fd, modHoName = s } -> do
+                    (mp,readHo,libHo,rs) <- f (hsModuleRequires hs ++ xs) (Set.insert m ds)
+                    return (mp `mappend` mempty { choFiles = Map.singleton m fd },readHo,libHo,((hs,(m,fd),s):rs))
+                ModuleHo hoh ho -> do
+                    let ss = Set.fromList $ fsts (hohDepends hoh)
+                    (mp,readHo,(libDeps,libHo),rs) <- f (fsts (hohModDepends hoh) ++ xs) (Set.union ss ds)
+                    let mp' = mp `mappend` mempty { choModules = mprovides hoh, choFiles = Map.fromList $ hohDepends hoh }
+                        ho' = ho `mappend` readHo
+                    case hohMetaInfo hoh of
+                        [] -> return (mp', ho',(libDeps,libHo `mappend` ho),rs)
+                        _  -> return (mp', ho',((m,hohHash hoh):libDeps,libHo),rs)
+                ModuleNotThere -> fail $ "Module not found:" <+> show m
+                ModuleNoHo -> fail $ "Module noho:" <+> show m
+        f [] _ = return (mempty,mempty,mempty,mempty)
+        mprovides hoh = Map.fromList [ (x,hohHash hoh) | (x,_) <- hohDepends hoh]
+    (cho,readHo,(libDeps,libHo), ms) <- f (concat ms) Set.empty
+    writeIORef r_dm (error "r_dm")  -- to encourage garbage collection.
+    let mgraph =  (G.newGraph ms (fromModule . hsModuleName . fst3) (hsModuleRequires' . fst3) )
+        scc = G.sccGroups mgraph
+        mgraph' =  (G.newGraph scc (fromModule . hsModuleName . fst3 . head) (concatMap ff . concatMap (hsModuleRequires' . fst3)) )
+        ff n = [ fromModule . hsModuleName $ ms | gs@((ms,_,_):_) <- scc, n `elem` map (fromModule . hsModuleName . fst3) gs]
+    when (dump FD.SccModules) $ do
+        CharIO.putErrLn $ "scc modules:\n" ++ unlines ( map  (\xs -> show [ hsModuleName x | (x,y,z) <- xs ]) scc)
+        putErrLn $ drawForest (map (fmap (show . map (hsModuleName . fst3))) (G.dff mgraph'))
+
+    let f ho libHo [] = processIOErrors >> return (ho,libDeps,libHo)
+        f ho libHo (sc:scs) = do
+            (cho',newHo) <- func ho [ hs | (hs,_,_) <- sc ]
+            let mods = [ hsModuleName hs | (hs,_,_) <- sc ]
+                mods' = snub [ m  | (hs,_,_) <- sc, m <- hsModuleRequires hs, m `notElem` mods]
+                mdeps = [ (m,dep) | m <- mods', dep <- Map.lookup m (choModules cho')]
+            let hoh = fillInHohHash HoHeader {
+                                 hohDepends    = [ x | (_,x,_) <- sc],
+                                 hohModDepends = mdeps,
+                                 hohHash = error "fillInHohHash - hoHash",
+                                 hohMetaInfo   = []
+                               }
+            recordHoFile newHo [ x | (_,_,x) <- sc ] hoh
+            f (cho' `mappend` mempty { choFiles = Map.fromList $ hohDepends hoh, choModules = mprovides hoh }) (libHo `mappend` newHo)  scs
+
+    cho <- ifunc cho (mempty { hoBuild = mempty { hoDataTable = dataTablePrims } } `mappend` readHo)
+    f cho libHo scc
+
+
+-}
+
+
+findModule' :: [Either Module String]                                -- ^ Either a module or filename to find
+              -> (CollectedHo -> Ho -> IO CollectedHo)              -- ^ Process initial ho loaded from file
+              -> (CollectedHo -> [HsModule] -> IO (CollectedHo,Ho)) -- ^ Process set of mutually recursive modules to produce final Ho
+              -> IO (CollectedHo,[(Module,MD5.Hash)],Ho)            -- ^ (Final accumulated ho,just the ho read to satisfy this command)
+findModule' need ifunc func  = do
hunk ./Ho/Build.hs 581
-checkForHoFile :: String -> IO (Maybe (HoHeader,Ho))
+checkForHoFile :: FilePath -> IO (Maybe (HoHeader,HoIDeps,Ho))
hunk ./Ho/Build.hs 584
-readHoFile :: String -> IO (HoHeader,Ho)
+readHoFile :: FilePath -> IO (HoHeader,HoIDeps,Ho)
hunk ./Ho/Build.hs 589
-    Just rhh <- return $ lookup cff_jhdr mp
-    Just rhe <- return $ lookup cff_defs mp
-    Just rhb <- return $ lookup cff_core mp
-    let hh = decode (decompress $ L.fromChunks [rhh])
-    let he = decode (decompress $ L.fromChunks [rhe])
-    let hb = decode (decompress $ L.fromChunks [rhb])
-    return (hh,mempty { hoExp = he, hoBuild = hb})
+    let fc ct = case lookup ct mp of
+            Nothing -> error $ "No chunk '" ++ show ct ++ "' found in file " ++ fn
+            Just x -> decode . decompress $ L.fromChunks [x]
+    return (fc cff_jhdr,fc cff_idep,mempty { hoExp = fc cff_defs, hoBuild = fc cff_core})
hunk ./Ho/Build.hs 633
+                    (cff_idep, compress $ encode ideps),
hunk ./Ho/Build.hs 636
+                ideps = HoIDeps $ Map.fromList [ (h,(m,fsts $ hohModDepends header)) | (m,h) <- hohDepends header]
hunk ./Ho/Build.hs 691
-
-hoToProgram :: Ho -> Program
-hoToProgram ho = programSetDs (hoEs $ hoBuild ho) program {
-    progClassHierarchy = hoClassHierarchy $ hoBuild ho,
-    progDataTable = hoDataTable $ hoBuild ho
-    }
-
hunk ./Ho/Build.hs 745
-    (hoh,ho) <- readHoFile fn
+    (hoh,_,ho) <- readHoFile fn
hunk ./Ho/Type.hs 22
+import Data.Binary
hunk ./Ho/Type.hs 54
-data HoIDeps = HoIDeps {
+newtype HoIDeps = HoIDeps {
hunk ./Ho/Type.hs 57
+    deriving(Binary)
hunk ./Main.hs 473
+        hoToProgram :: Ho -> Program
+        hoToProgram ho = programSetDs (hoEs $ hoBuild ho) program {
+            progClassHierarchy = hoClassHierarchy $ hoBuild ho,
+            progDataTable = hoDataTable $ hoBuild ho
+            }
+
hunk ./Makefile.am 84
-   drift_processed/DataConstructors.hs-boot drift_processed/Ho/Type.hs
+   drift_processed/DataConstructors.hs-boot drift_processed/Ho/Type.hs  drift_processed/Ho/Build.hs