feat: executing... kinda

lunarcast · Apr 27, 2020 · ec3f979 · ec3f979
1 parent e5bc256
commit ec3f979
Show file tree

Hide file tree

Showing 23 changed files with 293 additions and 175 deletions.
diff --git a/src/Component/Editor.purs b/src/Component/Editor.purs
@@ -1,4 +1,8 @@
-module Lunarbox.Component.Editor (component, Action(..), Query) where
+module Lunarbox.Component.Editor
+  ( component
+  , Action(..)
+  , Query
+  ) where
 
 import Prelude
 import Control.Monad.Reader (class MonadReader)
@@ -11,6 +15,7 @@ import Data.Lens (over, preview, set, view)
 import Data.List.Lazy as List
 import Data.Map as Map
 import Data.Maybe (Maybe(..), fromMaybe, maybe)
+import Data.Newtype (unwrap)
 import Data.Set as Set
 import Data.Symbol (SProxy(..))
 import Data.Tuple (Tuple(..), uncurry)
@@ -28,19 +33,18 @@ import Lunarbox.Component.Icon (icon)
 import Lunarbox.Component.Utils (container)
 import Lunarbox.Config (Config)
 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(..))
+import Lunarbox.Data.Editor.ExtendedLocation (ExtendedLocation(..), nothing)
 import Lunarbox.Data.Editor.FunctionName (FunctionName(..))
 import Lunarbox.Data.Editor.Node (Node(..))
 import Lunarbox.Data.Editor.Node.NodeData (NodeData(..), _NodeDataPosition, _NodeDataSelected)
 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, emptyProject)
-import Lunarbox.Data.Editor.State (State, Tab(..), _atColorMap, _atNode, _atNodeData, _currentFunction, _currentTab, _expression, _function, _functionData, _functions, _isSelected, _lastMousePosition, _nextId, _nodeData, _panelIsOpen, _partialFrom, _partialTo, _typeMap, compile, getSceneMousePosition, initializeFunction, removeConnection, setCurrentFunction, tabIcon, tryConnecting)
+import Lunarbox.Data.Editor.State (State, Tab(..), _atColorMap, _atNode, _atNodeData, _currentFunction, _currentNodeGroup, _currentNodes, _currentTab, _expression, _function, _functions, _isSelected, _lastMousePosition, _nextId, _nodeData, _panelIsOpen, _partialFrom, _partialTo, _typeMap, _valueMap, compile, getSceneMousePosition, initializeFunction, removeConnection, setCurrentFunction, tabIcon, tryConnecting)
 import Lunarbox.Data.Graph as G
 import Lunarbox.Data.Vector (Vec2)
 import Lunarbox.Page.Editor.EmptyEditor (emptyEditor)
@@ -88,9 +92,10 @@ component =
         , nodeData: Map.singleton (Tuple (FunctionName "main") $ NodeId "firstOutput") def
         , currentFunction: Nothing
         , lastMousePosition: Nothing
-        , expression: nullExpr Nowhere
+        , expression: nothing
         , project: emptyProject $ NodeId "firstOutput"
         , partialConnection: def
+        , valueMap: mempty
         }
     , render
     , eval:
@@ -141,6 +146,8 @@ component =
                 state'''' = over _functions (G.insertEdge name currentFunction) state'''
               void $ put $ compile $ setId state''''
     ChangeTab newTab -> do
+      s <- gets $ view _valueMap
+      print s
       oldTab <- gets $ view _currentTab
       modify_
         if (oldTab == newTab) then
@@ -149,9 +156,6 @@ component =
           set _currentTab newTab
     CreateFunction name -> do
       modify_ $ initializeFunction name
-      s <- gets $ view _functionData
-      print s
-      print name
     SelectFunction name -> modify_ $ setCurrentFunction name
     StartFunctionCreation -> do
       void $ query (SProxy :: _ "tree") unit $ tell TreeC.StartCreation
@@ -163,8 +167,6 @@ component =
         relativePosition = view _lastMousePosition state'
 
         maybeOffset = (-) <$> relativePosition <*> lastMousePosition
-      -- print relativePosition
-      -- print lastMousePosition
       for_ maybeOffset \offset -> do
         let
           updateState =
@@ -176,7 +178,6 @@ component =
                     node
         put $ updateState state'
     SceneMouseUp -> do
-      print "here"
       modify_ $ over _nodeData $ map $ set _NodeDataSelected false
     SelectNode id -> do
       maybeCurrentFunction <- gets $ view _currentFunction
@@ -192,6 +193,10 @@ component =
       modify_ $ tryConnecting <<< setFrom
       e <- gets $ view _expression
       printString $ printSource e
+      a <- gets $ view _currentNodeGroup
+      b <- gets $ preview _currentNodes
+      print b
+      (print :: Maybe (Array _) -> _) $ G.edges <$> _.nodes <$> unwrap <$> a
     RemoveConnection from to -> do
       modify_ $ removeConnection from to
 
@@ -264,6 +269,7 @@ component =
   , nodeData
   , colorMap
   , partialConnection
+  , valueMap
   } =
     fromMaybe
       emptyEditor do
@@ -281,6 +287,7 @@ component =
             , lastMousePosition
             , functionData
             , partialConnection
+            , valueMap
             , nodeData:
               Map.fromFoldable
                 $ (uncurry \(Tuple _ id) value -> Tuple id value)

diff --git a/src/Component/Editor/Add.purs b/src/Component/Editor/Add.purs
@@ -69,6 +69,7 @@ nodeInput typeMap name functionData =
           (\pin -> Map.lookup (Location name) typeMap >>= resolvePin pin)
           functionData
           node
+  , value: Nothing
   }
   where
   inputCount = fromMaybe 0 $ numberOfInputs <$> Map.lookup (Location name) typeMap

diff --git a/src/Component/Editor/Node.purs b/src/Component/Editor/Node.purs
@@ -25,9 +25,11 @@ import Lunarbox.Capability.Editor.Node.Arc as Arc
 import Lunarbox.Component.Editor.Edge (renderEdge)
 import Lunarbox.Component.Editor.Node.Input (input)
 import Lunarbox.Component.Editor.Node.Overlays (overlays)
+import Lunarbox.Component.Editor.RuntimeValue (renderRuntimeValue)
+import Lunarbox.Data.Dataflow.Runtime (RuntimeValue)
 import Lunarbox.Data.Editor.Constants (arcSpacing, arcWidth, inputLayerOffset, mouseId, nodeRadius, scaleConnectionPreview)
 import Lunarbox.Data.Editor.FunctionData (FunctionData)
-import Lunarbox.Data.Editor.Node (Node, _nodeInput, _nodeInputs, getInputs)
+import Lunarbox.Data.Editor.Node (Node(..), _nodeInput, _nodeInputs, getInputs)
 import Lunarbox.Data.Editor.Node.NodeData (NodeData, _NodeDataPosition)
 import Lunarbox.Data.Editor.Node.NodeId (NodeId)
 import Lunarbox.Data.Editor.Node.NodeInput (getArcs)
@@ -57,6 +59,7 @@ type Input h a
     , nodeDataMap :: Map NodeId NodeData
     , selectionStatus :: SelectionStatus
     , mousePosition :: Vec2 Number
+    , value :: Maybe RuntimeValue
     }
 
 type Actions a
@@ -104,6 +107,7 @@ renderNode { nodeData: nodeData
 , nodeDataMap
 , selectionStatus
 , mousePosition
+, value
 } { select
 , selectOutput
 , selectInput
@@ -115,6 +119,7 @@ renderNode { nodeData: nodeData
     ]
     $ [ overlays maxRadius labels
       ]
+    <> valueSvg
     <> arcs
     <> [ movementHandler
       , output
@@ -165,6 +170,25 @@ renderNode { nodeData: nodeData
 
   maxRadius = nodeRadius + (toNumber $ List.length inputArcs - 1) * inputLayerOffset
 
+  valueSvg =
+    maybe mempty
+      ( \value' ->
+          let
+            color = case node of
+              OutputNode _ -> fromMaybe transparent $ Map.lookup (InputPin 0) colorMap
+              _ -> outputColor
+          in
+            pure
+              $ SE.g
+                  [ SA.transform
+                      [ SA.Translate 0.0 $ maxRadius + inputLayerOffset
+                      ]
+                  ]
+                  [ renderRuntimeValue color value'
+                  ]
+      )
+      value
+
   arcs =
     if List.null $ view _nodeInputs node then
       [ constant ]

diff --git a/src/Component/Editor/Node/RuntimeValue.purs b/src/Component/Editor/Node/RuntimeValue.purs
@@ -0,0 +1,27 @@
+module Lunarbox.Component.Editor.RuntimeValue
+  ( renderRuntimeValue
+  ) where
+
+import Prelude
+import Data.Maybe (Maybe(..))
+import Halogen.HTML (HTML)
+import Halogen.HTML as HH
+import Lunarbox.Data.Dataflow.Runtime (RuntimeValue)
+import Svg.Attributes as SA
+import Svg.Elements as SE
+
+-- Helper to center some svg text
+centeredText :: forall h a. SA.Color -> String -> HTML h a
+centeredText color =
+  SE.text
+    [ SA.text_anchor SA.AnchorMiddle
+    , SA.fill $ Just color
+    , SA.class_ "unselectable"
+    , SA.dominant_baseline SA.Hanging
+    ]
+    <<< pure
+    <<< HH.text
+
+-- render a value visually
+renderRuntimeValue :: forall h a. SA.Color -> RuntimeValue -> HTML h a
+renderRuntimeValue color = centeredText color <<< show
diff --git a/src/Component/Editor/Scene.purs b/src/Component/Editor/Scene.purs
@@ -14,6 +14,7 @@ import Data.Lens (is, preview, view)
 import Data.Map (Map)
 import Data.Map as Map
 import Data.Maybe (Maybe, fromMaybe)
+import Data.Newtype (unwrap)
 import Data.Traversable (sequence)
 import Data.Tuple (Tuple(..))
 import Data.Vec (vec2)
@@ -25,6 +26,7 @@ import Lunarbox.Component.Editor.Node (renderNode)
 import Lunarbox.Component.Editor.Node.Label (labelText, label)
 import Lunarbox.Data.Dataflow.Expression (Expression, sumarizeExpression)
 import Lunarbox.Data.Dataflow.Expression as Expression
+import Lunarbox.Data.Dataflow.Runtime.ValueMap (ValueMap)
 import Lunarbox.Data.Dataflow.Type (Type)
 import Lunarbox.Data.Editor.ExtendedLocation (ExtendedLocation(..), _ExtendedLocation, _LocationExtension)
 import Lunarbox.Data.Editor.FunctionData (FunctionData, getFunctionData)
@@ -55,6 +57,7 @@ type Input
     , nodeData :: Map NodeId NodeData
     , partialConnection :: PartialConnection
     , lastMousePosition :: Maybe (Vec2 Number)
+    , valueMap :: ValueMap Location
     }
 
 type Actions a
@@ -105,6 +108,7 @@ createNodeComponent { functionName
 , partialConnection
 , lastMousePosition
 , nodeData: nodeDataMap
+, valueMap
 } { selectNode, selectInput, selectOutput, removeConnection } (Tuple id nodeData) = do
   let
     generateLocation = DeepLocation functionName
@@ -144,6 +148,7 @@ createNodeComponent { functionName
         , hasOutput: not $ is _OutputNode node
         , selectionStatus: getSelectionStatus partialConnection id
         , mousePosition: fromMaybe zero lastMousePosition
+        , value: Map.lookup location $ unwrap valueMap
         }
         { select: selectNode id
         , selectInput: selectInput id

diff --git a/src/Control/Monad/Dataflow/Interpreter.purs b/src/Control/Monad/Dataflow/Interpreter.purs
@@ -13,51 +13,52 @@ import Data.Lens (Lens')
 import Data.Lens.Record (prop)
 import Data.Newtype (class Newtype)
 import Data.Symbol (SProxy(..))
-import Lunarbox.Data.Dataflow.Runtime (TermEnvironment)
+import Data.Tuple (Tuple)
+import Lunarbox.Data.Dataflow.Runtime.TermEnvironment (TermEnvironment)
 import Lunarbox.Data.Dataflow.Runtime.ValueMap (ValueMap)
 import Lunarbox.Data.Lens (newtypeIso)
 
 -- The Interpreter context is the env all interpreting occurs in.
-newtype InterpreterContext v l
+newtype InterpreterContext l
   = InterpreterContext
   { location :: l
-  , termEnv :: TermEnvironment v
+  , termEnv :: TermEnvironment
   }
 
-derive instance newtypeInterpreterContent :: Newtype (InterpreterContext v l) _
+derive instance newtypeInterpreterContent :: Newtype (InterpreterContext l) _
 
 -- Lenses
-_location :: forall v l. Lens' (InterpreterContext v l) l
+_location :: forall l. Lens' (InterpreterContext l) l
 _location = newtypeIso <<< prop (SProxy :: _ "location")
 
-_termEnv :: forall v l. Lens' (InterpreterContext v l) (TermEnvironment v)
+_termEnv :: forall l. Lens' (InterpreterContext l) TermEnvironment
 _termEnv = newtypeIso <<< prop (SProxy :: _ "termEnv")
 
 -- Monad used to Interpret expressions
-newtype Interpreter v l a
-  = Interpreter (WriterT (ValueMap v l) (Reader (InterpreterContext v l)) a)
+newtype Interpreter l a
+  = Interpreter (WriterT (ValueMap l) (Reader (InterpreterContext l)) a)
 
 -- Takes a Interpreter monad and runs it 
-runInterpreter :: forall v l a. Ord l => Interpreter v l a -> ValueMap v l
-runInterpreter (Interpreter m) = runReader mempty $ runWriterT m
+runInterpreter :: forall l a. Ord l => InterpreterContext l -> Interpreter l a -> Tuple a (ValueMap l)
+runInterpreter context (Interpreter m) = runReader (runWriterT m) context
 
 -- Typeclasses
-derive instance newtypeInterpreter :: Newtype (Interpreter v l a) _
+derive instance newtypeInterpreter :: Newtype (Interpreter l a) _
 
-derive newtype instance functorInterpreter :: Ord l => Functor (Interpreter v l)
+derive newtype instance functorInterpreter :: Ord l => Functor (Interpreter l)
 
-derive newtype instance applyInterpreter :: Ord l => Apply (Interpreter v l)
+derive newtype instance applyInterpreter :: Ord l => Apply (Interpreter l)
 
-derive newtype instance applicativeInterpreter :: Ord l => Applicative (Interpreter v l)
+derive newtype instance applicativeInterpreter :: Ord l => Applicative (Interpreter l)
 
-derive newtype instance bindInterpreter :: Ord l => Bind (Interpreter v l)
+derive newtype instance bindInterpreter :: Ord l => Bind (Interpreter l)
 
-derive newtype instance monadInterpreter :: Ord l => Monad (Interpreter v l)
+derive newtype instance monadInterpreter :: Ord l => Monad (Interpreter l)
 
-derive newtype instance monadAskInterpreter :: Ord l => MonadAsk (InterpreterContext v l) (Interpreter v l)
+derive newtype instance monadAskInterpreter :: Ord l => MonadAsk (InterpreterContext l) (Interpreter l)
 
-derive newtype instance monadReaderInterpreter :: Ord l => MonadReader (InterpreterContext v l) (Interpreter v l)
+derive newtype instance monadReaderInterpreter :: Ord l => MonadReader (InterpreterContext l) (Interpreter l)
 
-derive newtype instance monadTellInterpreter :: Ord l => MonadTell (ValueMap v l) (Interpreter v l)
+derive newtype instance monadTellInterpreter :: Ord l => MonadTell (ValueMap l) (Interpreter l)
 
-derive newtype instance monadWriterInterpreter :: Ord l => MonadWriter (ValueMap v l) (Interpreter v l)
+derive newtype instance monadWriterInterpreter :: Ord l => MonadWriter (ValueMap l) (Interpreter l)