git.iko.soy/elk
on 49f58cf help sign in
elk/builder/src/File/Plan.hs
205 lines 5.1 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module File.Plan
4 ( plan
5 , Info(..)
6 )
7 where
9import Control.Concurrent (forkIO)
10import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
11import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, readMVar)
12import Control.Monad (foldM, void, when)
13import Control.Monad.Except (liftIO)
14import qualified Data.Binary as Binary
15import qualified Data.ByteString as BS
16import qualified Data.Map as Map
17import qualified Data.Time.Clock as Time
18import qualified System.Directory as Dir
20import qualified Elm.Compiler.Module as Module
21import qualified Elm.Package as Pkg
23import qualified Elm.Project.Json as Project
24import qualified Elm.Project.Summary as Summary
25import qualified File.Crawl as Crawl
26import qualified File.Header as Header
27import qualified Reporting.Task as Task
28import qualified Stuff.Paths
32-- PLAN
35type Dict value = Map.Map Module.Raw value
38plan :: Maybe FilePath -> Summary.Summary -> Crawl.Result -> Task.Task (Dict Info, Module.Interfaces)
39plan docs (Summary.Summary root project _ ifaces _) (Crawl.Graph _ locals _ foreigns _) =
40 liftIO $
41 do queue <- newChan
42 let env = Env queue root (Project.getName project) docs
44 mvar <- newEmptyMVar
45 statusMVars <- Map.traverseWithKey (getStatus env mvar foreigns) locals
46 putMVar mvar statusMVars
48 void $ forkIO $
49 do graph <- Map.traverseMaybeWithKey (\_ -> readMVar) statusMVars
50 writeChan queue (EndLoop graph)
52 ifaceLoader queue ifaces
55data Env =
56 Env
57 { _queue :: Chan Msg
58 , _root :: FilePath
59 , _pkg :: Pkg.Name
60 , _docs :: Maybe FilePath
61 }
65-- STATUS
68type Status = Maybe Info
69 -- Nothing == clean
70 -- Just info == dirty
73data Info =
74 Info
75 { _path :: FilePath
76 , _time :: Time.UTCTime
77 , _src :: BS.ByteString
78 , _clean :: [Module.Raw]
79 , _dirty :: [Module.Raw]
80 , _foreign :: [Module.Canonical] -- TODO is this needed?
81 }
85-- GET STATUS
88getStatus
89 :: Env
90 -> MVar (Dict (MVar Status))
91 -> Dict Pkg.Package
92 -> Module.Raw
93 -> Header.Info
94 -> IO (MVar Status)
95getStatus env statusMVars foreigns name (Header.Info path time src deps) =
96 do mvar <- newEmptyMVar
98 void $ forkIO $ putMVar mvar =<<
99 do statuses <- readMVar statusMVars
100 info <- foldM (addDep statuses foreigns) (Info path time src [] [] []) deps
102 let elmi = Stuff.Paths.elmi (_root env) name
103 let docs = Stuff.Paths.moduleDocs (_root env) name
105 case _dirty info of
106 _ : _ ->
107 do remove elmi
108 remove docs
109 return (Just info)
111 [] ->
112 do freshElmi <- isFresh time elmi
113 freshDocs <-
114 case _docs env of
115 Nothing -> return True
116 Just _ -> isFresh time docs
118 if freshElmi && freshDocs
119 then
120 do let canonical = Module.Canonical (_pkg env) name
121 writeChan (_queue env) (Get canonical elmi)
122 return Nothing
123 else
124 do remove elmi
125 remove docs
126 return (Just info)
128 return mvar
131addDep :: Dict (MVar Status) -> Dict Pkg.Package -> Info -> Module.Raw -> IO Info
132addDep locals foreigns info name =
133 case Map.lookup name locals of
134 Just mvar ->
135 do status <- readMVar mvar
136 case status of
137 Nothing ->
138 return $ info { _clean = name : _clean info }
140 Just _ ->
141 return $ info { _dirty = name : _dirty info }
143 Nothing ->
144 case Map.lookup name foreigns of
145 Just (Pkg.Package pkg _vsn) ->
146 return $ info { _foreign = Module.Canonical pkg name : _foreign info }
148 Nothing ->
149 return info -- must be native
153-- IS FRESH
156isFresh :: Time.UTCTime -> FilePath -> IO Bool
157isFresh srcTime cachedFile =
158 andM
159 [ Dir.doesFileExist cachedFile
160 , do cacheTime <- Dir.getModificationTime cachedFile
161 return (cacheTime >= srcTime)
162 ]
165andM :: [IO Bool] -> IO Bool
166andM checks =
167 case checks of
168 [] ->
169 return True
171 check : otherChecks ->
172 do bool <- check
173 if bool then andM otherChecks else return False
176remove :: FilePath -> IO ()
177remove path =
178 do exists <- Dir.doesFileExist path
179 when exists (Dir.removeFile path)
183-- INTERFACE LOADER
186data Msg
187 = EndLoop (Dict Info)
188 | Get Module.Canonical FilePath
191ifaceLoader :: Chan Msg -> Module.Interfaces -> IO (Dict Info, Module.Interfaces)
192ifaceLoader queue ifaces =
193 do msg <- readChan queue
194 case msg of
195 EndLoop dirty ->
196 return ( dirty, ifaces )
198 Get canonical elmi ->
199 case Map.lookup canonical ifaces of
200 Just _ ->
201 ifaceLoader queue ifaces
203 Nothing ->
204 do iface <- Binary.decodeFile elmi
205 ifaceLoader queue $ Map.insert canonical iface ifaces