From bc479e5d357d16e7e33e44a1a9d5d826ec362779 Mon Sep 17 00:00:00 2001 From: Matei Adriel Date: Tue, 14 Jul 2020 21:42:55 +0300 Subject: [PATCH] fix: I FINALLY FIXED THIS YAYAYAYAYAYAY --- src/Component/Editor.purs | 31 ++++- src/Component/Editor/EditNode.purs | 15 ++- src/Component/Editor/NodeUi.purs | 4 +- src/Component/Editor/NodeUiManager.purs | 16 ++- .../Monad/Dataflow/Interpreter/Interpret.purs | 109 ++++++++---------- src/Data/Editor/State.purs | 25 ++-- 6 files changed, 113 insertions(+), 87 deletions(-) diff --git a/src/Component/Editor.purs b/src/Component/Editor.purs index 567aada..9909dc0 100644 --- a/src/Component/Editor.purs +++ b/src/Component/Editor.purs @@ -16,6 +16,7 @@ import Data.Array ((!!)) import Data.Array as Array import Data.Foldable (for_, traverse_) import Data.Lens (_Just, is, over, preview, set, view) +import Data.Lens.At (at) import Data.Lens.Iso.Newtype (_Newtype) import Data.List ((:)) import Data.Map as Map @@ -39,6 +40,7 @@ import Lunarbox.Capability.Navigate (class Navigate, navigate) import Lunarbox.Component.Editor.Add as Add import Lunarbox.Component.Editor.Add as AddC import Lunarbox.Component.Editor.NodePreview as NodePreview +import Lunarbox.Component.Editor.NodeUi (uiToRuntime) import Lunarbox.Component.Editor.Problems (problems, shouldRender) import Lunarbox.Component.Editor.Scene as Scene import Lunarbox.Component.Editor.Tree as TreeC @@ -52,6 +54,7 @@ import Lunarbox.Data.Class.GraphRep (toGraph) import Lunarbox.Data.Dataflow.Expression.Lint as LintError import Lunarbox.Data.Dataflow.Native.Prelude (loadPrelude) import Lunarbox.Data.Dataflow.Runtime (RuntimeValue(..)) +import Lunarbox.Data.Dataflow.Runtime.TermEnvironment (Term(..)) import Lunarbox.Data.Dataflow.Type as Type import Lunarbox.Data.Dataflow.TypeError as TypeError import Lunarbox.Data.Editor.DataflowFunction (DataflowFunction(..), _NativeFunction) @@ -64,7 +67,7 @@ import Lunarbox.Data.Editor.Node.NodeId (NodeId) import Lunarbox.Data.Editor.Node.PinLocation (ScopedLocation(..)) import Lunarbox.Data.Editor.Project as Project import Lunarbox.Data.Editor.Save (stateToJson) -import Lunarbox.Data.Editor.State (MovementStep(..), State, Tab(..), _atFunctionData, _atInputCount, _atNode, _currentFunction, _currentTab, _function, _functions, _isAdmin, _isExample, _isVisible, _name, _nodeSearchTerm, _panelIsOpen, compile, createConnection, createNode, deleteFunction, deleteNode, evaluate, functionExists, generateUnconnectableInputs, generateUnconnectableOutputs, getFunctionColorMap, getMaxInputs, getNodeType, initializeFunction, moveTo, removeConnection, searchNode, setCurrentFunction, tabIcon, tryCompiling, updateAll, withCurrentFunction_, withCurrentGeometries, withCurrentNode_) +import Lunarbox.Data.Editor.State (MovementStep(..), State, Tab(..), _atFunctionData, _atInputCount, _atNode, _currentFunction, _currentTab, _function, _functions, _isAdmin, _isExample, _isVisible, _name, _nodeSearchTerm, _panelIsOpen, _runtimeOverwrites, compile, createConnection, createNode, deleteFunction, deleteNode, evaluate, functionExists, generateUnconnectableInputs, generateUnconnectableOutputs, getFunctionColorMap, getMaxInputs, getNodeType, initializeFunction, moveTo, removeConnection, searchNode, setCurrentFunction, tabIcon, tryCompiling, updateAll, withCurrentFunction_, withCurrentGeometries, withCurrentNode_) import Lunarbox.Data.Graph as G import Lunarbox.Data.Route (Route(..)) import Lunarbox.Data.Set (toNative) as Set @@ -107,6 +110,7 @@ data Action | UpdatePreview FunctionName | UpdatePreviews | MoveTo Location + | UpdateOverwrite NodeId FunctionName RuntimeValue -- Handle foreign actions bubbled by the Scene component | CreateConnection NodeId NodeId Int | SelectInput NodeId Int @@ -472,29 +476,44 @@ component = nodeEditingModal { title = show function , content = - \_ -> + \bubble -> EditNode.component { description , type' , inputs , id , function + , setValue: map (bubble <<< UpdateOverwrite id currentFunction) <<< uiToRuntime function , value: - fromMaybe Null - $ Map.lookup (InsideFunction function $ NodeLocation id) - $ state.runtimeOverwrites + case Map.lookup (InsideFunction currentFunction $ NodeLocation id) + $ unwrap + $ state.runtimeOverwrites of + Just (Term v) -> v + _ -> Null } } _ -> pure unit HandleNodeEdits action -> case action of NEDeleteNode -> withCurrentNode_ (handleAction <<< DeleteNode) - NECloseModal -> pure unit + NECloseModal -> do + modify_ evaluate + void updateAll + handleAction Rerender GotoId id -> withCurrentFunction_ \currentFunction -> gets (preview (_atNode currentFunction id)) >>= traverse_ case _ of ComplexNode { function } -> handleAction (SelectFunction function) _ -> pure unit + UpdateOverwrite id function value -> do + modify_ + $ set + ( _runtimeOverwrites + <<< _Newtype + <<< (at $ InsideFunction function $ NodeLocation id) + ) + $ Just + $ Term value handleTreeOutput :: TreeC.Output -> Maybe Action handleTreeOutput = case _ of diff --git a/src/Component/Editor/EditNode.purs b/src/Component/Editor/EditNode.purs index 8c82b62..a927215 100644 --- a/src/Component/Editor/EditNode.purs +++ b/src/Component/Editor/EditNode.purs @@ -8,6 +8,7 @@ import Prelude import Data.Array as Array import Data.Maybe (Maybe) import Data.Symbol (SProxy(..)) +import Debug.Trace (spy) import Halogen (Slot, ComponentHTML) import Halogen.HTML as HH import Lunarbox.Component.Editor.HighlightedType (highlightTypeToHTML) @@ -20,11 +21,11 @@ import Lunarbox.Data.Editor.FunctionName (FunctionName) import Lunarbox.Data.Editor.Node.NodeId (NodeId) type ChildSlots r - = ( nodeUi :: Slot NodeUiManager.Query Void NodeId + = ( nodeUi :: Slot NodeUiManager.Query NodeUiManager.Output NodeId | r ) -type Input +type Input a = { description :: Maybe String , type' :: Maybe Type , inputs :: @@ -36,11 +37,12 @@ type Input , function :: FunctionName , id :: NodeId , value :: RuntimeValue + , setValue :: RuntimeValue -> Maybe a } -- | The content of the node editing modal -component :: forall a m r. Input -> ComponentHTML a (ChildSlots r) m -component { description, type', inputs, id, function, value } = +component :: forall a m r. Input a -> ComponentHTML a (ChildSlots r) m +component { description, type', inputs, id, function, value, setValue } = HH.div [ className "edit-node" ] [ maybeElement type' \type'' -> HH.section [ className "edit-node__type" ] @@ -65,10 +67,13 @@ component { description, type', inputs, id, function, value } = , HH.slot (SProxy :: SProxy "nodeUi") id NodeUiManager.component { name: function, value } - absurd + handleNewValues ] ] where + handleNewValues = case _ of + NodeUiManager.NewValue val -> setValue $ spy "OOOOO" val + mkInput input = HH.details [ className "edit-node__input" ] [ HH.summary [ className "edit-node__input-name" ] diff --git a/src/Component/Editor/NodeUi.purs b/src/Component/Editor/NodeUi.purs index a5ad666..979a0ad 100644 --- a/src/Component/Editor/NodeUi.purs +++ b/src/Component/Editor/NodeUi.purs @@ -77,7 +77,9 @@ numberNodeInput = where render { value, setValue } = HH.input - [ HP.value $ fromMaybe "0" $ fromRuntime value + [ HP.value case value of + Number n -> show n + other -> fromMaybe "" $ fromRuntime other , HP.type_ HP.InputNumber , className "node-input node-input--number" , HE.onValueInput $ setValue <<< String diff --git a/src/Component/Editor/NodeUiManager.purs b/src/Component/Editor/NodeUiManager.purs index 77db915..55c7590 100644 --- a/src/Component/Editor/NodeUiManager.purs +++ b/src/Component/Editor/NodeUiManager.purs @@ -1,11 +1,12 @@ module Lunarbox.Component.Editor.NodeUiManager ( Query(..) + , Output(..) , component ) where import Prelude import Data.Maybe (Maybe(..)) -import Halogen (Component, HalogenM, defaultEval, get, mkComponent, mkEval, modify_) +import Halogen (Component, HalogenM, defaultEval, get, mkComponent, mkEval, modify_, raise) import Halogen.HTML as HH import Lunarbox.Component.Editor.NodeUi (runNodeUi, uiToRuntime) import Lunarbox.Data.Dataflow.Runtime (RuntimeValue) @@ -26,7 +27,10 @@ type Input r data Query a = GetValue (RuntimeValue -> a) -component :: forall m o. Component HH.HTML Query { | Input () } o m +newtype Output + = NewValue RuntimeValue + +component :: forall m. Component HH.HTML Query { | Input () } Output m component = mkComponent { initialState: identity @@ -39,11 +43,13 @@ component = } } where - handleAction :: Action -> HalogenM State Action ChildSlots o m Unit + handleAction :: Action -> HalogenM State Action ChildSlots Output m Unit handleAction = case _ of - SetValue val -> modify_ _ { value = val } + SetValue val -> do + modify_ _ { value = val } + raise $ NewValue val - handleQuery :: forall a. Query a -> HalogenM State Action ChildSlots o m (Maybe a) + handleQuery :: forall a. Query a -> HalogenM State Action ChildSlots Output m (Maybe a) handleQuery = case _ of GetValue return -> get <#> \{ name, value } -> return <$> uiToRuntime name value diff --git a/src/Control/Monad/Dataflow/Interpreter/Interpret.purs b/src/Control/Monad/Dataflow/Interpreter/Interpret.purs index 8f3484e..c85d169 100644 --- a/src/Control/Monad/Dataflow/Interpreter/Interpret.purs +++ b/src/Control/Monad/Dataflow/Interpreter/Interpret.purs @@ -1,19 +1,19 @@ module Lunarbox.Control.Monad.Dataflow.Interpreter.Interpret ( interpret , withTerm - , normalizeTerm + , termToRuntime ) where import Prelude -import Control.Monad.Reader (asks, local) +import Control.Monad.Reader (ask, asks, local) import Control.Monad.Writer (tell) import Data.Default (class Default, def) import Data.Lens (over, set, view) import Data.Map as Map import Data.Maybe (Maybe(..)) import Data.Newtype (unwrap) -import Lunarbox.Control.Monad.Dataflow.Interpreter (Interpreter, _location, _overwrites, _termEnv, _toplevel) -import Lunarbox.Data.Dataflow.Expression (Expression(..), NativeExpression(..), everywhereOnExpressionM, getLocation) +import Lunarbox.Control.Monad.Dataflow.Interpreter (Interpreter, InterpreterContext, _overwrites, _termEnv, _toplevel, evalInterpreter) +import Lunarbox.Data.Dataflow.Expression (Expression(..), NativeExpression(..), getLocation) import Lunarbox.Data.Dataflow.Runtime (RuntimeValue(..)) import Lunarbox.Data.Dataflow.Runtime.TermEnvironment (Term(..), TermEnvironment) import Lunarbox.Data.Dataflow.Runtime.TermEnvironment as TermEnvironment @@ -47,25 +47,15 @@ makeNative = Native def <<< NativeExpression (Forall [] typeString) scoped :: forall l a. Ord l => Interpreter l a -> Interpreter l a scoped = local $ set _toplevel false -normalizeTerm :: forall l. Ord l => Default l => Term l -> Interpreter l RuntimeValue -normalizeTerm (Term a) = pure a +-- | Transform a term into a runtime value +termToRuntime :: forall l. Ord l => Default l => InterpreterContext l -> Term l -> RuntimeValue +termToRuntime _ (Term a) = a -normalizeTerm (Closure env (Lambda _ _ _)) = pure Null +termToRuntime _ (Closure env (Lambda _ _ _)) = Null -normalizeTerm (Closure env expr) = result >>= normalizeTerm +termToRuntime ctx (Closure env expr) = termToRuntime ctx result where - result = withEnv env $ interpret expr - --- | Mark all the places inside an expression as null -markAsNull :: forall l. Ord l => Expression l -> Interpreter l (Term l) -markAsNull expr = - everywhereOnExpressionM (const $ pure true) - ( \e -> do - tell $ ValueMap $ Map.singleton (getLocation e) $ Term Null - pure e - ) - expr - $> def + result = evalInterpreter ctx $ withEnv env $ interpret expr -- Interpret an expression into a runtimeValue interpret :: forall l. Ord l => Default l => Expression l -> Interpreter l (Term l) @@ -77,47 +67,46 @@ interpret expression = do maybeOverwrite = Map.lookup location $ unwrap overwrites value <- case maybeOverwrite of Just overwrite -> pure overwrite - Nothing -> - local (set _location location) case expression of - TypedHole _ -> pure $ Term Null - Variable _ name -> getVariable $ show name - Lambda _ _ _ -> do - env <- getEnv - pure $ Closure env expression - Expression _ inner -> interpret inner - If _ cond then' else' -> interpret cond >>= go - where + Nothing -> case expression of + TypedHole _ -> pure $ Term Null + Variable _ name -> do + getVariable $ show name + Lambda _ _ _ -> do + env <- getEnv + pure $ Closure env expression + Expression _ inner -> interpret inner + If _ cond then' else' -> interpret cond >>= go + where + go = case _ of + Term (Bool true) -> interpret then' + Term (Bool false) -> interpret else' + Term (RLazy exec) -> go (Term $ exec unit) + t -> pure def + Let _ name value body -> do + runtimeValue <- interpret value + withTerm (show name) runtimeValue $ interpret body + expr@(FixPoint l name body) -> do + env <- getEnv + let + self = Closure env expr + withTerm (show name) self $ interpret body + Native _ (NativeExpression _ inner) -> pure $ Term inner + FunctionCall _ function argument -> do + runtimeArgument <- interpret argument + runtimeFunction <- interpret function + let go = case _ of - Term (Bool true) -> interpret then' - Term (Bool false) -> interpret else' - Term (RLazy exec) -> go (Term $ exec unit) - Term Null -> do - void $ markAsNull then' - markAsNull else' - t -> pure def - Let _ name value body -> do - runtimeValue <- interpret value - withTerm (show name) runtimeValue $ interpret body - expr@(FixPoint l name body) -> do - env <- getEnv - let - self = Closure env expr - withTerm (show name) self $ interpret body - Native _ (NativeExpression _ inner) -> pure $ Term inner - FunctionCall _ function argument -> do - runtimeArgument <- interpret argument - runtimeFunction <- interpret function - let - go = case _ of - Closure env (Lambda _ name expr) -> - scoped $ withEnv env $ withTerm (show name) runtimeArgument - $ interpret expr - Closure env expr -> call >>= go - where - call = scoped $ withEnv env $ interpret expr - Term (Function call) -> Term <$> call <$> normalizeTerm runtimeArgument - Term _ -> pure def - go runtimeFunction + Closure env (Lambda _ name expr) -> + scoped $ withEnv env $ withTerm (show name) runtimeArgument + $ interpret expr + Closure env expr -> call >>= go + where + call = scoped $ withEnv env $ interpret expr + Term (Function call) -> do + ctx <- ask + pure $ Term $ call $ termToRuntime ctx runtimeArgument + Term _ -> pure def + go runtimeFunction toplevel <- asks $ view _toplevel when toplevel $ tell $ ValueMap $ Map.singleton location value pure value diff --git a/src/Data/Editor/State.purs b/src/Data/Editor/State.purs index 9c5f107..96a330f 100644 --- a/src/Data/Editor/State.purs +++ b/src/Data/Editor/State.purs @@ -12,6 +12,7 @@ import Data.Foldable (foldMap, foldr, length, traverse_) import Data.Lens (Lens', Traversal', _Just, is, lens, over, preview, set, traversed, view) import Data.Lens.At (at) import Data.Lens.Index (ix) +import Data.Lens.Iso.Newtype (_Newtype) import Data.Lens.Record (prop) import Data.List (List) import Data.List as List @@ -29,8 +30,8 @@ import Data.Unfoldable (replicate) import Effect.Class (class MonadEffect) import Halogen (HalogenM, liftEffect, modify_) import Lunarbox.Capability.Editor.Type (generateColorMap, inputNodeType, typeToColor) -import Lunarbox.Control.Monad.Dataflow.Interpreter (InterpreterContext(..), evalInterpreter, runInterpreter) -import Lunarbox.Control.Monad.Dataflow.Interpreter.Interpret (interpret, normalizeTerm) +import Lunarbox.Control.Monad.Dataflow.Interpreter (InterpreterContext(..), runInterpreter) +import Lunarbox.Control.Monad.Dataflow.Interpreter.Interpret (interpret, termToRuntime) import Lunarbox.Control.Monad.Dataflow.Solve (SolveState(..)) import Lunarbox.Control.Monad.Dataflow.Solve.SolveExpression (solveExpression) import Lunarbox.Control.Monad.Dataflow.Solve.Unify (canUnify) @@ -38,8 +39,7 @@ import Lunarbox.Data.Class.GraphRep (toGraph) import Lunarbox.Data.Dataflow.Expression (Expression(..)) import Lunarbox.Data.Dataflow.Expression.Lint (LintError, lint) import Lunarbox.Data.Dataflow.Expression.Optimize (dce, inline) -import Lunarbox.Data.Dataflow.Runtime (RuntimeValue) -import Lunarbox.Data.Dataflow.Runtime.TermEnvironment (Term(..)) +import Lunarbox.Data.Dataflow.Runtime.TermEnvironment (Term) import Lunarbox.Data.Dataflow.Runtime.ValueMap (ValueMap(..)) import Lunarbox.Data.Dataflow.Type (Type(..), inputs, multiArgumentFuncion, typeBool) import Lunarbox.Data.Dataflow.TypeError (TypeError) @@ -92,7 +92,7 @@ type StatePermanentData r = ( project :: Project , nextId :: Int , geometries :: Map FunctionName GeometryCache - , runtimeOverwrites :: Map Location RuntimeValue + , runtimeOverwrites :: ValueMap Location , currentFunction :: FunctionName | r ) @@ -171,12 +171,17 @@ updateNode id = withCurrentFunction \currentFunction -> gets (preview $ _atCurrentNode id) >>= traverse_ \node -> do - { typeMap, valueMap } <- get + { typeMap, valueMap, runtimeOverwrites } <- get nodeGroup <- gets $ preview (_nodeGroup currentFunction) let + ctx = + over _Newtype + _ { overwrites = runtimeOverwrites } + (def :: InterpreterContext Location) + value = Nullable.toNullable - $ (show <<< evalInterpreter def <<< normalizeTerm) + $ (show <<< termToRuntime ctx) <$> getNodeValue currentFunction valueMap id node inputs = List.toUnfoldable $ view _nodeInputs node @@ -333,7 +338,7 @@ evaluate state@{ runtimeOverwrites, expression } = state { valueMap = valueMap } InterpreterContext { location: UnknownLocation , termEnv: mempty - , overwrites: ValueMap $ Term <$> runtimeOverwrites + , overwrites: runtimeOverwrites , toplevel: true } @@ -445,7 +450,7 @@ deleteFunction toDelete state = visualFunctions modify_ $ set (_atFunctionData toDelete) Nothing modify_ $ set (_function toDelete) Nothing - modify_ $ over _runtimeOverwrites $ Map.filterKeys $ (_ /= Just toDelete) <<< view _Function + modify_ $ over (_runtimeOverwrites <<< _Newtype) $ Map.filterKeys $ (_ /= Just toDelete) <<< view _Function modify_ $ set (_atInputCount toDelete) Nothing modify_ $ set (_atGeometry toDelete) Nothing when (view _currentFunction state == toDelete) $ modify_ $ set _currentFunction main @@ -597,7 +602,7 @@ _atInputCount name = _inputCountMap <<< at name _valueMap :: Lens' State (ValueMap Location) _valueMap = prop (SProxy :: _ "valueMap") -_runtimeOverwrites :: Lens' State (Map Location RuntimeValue) +_runtimeOverwrites :: Lens' State (ValueMap Location) _runtimeOverwrites = prop (SProxy :: _ "runtimeOverwrites") _geometries :: Lens' State (Map FunctionName GeometryCache)