git.iko.soy/elk
on master help sign in
Recompile modules when their dependencies have changed.
cf9d21bMax New
compiler/Build/Dependencies.hs+37−27
compare with master
unifiedsplit
@@ -1,4 +1,4 @@
1−module Build.Dependencies (getSortedDependencies) where
1+module Build.Dependencies (getSortedDependencies, readDeps) where
2
2
3import Data.Data
3import Data.Data
4import Control.Applicative
4import Control.Applicative
@@ -18,6 +18,8 @@ import System.FilePath as FP
18import System.IO
18import System.IO
19import Text.PrettyPrint (Doc)
19import Text.PrettyPrint (Doc)
20
20
21+import Build.Print (failure)
22+
21import qualified SourceSyntax.Module as Module
23import qualified SourceSyntax.Module as Module
22import qualified SourceSyntax.Type as Type
24import qualified SourceSyntax.Type as Type
23import qualified Parse.Parse as Parse
25import qualified Parse.Parse as Parse
@@ -36,7 +38,7 @@ getSortedDependencies :: [FilePath] -> Module.Interfaces -> FilePath -> IO [Stri
36getSortedDependencies srcDirs builtIns root =
38getSortedDependencies srcDirs builtIns root =
37 do extras <- extraDependencies
39 do extras <- extraDependencies
38 let allSrcDirs = srcDirs ++ Maybe.fromMaybe [] extras
40 let allSrcDirs = srcDirs ++ Maybe.fromMaybe [] extras
39− result <- runErrorT $ readDeps allSrcDirs builtIns root
41+ result <- runErrorT $ readAllDeps allSrcDirs builtIns root
40 case result of
42 case result of
41 Right deps -> sortDeps deps
43 Right deps -> sortDeps deps
42 Left err -> failure $ err ++ if Maybe.isJust extras then "" else msg
44 Left err -> failure $ err ++ if Maybe.isJust extras then "" else msg
@@ -44,8 +46,6 @@ getSortedDependencies srcDirs builtIns root =
44 Path.dependencyFile ++
46 Path.dependencyFile ++
45 " file if you\nare trying to use a 3rd party library."
47 " file if you\nare trying to use a 3rd party library."
46
48
47−failure msg = hPutStrLn stderr msg >> exitFailure
48−
49extraDependencies :: IO (Maybe [FilePath])
49extraDependencies :: IO (Maybe [FilePath])
50extraDependencies =
50extraDependencies =
51 do exists <- doesFileExist Path.dependencyFile
51 do exists <- doesFileExist Path.dependencyFile
@@ -86,34 +86,44 @@ sortDeps depends =
86 mistakes = filter (\scc -> length scc > 1) sccs
86 mistakes = filter (\scc -> length scc > 1) sccs
87 msg = "A cyclical module dependency or was detected in:\n"
87 msg = "A cyclical module dependency or was detected in:\n"
88
88
89−readDeps :: [FilePath] -> Module.Interfaces -> FilePath -> ErrorT String IO [Deps]
89+readAllDeps :: [FilePath] -> Module.Interfaces -> FilePath -> ErrorT String IO [Deps]
90−readDeps srcDirs builtIns root = do
90+readAllDeps srcDirs builtIns root = do
91 let ifaces = (Set.fromList . Map.keys) builtIns
91 let ifaces = (Set.fromList . Map.keys) builtIns
92 State.evalStateT (go ifaces root) Set.empty
92 State.evalStateT (go ifaces root) Set.empty
93 where
93 where
94 go :: Set.Set String -> FilePath -> State.StateT (Set.Set String) (ErrorT String IO) [Deps]
94 go :: Set.Set String -> FilePath -> State.StateT (Set.Set String) (ErrorT String IO) [Deps]
95 go builtIns root = do
95 go builtIns root = do
96− (root', txt) <- lift $ getFile srcDirs root
96+ root' <- lift $ findSrcFile srcDirs root
97− case Parse.dependencies txt of
97+ (name, deps) <- lift $ readDeps root'
98− Left err -> throwError $ msg ++ show err
99− where msg = "Error resolving dependencies in " ++ root' ++ ":\n"
100−
101− Right (name,deps) ->
102− do seen <- State.get
98+ seen <- State.get
103− let realDeps = Set.difference (Set.fromList deps) builtIns
99+ let realDeps = Set.difference (Set.fromList deps) builtIns
104− newDeps = Set.difference (Set.filter (not . isNative) realDeps) seen
100+ newDeps = Set.difference (Set.filter (not . isNative) realDeps) seen
105− State.put (Set.insert name (Set.union newDeps seen))
101+ State.put (Set.insert name (Set.union newDeps seen))
106− rest <- mapM (go builtIns . toFilePath) (Set.toList newDeps)
102+ rest <- mapM (go builtIns . toFilePath) (Set.toList newDeps)
107− return ((makeRelative "." root', name, Set.toList realDeps) : concat rest)
103+ return ((makeRelative "." root', name, Set.toList realDeps) : concat rest)
108−
104+
105+readDeps :: FilePath -> ErrorT String IO (String, [String])
106+readDeps path = do
107+ txt <- lift $ readFile path
108+ case Parse.dependencies txt of
109+ Left err -> throwError $ msg ++ show err
110+ where msg = "Error resolving dependencies in " ++ path ++ ":\n"
111+ Right o -> return o
112+
109−getFile :: [FilePath] -> FilePath -> ErrorT String IO (FilePath,String)
113+findSrcFile :: [FilePath] -> FilePath -> ErrorT String IO FilePath
110−getFile [] path =
114+findSrcFile dirs path = foldr tryDir notFound dirs
111− throwError $ unlines
115+ where notFound = throwError $ unlines
112− [ "Could not find file: " ++ path
116+ [ "Could not find file: " ++ path
113− , " If it is not in the root directory of your project, use"
117+ , " If it is not in the root directory of your project, use"
114− , " --src-dir to declare additional locations for source files."
118+ , " --src-dir to declare additional locations for source files."
115− , " If it is part of a 3rd party library, it needs to be declared"
119+ , " If it is part of a 3rd party library, it needs to be declared"
116− , " as a dependency in the " ++ Path.dependencyFile ++ " file." ]
120+ , " as a dependency in the " ++ Path.dependencyFile ++ " file." ]
121+ tryDir dir next = do
122+ let path' = dir </> path
123+ exists <- liftIO $ doesFileExist path'
124+ if exists
125+ then return path'
126+ else next
117
127
118getFile (dir:dirs) path = do
128getFile (dir:dirs) path = do
119 let path' = dir </> path
129 let path' = dir </> path
compiler/Build/File.hs+86−53
@@ -1,68 +1,100 @@
1module Build.File (build) where
1module Build.File (build) where
2
2
3−import Control.Applicative ((<$>))
3+import Control.Applicative ((<$>), (<*>), pure)
4−import Control.Monad (when)
4+import Control.Monad (when)
5+import Control.Monad.Error (runErrorT)
5import Control.Monad.RWS.Strict
6import 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(..))
7+import Data.Monoid (Last(..))
10−import qualified Data.Map as Map
11import System.Directory
8import System.Directory
12import System.Exit
9import System.Exit
13import System.FilePath
10import System.FilePath
14import System.IO
11import System.IO
15
12
16−import qualified Transform.Canonicalize as Canonical
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
17+import qualified Data.ByteString.Lazy as L
18−
18+
19−import qualified Build.Utils as Utils
19+import qualified Build.Dependencies as Deps
20−import qualified Build.Flags as Flag
20+import qualified Build.Flags as Flag
21−import qualified Build.Source as Source
21+import qualified Build.Print as Print
22+import qualified Build.Source as Source
22−import qualified Build.Print as Print
23+import qualified Build.Utils as Utils
23−import qualified Generate.JavaScript as JS
24+import qualified Generate.JavaScript as JS
24import qualified InterfaceSerialization as IS
25import qualified InterfaceSerialization as IS
25−import qualified Parse.Module as Parser
26+import qualified Parse.Module as Parser
26−import qualified SourceSyntax.Module as M
27+import qualified SourceSyntax.Module as M
28+import qualified Transform.Canonicalize as Canonical
27
29
28-- Reader: Runtime flags, always accessible
30-- Reader: Runtime flags, always accessible
29-- Writer: Remember the last module to be accessed
31-- Writer: Remember the last module to be accessed
30-- State: Build up a map of the module interfaces
32-- 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
32type Build a = BuildT IO a
34type Build a = BuildT IO a
33
35
36+-- Interfaces, remembering if something was recompiled
37+type BInterfaces = Map.Map String (Bool, M.ModuleInterface)
38+
34evalBuild :: Flag.Flags -> M.Interfaces -> Build () -> IO (Maybe String)
39evalBuild :: Flag.Flags -> M.Interfaces -> Build () -> IO (Maybe String)
35evalBuild fs is b = do
40evalBuild fs is b = do
36− (_, s) <- evalRWST b fs is
41+ (_, s) <- evalRWST b fs (fmap notUpdated is)
37 return . getLast $ s
42 return . getLast $ s
43+ where notUpdated i = (False, i)
38
44
39−-- Builds a list of files, returning the moduleName of the last one.
45+-- | Builds a list of files, returning the moduleName of the last one.
40−-- Returns "" if the list is empty
46+-- Returns \"\" if the list is empty
41build :: Flag.Flags -> M.Interfaces -> [FilePath] -> IO String
47build :: Flag.Flags -> M.Interfaces -> [FilePath] -> IO String
42build flags is = fmap (Maybe.fromMaybe "") . evalBuild flags is . buildAll
48build flags is = fmap (Maybe.fromMaybe "") . evalBuild flags is . buildAll
43
49
44buildAll :: [FilePath] -> Build ()
50buildAll :: [FilePath] -> Build ()
45−buildAll fs = mapM_ build1 (zip [1..] fs)
51+buildAll fs = mapM_ (uncurry build1) (zip [1..] fs)
46− where build1 (num, fname) = do
52+ where build1 num fname = do
47− compiled <- alreadyCompiled filePath
53+ shouldCompile <- shouldBeCompiled fname
48− case compiled of
54+ if shouldCompile
49− False ->
55+ then compile number fname
56+ else retrieve fname
57+
50− let number = join ["[", show num, " of ", show total, "]"]
58+ where number = join ["[", show num, " of ", show total, "]"]
51− compile number filePath
59+
52− True -> retrieve filePath
53 total = length fs
60 total = length fs
54
61
55−alreadyCompiled :: FilePath -> Build Bool
62+shouldBeCompiled :: FilePath -> Build Bool
56−alreadyCompiled filePath = do
63+shouldBeCompiled filePath = do
57 flags <- ask
64 flags <- ask
58− liftIO $ do
65+ let alreadyCompiled = liftIO $ do
59− existsi <- doesFileExist (Utils.elmi flags filePath)
66+ existsi <- doesFileExist (Utils.elmi flags filePath)
60− existso <- doesFileExist (Utils.elmo flags filePath)
67+ existso <- doesFileExist (Utils.elmo flags filePath)
61− if not existsi || not existso
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
62− then return False
93+ then return b1
63− else do tsrc <- getModificationTime filePath
94+ else m2
64− tint <- getModificationTime (Utils.elmo flags filePath)
95+
65− return (tsrc <= tint)
96+anyM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool
97+anyM f = foldr (orM . f) (return False)
66
98
67retrieve :: FilePath -> Build ()
99retrieve :: FilePath -> Build ()
68retrieve filePath = do
100retrieve filePath = do
@@ -72,19 +104,20 @@ retrieve filePath = do
72 let binary = IS.interfaceDecode elmi =<< bytes
104 let binary = IS.interfaceDecode elmi =<< bytes
73 case IS.validVersion filePath =<< binary of
105 case IS.validVersion filePath =<< binary of
74 Right (name, interface) ->
106 Right (name, interface) ->
75− do interfaces <- get
107+ do binterfaces <- get
108+ let interfaces = snd <$> binterfaces
76 liftIO $ when (Flag.print_types flags) (Print.interfaceTypes interfaces interface)
109 liftIO $ when (Flag.print_types flags) (Print.interfaceTypes interfaces interface)
77− update name interface
110+ update name interface False
78
111
79− Left err ->
112+ Left err -> liftIO $ Print.failure err
80− liftIO $ hPutStrLn stderr err >> exitFailure
81
113
82compile :: String -> FilePath -> Build ()
114compile :: String -> FilePath -> Build ()
83compile number filePath =
115compile number filePath =
84 do flags <- ask
116 do flags <- ask
85− interfaces <- get
117+ binterfaces <- get
86 source <- liftIO $ readFile filePath
118 source <- liftIO $ readFile filePath
119+ let interfaces = snd <$> binterfaces
87− let name = getName source
120+ name = getName source
88 liftIO $ do
121 liftIO $ do
89 printStatus name
122 printStatus name
90 createDirectoryIfMissing True (Flag.cache_dir flags)
123 createDirectoryIfMissing True (Flag.cache_dir flags)
@@ -98,9 +131,9 @@ compile number filePath =
98
131
99 liftIO $ when (Flag.print_types flags) $ Print.metaTypes interfaces metaModule
132 liftIO $ when (Flag.print_types flags) $ Print.metaTypes interfaces metaModule
100
133
101− let intermediate = (name, Canonical.interface name $ M.metaToInterface metaModule)
134+ let newInters = Canonical.interface name $ M.metaToInterface metaModule
102− generateCache intermediate metaModule
135+ generateCache name newInters metaModule
103− uncurry update intermediate
136+ update name newInters True
104
137
105 where
138 where
106 getName source = case Parser.getModuleName source of
139 getName source = case Parser.getModuleName source of
@@ -112,14 +145,14 @@ compile number filePath =
112 , replicate (max 1 (20 - length name)) ' '
145 , replicate (max 1 (20 - length name)) ' '
113 , "( " ++ filePath ++ " )" ]
146 , "( " ++ filePath ++ " )" ]
114
147
115− generateCache intermediate metaModule = do
148+ generateCache name interfs metaModule = do
116 flags <- ask
149 flags <- ask
117 liftIO $ do
150 liftIO $ do
118 createDirectoryIfMissing True . dropFileName $ Utils.elmi flags filePath
151 createDirectoryIfMissing True . dropFileName $ Utils.elmi flags filePath
119 writeFile (Utils.elmo flags filePath) (JS.generate metaModule)
152 writeFile (Utils.elmo flags filePath) (JS.generate metaModule)
120 withBinaryFile (Utils.elmi flags filePath) WriteMode $ \handle ->
153 withBinaryFile (Utils.elmi flags filePath) WriteMode $ \handle ->
121− L.hPut handle (Binary.encode intermediate)
154+ L.hPut handle (Binary.encode (name, interfs))
122
155
123−update :: String -> M.ModuleInterface -> Build ()
156+update :: String -> M.ModuleInterface -> Bool -> Build ()
124−update name inter = modify (Map.insert name inter)
157+update name inter wasUpdated = modify (Map.insert name (wasUpdated, inter))
125− >> tell (Last . Just $ name)
158+ >> tell (Last . Just $ name)
compiler/Build/Print.hs+7−1
@@ -1,5 +1,8 @@
1module Build.Print where
1module Build.Print where
2
2
3+import System.IO (hPutStrLn, stderr)
4+import System.Exit (exitFailure)
5+
3import qualified Data.Map as Map
6import qualified Data.Map as Map
4import qualified Data.List as List
7import qualified Data.List as List
5import qualified SourceSyntax.Module as M
8import qualified SourceSyntax.Module as M
@@ -29,4 +32,7 @@ types interfaces types' aliases imports =
29
32
30errors :: [P.Doc] -> IO ()
33errors :: [P.Doc] -> IO ()
31errors errs =
34errors errs =
32− mapM_ print (List.intersperse (P.text " ") errs)
35+ mapM_ print (List.intersperse (P.text " ") errs)
36+
37+failure :: String -> IO a
38+failure msg = hPutStrLn stderr msg >> exitFailure