git.iko.soy/elk
on 49f58cf help sign in
elk/builder/src/File/Compile.hs
192 lines 4.9 kB history raw
1module File.Compile
2 ( compile
3 , Answer(..)
4 )
5 where
7import Control.Concurrent (forkIO)
8import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, readMVar, takeMVar)
9import Control.Monad (void)
10import Control.Monad.Except (liftIO)
11import qualified Data.ByteString as BS
12import qualified Data.Map as Map
13import qualified Data.Time.Clock as Time
15import qualified Elm.Compiler as Compiler
16import qualified Elm.Compiler.Module as Module
18import Elm.Project.Json (Project)
19import qualified Elm.Project.Json as Project
20import qualified File.Plan as Plan
21import qualified Reporting.Progress as Progress
22import qualified Reporting.Task as Task
26-- COMPILE
29compile :: Project -> Maybe FilePath -> Module.Interfaces -> Dict Plan.Info -> Task.Task (Dict Answer)
30compile project maybeDocsPath ifaces modules =
31 do Task.report (Progress.CompileStart (Map.size modules))
33 tell <- Task.getReporter
35 answers <- liftIO $
36 do mvar <- newEmptyMVar
37 iMVar <- newMVar ifaces
38 answerMVars <- Map.traverseWithKey (compileModule tell project maybeDocsPath mvar iMVar) modules
39 putMVar mvar answerMVars
40 traverse readMVar answerMVars
42 Task.report Progress.CompileEnd
44 return answers
48-- ANSWERS
51data Answer
52 = Blocked
53 | Bad FilePath Time.UTCTime BS.ByteString [Compiler.Error]
54 | Good Compiler.Artifacts
57type Dict a = Map.Map Module.Raw a
61-- COMPILE MODULE
64compileModule
65 :: (Progress.Progress -> IO ())
66 -> Project
67 -> Maybe FilePath
68 -> MVar (Dict (MVar Answer))
69 -> MVar Module.Interfaces
70 -> Module.Raw
71 -> Plan.Info
72 -> IO (MVar Answer)
73compileModule tell project maybeDocsPath answersMVar ifacesMVar name info =
74 do mvar <- newEmptyMVar
76 void $ forkIO $
77 do answers <- readMVar answersMVar
78 blocked <- isBlocked answers info
79 if blocked
80 then putMVar mvar Blocked
81 else
82 do tell (Progress.CompileFileStart name)
83 let pkg = Project.getName project
84 let docs = toDocsFlag name project maybeDocsPath
85 let imports = makeImports project info
86 ifaces <- readMVar ifacesMVar
87 let context = Compiler.Context pkg docs imports ifaces
88 let source = Plan._src info
89 case Compiler.compile context source of
90 (_warnings, Left errors) ->
91 do tell (Progress.CompileFileEnd name Progress.Bad)
92 let path = Plan._path info
93 let time = Plan._time info
94 putMVar mvar (Bad path time source errors)
96 (_warnings, Right result@(Compiler.Artifacts elmi _ _)) ->
97 do tell (Progress.CompileFileEnd name Progress.Good)
98 let canonicalName = Module.Canonical pkg name
99 lock <- takeMVar ifacesMVar
100 putMVar ifacesMVar (Map.insert canonicalName elmi lock)
101 putMVar mvar (Good result)
103 return mvar
107-- TO DOCS FLAG
110toDocsFlag :: Module.Raw -> Project -> Maybe FilePath -> Compiler.DocsFlag
111toDocsFlag name project maybeDocsPath =
112 case maybeDocsPath of
113 Nothing ->
114 Compiler.NoDocs
116 Just _ ->
117 case project of
118 Project.App _ ->
119 Compiler.NoDocs
121 Project.Pkg info ->
122 if isExposed name (Project._pkg_exposed info) then
123 Compiler.YesDocs
124 else
125 Compiler.NoDocs
128isExposed :: Module.Raw -> Project.Exposed -> Bool
129isExposed name exposed =
130 case exposed of
131 Project.ExposedList modules ->
132 elem name modules
134 Project.ExposedDict chunks ->
135 elem name (concatMap snd chunks)
139-- IMPORTS
142makeImports :: Project -> Plan.Info -> Dict Module.Canonical
143makeImports project (Plan.Info _ _ _ clean dirty foreign) =
144 let
145 pkgName =
146 Project.getName project
148 mkLocal name =
149 ( name, Module.Canonical pkgName name )
151 mkForeign canonicalName@(Module.Canonical _ name) =
152 ( name, canonicalName )
153 in
154 Map.fromList $
155 map mkLocal clean
156 ++ map mkLocal dirty
157 ++ map mkForeign foreign
161-- INTERFACES
164isBlocked :: Dict (MVar Answer) -> Plan.Info -> IO Bool
165isBlocked answers info =
166 anyBlock <$> traverse (get answers) (Plan._dirty info)
169get :: Dict (MVar Answer) -> Module.Raw -> IO Answer
170get names name =
171 case Map.lookup name names of
172 Nothing ->
173 error "bug manifesting in File.Complie.get, please report at <TODO>!"
175 Just mvar ->
176 readMVar mvar
179anyBlock :: [Answer] -> Bool
180anyBlock answers =
181 case answers of
182 [] ->
183 False
185 Blocked : _ ->
186 True
188 Bad _ _ _ _ : _ ->
189 True
191 Good _ : otherAnswers ->
192 anyBlock otherAnswers