git.iko.soy/elk
on 69b783f help sign in
elk/builder/src/File/Plan.hs
196 lines 4.7 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 :: Summary.Summary -> Crawl.Result -> Task.Task (Dict Info, Module.Interfaces)
39plan (Summary.Summary root project _ ifaces _) (Crawl.Graph _ locals _ foreigns _) =
40 liftIO $
41 do queue <- newChan
42 let env = Env queue root (Project.getName project)
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 }
64-- STATUS
67type Status = Maybe Info
68 -- Nothing == clean
69 -- Just info == dirty
72data Info =
73 Info
74 { _path :: FilePath
75 , _time :: Time.UTCTime
76 , _src :: BS.ByteString
77 , _clean :: [Module.Raw]
78 , _dirty :: [Module.Raw]
79 , _foreign :: [Module.Canonical] -- TODO is this needed?
80 }
84-- GET STATUS
87getStatus
88 :: Env
89 -> MVar (Dict (MVar Status))
90 -> Dict Pkg.Package
91 -> Module.Raw
92 -> Header.Info
93 -> IO (MVar Status)
94getStatus env statusMVars foreigns name (Header.Info path time src deps) =
95 do mvar <- newEmptyMVar
97 void $ forkIO $ putMVar mvar =<<
98 do statuses <- readMVar statusMVars
99 info <- foldM (addDep statuses foreigns) (Info path time src [] [] []) deps
101 let elmi = Stuff.Paths.elmi (_root env) name
103 case _dirty info of
104 _ : _ ->
105 do remove elmi
106 return (Just info)
108 [] ->
109 do fresh <- isFresh time elmi
110 if fresh
111 then
112 do let canonical = Module.Canonical (_pkg env) name
113 writeChan (_queue env) (Get canonical elmi)
114 return Nothing
115 else
116 do remove elmi
117 return (Just info)
119 return mvar
122addDep :: Dict (MVar Status) -> Dict Pkg.Package -> Info -> Module.Raw -> IO Info
123addDep locals foreigns info name =
124 case Map.lookup name locals of
125 Just mvar ->
126 do status <- readMVar mvar
127 case status of
128 Nothing ->
129 return $ info { _clean = name : _clean info }
131 Just _ ->
132 return $ info { _dirty = name : _dirty info }
134 Nothing ->
135 case Map.lookup name foreigns of
136 Just (Pkg.Package pkg _vsn) ->
137 return $ info { _foreign = Module.Canonical pkg name : _foreign info }
139 Nothing ->
140 return info -- must be native
144-- IS FRESH
147isFresh :: Time.UTCTime -> FilePath -> IO Bool
148isFresh srcTime elmi =
149 andM
150 [ Dir.doesFileExist elmi
151 , do elmiTime <- Dir.getModificationTime elmi
152 return (elmiTime >= srcTime)
153 ]
156andM :: [IO Bool] -> IO Bool
157andM checks =
158 case checks of
159 [] ->
160 return True
162 check : otherChecks ->
163 do bool <- check
164 if bool then andM otherChecks else return False
167remove :: FilePath -> IO ()
168remove path =
169 do exists <- Dir.doesFileExist path
170 when exists (Dir.removeFile path)
174-- INTERFACE LOADER
177data Msg
178 = EndLoop (Dict Info)
179 | Get Module.Canonical FilePath
182ifaceLoader :: Chan Msg -> Module.Interfaces -> IO (Dict Info, Module.Interfaces)
183ifaceLoader queue ifaces =
184 do msg <- readChan queue
185 case msg of
186 EndLoop dirty ->
187 return ( dirty, ifaces )
189 Get canonical elmi ->
190 case Map.lookup canonical ifaces of
191 Just _ ->
192 ifaceLoader queue ifaces
194 Nothing ->
195 do iface <- Binary.decodeFile elmi
196 ifaceLoader queue $ Map.insert canonical iface ifaces