Merge pull request #23 from Mateiadrielrafael/develop

Release

package.json

@@ -3,7 +3,7 @@
   "scripts": {
     "prepare:purescript": "rm -rf output/bundle.js && hygen bundle prepare",
     "build:purescript": "spago build",
-    "dev": "pnpm run prepare:purescript && parcel public/index.html --port 8080 & nodemon",
+    "dev": "pnpm run prepare:purescript && parcel public/index.html --port 8080",
     "prebuild": "rm -rf dist",
     "bundle:purescript": "cross-env NODE_ENV=production pnpm run prepare:purescript && spago bundle-app -t output/prod-bundle.js",
     "build": "tsc && pnpm run bundle:purescript && parcel build public/index.html",

public/styles/components/node.scss

@@ -1,3 +1,21 @@
+@import "../theme.scss";
+
 .node.selected {
   border: 10px solid red;
 }
+
+.node-input {
+  transition: stroke-width $transition-time;
+}
+
+.node-input:hover {
+  stroke-width: 9px;
+}
+
+.node-output {
+  transition: transform $transition-time;
+}
+
+.node-output:hover {
+  transform: scale(1.3);
+}

public/styles/pages/editor/add.scss

@@ -61,6 +61,10 @@
           overflow: hidden;
           text-transform: capitalize;
         }
+
+        #node-type {
+          font-size: 0.85rem;
+        }
       }
     }
   }

public/styles/theme.scss

@@ -1,5 +1,5 @@
-// I curently have only one theme so using hardcoded scss variables is ok
-// In the future I might take a more complex aproach if I want to allow multiple themes
+// I currently have only one theme so using hard-coded scss variables is ok
+// In the future I might take a more complex approach if I want to allow multiple themes
 
 $primary: #262335;
 $on-primary: #e2e2e2;

spago.dhall

@@ -9,11 +9,13 @@ You can edit this file as you like.
   , "arrays"
   , "colehaus-graphs"
   , "console"
+  , "css"
   , "data-default"
   , "debug"
   , "effect"
   , "generics-rep"
   , "halogen"
+  , "halogen-css"
   , "halogen-svg"
   , "halogen-vdom"
   , "lists"
@@ -29,6 +31,7 @@ You can edit this file as you like.
   , "routing-duplex"
   , "sized-vectors"
   , "spec"
+  , "stringutils"
   , "tuples"
   , "typelevel"
   , "typelevel-prelude"

src/Component/Editor.purs

@@ -6,7 +6,6 @@ import Control.Monad.State (get, gets, modify_, put)
 import Control.MonadZero (guard)
 import Data.Array (foldr, (..))
 import Data.Default (def)
-import Data.Either (Either(..))
 import Data.Foldable (for_, sequence_)
 import Data.Lens (over, preview, set, view)
 import Data.List.Lazy as List
@@ -28,9 +27,10 @@ import Lunarbox.Component.Editor.Tree as TreeC
 import Lunarbox.Component.Icon (icon)
 import Lunarbox.Component.Utils (container)
 import Lunarbox.Config (Config)
-import Lunarbox.Control.Monad.Dataflow.Solve.SolveExpression (printTypeMap, solveExpression)
+import Lunarbox.Control.Monad.Dataflow.Solve.SolveExpression (printTypeMap)
 import Lunarbox.Control.Monad.Effect (print, printString)
 import Lunarbox.Data.Dataflow.Class.Expressible (nullExpr)
+import Lunarbox.Data.Dataflow.Expression (printSource)
 import Lunarbox.Data.Dataflow.Native.Prelude (loadPrelude)
 import Lunarbox.Data.Dataflow.Type (numberOfInputs)
 import Lunarbox.Data.Editor.ExtendedLocation (ExtendedLocation(..))
@@ -40,24 +40,24 @@ import Lunarbox.Data.Editor.Node.NodeData (NodeData(..), _NodeDataPosition, _Nod
 import Lunarbox.Data.Editor.Node.NodeDescriptor (onlyEditable)
 import Lunarbox.Data.Editor.Node.NodeId (NodeId(..))
 import Lunarbox.Data.Editor.Node.PinLocation (Pin(..))
-import Lunarbox.Data.Editor.Project (_projectNodeGroup, compileProject, createFunction, emptyProject)
-import Lunarbox.Data.Editor.State (State, Tab(..), _atColorMap, _atNode, _atNodeData, _currentFunction, _currentTab, _function, _functions, _isSelected, _lastMousePosition, _nextId, _nodeData, _panelIsOpen, _project, _typeMap, tabIcon)
+import Lunarbox.Data.Editor.Project (_projectNodeGroup, createFunction, emptyProject)
+import Lunarbox.Data.Editor.State (State, Tab(..), _atColorMap, _atCurrentNode, _atNode, _atNodeData, _currentFunction, _currentTab, _expression, _function, _functions, _isSelected, _lastMousePosition, _nextId, _nodeData, _panelIsOpen, _partialFrom, _partialTo, _project, _typeMap, compile, tabIcon, tryConnecting)
 import Lunarbox.Data.Graph as G
 import Lunarbox.Data.Vector (Vec2)
 import Lunarbox.Page.Editor.EmptyEditor (emptyEditor)
 import Lunarbox.Svg.Attributes (transparent)
-import Record as Record
 
 data Action
   = ChangeTab Tab
   | CreateFunction FunctionName
   | SelectFunction (Maybe FunctionName)
   | CreateNode FunctionName
   | StartFunctionCreation
-  | Compile
   | SceneMouseUp
   | SceneMouseDown (Vec2 Number)
   | SceneMouseMove (Vec2 Number)
+  | SelectInput NodeId Int
+  | SelectOutput NodeId
   | SelectNode NodeId
   | LoadNodes
 
@@ -90,6 +90,7 @@ component =
         , lastMousePosition: Nothing
         , expression: nullExpr Nowhere
         , project: emptyProject $ NodeId "firstOutput"
+        , partialConnection: def
         }
     , render
     , eval:
@@ -103,22 +104,7 @@ component =
   handleAction :: Action -> HalogenM State Action ChildSlots Void m Unit
   handleAction = case _ of
     LoadNodes -> do
-      modify_ loadPrelude
-      handleAction Compile
-    Compile -> do
-      { project, expression } <- get
-      let
-        expression' = compileProject project
-      -- we only run the type inference algorithm if the expression changed
-      when (expression /= expression') do
-        let
-          typeMap = case solveExpression expression' of
-            Right map -> Map.delete Nowhere map
-            Left _ -> mempty
-        printString $ printTypeMap typeMap
-        -- printString $ printSource expression'
-        -- TODO: make it so this accounts for errors
-        modify_ $ Record.merge { expression: expression', typeMap }
+      modify_ $ compile <<< loadPrelude
     CreateNode name -> do
       print "here:)"
       Tuple id setId <- createId
@@ -152,8 +138,9 @@ component =
                 state'' = set (_atNode currentFunction id) (Just node) state'
 
                 state''' = set (_atNodeData currentFunction id) (Just def) state''
-              void $ put $ setId state'''
-              handleAction Compile
+
+                state'''' = over _functions (G.insertEdge name currentFunction) state'''
+              void $ put $ compile $ setId state''''
     ChangeTab newTab -> do
       oldTab <- gets $ view _currentTab
       modify_
@@ -179,9 +166,8 @@ component =
             function <-
               G.lookup currentFunction functions
             pure do
-              handleAction Compile
               -- And finally, save the selected function in the state
-              modify_ $ set _currentFunction name
+              modify_ $ set _currentFunction name <<< compile
     SceneMouseDown position -> do
       modify_ $ set _lastMousePosition $ Just position
     SceneMouseMove position -> do
@@ -206,6 +192,22 @@ component =
       maybeCurrentFunction <- gets $ view _currentFunction
       for_ maybeCurrentFunction \currentFunction -> do
         modify_ $ set (_isSelected currentFunction id) true
+    SelectInput id index -> do
+      s <- gets $ view _partialTo
+      let
+        setTo = set _partialTo $ Just $ Tuple id index
+      print s
+      modify_ $ tryConnecting <<< setTo
+    SelectOutput id -> do
+      let
+        setFrom = set _partialFrom $ Just id
+      modify_ $ tryConnecting <<< setFrom
+      s <- gets $ view _typeMap
+      e <- gets $ view _expression
+      s' <- gets $ preview $ _atCurrentNode $ NodeId "firstOutput"
+      printString $ printTypeMap s
+      printString $ printSource e
+      print s'
 
   handleTreeOutput :: TreeC.Output -> Maybe Action
   handleTreeOutput = case _ of
@@ -302,6 +304,8 @@ component =
             , mouseMove: Just <<< SceneMouseMove
             , mouseUp: Just SceneMouseUp
             , selectNode: Just <<< SelectNode
+            , selectInput: (Just <<< _) <<< SelectInput
+            , selectOutput: Just <<< SelectOutput
             }
 
   render :: State -> HH.HTML _ Action

src/Component/Editor/Add.purs

@@ -15,7 +15,8 @@ import Halogen.HTML (HTML)
 import Halogen.HTML as HH
 import Halogen.HTML.Events (onClick)
 import Halogen.HTML.Properties as HP
-import Lunarbox.Capability.Editor.Type (generateTypeMap)
+import Lunarbox.Capability.Editor.Type (generateTypeMap, prettify)
+import Lunarbox.Component.Editor.HighlightedType (highlightTypeToHTML)
 import Lunarbox.Component.Editor.Node (node)
 import Lunarbox.Component.Editor.Node as NodeC
 import Lunarbox.Component.Icon (icon)
@@ -30,6 +31,7 @@ import Lunarbox.Data.Editor.Node (Node(..), hasOutput)
 import Lunarbox.Data.Editor.Node.NodeDescriptor (NodeDescriptor, describe)
 import Lunarbox.Data.Editor.Node.PinLocation (Pin(..))
 import Lunarbox.Data.Editor.Project (Project)
+import Svg.Attributes (Color(..))
 import Svg.Attributes as SA
 import Svg.Elements as SE
 
@@ -50,7 +52,7 @@ resolvePin (InputPin index) type' = inputs type' !! index
 
 resolvePin OutputPin type' = Just $ output type'
 
-nodeInput :: Map.Map Location Type -> FunctionName -> FunctionData -> NodeC.Input
+nodeInput :: forall h a. Map.Map Location Type -> FunctionName -> FunctionData -> NodeC.Input h a
 nodeInput typeMap name functionData =
   { nodeData: def
   , node
@@ -77,13 +79,22 @@ makeNode { edit, addNode } { isUsable, isEditable } name typeMap functionData =
         ]
         [ node
             (nodeInput typeMap name functionData)
-            { select: Nothing }
+            { select: Nothing
+            , selectOutput: Nothing
+            , selectInput: const Nothing
+            }
         ]
     , container "node-data"
         [ container "node-text"
             [ container "node-name"
                 [ HH.text $ show name
                 ]
+            , container "node-type"
+                $ fromMaybe mempty
+                $ pure
+                <<< highlightTypeToHTML (RGB 255 255 255)
+                <<< prettify
+                <$> Map.lookup (Location name) typeMap
             ]
         , container "node-buttons"
             [ HH.div

src/Component/Editor/HighlightedType.purs

@@ -0,0 +1,40 @@
+module Lunarbox.Component.Editor.HighlightedType
+  ( highlightedType
+  , highlightTypeToHTML
+  , highlightTypeToSvg
+  ) where
+
+import Prelude
+import Data.Maybe (Maybe(..), fromMaybe)
+import Halogen.HTML as HH
+import Lunarbox.Capability.Editor.Type (typeToColor)
+import Lunarbox.Component.HighlightedText as HT
+import Lunarbox.Data.Dataflow.Type (Type(..))
+import Lunarbox.Math.SeededRandom (seededInt)
+import Lunarbox.Svg.Element (tspan)
+import Svg.Attributes (Color(..))
+import Svg.Attributes as SA
+
+-- A type which is syntax highlighted
+highlightedType :: forall h a. (Array (HH.HTML h a) -> HH.HTML h a) -> (Color -> HH.HTML h a -> HH.HTML h a) -> Color -> Type -> HH.HTML h a
+highlightedType container highlight defaultColor = case _ of
+  TArrow from to ->
+    container
+      [ highlightedType container highlight defaultColor from
+      , HH.text " -> "
+      , highlightedType container highlight defaultColor to
+      ]
+  TVarariable name' -> highlight (RGB shade shade shade) $ HH.text $ show name'
+    where
+    shade = seededInt (show name') 100 255
+  other -> highlight color $ HH.text $ show other
+    where
+    color = fromMaybe defaultColor $ typeToColor other
+
+highlightTypeToHTML :: forall h a. Color -> Type -> HH.HTML h a
+highlightTypeToHTML = highlightedType HH.span_ HT.highlight
+
+highlightTypeToSvg :: forall h a. Color -> Type -> HH.HTML h a
+highlightTypeToSvg =
+  highlightedType (tspan []) \color ->
+    tspan [ SA.fill $ Just color ] <<< pure