Skip to content
This repository has been archived by the owner on Mar 4, 2024. It is now read-only.

Commit

Permalink
feat: basic modal system
Browse files Browse the repository at this point in the history
  • Loading branch information
prescientmoon committed Jun 28, 2020
1 parent f294bab commit 0420b04
Show file tree
Hide file tree
Showing 11 changed files with 322 additions and 118 deletions.
41 changes: 39 additions & 2 deletions src/Component/Editor.purs
Original file line number Diff line number Diff line change
Expand Up @@ -2,6 +2,7 @@ module Lunarbox.Component.Editor
( component
, Action(..)
, Output(..)
, ConfirmConnectionAction(..)
, EditorState
, ChildSlots
) where
Expand All @@ -16,8 +17,8 @@ import Data.Foldable (for_, traverse_)
import Data.Lens (over, preview, set, view)
import Data.Map as Map
import Data.Maybe (Maybe(..), isNothing, maybe)
import Data.Newtype (unwrap)
import Data.Set (toUnfoldable) as Set
import Lunarbox.Data.Set (toNative) as Set
import Data.String as String
import Data.Symbol (SProxy(..))
import Data.Traversable (traverse)
Expand All @@ -37,6 +38,7 @@ import Lunarbox.Component.Editor.Add as AddC
import Lunarbox.Component.Editor.Scene as Scene
import Lunarbox.Component.Editor.Tree as TreeC
import Lunarbox.Component.Icon (icon)
import Lunarbox.Component.Modal as Modal
import Lunarbox.Component.Switch (switch)
import Lunarbox.Component.Utils (className, container, whenElem)
import Lunarbox.Config (Config, _autosaveInterval)
Expand All @@ -50,6 +52,7 @@ import Lunarbox.Data.Editor.Save (stateToJson)
import Lunarbox.Data.Editor.State (State, Tab(..), _atGeometry, _atInputCount, _currentFunction, _currentTab, _isAdmin, _isExample, _isVisible, _name, _nodeSearchTerm, _nodes, _panelIsOpen, compile, createConnection, createNode, deleteFunction, functionExists, generateUnconnectableInputs, generateUnconnectableOutputs, initializeFunction, preventDefaults, removeConnection, searchNode, setCurrentFunction, setRuntimeValue, tabIcon, updateNode, withCurrentGeometries)
import Lunarbox.Data.Graph (wouldCreateCycle)
import Lunarbox.Data.Route (Route(..))
import Lunarbox.Data.Set (toNative) as Set
import Lunarbox.Foreign.Render (setUnconnectableInputs, setUnconnectableOutputs)
import Lunarbox.Foreign.Render as Native
import Web.Event.Event (Event, preventDefault, stopPropagation)
Expand Down Expand Up @@ -97,6 +100,7 @@ data Output
type ChildSlots
= ( tree :: Slot TreeC.Query TreeC.Output Unit
, scene :: Slot Scene.Query Scene.Output Unit
, confirmConnection :: Slot Modal.Query (Modal.Output ConfirmConnectionAction) Unit
)

-- Shorthand for manually passing the types of the actions and child slots
Expand All @@ -111,6 +115,30 @@ searchNodeInputRef = RefLabel "search node"
searchNodeClassName :: String
searchNodeClassName = "search-node"

-- | Actions which can be triggered from the connection confirmation modal.
data ConfirmConnectionAction
= ConfirmConnection
| CancelConnection

-- | The actual config for how to display the connection confirmation modal
confirmConnectionModal :: forall m. Modal.InputType ConfirmConnectionAction m
confirmConnectionModal =
{ id: "confirm-connection"
, title: "Confirm connection"
, content: HH.text "Connecting those nodes would change the type of this function. Do you want to unconnect all other nodes from it to prevent type errors?"
, buttons:
[ { text: "Connect nodes"
, primary: true
, value: ConfirmConnection
}
, { text: "Cancel connection"
, primary: false
, value: CancelConnection
}
]
, onClose: CancelConnection
}

component :: forall m q. MonadAff m => MonadEffect m => MonadReader Config m => Navigate m => Component HH.HTML q (EditorState m) Output m
component =
mkComponent
Expand Down Expand Up @@ -142,7 +170,8 @@ component =
-- TODO: readd this with the new foreign system
-- | KE.key event == "Delete" || (KE.ctrlKey event && KE.key event == "Backspace") -> do
-- modify_ deleteSelection
| KE.ctrlKey event && KE.key event == "b" -> handleAction TogglePanel
| KE.ctrlKey event && KE.key event == "b" -> do
handleAction TogglePanel
| KE.ctrlKey event && KE.key event == "i" -> handleAction $ CreateNode $ FunctionName "input"
| KE.key event == "s" -> do
let
Expand Down Expand Up @@ -289,6 +318,11 @@ component =
Native.SelectInput id index -> Just $ SelectInput id index
_ -> Nothing

handleConnectionConfirmation :: ConfirmConnectionAction -> Maybe Action
handleConnectionConfirmation CancelConnection = Nothing

handleConnectionConfirmation ConfirmConnection = Nothing

sidebarIcon activeTab current =
HH.div
[ classes $ ClassName <$> [ "sidebar-icon" ] <> (guard isActive $> "active")
Expand Down Expand Up @@ -414,4 +448,7 @@ component =
, container "scene"
[ scene
]
, HH.slot (SProxy :: SProxy "confirmConnection") unit Modal.component
confirmConnectionModal
(handleConnectionConfirmation <<< unwrap)
]
22 changes: 22 additions & 0 deletions src/Component/Foreign/Modal.js
Original file line number Diff line number Diff line change
@@ -0,0 +1,22 @@
"use strict"

const micromodal = require("micromodal")

// Reexporting those for use from withing purescript
exports.showModal = (name) => () =>
new Promise((resolve) => {
let resolved = false

micromodal.show(name, {
onClose: (element) => {
if (resolved) return

resolved = true

resolve(element)
},
awaitCloseAnimation: true
})
})

exports.closeModal = (name) => () => micromodal.close(name)
174 changes: 174 additions & 0 deletions src/Component/Foreign/Modal.purs
Original file line number Diff line number Diff line change
@@ -0,0 +1,174 @@
module Lunarbox.Component.Modal
( Query(..)
, Action(..)
, Output(..)
, Input
, ButtonConfig
, InputType
, component
) where

import Prelude
import Control.Monad.State (gets, modify_)
import Control.MonadZero (guard)
import Control.Promise (Promise, toAff)
import Data.Lens (Lens')
import Data.Lens.Record (prop)
import Data.Maybe (Maybe(..))
import Data.Newtype (class Newtype)
import Data.Symbol (SProxy(..))
import Effect (Effect)
import Effect.Aff.Class (class MonadAff, liftAff)
import Effect.Class (class MonadEffect, liftEffect)
import Halogen (AttrName(..), ClassName(..), Component, ComponentSlot, HalogenM, defaultEval, fork, mkComponent, mkEval, raise)
import Halogen.HTML as HH
import Halogen.HTML.Events (onClick)
import Halogen.HTML.Properties as HP
import Halogen.HTML.Properties.ARIA as AP
import Lunarbox.Component.Utils (className)
import Lunarbox.Control.Monad.Effect (printString)
import Record as Record
import Web.HTML (HTMLElement)

foreign import showModal :: String -> Effect (Promise HTMLElement)

foreign import closeModal :: String -> Effect Unit

data Action v
= CloseModal v

data Query a
= Close a
| Open a
| IsOpen (Boolean -> a)

type ButtonConfig v
= { text :: String
-- TODO: make this more generic once I make a separate button component or something
, primary :: Boolean
, value :: v
}

type Input h a v r
= ( id :: String
, title :: String
, content :: HH.HTML h a
, buttons :: Array (ButtonConfig v)
, onClose :: v
| r
)

type State h a v
= Input h a v
( open :: Boolean
)

_open :: forall r. Lens' { open :: Boolean | r } Boolean
_open = prop (SProxy :: SProxy "open")

type ChildSlots
= ()

type InputType v m
= {
| Input (ComponentSlot HH.HTML () m (Action v))
(Action v)
v
()
}

newtype Output v
= ClosedWith v

derive instance outputNewtype :: Newtype (Output v) _

component ::
forall m v.
MonadEffect m =>
MonadAff m => Component HH.HTML Query (InputType v m) (Output v) m
component =
mkComponent
{ initialState: Record.merge { open: false }
, render
, eval:
mkEval
$ defaultEval
{ handleAction = handleAction
, handleQuery = handleQuery
}
}
where
handleAction :: Action v -> HalogenM { | State _ _ v } (Action v) ChildSlots (Output v) m Unit
handleAction action = do
id <- gets _.id
case action of
CloseModal value -> do
liftEffect $ closeModal id
modify_ _ { open = false }
raise $ ClosedWith value

handleQuery :: forall a. Query a -> HalogenM { | State _ _ v } (Action v) ChildSlots (Output v) m (Maybe a)
handleQuery = case _ of
Open return -> do
printString "opening the modal"
id <- gets _.id
modify_ _ { open = true }
void
$ fork do
onClose <- gets _.onClose
promise <- liftEffect $ showModal id
void $ liftAff $ toAff promise
modify_ _ { open = false }
raise $ ClosedWith onClose
pure $ Just $ return
Close a -> do
id <- gets _.id
modify_ _ { open = false }
liftEffect $ closeModal id
pure $ Just a
IsOpen return -> Just <$> return <$> gets _.open

render { id, title, content, buttons } =
HH.div
[ HP.id_ id
, AP.hidden "true"
, className "modal micromodal-slide"
]
[ HH.div
[ HP.tabIndex (-1)
, HP.attr (AttrName "data-micromodal-close") "true"
, className "modal__overlay"
]
[ HH.div
[ AP.role "dialog"
, HP.attr (AttrName "aria-modal") "true"
, AP.labelledBy titleId
, className "modal__container"
]
[ HH.header [ className "modal__header" ]
[ HH.h2 [ HP.id_ titleId, className "modal__title" ]
[ HH.text title
]
]
, HH.main [ HP.id_ contentId, className "modal__content" ]
[ content
]
, HH.footer [ className "modal__footer" ]
$ ( \{ text, primary, value } ->
HH.button
[ HP.classes
$ ClassName
<$> ("modal__btn-primary" <$ guard primary)
<> [ "modal__btn" ]
, onClick $ const $ Just $ CloseModal value
]
[ HH.text text ]
)
<$> buttons
]
]
]
where
titleId = id <> "-title"

contentId = id <> "-content"
6 changes: 0 additions & 6 deletions src/Data/Editor/Foreign/NodeBoundingBox.purs

This file was deleted.

2 changes: 0 additions & 2 deletions src/Data/Editor/Foreign/NodeBoundingBox.ts

This file was deleted.

70 changes: 26 additions & 44 deletions src/Data/Editor/State.purs
Original file line number Diff line number Diff line change
Expand Up @@ -39,9 +39,10 @@ import Lunarbox.Data.Dataflow.Expression (Expression)
import Lunarbox.Data.Dataflow.Runtime (RuntimeValue)
import Lunarbox.Data.Dataflow.Runtime.ValueMap (ValueMap(..))
import Lunarbox.Data.Dataflow.Type (Type, inputs)
import Lunarbox.Data.Dataflow.TypeError (TypeError)
import Lunarbox.Data.Editor.DataflowFunction (DataflowFunction(..), _VisualFunction)
import Lunarbox.Data.Editor.ExtendedLocation (ExtendedLocation(..), _ExtendedLocation, nothing)
import Lunarbox.Data.Editor.FunctionData (FunctionData, _FunctionDataInputs, internal)
import Lunarbox.Data.Editor.FunctionData (FunctionData, _FunctionDataInputs)
import Lunarbox.Data.Editor.FunctionName (FunctionName(..))
import Lunarbox.Data.Editor.FunctionUi (FunctionUi)
import Lunarbox.Data.Editor.Location (Location)
Expand Down Expand Up @@ -261,51 +262,32 @@ generateUnconnectableOutputs input state = Set.filter (\outputId -> not $ canCon
Just id -> Set.difference keys $ Set.singleton id
Nothing -> keys

-- Generate the next expression / typeMap of a project
tryCompiling :: forall a s m. State a s m -> { expression :: Expression Location, typeMap :: Either (TypeError Location) (Map Location Type) }
tryCompiling state@{ project, expression, typeMap, valueMap } = { expression: expression', typeMap: typeMap' }
where
expression' = compileProject project

typeMap' =
-- we only run the type inference algorithm if the expression changed
if (expression == expression') then
pure typeMap
else
Map.delete Nowhere <$> solveExpression expression'

-- Compile a project
compile :: forall a s m. State a s m -> State a s m
compile state@{ project, expression, typeMap, valueMap } =
let
expression' = compileProject project

typeMap' =
-- we only run the type inference algorithm if the expression changed
if (expression == expression') then
typeMap
else case solveExpression expression' of
Right map -> Map.delete Nowhere map
-- WARNING: in case of errors we just return an empty typemap
-- This is not a good idea since in theory this "could" break
-- even tho in practice we never get to this point...
-- It would still be useful to do something with the error message
-- for debugging or stuff like that
Left _ -> mempty

visualFunctions :: List FunctionName
visualFunctions =
Set.toUnfoldable
$ Map.keys
$ Map.filter (is _VisualFunction)
$ view _functions state

state' =
foldr
( \functionName state'' ->
fromMaybe state'' do
functionType <- Map.lookup (Location functionName) typeMap
let
inputDocs =
List.toUnfoldable
$ List.mapWithIndex (\index -> const { name: "Input " <> show index, description: "An input for a custom function" })
$ inputs functionType

functionData = internal inputDocs { name: show functionName <> " output", description: "The output of a custom function" }
pure $ set (_atFunctionData functionName) (Just functionData) state''
)
state
visualFunctions
in
evaluate
$ state' { expression = expression', typeMap = typeMap' }
compile state =
evaluate
$ state
{ expression = expression
, typeMap =
case typeMap of
Left _ -> mempty
Right m -> m
}
where
{ expression, typeMap } = 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
Expand Down
Loading

0 comments on commit 0420b04

Please sign in to comment.