feat: show warnings in the problems tab

lunarcast · Jul 9, 2020 · 0369f55 · 0369f55
1 parent f8bdf86
commit 0369f55
Show file tree

Hide file tree

Showing 6 changed files with 125 additions and 76 deletions.
diff --git a/public/styles/pages/editor/problems.scss b/public/styles/pages/editor/problems.scss
@@ -46,6 +46,11 @@
   color: $error-text;
 }
 
+.problems__card--warning {
+  background: $warning-bg;
+  color: $warning-text;
+}
+
 .problems__card-message {
   grid-row-start: 2;
   grid-column: 1 / 3;

diff --git a/public/styles/theme.scss b/public/styles/theme.scss
@@ -18,4 +18,7 @@ $blue: #2667ff;
 $error-bg: #290000;
 $error-text: #df6d6d;
 
+$warning-bg: #332b00;
+$warning-text: #ffdd9e;
+
 $transition-time: 0.2s;
diff --git a/src/Component/Editor.purs b/src/Component/Editor.purs
@@ -61,6 +61,7 @@ import Lunarbox.Data.Route (Route(..))
 import Lunarbox.Data.Set (toNative) as Set
 import Lunarbox.Foreign.Render (centerNode, centerOutput, setUnconnectableInputs, setUnconnectableOutputs)
 import Lunarbox.Foreign.Render as Native
+import Record as Record
 import Web.Event.Event (preventDefault, stopPropagation)
 import Web.Event.Event as Event
 import Web.HTML (window) as Web
@@ -139,12 +140,8 @@ pendingConnectionModal =
   , title: "Confirm connection"
   , content: HH.text "Connecting those nodes would change the type of this function creating a type error."
   , buttons:
-    [ { text: "Autofix"
+    [ { text: "Continue"
       , primary: true
-      , value: AutofixConnection
-      }
-    , { text: "Continue"
-      , primary: false
       , value: ProceedConnecting
       }
     , { text: "Cancel"
@@ -283,7 +280,6 @@ component =
       liftAff $ delay interval
       name <- gets $ view _name
       if String.length name >= 2 then do
-        { errors, expression, typeMap } <- get
         newState <- gets stateToJson
         raise $ Save newState
         handleAction $ Autosave newState
@@ -305,11 +301,10 @@ component =
     CreateConnection from toId toIndex -> do
       state <- createConnection from toId toIndex <$> get
       let
-        { expression, typeMap, errors } = tryCompiling state
-      case errors of
+        compilationResult = tryCompiling state
+      case compilationResult.typeErrors of
         [] -> do
-          put $ evaluate $ state { expression = expression, typeMap = typeMap, errors = errors }
-          printString "Created connection with no errors"
+          put $ evaluate $ Record.merge compilationResult state
           void updateAll
         _ -> do
           modify_
@@ -319,9 +314,7 @@ component =
                   { from
                   , toId
                   , toIndex
-                  , expression
-                  , errors
-                  , typeMap
+                  , compilationResult
                   }
               }
           handleAction (HandleConnectionConfirmation ProceedConnecting)
@@ -345,16 +338,14 @@ component =
     HandleConnectionConfirmation other -> do
       p <- gets _.pendingConnection
       gets _.pendingConnection
-        >>= traverse_ \{ from, toId, toIndex, errors, expression, typeMap } -> case other of
+        >>= traverse_ \{ from, toId, toIndex, compilationResult } -> case other of
             ProceedConnecting -> do
               state <- get
               put
                 $ createConnection from toId toIndex
+                $ Record.merge compilationResult
                 $ state
                     { pendingConnection = Nothing
-                    , errors = errors
-                    , typeMap = typeMap
-                    , expression = expression
                     }
               void updateAll
               handleAction Rerender
@@ -442,7 +433,7 @@ component =
     ]
 
   panel :: State Action ChildSlots m -> Array (HH.ComponentHTML Action ChildSlots m)
-  panel { currentTab, project, currentFunction, functionData, typeMap, inputCountMap, name, isExample, isVisible, isAdmin, nodeSearchTerm, errors } = case currentTab of
+  panel { currentTab, project, currentFunction, functionData, typeMap, inputCountMap, name, isExample, isVisible, isAdmin, nodeSearchTerm, typeErrors, lintingErrors } = case currentTab of
     Settings ->
       mkPanel
         { title: "Project settings"
@@ -541,7 +532,7 @@ component =
         , actions: []
         , footer: Nothing
         , header: Nothing
-        , content: [ problems { typeErrors: errors, navigateTo: MoveTo } ]
+        , content: [ problems { typeErrors, lintingErrors, navigateTo: MoveTo } ]
         }
 
   scene :: HH.ComponentHTML Action ChildSlots m

diff --git a/src/Component/Editor/Problems.purs b/src/Component/Editor/Problems.purs
@@ -1,53 +1,93 @@
 module Lunarbox.Component.Editor.Problems where
 
 import Prelude
-import Data.Filterable (filterMap)
 import Data.Maybe (Maybe(..))
 import Halogen.HTML as HH
 import Halogen.HTML.Events (onClick)
 import Lunarbox.Component.Icon (icon)
-import Lunarbox.Component.Utils (className)
-import Lunarbox.Data.Dataflow.TypeError (TypeError, getLocation, printError)
+import Lunarbox.Component.Utils (className, whenElem)
+import Lunarbox.Data.Dataflow.Expression.Lint (LintError)
+import Lunarbox.Data.Dataflow.Expression.Lint as LintError
+import Lunarbox.Data.Dataflow.TypeError (TypeError)
+import Lunarbox.Data.Dataflow.TypeError as TypeError
 import Lunarbox.Data.Editor.Location (Location(..))
-import Lunarbox.Data.String (toHtml)
 
 type ProblemsInput a
   = { typeErrors :: Array (TypeError Location)
+    , lintingErrors :: Array (LintError Location)
     , navigateTo :: Location -> a
     }
 
 -- Icons
-error :: forall h a. HH.HTML h a
-error = icon "error"
+errorIcon :: forall h a. HH.HTML h a
+errorIcon = icon "error"
 
-warning :: forall h a. HH.HTML h a
-warning = icon "warning"
+warningIcon :: forall h a. HH.HTML h a
+warningIcon = icon "warning"
 
 -- The actual component
 problems :: forall h a. ProblemsInput a -> HH.HTML h a
-problems { typeErrors: [] } = HH.main [ className "problems__empty" ] [ HH.text "No errors here!" ]
+problems { typeErrors: [], lintingErrors: [] } = HH.main [ className "problems__empty" ] [ HH.text "No errors here!" ]
 
-problems { typeErrors, navigateTo } =
+problems { typeErrors, lintingErrors, navigateTo } =
   HH.main [ className "problems__container" ]
-    $ filterMap
-        ( \{ typeError, location } ->
-            if location == UnknownLocation then
-              Nothing
-            else
-              Just
-                $ HH.section [ className "problems__card problems__card--error" ]
-                    [ HH.div [ className "problems__card-header" ]
-                        [ HH.div [ className "problems__card-icon" ] [ error ]
-                        , HH.button
-                            [ className "problems__card-location"
-                            , onClick $ const $ Just $ navigateTo location
-                            ]
-                            [ HH.text $ show location
-                            ]
-                        ]
-                    , HH.div [ className "problems__card-message" ]
-                        [ toHtml $ printError typeError ]
-                    ]
-        )
-    $ (\typeError -> { typeError, location: getLocation typeError })
-    <$> typeErrors
+    $ typeErrorHtml
+    <> lintingErrorHtml
+  where
+  mkProblem = createProblemMaker navigateTo
+
+  typeErrorHtml =
+    ( \error ->
+        mkProblem
+          { level: Error
+          , message: TypeError.printError error
+          , location: TypeError.getLocation error
+          }
+    )
+      <$> typeErrors
+
+  lintingErrorHtml =
+    ( \error ->
+        mkProblem
+          { level: Warning
+          , message: "not here yet"
+          , location: LintError.getLocation error
+          }
+    )
+      <$> lintingErrors
+
+-- | Data about how to color a problem
+data ProblemLevel
+  = Warning
+  | Error
+
+type ProblemConfig
+  = { level :: ProblemLevel, message :: String, location :: Location
+    }
+
+-- | Create the html for a problem
+createProblemMaker :: forall h a. (Location -> a) -> ProblemConfig -> HH.HTML h a
+createProblemMaker navigateTo { location, message, level } =
+  whenElem (location /= UnknownLocation) \_ ->
+    HH.section
+      [ className $ "problems__card "
+          <> case level of
+              Warning -> "problems__card--warning"
+              Error -> "problems__card--error"
+      ]
+      [ HH.div [ className "problems__card-header" ]
+          [ HH.div [ className "problems__card-icon" ]
+              [ case level of
+                  Warning -> warningIcon
+                  Error -> errorIcon
+              ]
+          , HH.button
+              [ className "problems__card-location"
+              , onClick $ const $ Just $ navigateTo location
+              ]
+              [ HH.text $ show location
+              ]
+          ]
+      , HH.div [ className "problems__card-message" ]
+          [ HH.text message ]
+      ]
diff --git a/src/Data/Dataflow/Expression/Lint.purs b/src/Data/Dataflow/Expression/Lint.purs
@@ -4,17 +4,24 @@ import Prelude
 import Data.Array as Array
 import Lunarbox.Data.Dataflow.Expression (Expression(..), VarName, foldExpression)
 
+-- | Basically warnings the user gets for imrpoving code clarity
 data LintError l
-  = UnusedDeclaration VarName l
+  = UnusedDeclaration l VarName
   | UnsaturatedFunction l l
 
+-- | Get the location a linting error came from
+getLocation :: forall l. LintError l -> l
+getLocation (UnusedDeclaration location _) = location
+
+getLocation (UnsaturatedFunction location _) = location
+
 -- | Collect linting errors inside an expression
 lint :: forall l. Expression l -> Array (LintError l)
 lint = foldExpression go
   where
   go (Let location name _ body)
     | Array.null (references name body) =
-      [ UnusedDeclaration name location
+      [ UnusedDeclaration location name
       ]
 
   go (FunctionCall location _ (TypedHole argLocation)) =

diff --git a/src/Data/Editor/State.purs b/src/Data/Editor/State.purs
@@ -37,6 +37,7 @@ import Lunarbox.Control.Monad.Dataflow.Solve.SolveExpression (solveExpression)
 import Lunarbox.Control.Monad.Dataflow.Solve.Unify (canUnify)
 import Lunarbox.Data.Class.GraphRep (toGraph)
 import Lunarbox.Data.Dataflow.Expression (Expression(..))
+import Lunarbox.Data.Dataflow.Expression.Lint (LintError, lint)
 import Lunarbox.Data.Dataflow.Runtime (RuntimeValue)
 import Lunarbox.Data.Dataflow.Runtime.ValueMap (ValueMap(..))
 import Lunarbox.Data.Dataflow.Type (Type(..), inputs)
@@ -55,6 +56,8 @@ import Lunarbox.Data.Graph as G
 import Lunarbox.Data.Ord (sortBySearch)
 import Lunarbox.Foreign.Render (GeometryCache, ForeignTypeMap, emptyGeometryCache)
 import Lunarbox.Foreign.Render as Native
+import Record as Record
+import Type.Row (type (+))
 import Web.Event.Event as Event
 import Web.Event.Internal.Types (Event)
 
@@ -80,7 +83,8 @@ tabIcon = case _ of
 type CompilationResult r
   = ( expression :: Expression Location
     , typeMap :: Map Location Type
-    , errors :: Array (TypeError Location)
+    , typeErrors :: Array (TypeError Location)
+    , lintingErrors :: Array (LintError Location)
     | r
     )
 
@@ -97,29 +101,25 @@ type StatePermanentData r
 type State a s m
   = { 
     | StatePermanentData
-      ( currentTab :: Tab
+      + CompilationResult
+      + ( currentTab :: Tab
       , functionData :: Map FunctionName FunctionData
       , panelIsOpen :: Boolean
       , valueMap :: ValueMap Location
       , functionUis :: Map FunctionName (FunctionUi a s m)
       , inputCountMap :: Map FunctionName Int
       , pendingConnection ::
         Maybe
-          { 
-          | CompilationResult
-            ( from :: NodeId
-            , toId :: NodeId
-            , toIndex :: Int
-            )
+          { from :: NodeId
+          , toId :: NodeId
+          , toIndex :: Int
+          , compilationResult :: { | CompilationResult () }
           }
       , name :: String
       , isExample :: Boolean
       , isAdmin :: Boolean
       , nodeSearchTerm :: String
       , isVisible :: Boolean
-      , expression :: Expression Location
-      , errors :: Array (TypeError Location)
-      , typeMap :: Map Location Type
       )
     }
 
@@ -146,7 +146,8 @@ emptyState =
     , isAdmin: false
     , isVisible: false
     , pendingConnection: Nothing
-    , errors: []
+    , typeErrors: []
+    , lintingErrors: []
     }
 
 -- Helpers
@@ -306,30 +307,32 @@ tryCompiling ::
   forall a s m.
   State a s m ->
   { | CompilationResult () }
-tryCompiling state@{ project, expression, typeMap, errors } = { expression: expression', typeMap: typeMap', errors: errors' }
+tryCompiling state@{ project, expression, typeMap, typeErrors, lintingErrors } = result
   where
   expression' = compileProject project
 
-  (Tuple typeMap' errors') =
+  result =
     -- we only run the type inference algorithm if the expression changed
-    if (expression == expression') then
-      Tuple typeMap errors
+    if expression == expression' then
+      { typeMap, typeErrors, lintingErrors, expression }
     else
-      Tuple typeMap' errors'
+      { expression: expression'
+      , typeMap: typeMap'
+      , typeErrors: errors'
+      , lintingErrors: lintingErrors'
+      }
     where
+    lintingErrors' = lint expression'
+
     (Tuple typeMap' (SolveState { errors: errors' })) = solveExpression expression'
 
 -- Compile a project
 compile :: forall a s m. State a s m -> State a s m
 compile state =
   evaluate
-    $ state
-        { expression = expression
-        , typeMap = typeMap
-        , errors = errors
-        }
+    $ Record.merge overwrites state
   where
-  { expression, typeMap, errors } = tryCompiling state
+  overwrites = tryCompiling state
 
 -- Evaluate the current expression and write into the value map
 evaluate :: forall a s m. State a s m -> State a s m