Generate the right code for the --debug flag

Provide metadata for a debug program including the version of the compiler in use. Also only make VirtualDom.Debug reachable when the debug flag is in use. This means we can skip generating a bunch of code.
aslakg · Sep 27, 2016 · 941f1f5 · 941f1f5
1 parent 8c0d471
commit 941f1f5
Showing 1 changed file with 51 additions and 27 deletions.
diff --git a/src/Pipeline/Generate.hs b/src/Pipeline/Generate.hs
@@ -3,6 +3,7 @@
 module Pipeline.Generate where
 
 import Control.Monad.Except (forM_, liftIO)
+import Data.Aeson ((.=))
 import qualified Data.Aeson as Json
 import qualified Data.Graph as Graph
 import qualified Data.List as List
@@ -16,8 +17,10 @@ import qualified Data.Text.Lazy.Encoding as LazyText
 import qualified Data.Text.Lazy.IO as LazyText
 import qualified Data.Tree as Tree
 import Elm.Utils ((|>))
+import qualified Elm.Compiler as Elm
 import qualified Elm.Compiler.Module as Module
 import qualified Elm.Docs as Docs
+import qualified Elm.Package as Pkg
 import System.Directory ( createDirectoryIfMissing )
 import System.FilePath ( dropFileName )
 import System.IO ( IOMode(WriteMode) )
@@ -34,8 +37,10 @@ import qualified TheMasterPlan as TMP
 import qualified Utils.File as File
 
 
+
 -- GENERATE DOCS
 
+
 docs :: [Docs.Documentation] -> FilePath -> BM.Task ()
 docs docsList path =
   Docs.prettyJson docsList
@@ -45,8 +50,10 @@ docs docsList path =
     |> liftIO
 
 
+
 -- GENERATE ELM STUFF
 
+
 generate
     :: BM.Config
     -> Map.Map TMP.CanonicalModule Module.Interface
@@ -61,7 +68,7 @@ generate _config _interfaces _dependencies _natives [] =
 generate config interfaces dependencies natives rootModules =
   do  let objectFiles =
             setupNodes (BM._artifactDirectory config) dependencies natives
-              |> getReachableObjectFiles rootModules
+              |> getReachableObjectFiles (BM._debug config) rootModules
 
       let outputFile = BM.outputFilePath config
       liftIO (createDirectoryIfMissing True (dropFileName outputFile))
@@ -108,24 +115,34 @@ setupNodes cachePath dependencies natives =
 
 
 getReachableObjectFiles
-    :: [TMP.CanonicalModule]
-    -> [(FilePath, TMP.CanonicalModule, [TMP.CanonicalModule])]
-    -> [FilePath]
-getReachableObjectFiles moduleNames nodes =
-    let (dependencyGraph, vertexToKey, keyToVertex) =
-            Graph.graphFromEdges nodes
-
-        reachableSet =
-            Maybe.mapMaybe keyToVertex moduleNames
-              |> Graph.dfs dependencyGraph
-              |> concatMap Tree.flatten
-              |> Set.fromList
-    in
-        Graph.topSort dependencyGraph
-          |> filter (\vtx -> Set.member vtx reachableSet)
-          |> reverse
-          |> map vertexToKey
-          |> map (\(path, _, _) -> path)
+  :: Bool
+  -> [TMP.CanonicalModule]
+  -> [(FilePath, TMP.CanonicalModule, [TMP.CanonicalModule])]
+  -> [FilePath]
+getReachableObjectFiles debug moduleNames allNodes =
+  let
+    nodes =
+      if debug then allNodes else filter (not . isVirtualDomDebug) allNodes
+
+    (dependencyGraph, vertexToKey, keyToVertex) =
+      Graph.graphFromEdges nodes
+
+    reachableSet =
+      Maybe.mapMaybe keyToVertex moduleNames
+        |> Graph.dfs dependencyGraph
+        |> concatMap Tree.flatten
+        |> Set.fromList
+  in
+    Graph.topSort dependencyGraph
+      |> filter (\vtx -> Set.member vtx reachableSet)
+      |> reverse
+      |> map vertexToKey
+      |> map (\(path, _, _) -> path)
+
+
+isVirtualDomDebug :: (fp, TMP.CanonicalModule, deps) -> Bool
+isVirtualDomDebug (_filePath, TMP.CanonicalModule (pkg, _vsn) name, _deps) =
+  pkg == Pkg.virtualDom && name == ["VirtualDom","Debug"]
 
 
 
@@ -149,6 +166,7 @@ html generatedJavaScript moduleName =
             Blaze.preEscapedToMarkup ("Elm." ++ Module.nameToString moduleName ++ ".fullscreen()")
 
 
+
 -- FOOTER
 
 
@@ -190,19 +208,25 @@ exportProgram debugMode interfaces canonicalName@(Module.Canonical _ moduleName)
       Module.nameToString moduleName
 
     debugArg =
-      if debugMode then createDebugArg interfaces canonicalName else "undefined"
+      if debugMode then createDebugMetadata interfaces canonicalName else "undefined"
   in
     setup moduleName
     ++ makeProgram ++ "(" ++ object ++ ", '" ++ name ++ "', " ++ debugArg ++ ");"
 
 
-createDebugArg :: Map.Map Module.Canonical Module.Interface -> Module.Canonical -> String
-createDebugArg interfaces canonicalName =
-  Module.programTypes interfaces canonicalName
-    |> Json.encode
-    |> LazyText.decodeUtf8
-    |> LazyText.replace "\\u003e" ">"
-    |> LazyText.unpack
+createDebugMetadata :: Map.Map Module.Canonical Module.Interface -> Module.Canonical -> String
+createDebugMetadata interfaces canonicalName =
+  let
+    metadataFields =
+      [ "versions" .= Json.object [ "elm" .= Elm.version ]
+      , "types" .= Module.programTypes interfaces canonicalName
+      ]
+  in
+    Json.object metadataFields
+      |> Json.encode
+      |> LazyText.decodeUtf8
+      |> LazyText.replace "\\u003e" ">"
+      |> LazyText.unpack
 
 
 setup :: [String] -> String