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