From 967d40af31611d4c3ae3f3757001d96cf7f0bf82 Mon Sep 17 00:00:00 2001 From: Evan Czaplicki Date: Fri, 12 Aug 2016 01:35:16 -0700 Subject: [PATCH] Modify --debug flag to provide program type information --- src/Main.hs | 4 ++-- src/Pipeline/Compile.hs | 24 +++++++++---------- src/Pipeline/Generate.hs | 51 ++++++++++++++++++++++++++++------------ 3 files changed, 50 insertions(+), 29 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index 359a20a..e01544c 100644 --- 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 index eb20b9c..68248ef 100644 --- 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,12 +127,12 @@ 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 () @@ -136,7 +140,7 @@ 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 index 93be8ef..31620c2 100644 --- 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,15 +49,16 @@ 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 @@ -64,14 +66,14 @@ generate config dependencies natives 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,11 +152,20 @@ 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" @@ -162,8 +173,12 @@ footer debugMode rootModules = ++ 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