[clean up ho code some, move stuff into binary
John Meacham <john@repetae.net>**20090808110111
 Ignore-this: 1fd66b59d0b2f02ddacaa37ae54b6fa2
] hunk ./src/Ho/Binary.hs 1
-module Ho.Binary() where
+module Ho.Binary(readHoFile,recordHoFile,readHlFile,recordHlFile) where
hunk ./src/Ho/Binary.hs 4
+import Codec.Compression.GZip
hunk ./src/Ho/Binary.hs 7
-import Data.Version
+import System.Posix.Files
+import Text.Printf
+import Util.Gen
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.Version
hunk ./src/Ho/Binary.hs 14
+import Options
hunk ./src/Ho/Binary.hs 19
+import Support.CFF
hunk ./src/Ho/Binary.hs 22
+current_version :: Int
+current_version = 2
hunk ./src/Ho/Binary.hs 25
+readHFile :: FilePath -> IO (FilePath,HoHeader,forall a . Binary a => ChunkType -> a)
+readHFile fn = do
+    bs <- BS.readFile fn
+    fn' <- shortenPath fn
+    (ct,mp) <- bsCFF bs
+    True <- return $ ct == cff_magic
+    let fc ct = case lookup ct mp of
+            Nothing -> error $ "No chunk '" ++ show ct ++ "' found in file " ++ fn
+            Just x -> decode . decompress $ LBS.fromChunks [x]
+            --Just x -> trace (printf "**** Reading %s from %s ****\n" (show ct) fn') $ decode . decompress $ L.fromChunks [x]
+    let hoh = fc cff_jhdr
+    when (hohVersion hoh /= current_version) $ fail "invalid version in hofile"
+    return (fn',hoh,fc)
hunk ./src/Ho/Binary.hs 39
+readHoFile :: FilePath -> IO (HoHeader,HoIDeps,Ho)
+readHoFile fn = do
+    (_fn',hoh,fc) <- readHFile fn
+    let Left modGroup = hohName hoh
+    return (hoh,fc cff_idep,Ho { hoModuleGroup = modGroup, hoTcInfo = fc cff_defs, hoBuild = fc cff_core})
hunk ./src/Ho/Binary.hs 45
+recordHoFile ::
+    Ho               -- ^ File to record
+    -> HoIDeps
+    -> [FilePath]    -- ^ files to write to
+    -> HoHeader      -- ^ file header
+    -> IO ()
+recordHoFile ho idep fs header = do
+    if optNoWriteHo options then do
+        when verbose $ do
+            fs' <- mapM shortenPath fs
+            putErrLn $ "Skipping Writing Ho Files: " ++ show fs'
+      else do
+    let removeLink' fn = catch  (removeLink fn)  (\_ -> return ())
+    let g (fn:fs) = do
+            f fn
+            mapM_ (l fn) fs
+            return ()
+        g [] = error "Ho.g: shouldn't happen"
+        l fn fn' = do
+            when verbose $ do
+                fn_ <- shortenPath fn
+                fn_' <- shortenPath fn'
+                when (optNoWriteHo options) $ putErr "Skipping "
+                putErrLn $ printf "Linking haskell object file: %s to %s" fn_' fn_
+            if optNoWriteHo options then return () else do
+            let tfn = fn' ++ ".tmp"
+            removeLink' tfn
+            createLink fn tfn
+            rename tfn fn'
+        f fn = do
+            when verbose $ do
+                when (optNoWriteHo options) $ putErr "Skipping "
+                fn' <- shortenPath fn
+                putErrLn $ "Writing haskell object file: " ++ fn'
+            if optNoWriteHo options then return () else do
+            let tfn = fn ++ ".tmp"
+                cfflbs = mkCFFfile cff_magic [
+                    (cff_jhdr, compress $ encode header { hohVersion = current_version }),
+                    (cff_idep, compress $ encode idep),
+                    (cff_defs, compress $ encode $ hoTcInfo ho),
+                    (cff_core, compress $ encode $ hoBuild ho)]
+            LBS.writeFile tfn cfflbs
+            rename tfn fn
+    g fs
+
+recordHlFile
+    :: Library
+    -> FilePath
+    -> IO ()
+recordHlFile (Library hoh libr ldef lcor) fp = do
+    --let theho =  mapHoBodies eraseE ho
+    let cfflbs = mkCFFfile cff_magic [
+            (cff_jhdr, compress $ encode hoh { hohVersion = current_version }),
+            (cff_libr, compress $ encode libr),
+            (cff_ldef, compress $ encode ldef),
+            (cff_lcor, compress $ encode lcor)]
+    let tfp = fp ++ ".tmp"
+    LBS.writeFile tfp cfflbs
+    rename tfp fp
+
+readHlFile :: FilePath -> IO Library
+readHlFile fn = do
+    (_fn',hoh,fc) <- readHFile fn
+    return (Library hoh (fc cff_libr) (fc cff_ldef) (fc cff_lcor))
hunk ./src/Ho/Binary.hs 147
-{-
hunk ./src/Ho/Binary.hs 157
-    -}
-
hunk ./src/Ho/Binary.hs 160
-    put (Version a b) = put a >> put b 
-    get = liftM2 Version get get
+    put (Data.Version.Version a b) = put a >> put b 
+    get = liftM2 Data.Version.Version get get
hunk ./src/Ho/Build.hs 4
---    compileModules,
hunk ./src/Ho/Build.hs 10
-import Codec.Compression.GZip
-import Control.Monad.Identity
hunk ./src/Ho/Build.hs 11
+import Control.Monad.Identity
hunk ./src/Ho/Build.hs 14
-import Data.Monoid
hunk ./src/Ho/Build.hs 15
-import Data.Tree
hunk ./src/Ho/Build.hs 16
+import Data.Monoid
+import Data.Tree
+import Debug.Trace
hunk ./src/Ho/Build.hs 21
-import Text.Printf
hunk ./src/Ho/Build.hs 23
+import System.Mem
hunk ./src/Ho/Build.hs 25
-import qualified Data.ByteString.Lazy as L
+import Text.Printf
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.ByteString.Lazy.UTF8 as LBS
hunk ./src/Ho/Build.hs 32
-import Debug.Trace
-import System.Mem
hunk ./src/Ho/Build.hs 33
-import PackedString(packString)
hunk ./src/Ho/Build.hs 35
-import Directory
hunk ./src/Ho/Build.hs 43
-import FrontEnd.FrontEnd
hunk ./src/Ho/Build.hs 44
+import FrontEnd.FrontEnd
hunk ./src/Ho/Build.hs 46
+import FrontEnd.HsSyn
hunk ./src/Ho/Build.hs 49
+import FrontEnd.SrcLoc
hunk ./src/Ho/Build.hs 53
-import FrontEnd.SrcLoc
-import RawFiles(prelude_m4)
-import Ho.Binary()
-import Ho.Library
+import Ho.Binary
hunk ./src/Ho/Build.hs 55
+import Ho.Library
hunk ./src/Ho/Build.hs 57
-import FrontEnd.HsSyn
hunk ./src/Ho/Build.hs 58
+import PackedString(packString)
+import RawFiles(prelude_m4)
hunk ./src/Ho/Build.hs 64
-import Version.Version(versionString)
hunk ./src/Ho/Build.hs 65
-import qualified Data.ByteString as BS
-import qualified Data.ByteString.Lazy as LBS
+import Version.Version(versionString)
hunk ./src/Ho/Build.hs 68
-import qualified Util.Graph as G
hunk ./src/Ho/Build.hs 69
-import qualified Data.ByteString.Lazy.UTF8 as LBS
+import qualified Util.Graph as G
hunk ./src/Ho/Build.hs 81
--- IDEP - immutable import information
+-- IDEP - immutable import information, needed to tell if ho files are up to date
hunk ./src/Ho/Build.hs 83
--- DEFS - definitions and exports for modules, all that is needed for name resolution
--- TCIN - type checking information
+-- DEFS - definitions type checking information
hunk ./src/Ho/Build.hs 85
+-- LDEF - library map of module group name to DEFS
+-- LCOR - library map of module group name to CORE
hunk ./src/Ho/Build.hs 88
---
hunk ./src/Ho/Build.hs 105
-current_version :: Int
-current_version = 2
-
-cff_magic = chunkType "JHC"
-cff_link  = chunkType "LINK"
-cff_jhdr  = chunkType "JHDR"
-cff_core  = chunkType "CORE"
-cff_defs  = chunkType "DEFS"
-cff_idep  = chunkType "IDEP"
-
-
-shortenPath :: String -> IO String
-shortenPath x@('/':_) = do
-    cd <- getCurrentDirectory
-    pwd <- lookupEnv "PWD"
-    h <- lookupEnv "HOME"
-    let f d = do
-            d <- d
-            '/':rest <- getPrefix d x
-            return rest
-    return $ fromJust $ f (return cd) `mplus` f pwd `mplus` liftM ("~/" ++) (f h) `mplus` return x
-shortenPath x = return x
-
hunk ./src/Ho/Build.hs 109
-
hunk ./src/Ho/Build.hs 231
+    | CompLibrary Ho Library
+
hunk ./src/Ho/Build.hs 266
-
hunk ./src/Ho/Build.hs 344
-               -> IO CollectedHo                                       -- ^ Final accumulated ho
+               -> IO (CompNode,CollectedHo)                            -- ^ Final accumulated ho
hunk ./src/Ho/Build.hs 355
-    compileCompNode ifunc func ksm cnode
+    cho <- compileCompNode ifunc func ksm cnode
+    return (cnode,cho)
hunk ./src/Ho/Build.hs 435
-            --CompHo hoh idep _   -> do
-            --    return $ Set.fromList (map (show.fst) (hoDepends idep))
hunk ./src/Ho/Build.hs 511
-                                 hohVersion = current_version,
+                                 hohVersion = error "hohVersion",
hunk ./src/Ho/Build.hs 523
-                    recordHoFile newHo idep shns hoh
+                    recordHoFile (mapHoBodies eraseE newHo) idep shns hoh
hunk ./src/Ho/Build.hs 530
-readHFile :: FilePath -> IO (FilePath,HoHeader,forall a . Binary a => ChunkType -> a)
-readHFile fn = do
-    bs <- BS.readFile fn
-    fn' <- shortenPath fn
-    (ct,mp) <- bsCFF bs
-    True <- return $ ct == cff_magic
-    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]
-            --Just x -> trace (printf "**** Reading %s from %s ****\n" (show ct) fn') $ decode . decompress $ L.fromChunks [x]
-    let hoh = fc cff_jhdr
-    when (hohVersion hoh /= current_version) $ fail "invalid version in hofile"
-    return (fn',hoh,fc)
-
--- Read in a Ho file.
-
-readHoFile :: FilePath -> IO (HoHeader,HoIDeps,Ho)
-readHoFile fn = do
-    (_fn',hoh,fc) <- readHFile fn
-    let Left modGroup = hohName hoh
-    return (hoh,fc cff_idep,mempty { hoModuleGroup = modGroup, hoTcInfo = fc cff_defs, hoBuild = fc cff_core})
-
-
-recordHoFile ::
-    Ho               -- ^ File to record
-    -> HoIDeps
-    -> [FilePath]    -- ^ files to write to
-    -> HoHeader      -- ^ file header
-    -> IO ()
-recordHoFile ho idep fs header = do
-    if optNoWriteHo options then do
-        when verbose $ do
-            fs' <- mapM shortenPath fs
-            putErrLn $ "Skipping Writing Ho Files: " ++ show fs'
-      else do
-    let removeLink' fn = catch  (removeLink fn)  (\_ -> return ())
-    let g (fn:fs) = do
-            f fn
-            mapM_ (l fn) fs
-            return ()
-        g [] = error "Ho.g: shouldn't happen"
-        l fn fn' = do
-            when verbose $ do
-                fn_ <- shortenPath fn
-                fn_' <- shortenPath fn'
-                when (optNoWriteHo options) $ putErr "Skipping "
-                putErrLn $ "Linking haskell object file:" <+> fn_' <+> "to" <+> fn_
-            if optNoWriteHo options then return () else do
-            let tfn = fn' ++ ".tmp"
-            removeLink' tfn
-            createLink fn tfn
-            rename tfn fn'
-        f fn = do
-            when verbose $ do
-                when (optNoWriteHo options) $ putErr "Skipping "
-                fn' <- shortenPath fn
-                putErrLn $ "Writing haskell object file:" <+> fn'
-            if optNoWriteHo options then return () else do
-            let tfn = fn ++ ".tmp"
-            let theho =  mapHoBodies eraseE ho
-                cfflbs = mkCFFfile cff_magic [
-                    (cff_jhdr, compress $ encode header),
-                    (cff_idep, compress $ encode idep),
-                    (cff_defs, compress $ encode $ hoTcInfo theho),
-                    (cff_core, compress $ encode $ hoBuild theho)]
-            LBS.writeFile tfn cfflbs
-            rename tfn fn
-    g fs
hunk ./src/Ho/Build.hs 607
---collectLibraries :: IO [FilePath]
---collectLibraries = concat `fmap` mapM f (optHlPath options) where
---    f fp = do
---        fs <- flip catch (\_ -> return []) $ getDirectoryContents fp
---        flip mapM fs $ \e -> case reverse e of
---            ('l':'h':'.':r)  -> do
---                (fn',hoh,mp) <- readHFile (fp++"/"++e)
---
---        _               -> []
+
hunk ./src/Ho/Build.hs 616
-        let allmods  = sort (emods ++ hmods)
-        cho <- parseFiles (map Left allmods) ifunc func
+        let allmods = snub (emods ++ hmods)
+        -- TODO - must check we depend only on libraries
+        (cnode,_) <- parseFiles (map Left allmods) ifunc func
hunk ./src/Ho/Build.hs 622
-        putVerboseLn $ "Creating library from description file: " ++ show fp
+        putProgressLn $ "Creating library from description file: " ++ show fp
hunk ./src/Ho/Build.hs 634
+--collectLibraries :: IO [FilePath]
+--collectLibraries = concat `fmap` mapM f (optHlPath options) where
+--    f fp = do
+--        fs <- flip catch (\_ -> return []) $ getDirectoryContents fp
+--        flip mapM fs $ \e -> case reverse e of
+--            ('l':'h':'.':r)  -> do
+--                (fn',hoh,mp) <- readHFile (fp++"/"++e)
+--
+--        _               -> []
+
hunk ./src/Ho/Build.hs 679
-    -- parse library description file
-    parse fp = do
-        putVerboseLn $ "Creating library from description file: " ++ show fp
-        desc <- readDescFile fp
-        when verbose2 $ mapM_ print desc
-        let field x = lookup x desc
-            jfield x = maybe (fail $ "createLibrary: description lacks required field " ++ show x) return $ field x
-            mfield x = maybe [] (words . map (\c -> if c == ',' then ' ' else c)) $ field x
-        name <- jfield "name"
-        vers <- jfield "version"
-        let hmods = map Module $ snub $ mfield "hidden-modules"
-            emods = map Module $ snub $ mfield "exposed-modules"
-        return (desc,name ++ "-" ++ vers,hmods,emods)
-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
-    (needed,cug) <- loadModules (optHls options) need
-    cnodes <- processCug cug
-    rnode <- mkPhonyCompNode needed cnodes
-    typeCheckGraph rnode
-    cho <- compileCompNode ifunc func rnode
-    return (cho,undefined,undefined)
-
hunk ./src/Ho/Collected.hs 10
-    choHo
+    updateChoHo
hunk ./src/Ho/Collected.hs 36
-    mempty = CollectedHo {
+    mempty = updateChoHo CollectedHo {
hunk ./src/Ho/Collected.hs 41
+        choHo = error "choHo-a",
hunk ./src/Ho/Collected.hs 44
-    a `mappend` b = CollectedHo {
+    a `mappend` b = updateChoHo CollectedHo {
hunk ./src/Ho/Collected.hs 49
+        choHo = error "choHo-b",
hunk ./src/Ho/Collected.hs 53
-choHo cho = hoBuild_u (hoEs_u f) . mconcat . Map.elems $ choHoMap cho where
+updateChoHo cho = cho { choHo = ho } where
+    ho = hoBuild_u (hoEs_u f) . mconcat . Map.elems $ choHoMap cho
hunk ./src/Ho/Type.hs 21
-import Data.Binary
hunk ./src/Ho/Type.hs 24
+import Support.CFF
hunk ./src/Ho/Type.hs 26
+cff_magic = chunkType "JHC"
+cff_link  = chunkType "LINK"
+cff_libr  = chunkType "LIBR"
+cff_jhdr  = chunkType "JHDR"
+cff_core  = chunkType "CORE"
+cff_defs  = chunkType "DEFS"
+cff_lcor  = chunkType "LCOR"
+cff_ldef  = chunkType "LDEF"
+cff_idep  = chunkType "IDEP"
hunk ./src/Ho/Type.hs 63
-    choHoMap :: Map.Map String Ho }
+    -- this is a cache
+    choHo :: Ho,
+    choHoMap :: Map.Map String Ho
+    }
hunk ./src/Ho/Type.hs 96
-    hoModDepends :: [HoHash] }
+    hoModDepends :: [HoHash]
+    }
hunk ./src/Ho/Type.hs 103
-    hoModuleDeps :: Map.Map ModuleGroup [ModuleGroup],
-    hoHiddenModules :: [Module],
-    -- for libraries we have to keep these seperated
-    -- by module group since they are inherited whenever
-    -- the corresponding modules are imported
-    hoClasses :: Map.Map ModuleGroup ClassHierarchy,
-    hoLibRules :: Map.Map ModuleGroup Rules
+    hoModuleDeps :: Map.Map ModuleGroup [ModuleGroup]
hunk ./src/Ho/Type.hs 107
+data Library = Library HoHeader HoLib (Map.Map ModuleGroup HoTcInfo) (Map.Map ModuleGroup HoBuild)
+
+
hunk ./src/Main.hs 127
-    g fs =  processCollectedHo =<< parseFiles fs processInitialHo processDecls
+    g fs = processCollectedHo . snd =<< parseFiles fs processInitialHo processDecls
hunk ./src/Main.hs 168
-    return $ mempty {
+    return $ updateChoHo mempty {
hunk ./src/Main.hs 176
-
-
hunk ./src/Main.hs 192
-    let allHo = ho `mappend` ho'
-        ho = choHo cho
-        htc = hoTcInfo ho
+    let ho = choHo cho
hunk ./src/Main.hs 412
-    return (mempty {
+    return (updateChoHo $ mempty {
hunk ./src/Util/Gen.hs 9
+import Directory
+import System.IO
+import Data.Maybe
hunk ./src/Util/Gen.hs 31
+
+shortenPath :: String -> IO String
+shortenPath x@('/':_) = do
+    cd <- getCurrentDirectory
+    pwd <- lookupEnv "PWD"
+    h <- lookupEnv "HOME"
+    let f d = do
+            d <- d
+            '/':rest <- getPrefix d x
+            return rest
+    return $ fromJust $ f (return cd) `mplus` f pwd `mplus` liftM ("~/" ++) (f h) `mplus` return x
+shortenPath x = return x
+
+