git.iko.soy/elk
on 1c3cda7 help sign in
elk/builder/src/File/Compile.hs
159 lines 4.1 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 -> Module.Interfaces -> Dict Plan.Info -> Task.Task (Dict Answer)
30compile project 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 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 -> MVar (Dict (MVar Answer))
68 -> MVar Module.Interfaces
69 -> Module.Raw
70 -> Plan.Info
71 -> IO (MVar Answer)
72compileModule tell project answersMVar ifacesMVar name info =
73 do mvar <- newEmptyMVar
75 void $ forkIO $
76 do answers <- readMVar answersMVar
77 blocked <- isBlocked answers info
78 if blocked
79 then putMVar mvar Blocked
80 else
81 do tell (Progress.CompileFileStart name)
82 let pkg = Project.getName project
83 let isExposed = Project.isPackageRoot name project
84 let imports = makeImports project info
85 ifaces <- readMVar ifacesMVar
86 let context = Compiler.Context pkg isExposed imports ifaces
87 let source = Plan._src info
88 case Compiler.compile context source of
89 (_warnings, Left errors) ->
90 do tell (Progress.CompileFileEnd name Progress.Bad)
91 let path = Plan._path info
92 let time = Plan._time 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 = Module.Canonical pkg name
98 lock <- takeMVar ifacesMVar
99 putMVar ifacesMVar (Map.insert canonicalName elmi lock)
100 putMVar mvar (Good result)
102 return mvar
106-- IMPORTS
109makeImports :: Project -> Plan.Info -> Dict Module.Canonical
110makeImports project (Plan.Info _ _ _ clean dirty foreign) =
111 let
112 pkgName =
113 Project.getName project
115 mkLocal name =
116 ( name, Module.Canonical pkgName name )
118 mkForeign canonicalName@(Module.Canonical _ name) =
119 ( name, canonicalName )
120 in
121 Map.fromList $
122 map mkLocal clean
123 ++ map mkLocal dirty
124 ++ map mkForeign foreign
128-- INTERFACES
131isBlocked :: Dict (MVar Answer) -> Plan.Info -> IO Bool
132isBlocked answers info =
133 anyBlock <$> traverse (get answers) (Plan._dirty info)
136get :: Dict (MVar Answer) -> Module.Raw -> IO Answer
137get names name =
138 case Map.lookup name names of
139 Nothing ->
140 error "bug manifesting in File.Complie.get, please report at <TODO>!"
142 Just mvar ->
143 readMVar mvar
146anyBlock :: [Answer] -> Bool
147anyBlock answers =
148 case answers of
149 [] ->
150 False
152 Blocked : _ ->
153 True
155 Bad _ _ _ _ : _ ->
156 True
158 Good _ : otherAnswers ->
159 anyBlock otherAnswers