git.iko.soy/elk
on f25154e help sign in
elk/builder/src/File/Compile.hs
157 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.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 -> I.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 ModuleName.Raw a
61-- COMPILE MODULE
64compileModule
65 :: (Progress.Progress -> IO ())
66 -> Project
67 -> MVar (Dict (MVar Answer))
68 -> MVar I.Interfaces
69 -> ModuleName.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 imports = makeImports project info
84 ifaces <- readMVar ifacesMVar
85 let source = Plan._src info
86 case Compiler.compile pkg imports ifaces source of
87 (_warnings, Left errors) ->
88 do tell (Progress.CompileFileEnd name Progress.Bad)
89 let time = Plan._time info
90 let path = Plan._path info
91 putMVar mvar (Bad path time source errors)
93 (_warnings, Right result@(Compiler.Artifacts elmi _)) ->
94 do tell (Progress.CompileFileEnd name Progress.Good)
95 let canonicalName = ModuleName.Canonical pkg name
96 lock <- takeMVar ifacesMVar
97 putMVar ifacesMVar (Map.insert canonicalName elmi lock)
98 putMVar mvar (Good result)
100 return mvar
104-- IMPORTS
107makeImports :: Project -> Plan.Info -> Dict ModuleName.Canonical
108makeImports project (Plan.Info _ _ _ clean dirty foreign) =
109 let
110 pkgName =
111 Project.getName project
113 mkLocal name =
114 ( name, ModuleName.Canonical pkgName name )
116 mkForeign canonicalName@(ModuleName.Canonical _ name) =
117 ( name, canonicalName )
118 in
119 Map.fromList $
120 map mkLocal clean
121 ++ map mkLocal dirty
122 ++ map mkForeign foreign
126-- INTERFACES
129isBlocked :: Dict (MVar Answer) -> Plan.Info -> IO Bool
130isBlocked answers info =
131 anyBlock <$> traverse (get answers) (Plan._dirty info)
134get :: Dict (MVar Answer) -> ModuleName.Raw -> IO Answer
135get names name =
136 case Map.lookup name names of
137 Nothing ->
138 error "bug manifesting in File.Complie.get, please report at <TODO>!"
140 Just mvar ->
141 readMVar mvar
144anyBlock :: [Answer] -> Bool
145anyBlock answers =
146 case answers of
147 [] ->
148 False
150 Blocked : _ ->
151 True
153 Bad _ _ _ _ : _ ->
154 True
156 Good _ : otherAnswers ->
157 anyBlock otherAnswers