@@ -1,92 +1,137 @@
11{-# OPTIONS_GHC -W #-}
22module Build.File (build) where
33
4−import Control.Monad (when)
5−import qualified Data.Binary as Binary
6−import qualified Data.Map as Map
4+import Control.Applicative ((<$>))
5+import Control.Monad.Error (runErrorT)
6+import Control.Monad.RWS.Strict
77import System.Directory
88import System.Exit
99import System.FilePath
1010import System.IO
1111
12+import qualified Data.Binary as Binary
13+import qualified Data.Maybe as Maybe
14+import qualified Data.Map as Map
15+import qualified Data.ByteString.Lazy as L
16+
17+import qualified Build.Dependencies as Deps
18+import qualified Build.Flags as Flag
19+import qualified Build.Interface as Interface
20+import qualified Build.Print as Print
21+import qualified Build.Source as Source
22+import qualified Build.Utils as Utils
23+import qualified Generate.JavaScript as JS
24+import qualified Parse.Module as Parser
25+import qualified SourceSyntax.Module as M
1226import qualified Transform.Canonicalize as Canonical
1327
14−import qualified Data.ByteString.Lazy as L
15−
16−import qualified Build.Utils as Utils
17−import qualified Build.Flags as Flag
18−import qualified Build.Interface as Interface
19−import qualified Build.Print as Print
20−import qualified Build.Source as Source
21−import qualified Generate.JavaScript as JS
22−import qualified Parse.Module as Parser
23−import qualified SourceSyntax.Module as M
24−
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− iface <- Interface.load (Utils.elmi flags 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
31+type BuildT m a = RWST Flag.Flags (Last String) BInterfaces m a
32+type Build a = BuildT IO a
33+
34+-- Interfaces, remembering if something was recompiled
35+type BInterfaces = Map.Map String (Bool, M.ModuleInterface)
36+
37+evalBuild :: Flag.Flags -> M.Interfaces -> Build () -> IO (Maybe String)
38+evalBuild flags interfaces b = do
39+ (_, s) <- evalRWST b flags (fmap notUpdated interfaces)
40+ return . getLast $ s
41+ where
42+ notUpdated i = (False, i)
43+
44+-- | Builds a list of files, returning the moduleName of the last one.
45+-- Returns \"\" if the list is empty
46+build :: Flag.Flags -> M.Interfaces -> [FilePath] -> IO String
47+build flags is = fmap (Maybe.fromMaybe "") . evalBuild flags is . buildAll
48+
49+buildAll :: [FilePath] -> Build ()
50+buildAll fs = mapM_ (uncurry build1) (zip [1..] fs)
51+ where build1 :: Integer -> FilePath -> Build ()
52+ build1 num fname = do
53+ shouldCompile <- shouldBeCompiled fname
54+ if shouldCompile
55+ then compile number fname
56+ else retrieve fname
57+
58+ where number = join ["[", show num, " of ", show total, "]"]
59+
60+ total = length fs
61+
62+shouldBeCompiled :: FilePath -> Build Bool
63+shouldBeCompiled filePath = do
64+ flags <- ask
65+ let alreadyCompiled = liftIO $ do
66+ existsi <- doesFileExist (Utils.elmi flags filePath)
67+ existso <- doesFileExist (Utils.elmo flags filePath)
68+ return $ existsi && existso
69+
70+ outDated = liftIO $ do
71+ tsrc <- getModificationTime filePath
72+ tint <- getModificationTime (Utils.elmo flags filePath)
73+ return (tsrc > tint)
74+
75+ dependenciesUpdated = do
76+ eDeps <- liftIO . runErrorT $ Deps.readDeps filePath
77+ case eDeps of
78+ -- Should never actually reach here
79+ Left err -> liftIO $ Print.failure err
80+ Right (_, deps) -> anyM wasCompiled deps
81+
82+
83+ in (not <$> alreadyCompiled) `orM` outDated `orM` dependenciesUpdated
84+
85+wasCompiled :: String -> Build Bool
86+wasCompiled modul = maybe False fst . Map.lookup modul <$> get
87+
88+-- Short-circuiting monadic (||)
89+infixr 2 `orM`
90+orM :: (Monad m) => m Bool -> m Bool -> m Bool
91+orM m1 m2 = do b1 <- m1
92+ if b1
93+ then return b1
94+ else m2
95+
96+anyM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool
97+anyM f = foldr (orM . f) (return False)
98+
99+retrieve :: FilePath -> Build ()
100+retrieve filePath = do
101+ flags <- ask
102+ iface <- liftIO $ Interface.load (Utils.elmi flags filePath)
61103 case Interface.isValid filePath iface of
62104 Right (name, interface) ->
63− do when (Flag.print_types flags) (Print.interfaceTypes interfaces interface)
64− return (name, interface)
65− Left err ->
66− do hPutStrLn stderr err
67− exitFailure
68−
69−compile :: Flag.Flags -> String -> M.Interfaces -> FilePath
70− -> IO (String, M.ModuleInterface)
71−compile flags number interfaces filePath =
72− do source <- readFile filePath
73− let name = getName source
74− printStatus name
75−
76− createDirectoryIfMissing True (Flag.cache_dir flags)
77− createDirectoryIfMissing True (Flag.build_dir flags)
78−
79− metaModule <-
80− case Source.build (Flag.no_prelude flags) interfaces source of
105+ do binterfaces <- get
106+ let interfaces = snd <$> binterfaces
107+ liftIO $ when (Flag.print_types flags) (Print.interfaceTypes interfaces interface)
108+ update name interface False
109+
110+ Left err -> liftIO $ Print.failure err
111+
112+compile :: String -> FilePath -> Build ()
113+compile number filePath =
114+ do flags <- ask
115+ binterfaces <- get
116+ source <- liftIO $ readFile filePath
117+ let interfaces = snd <$> binterfaces
118+ name = getName source
119+ liftIO $ do
120+ printStatus name
121+ createDirectoryIfMissing True (Flag.cache_dir flags)
122+ createDirectoryIfMissing True (Flag.build_dir flags)
123+
124+ metaModule <-
125+ liftIO $ case Source.build (Flag.no_prelude flags) interfaces source of
81126 Right modul -> return modul
82127 Left errors -> do Print.errors errors
83128 exitFailure
84129
85− when (Flag.print_types flags) $ Print.metaTypes interfaces metaModule
86−
87− let intermediate = (name, Canonical.interface name $ M.metaToInterface metaModule)
88− generateCache intermediate metaModule
89− return intermediate
130+ liftIO $ when (Flag.print_types flags) $ Print.metaTypes interfaces metaModule
131+
132+ let newInters = Canonical.interface name $ M.metaToInterface metaModule
133+ generateCache name newInters metaModule
134+ update name newInters True
90135
91136 where
92137 getName source = case Parser.getModuleName source of
@@ -98,8 +143,14 @@ compile flags number interfaces filePath =
98143 , replicate (max 1 (20 - length name)) ' '
99144 , "( " ++ filePath ++ " )" ]
100145
101− generateCache intermediate metaModule = do
102− createDirectoryIfMissing True . dropFileName $ Utils.elmi flags filePath
103− writeFile (Utils.elmo flags filePath) (JS.generate metaModule)
104− withBinaryFile (Utils.elmi flags filePath) WriteMode $ \handle ->
105− L.hPut handle (Binary.encode intermediate)
146+ generateCache name interfs metaModule = do
147+ flags <- ask
148+ liftIO $ do
149+ createDirectoryIfMissing True . dropFileName $ Utils.elmi flags filePath
150+ writeFile (Utils.elmo flags filePath) (JS.generate metaModule)
151+ withBinaryFile (Utils.elmi flags filePath) WriteMode $ \handle ->
152+ L.hPut handle (Binary.encode (name, interfs))
153+
154+update :: String -> M.ModuleInterface -> Bool -> Build ()
155+update name inter wasUpdated = modify (Map.insert name (wasUpdated, inter))
156+ >> tell (Last . Just $ name)