git.iko.soy/elk
on master help sign in
Get rid of File/* modules

Going to collapse all this logic into one file that uses metadata to avoid reading all files from disk.

commit9a6ad86af87fb24a8c381259c99f52d3a1c92ecb authorEvan Czaplicki <evancz@users.noreply.github.com> dateTue 12 Feb 2019, 18:36 (8 years ago) parent6dc8960
6 files changed−1008
compare with master
unifiedsplit
builder/src/File/Args.hs−40 builder/src/File/Compile.hs−157 builder/src/File/Crawl.hs−297 builder/src/File/Find.hs−114 builder/src/File/Header.hs−203 builder/src/File/Plan.hs−197
builder/src/File/Args.hsdeleted−40
@@ -1,40 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−module File.Args
3− ( Args(..)
4− , fromPaths
5− , fromSummary
6− )
7− where
8−
9−
10−import qualified Elm.ModuleName as ModuleName
11−import qualified Elm.Project.Json as Project
12−import qualified Elm.Project.Summary as Summary
13−import qualified Reporting.Exit as Exit
14−import qualified Reporting.Exit.Make as E
15−import qualified Reporting.Task as Task
16−
17−
18−data Args root
19− = Pkg [ModuleName.Raw]
20− | Roots root [root]
21−
22−
23−fromPaths :: Summary.Summary -> [FilePath] -> Task.Task (Args FilePath)
24−fromPaths summary paths =
25− case paths of
26− [] ->
27− fromSummary summary
28−
29− first : rest ->
30− return $ Roots first rest
31−
32−
33−fromSummary :: Summary.Summary -> Task.Task (Args a)
34−fromSummary (Summary.Summary _ project _ _ _) =
35− case project of
36− Project.Pkg info ->
37− return $ Pkg (Project.getExposed info)
38−
39− Project.App _ ->
40− Task.throw (Exit.Make E.CannotMakeNothing)
builder/src/File/Compile.hsdeleted−157
@@ -1,157 +0,0 @@
1−module File.Compile
2− ( compile
3− , Answer(..)
4− )
5− where
6−
7−import Control.Concurrent (forkIO)
8−import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, readMVar, takeMVar)
9−import Control.Monad (void)
10−import Control.Monad.Except (liftIO)
11−import qualified Data.ByteString as BS
12−import qualified Data.Map as Map
13−import qualified Data.Time.Clock as Time
14−
15−import qualified Elm.Compiler as Compiler
16−import qualified Elm.Interface as I
17−import qualified Elm.ModuleName as ModuleName
18−import Elm.Project.Json (Project)
19−import qualified Elm.Project.Json as Project
20−import qualified File.Plan as Plan
21−import qualified Reporting.Progress as Progress
22−import qualified Reporting.Task as Task
23−
24−
25−
26−-- COMPILE
27−
28−
29−compile :: Project -> I.Interfaces -> Dict Plan.Info -> Task.Task (Dict Answer)
30−compile project ifaces modules =
31− do Task.report (Progress.CompileStart (Map.size modules))
32−
33− tell <- Task.getReporter
34−
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
41−
42− Task.report Progress.CompileEnd
43−
44− return answers
45−
46−
47−
48−-- ANSWERS
49−
50−
51−data Answer
52− = Blocked
53− | Bad FilePath Time.UTCTime BS.ByteString [Compiler.Error]
54− | Good Compiler.Artifacts
55−
56−
57−type Dict a = Map.Map ModuleName.Raw a
58−
59−
60−
61−-- COMPILE MODULE
62−
63−
64−compileModule
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)
72−compileModule tell project answersMVar ifacesMVar name info =
73− do mvar <- newEmptyMVar
74−
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)
92−
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)
99−
100− return mvar
101−
102−
103−
104−-- IMPORTS
105−
106−
107−makeImports :: Project -> Plan.Info -> Dict ModuleName.Canonical
108−makeImports project (Plan.Info _ _ _ clean dirty foreign) =
109− let
110− pkgName =
111− Project.getName project
112−
113− mkLocal name =
114− ( name, ModuleName.Canonical pkgName name )
115−
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
123−
124−
125−
126−-- INTERFACES
127−
128−
129−isBlocked :: Dict (MVar Answer) -> Plan.Info -> IO Bool
130−isBlocked answers info =
131− anyBlock <$> traverse (get answers) (Plan._dirty info)
132−
133−
134−get :: Dict (MVar Answer) -> ModuleName.Raw -> IO Answer
135−get names name =
136− case Map.lookup name names of
137− Nothing ->
138− error "bug manifesting in File.Complie.get, please report at <TODO>!"
139−
140− Just mvar ->
141− readMVar mvar
142−
143−
144−anyBlock :: [Answer] -> Bool
145−anyBlock answers =
146− case answers of
147− [] ->
148− False
149−
150− Blocked : _ ->
151− True
152−
153− Bad _ _ _ _ : _ ->
154− True
155−
156− Good _ : otherAnswers ->
157− anyBlock otherAnswers
builder/src/File/Crawl.hsdeleted−297
@@ -1,297 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module File.Crawl
4− ( Result
5− , Graph(..)
6− , crawl
7− , crawlFromSource
8− )
9− where
10−
11−import Control.Concurrent.Chan (Chan, newChan, readChan)
12−import Control.Monad (foldM)
13−import Control.Monad.Except (liftIO)
14−import qualified Data.ByteString as BS
15−import qualified Data.Graph as Graph
16−import qualified Data.Map as Map
17−import qualified Data.Set as Set
18−
19−import qualified Elm.Compiler.Objects as Obj
20−import qualified Elm.Kernel as Kernel
21−import qualified Elm.ModuleName as ModuleName
22−import qualified Elm.Package as Pkg
23−
24−import qualified Elm.Project.Json as Project
25−import Elm.Project.Summary (Summary(..))
26−import qualified File.Args as Args
27−import qualified File.Find as Find
28−import qualified File.Header as Header
29−import qualified File.IO as IO
30−import qualified Reporting.Exit as Exit
31−import qualified Reporting.Exit.Crawl as E
32−import qualified Reporting.Task as Task
33−
34−
35−
36−-- GRAPH
37−
38−
39−data 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− }
47−
48−
49−type Result =
50− Graph Obj.Kernel ()
51−
52−
53−type WorkGraph =
54− Graph (FilePath, Maybe FilePath) [E.Problem]
55−
56−
57−initWorkGraph :: Args.Args ModuleName.Raw -> Map.Map ModuleName.Raw Header.Info -> WorkGraph
58−initWorkGraph args locals =
59− Graph args locals Map.empty Map.empty []
60−
61−
62−
63−-- CRAWL
64−
65−
66−crawl :: Summary -> Args.Args FilePath -> Task.Task Result
67−crawl 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
73−
74− Args.Roots path [] ->
75− crawlHelp summary =<< Header.readOneFile summary path
76−
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
85−
86−
87−crawlFromSource :: Summary -> BS.ByteString -> Task.Task Result
88−crawlFromSource summary@(Summary _ project _ _ _) source =
89− crawlHelp summary =<<
90− Header.readSource project source
91−
92−
93−crawlHelp :: Summary -> ( Maybe ModuleName.Raw, Header.Info ) -> Task.Task Result
94−crawlHelp 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
100−
101−
102−
103−-- DEPTH FIRST SEARCH
104−
105−
106−depthFirstSearch :: Summary -> [Unvisited] -> WorkGraph -> Task.Task Result
107−depthFirstSearch summary unvisited startGraph =
108− do chan <- liftIO newChan
109−
110− (Graph args locals kernelPaths foreigns problems) <-
111− dfs summary chan 0 Set.empty unvisited startGraph
112−
113− case problems of
114− [] ->
115− do checkForCycles locals
116− kernels <- visitKernels summary locals kernelPaths
117− return $ Graph args locals kernels foreigns ()
118−
119− problem : otherProblems ->
120− Task.throw (Exit.Crawl (E.DependencyProblems problem otherProblems))
121−
122−
123−
124−-- CHECK FOR CYCLES
125−
126−
127−checkForCycles :: Map.Map ModuleName.Raw Header.Info -> Task.Task ()
128−checkForCycles locals =
129− let
130− toNode (name, Header.Info _ _ _ imports) =
131− (name, name, imports)
132−
133− components =
134− Graph.stronglyConnComp (map toNode (Map.toList locals))
135− in
136− mapM_ checkComponent components
137−
138−
139−checkComponent :: Graph.SCC ModuleName.Raw -> Task.Task ()
140−checkComponent scc =
141− case scc of
142− Graph.AcyclicSCC _ ->
143− return ()
144−
145− Graph.CyclicSCC names ->
146− Task.throw (Exit.Cycle names)
147−
148−
149−
150−-- CONCURRENT DEPTH FIRST SEARCH
151−
152−
153−dfs
154− :: Summary
155− -> Chan (Either E.Problem Asset)
156− -> Int
157− -> Set.Set ModuleName.Raw
158− -> [Unvisited]
159− -> WorkGraph
160− -> Task.Task WorkGraph
161−dfs summary chan oldPending oldSeen unvisited graph =
162− do (seen, pending) <-
163− foldM (spawnVisitor summary chan) (oldSeen, oldPending) unvisited
164−
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
174−
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
179−
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
184−
185− Right ForeignKernel ->
186− dfs summary chan (pending - 1) seen [] graph
187−
188− Left problem ->
189− do let problems = problem : _problems graph
190− let newGraph = graph { _problems = problems }
191− dfs summary chan (pending - 1) seen [] newGraph
192−
193−
194−spawnVisitor
195− :: Summary
196− -> Chan (Either E.Problem Asset)
197− -> (Set.Set ModuleName.Raw, Int)
198− -> Unvisited
199− -> Task.Task (Set.Set ModuleName.Raw, Int)
200−spawnVisitor 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)
206−
207−
208−
209−-- VISITOR
210−
211−
212−data Unvisited =
213− Unvisited
214− { _origin :: E.Origin
215− , _name :: ModuleName.Raw
216− }
217−
218−
219−data Asset
220− = Local ModuleName.Raw Header.Info
221− | Kernel ModuleName.Raw (FilePath, Maybe FilePath)
222− | Foreign ModuleName.Raw Pkg.Canonical
223− | ForeignKernel
224−
225−
226−toVisitor :: Summary -> Unvisited -> Task.Task_ E.Problem Asset
227−toVisitor 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
232−
233− Find.Foreign pkg ->
234− return $ Foreign name pkg
235−
236− Find.Kernel clientPath maybeServerPath ->
237− return $ Kernel name (clientPath, maybeServerPath)
238−
239− Find.ForeignKernel ->
240− return ForeignKernel
241−
242−
243−
244−-- VISIT KERNELS
245−
246−
247−visitKernels
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)
252−visitKernels 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
259−
260−
261−readKernel :: ImportDict -> (FilePath, Maybe FilePath) -> Task.Task Obj.Kernel
262−readKernel importDict (clientPath, maybeServerPath) =
263− Obj.Kernel
264− <$> readKContent importDict clientPath
265− <*> traverse (readKContent importDict) maybeServerPath
266−
267−
268−readKContent :: ImportDict -> FilePath -> Task.Task Kernel.KContent
269−readKContent importDict path =
270− do source <- liftIO $ IO.readUtf8 path
271− case Kernel.parse importDict source of
272− Right content ->
273− return content
274−
275− Left _ ->
276− Task.throw (Exit.Crawl (E.BadKernelHeader path))
277−
278−
279−
280−-- IMPORT DICT
281−
282−
283−type ImportDict =
284− Map.Map ModuleName.Raw [Pkg.Name]
285−
286−
287−toImportDict :: Summary -> Map.Map ModuleName.Raw info -> ImportDict
288−toImportDict (Summary _ project exposed _ _) locals =
289− let
290− localPkg =
291− [Project.getName project]
292−
293− addLocal name _ dict =
294− Map.insertWith (++) name localPkg dict
295− in
296− Map.foldrWithKey addLocal (Map.map (map Pkg._name) exposed) locals
297−
builder/src/File/Find.hsdeleted−114
@@ -1,114 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module File.Find
4− ( Asset(..)
5− , find
6− )
7− where
8−
9−import Control.Monad.Except (liftIO)
10−import qualified Data.Map as Map
11−import qualified Data.Maybe as Maybe
12−import qualified Data.Name as Name
13−import qualified System.FilePath as FP
14−import qualified System.Directory as Dir
15−import System.FilePath ((</>), (<.>))
16−
17−import qualified Elm.ModuleName as ModuleName
18−import qualified Elm.Package as Pkg
19−
20−import qualified Elm.Project.Json as Project
21−import qualified Elm.Project.Summary as Summary
22−import qualified Reporting.Exit.Crawl as E
23−import qualified Reporting.Task as Task
24−
25−
26−
27−-- ASSET
28−
29−
30−data Asset
31− = Local FilePath
32− | Kernel FilePath (Maybe FilePath)
33− | Foreign Pkg.Canonical
34− | ForeignKernel
35−
36−
37−
38−-- FIND
39−
40−
41−find :: Summary.Summary -> E.Origin -> ModuleName.Raw -> Task.Task_ E.Problem Asset
42−find (Summary.Summary root project exposed _ _) origin name =
43− do here <- liftIO Dir.getCurrentDirectory
44− let toRoot dir = FP.makeRelative here (root </> dir)
45− case project of
46− Project.App info ->
47− do let srcDirs = map toRoot (Project._app_source_dirs info)
48− findElm project srcDirs exposed origin name
49−
50− Project.Pkg _ ->
51− if Name.isKernel name then
52− if Project.isPlatformPackage project then
53− findKernel (toRoot "src") exposed origin name
54− else
55− Task.throw $ E.ModuleNameReservedForKernel origin name
56−
57− else
58− findElm project [ toRoot "src" ] exposed origin name
59−
60−
61−
62−-- FIND ELM
63−
64−
65−findElm :: Project.Project -> [FilePath] -> Summary.ExposedModules -> E.Origin -> ModuleName.Raw -> Task.Task_ E.Problem Asset
66−findElm project srcDirs exposed origin name =
67− do
68− paths <- liftIO $ Maybe.catMaybes <$> mapM (elmExists name) srcDirs
69−
70− case (paths, Map.lookup name exposed) of
71− ([path], Nothing) ->
72− return (Local path)
73−
74− ([], Just [pkg]) ->
75− return (Foreign pkg)
76−
77− ([], Nothing) ->
78− case project of
79− Project.App _ ->
80− Task.throw $ E.ModuleNotFound origin name (E.App srcDirs)
81−
82− Project.Pkg _ ->
83− Task.throw $ E.ModuleNotFound origin name E.Pkg
84−
85− (_, maybePkgs) ->
86− Task.throw $ E.ModuleAmbiguous origin name paths (maybe [] id maybePkgs)
87−
88−
89−elmExists :: ModuleName.Raw -> FilePath -> IO (Maybe FilePath)
90−elmExists name srcDir =
91− do let path = srcDir </> ModuleName.nameToSlashPath name <.> "elm"
92− exists <- Dir.doesFileExist path
93− return $ if exists then Just path else Nothing
94−
95−
96−
97−-- FIND KERNEL
98−
99−
100−findKernel :: FilePath -> Summary.ExposedModules -> E.Origin -> ModuleName.Raw -> Task.Task_ E.Problem Asset
101−findKernel srcDir exposed origin name =
102− do let clientPath = srcDir </> ModuleName.nameToSlashPath name <.> "js"
103− let serverPath = srcDir </> ModuleName.nameToSlashPath name <.> "server.js"
104− client <- liftIO $ Dir.doesFileExist clientPath
105− server <- liftIO $ Dir.doesFileExist serverPath
106− if client
107− then return $ Kernel clientPath (if server then Just serverPath else Nothing)
108− else
109− case Map.lookup (Name.getKernel name) exposed of
110− Just [Pkg.Canonical pkg _vsn] | pkg == Pkg.core || pkg == Pkg.virtualDom ->
111− return ForeignKernel
112−
113− _ ->
114− Task.throw $ E.ModuleNotFound origin name E.Pkg
builder/src/File/Header.hsdeleted−203
@@ -1,203 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module File.Header
4− ( Info(..)
5− , readModule
6− , readOneFile
7− , readManyFiles
8− , readSource
9− )
10− where
11−
12−import Control.Monad.Except (liftIO)
13−import qualified Data.ByteString as BS
14−import qualified Data.Map as Map
15−import qualified Data.Time.Calendar as Day
16−import qualified Data.Time.Clock as Time
17−import qualified System.Directory as Dir
18−
19−import qualified AST.Source as Src
20−import qualified Elm.Compiler.Imports as Imports
21−import qualified Elm.ModuleName as ModuleName
22−import qualified Elm.Package as Pkg
23−import qualified Elm.Project.Json as Project
24−import Elm.Project.Json (Project)
25−import Elm.Project.Summary (Summary(..))
26−import qualified File.IO as IO
27−import qualified Parse.Module as Module
28−import Parse.Utils (Parser)
29−import qualified Parse.Primitives as P
30−import qualified Reporting.Annotation as A
31−import qualified Reporting.Exit as Exit
32−import qualified Reporting.Exit.Crawl as E
33−import qualified Reporting.Task as Task
34−
35−
36−
37−-- INFO
38−
39−
40−data Info =
41− Info
42− { _path :: FilePath
43− , _time :: Time.UTCTime
44− , _source :: BS.ByteString
45− , _imports :: [ModuleName.Raw]
46− }
47−
48−
49−atRoot :: Task.Task_ E.Problem a -> Task.Task_ E.Exit a
50−atRoot task =
51− Task.mapError (\problem -> E.DependencyProblems problem []) task
52−
53−
54−-- READ MODULE
55−
56−
57−readModule :: Summary -> ModuleName.Raw -> FilePath -> Task.Task_ E.Problem (ModuleName.Raw, Info)
58−readModule summary expectedName path =
59− do time <- liftIO $ Dir.getModificationTime path
60− source <- liftIO $ IO.readUtf8 path
61− (maybeName, info) <- parse (_project summary) path time source
62− name <- checkName path expectedName maybeName
63− return (name, info)
64−
65−
66−checkName :: FilePath -> ModuleName.Raw -> Maybe ModuleName.Raw -> Task.Task_ E.Problem ModuleName.Raw
67−checkName path expectedName maybeName =
68− case maybeName of
69− Nothing ->
70− Task.throw (E.ModuleNameMissing path expectedName)
71−
72− Just actualName ->
73− if expectedName == actualName
74− then return expectedName
75− else Task.throw (E.ModuleNameMismatch path expectedName actualName)
76−
77−
78−
79−-- READ ONE FILE
80−
81−
82−readOneFile :: Summary -> FilePath -> Task.Task (Maybe ModuleName.Raw, Info)
83−readOneFile summary path =
84− Task.mapError Exit.Crawl $
85− do (time, source) <- readOneHelp path
86− atRoot $ parse (_project summary) path time source
87−
88−
89−readOneHelp :: FilePath -> Task.Task_ E.Exit (Time.UTCTime, BS.ByteString)
90−readOneHelp path =
91− do exists <- liftIO $ IO.exists path
92− if exists
93− then liftIO $ (,) <$> Dir.getModificationTime path <*> IO.readUtf8 path
94− else Task.throw $ E.RootFileNotFound path
95−
96−
97−
98−-- READ MANY FILES
99−
100−
101−readManyFiles :: Summary -> FilePath -> [FilePath] -> Task.Task ((ModuleName.Raw, Info), [(ModuleName.Raw, Info)])
102−readManyFiles summary file files =
103− Task.mapError Exit.Crawl $
104− do info <- readManyFilesHelp summary file
105− infos <- traverse (readManyFilesHelp summary) files
106− let nameTable = foldr insert Map.empty (info:infos)
107− _ <- Map.traverseWithKey detectDuplicateNames nameTable
108− return (info, infos)
109− where
110− append (x,xs) (y,ys) = (x, xs ++ y : ys)
111− insert (k,v) dict = Map.insertWith append k (v, []) dict
112−
113−
114−readManyFilesHelp :: Summary -> FilePath -> Task.Task_ E.Exit (ModuleName.Raw, Info)
115−readManyFilesHelp summary path =
116− do (time, source) <- readOneHelp path
117− (maybeName, info) <- atRoot $ parse (_project summary) path time source
118− case maybeName of
119− Nothing ->
120− Task.throw (E.RootNameless path)
121−
122− Just name ->
123− return (name, info)
124−
125−
126−detectDuplicateNames :: ModuleName.Raw -> (Info, [Info]) -> Task.Task_ E.Exit ()
127−detectDuplicateNames name (info, otherInfos) =
128− case otherInfos of
129− [] ->
130− return ()
131−
132− _ ->
133− Task.throw (E.RootModuleNameDuplicate name (map _path (info : otherInfos)))
134−
135−
136−
137−
138−-- READ SOURCE
139−
140−
141−readSource :: Project -> BS.ByteString -> Task.Task (Maybe ModuleName.Raw, Info)
142−readSource project source =
143− Task.mapError Exit.Crawl $
144− atRoot $ parse project "elm" fakeTime source
145−
146−
147−fakeTime :: Time.UTCTime
148−fakeTime =
149− Time.UTCTime (Day.fromGregorian 3000 1 1) 0
150−
151−
152−
153−-- PARSE HEADER
154−
155−
156−parse :: Project -> FilePath -> Time.UTCTime -> BS.ByteString -> Task.Task_ E.Problem (Maybe ModuleName.Raw, Info)
157−parse project path time source =
158− -- TODO get regions on data extracted here
159− case P.fromByteString parser source of
160− P.Ok (maybeHeader, imports) _ ->
161− let
162− deps =
163− map (\(Src.Import (A.At _ name) _ _) -> name) $
164− if Project.getName project == Pkg.core
165− then imports
166− else Imports.addDefaults imports
167− in
168− do maybeName <- checkTag project path maybeHeader
169− return ( maybeName, Info path time source deps )
170−
171− P.Err _ _ _ _ ->
172− Task.throw (error "TODO give an error on bad headers / stop having a double parse")
173−
174−
175−parser :: Parser (Maybe Module.Header, [Src.Import])
176−parser =
177− do Module.freshLine
178− header <- Module.chompHeader
179− Module.maybeSkipDocComment
180− imports <- Module.chompImports []
181− return (header, imports)
182−
183−
184−checkTag :: Project -> FilePath -> Maybe Module.Header -> Task.Task_ E.Problem (Maybe ModuleName.Raw)
185−checkTag project path maybeHeader =
186− case maybeHeader of
187− Nothing ->
188− return Nothing
189−
190− Just (Module.Header name effects _) ->
191− case effects of
192− Module.NoEffects _ ->
193− return (Just name)
194−
195− Module.Ports _ ->
196− case project of
197− Project.App _ -> return (Just name)
198− Project.Pkg _ -> Task.throw (E.PortsInPackage path name)
199−
200− Module.Manager _ _ ->
201− if Project.isPlatformPackage project
202− then return (Just name)
203− else Task.throw (E.EffectsUnexpected path name)
builder/src/File/Plan.hsdeleted−197
@@ -1,197 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module File.Plan
4− ( plan
5− , Info(..)
6− )
7− where
8−
9−
10−import Control.Concurrent (forkIO)
11−import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
12−import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, readMVar)
13−import Control.Monad (foldM, void, when)
14−import Control.Monad.Except (liftIO)
15−import qualified Data.Binary as Binary
16−import qualified Data.ByteString as BS
17−import qualified Data.Map as Map
18−import qualified Data.Time.Clock as Time
19−import qualified System.Directory as Dir
20−
21−import qualified Elm.Interface as I
22−import qualified Elm.ModuleName as ModuleName
23−import qualified Elm.Package as Pkg
24−import qualified Elm.Project.Json as Project
25−import qualified Elm.Project.Summary as Summary
26−import qualified File.Crawl as Crawl
27−import qualified File.Header as Header
28−import qualified Reporting.Task as Task
29−import qualified Stuff.Paths
30−
31−
32−
33−-- PLAN
34−
35−
36−type Dict value = Map.Map ModuleName.Raw value
37−
38−
39−plan :: Summary.Summary -> Crawl.Result -> Task.Task (Dict Info, I.Interfaces)
40−plan (Summary.Summary root project _ ifaces _) (Crawl.Graph _ locals _ foreigns _) =
41− liftIO $
42− do queue <- newChan
43− let env = Env queue root (Project.getName project)
44−
45− mvar <- newEmptyMVar
46− statusMVars <- Map.traverseWithKey (getStatus env mvar foreigns) locals
47− putMVar mvar statusMVars
48−
49− void $ forkIO $
50− do graph <- Map.traverseMaybeWithKey (\_ -> readMVar) statusMVars
51− writeChan queue (EndLoop graph)
52−
53− ifaceLoader queue ifaces
54−
55−
56−data Env =
57− Env
58− { _queue :: Chan Msg
59− , _root :: FilePath
60− , _pkg :: Pkg.Name
61− }
62−
63−
64−
65−-- STATUS
66−
67−
68−type Status = Maybe Info
69− -- Nothing == clean
70− -- Just info == dirty
71−
72−
73−data Info =
74− Info
75− { _path :: FilePath
76− , _time :: Time.UTCTime
77− , _src :: BS.ByteString
78− , _clean :: [ModuleName.Raw]
79− , _dirty :: [ModuleName.Raw]
80− , _foreign :: [ModuleName.Canonical] -- TODO is this needed?
81− }
82−
83−
84−
85−-- GET STATUS
86−
87−
88−getStatus
89− :: Env
90− -> MVar (Dict (MVar Status))
91− -> Dict Pkg.Canonical
92− -> ModuleName.Raw
93− -> Header.Info
94− -> IO (MVar Status)
95−getStatus env statusMVars foreigns name (Header.Info path time src deps) =
96− do mvar <- newEmptyMVar
97−
98− void $ forkIO $ putMVar mvar =<<
99− do statuses <- readMVar statusMVars
100− info <- foldM (addDep statuses foreigns) (Info path time src [] [] []) deps
101−
102− let elmi = Stuff.Paths.elmi (_root env) name
103−
104− case _dirty info of
105− _ : _ ->
106− do remove elmi
107− return (Just info)
108−
109− [] ->
110− do freshElmi <- isFresh time elmi
111− if name /= "Main" && freshElmi
112− then
113− do let canonical = ModuleName.Canonical (_pkg env) name
114− writeChan (_queue env) (Get canonical elmi)
115− return Nothing
116− else
117− do remove elmi
118− return (Just info)
119−
120− return mvar
121−
122−
123−addDep :: Dict (MVar Status) -> Dict Pkg.Canonical -> Info -> ModuleName.Raw -> IO Info
124−addDep locals foreigns info name =
125− case Map.lookup name locals of
126− Just mvar ->
127− do status <- readMVar mvar
128− case status of
129− Nothing ->
130− return $ info { _clean = name : _clean info }
131−
132− Just _ ->
133− return $ info { _dirty = name : _dirty info }
134−
135− Nothing ->
136− case Map.lookup name foreigns of
137− Just (Pkg.Canonical pkg _vsn) ->
138− return $ info { _foreign = ModuleName.Canonical pkg name : _foreign info }
139−
140− Nothing ->
141− return info -- must be native
142−
143−
144−
145−-- IS FRESH
146−
147−
148−isFresh :: Time.UTCTime -> FilePath -> IO Bool
149−isFresh srcTime cachedFile =
150− andM
151− [ Dir.doesFileExist cachedFile
152− , do cacheTime <- Dir.getModificationTime cachedFile
153− return (cacheTime >= srcTime)
154− ]
155−
156−
157−andM :: [IO Bool] -> IO Bool
158−andM checks =
159− case checks of
160− [] ->
161− return True
162−
163− check : otherChecks ->
164− do bool <- check
165− if bool then andM otherChecks else return False
166−
167−
168−remove :: FilePath -> IO ()
169−remove path =
170− do exists <- Dir.doesFileExist path
171− when exists (Dir.removeFile path)
172−
173−
174−
175−-- INTERFACE LOADER
176−
177−
178−data Msg
179− = EndLoop (Dict Info)
180− | Get ModuleName.Canonical FilePath
181−
182−
183−ifaceLoader :: Chan Msg -> I.Interfaces -> IO (Dict Info, I.Interfaces)
184−ifaceLoader queue ifaces =
185− do msg <- readChan queue
186− case msg of
187− EndLoop dirty ->
188− return ( dirty, ifaces )
189−
190− Get canonical elmi ->
191− case Map.lookup canonical ifaces of
192− Just _ ->
193− ifaceLoader queue ifaces
194−
195− Nothing ->
196− do iface <- Binary.decodeFile elmi
197− ifaceLoader queue $ Map.insert canonical iface ifaces