fix: Time starts from zero

fix: Time starts from zero

module Main (main,run) where

import Debug.Trace

import Control.Bind
import Control.Timer (timeout,clearTimeout)
import Control.Monad.Eff
import Control.Monad.Eff.Ref
import Data.Date
import Data.Time
import Data.Foldable (for_, foldl)

import Ace
import Ace.Types
import qualified Ace.Editor as Editor
import qualified Ace.EditSession as Session
import qualified Ace.Range as Range

import qualified Graphics.WebGL as GL
import qualified Control.Monad.JQuery as J

import WebSocket
import DefaultText
import Data.Either
import Sample

import Data.Function
import Data.Maybe
import Data.StrMap
import Data.Tuple
import Data.Array(filter,head)

import Backend
import IR
import Mesh
import Type
import Input

import MeshJsonDecode
import PipelineJsonDecode
import qualified Data.Argonaut as A
import qualified Data.Argonaut.Core as AC

import Data.Matrix (Mat(..))
import Data.Matrix4
import Data.Vector3

import qualified DOM as DOM

main = return unit

foreign import getJSON """
  function getJSON(uri) {
    return function(act) {
      return function() {
        $.getJSON(uri, function(data) {
          act(data)();
        });
      };
    };
  }
""" :: forall eff a. String -> (AC.Json -> Eff (dom :: DOM.DOM | eff) a) -> Eff (dom :: DOM.DOM | eff) Unit

{-
  control-b - compile/build
  control-n - new
-}
foreign import addCommand """
  function addCommand(editor) {
    return function(cmdName) {
      return function(winKey) {
        return function(macKey) {
          return function(cmd) {
            return function() {
              editor.commands.addCommand({
                name: cmdName,
                bindKey: {win: winKey,  mac: macKey},
                exec: function(editor) {
                  cmd(editor)();
                }
              });
            };
          };
        };
      };
    };
  }
""" :: forall eff . Editor -> String -> String -> String -> (Editor -> Eff (ace :: EAce | eff) Unit) -> Eff (ace :: EAce | eff) Unit

foreign import tokenTooltip """
  function tokenTooltip(editor) {
    return function(getTy) {
      return function() {
          editor.tokenTooltip = new myTokenTooltip(editor,getTy);
      };
    };
  }
""" :: forall eff . Editor -> (Int -> Int -> Eff (ace :: EAce | eff) TypeInfoRecord) -> Eff (ace :: EAce | eff) Unit

foreign import add
  """
  function add(ob1) {
    return function(ob) {
      return function () {
        return ob.add(ob1);
      };
    };
  }
  """ :: forall eff. J.JQuery -> J.JQuery -> Eff (dom :: DOM.DOM | eff) J.JQuery

foreign import addMarkerImpl
  "function addMarkerImpl(range, clazz, type, inFront, self) {\
  \  return function() {\
  \    return self.addMarker(range, clazz, type, inFront);\
  \  };\
  \}" :: forall eff. Fn5 Range String String Boolean EditSession (Eff (ace :: EAce | eff) Int)

addMarker :: forall eff. Range -> String -> String -> Boolean -> EditSession -> Eff (ace :: EAce | eff) Int
addMarker range clazz _type inFront self = runFn5 addMarkerImpl range clazz _type inFront self

run = GL.runWebGL "glcanvas" (\s -> trace s) $ \context -> do
  Milliseconds baseTime <- nowEpochMilliseconds
  -- setup pipeline input
  let inputSchema =
        { slots : fromList [ Tuple "stream"  {primitive: Triangles, attributes: fromList [Tuple "position"  TV3F, Tuple "normal" TV3F]}
                           , Tuple "stream4" {primitive: Triangles, attributes: fromList [Tuple "position4" TV4F]}
                           , Tuple "line"    {primitive: Triangles, attributes: fromList [Tuple "position" TV3F]}
                           , Tuple "grid"    {primitive: Triangles, attributes: fromList [Tuple "position" TV3F]}
                           , Tuple "quad"    {primitive: Triangles, attributes: fromList [Tuple "position" TV4F]}
                           , Tuple "grid3d"  {primitive: Points,    attributes: fromList [Tuple "position" TV3F]}
                           ]
        , uniforms : fromList [Tuple "MVP" M44F, Tuple "MVP2" M44F, Tuple "Time" Float]
        }
  pplInput <- mkWebGLPipelineInput inputSchema
  let toLCMat4 :: Mat4 -> M44F
      toLCMat4 (Mat [x11, x21, x31, x41, x12, x22, x32, x42, x13, x23, x33, x43, x14, x24, x34, x44]) = let
          v1 = V4 x11 x21 x31 x41
          v2 = V4 x12 x22 x32 x42
          v3 = V4 x13 x23 x33 x43
          v4 = V4 x14 x24 x34 x44
        in V4 v1 v2 v3 v4

      updateInput t = do
        w <- GL.getCanvasWidth context
        h <- GL.getCanvasHeight context
        let pi = 3.141592653589793
            angle = pi / 24 * t
            cm = makeLookAt (vec3 3 1.3 0.3) (vec3 0 0 0) (vec3 0 1 0)
            mm = makeRotate angle (vec3 0 1 0)
            pm = makePerspective 45 (w/h) 0.1 100
            mvp = pm `mul` cm `mul` mm
            cm' = makeLookAt (vec3 4 0.5 (-0.6)) (vec3 0 0 0) (vec3 0 1 0)
            mvp2 = pm `mul` cm' `mul` mm

        uniformFloat "Time" pplInput.uniformSetter t
        uniformM44F "MVP" pplInput.uniformSetter $ toLCMat4 mvp
        uniformM44F "MVP2" pplInput.uniformSetter $ toLCMat4 mvp2

  gpuCube <- compileMesh myCube
  addMesh pplInput "stream4" gpuCube []

  let addRemoteModel sname uri = getJSON uri $ \m -> do
        case A.decodeJson m of
          Left e -> trace $ "decode error: " ++ e
          Right (MeshData mesh) -> do
            gpuMesh <- compileMesh mesh
            addMesh pplInput sname gpuMesh []
            sortSlotObjects pplInput
            return unit

  --addRemoteModel "grid3d" "http://rawgit.com/lambdacube3d/lambdacube-editor/master/mesh/grid3d.mesh.json"
  --addRemoteModel "stream" "http://rawgit.com/lambdacube3d/lambdacube-editor/master/mesh/logo2.mesh.json"
  --addRemoteModel "stream" "http://rawgit.com/lambdacube3d/lambdacube-editor/master/mesh/logo3.mesh.json"
  addRemoteModel "quad"   "http://rawgit.com/lambdacube3d/lambdacube-editor/master/mesh/quad.mesh.json"
  addRemoteModel "grid"   "http://rawgit.com/lambdacube3d/lambdacube-editor/master/mesh/grid.mesh.json"
  addRemoteModel "line"   "http://rawgit.com/lambdacube3d/lambdacube-editor/master/mesh/line.mesh.json"
  addRemoteModel "stream" "http://rawgit.com/lambdacube3d/lambdacube-editor/master/mesh/ico.mesh.json"

  -- setup ace editor
  editor <- Ace.edit "editor" ace
  session <- Editor.getSession editor
  Editor.setTheme "ace/theme/terminal" editor
  Session.setMode "ace/mode/haskell" session
  Session.setValue defaultSrc session
  typeInfoRef <- newRef []
  markerRef <- newRef []
  let lessEqPos l c l' c' = l < l' || l == l' && c <= c'
  let lessPos l c l' c' = l < l' || l == l' && c < c'
  let getTypeInfo l c = do
        x <- readRef typeInfoRef
        let ps = flip filter x $ \(TypeInfo i) -> lessEqPos i.startLine i.startColumn l c && lessPos l c i.endLine i.endColumn
        let f Nothing (TypeInfo i) = Just i
            f (Just d) (TypeInfo i)
                | lessPos d.startLine d.startColumn i.startLine i.startColumn = Just i
                | otherwise = Just d
        return $ case foldl f Nothing ps of
          Nothing ->
              { startLine   : 0
              , startColumn : 0
              , endLine     : 0
              , endColumn   : 0
              , text        : ""
              }
          Just a -> a
  tokenTooltip editor getTypeInfo

  b <- J.body
  messagepanel <- J.find "#messagepanel" b
  statuspanel <- J.find "#statuspanel" b
  btnCompile <- J.find "#compilebutton" b
  exerciseselect <- J.find "#exerciseselect" b

  pipelineRef <- newRef Nothing
  let compile s = do
        trace "compile"
        J.setText "Compiling..." statuspanel
        src <- Session.getValue session
        send s src

      render ir = do
        old <- readRef pipelineRef
        writeRef pipelineRef Nothing
        case old of
          Nothing -> return unit
          Just p -> do
            trace "dispose old pipeline"
            disposePipeline p
        trace "allocate new pipeline"
        ppl <- allocPipeline ir -- gfx03Pipeline -- samplePipeline
        trace "attach pipeline input"
        setPipelineInput ppl (Just pplInput)
        trace "generate object commands"
        sortSlotObjects pplInput
        writeRef pipelineRef $ Just ppl

  socket1 <- webSocket "ws://localhost:8000/exerciselist" $
    { onOpen    : \s -> do
        send s "query"
        trace "socket1 is ready"
        return unit
    , onMessage : \s m -> case A.jsonParser m >>= A.decodeJson of
          Left e -> trace $ "decode error: " ++ e
          Right es -> do
            for_ (es :: [String]) $ \e -> do
                op <- J.create "<option></option>"
                J.setText e op
                J.append op exerciseselect
            return unit
    , onError   : \s m -> trace m
    , onClose   : trace "socket1 is closed"
    }

  socket <- webSocket "ws://localhost:8000/compile" $
    { onOpen    : \s -> do
        trace "socket is ready"
        compile s
        timerRef <- newRef Nothing
        Session.onChange session $ do
          t <- readRef timerRef
          case t of
            Nothing -> return unit
            Just a -> clearTimeout a
          writeRef timerRef =<< Just <$> timeout 1000 (compile s)

    , onClose   : trace "socket is closed"
    , onMessage : \s m -> do
        trace "got response"
        case A.jsonParser m >>= A.decodeJson of
          Left e -> trace $ "decode error: " ++ e
          Right (MyLeft (TypeInfo e) infos) -> do
            J.setText "Error" statuspanel
            J.setText e.text messagepanel
            range <- Range.create (e.startLine - 1) (e.startColumn - 1) (e.endLine - 1) (e.endColumn - 1)
            rs <- readRef markerRef
            for_ rs $ \mkr -> Session.removeMarker mkr session
            mkr <- addMarker range "lc_error" "text" false session
            writeRef markerRef [mkr]
            writeRef typeInfoRef infos
            return unit
          Right (MyRight p infos) -> do
            J.setText "Compiled" statuspanel
            J.setText "No errors." messagepanel
            writeRef typeInfoRef infos
            rs <- readRef markerRef
            for_ rs $ \mkr -> Session.removeMarker mkr session
            writeRef markerRef []
            render p
    , onError   : \s m -> trace $ "error: " ++ m
    }
  case socket of
    Left m -> trace $ "error: " ++ m
    Right ws -> do

      socket2 <- webSocket "ws://localhost:8000/getexercise" $
        { onOpen    : \s -> do
            trace "socket2 is ready"
            flip (J.on "change") exerciseselect $ \_ _ -> do
                sel <- J.find ":selected" exerciseselect
                txt <- J.getText sel
                send s txt
            return unit
        , onMessage : \s m -> case A.jsonParser m >>= A.decodeJson of
              Left e -> trace $ "decode error: " ++ e
              Right src -> do
                Session.setValue src session
                compile ws
                return unit
        , onError   : \s m -> trace m
        , onClose   : trace "socket2 is closed"
        }

      flip (J.on "click") btnCompile $ \_ _ -> do
        compile ws
        trace "clicked compile"
      addCommand editor "Compile" "Ctrl-B" "Command-B" (\_ -> compile ws)
      let renderLoop = do
            Milliseconds t <- nowEpochMilliseconds
            updateInput ((t - baseTime) / 1000)
            mppl <- readRef pipelineRef
            case mppl of
              Nothing -> return unit
              Just ppl -> renderPipeline ppl
            timeout (1000/25) renderLoop
      -- render loop
      renderLoop
      return unit

module Main (main,run) where

import Debug.Trace

import Control.Monad.Aff
import Control.Bind
import Control.Timer (timeout,clearTimeout)
import Control.Monad.Eff
import Control.Monad.Eff.Ref
import Data.Date
import Data.Time
import Data.Foldable (for_, foldl)

import Ace
import Ace.Types
import qualified Ace.Editor as Editor
import qualified Ace.EditSession as Session
import qualified Ace.Range as Range

import qualified Graphics.WebGL as GL
import qualified Control.Monad.JQuery as J

import WebSocket
import DefaultText
import Data.Either
import Sample

import Data.Function
import Data.Maybe
import Data.StrMap
import Data.Tuple
import Data.Array(filter,head)

import Backend
import IR
import Mesh
import Type
import Input

import MeshJsonDecode
import PipelineJsonDecode
import qualified Data.Argonaut as A
import qualified Data.Argonaut.Core as AC

import Data.Matrix (Mat(..))
import Data.Matrix4
import Data.Vector3

import qualified DOM as DOM

main = return unit

foreign import getJSON """
  function getJSON(uri) {
    return function(act) {
      return function() {
        $.getJSON(uri, function(data) {
          act(data)();
        });
      };
    };
  }
""" :: forall eff a. String -> (AC.Json -> Eff (dom :: DOM.DOM | eff) a) -> Eff (dom :: DOM.DOM | eff) Unit

{-
  control-b - compile/build
  control-n - new
-}
foreign import addCommand """
  function addCommand(editor) {
    return function(cmdName) {
      return function(winKey) {
        return function(macKey) {
          return function(cmd) {
            return function() {
              editor.commands.addCommand({
                name: cmdName,
                bindKey: {win: winKey,  mac: macKey},
                exec: function(editor) {
                  cmd(editor)();
                }
              });
            };
          };
        };
      };
    };
  }
""" :: forall eff . Editor -> String -> String -> String -> (Editor -> Eff (ace :: EAce | eff) Unit) -> Eff (ace :: EAce | eff) Unit

foreign import tokenTooltip """
  function tokenTooltip(editor) {
    return function(getTy) {
      return function() {
          editor.tokenTooltip = new myTokenTooltip(editor,getTy);
      };
    };
  }
""" :: forall eff . Editor -> (Int -> Int -> Eff (ace :: EAce | eff) TypeInfoRecord) -> Eff (ace :: EAce | eff) Unit

foreign import add
  """
  function add(ob1) {
    return function(ob) {
      return function () {
        return ob.add(ob1);
      };
    };
  }
  """ :: forall eff. J.JQuery -> J.JQuery -> Eff (dom :: DOM.DOM | eff) J.JQuery

foreign import addMarkerImpl
  "function addMarkerImpl(range, clazz, type, inFront, self) {\
  \  return function() {\
  \    return self.addMarker(range, clazz, type, inFront);\
  \  };\
  \}" :: forall eff. Fn5 Range String String Boolean EditSession (Eff (ace :: EAce | eff) Int)

addMarker :: forall eff. Range -> String -> String -> Boolean -> EditSession -> Eff (ace :: EAce | eff) Int
addMarker range clazz _type inFront self = runFn5 addMarkerImpl range clazz _type inFront self

run = GL.runWebGL "glcanvas" (\s -> trace s) $ \context -> do
  -- setup pipeline input
  let inputSchema =
        { slots : fromList [ Tuple "stream"  {primitive: Triangles, attributes: fromList [Tuple "position"  TV3F, Tuple "normal" TV3F]}
                           , Tuple "stream4" {primitive: Triangles, attributes: fromList [Tuple "position4" TV4F]}
                           , Tuple "line"    {primitive: Triangles, attributes: fromList [Tuple "position" TV3F]}
                           , Tuple "grid"    {primitive: Triangles, attributes: fromList [Tuple "position" TV3F]}
                           , Tuple "quad"    {primitive: Triangles, attributes: fromList [Tuple "position" TV4F]}
                           , Tuple "grid3d"  {primitive: Points,    attributes: fromList [Tuple "position" TV3F]}
                           ]
        , uniforms : fromList [Tuple "MVP" M44F, Tuple "MVP2" M44F, Tuple "Time" Float]
        }
  pplInput <- mkWebGLPipelineInput inputSchema
  let toLCMat4 :: Mat4 -> M44F
      toLCMat4 (Mat [x11, x21, x31, x41, x12, x22, x32, x42, x13, x23, x33, x43, x14, x24, x34, x44]) = let
          v1 = V4 x11 x21 x31 x41
          v2 = V4 x12 x22 x32 x42
          v3 = V4 x13 x23 x33 x43
          v4 = V4 x14 x24 x34 x44
        in V4 v1 v2 v3 v4

      updateInput t = do
        w <- GL.getCanvasWidth context
        h <- GL.getCanvasHeight context
        let pi = 3.141592653589793
            angle = pi / 24 * t
            cm = makeLookAt (vec3 3 1.3 0.3) (vec3 0 0 0) (vec3 0 1 0)
            mm = makeRotate angle (vec3 0 1 0)
            pm = makePerspective 45 (w/h) 0.1 100
            mvp = pm `mul` cm `mul` mm
            cm' = makeLookAt (vec3 4 0.5 (-0.6)) (vec3 0 0 0) (vec3 0 1 0)
            mvp2 = pm `mul` cm' `mul` mm

        uniformFloat "Time" pplInput.uniformSetter t
        uniformM44F "MVP" pplInput.uniformSetter $ toLCMat4 mvp
        uniformM44F "MVP2" pplInput.uniformSetter $ toLCMat4 mvp2

  gpuCube <- compileMesh myCube
  addMesh pplInput "stream4" gpuCube []

  let addRemoteModel sname uri = getJSON uri $ \m -> do
        case A.decodeJson m of
          Left e -> trace $ "decode error: " ++ e
          Right (MeshData mesh) -> do
            gpuMesh <- compileMesh mesh
            addMesh pplInput sname gpuMesh []
            sortSlotObjects pplInput
            return unit

  --addRemoteModel "grid3d" "http://rawgit.com/lambdacube3d/lambdacube-editor/master/mesh/grid3d.mesh.json"
  --addRemoteModel "stream" "http://rawgit.com/lambdacube3d/lambdacube-editor/master/mesh/logo2.mesh.json"
  --addRemoteModel "stream" "http://rawgit.com/lambdacube3d/lambdacube-editor/master/mesh/logo3.mesh.json"
  addRemoteModel "quad"   "http://rawgit.com/lambdacube3d/lambdacube-editor/master/mesh/quad.mesh.json"
  addRemoteModel "grid"   "http://rawgit.com/lambdacube3d/lambdacube-editor/master/mesh/grid.mesh.json"
  addRemoteModel "line"   "http://rawgit.com/lambdacube3d/lambdacube-editor/master/mesh/line.mesh.json"
  addRemoteModel "stream" "http://rawgit.com/lambdacube3d/lambdacube-editor/master/mesh/ico.mesh.json"

  -- setup ace editor
  editor <- Ace.edit "editor" ace
  session <- Editor.getSession editor
  Editor.setTheme "ace/theme/terminal" editor
  Session.setMode "ace/mode/haskell" session
  Session.setValue defaultSrc session
  typeInfoRef <- newRef []
  markerRef <- newRef []
  let lessEqPos l c l' c' = l < l' || l == l' && c <= c'
  let lessPos l c l' c' = l < l' || l == l' && c < c'
  let getTypeInfo l c = do
        x <- readRef typeInfoRef
        let ps = flip filter x $ \(TypeInfo i) -> lessEqPos i.startLine i.startColumn l c && lessPos l c i.endLine i.endColumn
        let f Nothing (TypeInfo i) = Just i
            f (Just d) (TypeInfo i)
                | lessPos d.startLine d.startColumn i.startLine i.startColumn = Just i
                | otherwise = Just d
        return $ case foldl f Nothing ps of
          Nothing ->
              { startLine   : 0
              , startColumn : 0
              , endLine     : 0
              , endColumn   : 0
              , text        : ""
              }
          Just a -> a
  tokenTooltip editor getTypeInfo

  b <- J.body
  messagepanel <- J.find "#messagepanel" b
  statuspanel <- J.find "#statuspanel" b
  btnCompile <- J.find "#compilebutton" b
  exerciseselect <- J.find "#exerciseselect" b

  pipelineRef <- newRef Nothing
  let compile s = do
        trace "compile"
        J.setText "Compiling..." statuspanel
        src <- Session.getValue session
        send s src

      render ir = do
        old <- readRef pipelineRef
        writeRef pipelineRef Nothing
        case old of
          Nothing -> return unit
          Just p -> do
            trace "dispose old pipeline"
            disposePipeline p
        trace "allocate new pipeline"
        ppl <- allocPipeline ir -- gfx03Pipeline -- samplePipeline
        trace "attach pipeline input"
        setPipelineInput ppl (Just pplInput)
        trace "generate object commands"
        sortSlotObjects pplInput
        writeRef pipelineRef $ Just ppl

  socket1 <- webSocket "ws://localhost:8000/exerciselist" $
    { onOpen    : \s -> do
        send s "query"
        trace "socket1 is ready"
        return unit
    , onMessage : \s m -> case A.jsonParser m >>= A.decodeJson of
          Left e -> trace $ "decode error: " ++ e
          Right es -> do
            for_ (es :: [String]) $ \e -> do
                op <- J.create "<option></option>"
                J.setText e op
                J.append op exerciseselect
            return unit
    , onError   : \s m -> trace m
    , onClose   : trace "socket1 is closed"
    }

  socket <- webSocket "ws://localhost:8000/compile" $
    { onOpen    : \s -> do
        trace "socket is ready"
        compile s
        timerRef <- newRef Nothing
        Session.onChange session $ do
          t <- readRef timerRef
          case t of
            Nothing -> return unit
            Just a -> clearTimeout a
          writeRef timerRef =<< Just <$> timeout 1000 (compile s)

    , onClose   : trace "socket is closed"
    , onMessage : \s m -> do
        trace "got response"
        case A.jsonParser m >>= A.decodeJson of
          Left e -> trace $ "decode error: " ++ e
          Right (MyLeft (TypeInfo e) infos) -> do
            J.setText "Error" statuspanel
            J.setText e.text messagepanel
            range <- Range.create (e.startLine - 1) (e.startColumn - 1) (e.endLine - 1) (e.endColumn - 1)
            rs <- readRef markerRef
            for_ rs $ \mkr -> Session.removeMarker mkr session
            mkr <- addMarker range "lc_error" "text" false session
            writeRef markerRef [mkr]
            writeRef typeInfoRef infos
            return unit
          Right (MyRight p infos) -> do
            J.setText "Compiled" statuspanel
            J.setText "No errors." messagepanel
            writeRef typeInfoRef infos
            rs <- readRef markerRef
            for_ rs $ \mkr -> Session.removeMarker mkr session
            writeRef markerRef []
            render p
    , onError   : \s m -> trace $ "error: " ++ m
    }
  case socket of
    Left m -> trace $ "error: " ++ m
    Right ws -> do

      socket2 <- webSocket "ws://localhost:8000/getexercise" $
        { onOpen    : \s -> do
            trace "socket2 is ready"
            flip (J.on "change") exerciseselect $ \_ _ -> do
                sel <- J.find ":selected" exerciseselect
                txt <- J.getText sel
                send s txt
            return unit
        , onMessage : \s m -> case A.jsonParser m >>= A.decodeJson of
              Left e -> trace $ "decode error: " ++ e
              Right src -> do
                Session.setValue src session
                compile ws
                return unit
        , onError   : \s m -> trace m
        , onClose   : trace "socket2 is closed"
        }

      flip (J.on "click") btnCompile $ \_ _ -> do
        compile ws
        trace "clicked compile"
      addCommand editor "Compile" "Ctrl-B" "Command-B" (\_ -> compile ws)
      let renderLoop = do
            Milliseconds t <- nowEpochMilliseconds
            updateInput (t / 1000)
            mppl <- readRef pipelineRef
            case mppl of
              Nothing -> return unit
              Just ppl -> renderPipeline ppl
            timeout (1000/25) renderLoop
      -- render loop
      renderLoop
      return unit


Add check all and delete completed

Add check all and delete completed

module Main where

import App.Events (AppEffects)
import Control.Monad.Eff (Eff)
import DOM (DOM)
import Data.Array (filter, snoc)
import Data.Foldable (for_)
import Pux (CoreEffects, App, start, EffModel, noEffects)
import Pux.DOM.Events (DOMEvent, onChange, onClick, targetValue)
import Pux.DOM.HTML (HTML)
import Pux.Renderer.React (renderToDOM)
import Text.Smolder.HTML (a, button, div, input, span)
import Text.Smolder.HTML.Attributes (value)
import Text.Smolder.Markup (text, (!), (#!))
import Prelude hiding (div)

data Visibility = All | Active | Completed
derive instance eqVis :: Eq Visibility

data Event = FieldChanged DOMEvent
           | AddEntry DOMEvent
           | DeleteEntry Int DOMEvent
           | EditEntry Int DOMEvent
           | ChangeEntry Int DOMEvent
           | UpdateEntry Int DOMEvent
           | CancelEditEntry Int DOMEvent
           | ToggleComplete Int DOMEvent
           | ChangeVisibility Visibility DOMEvent
           | CheckAll DOMEvent
           | DeleteCompeleted DOMEvent

newtype Entry = Entry { id :: Int
                      , description :: String
                      , editingDesc :: String
                      , isEditing :: Boolean
                      , isCompleted :: Boolean
                      }

mkEntry :: Int -> String -> Entry
mkEntry id description = Entry { id
                               , description
                               , editingDesc: description
                               , isEditing: false
                               , isCompleted: false
                               }

newtype State = State { nextId :: Int
                      , editingField :: String
                      , entries :: Array Entry
                      , visibility :: Visibility
                      }

init :: String -> State
init url = State { nextId: 0
                 , editingField: ""
                 , entries: []
                 , visibility: All
                 }

updateEntryWithId :: (Entry -> Entry) -> Int -> Array Entry -> Array Entry
updateEntryWithId f id = map applyIfMatch
  where applyIfMatch entry@(Entry en) | en.id == id = f entry
                                      | otherwise = entry

setEditState :: Boolean -> Entry -> Entry
setEditState isEditing (Entry en) = Entry $ en { isEditing = isEditing }

foldp :: forall fx. Event -> State -> EffModel State Event (AppEffects fx)
foldp (FieldChanged ev) (State s) =
  noEffects $ State s { editingField = targetValue ev }

foldp (AddEntry ev) (State s) =
  noEffects $ State s { nextId = s.nextId + 1
                      , editingField = ""
                      , entries = snoc s.entries $ mkEntry s.nextId s.editingField
                      }

foldp (DeleteEntry id ev) (State s) =
  noEffects $ State s { entries = filter (\(Entry en) -> en.id /= id) s.entries }

foldp (EditEntry id ev) (State s) =
  noEffects $ State s {
    entries = updateEntryWithId (setEditState true) id s.entries
  }

foldp (ChangeEntry id ev) (State s) =
  noEffects $ State s {
    entries = updateEntryWithId update id s.entries
  }
  where
    update (Entry en) = Entry $ en { editingDesc = targetValue ev }

foldp (CancelEditEntry id ev) ((State s)) =
  noEffects $ State s {
    entries = updateEntryWithId update id s.entries
  }

  where
    resetEditingDesc (Entry en) = Entry $ en { editingDesc = en.description }
    update = resetEditingDesc >>> setEditState false

foldp (UpdateEntry id ev) (State s) =
  noEffects $ State s {
    entries = updateEntryWithId update id s.entries
  }

  where
    commitEditingDesc (Entry en) = Entry $ en { description = en.editingDesc }
    update = commitEditingDesc >>> setEditState false

foldp (ToggleComplete id ev) (State s) =
  noEffects $ State s {
    entries = updateEntryWithId update id s.entries
  }

  where
    update (Entry en) = Entry $ en { isCompleted = not en.isCompleted }

foldp (ChangeVisibility vis ev) (State s) =
  noEffects $ State s { visibility = vis }

foldp (CheckAll ev) (State s) =
  noEffects $ State s { entries = map update s.entries}
  where
    update (Entry en) = Entry $ en { isCompleted = true }

foldp (DeleteCompeleted ev) (State s) =
  noEffects $ State s { entries = filter (\(Entry en) -> not en.isCompleted) s.entries }

viewEntry :: Entry -> HTML Event
viewEntry (Entry { id, description, editingDesc, isEditing, isCompleted }) = div do
  checkbox
  rightView
  where
    checkbox = span do
      a #! onClick (ToggleComplete id) $ text $
        "[" <> (if isCompleted then "v" else " ") <> "]"

    rightView = if isEditing
                then do
                  input #! onChange (ChangeEntry id) ! value editingDesc
                  button #! onClick (UpdateEntry id) $ text "Update"
                  button #! onClick (CancelEditEntry id) $ text "Cancel"
                else do
                  text description
                  button #! onClick (EditEntry id) $ text "Edit"
                  button #! onClick (DeleteEntry id) $ text "x"

view :: State -> HTML Event
view (State st) = div do
  div $ text $ "nextId = " <> show st.nextId
  div $ text $ "editingField = " <> show st.editingField
  div do
    for_ entries' $ viewEntry
  div do
    input #! onChange FieldChanged ! value st.editingField
    button #! onClick AddEntry $ text "Add"
  div do
    text $ "Visibility: "
    visBtn All "All" st.visibility
    visBtn Active "Active" st.visibility
    visBtn Completed "Completed" st.visibility
  div do
    text $ "Control: "
    button #! onClick CheckAll $ text "Check All"
    button #! onClick DeleteCompeleted $ text "Delete Completed"

  where
    entries' = filter matchVis st.entries

    matchVis (Entry { isCompleted }) =
      if st.visibility == All
      then true
      else if st.visibility == Active
           then not isCompleted
           else isCompleted

    visBtn :: Visibility -> String -> Visibility -> HTML Event
    visBtn vis label currentVis = button #! onClick (ChangeVisibility vis) $ text label'
      where label' = if vis == currentVis
                     then label <> "*"
                     else label

--------------------
-- infrastructure --
--------------------

type WebApp = App (DOMEvent -> Event) Event State

type ClientEffects = CoreEffects (AppEffects (dom :: DOM))

main :: String -> State -> Eff ClientEffects WebApp
main url state = do
  -- | Start the app.
  app <- start
    { initialState: state
    , view
    , foldp
    , inputs: [] }

  -- | Render to the DOM
  renderToDOM "#app" app.markup app.input

  -- | Return app to be used for hot reloading logic in support/client.entry.js
  pure app

initialState :: State
initialState = init "/"

module Main where

import App.Events (AppEffects)
import Control.Monad.Eff (Eff)
import DOM (DOM)
import Data.Array (filter, snoc)
import Data.Foldable (for_)
import Pux (CoreEffects, App, start, EffModel, noEffects)
import Pux.DOM.Events (DOMEvent, onChange, onClick, targetValue)
import Pux.DOM.HTML (HTML)
import Pux.Renderer.React (renderToDOM)
import Text.Smolder.HTML (a, button, div, input, span)
import Text.Smolder.HTML.Attributes (value)
import Text.Smolder.Markup (text, (!), (#!))
import Prelude hiding (div)

data Visibility = All | Active | Completed
derive instance eqVis :: Eq Visibility

data Event = FieldChanged DOMEvent
           | AddEntry DOMEvent
           | DeleteEntry Int DOMEvent
           | EditEntry Int DOMEvent
           | ChangeEntry Int DOMEvent
           | UpdateEntry Int DOMEvent
           | CancelEditEntry Int DOMEvent
           | ToggleComplete Int DOMEvent
           | ChangeVisibility Visibility DOMEvent

newtype Entry = Entry { id :: Int
                      , description :: String
                      , editingDesc :: String
                      , isEditing :: Boolean
                      , isCompleted :: Boolean
                      }

mkEntry :: Int -> String -> Entry
mkEntry id description = Entry { id
                               , description
                               , editingDesc: description
                               , isEditing: false
                               , isCompleted: false
                               }

newtype State = State { nextId :: Int
                      , editingField :: String
                      , entries :: Array Entry
                      , visibility :: Visibility
                      }

init :: String -> State
init url = State { nextId: 0
                 , editingField: ""
                 , entries: []
                 , visibility: All
                 }

updateEntryWithId :: (Entry -> Entry) -> Int -> Array Entry -> Array Entry
updateEntryWithId f id = map applyIfMatch
  where applyIfMatch entry@(Entry en) | en.id == id = f entry
                                      | otherwise = entry

setEditState :: Boolean -> Entry -> Entry
setEditState isEditing (Entry en) = Entry $ en { isEditing = isEditing }

foldp :: forall fx. Event -> State -> EffModel State Event (AppEffects fx)
foldp (FieldChanged ev) (State s) =
  noEffects $ State s { editingField = targetValue ev }

foldp (AddEntry ev) (State s) =
  noEffects $ State s { nextId = s.nextId + 1
                      , editingField = ""
                      , entries = snoc s.entries $ mkEntry s.nextId s.editingField
                      }

foldp (DeleteEntry id ev) (State s) =
  noEffects $ State s { entries = filter (\(Entry en) -> en.id /= id) s.entries }

foldp (EditEntry id ev) (State s) =
  noEffects $ State s {
    entries = updateEntryWithId (setEditState true) id s.entries
  }

foldp (ChangeEntry id ev) (State s) =
  noEffects $ State s {
    entries = updateEntryWithId update id s.entries
  }
  where
    update (Entry en) = Entry $ en { editingDesc = targetValue ev }

foldp (CancelEditEntry id ev) ((State s)) =
  noEffects $ State s {
    entries = updateEntryWithId update id s.entries
  }

  where
    resetEditingDesc (Entry en) = Entry $ en { editingDesc = en.description }
    update = resetEditingDesc >>> setEditState false

foldp (UpdateEntry id ev) (State s) =
  noEffects $ State s {
    entries = updateEntryWithId update id s.entries
  }

  where
    commitEditingDesc (Entry en) = Entry $ en { description = en.editingDesc }
    update = commitEditingDesc >>> setEditState false

foldp (ToggleComplete id ev) (State s) =
  noEffects $ State s {
    entries = updateEntryWithId update id s.entries
  }

  where
    update (Entry en) = Entry $ en { isCompleted = not en.isCompleted }

foldp (ChangeVisibility vis ev) (State s) =
  noEffects $ State s { visibility = vis }

viewEntry :: Entry -> HTML Event
viewEntry (Entry { id, description, editingDesc, isEditing, isCompleted }) = div do
  checkbox
  rightView
  where
    checkbox = span do
      a #! onClick (ToggleComplete id) $ text $
        "[" <> (if isCompleted then "v" else " ") <> "]"

    rightView = if isEditing
                then do
                  input #! onChange (ChangeEntry id) ! value editingDesc
                  button #! onClick (UpdateEntry id) $ text "Update"
                  button #! onClick (CancelEditEntry id) $ text "Cancel"
                else do
                  text description
                  button #! onClick (EditEntry id) $ text "Edit"
                  button #! onClick (DeleteEntry id) $ text "x"

view :: State -> HTML Event
view (State st) = div do
  div $ text $ "nextId = " <> show st.nextId
  div $ text $ "editingField = " <> show st.editingField
  div do
    for_ entries' $ viewEntry
  div do
    input #! onChange FieldChanged ! value st.editingField
    button #! onClick AddEntry $ text "Add"
  div do
    text $ "Visibility: "
    visBtn All "All" st.visibility
    visBtn Active "Active" st.visibility
    visBtn Completed "Completed" st.visibility

  where
    entries' = filter matchVis st.entries

    matchVis (Entry { isCompleted }) =
      if st.visibility == All
      then true
      else if st.visibility == Active
           then not isCompleted
           else isCompleted

    visBtn :: Visibility -> String -> Visibility -> HTML Event
    visBtn vis label currentVis = button #! onClick (ChangeVisibility vis) $ text label'
      where label' = if vis == currentVis
                     then label <> "*"
                     else label

--------------------
-- infrastructure --
--------------------

type WebApp = App (DOMEvent -> Event) Event State

type ClientEffects = CoreEffects (AppEffects (dom :: DOM))

main :: String -> State -> Eff ClientEffects WebApp
main url state = do
  -- | Start the app.
  app <- start
    { initialState: state
    , view
    , foldp
    , inputs: [] }

  -- | Render to the DOM
  renderToDOM "#app" app.markup app.input

  -- | Return app to be used for hot reloading logic in support/client.entry.js
  pure app

initialState :: State
initialState = init "/"


slightly bogus checkpoint save

slightly bogus checkpoint save

this isn’t how named transitions work in D3

module Main where

import D3.Selection
import Control.Monad.Eff.Console (CONSOLE, log)
import D3.Base (D3, Eff, D3Element, Nodes, Index, theHorror, (..), (...))
import D3.Transitions (Transition, duration, makeTransition, namedTransition, savedTransition, d3Transition)
import DOM.HTML.Event.EventTypes (mouseenter, mouseleave, click)
import Data.Array (reverse)
import Data.Foldable (foldr)
import Data.String (length, toCharArray, fromCharArray)
import Prelude (Unit, show, unit, pure, bind, max, (*), (<>), (<<<), (==))
{-
-- next target is to handle this case:
var matrix = [
  [11975,  5871, 8916, 2868],
  [ 1951, 10048, 2060, 6171],
  [ 8010, 16145, 8090, 8045],
  [ 1013,   990,  940, 6907]
];

var tr = d3.select("body")
  .append("table")
  .selectAll("tr")
  .data(matrix)
  .enter().append("tr");
-}

-- | mainline: simplest possible D3 demo
array :: Array Number
array = [4.0, 8.0, 15.0, 16.0, 23.0, 42.0]

array2 :: Array String
array2 = ["this", "is", "a", "sentence", "in", "pieces"]

arrayMax :: Number
arrayMax = foldr max 0.0 array

revString :: String -> String
revString = fromCharArray <<< reverse <<< toCharArray

awn :: forall eff. CallbackParam Number -> Eff (d3::D3, console::CONSOLE|eff) Unit
awn { datum: d, meta: m } = do
  log (show d)
  log (show m)
  pure unit

bel :: forall eff. CallbackParamP Number String -> Eff (d3::D3, console::CONSOLE|eff) Unit
bel { datum: d, prop: p } = do
  log (show d)
  log (show p)
  pure unit

cep :: Number -> Index -> Nodes -> D3Element -> Boolean
cep datum _ _ _ = if (datum == 16.0) then true else false

dof :: String -> Index -> Nodes -> D3Element -> String
dof datum _ _ _ = if (datum == "sentence") then "marriage" else theHorror

hoy :: forall eff. Eff (d3::D3|eff) (Transition String)
hoy = d3Transition "ist"

main :: forall e. Eff (d3::D3,console::CONSOLE|e) Unit
main = do
  d3Transition "erg"
    .. duration 750.0

  chart1 <- d3Select ".chart"
      .. selectAll "div"
        .. dataBind (Data array)
      .. enter .. append "div"
        .. style    "width"         (FnD (\d -> show (d * 10.0) <> "px"))
        .. classed  "twice as nice" (ClassFn (\d i nodes el -> i == 2.0 ))
        .. classed  "sweet sixteen" (ClassFn cep)
        .. attr     "name"          (AttrV "fred")
        .. text                     (FnD (\d -> show d))
        .. on       mouseenter      awn
        .. on       mouseleave      awn
        .. on' click "magic" "snape" bel

  chart2 <- d3Select ".chart2"
    .. selectAll "div"
      .. dataBind (Keyed array2 (\d -> revString d))
    .. enter .. append "div"
      .. style "background-color"  (Value "red")
      .. style "width"             (FnD (\d -> show ((length d) * 20) <> "px"))
      .. classed "foo bar"         (ClassB true)
      .. attr "name"               (AttrFn dof)
      .. text                      (FnD (\d -> show d))
      .. on' click "cep" "stringy" bel
      -- .. makeTransition

  chart1 ... namedTransition "erg"
  chart2 ... namedTransition "erg"

  pure unit

module Main where

import D3.Selection
import Control.Monad.Eff.Console (CONSOLE, log)
import D3.Base (D3, Eff, D3Element, Nodes, Index, theHorror, (..), (...))
import D3.Transitions (Transition, duration, makeTransition, namedTransition, savedTransition, d3Transition)
import DOM.HTML.Event.EventTypes (mouseenter, mouseleave, click)
import Data.Array (reverse)
import Data.Foldable (foldr)
import Data.String (length, toCharArray, fromCharArray)
import Prelude (Unit, show, unit, pure, bind, max, (*), (<>), (<<<), (==))
{-
-- next target is to handle this case:
var matrix = [
  [11975,  5871, 8916, 2868],
  [ 1951, 10048, 2060, 6171],
  [ 8010, 16145, 8090, 8045],
  [ 1013,   990,  940, 6907]
];

var tr = d3.select("body")
  .append("table")
  .selectAll("tr")
  .data(matrix)
  .enter().append("tr");
-}

-- | mainline: simplest possible D3 demo
array :: Array Number
array = [4.0, 8.0, 15.0, 16.0, 23.0, 42.0]

array2 :: Array String
array2 = ["this", "is", "a", "sentence", "in", "pieces"]

arrayMax :: Number
arrayMax = foldr max 0.0 array

revString :: String -> String
revString = fromCharArray <<< reverse <<< toCharArray

awn :: forall eff. CallbackParam Number -> Eff (d3::D3, console::CONSOLE|eff) Unit
awn { datum: d, meta: m } = do
  log (show d)
  log (show m)
  pure unit

bel :: forall eff. CallbackParamP Number String -> Eff (d3::D3, console::CONSOLE|eff) Unit
bel { datum: d, prop: p } = do
  log (show d)
  log (show p)
  pure unit

cep :: Number -> Index -> Nodes -> D3Element -> Boolean
cep datum _ _ _ = if (datum == 16.0) then true else false

dof :: String -> Index -> Nodes -> D3Element -> String
dof datum _ _ _ = if (datum == "sentence") then "marriage" else theHorror

fub :: forall d eff. Eff (d3::D3|eff) (Transition d)
fub = d3Transition "erg"
        .. duration 750.0

hoy :: forall eff. Eff (d3::D3|eff) (Transition String)
hoy = d3Transition "ist"

main :: forall e. Eff (d3::D3,console::CONSOLE|e) Unit
main = do

  d3Select ".chart"
      .. selectAll "div"
        .. dataBind (Data array)
      .. enter .. append "div"
        .. style    "width"         (FnD (\d -> show (d * 10.0) <> "px"))
        .. classed  "twice as nice" (ClassFn (\d i nodes el -> i == 2.0 ))
        .. classed  "sweet sixteen" (ClassFn cep)
        .. attr     "name"          (AttrV "fred")
        .. text                     (FnD (\d -> show d))
        .. on       mouseenter      awn
        .. on       mouseleave      awn
        .. on' click "magic" "snape" bel

  chart2 <- d3Select ".chart2"
    .. selectAll "div"
      .. dataBind (Keyed array2 (\d -> revString d))
    .. enter .. append "div"
      .. style "background-color"  (Value "red")
      .. style "width"             (FnD (\d -> show ((length d) * 20) <> "px"))
      .. classed "foo bar"         (ClassB true)
      .. attr "name"               (AttrFn dof)
      .. text                      (FnD (\d -> show d))
      .. on' click "cep" "stringy" bel
      -- .. makeTransition

  chart2 ... makeTransition

  pure unit


Added doc comment to viewLoading

Added doc comment to viewLoading

-- | Html view elements which are generically usefull:
module Gonimo.UI.Html where

import Prelude
import Pux.Html.Attributes as A
import Pux.Html (text, span, Html, img, div)

viewLogo :: forall action. Html action -> Html action
viewLogo inner =
  div [ A.id_ "site" ]
    [ div [ A.id_ "main"]
        [ img [ A.id_ "logo", A.src "pix/gonimo-21.jpg", A.alt "Gonimo Logo"] []
        , inner
        ]
    ]

-- | Loading something screen.
viewLoading :: forall action. String -> Html action
viewLoading inner = viewLogo $ span [] [text inner]

-- | Html view elements which are generically usefull:
module Gonimo.UI.Html where

import Prelude
import Pux.Html.Attributes as A
import Pux.Html (text, span, Html, img, div)

viewLogo :: forall action. Html action -> Html action
viewLogo inner =
  div [ A.id_ "site" ]
    [ div [ A.id_ "main"]
        [ img [ A.id_ "logo", A.src "pix/gonimo-21.jpg", A.alt "Gonimo Logo"] []
        , inner
        ]
    ]

viewLoading :: forall action. String -> Html action
viewLoading inner = viewLogo $ span [] [text inner]


Don't shadow type variables

Don't shadow type variables

The PureScript compiler warns about shadowed type variables as of 0.7.6.

-- | This module defines a type class for reading foreign values.

module Data.Foreign.Class
  ( IsForeign
  , read
  , readJSON
  , readWith
  , readProp
  ) where

import Prelude

import Data.Array (range, zipWith, length)
import Data.Either (Either(..), either)
import Data.Foreign
import Data.Foreign.Index
import Data.Foreign.Null
import Data.Foreign.NullOrUndefined
import Data.Foreign.Undefined
import Data.Int ()
import Data.Traversable (sequence)

-- | A type class instance for this class can be written for a type if it
-- | is possible to attempt to _safely_ coerce a `Foreign` value to that
-- | type.
-- |
-- | Instances are provided for standard data structures, and the `F` monad
-- | can be used to construct instances for new data structures.
class IsForeign a where
  read :: Foreign -> F a

instance foreignIsForeign :: IsForeign Foreign where
  read f = return f

instance stringIsForeign :: IsForeign String where
  read = readString

instance charIsForeign :: IsForeign Char where
  read = readChar

instance booleanIsForeign :: IsForeign Boolean where
  read = readBoolean

instance numberIsForeign :: IsForeign Number where
  read = readNumber

instance intIsForeign :: IsForeign Int where
  read = readInt

instance arrayIsForeign :: (IsForeign a) => IsForeign (Array a) where
  read value = readArray value >>= readElements
    where
    readElements :: Array Foreign -> F (Array a)
    readElements arr = sequence (zipWith readElement (range zero (length arr)) arr)

    readElement :: Int -> Foreign -> F a
    readElement i value = readWith (ErrorAtIndex i) value

instance nullIsForeign :: (IsForeign a) => IsForeign (Null a) where
  read = readNull read

instance undefinedIsForeign :: (IsForeign a) => IsForeign (Undefined a) where
  read = readUndefined read

instance nullOrUndefinedIsForeign :: (IsForeign a) => IsForeign (NullOrUndefined a) where
  read = readNullOrUndefined read

-- | Attempt to read a data structure from a JSON string
readJSON :: forall a. (IsForeign a) => String -> F a
readJSON json = parseJSON json >>= read

-- | Attempt to read a foreign value, handling errors using the specified function
readWith :: forall a e. (IsForeign a) => (ForeignError -> e) -> Foreign -> Either e a
readWith f value = either (Left <<< f) Right (read value)

-- | Attempt to read a property of a foreign value at the specified index
readProp :: forall a i. (IsForeign a, Index i) => i -> Foreign -> F a
readProp prop value = value ! prop >>= readWith (errorAt prop)

-- | This module defines a type class for reading foreign values.

module Data.Foreign.Class
  ( IsForeign
  , read
  , readJSON
  , readWith
  , readProp
  ) where

import Prelude

import Data.Array (range, zipWith, length)
import Data.Either (Either(..), either)
import Data.Foreign
import Data.Foreign.Index
import Data.Foreign.Null
import Data.Foreign.NullOrUndefined
import Data.Foreign.Undefined
import Data.Int ()
import Data.Traversable (sequence)

-- | A type class instance for this class can be written for a type if it
-- | is possible to attempt to _safely_ coerce a `Foreign` value to that
-- | type.
-- |
-- | Instances are provided for standard data structures, and the `F` monad
-- | can be used to construct instances for new data structures.
class IsForeign a where
  read :: Foreign -> F a

instance foreignIsForeign :: IsForeign Foreign where
  read f = return f

instance stringIsForeign :: IsForeign String where
  read = readString

instance charIsForeign :: IsForeign Char where
  read = readChar

instance booleanIsForeign :: IsForeign Boolean where
  read = readBoolean

instance numberIsForeign :: IsForeign Number where
  read = readNumber

instance intIsForeign :: IsForeign Int where
  read = readInt

instance arrayIsForeign :: (IsForeign a) => IsForeign (Array a) where
  read value = readArray value >>= readElements
    where
    readElements :: forall a. (IsForeign a) => Array Foreign -> F (Array a)
    readElements arr = sequence (zipWith readElement (range zero (length arr)) arr)

    readElement :: forall a. (IsForeign a) => Int -> Foreign -> F a
    readElement i value = readWith (ErrorAtIndex i) value

instance nullIsForeign :: (IsForeign a) => IsForeign (Null a) where
  read = readNull read

instance undefinedIsForeign :: (IsForeign a) => IsForeign (Undefined a) where
  read = readUndefined read

instance nullOrUndefinedIsForeign :: (IsForeign a) => IsForeign (NullOrUndefined a) where
  read = readNullOrUndefined read

-- | Attempt to read a data structure from a JSON string
readJSON :: forall a. (IsForeign a) => String -> F a
readJSON json = parseJSON json >>= read

-- | Attempt to read a foreign value, handling errors using the specified function
readWith :: forall a e. (IsForeign a) => (ForeignError -> e) -> Foreign -> Either e a
readWith f value = either (Left <<< f) Right (read value)

-- | Attempt to read a property of a foreign value at the specified index
readProp :: forall a i. (IsForeign a, Index i) => i -> Foreign -> F a
readProp prop value = value ! prop >>= readWith (errorAt prop)


Cleanup code, add some comments etc.

Cleanup code, add some comments etc.

module Main where

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (EXCEPTION)
import DOM (DOM)
import Data.Bifunctor (class Bifunctor, bimap)
import Data.Generic (class Generic)
import Data.Maybe (Maybe(Just, Nothing))
import Pux (renderToDOM, start, noEffects, Update)
import Pux.Html (Html, div, ul, text, br, a, li)
import Pux.Html.Attributes (href, className)
import Pux.Html.Elements (p)
import Pux.Html.Events (onClick)
import Pux.Routing.Bob (RoutingAction(Routed, RoutingError))
import Pux.Routing.Bob.Component as Pux.Routing.Bob.Component
import Pux.Routing.Bob.Component (View, Action(RawAction, RoutingAction), link', sampleUrl)
import Routing.Bob as Routing.Bob
import Routing.Bob (Router)
import Signal.Channel (CHANNEL)
import Type.Proxy (Proxy(Proxy))
import Prelude hiding (div)

-- Main window component

data MainWindowRoute
  = Profile
  | Inbox
  | Settings
derive instance genericMainWindowRoute :: Generic MainWindowRoute
derive instance eqMainWindowRoute :: Eq MainWindowRoute

data MainWindowRawAction
  = ProfileClick
  | InboxClick
  | SettingsClick

type MainWindowState =
  { activeTab :: MainWindowRoute
  -- clicks counters - just to include other state and actions
  , profileCounter :: Int
  , inboxCounter :: Int
  , settingsCounter :: Int
  }

type MainWindowAction = Action MainWindowRoute MainWindowRawAction

mainWindowUpdate :: (Router MainWindowRoute) -> Update MainWindowState MainWindowAction (dom :: DOM)
mainWindowUpdate _ (RawAction ProfileClick) state =
  noEffects $ state { profileCounter = state.profileCounter + 1 }
mainWindowUpdate _ (RawAction InboxClick) state =
  noEffects $ state { inboxCounter = state.inboxCounter + 1 }
mainWindowUpdate _ (RawAction SettingsClick) state =
  noEffects $ state { settingsCounter = state.settingsCounter + 1 }
mainWindowUpdate _ (RoutingAction (Routed r)) state =
  noEffects $ state { activeTab = r }
mainWindowUpdate _ (RoutingAction (RoutingError _)) state = noEffects state
mainWindowUpdate router (RoutingAction a) state =
  Pux.Routing.Bob.Component.update router a state

mainWindowView :: View MainWindowState MainWindowRoute MainWindowRawAction
mainWindowView router mapAction state =
  div []
    [ ul []
        [ tabHeader Profile "profile"
        , tabHeader Inbox "inbox"
        , tabHeader Settings "settings"
        ]
    , div []
        case state.activeTab of
          Profile -> [ tabBody (mapAction (RawAction ProfileClick)) state.profileCounter "profile" ]
          Inbox -> [ tabBody (mapAction (RawAction InboxClick)) state.inboxCounter "inbox" ]
          Settings -> [ tabBody (mapAction (RawAction SettingsClick)) state.settingsCounter "settings" ]
    ]
 where
  link'' = link' mapAction router
  tabHeader route label =
    li
      (if state.activeTab == route
        then [className "active"]
        else [])
      [ link''
          route
          []
          [ text label ]
      ]
  tabBody action counter label =
    a [ href "#", onClick $ const action]
      [ text (label <> " action"), br [] [], text <<< show $ counter ]

-- Sidebar component

data SideBarRoute
  = Expanded
  | Minimized
derive instance genericSideBarRoute :: Generic SideBarRoute
derive instance eqSideBarRoute :: Eq SideBarRoute

type SideBarState = SideBarRoute

type SideBarRawAction = Unit

type SideBarAction = Action SideBarRoute SideBarRawAction

sideBarUpdate :: forall eff. Router SideBarRoute -> Update SideBarState SideBarAction (dom :: DOM | eff)
sideBarUpdate _ (RawAction _) state = noEffects state
sideBarUpdate _ (RoutingAction (Routed r)) state | r == Expanded = noEffects Expanded
                                                 | r == Minimized = noEffects Minimized
sideBarUpdate _ (RoutingAction (RoutingError _)) state = noEffects state
sideBarUpdate router (RoutingAction a) state =
  Pux.Routing.Bob.Component.update router a state

sideBarView :: View SideBarState SideBarRoute SideBarRawAction
sideBarView router mapAction state =
  p []
    if state == Expanded
      then
        [ text "Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat."
        , link'' Minimized [] [ text "hide"]
        ]
      else
        [ text "Lorem ipsum..."
        , link'' Expanded [] [ text "show more" ]
        ]
 where
  link'' = link' mapAction router

-- Application

data AppRoute =
  AppRoute MainWindowRoute SideBarRoute
derive instance genericAppRoute :: Generic AppRoute

type AppState =
  { mainWindowState :: MainWindowState
  , sideBarState :: SideBarState
  }

data AppRawAction
  = MainWindowRawAction MainWindowRawAction
  | SideBarRawAction SideBarRawAction

type AppAction = Action AppRoute AppRawAction

-- To be honest I'm using: unsafePartial (router RouteType)
-- for Router generation when it's tested, because route type
-- doesn't change over runtime. This simplifies API
-- a lot - you can avoid all this routers passing clutter...
appUpdate :: (Router MainWindowRoute) ->
             (Router SideBarRoute) ->
             (Router AppRoute) ->
             Update AppState AppAction (dom :: DOM)
appUpdate mr _ _ (RawAction (MainWindowRawAction a)) state =
  let r = mainWindowUpdate mr (RawAction a) state.mainWindowState
  in
    { state: state { mainWindowState = r.state }
    , effects: (bimap mapRoute MainWindowRawAction <$> _) <$> r.effects
    }
 where
  mapRoute mainWindowRoute = AppRoute mainWindowRoute state.sideBarState
-- this branch could be avoided as sideBarUpdate doesn't perform anything
appUpdate _ sr _ (RawAction (SideBarRawAction a)) state =
  let r = sideBarUpdate sr (RawAction a) state.sideBarState
  in
    { state: state { sideBarState = r.state }
    , effects: (bimap mapRoute SideBarRawAction <$> _) <$> r.effects
    }
 where
  mapRoute sideBarRoute = AppRoute state.mainWindowState.activeTab sideBarRoute
appUpdate mRouter sRouter _
          (RoutingAction (Routed (AppRoute mainWindowRoute sideBarRoute)))
          state =
  let sr = sideBarUpdate sRouter (RoutingAction (Routed sideBarRoute)) state.sideBarState
      mr = mainWindowUpdate mRouter (RoutingAction (Routed mainWindowRoute)) state.mainWindowState
      mapSideBarRoute sideBarRoute = AppRoute mr.state.activeTab sideBarRoute
      mapMainWindowRoute mainWindowRoute = AppRoute mainWindowRoute sr.state
  in
    { state: state { sideBarState = sr.state
                   , mainWindowState = mr.state
                   }
    , effects: ((bimap mapSideBarRoute SideBarRawAction <$> _) <$> sr.effects) <>
               ((bimap mapMainWindowRoute MainWindowRawAction <$> _) <$> mr.effects)
    }
appUpdate _ _ _ (RoutingAction (RoutingError _)) state = noEffects state
appUpdate _ _ aRouter (RoutingAction a) state =
  Pux.Routing.Bob.Component.update aRouter a state

appView :: Router AppRoute -> AppState -> Html AppAction
appView router state =
  div []
    [ mainWindowView
        router
        (bimap (\r -> AppRoute r state.sideBarState) MainWindowRawAction)
        state.mainWindowState
    , sideBarView router mapSideBarAction state.sideBarState
    ]
 where
  -- Helper with type signature, which is necessary in this case
  mapSideBarAction :: forall b. (Bifunctor b) =>
                      b SideBarRoute SideBarRawAction ->
                      b AppRoute AppRawAction
  mapSideBarAction = bimap (\r -> AppRoute state.mainWindowState.activeTab r) SideBarRawAction

main :: Eff ( dom :: DOM , channel :: CHANNEL , err :: EXCEPTION ) Unit
main = do
  sampleUrlSignal <- sampleUrl
  let
    config = do
      -- this can be simplified with unsafePartial use
      -- on each component level, so all update functions
      -- would have appropriate router in scope
      mainWindowRouter <- Routing.Bob.router (Proxy :: Proxy MainWindowRoute)
      sideBarRouter <- Routing.Bob.router (Proxy :: Proxy SideBarRoute)
      appRouter <- Routing.Bob.router (Proxy :: Proxy AppRoute)
      let
        view = appView appRouter
        update = appUpdate mainWindowRouter sideBarRouter appRouter
      pure
        { update: update
        , view: view
        , inputs: [ sampleUrlSignal ]
        , initialState:
            { mainWindowState:
              { activeTab: Profile
              , profileCounter: 0
              , inboxCounter: 0
              , settingsCounter: 0
              }
            , sideBarState: Minimized
            }
        }
  case config of
    Just c ->
      do
        app <- start c
        renderToDOM "#app" app.html
    Nothing -> pure unit

module Main where

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (EXCEPTION)
import DOM (DOM)
import Data.Bifunctor (class Bifunctor, bimap)
import Data.Generic (class Generic)
import Data.Maybe (Maybe(Just, Nothing))
import Pux (renderToDOM, start, noEffects, Update)
import Pux.Html (Html, div, ul, text, br, a, li)
import Pux.Html.Attributes (href, className)
import Pux.Html.Elements (p)
import Pux.Html.Events (onClick)
import Pux.Routing.Bob (RoutingAction(Routed, RoutingError))
import Pux.Routing.Bob.Component as Pux.Routing.Bob.Component
import Pux.Routing.Bob.Component (View, Action(RawAction, RoutingAction), link', sampleUrl)
import Routing.Bob as Routing.Bob
import Routing.Bob (Router)
import Signal.Channel (CHANNEL)
import Type.Proxy (Proxy(Proxy))
import Prelude hiding (div)

-- Main window component

data MainWindowRoute
  = Profile
  | Inbox
  | Settings
derive instance genericMainWindowRoute :: Generic MainWindowRoute
derive instance eqMainWindowRoute :: Eq MainWindowRoute

data MainWindowRawAction
  = ProfileClick
  | InboxClick
  | SettingsClick

type MainWindowState =
  { activeTab :: MainWindowRoute
  -- clicks counters - just to include other state and actions
  , profileCounter :: Int
  , inboxCounter :: Int
  , settingsCounter :: Int
  }

type MainWindowAction = Action MainWindowRoute MainWindowRawAction

mainWindowUpdate :: (Router MainWindowRoute) -> Update MainWindowState MainWindowAction (dom :: DOM)
mainWindowUpdate _ (RawAction ProfileClick) state =
  noEffects $ state { profileCounter = state.profileCounter + 1 }
mainWindowUpdate _ (RawAction InboxClick) state =
  noEffects $ state { inboxCounter = state.inboxCounter + 1 }
mainWindowUpdate _ (RawAction SettingsClick) state =
  noEffects $ state { settingsCounter = state.settingsCounter + 1 }
mainWindowUpdate _ (RoutingAction (Routed r)) state =
  noEffects $ state { activeTab = r }
mainWindowUpdate _ (RoutingAction (RoutingError _)) state = noEffects state
mainWindowUpdate router (RoutingAction a) state =
  Pux.Routing.Bob.Component.update router a state

mainWindowView :: View MainWindowState MainWindowRoute MainWindowRawAction
mainWindowView router mapAction state =
  div []
    [ ul []
        [ tabHeader Profile "profile"
        , tabHeader Inbox "inbox"
        , tabHeader Settings "settings"
        ]
    , div []
        case state.activeTab of
          Profile -> [ tabBody (mapAction (RawAction ProfileClick)) state.profileCounter "profile" ]
          Inbox -> [ tabBody (mapAction (RawAction InboxClick)) state.inboxCounter "inbox" ]
          Settings -> [ tabBody (mapAction (RawAction SettingsClick)) state.settingsCounter "settings" ]
    ]
 where
  link'' = link' mapAction router
  tabHeader route label =
    li
      (if state.activeTab == route
        then [className "active"]
        else [])
      [ link''
          route
          []
          [ text label ]
      ]
  tabBody action counter label =
    a [ href "#", onClick $ const action]
      [ text (label <> " action"), br [] [], text <<< show $ counter ]

-- Sidebar component

data SideBarRoute
  = Expanded
  | Minimized
derive instance genericSideBarRoute :: Generic SideBarRoute
derive instance eqSideBarRoute :: Eq SideBarRoute

type SideBarState = SideBarRoute

type SideBarRawAction = Unit

type SideBarAction = Action SideBarRoute SideBarRawAction

sideBarUpdate :: forall eff. Router SideBarRoute -> Update SideBarState SideBarAction (dom :: DOM | eff)
sideBarUpdate _ (RawAction _) state = noEffects state
sideBarUpdate _ (RoutingAction (Routed r)) state | r == Expanded = noEffects Expanded
                                                 | r == Minimized = noEffects Minimized
sideBarUpdate _ (RoutingAction (RoutingError _)) state = noEffects state
sideBarUpdate router (RoutingAction a) state =
  Pux.Routing.Bob.Component.update router a state

sideBarView :: View SideBarState SideBarRoute SideBarRawAction
sideBarView router mapAction state =
  p []
    if state == Expanded
      then
        [ text "Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat."
        , link'' Minimized [] [ text "hide"]
        ]
      else
        [ text "Lorem ipsum..."
        , link'' Expanded [] [ text "show more" ]
        ]
 where
  link'' = link' mapAction router

-- Application

data AppRoute =
  AppRoute MainWindowRoute SideBarRoute
derive instance genericAppRoute :: Generic AppRoute

type AppState =
  { mainWindowState :: MainWindowState
  , sideBarState :: SideBarState
  }

data AppRawAction
  = MainWindowRawAction MainWindowRawAction
  | SideBarRawAction SideBarRawAction

type AppAction = Action AppRoute AppRawAction

-- To be honest I'm using: unsafePartial (router RouteType)
-- for Router generation when it's tested, because route type
-- doesn't change over runtime. This simplifies API
-- a lot - you can avoid all this routers passing clutter...
appUpdate :: (Router MainWindowRoute) ->
             (Router SideBarRoute) ->
             (Router AppRoute) ->
             Update AppState AppAction (dom :: DOM)
appUpdate mr _ _ (RawAction (MainWindowRawAction a)) state =
  let r = mainWindowUpdate mr (RawAction a) state.mainWindowState
  in
    { state: state { mainWindowState = r.state }
    , effects: (bimap mapRoute MainWindowRawAction <$> _) <$> r.effects
    }
 where
  mapRoute mainWindowRoute = AppRoute mainWindowRoute state.sideBarState
-- this branch could be avoided as sideBarUpdate doesn't perform anything
appUpdate _ sr _ (RawAction (SideBarRawAction a)) state =
  let r = sideBarUpdate sr (RawAction a) state.sideBarState
  in
    { state: state { sideBarState = r.state }
    , effects: (bimap mapRoute SideBarRawAction <$> _) <$> r.effects
    }
 where
  mapRoute sideBarRoute = AppRoute state.mainWindowState.activeTab sideBarRoute
appUpdate mRouter sRouter _
          (RoutingAction (Routed (AppRoute mainWindowRoute sideBarRoute)))
          state =
  let sr = sideBarUpdate sRouter (RoutingAction (Routed sideBarRoute)) state.sideBarState
      mr = mainWindowUpdate mRouter (RoutingAction (Routed mainWindowRoute)) state.mainWindowState
      mapSideBarRoute sideBarRoute = AppRoute mr.state.activeTab sideBarRoute
      mapMainWindowRoute mainWindowRoute = AppRoute mainWindowRoute sr.state
  in
    { state: state { sideBarState = sr.state
                   , mainWindowState = mr.state
                   }
    , effects: ((bimap mapSideBarRoute SideBarRawAction <$> _) <$> sr.effects) <>
               ((bimap mapMainWindowRoute MainWindowRawAction <$> _) <$> mr.effects)
    }
appUpdate _ _ _ (RoutingAction (RoutingError _)) state = noEffects state
appUpdate _ _ aRouter (RoutingAction a) state =
  Pux.Routing.Bob.Component.update aRouter a state

appView :: Router AppRoute -> AppState -> Html AppAction
appView router state =
  div []
    [ mainWindowView router mapMainWindowAction state.mainWindowState
    , sideBarView router mapSideBarAction state.sideBarState
    ]
 where
  mapMainWindowRoute mainWindowRoute = AppRoute mainWindowRoute state.sideBarState
  mapMainWindowAction :: forall b. (Bifunctor b) =>
                         b MainWindowRoute MainWindowRawAction ->
                         b AppRoute AppRawAction
  mapMainWindowAction = bimap (\r -> AppRoute r state.sideBarState) MainWindowRawAction

  mapSideBarRoute sideBarRoute = AppRoute state.mainWindowState.activeTab sideBarRoute
  mapSideBarAction :: forall b. (Bifunctor b) =>
                      b SideBarRoute SideBarRawAction ->
                      b AppRoute AppRawAction
  mapSideBarAction = bimap mapSideBarRoute SideBarRawAction

main :: Eff ( dom :: DOM , channel :: CHANNEL , err :: EXCEPTION ) Unit
main = do
  sampleUrlSignal <- sampleUrl
  let
    config = do
      -- this can be simplified with unsafePartial use
      -- on each component level, so all update functions
      -- would have appropriate router in scope
      mainWindowRouter <- Routing.Bob.router (Proxy :: Proxy MainWindowRoute)
      sideBarRouter <- Routing.Bob.router (Proxy :: Proxy SideBarRoute)
      appRouter <- Routing.Bob.router (Proxy :: Proxy AppRoute)
      let
        view = appView appRouter
        update = appUpdate mainWindowRouter sideBarRouter appRouter
      pure
        { update: update
        , view: view
        , inputs: [ sampleUrlSignal ]
        , initialState:
            { mainWindowState:
              { activeTab: Profile
              , profileCounter: 0
              , inboxCounter: 0
              , settingsCounter: 0
              }
            , sideBarState: Minimized
            }
        }
  case config of
    Just c ->
      do
        app <- start c
        renderToDOM "#app" app.html
    Nothing -> pure unit