@@ -1,68 +1,100 @@
11module Build.File (build) where
22
3−import Control.Applicative ((<$>))
4−import Control.Monad (when)
3+import Control.Applicative ((<$>), (<*>), pure)
4+import Control.Monad (when)
5+import Control.Monad.Error (runErrorT)
56import Control.Monad.RWS.Strict
6−import qualified Data.Binary as Binary
7−import qualified Data.List as List
8−import qualified Data.Maybe as Maybe
9−import Data.Monoid (Last(..))
10−import qualified Data.Map as Map
7+import Data.Monoid (Last(..))
118import System.Directory
129import System.Exit
1310import System.FilePath
1411import System.IO
1512
16−import qualified Transform.Canonicalize as Canonical
17−import qualified Data.ByteString.Lazy as L
18−
19−import qualified Build.Utils as Utils
20−import qualified Build.Flags as Flag
21−import qualified Build.Source as Source
22−import qualified Build.Print as Print
23−import qualified Generate.JavaScript as JS
13+import qualified Data.Binary as Binary
14+import qualified Data.List as List
15+import qualified Data.Maybe as Maybe
16+import qualified Data.Map as Map
17+import qualified Data.ByteString.Lazy as L
18+
19+import qualified Build.Dependencies as Deps
20+import qualified Build.Flags as Flag
21+import qualified Build.Print as Print
22+import qualified Build.Source as Source
23+import qualified Build.Utils as Utils
24+import qualified Generate.JavaScript as JS
2425import qualified InterfaceSerialization as IS
25−import qualified Parse.Module as Parser
26−import qualified SourceSyntax.Module as M
26+import qualified Parse.Module as Parser
27+import qualified SourceSyntax.Module as M
28+import qualified Transform.Canonicalize as Canonical
2729
2830-- Reader: Runtime flags, always accessible
2931-- Writer: Remember the last module to be accessed
3032-- State: Build up a map of the module interfaces
31−type BuildT m a = RWST Flag.Flags (Last String) M.Interfaces m a
33+type BuildT m a = RWST Flag.Flags (Last String) BInterfaces m a
3234type Build a = BuildT IO a
3335
36+-- Interfaces, remembering if something was recompiled
37+type BInterfaces = Map.Map String (Bool, M.ModuleInterface)
38+
3439evalBuild :: Flag.Flags -> M.Interfaces -> Build () -> IO (Maybe String)
3540evalBuild fs is b = do
36− (_, s) <- evalRWST b fs is
41+ (_, s) <- evalRWST b fs (fmap notUpdated is)
3742 return . getLast $ s
43+ where notUpdated i = (False, i)
3844
39−-- Builds a list of files, returning the moduleName of the last one.
40−-- Returns "" if the list is empty
45+-- | Builds a list of files, returning the moduleName of the last one.
46+-- Returns \"\" if the list is empty
4147build :: Flag.Flags -> M.Interfaces -> [FilePath] -> IO String
4248build flags is = fmap (Maybe.fromMaybe "") . evalBuild flags is . buildAll
4349
4450buildAll :: [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
51+buildAll fs = mapM_ (uncurry build1) (zip [1..] fs)
52+ where 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+
5360 total = length fs
5461
55−alreadyCompiled :: FilePath -> Build Bool
56−alreadyCompiled filePath = do
62+shouldBeCompiled :: FilePath -> Build Bool
63+shouldBeCompiled filePath = do
5764 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)
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)
6698
6799retrieve :: FilePath -> Build ()
68100retrieve filePath = do
@@ -72,19 +104,20 @@ retrieve filePath = do
72104 let binary = IS.interfaceDecode elmi =<< bytes
73105 case IS.validVersion filePath =<< binary of
74106 Right (name, interface) ->
75− do interfaces <- get
107+ do binterfaces <- get
108+ let interfaces = snd <$> binterfaces
76109 liftIO $ when (Flag.print_types flags) (Print.interfaceTypes interfaces interface)
77− update name interface
110+ update name interface False
78111
79− Left err ->
80− liftIO $ hPutStrLn stderr err >> exitFailure
112+ Left err -> liftIO $ Print.failure err
81113
82114compile :: String -> FilePath -> Build ()
83115compile number filePath =
84116 do flags <- ask
85− interfaces <- get
117+ binterfaces <- get
86118 source <- liftIO $ readFile filePath
87− let name = getName source
119+ let interfaces = snd <$> binterfaces
120+ name = getName source
88121 liftIO $ do
89122 printStatus name
90123 createDirectoryIfMissing True (Flag.cache_dir flags)
@@ -98,9 +131,9 @@ compile number filePath =
98131
99132 liftIO $ when (Flag.print_types flags) $ Print.metaTypes interfaces metaModule
100133
101− let intermediate = (name, Canonical.interface name $ M.metaToInterface metaModule)
102− generateCache intermediate metaModule
103− uncurry update intermediate
134+ let newInters = Canonical.interface name $ M.metaToInterface metaModule
135+ generateCache name newInters metaModule
136+ update name newInters True
104137
105138 where
106139 getName source = case Parser.getModuleName source of
@@ -112,14 +145,14 @@ compile number filePath =
112145 , replicate (max 1 (20 - length name)) ' '
113146 , "( " ++ filePath ++ " )" ]
114147
115− generateCache intermediate metaModule = do
148+ generateCache name interfs metaModule = do
116149 flags <- ask
117150 liftIO $ do
118151 createDirectoryIfMissing True . dropFileName $ Utils.elmi flags filePath
119152 writeFile (Utils.elmo flags filePath) (JS.generate metaModule)
120153 withBinaryFile (Utils.elmi flags filePath) WriteMode $ \handle ->
121− L.hPut handle (Binary.encode intermediate)
154+ L.hPut handle (Binary.encode (name, interfs))
122155
123−update :: String -> M.ModuleInterface -> Build ()
124−update name inter = modify (Map.insert name inter)
125− >> tell (Last . Just $ name)
156+update :: String -> M.ModuleInterface -> Bool -> Build ()
157+update name inter wasUpdated = modify (Map.insert name (wasUpdated, inter))
158+ >> tell (Last . Just $ name)