Merge pull request #384 from statebox/383/kdmoncat-help

kdmoncat: Add help #383

Author: epost

halogen-grid-kit/src/View/ReactiveInput.purs

@@ -31,7 +31,7 @@ type ComponentSpec surface state action slots input output m =
 
 type ComponentSpecQuery surface state query action slots input output m =
   Record (ComponentSpecRow surface state action slots input output m
-         (handleQuery :: forall a. query a -> H.HalogenM state action slots output m (Maybe a)))
+         (handleQuery :: forall a. input -> query a -> H.HalogenM state action slots output m (Maybe a)))
 
 mkComponentWithQuery
   :: ∀ surface state query action slots input output m
@@ -45,7 +45,7 @@ mkComponentWithQuery spec@{ initialState, render } =
     , render: \{ input, rest } -> render input rest # mapAction Rest
     , eval: H.mkEval $ H.defaultEval
       { handleAction = handle spec
-      , handleQuery = \q -> H.get >>= \{ input } -> mapHalogenM input (spec.handleQuery q)
+      , handleQuery = \q -> H.get >>= \{ input } -> mapHalogenM input (spec.handleQuery input q)
       , receive = Just <<< Update
       , initialize = Just Initialize
       }
@@ -58,7 +58,7 @@ mkComponent
   => ComponentSpec surface state action slots input output m
   -> H.Component surface query input output m
 mkComponent { initialState, render, handleInput, handleAction } =
-  mkComponentWithQuery { initialState, render, handleInput, handleAction, handleQuery: H.defaultEval.handleQuery }
+  mkComponentWithQuery { initialState, render, handleInput, handleAction, handleQuery: \_ -> H.defaultEval.handleQuery }
 
 handle
   :: ∀ surface state query action slots input output m

halogen-kdmoncat/spago.dhall

@@ -14,6 +14,7 @@
     , "ordered-collections"
     , "profunctor-lenses"
     , "psci-support"
+    , "random"
     , "strings"
     , "variant"
     , "vec"

halogen-kdmoncat/src/View/KDMonCat/App.purs

@@ -12,16 +12,21 @@ import Data.Maybe (Maybe(..), maybe)
 import Data.Set as Set
 import Data.String (replaceAll, Pattern(..), Replacement(..))
 import Data.Symbol (SProxy(..))
+import Data.Tuple.Nested ((/\))
 import Effect.Class (class MonadEffect, liftEffect)
 import Global (encodeURIComponent)
 import Halogen as H
-import Halogen.HTML hiding (map, head, i, prop)
-import Halogen.HTML.Properties (classes, value, readOnly, href, type_, InputType(InputText))
-import Halogen.HTML.Events (onValueInput, onClick)
+import Halogen.HTML hiding (map, head, i, prop, title)
+import Halogen.HTML.Properties (classes, value, readOnly, href, type_, InputType(InputText), ref, title)
+import Halogen.HTML.Events (onValueInput, onClick, onMouseDown)
+import Halogen.Query.Input (RefLabel(..))
 import View.ReactiveInput as ReactiveInput
 import Web.HTML (window)
 import Web.HTML.Location (setHash)
 import Web.HTML.Window (location)
+import Web.Event.Event (Event)
+import Web.Event.Event as Event
+import Web.UIEvent.MouseEvent (toEvent)
 
 import KDMonCat.Bricks as Bricks
 import KDMonCat.InferType
@@ -33,7 +38,7 @@ import KDMonCat.Output.JSON (json)
 
 import View.KDMonCat.Bricks as Bricks
 import View.KDMonCat.Term as Term
-import View.KDMonCat.CopyToClipboard (copyToClipboard)
+import View.KDMonCat.EditDomHelpers (copyToClipboard, insertText)
 
 type Input = String.Input
 type Output = String.Input
@@ -63,6 +68,8 @@ data Action
   | UpdateContext String
   | BricksMessage Bricks.Output
   | CopyToClipboard String
+  | InsertPixel String
+  | PreventDefault Action Event
 
 data Query a
   = DoAction Action a
@@ -81,7 +88,7 @@ appView =
   ReactiveInput.mkComponentWithQuery
     { initialState
     , render
-    , handleAction: \_ -> handleAction
+    , handleAction
     , handleQuery
     , handleInput
     }
@@ -99,9 +106,11 @@ render _ st = div [ classes [ ClassName "kdmoncat-app" ] ]
         [ label_ [ text "Whole" ], input [ type_ InputText, value termTypeStr, readOnly true ] ]
         <> (selectionType # maybe [] \s -> [ label_ [ text "Selection" ], input [ type_ InputText, value s, readOnly true ] ])
       , h2_ [ text "Pixels"]
-      , textarea [ value st.input.pixels, onValueInput (Just <<< UpdatePixels) ]
+      , textarea [ value st.input.pixels, onValueInput (Just <<< UpdatePixels), ref (RefLabel "pixels") ]
+      , div_ pixelButtons
       , h2_ [ text "Context"]
-      , textarea [ value st.input.context, onValueInput (Just <<< UpdateContext) ]
+      , textarea [ value st.input.context, onValueInput (Just <<< UpdateContext), ref (RefLabel "context") ]
+      , div_ [ text "F.e.: ", code_ [ text "a b -> c d, [4 2 3 1] (Wire swaps), 3.5, 4o2 (Spiders)" ] ]
       , h2_ [ text "Copy serialized output to clipboard"]
       , div_ $ inferredType # either (const []) (\{ term } ->
           [ button [ onClick \_ -> Just (CopyToClipboard $ json term) ]
@@ -127,6 +136,22 @@ render _ st = div [ classes [ ClassName "kdmoncat-app" ] ]
     selectionPath = Bricks.toSelection st.selectionBox bricksInput.bricks.term Nil
     selectionType = hush inferredType <#> \{ errors, term } -> showInferred { errors, term: getSubTerm selectionPath term }
 
+    predefined =
+      [ "-" /\ "id, type [1]"
+      , "=" /\ "id ⊗ id, type [1 2]"
+      , "σ" /\ "Swap, type [2 1]"
+      , "ε" /\ "Counit (discard), type 1.0"
+      , "δ" /\ "Comultiply (copy), type 1.2"
+      , "η" /\ "Unit (zero), type 1o0"
+      , "μ" /\ "Multiply (sum), type 1o2"
+      , "(" /\ "Cup"
+      , ")" /\ "Cap"
+      ]
+    pixelButtons = predefined <#> \(pixel /\ help) ->
+      button [ onMouseDown $ Just <<< PreventDefault (InsertPixel pixel) <<< toEvent
+             , title help ]
+             [ text pixel ]
+
 toBricksInput :: Input -> Box -> Bricks.Input
 toBricksInput input selectionBox =
   { bricks, matches, context, selectedBoxes, renderBoxContent: Bricks.defaultRenderBoxContent }
@@ -148,8 +173,8 @@ handleInput input = do
   H.put $ initialState { input = input }
   updateWindowLocation input
 
-handleAction :: ∀ m. MonadEffect m => Action -> H.HalogenM State Action ChildSlots Output m Unit
-handleAction = case _ of
+handleAction :: ∀ m. MonadEffect m => Input -> Action -> H.HalogenM State Action ChildSlots Output m Unit
+handleAction inp = case _ of
   UpdatePixels p -> do
     st <- H.modify $ set (_input <<< _pixels) p
     H.raise st.input
@@ -162,10 +187,15 @@ handleAction = case _ of
     H.modify_ $ set _selectionBox sel
   CopyToClipboard s ->
     liftEffect (copyToClipboard s)
-
-handleQuery :: ∀ m a. MonadEffect m => Query a -> H.HalogenM State Action ChildSlots Output m (Maybe a)
-handleQuery (DoAction x next) = do
-  handleAction x
+  InsertPixel s ->
+    liftEffect (insertText s)
+  PreventDefault action event -> do
+    H.liftEffect $ Event.preventDefault event
+    handleAction inp action
+
+handleQuery :: ∀ m a. MonadEffect m => Input -> Query a -> H.HalogenM State Action ChildSlots Output m (Maybe a)
+handleQuery inp (DoAction x next) = do
+  handleAction inp x
   pure (Just next)
 
 updateWindowLocation :: ∀ m. MonadEffect m => Input -> H.HalogenM State Action ChildSlots Output m Unit

…cat/src/View/KDMonCat/CopyToClipboard.js …ncat/src/View/KDMonCat/EditDomHelpers.jshalogen-kdmoncat/src/View/KDMonCat/CopyToClipboard.js renamed to halogen-kdmoncat/src/View/KDMonCat/EditDomHelpers.js halogen-kdmoncat/src/View/KDMonCat/CopyToClipboard.js renamed to halogen-kdmoncat/src/View/KDMonCat/EditDomHelpers.js

@@ -9,3 +9,7 @@ exports.copyToClipboard = function (text) {
   document.execCommand('copy');
   document.body.removeChild(textArea);
 }
+
+exports.insertText = function (text) {
+  document.execCommand("insertText", false, text);
+}

…t/src/View/KDMonCat/CopyToClipboard.purs …at/src/View/KDMonCat/EditDomHelpers.purshalogen-kdmoncat/src/View/KDMonCat/CopyToClipboard.purs renamed to halogen-kdmoncat/src/View/KDMonCat/EditDomHelpers.purs halogen-kdmoncat/src/View/KDMonCat/CopyToClipboard.purs renamed to halogen-kdmoncat/src/View/KDMonCat/EditDomHelpers.purs

@@ -1,6 +1,7 @@
-module View.KDMonCat.CopyToClipboard where
+module View.KDMonCat.EditDomHelpers where
 
 import Prelude
 import Effect (Effect)
 
 foreign import copyToClipboard :: String -> Effect Unit
+foreign import insertText :: String -> Effect Unit