Merge pull request #106 from mdibaiee/already-compiled

Re-render compilation view only if recently compiled the output

Author: NickSeagull

src/common/HaskellDo/Compilation/State.hs

@@ -34,6 +34,7 @@ initialState = State
     , compilationError = "No project has been loaded yet, try opening one?"
     , projectPath = ""
     , workingFile = "src/Main.hs"
+    , dirtyCompile = True
     }
 
 lastProjectFile :: FilePath
@@ -92,7 +93,7 @@ buildOutput state = do
         System.ExitFailure _ ->
             return state { compiledOutput = "Compiling" }
         System.ExitSuccess ->
-            return state { compiledOutput = preprocessOutput out, compilationError = "" }
+            return state { compiledOutput = preprocessOutput out, compilationError = "", dirtyCompile = True }
 
 
 preprocessOutput :: String -> String

src/common/HaskellDo/Compilation/Types.hs

@@ -20,6 +20,7 @@ data State = State
     , compilationError :: String
     , projectPath      :: String
     , workingFile      :: String
+    , dirtyCompile     :: Bool
     } deriving (Read, Show)
 
 data Action

src/common/HaskellDo/Compilation/View.hs

@@ -16,7 +16,7 @@
 module HaskellDo.Compilation.View where
 
 import           Control.Monad.IO.Class
-import           Control.Monad (unless)
+import           Control.Monad (when)
 import           Prelude                     hiding (div, id)
 
 import           AxiomUtils
@@ -41,10 +41,10 @@ errorDisplay state
         $ code (compilationError state)
 
 updateDisplays :: State -> Widget ()
-updateDisplays state = do
-  highlighted <- liftIO alreadyHighlighted
-  unless highlighted $ Ulmus.newWidget "outputDisplay" (outputDisplay state)
-  Ulmus.newWidget "errorDisplay" (errorDisplay state)
-  liftIO $ activateScriptTags "#output-frame"
-  liftIO $ setHeightFromElement ".error-placeholder" "#errorDisplay"
-  liftIO highlightCode
+updateDisplays state =
+  when (dirtyCompile state) $ do
+    Ulmus.newWidget "outputDisplay" (outputDisplay state)
+    Ulmus.newWidget "errorDisplay" (errorDisplay state)
+    liftIO $ activateScriptTags "#output-frame"
+    liftIO $ setHeightFromElement ".error-placeholder" "#errorDisplay"
+    liftIO highlightCode

src/common/HaskellDo/State.hs

@@ -32,7 +32,6 @@ import qualified HaskellDo.Compilation.Types as Compilation
 import qualified HaskellDo.Toolbar.State as Toolbar
 import qualified HaskellDo.Toolbar.Types as Toolbar
 import qualified Foreign.JQuery as JQuery
-import qualified Foreign.Highlight as Highlight
 
 initialAppState :: AppState
 initialAppState = AppState
@@ -42,7 +41,19 @@ initialAppState = AppState
   }
 
 update :: Action -> AppState -> Cloud AppState
-update (CodeMirrorAction action) appState = do
+update action appState = _preUpdate action appState >>= _update action >>= _postUpdate action
+
+_preUpdate :: Action -> AppState -> Cloud AppState
+_preUpdate _ appState = do
+  let cs = compilationState appState
+      newCS = cs { Compilation.dirtyCompile = False }
+  return appState { compilationState = newCS }
+
+_postUpdate :: Action -> AppState -> Cloud AppState
+_postUpdate _ = return
+
+_update :: Action -> AppState -> Cloud AppState
+_update (CodeMirrorAction action) appState = do
     newCodeMirrorState <- CodeMirror.update action (codeMirrorState appState)
     let newContent = CodeMirror.content newCodeMirrorState
     _ <- atRemote $ Compilation.update
@@ -53,12 +64,10 @@ update (CodeMirrorAction action) appState = do
             { codeMirrorState = newCodeMirrorState
             }
     if compileShortcutPressed
-        then do
-            localIO Highlight.askForHighlight
-            update (ToolbarAction Toolbar.Compile) newState
+        then update (ToolbarAction Toolbar.Compile) newState
         else return newState
 
-update (ToolbarAction Toolbar.Compile) appState = do
+_update (ToolbarAction Toolbar.Compile) appState = do
     let tbState = toolbarState appState
     if Toolbar.projectOpened tbState
         then do
@@ -74,7 +83,7 @@ update (ToolbarAction Toolbar.Compile) appState = do
             localIO Toolbar.shakeErrorDisplay
             return appState
 
-update (ToolbarAction Toolbar.LoadProject) appState = do
+_update (ToolbarAction Toolbar.LoadProject) appState = do
     localIO $ JQuery.hide "#dependencyMessage"
     let tbState = toolbarState appState
     let cmpState = compilationState appState
@@ -116,7 +125,7 @@ update (ToolbarAction Toolbar.LoadProject) appState = do
             localIO $ JQuery.show "#errorDisplay" -- Show it after they finished
             return newState
 
-update (ToolbarAction Toolbar.LoadPackageYaml) appState = do
+_update (ToolbarAction Toolbar.LoadPackageYaml) appState = do
     let projectPath = Compilation.projectPath (compilationState appState)
     contents <- atRemote $ localIO $ readFile (projectPath </> "package.yaml")
     let tbState = toolbarState appState
@@ -125,7 +134,7 @@ update (ToolbarAction Toolbar.LoadPackageYaml) appState = do
     _ <- Toolbar.update Toolbar.LoadPackageYaml tbState
     return appState { toolbarState = tbState' }
 
-update (ToolbarAction Toolbar.SavePackage) appState = do
+_update (ToolbarAction Toolbar.SavePackage) appState = do
     let projectPath = Compilation.projectPath (compilationState appState)
     let tbState = toolbarState appState
     atRemote $ localIO $ writeFile (projectPath </> "package.yaml") (Toolbar.projectConfig tbState)
@@ -135,7 +144,7 @@ update (ToolbarAction Toolbar.SavePackage) appState = do
     localIO $ JQuery.hide "#dependencyMessage"
     return newState
 
-update (ToolbarAction action) appState = do
+_update (ToolbarAction action) appState = do
     newToolbarState <- Toolbar.update action (toolbarState appState)
     let cs = compilationState appState
     let newCompilationState = cs

src/ghc-specific/Foreign/Highlight.hs

@@ -17,9 +17,3 @@ module Foreign.Highlight where
 
 highlightCode :: IO ()
 highlightCode = return ()
-
-askForHighlight :: IO ()
-askForHighlight = return ()
-
-alreadyHighlighted :: IO Bool
-alreadyHighlighted = return True

src/ghcjs-specific/Foreign/Highlight.hs

@@ -15,14 +15,5 @@
  -}
 module Foreign.Highlight where
 
-foreign import javascript unsafe "if (!alreadyHighlighted){ \
-                                    setTimeout(function() {$('.haskell').each(function(i, block){ hljs.highlightBlock(block);}) }, 0); \
-                                    alreadyHighlighted = true; \
-                                  }"
+foreign import javascript unsafe "setTimeout(function() {$('.haskell').each(function(i, block){ hljs.highlightBlock(block);}) }, 0);"
     highlightCode :: IO ()
-
-foreign import javascript unsafe "alreadyHighlighted = false;"
-    askForHighlight :: IO ()
-
-foreign import javascript unsafe "$r = alreadyHighlighted;"
-    alreadyHighlighted :: IO Bool