git.iko.soy/elk
on e7ca69f help sign in
elk/builder/src/File/Compile.hs
191 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.Interface as I
17import qualified Elm.ModuleName as ModuleName
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 -> I.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 ModuleName.Raw a
61-- COMPILE MODULE
64compileModule
65 :: (Progress.Progress -> IO ())
66 -> Project
67 -> Maybe FilePath
68 -> MVar (Dict (MVar Answer))
69 -> MVar I.Interfaces
70 -> ModuleName.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 source = Plan._src info
88 case Compiler.compile docs pkg imports ifaces source of
89 (_warnings, Left errors) ->
90 do tell (Progress.CompileFileEnd name Progress.Bad)
91 let time = Plan._time info
92 let path = Plan._path info
93 putMVar mvar (Bad path time source errors)
95 (_warnings, Right result@(Compiler.Artifacts elmi _ _)) ->
96 do tell (Progress.CompileFileEnd name Progress.Good)
97 let canonicalName = ModuleName.Canonical pkg name
98 lock <- takeMVar ifacesMVar
99 putMVar ifacesMVar (Map.insert canonicalName elmi lock)
100 putMVar mvar (Good result)
102 return mvar
106-- TO DOCS FLAG
109toDocsFlag :: ModuleName.Raw -> Project -> Maybe FilePath -> Compiler.DocsFlag
110toDocsFlag name project maybeDocsPath =
111 case maybeDocsPath of
112 Nothing ->
113 Compiler.NoDocs
115 Just _ ->
116 case project of
117 Project.App _ ->
118 Compiler.NoDocs
120 Project.Pkg info ->
121 if isExposed name (Project._pkg_exposed info) then
122 Compiler.YesDocs
123 else
124 Compiler.NoDocs
127isExposed :: ModuleName.Raw -> Project.Exposed -> Bool
128isExposed name exposed =
129 case exposed of
130 Project.ExposedList modules ->
131 elem name modules
133 Project.ExposedDict chunks ->
134 elem name (concatMap snd chunks)
138-- IMPORTS
141makeImports :: Project -> Plan.Info -> Dict ModuleName.Canonical
142makeImports project (Plan.Info _ _ _ clean dirty foreign) =
143 let
144 pkgName =
145 Project.getName project
147 mkLocal name =
148 ( name, ModuleName.Canonical pkgName name )
150 mkForeign canonicalName@(ModuleName.Canonical _ name) =
151 ( name, canonicalName )
152 in
153 Map.fromList $
154 map mkLocal clean
155 ++ map mkLocal dirty
156 ++ map mkForeign foreign
160-- INTERFACES
163isBlocked :: Dict (MVar Answer) -> Plan.Info -> IO Bool
164isBlocked answers info =
165 anyBlock <$> traverse (get answers) (Plan._dirty info)
168get :: Dict (MVar Answer) -> ModuleName.Raw -> IO Answer
169get names name =
170 case Map.lookup name names of
171 Nothing ->
172 error "bug manifesting in File.Complie.get, please report at <TODO>!"
174 Just mvar ->
175 readMVar mvar
178anyBlock :: [Answer] -> Bool
179anyBlock answers =
180 case answers of
181 [] ->
182 False
184 Blocked : _ ->
185 True
187 Bad _ _ _ _ : _ ->
188 True
190 Good _ : otherAnswers ->
191 anyBlock otherAnswers