git.iko.soy/elk
on 83cd588 help sign in
elk/builder/src/File/Crawl.hs
297 lines 8.2 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module File.Crawl
4 ( Result
5 , Graph(..)
6 , crawl
7 , crawlFromSource
8 )
9 where
11import Control.Concurrent.Chan (Chan, newChan, readChan)
12import Control.Monad (foldM)
13import Control.Monad.Except (liftIO)
14import qualified Data.ByteString as BS
15import qualified Data.Graph as Graph
16import qualified Data.Map as Map
17import qualified Data.Set as Set
19import qualified Elm.Compiler.Objects as Obj
20import qualified Elm.Kernel as Kernel
21import qualified Elm.ModuleName as ModuleName
22import qualified Elm.Package as Pkg
24import qualified Elm.Project.Json as Project
25import Elm.Project.Summary (Summary(..))
26import qualified File.Args as Args
27import qualified File.Find as Find
28import qualified File.Header as Header
29import qualified File.IO as IO
30import qualified Reporting.Exit as Exit
31import qualified Reporting.Exit.Crawl as E
32import qualified Reporting.Task as Task
36-- GRAPH
39data Graph kernel problems =
40 Graph
41 { _args :: Args.Args ModuleName.Raw
42 , _locals :: Map.Map ModuleName.Raw Header.Info
43 , _kernels :: Map.Map ModuleName.Raw kernel
44 , _foreigns :: Map.Map ModuleName.Raw Pkg.Canonical
45 , _problems :: problems
46 }
49type Result =
50 Graph Obj.Kernel ()
53type WorkGraph =
54 Graph (FilePath, Maybe FilePath) [E.Problem]
57initWorkGraph :: Args.Args ModuleName.Raw -> Map.Map ModuleName.Raw Header.Info -> WorkGraph
58initWorkGraph args locals =
59 Graph args locals Map.empty Map.empty []
63-- CRAWL
66crawl :: Summary -> Args.Args FilePath -> Task.Task Result
67crawl summary args =
68 case args of
69 Args.Pkg names ->
70 do let roots = map (Unvisited E.ElmJson) names
71 let graph = initWorkGraph (Args.Pkg names) Map.empty
72 depthFirstSearch summary roots graph
74 Args.Roots path [] ->
75 crawlHelp summary =<< Header.readOneFile summary path
77 Args.Roots p ps ->
78 do (h,hs) <- Header.readManyFiles summary p ps
79 let unvisited = concatMap toUnvisited (h:hs)
80 let graph = initWorkGraph (Args.Roots (fst h) (map fst hs)) (Map.fromList (h:hs))
81 depthFirstSearch summary unvisited graph
82 where
83 toUnvisited (name, Header.Info path _ _ deps) =
84 map (Unvisited (E.Module path name)) deps
87crawlFromSource :: Summary -> BS.ByteString -> Task.Task Result
88crawlFromSource summary@(Summary _ project _ _ _) source =
89 crawlHelp summary =<<
90 Header.readSource project source
93crawlHelp :: Summary -> ( Maybe ModuleName.Raw, Header.Info ) -> Task.Task Result
94crawlHelp summary ( maybeName, info@(Header.Info path _ _ deps) ) =
95 do let name = maybe "Main" id maybeName
96 let toUnvisited dep = Unvisited (maybe (E.File path) (E.Module path) maybeName) dep
97 let roots = map toUnvisited deps
98 let graph = initWorkGraph (Args.Roots name []) (Map.singleton name info)
99 depthFirstSearch summary roots graph
103-- DEPTH FIRST SEARCH
106depthFirstSearch :: Summary -> [Unvisited] -> WorkGraph -> Task.Task Result
107depthFirstSearch summary unvisited startGraph =
108 do chan <- liftIO newChan
110 (Graph args locals kernelPaths foreigns problems) <-
111 dfs summary chan 0 Set.empty unvisited startGraph
113 case problems of
114 [] ->
115 do checkForCycles locals
116 kernels <- visitKernels summary locals kernelPaths
117 return $ Graph args locals kernels foreigns ()
119 problem : otherProblems ->
120 Task.throw (Exit.Crawl (E.DependencyProblems problem otherProblems))
124-- CHECK FOR CYCLES
127checkForCycles :: Map.Map ModuleName.Raw Header.Info -> Task.Task ()
128checkForCycles locals =
129 let
130 toNode (name, Header.Info _ _ _ imports) =
131 (name, name, imports)
133 components =
134 Graph.stronglyConnComp (map toNode (Map.toList locals))
135 in
136 mapM_ checkComponent components
139checkComponent :: Graph.SCC ModuleName.Raw -> Task.Task ()
140checkComponent scc =
141 case scc of
142 Graph.AcyclicSCC _ ->
143 return ()
145 Graph.CyclicSCC names ->
146 Task.throw (Exit.Cycle names)
150-- CONCURRENT DEPTH FIRST SEARCH
153dfs
154 :: Summary
155 -> Chan (Either E.Problem Asset)
156 -> Int
157 -> Set.Set ModuleName.Raw
158 -> [Unvisited]
159 -> WorkGraph
160 -> Task.Task WorkGraph
161dfs summary chan oldPending oldSeen unvisited graph =
162 do (seen, pending) <-
163 foldM (spawnVisitor summary chan) (oldSeen, oldPending) unvisited
165 if pending == 0
166 then return graph
167 else
168 do asset <- liftIO $ readChan chan
169 case asset of
170 Right (Local name info@(Header.Info path _ _ imports)) ->
171 do let newGraph = graph { _locals = Map.insert name info (_locals graph) }
172 let deps = map (Unvisited (E.Module path name)) imports
173 dfs summary chan (pending - 1) seen deps newGraph
175 Right (Kernel name info) ->
176 do let kernels = Map.insert name info (_kernels graph)
177 let newGraph = graph { _kernels = kernels }
178 dfs summary chan (pending - 1) seen [] newGraph
180 Right (Foreign name pkg) ->
181 do let foreigns = Map.insert name pkg (_foreigns graph)
182 let newGraph = graph { _foreigns = foreigns }
183 dfs summary chan (pending - 1) seen [] newGraph
185 Right ForeignKernel ->
186 dfs summary chan (pending - 1) seen [] graph
188 Left problem ->
189 do let problems = problem : _problems graph
190 let newGraph = graph { _problems = problems }
191 dfs summary chan (pending - 1) seen [] newGraph
194spawnVisitor
195 :: Summary
196 -> Chan (Either E.Problem Asset)
197 -> (Set.Set ModuleName.Raw, Int)
198 -> Unvisited
199 -> Task.Task (Set.Set ModuleName.Raw, Int)
200spawnVisitor summary chan (seen, n) unvisited@(Unvisited _ name) =
201 if Set.member name seen then
202 return (seen, n)
203 else
204 do Task.workerChan chan (toVisitor summary unvisited)
205 return (Set.insert name seen, n + 1)
209-- VISITOR
212data Unvisited =
213 Unvisited
214 { _origin :: E.Origin
215 , _name :: ModuleName.Raw
216 }
219data Asset
220 = Local ModuleName.Raw Header.Info
221 | Kernel ModuleName.Raw (FilePath, Maybe FilePath)
222 | Foreign ModuleName.Raw Pkg.Canonical
223 | ForeignKernel
226toVisitor :: Summary -> Unvisited -> Task.Task_ E.Problem Asset
227toVisitor summary (Unvisited origin name) =
228 do asset <- Find.find summary origin name
229 case asset of
230 Find.Local path ->
231 uncurry Local <$> Header.readModule summary name path
233 Find.Foreign pkg ->
234 return $ Foreign name pkg
236 Find.Kernel clientPath maybeServerPath ->
237 return $ Kernel name (clientPath, maybeServerPath)
239 Find.ForeignKernel ->
240 return ForeignKernel
244-- VISIT KERNELS
247visitKernels
248 :: Summary
249 -> Map.Map ModuleName.Raw Header.Info
250 -> Map.Map ModuleName.Raw (FilePath, Maybe FilePath)
251 -> Task.Task (Map.Map ModuleName.Raw Obj.Kernel)
252visitKernels summary locals kernelPaths =
253 if Map.null kernelPaths then
254 return Map.empty
255 else
256 -- TODO do this concurrently?
257 -- Need better concurrency primitives in Task
258 traverse (readKernel (toImportDict summary locals)) kernelPaths
261readKernel :: ImportDict -> (FilePath, Maybe FilePath) -> Task.Task Obj.Kernel
262readKernel importDict (clientPath, maybeServerPath) =
263 Obj.Kernel
264 <$> readKContent importDict clientPath
265 <*> traverse (readKContent importDict) maybeServerPath
268readKContent :: ImportDict -> FilePath -> Task.Task Kernel.KContent
269readKContent importDict path =
270 do source <- liftIO $ IO.readUtf8 path
271 case Kernel.parse importDict source of
272 Right content ->
273 return content
275 Left _ ->
276 Task.throw (Exit.Crawl (E.BadKernelHeader path))
280-- IMPORT DICT
283type ImportDict =
284 Map.Map ModuleName.Raw [Pkg.Name]
287toImportDict :: Summary -> Map.Map ModuleName.Raw info -> ImportDict
288toImportDict (Summary _ project exposed _ _) locals =
289 let
290 localPkg =
291 [Project.getName project]
293 addLocal name _ dict =
294 Map.insertWith (++) name localPkg dict
295 in
296 Map.foldrWithKey addLocal (Map.map (map Pkg._name) exposed) locals