git.iko.soy/elk
on master help sign in
add filelock when compiling with make, reactor, and repl
f57012cEvan Czaplicki
builder/src/Stuff.hs+3−10
compare with master
unifiedsplit
@@ -8,8 +8,7 @@ module Stuff
8 , elmo
8 , elmo
9 , temp
9 , temp
10 , findRoot
10 , findRoot
11− , withProjectLock
11+ , withRootLock
12− , withCacheLock
13 , PackageCache
12 , PackageCache
14 , getPackageCache
13 , getPackageCache
15 , registry
14 , registry
@@ -120,19 +119,13 @@ findRootHelp dirs =
120-- LOCKS
119-- LOCKS
121
120
122
121
123−withProjectLock :: FilePath -> IO a -> IO a
122+withRootLock :: FilePath -> IO a -> IO a
124−withProjectLock root work =
123+withRootLock root work =
125 do let dir = stuff root
124 do let dir = stuff root
126 Dir.createDirectoryIfMissing True dir
125 Dir.createDirectoryIfMissing True dir
127 Lock.withFileLock (dir </> "project.lock") Lock.Exclusive (\_ -> work)
126 Lock.withFileLock (dir </> "project.lock") Lock.Exclusive (\_ -> work)
128
127
129
128
130−withCacheLock :: PackageCache -> IO a -> IO a
131−withCacheLock (PackageCache dir) work =
132− Lock.withFileLock (dir </> "cache.lock") Lock.Exclusive (\_ -> work)
133−
134−
135−
136
129
137-- PACKAGE CACHES
130-- PACKAGE CACHES
138
131
terminal/src/Develop.hs+14−8
@@ -138,7 +138,7 @@ serveElm :: FilePath -> Snap ()
138serveElm path =
138serveElm path =
139 do guard (takeExtension path == ".elm")
139 do guard (takeExtension path == ".elm")
140 modifyResponse (setContentType "text/html")
140 modifyResponse (setContentType "text/html")
141− result <- liftIO $ Task.run $ compile path
141+ result <- liftIO $ compile path
142 case result of
142 case result of
143 Right builder ->
143 Right builder ->
144 writeBuilder builder
144 writeBuilder builder
@@ -148,14 +148,20 @@ serveElm path =
148 Exit.toJson $ Exit.reactorToReport exit
148 Exit.toJson $ Exit.reactorToReport exit
149
149
150
150
151−compile :: FilePath -> Task.Task Exit.Reactor B.Builder
151+compile :: FilePath -> IO (Either Exit.Reactor B.Builder)
152compile path =
152compile path =
153− do root <- Task.mio Exit.ReactorNoOutline Stuff.findRoot
153+ do maybeRoot <- Stuff.findRoot
154+ case maybeRoot of
155+ Nothing ->
156+ return $ Left $ Exit.ReactorNoOutline
157+
158+ Just root ->
159+ Stuff.withRootLock root $ Task.run $
154− details <- Task.eio Exit.ReactorBadDetails $ Details.load Reporting.silent root
160+ do details <- Task.eio Exit.ReactorBadDetails $ Details.load Reporting.silent root
155− artifacts <- Task.eio Exit.ReactorBadBuild $ Build.fromMains Reporting.silent root details (NE.List path [])
161+ artifacts <- Task.eio Exit.ReactorBadBuild $ Build.fromMains Reporting.silent root details (NE.List path [])
156− javascript <- Task.mapError Exit.ReactorBadGenerate $ Generate.dev root details artifacts
162+ javascript <- Task.mapError Exit.ReactorBadGenerate $ Generate.dev root details artifacts
157− let (NE.List name _) = Build.getMainNames artifacts
163+ let (NE.List name _) = Build.getMainNames artifacts
158− return $ Html.sandwich name javascript
164+ return $ Html.sandwich name javascript
159
165
160
166
161
167
terminal/src/Make.hs+50−42
@@ -62,49 +62,57 @@ type Task a = Task.Task Exit.Make a
62
62
63
63
64run :: [FilePath] -> Flags -> IO ()
64run :: [FilePath] -> Flags -> IO ()
65−run paths (Flags debug optimize maybeOutput report maybeDocs) =
65+run paths flags@(Flags _ _ _ report _) =
66 do style <- getStyle report
66 do style <- getStyle report
67+ maybeRoot <- Stuff.findRoot
67− Reporting.attemptWithStyle style Exit.makeToReport $ Task.run $
68+ Reporting.attemptWithStyle style Exit.makeToReport $
68− do root <- Task.mio Exit.MakeNoOutline Stuff.findRoot
69+ case maybeRoot of
70+ Just root -> runHelp root paths style flags
71+ Nothing -> return $ Left $ Exit.MakeNoOutline
72+
73+
74+runHelp :: FilePath -> [FilePath] -> Reporting.Style -> Flags -> IO (Either Exit.Make ())
75+runHelp root paths style (Flags debug optimize maybeOutput _ maybeDocs) =
76+ Stuff.withRootLock root $ Task.run $
69− desiredMode <- getMode debug optimize
77+ do desiredMode <- getMode debug optimize
70− details <- Task.eio Exit.MakeBadDetails (Details.load style root)
78+ details <- Task.eio Exit.MakeBadDetails (Details.load style root)
71− case paths of
79+ case paths of
72− [] ->
80+ [] ->
73− do exposed <- getExposed details
81+ do exposed <- getExposed details
74− buildExposed style root details maybeDocs exposed
82+ buildExposed style root details maybeDocs exposed
75−
83+
76− p:ps ->
84+ p:ps ->
77− do artifacts <- buildPaths style root details (NE.List p ps)
85+ do artifacts <- buildPaths style root details (NE.List p ps)
78− case maybeOutput of
86+ case maybeOutput of
79− Nothing ->
87+ Nothing ->
80− case getMains artifacts of
88+ case getMains artifacts of
81− [] ->
89+ [] ->
82− return ()
90+ return ()
83−
91+
84− [name] ->
92+ [name] ->
85− do builder <- toBuilder root details desiredMode artifacts
93+ do builder <- toBuilder root details desiredMode artifacts
86− generate style "index.html" (Html.sandwich name builder) (NE.List name [])
94+ generate style "index.html" (Html.sandwich name builder) (NE.List name [])
87−
95+
88− name:names ->
96+ name:names ->
89− do builder <- toBuilder root details desiredMode artifacts
97+ do builder <- toBuilder root details desiredMode artifacts
90− generate style "elm.js" builder (NE.List name names)
98+ generate style "elm.js" builder (NE.List name names)
91−
99+
92− Just DevNull ->
100+ Just DevNull ->
93− return ()
101+ return ()
94−
102+
95− Just (JS target) ->
103+ Just (JS target) ->
96− case getNoMains artifacts of
104+ case getNoMains artifacts of
97− [] ->
105+ [] ->
98− do builder <- toBuilder root details desiredMode artifacts
106+ do builder <- toBuilder root details desiredMode artifacts
99− generate style target builder (Build.getMainNames artifacts)
107+ generate style target builder (Build.getMainNames artifacts)
100−
108+
101− name:names ->
109+ name:names ->
102− Task.throw (Exit.MakeNonMainFilesIntoJavaScript name names)
110+ Task.throw (Exit.MakeNonMainFilesIntoJavaScript name names)
103−
111+
104− Just (Html target) ->
112+ Just (Html target) ->
105− do name <- hasOneMain artifacts
113+ do name <- hasOneMain artifacts
106− builder <- toBuilder root details desiredMode artifacts
114+ builder <- toBuilder root details desiredMode artifacts
107− generate style target (Html.sandwich name builder) (NE.List name [])
115+ generate style target (Html.sandwich name builder) (NE.List name [])
108
116
109
117
110
118
terminal/src/Repl.hs+1−1
@@ -377,7 +377,7 @@ data Output
377
377
378attemptEval :: Env -> State -> State -> Output -> IO State
378attemptEval :: Env -> State -> State -> Output -> IO State
379attemptEval (Env root interpreter ansi) oldState newState output =
379attemptEval (Env root interpreter ansi) oldState newState output =
380− do result <- Task.run $
380+ do result <- Stuff.withRootLock root $ Task.run $
381 do details <-
381 do details <-
382 Task.eio Exit.ReplBadDetails $
382 Task.eio Exit.ReplBadDetails $
383 Details.load Reporting.silent root
383 Details.load Reporting.silent root