git.iko.soy/elk
on be145bc help sign in
elk/builder/src/Generate/Output.hs
295 lines 7.8 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Generate.Output
4 ( Mode(..)
5 , Mode.Target(..)
6 , generate
7 , generateReplFile
8 , noDebugUsesInPackage
9 , Output(..)
10 , output
11 )
12 where
15import Control.Concurrent.MVar (MVar, putMVar)
16import Control.Monad.Trans (liftIO)
17import qualified Data.ByteString.Builder as B
18import qualified Data.Map as Map
19import Data.Monoid ((<>))
20import qualified Data.Name as Name
21import qualified System.Directory as Dir
22import qualified System.FilePath as FP
23import System.FilePath ((</>))
25import qualified Elm.Compiler as Compiler
26import qualified Elm.Compiler.Objects as Obj
27import qualified Elm.Interface as I
28import qualified Elm.ModuleName as ModuleName
29import qualified Elm.Package as Pkg
30import qualified Elm.Project.Json as Project
31import qualified Elm.Project.Summary as Summary
32import qualified File.Args as Args
33import qualified File.Crawl as Crawl
34import qualified File.IO as IO
35import qualified Generate.Functions as Functions
36import qualified Generate.Html as Html
37import qualified Generate.Nitpick as Nitpick
38import qualified Generate.JavaScript.Mode as Mode
39import qualified Reporting.Exit as Exit
40import qualified Reporting.Exit.Make as E
41import qualified Reporting.Render.Type.Localizer as L
42import qualified Reporting.Task as Task
43import qualified Stuff.Paths as Paths
44import Terminal.Args (Parser(..))
48-- GENERATE
51data Mode = Debug | Dev | Prod
54generate
55 :: Mode
56 -> Mode.Target
57 -> Maybe Output
58 -> Summary.Summary
59 -> Crawl.Result
60 -> Map.Map ModuleName.Raw Compiler.Artifacts
61 -> Task.Task ()
62generate mode target maybeOutput summary graph@(Crawl.Graph args locals _ _ _) artifacts =
63 case args of
64 Args.Pkg _ ->
65 return ()
67 Args.Roots name names ->
68 do objectGraph <- organize summary graph
70 realMode <-
71 case mode of
72 Debug ->
73 do interfaces <- getInterfaces summary locals artifacts
74 return $ Mode.debug target interfaces
76 Dev ->
77 return $ Mode.dev target
79 Prod ->
80 do noDebugUses summary objectGraph
81 return $ Mode.prod target objectGraph
83 generateMonolith realMode maybeOutput summary objectGraph (name:names)
86getInterfaces
87 :: Summary.Summary
88 -> Map.Map ModuleName.Raw a
89 -> Map.Map ModuleName.Raw Compiler.Artifacts
90 -> Task.Task I.Interfaces
91getInterfaces (Summary.Summary root project _ interfaces _) locals artifacts =
92 let
93 pkg =
94 Project.getName project
96 addArtifact home (Compiler.Artifacts elmi _ _) ifaces =
97 (ModuleName.Canonical pkg home, elmi) : ifaces
99 addInterface home iface ifaces =
100 (ModuleName.Canonical pkg home, iface) : ifaces
102 readInterface home _ =
103 IO.readBinary (Paths.elmi root home)
104 in
105 do cached <- Map.traverseWithKey readInterface (Map.difference locals artifacts)
106 return $
107 Map.union interfaces $ Map.fromList $
108 Map.foldrWithKey addInterface (Map.foldrWithKey addArtifact [] artifacts) cached
112-- GENERATE MONOLITH
115generateMonolith
116 :: Mode.Mode
117 -> Maybe Output
118 -> Summary.Summary
119 -> Obj.Graph
120 -> [ModuleName.Raw]
121 -> Task.Task ()
122generateMonolith mode maybeOutput (Summary.Summary _ project _ _ _) graph rootNames =
123 do let pkg = Project.getName project
124 let roots = map (ModuleName.Canonical pkg) rootNames
125 case Obj.generate mode graph roots of
126 Obj.None ->
127 return ()
129 Obj.Some name _names builder ->
130 let
131 monolith =
132 "(function(scope){\n'use strict';"
133 <> Functions.functions <> builder <> "}(this));"
134 in
135 liftIO $
136 case maybeOutput of
137 Nothing ->
138 IO.writeBuilder "index.html" (Html.sandwich name monolith)
140 Just output_ ->
141 case output_ of
142 None ->
143 return ()
145 JavaScript maybeDir fileName ->
146 do path <- toWritablePath maybeDir fileName
147 IO.writeBuilder path monolith
149 HtmlBuilder mvar ->
150 putMVar mvar (Html.sandwich name monolith)
152 Html maybeDir fileName ->
153 do path <- toWritablePath maybeDir fileName
154 IO.writeBuilder path (Html.sandwich name monolith)
158-- GENERATE REPL MONOLITH
161generateReplFile
162 :: Bool
163 -> L.Localizer
164 -> Summary.Summary
165 -> Crawl.Result
166 -> I.Interface
167 -> Name.Name
168 -> Task.Task FilePath
169generateReplFile noColors localizer summary@(Summary.Summary _ project _ _ _) graph iface name =
170 do
171 objectGraph <- organize summary graph
173 let home = ModuleName.Canonical (Project.getName project) Name.replModule
174 let builder = Obj.generateForRepl (not noColors) localizer objectGraph iface home name
176 liftIO $ IO.writeBuilder (Paths.temp "js") $
177 replRecovery <> "(function(){\n'use strict';" <> Functions.functions <> builder <> "}());"
179 return (Paths.temp "js")
182replRecovery :: B.Builder
183replRecovery =
184 "process.on('uncaughtException', function(err) { process.stderr.write(err.toString()); process.exit(1); });"
188-- ORGANIZE
191organize :: Summary.Summary -> Crawl.Result -> Task.Task Obj.Graph
192organize (Summary.Summary root _ _ _ deps) (Crawl.Graph _ locals _ _ _) =
193 do localObjs <- Obj.unions <$> traverse (loadModuleObj root) (Map.keys locals)
194 foreignObjs <- Obj.unions <$> traverse loadPackageObj (Map.toList deps)
195 return (Obj.union localObjs foreignObjs)
198loadModuleObj :: FilePath -> ModuleName.Raw -> Task.Task Obj.Graph
199loadModuleObj root name =
200 IO.readBinary (Paths.elmo root name)
203loadPackageObj :: ( Pkg.Name, (Pkg.Version, deps) ) -> Task.Task Obj.Graph
204loadPackageObj ( name, (version,_) ) =
205 do dir <- Task.getPackageCacheDirFor name version
206 IO.readBinary (dir </> "objs.dat")
210-- NO DEBUG USES
213noDebugUses :: Summary.Summary -> Obj.Graph -> Task.Task ()
214noDebugUses (Summary.Summary _ project _ _ _) graph =
215 case Nitpick.findDebugUses (Project.getName project) graph of
216 [] ->
217 return ()
219 m:ms ->
220 Task.throw (Exit.Make (E.CannotOptimizeDebugValues m ms))
223noDebugUsesInPackage :: Summary.Summary -> Crawl.Result -> Task.Task ()
224noDebugUsesInPackage summary graph =
225 noDebugUses summary =<< organize summary graph
229-- OUTPUT
232data Output
233 = None
234 | Html (Maybe FilePath) FilePath
235 | JavaScript (Maybe FilePath) FilePath
236 | HtmlBuilder (MVar B.Builder)
239toWritablePath :: Maybe FilePath -> FilePath -> IO FilePath
240toWritablePath maybeDir fileName =
241 case maybeDir of
242 Nothing ->
243 do return fileName
245 Just dir ->
246 do Dir.createDirectoryIfMissing True dir
247 return (dir </> fileName)
251-- OUTPUT PARSER
254output :: Parser Output
255output =
256 Parser
257 { _singular = "output file"
258 , _plural = "output files"
259 , _parser = parseOutput
260 , _suggest = \_ -> return []
261 , _examples = exampleOutput
262 }
265parseOutput :: String -> Maybe Output
266parseOutput string =
267 if string == "/dev/null" || string == "NUL" || string == "$null" then
268 Just None
270 else if FP.takeExtension string == ".html" && length string > 5 then
271 splitOutput Html string
273 else if FP.takeExtension string == ".js" && length string > 3 then
274 splitOutput JavaScript string
276 else
277 Nothing
280splitOutput :: (Maybe FilePath -> FilePath -> Output) -> String -> Maybe Output
281splitOutput toOutput string =
282 case FP.splitPath string of
283 [] ->
284 Nothing
286 [name] ->
287 Just $ toOutput Nothing name
289 segments ->
290 Just $ toOutput (Just (FP.joinPath (init segments))) (last segments)
293exampleOutput :: String -> IO [String]
294exampleOutput _ =
295 return [ "elm.js", "index.html", "/dev/null" ]