git.iko.soy/elk
on d4e9599 help sign in
elk/builder/src/File/Crawl.hs
294 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.List.NonEmpty as NonEmpty
17import Data.List.NonEmpty (NonEmpty((:|)))
18import qualified Data.Map as Map
19import qualified Data.Set as Set
21import qualified Elm.Compiler.Module as Module
22import qualified Elm.Compiler.Objects as Obj
23import qualified Elm.Kernel as Kernel
24import qualified Elm.Package as Pkg
26import qualified Elm.Project.Json as Project
27import Elm.Project.Summary (Summary(..))
28import qualified File.Args as Args
29import qualified File.Find as Find
30import qualified File.Header as Header
31import qualified File.IO as IO
32import qualified Reporting.Exit as Exit
33import qualified Reporting.Exit.Crawl as E
34import qualified Reporting.Task as Task
38-- GRAPH
41data Graph kernel problems =
42 Graph
43 { _args :: Args.Args Module.Raw
44 , _locals :: Map.Map Module.Raw Header.Info
45 , _kernels :: Map.Map Module.Raw kernel
46 , _foreigns :: Map.Map Module.Raw Pkg.Package
47 , _problems :: problems
48 }
51type Result =
52 Graph Obj.Kernel ()
55type WorkGraph =
56 Graph (FilePath, Maybe FilePath) [E.Problem]
59initWorkGraph :: Args.Args Module.Raw -> Map.Map Module.Raw Header.Info -> WorkGraph
60initWorkGraph args locals =
61 Graph args locals Map.empty Map.empty []
65-- CRAWL
68crawl :: Summary -> Args.Args FilePath -> Task.Task Result
69crawl summary args =
70 case args of
71 Args.Pkg names ->
72 do let roots = map (Unvisited E.ElmJson) names
73 let graph = initWorkGraph (Args.Pkg names) Map.empty
74 depthFirstSearch summary roots graph
76 Args.Roots (path :| []) ->
77 crawlHelp summary =<< Header.readOneFile summary path
79 Args.Roots paths ->
80 do headers <- Header.readManyFiles summary paths
81 let names = NonEmpty.map fst headers
82 let unvisited = concatMap toUnvisited (NonEmpty.toList headers)
83 let graph = initWorkGraph (Args.Roots names) (Map.fromList (NonEmpty.toList headers))
84 depthFirstSearch summary unvisited graph
85 where
86 toUnvisited (name, Header.Info path _ _ deps) =
87 map (Unvisited (E.Module path name)) deps
90crawlFromSource :: Summary -> BS.ByteString -> Task.Task Result
91crawlFromSource summary@(Summary _ project _ _ _) source =
92 crawlHelp summary =<<
93 Header.readSource project source
96crawlHelp :: Summary -> ( Maybe Module.Raw, Header.Info ) -> Task.Task Result
97crawlHelp summary ( maybeName, info@(Header.Info path _ _ deps) ) =
98 do let name = maybe "Main" id maybeName
99 let args = Args.Roots (name :| [])
100 let toUnvisited dep = Unvisited (maybe (E.File path) (E.Module path) maybeName) dep
101 let roots = map toUnvisited deps
102 let graph = initWorkGraph args (Map.singleton name info)
103 depthFirstSearch summary roots graph
107-- DEPTH FIRST SEARCH
110depthFirstSearch :: Summary -> [Unvisited] -> WorkGraph -> Task.Task Result
111depthFirstSearch summary unvisited startGraph =
112 do chan <- liftIO newChan
114 (Graph args locals kernelPaths foreigns problems) <-
115 dfs summary chan 0 Set.empty unvisited startGraph
117 case problems of
118 [] ->
119 do checkForCycles locals
120 kernels <- visitKernels summary locals kernelPaths
121 return $ Graph args locals kernels foreigns ()
123 problem : otherProblems ->
124 Task.throw (Exit.Crawl (E.DependencyProblems problem otherProblems))
128-- CHECK FOR CYCLES
131checkForCycles :: Map.Map Module.Raw Header.Info -> Task.Task ()
132checkForCycles locals =
133 let
134 toNode (name, Header.Info _ _ _ imports) =
135 (name, name, imports)
137 components =
138 Graph.stronglyConnComp (map toNode (Map.toList locals))
139 in
140 mapM_ checkComponent components
143checkComponent :: Graph.SCC Module.Raw -> Task.Task ()
144checkComponent scc =
145 case scc of
146 Graph.AcyclicSCC _ ->
147 return ()
149 Graph.CyclicSCC names ->
150 Task.throw (Exit.Cycle names)
154-- CONCURRENT DEPTH FIRST SEARCH
157dfs
158 :: Summary
159 -> Chan (Either E.Problem Asset)
160 -> Int
161 -> Set.Set Module.Raw
162 -> [Unvisited]
163 -> WorkGraph
164 -> Task.Task WorkGraph
165dfs summary chan oldPending oldSeen unvisited graph =
166 do (seen, pending) <-
167 foldM (spawnVisitor summary chan) (oldSeen, oldPending) unvisited
169 if pending == 0
170 then return graph
171 else
172 do asset <- liftIO $ readChan chan
173 case asset of
174 Right (Local name info@(Header.Info path _ _ imports)) ->
175 do let newGraph = graph { _locals = Map.insert name info (_locals graph) }
176 let deps = map (Unvisited (E.Module path name)) imports
177 dfs summary chan (pending - 1) seen deps newGraph
179 Right (Kernel name info) ->
180 do let kernels = Map.insert name info (_kernels graph)
181 let newGraph = graph { _kernels = kernels }
182 dfs summary chan (pending - 1) seen [] newGraph
184 Right (Foreign name pkg) ->
185 do let foreigns = Map.insert name pkg (_foreigns graph)
186 let newGraph = graph { _foreigns = foreigns }
187 dfs summary chan (pending - 1) seen [] newGraph
189 Left problem ->
190 do let problems = problem : _problems graph
191 let newGraph = graph { _problems = problems }
192 dfs summary chan (pending - 1) seen [] newGraph
195spawnVisitor
196 :: Summary
197 -> Chan (Either E.Problem Asset)
198 -> (Set.Set Module.Raw, Int)
199 -> Unvisited
200 -> Task.Task (Set.Set Module.Raw, Int)
201spawnVisitor summary chan (seen, n) unvisited@(Unvisited _ name) =
202 if Set.member name seen then
203 return (seen, n)
204 else
205 do Task.workerChan chan (toVisitor summary unvisited)
206 return (Set.insert name seen, n + 1)
210-- VISITOR
213data Unvisited =
214 Unvisited
215 { _origin :: E.Origin
216 , _name :: Module.Raw
217 }
220data Asset
221 = Local Module.Raw Header.Info
222 | Kernel Module.Raw (FilePath, Maybe FilePath)
223 | Foreign Module.Raw Pkg.Package
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)
241-- VISIT KERNELS
244visitKernels
245 :: Summary
246 -> Map.Map Module.Raw Header.Info
247 -> Map.Map Module.Raw (FilePath, Maybe FilePath)
248 -> Task.Task (Map.Map Module.Raw Obj.Kernel)
249visitKernels summary locals kernelPaths =
250 if Map.null kernelPaths then
251 return Map.empty
252 else
253 -- TODO do this concurrently?
254 -- Need better concurrency primitives in Task
255 traverse (readKernel (toImportDict summary locals)) kernelPaths
258readKernel :: ImportDict -> (FilePath, Maybe FilePath) -> Task.Task Obj.Kernel
259readKernel importDict (clientPath, maybeServerPath) =
260 Obj.Kernel
261 <$> readKContent importDict clientPath
262 <*> traverse (readKContent importDict) maybeServerPath
265readKContent :: ImportDict -> FilePath -> Task.Task Kernel.KContent
266readKContent importDict path =
267 do source <- liftIO $ IO.readUtf8 path
268 case Kernel.parse importDict source of
269 Right content ->
270 return content
272 Left _ ->
273 Task.throw (Exit.Crawl (E.BadKernelHeader path))
277-- IMPORT DICT
280type ImportDict =
281 Map.Map Module.Raw [Pkg.Name]
284toImportDict :: Summary -> Map.Map Module.Raw info -> ImportDict
285toImportDict (Summary _ project exposed _ _) locals =
286 let
287 localPkg =
288 [Project.getName project]
290 addLocal name _ dict =
291 Map.insertWith (++) name localPkg dict
292 in
293 Map.foldrWithKey addLocal (Map.map (map Pkg._name) exposed) locals