@@ -1,8 +1,12 @@
1module Build.File (build) where
1module Build.File (build) where
3+import Control.Applicative ((<$>))
3import Control.Monad (when)
4import Control.Monad (when)
5+import Control.Monad.RWS.Strict
4import qualified Data.Binary as Binary
6import qualified Data.Binary as Binary
5import qualified Data.List as List
7import qualified Data.List as List
8+import qualified Data.Maybe as Maybe
9+import Data.Monoid (Last(..))
6import qualified Data.Map as Map
10import qualified Data.Map as Map
7import System.Directory
11import System.Directory
8import System.Exit
12import System.Exit
@@ -10,7 +14,6 @@ import System.FilePath
10import System.IO
14import System.IO
12import qualified Transform.Canonicalize as Canonical
16import qualified Transform.Canonicalize as Canonical
14import qualified Data.ByteString.Lazy as L
17import qualified Data.ByteString.Lazy as L
16import qualified Build.Utils as Utils
19import qualified Build.Utils as Utils
@@ -22,72 +25,82 @@ import qualified InterfaceSerialization as IS
22import qualified Parse.Module as Parser
25import qualified Parse.Module as Parser
23import qualified SourceSyntax.Module as M
26import qualified SourceSyntax.Module as M
25−build :: Flag.Flags -> Int -> M.Interfaces -> String -> [FilePath]
28+-- Reader: Runtime flags, always accessible
29+-- Writer: Remember the last module to be accessed
30+-- State: Build up a map of the module interfaces
26− -> IO (String, M.Interfaces)
31+type BuildT m a = RWST Flag.Flags (Last String) M.Interfaces m a
27−build _ _ interfaces moduleName [] =
32+type Build a = BuildT IO a
28− return (moduleName, interfaces)
33+
29−build flags numModules interfaces _ (filePath:rest) =
34+evalBuild :: Flag.Flags -> M.Interfaces -> Build () -> IO (Maybe String)
30− do (name,interface) <-
35+evalBuild fs is b = do
31− build1 flags (numModules - length rest) numModules interfaces filePath
36+ (_, s) <- evalRWST b fs is
32− let interfaces' = Map.insert name interface interfaces
37+ return . getLast $ s
33− build flags numModules interfaces' name rest
38+
34−
39+-- Builds a list of files, returning the moduleName of the last one.
35−
40+-- Returns "" if the list is empty
36−build1 :: Flag.Flags -> Int -> Int -> M.Interfaces -> FilePath
41+build :: Flag.Flags -> M.Interfaces -> [FilePath] -> IO String
37− -> IO (String, M.ModuleInterface)
42+build flags is = fmap (Maybe.fromMaybe "") . evalBuild flags is . buildAll
38−build1 flags moduleNum numModules interfaces filePath =
43+
44+buildAll :: [FilePath] -> Build ()
45+buildAll fs = mapM_ build1 (zip [1..] fs)
46+ where build1 (num, fname) = do
39− do compiled <- alreadyCompiled flags filePath
47+ compiled <- alreadyCompiled filePath
40− case compiled of
48+ case compiled of
50+ let number = join ["[", show num, " of ", show total, "]"]
41− False -> compile flags number interfaces filePath
51+ compile number filePath
42− True -> retrieve flags interfaces filePath
52+ True -> retrieve filePath
43− where
53+ total = length fs
44− number = "[" ++ show moduleNum ++ " of " ++ show numModules ++ "]"
54+
47−alreadyCompiled :: Flag.Flags -> FilePath -> IO Bool
55+alreadyCompiled :: FilePath -> Build Bool
48−alreadyCompiled flags filePath = do
56+alreadyCompiled filePath = do
49− existsi <- doesFileExist (Utils.elmi flags filePath)
59+ existsi <- doesFileExist (Utils.elmi flags filePath)
50− existso <- doesFileExist (Utils.elmo flags filePath)
60+ existso <- doesFileExist (Utils.elmo flags filePath)
51− if not existsi || not existso
61+ if not existsi || not existso
52− then return False
62+ then return False
53− else do tsrc <- getModificationTime filePath
63+ else do tsrc <- getModificationTime filePath
54− tint <- getModificationTime (Utils.elmo flags filePath)
64+ tint <- getModificationTime (Utils.elmo flags filePath)
55− return (tsrc <= tint)
65+ return (tsrc <= tint)
57−retrieve :: Flag.Flags -> Map.Map String M.ModuleInterface -> FilePath
67+retrieve :: FilePath -> Build ()
58− -> IO (String, M.ModuleInterface)
68+retrieve filePath = do
59−retrieve flags interfaces filePath = do
69+ flags <- ask
70+ let elmi = Utils.elmi flags filePath
60− bytes <- IS.loadInterface (Utils.elmi flags filePath)
71+ bytes <- liftIO $ IS.loadInterface elmi
61− let binary = IS.interfaceDecode (Utils.elmi flags filePath) =<< bytes
72+ let binary = IS.interfaceDecode elmi =<< bytes
62 case IS.validVersion filePath =<< binary of
73 case IS.validVersion filePath =<< binary of
63 Right (name, interface) ->
74 Right (name, interface) ->
64− do when (Flag.print_types flags) (Print.interfaceTypes interfaces interface)
76+ liftIO $ when (Flag.print_types flags) (Print.interfaceTypes interfaces interface)
65− return (name, interface)
77+ update name interface
66 Left err ->
79 Left err ->
67− do hPutStrLn stderr err
80+ liftIO $ hPutStrLn stderr err >> exitFailure
70−compile :: Flag.Flags -> String -> M.Interfaces -> FilePath
82+compile :: String -> FilePath -> Build ()
71− -> IO (String, M.ModuleInterface)
72−compile flags number interfaces filePath =
83+compile number filePath =
73− do source <- readFile filePath
86+ source <- liftIO $ readFile filePath
74 let name = getName source
87 let name = getName source
75− printStatus name
89+ printStatus name
77− createDirectoryIfMissing True (Flag.cache_dir flags)
90+ createDirectoryIfMissing True (Flag.cache_dir flags)
78− createDirectoryIfMissing True (Flag.build_dir flags)
91+ createDirectoryIfMissing True (Flag.build_dir flags)
80− metaModule <-
93+ metaModule <-
81− case Source.build (Flag.no_prelude flags) interfaces source of
94+ liftIO $ case Source.build (Flag.no_prelude flags) interfaces source of
82 Right modul -> return modul
95 Right modul -> return modul
83 Left errors -> do Print.errors errors
96 Left errors -> do Print.errors errors
84 exitFailure
97 exitFailure
86− when (Flag.print_types flags) $ Print.metaTypes interfaces metaModule
99+ liftIO $ when (Flag.print_types flags) $ Print.metaTypes interfaces metaModule
88 let intermediate = (name, Canonical.interface name $ M.metaToInterface metaModule)
101 let intermediate = (name, Canonical.interface name $ M.metaToInterface metaModule)
89 generateCache intermediate metaModule
102 generateCache intermediate metaModule
90− return intermediate
103+ uncurry update intermediate
93 getName source = case Parser.getModuleName source of
106 getName source = case Parser.getModuleName source of
@@ -100,7 +113,13 @@ compile flags number interfaces filePath =
100 , "( " ++ filePath ++ " )" ]
113 , "( " ++ filePath ++ " )" ]
102 generateCache intermediate metaModule = do
115 generateCache intermediate metaModule = do
103− createDirectoryIfMissing True . dropFileName $ Utils.elmi flags filePath
118+ createDirectoryIfMissing True . dropFileName $ Utils.elmi flags filePath
104− writeFile (Utils.elmo flags filePath) (JS.generate metaModule)
119+ writeFile (Utils.elmo flags filePath) (JS.generate metaModule)
105− withBinaryFile (Utils.elmi flags filePath) WriteMode $ \handle ->
120+ withBinaryFile (Utils.elmi flags filePath) WriteMode $ \handle ->
106 L.hPut handle (Binary.encode intermediate)
121 L.hPut handle (Binary.encode intermediate)
123+update :: String -> M.ModuleInterface -> Build ()
124+update name inter = modify (Map.insert name inter)
125+ >> tell (Last . Just $ name)