Modify --debug flag to provide program type information

aslakg · Aug 12, 2016 · 967d40a · 967d40a
1 parent a7d9e3e
commit 967d40a
Show file tree

Hide file tree

Showing 3 changed files with 50 additions and 29 deletions.
diff --git a/src/Main.hs b/src/Main.hs
@@ -49,7 +49,7 @@ make =
       buildSummary <-
           BM.phase "Plan Build" (Plan.planBuild config modulesToDocument projectSummary)
 
-      docs <-
+      (interfaces, docs) <-
         BM.phase "Compile" $ liftIO $
           Compile.build
             config
@@ -65,7 +65,7 @@ make =
       BM.phase "Generate Code" $
         Generate.generate
           config
+          interfaces
           dependencies
           (projectNatives projectSummary)
           moduleForGeneration
-
diff --git a/src/Pipeline/Compile.hs b/src/Pipeline/Compile.hs
@@ -27,7 +27,7 @@ data Env =
     { numTasks :: Int
     , resultChan :: Chan.Chan Result
     , reportChan :: Chan.Chan Report.Message
-    , docsChan :: Chan.Chan [Docs.Documentation]
+    , doneChan :: Chan.Chan (Interfaces, [Docs.Documentation])
     , dependencies :: Map.Map CanonicalModule [CanonicalModule]
     , reverseDependencies :: Map.Map CanonicalModule [CanonicalModule]
     , cachePath :: FilePath
@@ -40,11 +40,15 @@ data State =
   State
     { numActiveThreads :: Int
     , blockedModules :: Map.Map CanonicalModule BuildData
-    , completedInterfaces :: Map.Map CanonicalModule Module.Interface
+    , completedInterfaces :: Interfaces
     , documentation :: [Docs.Documentation]
     }
 
 
+type Interfaces =
+  Map.Map CanonicalModule Module.Interface
+
+
 
 -- HELPERS for ENV and STATE
 
@@ -59,12 +63,12 @@ initEnv
 initEnv cachePath exposedModules modulesForGeneration dependencies (BuildGraph blocked _completed) =
   do  resultChan <- Chan.newChan
       reportChan <- Chan.newChan
-      docsChan <- Chan.newChan
+      doneChan <- Chan.newChan
       return $ Env
         { numTasks = Map.size blocked
         , resultChan = resultChan
         , reportChan = reportChan
-        , docsChan = docsChan
+        , doneChan = doneChan
         , dependencies = dependencies
         , reverseDependencies = reverseGraph dependencies
         , cachePath = cachePath
@@ -123,20 +127,20 @@ build
     -> [CanonicalModule]
     -> Map.Map CanonicalModule [CanonicalModule]
     -> BuildGraph
-    -> IO [Docs.Documentation]
+    -> IO (Interfaces, [Docs.Documentation])
 build config rootPkg exposedModules modulesForGeneration dependencies summary =
   do  env <- initEnv (BM._artifactDirectory config) exposedModules modulesForGeneration dependencies summary
       forkIO (buildManager env =<< initState env summary)
       Report.thread (BM._reportType config) (BM._warn config) (reportChan env) rootPkg (numTasks env)
-      Chan.readChan (docsChan env)
+      Chan.readChan (doneChan env)
 
 
 buildManager :: Env -> State -> IO ()
 buildManager env state =
   if numActiveThreads state == 0 then
 
     do  Chan.writeChan (reportChan env) Report.Close
-        Chan.writeChan (docsChan env) (documentation state)
+        Chan.writeChan (doneChan env) (completedInterfaces state, documentation state)
 
   else
 
@@ -229,11 +233,7 @@ updateBlockedModules modul blockedModules potentiallyFreedModule =
 
 -- UPDATE - BUILD SOME MODULES
 
-buildModule
-    :: Env
-    -> Map.Map CanonicalModule Module.Interface
-    -> (CanonicalModule, Location)
-    -> IO ()
+buildModule :: Env -> Interfaces -> (CanonicalModule, Location) -> IO ()
 buildModule env interfaces (modul, location) =
   let
     packageName = fst (TMP.package modul)

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 qualified Data.Aeson as Json
 import qualified Data.Graph as Graph
 import qualified Data.List as List
 import qualified Data.Map as Map
@@ -48,30 +49,31 @@ docs docsList path =
 
 generate
     :: BM.Config
+    -> Map.Map TMP.CanonicalModule Module.Interface
     -> Map.Map TMP.CanonicalModule [TMP.CanonicalModule]
     -> Map.Map TMP.CanonicalModule TMP.Location
     -> [TMP.CanonicalModule]
     -> BM.Task ()
 
-generate _config _dependencies _natives [] =
+generate _config _interfaces _dependencies _natives [] =
   return ()
 
-generate config dependencies natives rootModules =
+generate config interfaces dependencies natives rootModules =
   do  let objectFiles =
             setupNodes (BM._artifactDirectory config) dependencies natives
               |> getReachableObjectFiles rootModules
 
       let outputFile = BM.outputFilePath config
       liftIO (createDirectoryIfMissing True (dropFileName outputFile))
 
-      let debugMode = BM._debug config
+      let footer = createFooter (BM._debug config) interfaces rootModules
 
       case BM._output config of
         BM.Html outputFile ->
           liftIO $
             do  js <- mapM File.readTextUtf8 objectFiles
                 let (TMP.CanonicalModule _ moduleName) = head rootModules
-                let outputText = html (Text.concat (header : js ++ [footer debugMode rootModules])) moduleName
+                let outputText = html (Text.concat (header : js ++ [footer])) moduleName
                 LazyText.writeFile outputFile outputText
 
         BM.JS outputFile ->
@@ -80,7 +82,7 @@ generate config dependencies natives rootModules =
               do  Text.hPutStrLn handle header
                   forM_ objectFiles $ \jsFile ->
                       Text.hPutStrLn handle =<< File.readTextUtf8 jsFile
-                  Text.hPutStrLn handle (footer debugMode rootModules)
+                  Text.hPutStrLn handle footer
 
         BM.DevNull ->
           return ()
@@ -150,20 +152,33 @@ html generatedJavaScript moduleName =
 -- FOOTER
 
 
-footer :: Bool -> [TMP.CanonicalModule] -> Text.Text
-footer debugMode rootModules =
+createFooter
+  :: Bool
+  -> Map.Map TMP.CanonicalModule Module.Interface
+  -> [TMP.CanonicalModule]
+  -> Text.Text
+createFooter debugMode canonicalInterfaces rootModules =
   let
+    interfaces =
+      Map.mapKeys TMP.simplifyModuleName canonicalInterfaces
+
     exportChunks =
-      map (export debugMode) (List.sort (map TMP.simplifyModuleName rootModules))
+      map
+        (exportProgram debugMode interfaces)
+        (List.sort (map TMP.simplifyModuleName rootModules))
   in
     Text.pack $
       "var Elm = {};\n"
       ++ unlines exportChunks
       ++ footerClose
 
 
-export :: Bool -> Module.Canonical -> String
-export debugMode canonicalName@(Module.Canonical _ moduleName) =
+exportProgram
+  :: Bool
+  -> Map.Map Module.Canonical Module.Interface
+  -> Module.Canonical
+  -> String
+exportProgram debugMode interfaces canonicalName@(Module.Canonical _ moduleName) =
   let
     makeProgram =
       Module.qualifiedVar canonicalName "main"
@@ -175,13 +190,19 @@ export debugMode canonicalName@(Module.Canonical _ moduleName) =
       Module.nameToString moduleName
 
     debugArg =
-      if debugMode then
-        ", true"
-      else
-        ""
+      if debugMode then createDebugArg interfaces canonicalName else "undefined"
   in
     setup moduleName
-    ++ makeProgram ++ "(" ++ object ++ ", '" ++ name ++ "'" ++ debugArg ++ ");"
+    ++ 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
 
 
 setup :: [String] -> String