Update Dialog.Unshare component

Update Dialog.Unshare component

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.Workspace.Deck.Dialog.Unshare.Component where

import SlamData.Prelude

import Control.Monad.Aff.AVar (makeVar, takeVar, putVar)
import Control.Monad.Eff.Ref (newRef, modifyRef, readRef)
import Control.Monad.Fork.Class (fork)
import Control.UI.Browser (select)

import Data.Array as Arr
import Data.Foldable as F
import Data.Foreign (toForeign)
import Data.Lens (Lens', lens, (.~), (%~), (?~))
import Data.Lens.Index (ix)
import Data.List as L
import Data.Set as Set
import Data.Map as Map
import Data.StrMap as SM
import Data.Path.Pathy as Pt

import DOM.HTML.Types (htmlElementToElement, readHTMLElement)

import Halogen as H
import Halogen.HTML.Events as HE
import Halogen.HTML as HH
import Halogen.HTML.Elements.Keyed as HK
import Halogen.HTML.Properties as HP
import Halogen.Themes.Bootstrap3 as B

import Quasar.Advanced.Types as QTA

import SlamData.Monad (Slam)
import SlamData.Quasar.Security as Q
import SlamData.Render.Common (glyph)
import SlamData.Workspace.Deck.Dialog.Share.Model (ShareResume(..), printShareResume)
import SlamData.Workspace.Deck.Dialog.Share.Model as Model

import Utils.DOM as DOM
import Utils.Path (parseFilePath)
import Utils.Foldable (chunkedParTraverse, splitList)

import ZClipboard as Z

type HTML = H.ComponentHTML Query
type DSL = H.ComponentDSL State Query Message Slam

type PermissionId = Set.Set QTA.PermissionId

data PermissionState
  = Unsharing
  | Modifying
  | RevokeError
  | ModifyError

derive instance permissionStateEq ∷ Eq PermissionState

type Permission =
  { resume ∷ ShareResume
  , actions ∷ Map.Map QTA.PermissionId QTA.ActionR
  , state ∷ Maybe PermissionState
  }

data Modifyable = User | Group

type TokenPermission =
  { name ∷ Maybe String
  , secret ∷ String
  , resume ∷ ShareResume
  , tokenId ∷ QTA.TokenId
  , state ∷ Maybe PermissionState
  }

_resume ∷ ∀ a r. Lens' {resume ∷ a|r} a
_resume = lens (_.resume) (_{resume = _})

_tokenId ∷ ∀ a r. Lens' {tokenId ∷ a|r} a
_tokenId = lens (_.tokenId) (_{tokenId = _})

_secret ∷ ∀ a r. Lens' {secret ∷ a|r} a
_secret = lens (_.secret) (_{secret = _})

-- :( `ix` doesn't work without `Maybe PermissionState`
_state ∷ ∀ r. Lens' {state ∷ (Maybe PermissionState)|r} (Maybe PermissionState)
_state = lens (_.state) (_{state = _})

_actions
  ∷ ∀ r
  . Lens'
      {actions ∷ Map.Map QTA.PermissionId QTA.ActionR|r}
      (Map.Map QTA.PermissionId QTA.ActionR)
_actions = lens (_.actions) (_{actions = _})

type State =
  { userPermissions ∷ SM.StrMap Permission
  , tokenPermissions ∷ Array TokenPermission
  , groupPermissions ∷ SM.StrMap Permission
  , loading ∷ Boolean
  , errored ∷ Boolean
  , sharingInput ∷ Model.SharingInput
  }

initialState ∷ Model.SharingInput → State
initialState sharingInput =
  { userPermissions: SM.empty
  , tokenPermissions: [ ]
  , groupPermissions: SM.empty
  , loading: true
  , errored: false
  , sharingInput
  }

_userPermissions ∷ ∀ a r. Lens' {userPermissions ∷ a|r} a
_userPermissions = lens (_.userPermissions) (_{userPermissions = _})

_groupPermissions ∷ ∀ a r. Lens' {groupPermissions ∷ a |r} a
_groupPermissions = lens (_.groupPermissions) (_{groupPermissions = _})

_tokenPermissions ∷ ∀ a r. Lens' {tokenPermissions ∷ a|r} a
_tokenPermissions = lens (_.tokenPermissions) (_{tokenPermissions = _})

_loading ∷ ∀ a r. Lens' {loading ∷ a|r} a
_loading = lens (_.loading) (_{loading = _})

_errored ∷ ∀ a r. Lens' {errored ∷ a|r} a
_errored = lens (_.errored) (_{errored = _})

data Query a
  = Init a
  | SelectElement DOM.Event a
  | ChangePermissionResume String String a
  | Unshare String a
  | UnshareToken QTA.TokenId a
  | PreventDefault DOM.Event a
  | Done a

data Message = Dismiss

type AdjustedPermissions =
  { users ∷ SM.StrMap Permission
  , groups ∷ SM.StrMap Permission
  }

copyButtonRef ∷ QTA.TokenId → H.RefLabel
copyButtonRef tokenId = H.RefLabel $ "copy" <> QTA.runTokenId tokenId

component ∷ H.Component HH.HTML Query Model.SharingInput Message Slam
component =
  H.lifecycleComponent
    { render
    , eval
    , initialState
    , initializer: Just (H.action Init)
    , finalizer: Nothing
    , receiver: const Nothing
    }

render ∷ State → HTML
render state =
  HH.div
    [ HP.classes [ HH.ClassName "deck-dialog-unshare" ] ]
    [ HH.h4_ [ HH.text "Unshare deck" ]
    , HH.div
        [ HP.classes
            $ [ B.alert, B.alertInfo, HH.ClassName "share-loading" ]
            ⊕ if state.loading then [ ] else [ B.hidden ]
        ]
        [ HH.img [ HP.src "img/blue-spin.svg" ]
        , HH.text "Loading"
        ]

    , HH.div
        [ HP.classes
            $ [ HH.ClassName "deck-dialog-body" ]
            ⊕ (if state.loading then [ B.hidden ] else [ ])
        ]
        [ HH.form
            [ HE.onSubmit $ HE.input PreventDefault ]
            $ (if SM.isEmpty state.userPermissions
                 then
                   [ ]
                 else
                   [ HH.h5_ [ HH.text "Users" ] ]
                   ⊕ (foldMap renderUserOrGroup $ SM.toList state.userPermissions)
              )
            ⊕ (if SM.isEmpty state.groupPermissions
                 then
                   [ ]
                 else
                   [ HH.h5_ [ HH.text "Groups" ] ]
                   ⊕ (foldMap renderUserOrGroup $ SM.toList state.groupPermissions)
              )
            ⊕ (if Arr.null state.tokenPermissions
                 then
                   [ ]
                 else
                   [ HH.h5_ [ HH.text "Tokens" ]
                   , HK.div_ $ state.tokenPermissions <#> \token →
                      QTA.runTokenId token.tokenId × renderToken token
                   ]
              )
            ⊕ (if SM.isEmpty state.userPermissions
                  ∧ SM.isEmpty state.groupPermissions
                  ∧ Arr.null state.tokenPermissions
                  ∧ not state.errored
                 then
                   [ HH.div_
                       [ HH.text "This deck hasn't been shared with anyone." ]
                   ]
                 else [ ]
              )
        ]
    , let
        states =
          (foldMap (\x → [x.state]) state.userPermissions)
          ⊕ (foldMap (\x → [x.state]) state.groupPermissions)
          ⊕ (foldMap (\x → [x.state]) state.tokenPermissions)
        somethingErrored =
          F.any (\x → x ≡ Just ModifyError ∨ x ≡ Just RevokeError) states
        somethingHappening =
          F.any (\x → x ≡ Just Unsharing ∨ x ≡ Just Modifying) states
      in
       HH.div
        [ HP.classes
            $ [ HH.ClassName "deck-dialog-footer" ]
            ⊕ (if state.loading then [ B.hidden ] else [ ])
        ]
        [ HH.div
            [ HP.classes
                $ [ B.alert, B.alertDanger ]
                ⊕ (if state.errored ∨ somethingErrored then [ ] else [ B.hidden ])
            ]
            [ HH.text
                $ if state.errored
                  then
                    "Sharing information is unavailable. To access or change the "
                    ⊕ "sharing information for this deck please check your network connection "
                    ⊕ "and try again."

                  else
                    "This action couldn't be performed. "
                    ⊕ "Please check your network connection and try again."
            ]
        , HH.button
            [ HE.onClick (HE.input_ Done)
            , HP.type_ HP.ButtonButton
            , HP.classes [ B.btn, B.btnDefault ]
            , HP.disabled somethingHappening
            ]
            [ HH.text "Done" ]
        ]

    ]

renderUserOrGroup ∷ (String × Permission) → Array HTML
renderUserOrGroup (name × perm) =
  [ HH.div
      [ HP.class_ $ HH.ClassName "sd-unshare-subject" ]
      [ HH.label_ [ HH.text name ]
      , HH.div
          [ HP.classes $ if perm.state ≡ Just ModifyError then [ B.hasError ] else [ ] ]
          [ HH.select
              [ HP.classes [ B.formControl ]
              , HE.onValueChange (HE.input (ChangePermissionResume name))
              , HP.disabled $ perm.state ≡ Just Modifying ∨ perm.state ≡ Just Unsharing
              ]
              [ HH.option
                  [ HP.value "view"
                  , HP.selected $ perm.resume ≡ View
                  ]
                  [ HH.text
                      $ "View"
                      ⊕ if perm.state ≡ Just Modifying
                          then "..."
                          else ""
                  ]
              , HH.option
                  [ HP.value "edit"
                  , HP.selected $ perm.resume ≡ Edit
                  ]
                  [ HH.text
                      $ "Edit"
                      ⊕ if perm.state ≡ Just Modifying
                          then "..."
                          else ""
                  ]
              ]
          ]
      , HH.div
          [ HP.classes $ if perm.state ≡ Just RevokeError then [ B.hasError ] else [ ] ]
          [ HH.button
              [ HP.classes [ B.btn, B.btnPrimary ]
              , HE.onClick (HE.input_ (Unshare name))
              , HP.disabled $ perm.state ≡ Just Modifying ∨ perm.state ≡ Just Unsharing
              ]
              [ HH.text if perm.state ≡ Just Unsharing
                          then "Revoking..."
                          else "Unshare"
              ]
          ]
      ]
  ]

renderToken ∷ TokenPermission → HTML
renderToken token =
  HH.div
    [ HP.class_ $ HH.ClassName "sd-unshare-subject" ]
    [ HH.label_
        [ HH.text $ fromMaybe "Untitled token" token.name
        ]
    , HH.span
        [ HP.classes [ HH.ClassName "sd-unshare-subject-access-type" ] ]
        [ HH.text $ printShareResume token.resume ]
    , HH.div
        [ HP.classes
            $ [ HH.ClassName "sd-url" ]
            ⊕ if token.state ≡ Just ModifyError then [ B.hasError ] else [ ]
        ]
        [ HH.input
            [ HP.readOnly true
            , HP.title "Token secret"
            , HP.value token.secret
            , HE.onClick $ HE.input (SelectElement ∘ DOM.toEvent)
            , HP.disabled $ isJust token.state
        ]
        , HH.button
            [ HP.classes [ B.btn, B.btnDefault ]
            , HP.ref $ copyButtonRef token.tokenId
            , HP.disabled $ token.state ≡ Just Modifying ∨ token.state ≡ Just Unsharing
            ]
            [ glyph B.glyphiconCopy ]
        ]
    , HH.div
        [ HP.classes $ if token.state ≡ Just RevokeError then [ B.hasError ] else [ ] ]
        [ HH.div
            [ HP.class_ B.btnGroup ]
            [ HH.button
                [ HP.classes [ B.btn, B.btnPrimary ]
                , HE.onClick (HE.input_ (UnshareToken token.tokenId))
                , HP.disabled $ token.state ≡ Just Modifying ∨ token.state ≡ Just Unsharing
                ]
                [ HH.text if token.state ≡ Just Unsharing
                            then "Revoking..."
                            else "Unshare"
                ]
            ]
        ]
    ]

eval ∷ Query ~> DSL
eval = case _ of
  Init next → do
    _ ← fork do
      sharingInput ← H.gets _.sharingInput
      Q.tokenList >>= case _ of
        Left e →
          H.modify _ { errored = true }
        Right toks → do
          let tokenPerms = prepareAndFilterTokens toks sharingInput
          H.modify _ { tokenPermissions = tokenPerms }
          for_ tokenPerms initZClipboard
      Q.permissionList false >>= case _ of
        Left e →
          H.modify _
            { errored = true
            , loading = false
            }
        Right ps → do
          let adjusted = adjustPermissions ps sharingInput
          H.modify _
            { userPermissions = adjusted.users
            , groupPermissions = adjusted.groups
            , loading = false
            }
    pure next
-- eval (InitZClipboard token mbEl next) =
--   next <$ for_ mbEl \el → do
--     H.liftEff $ Z.make (htmlElementToElement el)
--       >>= Z.onCopy (Z.setData "text/plain" token)
  ChangePermissionResume name string next → do
    state ← H.get
    H.modify (_{errored = false})
    let
      mbUserPerms = SM.lookup name state.userPermissions
      mbGroupPerms = SM.lookup name state.groupPermissions
      newResume = case string of
        "view" → View
        _ → Edit
      oldResume = case string of
        "view" → Edit
        _ → View

    for_ mbUserPerms \perms → do
      H.modify
        $ (_userPermissions ∘ ix name ∘ _state ?~ Modifying)
        ∘ (_userPermissions ∘ ix name ∘ _resume .~ newResume)
      (succeeded × actionMap) ←
        changePermissionResumeForUser name state.sharingInput newResume perms
      H.modify
        $ (_userPermissions ∘ ix name ∘ _actions .~ actionMap)
        ∘ if succeeded
          then
            (_userPermissions ∘ ix name ∘ _state .~ Nothing)
          else
            (_userPermissions ∘ ix name ∘ _state ?~ ModifyError)
            ∘ (_userPermissions ∘ ix name ∘ _resume .~ oldResume)

    for_ mbGroupPerms \perms → do
      H.modify
        $ (_groupPermissions ∘ ix name ∘ _state ?~ Modifying)
        ∘ (_groupPermissions ∘ ix name ∘ _resume .~ newResume)

      (succeeded × actionMap)  ←
        changePermissionResumeForGroup name state.sharingInput newResume perms
      H.modify
        $ (_groupPermissions ∘ ix name ∘ _actions .~ actionMap)
        ∘ if succeeded
          then
            (_groupPermissions ∘ ix name ∘ _state .~ Nothing)
          else
            (_groupPermissions ∘ ix name ∘ _state ?~ ModifyError)
            ∘ (_groupPermissions ∘ ix name ∘ _resume .~ oldResume)
    pure next
  UnshareToken tokenId next → do
    state ← H.get
    let mtix = Arr.findIndex (\x → x.tokenId ≡ tokenId) state.tokenPermissions
    for_ mtix \tix → do
      H.modify $ _tokenPermissions ∘ ix tix ∘ _state ?~ Unsharing
      Q.deleteToken tokenId >>= case _ of
        Left _ →
          H.modify
            $ (_tokenPermissions ∘ ix tix ∘ _state ?~ RevokeError)
            ∘ (_errored .~ false)
        Right _ →
          H.modify
            $ _tokenPermissions %~ Arr.filter (\x → x.tokenId ≠ tokenId)
    pure next
  Unshare name next → do
    state ← H.get
    H.modify _ { errored = false }
    let
      mbUserPerms = SM.lookup name state.userPermissions
      mbGroupPerms = SM.lookup name state.groupPermissions

    for_ mbUserPerms \userPerms → do
      H.modify $ _userPermissions ∘ ix name ∘ _state ?~ Unsharing
      leftPids ← deletePermission userPerms.actions
      if Map.isEmpty leftPids
        then
          H.modify
            $ (_userPermissions %~ SM.delete name)
            ∘ (_userPermissions ∘ ix name ∘ _state .~ Nothing)
        else
          H.modify
            $ (_userPermissions ∘ ix name ∘ _actions .~ leftPids)
            ∘ (_userPermissions ∘ ix name ∘ _state ?~ RevokeError)

    for_ mbGroupPerms \groupPerms → do
      H.modify $ _groupPermissions ∘ ix name ∘ _state ?~ Unsharing
      leftPids ← deletePermission groupPerms.actions
      if Map.isEmpty leftPids
        then
          H.modify
            $ (_groupPermissions ∘ ix name ∘ _state .~ Nothing)
            ∘ (_groupPermissions %~ SM.delete name)
        else
          H.modify
            $ (_groupPermissions ∘ ix name ∘ _actions .~ leftPids)
            ∘ (_groupPermissions ∘ ix name ∘ _state ?~ RevokeError)
    pure next
  SelectElement ev next → do
    H.liftEff $ DOM.currentTarget
      # readHTMLElement ∘ toForeign
      # runExcept
      # traverse_ select
    pure next
  PreventDefault ev next →
    H.liftEff (DOM.preventDefault ev) $> next
  Done next →
    H.raise Dismiss $> next

initZClipboard ∷ TokenPermission → DSL Unit
initZClipboard token =
  H.getHTMLElementRef (copyButtonRef token.tokenId) >>= traverse_ \htmlEl →
    H.liftEff $ Z.make (htmlElementToElement htmlEl)
      >>= Z.onCopy (Z.setData "text/plain" token.secret)

changePermissionResumeForUser
  ∷ String
  → Model.SharingInput
  → ShareResume
  → Permission
  → DSL (Boolean × (Map.Map QTA.PermissionId QTA.ActionR))
changePermissionResumeForUser name sharingInput res perm = do
  leftPids ← deletePermission perm.actions
  if not $ Map.isEmpty leftPids
    then
    pure $ false × leftPids
    else do
    let
      actions = Model.sharingActions sharingInput res
      shareRequest =
        { users: [ QTA.UserId name ]
        , groups: [ ]
        , actions
        }
    shareRes ← Q.sharePermission shareRequest
    case shareRes of
      Left _ → pure $ false × Map.empty
      Right ps → pure $ true × foldMap (\p → Map.singleton p.id p.action) ps

changePermissionResumeForGroup
  ∷ String
  → Model.SharingInput
  → ShareResume
  → Permission
  → DSL (Boolean × (Map.Map QTA.PermissionId QTA.ActionR))
changePermissionResumeForGroup name sharingInput res perm =
  case parseFilePath name of
    Nothing → pure $ false × perm.actions
    Just groupPath → do
      leftPids ← deletePermission perm.actions
      if not $ Map.isEmpty leftPids
        then
        pure $ false × leftPids
        else do
        let
          actions = Model.sharingActions sharingInput res
          shareRequest =
            { users: [ ]
            , groups: [ Right groupPath ]
            , actions
            }
        shareRes ← Q.sharePermission shareRequest
        case shareRes of
          Left _ → pure $ false × Map.empty
          Right ps → pure $ true × foldMap (\p → Map.singleton p.id p.action) ps

deletePermission
  ∷ Map.Map QTA.PermissionId QTA.ActionR
  → DSL (Map.Map QTA.PermissionId QTA.ActionR)
deletePermission permissionMap = do
  r ← H.liftEff $ newRef $ Map.empty × Map.size permissionMap
  resultVar ← H.liftAff makeVar
  H.lift $ chunkedParTraverse (go r resultVar) (Map.toList permissionMap) (splitList 20) L.concat
  H.liftAff $ takeVar resultVar
  where
  go r resultVar (pid × act) = do
    result ← Q.deletePermission pid
    H.liftEff $ modifyRef r \(acc × count) → acc × (count - 1)
    case result of
      Left _ → H.liftEff $ modifyRef r \(acc × count) → (Map.insert pid act acc) × count
      Right _ → pure unit
    (acc × count) ← H.liftEff $ readRef r
    when (count ≡ 0) $ H.liftAff $ putVar resultVar acc

adjustPermissions ∷ Array QTA.PermissionR → Model.SharingInput → AdjustedPermissions
adjustPermissions prs sharingInput =
  let
    folded = foldl foldFn Map.empty prs
    foldFn mp pr =
      Map.alter (alterFn pr) pr.grantedTo mp

    alterFn pr Nothing = Just [ pr ]
    alterFn pr (Just arr) = Just $ Arr.cons pr arr

    sharingActionsEdit =
      Set.fromFoldable $ map QTA.Action $ Model.sharingActions sharingInput Edit
    sharingActionsView =
      Set.fromFoldable $ map QTA.Action $ Model.sharingActions sharingInput View

    obj = foldl objFoldFn { users: SM.empty, groups: SM.empty } $ Map.toList folded

    -- Set.subset is sooooo slow :( @crygoenian
    subset ∷ ∀ a. Ord a ⇒ Set.Set a → Set.Set a → Boolean
    subset needle hay =
      let
        needleLst = L.sort $ L.fromFoldable needle
        hayLst = L.sort $ L.fromFoldable hay

        subset' ∷ L.List a → L.List a → Boolean
        subset' L.Nil _ = true
        subset' _ L.Nil = false
        subset' needle'@(L.Cons x xs) (L.Cons y ys) =
          if x ≡ y
          then subset' xs ys
          else subset' needle' ys
      in subset' needleLst hayLst

    objFoldFn acc@{ users, groups } (key × arr) =
      let
        actions = foldMap (\a → Map.singleton a.id a.action) arr
        actionsSet = Set.fromFoldable $ map QTA.Action actions
        perm = { resume: View
               , actions
               , state: Nothing
               }
      in case key of
        QTA.TokenGranted _ → acc
        QTA.UserGranted (QTA.UserId uid) →
          let
            res
              | subset sharingActionsEdit actionsSet =
                acc{users = SM.insert uid perm{resume = Edit} users }
              | subset sharingActionsView actionsSet =
                acc{users = SM.insert uid perm users}
              | otherwise = acc
          in res
        QTA.GroupGranted pt →
          let
            gid = either QTA.printRoot Pt.printPath pt
            res
              | subset sharingActionsEdit actionsSet =
                acc{groups = SM.insert gid perm{resume = Edit} groups }
              | subset sharingActionsView actionsSet =
                acc{groups = SM.insert gid perm groups}
              | otherwise = acc
          in res
  in obj

prepareAndFilterTokens ∷ Array QTA.TokenR → Model.SharingInput →  Array TokenPermission
prepareAndFilterTokens toks sharingInput =
  foldMap foldFn toks
  where
  foldFn ∷ QTA.TokenR → Array TokenPermission
  foldFn tr =
    let
      sharingActionsEdit =
        Set.fromFoldable $ map QTA.Action $ Model.sharingActions sharingInput Edit
      sharingActionsView =
        Set.fromFoldable $ map QTA.Action $ Model.sharingActions sharingInput View
      actions =
        Set.fromFoldable $ map QTA.Action tr.actions
      preToken =
        { name: map QTA.runTokenName tr.name
        , secret: QTA.runTokenHash tr.secret
        , tokenId: tr.id
        , state: Nothing
        , resume: View
        }
      res
        | sharingActionsEdit ≡ actions =
          [ preToken{resume = Edit} ]
        | sharingActionsView ≡ actions =
          [ preToken ]
        | otherwise =
            [ ]
    in
      res

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.Workspace.Deck.Dialog.Unshare.Component where

import SlamData.Prelude

import Control.Monad.Aff.AVar (makeVar, takeVar, putVar)
import Control.Monad.Eff.Ref (newRef, modifyRef, readRef)
import Control.UI.Browser (select)

import Data.Array as Arr
import Data.Foldable as F
import Data.Lens (Lens', lens, (.~), (%~), (?~))
import Data.Lens.Index (ix)
import Data.List as L
import Data.Set as Set
import Data.Map as Map
import Data.StrMap as SM
import Data.Path.Pathy as Pt

import DOM.HTML.Types (HTMLElement, htmlElementToElement)

import Halogen as H
import Halogen.HTML.Events as HE
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import Halogen.Themes.Bootstrap3 as B
import Halogen.CustomProps as Cp

import Quasar.Advanced.Types as QTA

import SlamData.Monad (Slam)
import SlamData.Quasar.Security as Q
import SlamData.Render.Common (glyph)
import SlamData.Workspace.Deck.Dialog.Share.Model (ShareResume(..), printShareResume)
import SlamData.Workspace.Deck.Dialog.Share.Model as Model

import Utils.Path (parseFilePath)
import Utils.Foldable (chunkedParTraverse, splitList)

import ZClipboard as Z

type HTML = H.ComponentHTML Query
type DSL = H.ComponentDSL State Query Slam

type PermissionId = Set.Set QTA.PermissionId

data PermissionState
  = Unsharing
  | Modifying
  | RevokeError
  | ModifyError

derive instance permissionStateEq ∷ Eq PermissionState

type Permission =
  { resume ∷ ShareResume
  , actions ∷ Map.Map QTA.PermissionId QTA.ActionR
  , state ∷ Maybe PermissionState
  }

data Modifyable = User | Group

type TokenPermission =
  { name ∷ Maybe String
  , secret ∷ String
  , resume ∷ ShareResume
  , tokenId ∷ QTA.TokenId
  , state ∷ Maybe PermissionState
  }

_resume ∷ ∀ a r. Lens' {resume ∷ a|r} a
_resume = lens (_.resume) (_{resume = _})

_tokenId ∷ ∀ a r. Lens' {tokenId ∷ a|r} a
_tokenId = lens (_.tokenId) (_{tokenId = _})

_secret ∷ ∀ a r. Lens' {secret ∷ a|r} a
_secret = lens (_.secret) (_{secret = _})

-- :( `ix` doesn't work without `Maybe PermissionState`
_state ∷ ∀ r. Lens' {state ∷ (Maybe PermissionState)|r} (Maybe PermissionState)
_state = lens (_.state) (_{state = _})

_actions
  ∷ ∀ r
  . Lens'
      {actions ∷ Map.Map QTA.PermissionId QTA.ActionR|r}
      (Map.Map QTA.PermissionId QTA.ActionR)
_actions = lens (_.actions) (_{actions = _})

type State =
  { userPermissions ∷ SM.StrMap Permission
  , tokenPermissions ∷ Array TokenPermission
  , groupPermissions ∷ SM.StrMap Permission
  , loading ∷ Boolean
  , errored ∷ Boolean
  , sharingInput ∷ Model.SharingInput
  }

initialState ∷ Model.SharingInput → State
initialState sharingInput =
  { userPermissions: SM.empty
  , tokenPermissions: [ ]
  , groupPermissions: SM.empty
  , loading: true
  , errored: false
  , sharingInput
  }

_userPermissions ∷ ∀ a r. Lens' {userPermissions ∷ a|r} a
_userPermissions = lens (_.userPermissions) (_{userPermissions = _})

_groupPermissions ∷ ∀ a r. Lens' {groupPermissions ∷ a |r} a
_groupPermissions = lens (_.groupPermissions) (_{groupPermissions = _})

_tokenPermissions ∷ ∀ a r. Lens' {tokenPermissions ∷ a|r} a
_tokenPermissions = lens (_.tokenPermissions) (_{tokenPermissions = _})

_loading ∷ ∀ a r. Lens' {loading ∷ a|r} a
_loading = lens (_.loading) (_{loading = _})

_errored ∷ ∀ a r. Lens' {errored ∷ a|r} a
_errored = lens (_.errored) (_{errored = _})

data Query a
  = Dismiss a
  | InitZClipboard String (Maybe HTMLElement) a
  | Init a
  | SelectElement HTMLElement a
  | PermissionResumeChanged String String a
  | Unshare String a
  | UnshareToken QTA.TokenId  a

type AdjustedPermissions =
  { users ∷ SM.StrMap Permission
  , groups ∷ SM.StrMap Permission
  }

comp ∷ H.Component State Query Slam
comp =
  H.lifecycleComponent
    { render
    , eval
    , initializer: Just (H.action Init)
    , finalizer: Nothing
    }

render ∷ State → HTML
render state =
  HH.div
    [ HP.classes [ HH.ClassName "deck-dialog-unshare" ] ]
    [ HH.h4_ [ HH.text "Unshare deck" ]
    , HH.div
        [ HP.classes
            $ [ B.alert, B.alertInfo, HH.ClassName "share-loading" ]
            ⊕ if state.loading then [ ] else [ B.hidden ]
        ]
        [ HH.img [ HP.src "img/blue-spin.svg" ]
        , HH.text "Loading"
        ]

    , HH.div
        [ HP.classes
            $ [ HH.ClassName "deck-dialog-body" ]
            ⊕ (if state.loading then [ B.hidden ] else [ ])
        ]
        [ HH.form
            [ Cp.nonSubmit ]
            $ (if SM.isEmpty state.userPermissions
                 then
                   [ ]
                 else
                   [ HH.h5_ [ HH.text "Users" ] ]
                   ⊕ (foldMap renderUserOrGroup $ SM.toList state.userPermissions)
              )
            ⊕ (if SM.isEmpty state.groupPermissions
                 then
                   [ ]
                 else
                   [ HH.h5_ [ HH.text "Groups" ] ]
                   ⊕ (foldMap renderUserOrGroup $ SM.toList state.groupPermissions)
              )
            ⊕ (if Arr.null state.tokenPermissions
                 then
                   [ ]
                 else
                   [ HH.h5_ [ HH.text "Tokens" ] ]
                   ⊕ map renderToken state.tokenPermissions
              )
            ⊕ (if SM.isEmpty state.userPermissions
                  ∧ SM.isEmpty state.groupPermissions
                  ∧ Arr.null state.tokenPermissions
                  ∧ not state.errored
                 then
                   [ HH.div_
                       [ HH.text "This deck hasn't been shared with anyone." ]
                   ]
                 else [ ]
              )
        ]
    , let
        states =
          (foldMap (\x → [x.state]) state.userPermissions)
          ⊕ (foldMap (\x → [x.state]) state.groupPermissions)
          ⊕ (foldMap (\x → [x.state]) state.tokenPermissions)
        somethingErrored =
          F.any (\x → x ≡ Just ModifyError ∨ x ≡ Just RevokeError) states
        somethingHappening =
          F.any (\x → x ≡ Just Unsharing ∨ x ≡ Just Modifying) states
      in
       HH.div
        [ HP.classes
            $ [ HH.ClassName "deck-dialog-footer" ]
            ⊕ (if state.loading then [ B.hidden ] else [ ])
        ]
        [ HH.div
            [ HP.classes
                $ [ B.alert, B.alertDanger ]
                ⊕ (if state.errored ∨ somethingErrored then [ ] else [ B.hidden ])
            ]
            [ HH.text
                $ if state.errored
                  then
                    "Sharing information is unavailable. To access or change the "
                    ⊕ "sharing information for this deck please check your network connection "
                    ⊕ "and try again."

                  else
                    "This action couldn't be performed. "
                    ⊕ "Please check your network connection and try again."

            ]

        , HH.button
            [ HE.onClick (HE.input_ Dismiss)
            , HP.type_ HP.ButtonButton
            , HP.classes [ B.btn, B.btnDefault ]
            , HP.disabled somethingHappening
            ]
            [ HH.text "Done" ]
        ]

    ]

renderUserOrGroup ∷ (String × Permission) → Array HTML
renderUserOrGroup (name × perm) =
  [ HH.div
      [ HP.class_ $ HH.ClassName "sd-unshare-subject" ]
      [ HH.label_ [ HH.text name ]
      , HH.div
          [ HP.classes $ if perm.state ≡ Just ModifyError then [ B.hasError ] else [ ] ]
          [ HH.select
              [ HP.classes [ B.formControl ]
              , HE.onValueChange (HE.input (PermissionResumeChanged name))
              , HP.disabled $ perm.state ≡ Just Modifying ∨ perm.state ≡ Just Unsharing
              ]
              [ HH.option
                  [ HP.value "view"
                  , HP.selected $ perm.resume ≡ View
                  ]
                  [ HH.text
                      $ "View"
                      ⊕ if perm.state ≡ Just Modifying
                          then "..."
                          else ""
                  ]
              , HH.option
                  [ HP.value "edit"
                  , HP.selected $ perm.resume ≡ Edit
                  ]
                  [ HH.text
                      $ "Edit"
                      ⊕ if perm.state ≡ Just Modifying
                          then "..."
                          else ""
                  ]
              ]
          ]
      , HH.div
          [ HP.classes $ if perm.state ≡ Just RevokeError then [ B.hasError ] else [ ] ]
          [ HH.button
              [ HP.classes [ B.btn, B.btnPrimary ]
              , HE.onClick (HE.input_ (Unshare name))
              , HP.disabled $ perm.state ≡ Just Modifying ∨ perm.state ≡ Just Unsharing
              ]
              [ HH.text if perm.state ≡ Just Unsharing
                          then "Revoking..."
                          else "Unshare"
              ]
          ]
      ]
  ]

renderToken ∷ TokenPermission → HTML
renderToken token =
  HH.div
    [ HP.class_ $ HH.ClassName "sd-unshare-subject" ]
    [ HH.label_
        [ HH.text $ fromMaybe "Untitled token" token.name
        ]
    , HH.span
        [ HP.classes [ HH.ClassName "sd-unshare-subject-access-type" ] ]
        [ HH.text $ printShareResume token.resume ]
    , HH.div
        [ HP.classes
            $ [ HH.ClassName "sd-url" ]
            ⊕ if token.state ≡ Just ModifyError then [ B.hasError ] else [ ]
        ]
        [ HH.input
            [ HP.readonly true
            , HP.title "Token secret"
            , HP.value token.secret
            , HE.onClick $ HE.input (SelectElement ∘ _.target)
            , HP.disabled $ isJust token.state
        ]
        , HH.button
            [ HP.classes [ B.btn, B.btnDefault ]
            , HP.ref (H.action ∘ InitZClipboard token.secret)
            , HP.disabled $ token.state ≡ Just Modifying ∨ token.state ≡ Just Unsharing
            ]
            [ glyph B.glyphiconCopy ]
        ]
    , HH.div
        [ HP.classes $ if token.state ≡ Just RevokeError then [ B.hasError ] else [ ] ]
        [ HH.div
            [ HP.class_ B.btnGroup ]
            [ HH.button
                [ HP.classes [ B.btn, B.btnPrimary ]
                , HE.onClick (HE.input_ (UnshareToken token.tokenId))
                , HP.disabled $ token.state ≡ Just Modifying ∨ token.state ≡ Just Unsharing
                ]
                [ HH.text if token.state ≡ Just Unsharing
                            then "Revoking..."
                            else "Unshare"
                ]
            ]
        ]
  ]

eval ∷ Query ~> DSL
eval (Init next) = next <$ do
  tokensRes ← Q.tokenList
  sharingInput ← H.gets _.sharingInput
  case tokensRes of
    Left e → H.modify (_{errored = true})
    Right toks →
      let
        tokenPerms = prepareAndFilterTokens toks sharingInput
      in
        H.modify (_{tokenPermissions = tokenPerms})

  permsRes ← Q.permissionList false
  case permsRes of
    Left e → H.modify (_{errored = true})
    Right ps →
      let
        adjusted = adjustPermissions ps sharingInput
      in
        H.modify (_{ userPermissions = adjusted.users
                   , groupPermissions = adjusted.groups
                   })
  H.modify (_{ loading = false})
eval (InitZClipboard token mbEl next) =
  next <$ for_ mbEl \el → do
    H.liftEff $ Z.make (htmlElementToElement el)
      >>= Z.onCopy (Z.setData "text/plain" token)
eval (Dismiss next) = pure next
eval (SelectElement el next) =
  next <$ H.liftEff (select el)
eval (PermissionResumeChanged name string next) = next <$ do
  state ← H.get
  H.modify (_{errored = false})
  let
    mbUserPerms = SM.lookup name state.userPermissions
    mbGroupPerms = SM.lookup name state.groupPermissions

    newResume | string ≡ "view" = View
              | otherwise = Edit

    oldResume | string ≡ "view" = Edit
              | otherwise = View

  for_ mbUserPerms \perms → do
    H.modify
      $ (_userPermissions ∘ ix name ∘ _state ?~ Modifying)
      ∘ (_userPermissions ∘ ix name ∘ _resume .~ newResume)
    (succeeded × actionMap) ←
      changePermissionResumeForUser name state.sharingInput newResume perms
    H.modify
      $ (_userPermissions ∘ ix name ∘ _actions .~ actionMap)
      ∘ if succeeded
        then
          (_userPermissions ∘ ix name ∘ _state .~ Nothing)
        else
          (_userPermissions ∘ ix name ∘ _state ?~ ModifyError)
          ∘ (_userPermissions ∘ ix name ∘ _resume .~ oldResume)

  for_ mbGroupPerms \perms → do
    H.modify
      $ (_groupPermissions ∘ ix name ∘ _state ?~ Modifying)
      ∘ (_groupPermissions ∘ ix name ∘ _resume .~ newResume)

    (succeeded × actionMap)  ←
      changePermissionResumeForGroup name state.sharingInput newResume perms
    H.modify
      $ (_groupPermissions ∘ ix name ∘ _actions .~ actionMap)
      ∘ if succeeded
        then
          (_groupPermissions ∘ ix name ∘ _state .~ Nothing)
        else
          (_groupPermissions ∘ ix name ∘ _state ?~ ModifyError)
          ∘ (_groupPermissions ∘ ix name ∘ _resume .~ oldResume)

eval (UnshareToken tokenId next) = next <$ do
  state ← H.get
  let
    mtix = Arr.findIndex (\x → x.tokenId ≡ tokenId) state.tokenPermissions

  for_ mtix \tix → do
    H.modify $ _tokenPermissions ∘ ix tix ∘ _state ?~ Unsharing

    Q.deleteToken tokenId >>= case _ of
      Left _ →
        H.modify
          $ (_tokenPermissions ∘ ix tix ∘ _state ?~ RevokeError)
          ∘ (_errored .~ false)

      Right _ →
        H.modify
          $ _tokenPermissions %~ Arr.filter (\x → x.tokenId ≠ tokenId)

eval (Unshare name next) = next <$ do
  state ← H.get
  H.modify (_{errored = false})
  let
    mbUserPerms = SM.lookup name state.userPermissions
    mbGroupPerms = SM.lookup name state.groupPermissions

  for_ mbUserPerms \userPerms → do
    H.modify $ _userPermissions ∘ ix name ∘ _state ?~ Unsharing
    leftPids ← deletePermission userPerms.actions
    H.modify
      if Map.isEmpty leftPids
        then
        (_userPermissions %~ SM.delete name)
        ∘ (_userPermissions ∘ ix name ∘ _state .~ Nothing)
        else
        (_userPermissions ∘ ix name ∘ _actions .~ leftPids)
        ∘ (_userPermissions ∘ ix name ∘ _state ?~ RevokeError)

  for_ mbGroupPerms \groupPerms → do
    H.modify $ _groupPermissions ∘ ix name ∘ _state ?~ Unsharing
    leftPids ← deletePermission groupPerms.actions
    H.modify
      if Map.isEmpty leftPids
        then
        (_groupPermissions ∘ ix name ∘ _state .~ Nothing)
        ∘ (_groupPermissions %~ SM.delete name)
        else
        (_groupPermissions ∘ ix name ∘ _actions .~ leftPids)
        ∘ (_groupPermissions ∘ ix name ∘ _state ?~ RevokeError)

changePermissionResumeForUser
  ∷ String
  → Model.SharingInput
  → ShareResume
  → Permission
  → DSL (Boolean × (Map.Map QTA.PermissionId QTA.ActionR))
changePermissionResumeForUser name sharingInput res perm = do
  leftPids ← deletePermission perm.actions
  if not $ Map.isEmpty leftPids
    then
    pure $ false × leftPids
    else do
    let
      actions = Model.sharingActions sharingInput res
      shareRequest =
        { users: [ QTA.UserId name ]
        , groups: [ ]
        , actions
        }
    shareRes ← Q.sharePermission shareRequest
    case shareRes of
      Left _ → pure $ false × Map.empty
      Right ps → pure $ true × foldMap (\p → Map.singleton p.id p.action) ps

changePermissionResumeForGroup
  ∷ String
  → Model.SharingInput
  → ShareResume
  → Permission
  → DSL (Boolean × (Map.Map QTA.PermissionId QTA.ActionR))
changePermissionResumeForGroup name sharingInput res perm =
  case parseFilePath name of
    Nothing → pure $ false × perm.actions
    Just groupPath → do
      leftPids ← deletePermission perm.actions
      if not $ Map.isEmpty leftPids
        then
        pure $ false × leftPids
        else do
        let
          actions = Model.sharingActions sharingInput res
          shareRequest =
            { users: [ ]
            , groups: [ Right groupPath ]
            , actions
            }
        shareRes ← Q.sharePermission shareRequest
        case shareRes of
          Left _ → pure $ false × Map.empty
          Right ps → pure $ true × foldMap (\p → Map.singleton p.id p.action) ps

deletePermission
  ∷ Map.Map QTA.PermissionId QTA.ActionR
  → DSL (Map.Map QTA.PermissionId QTA.ActionR)
deletePermission permissionMap = do
  r ← H.liftEff $ newRef $ Map.empty × Map.size permissionMap
  resultVar ← H.liftAff makeVar
  H.liftH $ chunkedParTraverse (go r resultVar) (Map.toList permissionMap) (splitList 20) L.concat
  H.liftAff $ takeVar resultVar
  where
  go r resultVar (pid × act) = do
    result ← Q.deletePermission pid
    H.liftEff $ modifyRef r \(acc × count) → acc × (count - 1)
    case result of
      Left _ → H.liftEff $ modifyRef r \(acc × count) → (Map.insert pid act acc) × count
      Right _ → pure unit
    (acc × count) ← H.liftEff $ readRef r
    when (count ≡ 0) $ H.liftAff $ putVar resultVar acc

adjustPermissions ∷ Array QTA.PermissionR → Model.SharingInput → AdjustedPermissions
adjustPermissions prs sharingInput =
  let
    folded = foldl foldFn Map.empty prs
    foldFn mp pr =
      Map.alter (alterFn pr) pr.grantedTo mp

    alterFn pr Nothing = Just [ pr ]
    alterFn pr (Just arr) = Just $ Arr.cons pr arr

    sharingActionsEdit =
      Set.fromFoldable $ map QTA.Action $ Model.sharingActions sharingInput Edit
    sharingActionsView =
      Set.fromFoldable $ map QTA.Action $ Model.sharingActions sharingInput View

    obj = foldl objFoldFn { users: SM.empty, groups: SM.empty } $ Map.toList folded

    -- Set.subset is sooooo slow :( @crygoenian
    subset ∷ ∀ a. Ord a ⇒ Set.Set a → Set.Set a → Boolean
    subset needle hay =
      let
        needleLst = L.sort $ L.fromFoldable needle
        hayLst = L.sort $ L.fromFoldable hay

        subset' ∷ L.List a → L.List a → Boolean
        subset' L.Nil _ = true
        subset' _ L.Nil = false
        subset' needle'@(L.Cons x xs) (L.Cons y ys) =
          if x ≡ y
          then subset' xs ys
          else subset' needle' ys
      in subset' needleLst hayLst

    objFoldFn acc@{ users, groups } (key × arr) =
      let
        actions = foldMap (\a → Map.singleton a.id a.action) arr
        actionsSet = Set.fromFoldable $ map QTA.Action actions
        perm = { resume: View
               , actions
               , state: Nothing
               }
      in case key of
        QTA.TokenGranted _ → acc
        QTA.UserGranted (QTA.UserId uid) →
          let
            res
              | subset sharingActionsEdit actionsSet =
                acc{users = SM.insert uid perm{resume = Edit} users }
              | subset sharingActionsView actionsSet =
                acc{users = SM.insert uid perm users}
              | otherwise = acc
          in res
        QTA.GroupGranted pt →
          let
            gid = either QTA.printRoot Pt.printPath pt
            res
              | subset sharingActionsEdit actionsSet =
                acc{groups = SM.insert gid perm{resume = Edit} groups }
              | subset sharingActionsView actionsSet =
                acc{groups = SM.insert gid perm groups}
              | otherwise = acc
          in res
  in obj

prepareAndFilterTokens ∷ Array QTA.TokenR → Model.SharingInput →  Array TokenPermission
prepareAndFilterTokens toks sharingInput =
  foldMap foldFn toks
  where
  foldFn ∷ QTA.TokenR → Array TokenPermission
  foldFn tr =
    let
      sharingActionsEdit =
        Set.fromFoldable $ map QTA.Action $ Model.sharingActions sharingInput Edit
      sharingActionsView =
        Set.fromFoldable $ map QTA.Action $ Model.sharingActions sharingInput View
      actions =
        Set.fromFoldable $ map QTA.Action tr.actions
      preToken =
        { name: map QTA.runTokenName tr.name
        , secret: QTA.runTokenHash tr.secret
        , tokenId: tr.id
        , state: Nothing
        , resume: View
        }
      res
        | sharingActionsEdit ≡ actions =
          [ preToken{resume = Edit} ]
        | sharingActionsView ≡ actions =
          [ preToken ]
        | otherwise =
            [ ]
    in
      res


Fix explore cell created from file browser

module Model.Notebook.Domain
  ( Notebook()
  , emptyNotebook
  , _cells
  , _dependencies
  , _activeCellId
  , _name
  , _path
  , _activeCell
  , cellById
  , Dependencies()
  , deps
  , addCell
  , insertCell
  , notebookPath
  , notebookURL
  , cellURL
  , cellOut
  ) where

import Data.Argonaut.Combinators ((~>), (:=), (.?))
import Data.Argonaut.Core (jsonEmptyObject)
import Data.Argonaut.Decode (DecodeJson, decodeJson)
import Data.Argonaut.Encode (EncodeJson, encodeJson)
import Data.Argonaut.Printer (printJson)
import Data.Array (length, sort, reverse, head, insertAt, findIndex, elemIndex, snoc)
import Data.Either (Either(..))
import Data.Map (Map(), insert, lookup, empty, toList, fromList)
import Data.Maybe (Maybe(..), maybe, fromMaybe)
import Data.Path.Pathy (rootDir, dir, file, (</>), printPath)
import Data.These (These(..), these, theseRight)
import Data.Tuple (Tuple(..))
import Model.Action (Action(), printAction)
import Model.Notebook.Cell (CellContent(..), CellId(), Cell(), _cellId, _output, newCell, _input, _parent, _FileInput)
import Model.Notebook.Cell.FileInput (_file, fileFromString, portFromFile)
import Model.Notebook.Port (Port(..), _PortResource)
import Model.Path (DirPath(), (<./>), encodeURIPath)
import Model.Resource (Resource(File))
import Network.HTTP.Affjax.Request (Requestable, toRequest)
import Optic.Core (lens, LensP(), (..), (.~), (^.))
import Optic.Extended (TraversalP())
import Optic.Fold ((^?))
import Optic.Index (ix)
import Optic.Refractor.Prism (_Right)

import qualified Data.StrMap as SM

newtype Notebook =
  Notebook { cells :: [Cell]
           , dependencies :: Dependencies
           , activeCellId :: CellId
           , name :: These String String
           , path :: DirPath
           }

emptyNotebook :: Notebook
emptyNotebook = Notebook
  { cells: []
  , dependencies: empty
  , activeCellId: 0
  , name: This Config.newNotebookName
  , path: rootDir
  }

_Notebook :: LensP Notebook _
_Notebook = lens (\(Notebook r) -> r) (\_ r -> Notebook r)

_cells :: LensP Notebook [Cell]
_cells = _Notebook .. lens _.cells _{cells = _}

_dependencies :: LensP Notebook Dependencies
_dependencies = _Notebook .. lens _.dependencies _{dependencies = _}

_activeCellId :: LensP Notebook CellId
_activeCellId = _Notebook .. lens _.activeCellId _{activeCellId = _}

_name :: LensP Notebook (These String String)
_name = _Notebook .. lens _.name _{name = _}

_path :: LensP Notebook DirPath
_path = _Notebook .. lens _.path _{path = _}

_activeCell :: TraversalP Notebook Cell
_activeCell f s = cellById (s ^. _activeCellId) f s

cellById :: CellId -> TraversalP Notebook Cell
cellById cellId f s =
  let i = findIndex (\cell -> cell ^. _cellId == cellId) (s ^. _cells)
  in (_cells .. ix i) f s

instance encodeJsonNotebook :: EncodeJson Notebook where
  encodeJson (Notebook obj)
    =  "cells" := obj.cells
    ~> "dependencies" := toList obj.dependencies
    ~> jsonEmptyObject

instance decodeJsonNotebook :: DecodeJson Notebook where
  decodeJson json = do
    obj <- decodeJson json
    cells <- obj .? "cells"
    dependencies <- obj .? "dependencies"
    return (emptyNotebook # (_cells .~ cells)
                         .. (_dependencies .~ fromList dependencies))

instance requestableNotebook :: Requestable Notebook where
  toRequest notebook =
    let str = printJson (encodeJson notebook) :: String
    in toRequest str

-- We have no any cells that have more than one
-- dependency right now. And have no ui to make
-- cell that has more than one deps.
type Dependencies = Map CellId CellId

deps :: CellId -> Dependencies -> [CellId]
deps cid ds = deps' cid ds []
  where
  deps' cid ds agg =
    case lookup cid ds of
      Nothing -> agg
      Just a -> deps' a ds (a : agg)

addCell :: CellContent -> Notebook -> Tuple Notebook Cell
addCell content oldNotebook@(Notebook n) = Tuple notebook cell'
  where
  newId = freeId oldNotebook
  cell = newCell newId content # (_output .~ cellOut content oldNotebook newId)
  cell' = case content of
    (Explore _) -> cell # (_input .~ maybe Closed PortResource (content ^? _FileInput .. _file .. _Right))
    _ -> cell
  notebook = Notebook $ n { cells = n.cells `snoc` cell'
                          , activeCellId = newId
                          }

insertCell :: Cell -> CellContent -> Notebook -> Tuple Notebook Cell
insertCell parent content oldNotebook@(Notebook n) = Tuple new cell
  where
  new = Notebook $ n { cells = insertAt (i + 1) cell n.cells
                     , dependencies = newDeps
                     }
  i = elemIndex parent n.cells
  newDeps = insert newId (parent ^. _cellId) n.dependencies
  newId = freeId oldNotebook
  input = parent ^. _output
  cell = newCell newId (content # _FileInput .. _file .~ maybe (Left "") Right (input ^? _PortResource))
         # (_output .~ port)
         ..(_input  .~ input)
         ..(_parent .~ Just (parent ^. _cellId))
  port = cellOut content oldNotebook newId

cellOut :: CellContent -> Notebook -> CellId -> Port
cellOut content n cid = case content of
  (Explore _) -> Closed
  (Visualize _) -> Closed
  (Markdown _) -> VarMap SM.empty
  _ -> these (const Closed) portRes (\_ -> portRes) (n ^. _name)
  where
  portRes :: String -> Port
  portRes _ = maybe Closed (\p -> PortResource $ File $ p </> file ("out" <> show cid)) (notebookPath n)

freeId :: Notebook -> CellId
freeId (Notebook n) =
  maybe 0 (+ 1) $ head $ reverse $ sort $ (^. _cellId) <$> n.cells

notebookPath :: Notebook -> Maybe DirPath
notebookPath nb = (\name -> (nb ^. _path) </> dir name <./> Config.notebookExtension) <$> theseRight (nb ^. _name)

notebookURL :: Notebook -> Action -> Maybe String
notebookURL nb act = (\path -> Config.notebookUrl ++ "#" ++ encodeURIPath (printPath path) ++ printAction act) <$> notebookPath nb

cellURL :: Notebook -> CellId -> Action -> Maybe String
cellURL nb cid act = (\path -> Config.notebookUrl ++ "#" ++ encodeURIPath (printPath path) ++ "cells" ++ "/" ++ show cid ++ "/" ++ printAction act) <$> notebookPath nb

module Model.Notebook.Domain
  ( Notebook()
  , emptyNotebook
  , _cells
  , _dependencies
  , _activeCellId
  , _name
  , _path
  , _activeCell
  , cellById
  , Dependencies()
  , deps
  , addCell
  , insertCell
  , notebookPath
  , notebookURL
  , cellURL
  , cellOut
  ) where

import Data.Argonaut.Combinators ((~>), (:=), (.?))
import Data.Argonaut.Core (jsonEmptyObject)
import Data.Argonaut.Decode (DecodeJson, decodeJson)
import Data.Argonaut.Encode (EncodeJson, encodeJson)
import Data.Argonaut.Printer (printJson)
import Data.Array (length, sort, reverse, head, insertAt, findIndex, elemIndex, snoc)
import Data.Either (Either(..))
import Data.Map (Map(), insert, lookup, empty, toList, fromList)
import Data.Maybe (Maybe(..), maybe, fromMaybe)
import Data.Path.Pathy (rootDir, dir, file, (</>), printPath)
import Data.These (These(..), these, theseRight)
import Data.Tuple (Tuple(..))
import Model.Notebook.Cell (CellContent(..), CellId(), Cell(), _cellId, _output, newCell, _input, _parent, _FileInput)
import Model.Notebook.Cell.FileInput (_file, fileFromString, portFromFile)
import Model.Notebook.Port (Port(..), _PortResource)
import Model.Action (Action(), printAction)
import Model.Path (DirPath(), (<./>), encodeURIPath)
import Model.Resource (Resource(File))
import Network.HTTP.Affjax.Request (Requestable, toRequest)
import Optic.Core (lens, LensP(), (..), (.~), (^.))
import Optic.Extended (TraversalP())
import Optic.Fold ((^?))
import Optic.Index (ix)

import qualified Data.StrMap as SM

newtype Notebook =
  Notebook { cells :: [Cell]
           , dependencies :: Dependencies
           , activeCellId :: CellId
           , name :: These String String
           , path :: DirPath
           }

emptyNotebook :: Notebook
emptyNotebook = Notebook
  { cells: []
  , dependencies: empty
  , activeCellId: 0
  , name: This Config.newNotebookName
  , path: rootDir
  }

_Notebook :: LensP Notebook _
_Notebook = lens (\(Notebook r) -> r) (\_ r -> Notebook r)

_cells :: LensP Notebook [Cell]
_cells = _Notebook .. lens _.cells _{cells = _}

_dependencies :: LensP Notebook Dependencies
_dependencies = _Notebook .. lens _.dependencies _{dependencies = _}

_activeCellId :: LensP Notebook CellId
_activeCellId = _Notebook .. lens _.activeCellId _{activeCellId = _}

_name :: LensP Notebook (These String String)
_name = _Notebook .. lens _.name _{name = _}

_path :: LensP Notebook DirPath
_path = _Notebook .. lens _.path _{path = _}

_activeCell :: TraversalP Notebook Cell
_activeCell f s = cellById (s ^. _activeCellId) f s

cellById :: CellId -> TraversalP Notebook Cell
cellById cellId f s =
  let i = findIndex (\cell -> cell ^. _cellId == cellId) (s ^. _cells)
  in (_cells .. ix i) f s

instance encodeJsonNotebook :: EncodeJson Notebook where
  encodeJson (Notebook obj)
    =  "cells" := obj.cells
    ~> "dependencies" := toList obj.dependencies
    ~> jsonEmptyObject

instance decodeJsonNotebook :: DecodeJson Notebook where
  decodeJson json = do
    obj <- decodeJson json
    cells <- obj .? "cells"
    dependencies <- obj .? "dependencies"
    return (emptyNotebook # (_cells .~ cells)
                         .. (_dependencies .~ fromList dependencies))

instance requestableNotebook :: Requestable Notebook where
  toRequest notebook =
    let str = printJson (encodeJson notebook) :: String
    in toRequest str

-- We have no any cells that have more than one
-- dependency right now. And have no ui to make
-- cell that has more than one deps.
type Dependencies = Map CellId CellId

deps :: CellId -> Dependencies -> [CellId]
deps cid ds = deps' cid ds []
  where
  deps' cid ds agg =
    case lookup cid ds of
      Nothing -> agg
      Just a -> deps' a ds (a : agg)

addCell :: CellContent -> Notebook -> Tuple Notebook Cell
addCell content oldNotebook@(Notebook n) = Tuple notebook cell
  where
  newId = freeId oldNotebook
  cell = newCell newId content # (_output .~ cellOut content oldNotebook newId)
  notebook = Notebook $ n { cells = n.cells `snoc` cell
                          , activeCellId = newId
                          }

insertCell :: Cell -> CellContent -> Notebook -> Tuple Notebook Cell
insertCell parent content oldNotebook@(Notebook n) = Tuple new cell
  where
  new = Notebook $ n { cells = insertAt (i + 1) cell n.cells
                     , dependencies = newDeps
                     }
  i = elemIndex parent n.cells
  newDeps = insert newId (parent ^. _cellId) n.dependencies
  newId = freeId oldNotebook
  input = parent ^. _output
  cell = newCell newId (content # _FileInput .. _file .~ maybe (Left "") Right (input ^? _PortResource))
         # (_output .~ port)
         ..(_input  .~ input)
         ..(_parent .~ Just (parent ^. _cellId))
  port = cellOut content oldNotebook newId

cellOut :: CellContent -> Notebook -> CellId -> Port
cellOut content n cid = case content of
  (Explore _) -> Closed
  (Visualize _) -> Closed
  (Markdown _) -> VarMap SM.empty
  _ -> these (const Closed) portRes (\_ -> portRes) (n ^. _name)
  where
  portRes :: String -> Port
  portRes _ = maybe Closed (\p -> PortResource $ File $ p </> file ("out" <> show cid)) (notebookPath n)

freeId :: Notebook -> CellId
freeId (Notebook n) =
  maybe 0 (+ 1) $ head $ reverse $ sort $ (^. _cellId) <$> n.cells

notebookPath :: Notebook -> Maybe DirPath
notebookPath nb = (\name -> (nb ^. _path) </> dir name <./> Config.notebookExtension) <$> theseRight (nb ^. _name)

notebookURL :: Notebook -> Action -> Maybe String
notebookURL nb act = (\path -> Config.notebookUrl ++ "#" ++ encodeURIPath (printPath path) ++ printAction act) <$> notebookPath nb

cellURL :: Notebook -> CellId -> Action -> Maybe String
cellURL nb cid act = (\path -> Config.notebookUrl ++ "#" ++ encodeURIPath (printPath path) ++ "cells" ++ "/" ++ show cid ++ "/" ++ printAction act) <$> notebookPath nb


Changed initial conditions to a much earlier state than the previous initial conditions

module Core where

import Prelude
import Data.Int.Bits
import Data.Tuple
import Data.Maybe
import Data.Either
import Control.Monad.Eff

import Types
import MainMem
import Ops
import OpCodeMap
import Gpu
import Utils
import Control.Monad.Rec.Class

import Debug

reset :: forall e. Array I8 -> Eff (canvas :: Canvas | e) Z80State
reset rom = do
  resetScreen
  return
    cleanState {
      mem = cleanMem {
        mainMem = setRom rom cleanMainMem
      }
    }

run :: forall e. Int -> Z80State -> Eff (canvas :: Canvas | e) Z80State
run interval state = tailRecM go { intr : interval, st : state }
 where
  go { st = st@{stop = true} } = return $ Right state
  go { intr, st } | intr <= 0 = return $ Right state
  go { intr, st } = do
    st' <- step st
    let elapsed = st'.totalM - st.totalM
    return $ Left { intr : (intr - elapsed), st : st' }

--NOTE Reg r should be increased by 1?
step :: forall e. Z80State -> Eff (canvas :: Canvas | e) Z80State
step state@{ mem = oldMem@{regs = oldRegs} } =
  hndlGpu <<< incTime <<< incPc oldRegs.pc <<< op $
    traceState $ state
 where
  incTime st@{totalM} = st
    { totalM = st.totalM + st.mem.regs.m }

  hndlGpu st = do
    gpu' <- gpuStep st.mem.regs.m (getGpu st.mem.mainMem)
    let intF' = (if gpu'.vblIntrr then (0x01 .|. _) else id) $ getIntF st.mem.mainMem
    return $ st { mem = st.mem { mainMem =
          setIntF intF'
      <<< setGpu (gpu' { vblIntrr = false })
       $  st.mem.mainMem } }

  op st = if shldHndlIntrr st
    then interruptOp st
    else regularOp st

  shldHndlIntrr st = getIme st.mem.mainMem && intBits st /= 0

  regularOp st = getOpcode (opCode st) basicOps $ st
  opCode st = rd8 st.mem.regs.pc st.mem.mainMem

  interruptOp :: Z80State -> Z80State
  interruptOp st = snd res $
    st { mem = st.mem {
      mainMem = setIme false <<< setIntF (fst res $ getIntF st.mem.mainMem) $ st.mem.mainMem } }
   where
    res :: Tuple (Int -> Int) (Z80State -> Z80State)
    res = fromMaybe (Tuple id id) mRes
    mRes = getOnBit (intBits st) >>= \x -> case x of
             1  -> Just $ Tuple (0xFE .&. _) (mm2op $ callRoutine 0x40)
             2  -> Just $ Tuple (0xFD .&. _) (mm2op $ callRoutine 0x48)
             4  -> Just $ Tuple (0xFB .&. _) (mm2op $ callRoutine 0x50)
             8  -> Just $ Tuple (0xF7 .&. _) (mm2op $ callRoutine 0x58)
             16 -> Just $ Tuple (0xEF .&. _) (mm2op $ callRoutine 0x60)
             otherwise -> Nothing -- NOTE log this

  intBits st = getIntE st.mem.mainMem .&. getIntF st.mem.mainMem

  --NOTE is there a better way to set nested properties?
  --consider checking the lens-equivalent in purescript.
  incPc oldPc st =
    if oldPc /= st.mem.regs.pc
      then st
      else
        st {
          mem = st.mem {
            regs = st.mem.regs {
              pc = 65535 .&. (st.mem.regs.pc + 1)
            }
          }
        }

cleanState :: Z80State
cleanState =
  { mem : cleanMem
  , totalM : 1
  , halt : false
  , stop : false
  }

cleanMem :: Mem
cleanMem =
  { regs : cleanRegs
  , svdRegs : cleanSavedRegs
  , mainMem : cleanMainMem
  }

cleanRegs :: Regs
cleanRegs =
  { pc    : 0x0101
  , sp    : 0xFFFE
  , m     : 0
  , a     : 0x01
  , b     : 0
  , c     : 0x13
  , d     : 0
  , e     : 0xD8
  , h     : 0x01
  , l     : 0x4D
  , f     : 0xB0
  , brTkn : false
  }

cleanSavedRegs :: SavedRegs
cleanSavedRegs =
  { a  : 0
  , b  : 0
  , c  : 0
  , d  : 0
  , e  : 0
  , h  : 0
  , l  : 0
  , f  : 0
  }

--Debug functions

traceState :: Z80State -> Z80State
traceState state@{ mem = oldMem@{regs = oldRegs} } =
  condTr shldTrc (\_ -> "-----------") $
  condTr shldTrc (\_ -> "totalM: "++show state.totalM) $

  {--condTr shldTrc (\_ -> tileMap0Str mem) $--}

  condTr shldTrc (\_ -> ioArea oldMem) $
  condTr shldTrc (\_ -> pcArea oldMem) $
  condTr shldTrc (\_ -> spArea oldMem) $

  {--condTr shldTrc (\_ -> "IntF: " ++ toHexStr 2 intF) $--}
  {--condTr shldTrc (\_ -> "IntE: " ++ toHexStr 2 intE) $--}
  {--condTr shldTrc (\_ -> "Ime: " ++ show (getIme state.mem.mainMem)) $--}
  {--condTr shldTrc (\_ -> "IntBits: " ++ toHexStr 2 intBits) $--}
  {--condTr shldTrc (\_ -> "getOnBit: " ++ show (getOnBit intBits)) $--}
  {--condTr shldTrc (\_ -> "shldHndlIntrr: " ++ show (shldHndlIntrr state)) $--}
  {--condTr shldTrc (\_ -> "intF after interruptop: " ++ toHexStr 2 (getIntF (interruptOp state).mem.mainMem)) $--}
  condTr shldTrc (\_ -> regsStr oldRegs) $
  {--condTr shldTrc (\_ -> rd8RangeStr "FF85" 0xFF85 0xFF85 mem) $--}
  state
 where
  shldTrc = true
  {--shldTrc = state.totalM >= 125000--}
  {--shldTrc = oldRegs.pc == 0x0371 || oldRegs.pc == 0x0200--}
  {--shldTrc2 = regs.pc == 0x0407--}

regsStr :: Regs -> String
regsStr regs = "af: " ++ af
          ++ "\nbc: " ++ bc
          ++ "\nde: " ++ de
          ++ "\nhl: " ++ hl
          ++ "\nsp: " ++ sp
          ++ "\npc: " ++ pc
 where
  af = toHexStr 4 $ joinRegs a f regs
  bc = toHexStr 4 $ joinRegs b c regs
  de = toHexStr 4 $ joinRegs d e regs
  hl = toHexStr 4 $ joinRegs h l regs
  sp = toHexStr 4 $ regs.sp
  pc = toHexStr 4 $ regs.pc

module Core where

import Prelude
import Data.Int.Bits
import Data.Tuple
import Data.Maybe
import Data.Either
import Control.Monad.Eff

import Types
import MainMem
import Ops
import OpCodeMap
import Gpu
import Utils
import Control.Monad.Rec.Class

import Debug

reset :: forall e. Array I8 -> Eff (canvas :: Canvas | e) Z80State
reset rom = do
  resetScreen
  return
    cleanState {
      mem = cleanMem {
        mainMem = setRom rom cleanMainMem
      }
    }

run :: forall e. Int -> Z80State -> Eff (canvas :: Canvas | e) Z80State
run interval state = tailRecM go { intr : interval, st : state }
 where
  go { st = st@{stop = true} } = return $ Right state
  go { intr, st } | intr <= 0 = return $ Right state
  go { intr, st } = do
    st' <- step st
    let elapsed = st'.totalM - st.totalM
    return $ Left { intr : (intr - elapsed), st : st' }

--NOTE Reg r should be increased by 1?
step :: forall e. Z80State -> Eff (canvas :: Canvas | e) Z80State
step state@{ mem = oldMem@{regs = oldRegs} } =
  hndlGpu <<< incTime <<< incPc oldRegs.pc <<< op $
    traceState $ state
 where
  incTime st@{totalM} = st
    { totalM = st.totalM + st.mem.regs.m }

  hndlGpu st = do
    gpu' <- gpuStep st.mem.regs.m (getGpu st.mem.mainMem)
    let intF' = (if gpu'.vblIntrr then (0x01 .|. _) else id) $ getIntF st.mem.mainMem
    return $ st { mem = st.mem { mainMem =
          setIntF intF'
      <<< setGpu (gpu' { vblIntrr = false })
       $  st.mem.mainMem } }

  op st = if shldHndlIntrr st
    then interruptOp st
    else regularOp st

  shldHndlIntrr st = getIme st.mem.mainMem && intBits st /= 0

  regularOp st = getOpcode (opCode st) basicOps $ st
  opCode st = rd8 st.mem.regs.pc st.mem.mainMem

  interruptOp :: Z80State -> Z80State
  interruptOp st = snd res $
    st { mem = st.mem {
      mainMem = setIme false <<< setIntF (fst res $ getIntF st.mem.mainMem) $ st.mem.mainMem } }
   where
    res :: Tuple (Int -> Int) (Z80State -> Z80State)
    res = fromMaybe (Tuple id id) mRes
    mRes = getOnBit (intBits st) >>= \x -> case x of
             1  -> Just $ Tuple (0xFE .&. _) (mm2op $ callRoutine 0x40)
             2  -> Just $ Tuple (0xFD .&. _) (mm2op $ callRoutine 0x48)
             4  -> Just $ Tuple (0xFB .&. _) (mm2op $ callRoutine 0x50)
             8  -> Just $ Tuple (0xF7 .&. _) (mm2op $ callRoutine 0x58)
             16 -> Just $ Tuple (0xEF .&. _) (mm2op $ callRoutine 0x60)
             otherwise -> Nothing -- NOTE log this

  intBits st = getIntE st.mem.mainMem .&. getIntF st.mem.mainMem

  --NOTE is there a better way to set nested properties?
  --consider checking the lens-equivalent in purescript.
  incPc oldPc st =
    if oldPc /= st.mem.regs.pc
      then st
      else
        st {
          mem = st.mem {
            regs = st.mem.regs {
              pc = 65535 .&. (st.mem.regs.pc + 1)
            }
          }
        }

cleanState :: Z80State
cleanState =
  { mem : cleanMem
  , totalM : 0
  , halt : false
  , stop : false
  }

cleanMem :: Mem
cleanMem =
  { regs : cleanRegs
  , svdRegs : cleanSavedRegs
  , mainMem : cleanMainMem
  }

cleanRegs :: Regs
cleanRegs =
  { pc : 0x0200
  , sp : 0xCFF7
  , ime : true
  , m  : 0
  , a  : 0
  , b  : 0
  , c  : 0
  , d  : 0
  , e  : 0xD8
  , h  : 0x97
  , l  : 0xFF
  , f  : 0x80
  }

cleanSavedRegs :: SavedRegs
cleanSavedRegs =
  { a  : 0
  , b  : 0
  , c  : 0
  , d  : 0
  , e  : 0
  , h  : 0
  , l  : 0
  , f  : 0
  }

--Debug functions

traceState :: Z80State -> Z80State
traceState state@{ mem = oldMem@{regs = oldRegs} } =
  condTr shldTrc (\_ -> "-----------") $
  condTr shldTrc (\_ -> "totalM: "++show state.totalM) $

  {--condTr shldTrc (\_ -> tileMap0Str mem) $--}

  condTr shldTrc (\_ -> ioArea oldMem) $
  condTr shldTrc (\_ -> pcArea oldMem) $
  condTr shldTrc (\_ -> spArea oldMem) $

  {--condTr shldTrc (\_ -> "IntF: " ++ toHexStr 2 intF) $--}
  {--condTr shldTrc (\_ -> "IntE: " ++ toHexStr 2 intE) $--}
  {--condTr shldTrc (\_ -> "Ime: " ++ show (getIme state.mem.mainMem)) $--}
  {--condTr shldTrc (\_ -> "IntBits: " ++ toHexStr 2 intBits) $--}
  {--condTr shldTrc (\_ -> "getOnBit: " ++ show (getOnBit intBits)) $--}
  {--condTr shldTrc (\_ -> "shldHndlIntrr: " ++ show (shldHndlIntrr state)) $--}
  {--condTr shldTrc (\_ -> "intF after interruptop: " ++ toHexStr 2 (getIntF (interruptOp state).mem.mainMem)) $--}
  condTr shldTrc (\_ -> regsStr oldRegs) $
  {--condTr shldTrc (\_ -> rd8RangeStr "FF85" 0xFF85 0xFF85 mem) $--}
  state
 where
  shldTrc = true
  {--shldTrc = state.totalM >= 125000--}
  {--shldTrc = oldRegs.pc == 0x0371 || oldRegs.pc == 0x0200--}
  {--shldTrc2 = regs.pc == 0x0407--}

regsStr :: Regs -> String
regsStr regs = "af: " ++ af
          ++ "\nbc: " ++ bc
          ++ "\nde: " ++ de
          ++ "\nhl: " ++ hl
          ++ "\nsp: " ++ sp
          ++ "\npc: " ++ pc
 where
  af = toHexStr 4 $ joinRegs a f regs
  bc = toHexStr 4 $ joinRegs b c regs
  de = toHexStr 4 $ joinRegs d e regs
  hl = toHexStr 4 $ joinRegs h l regs
  sp = toHexStr 4 $ regs.sp
  pc = toHexStr 4 $ regs.pc


Proper click handlers for both lists

Proper click handlers for both lists

module Main (main) where

import Control.Monad
import Control.Monad.Eff
import DOM
import Data.Array
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Events
import Data.DOM.Simple.Types
import Data.DOM.Simple.Window
import Data.Enum
import Data.Foldable
import Data.Maybe
import Data.String.Regex (regex, parseFlags, replace)
import Data.Traversable
import Debug.Trace
import qualified Data.StrMap as SM

import DOMHelper
import Isomer
import Level
import Sortable
import Storage
import Transformer
import Types

-- | RGB codes for the abstract colors
cubeColor :: Cube -> IsomerColor
cubeColor Blue = colorFromRGB 0 160 176
cubeColor Brown = colorFromRGB 106 74 60
cubeColor Red = colorFromRGB 204 51 63
cubeColor Orange = colorFromRGB 235 104 65
cubeColor Yellow = colorFromRGB 237 201 81

-- | Like traverse_, but specialized for arrays with an additional parameter (index of element)
traverseWithIndex_ :: forall a b m. (Applicative m) => (Number -> a -> m b) -> [a] -> m Unit
traverseWithIndex_ f xs = sequence_ (zipWith f (0 .. (length xs - 1)) xs)

-- | Render a single stack of cubes
renderStack :: forall eff. IsomerInstance -> Number -> Number -> Stack -> Eff (isomer :: Isomer | eff) Unit
renderStack isomer y x stack =
    traverseWithIndex_ (renderCube isomer x (-6 * y)) $ map cubeColor stack

-- | Render a wall (multiple stacks)
renderWall :: forall eff. IsomerInstance -> Number -> Wall -> Eff (isomer :: Isomer | eff) Unit
renderWall isomer y wall =
    traverseWithIndex_ (\x -> renderStack isomer y (length wall - x)) (reverse wall)

-- | Render a series of walls
renderWalls :: forall eff. IsomerInstance -> [Wall] -> Eff (isomer :: Isomer | eff) Unit
renderWalls isomer walls = do
    setIsomerConfig isomer 40 40 400
    traverseWithIndex_ (renderWall isomer) walls

-- | Render the target shape
renderTarget isomer target = do
    setIsomerConfig isomer 22 1200 250
    renderWall isomer 0 target

-- | Get program (list of transformer ids) of the active level
getCurrentIds :: GameState -> [TransformerId]
getCurrentIds gs = case (SM.lookup gs.currentLevel gs.levelState) of
                       Just ids -> ids
                       Nothing -> []

-- | Traverse a StrMap while performing monadic side effects
traverseWithKey_ :: forall a m. (Monad m) => (String -> a -> m Unit) -> SM.StrMap a -> m Unit
traverseWithKey_ f sm = SM.foldM (const f) unit sm

-- | Render all UI components, DOM and canvas
render :: Boolean -> GameState -> _
render setupUI gs = do
    doc <- document globalWindow
    isomer <- getIsomerInstance "canvas"

    let level = getLevel gs.currentLevel
        chapter = getChapter gs.currentLevel
        tids = getCurrentIds gs

    -- Set up UI, only if new level is loaded
    when setupUI $ do
        Just ulAvailable <- getElementById "available" doc
        Just ulProgram <- getElementById "program" doc

        setInnerHTML "" ulAvailable
        setInnerHTML "" ulProgram

        let unused = foldl (flip SM.delete) chapter.transformers tids
        let active = foldl (\sm id -> SM.insert id (getTransformerRecord chapter id) sm) SM.empty tids

        -- create li elements for transformers
        traverseWithKey_ (appendTransformerElement ulAvailable) unused
        traverseWithKey_ (appendTransformerElement ulProgram) active

        -- set up mouse event handlers
        let installClickHandler li = addMouseEventListener MouseClickEvent (clickLi li) li
        children ulAvailable >>= traverse_ installClickHandler
        children ulProgram >>=   traverse_ installClickHandler

        withElementById "levels" doc $ \selectLevel -> do
            setInnerHTML "levels" selectLevel
            traverseWithKey_ (appendLevelElement selectLevel gs.currentLevel) allLevels

    let transformers = map (getTransformer chapter) tids
    let steps = allSteps transformers level.initial

    -- On-canvas rendering
    clearCanvas isomer
    renderWalls isomer steps
    renderTarget isomer level.target

    -- DOM 'rendering'
    let message = if (maybe false (== (level.target)) (last steps))
                  then "Solved!"
                  else "Target"
    withElementById "message" doc (setInnerHTML message)

    -- DEBUG:
    trace $ "Program: " ++ show tids
    trace $ "Initial: " ++ show level.initial
    trace "Steps:"
    traverse_ print steps
    trace "---"
    trace $ "Target: " ++ show level.target
    trace ""

-- | Replace color placeholders in the transformer description by colored rectangular divs
replaceColors :: String -> String
replaceColors s =
    foldl replaceColor s ("X" : map show (Blue `enumFromTo` Yellow))
        where replaceColor s c = replace (regex (pattern c) rf) (replacement c) s
              rf = parseFlags "g"
              pattern c = "{" ++ c ++ "}"
              replacement c = "<div class=\"rect " ++ c ++ "\"> </div>"

-- | General key press handler
keyPress :: forall eff. DOMEvent -> _
keyPress event = do
    doc <- document globalWindow
    code <- keyCode event
    case code of
         -- 'r': reset lists
         82 -> modifyGameStateAndRender true $ \gs ->
                   gs { levelState = SM.insert gs.currentLevel [] gs.levelState }
         _ -> return unit
    return unit

-- | Click handler for the <li> elements (transformers)
clickLi :: forall eff. HTMLElement
        -> DOMEvent
        -> Eff (dom :: DOM, trace :: Trace, isomer :: Isomer, storage :: Storage | eff) Unit
clickLi liEl event = do
    newId <- getAttribute "id" liEl
    ulId <- parentElement liEl >>= getAttribute "id"
    modifyGameStateAndRender true (modify ulId newId)

    where modify ulId clicked gs = let program = getCurrentIds gs
                                       program' =
                                           if ulId == "available"
                                           then program `snoc` clicked
                                           else filter (/= clicked) program
                          in gs { levelState = SM.insert gs.currentLevel program' gs.levelState }

-- | Add a li-element corresponding to the given Transformer
appendTransformerElement :: forall eff. HTMLElement -> String -> TransformerRecord -> Eff (dom :: DOM | eff) Unit
appendTransformerElement ul id t = do
    doc <- document globalWindow
    li <- createElement doc "li"
    setAttribute "id" id li
    setInnerHTML (replaceColors t.name) li
    appendChild ul li

-- | Add an option-element corresponding to the given Level
appendLevelElement :: forall eff. HTMLElement -> String -> LevelId -> Level -> Eff (dom :: DOM | eff) Unit
appendLevelElement select currentId id l = do
    let chapter = getChapter id
    doc <- document globalWindow
    option <- createElement doc "option"
    setAttribute "value" id option
    when (currentId == id) $
        setAttribute "selected" "selected" option
    setTextContent (chapter.name ++ ": " ++ l.name ++ " (" ++ show l.difficulty ++ ")") option
    appendChild select option

-- | Initial game state for first-time visitors
initialGS :: GameState
initialGS = { currentLevel: "1_1", levelState: SM.empty }

-- | Load game, modify and store the game state. Render the new state
modifyGameStateAndRender :: forall eff.  Boolean
                         -> (GameState -> GameState)
                         -> Eff (storage :: Storage, dom :: DOM, isomer :: Isomer, trace :: Trace | eff) Unit
modifyGameStateAndRender setupUI modifyGS = do
    -- Load old game state from local storage
    mgs <- loadGameState
    let gs = fromMaybe initialGS mgs

    -- Modify by supplied function
    let gs' = modifyGS gs

    -- Render the new state and save back to local storage
    render setupUI gs'
    saveGameState gs'

-- | Event handler for a level change
levelChangeHandler :: forall eff. HTMLElement -> _
levelChangeHandler selectLevel = do
    levelId <- getSelectedValue selectLevel

    modifyGameStateAndRender true $ \gs ->
        gs { currentLevel = levelId }

-- | Event handler for a 'reprogram' (new instruction, re-ordering, ..)
reprogramHandler = do
    doc <- document globalWindow

    -- Retrieve current 'program'
    Just ulAvailable <- getElementById "program" doc
    lis <- children ulAvailable
    program <- traverse (getAttribute "id") lis

    modifyGameStateAndRender false $ \gs ->
        gs { levelState = SM.insert gs.currentLevel program gs.levelState }

main = do
    doc <- document globalWindow

    -- install sortable
    Just ulAvailable <- getElementById "available" doc
    Just ulProgram   <- getElementById "program" doc
    installSortable ulAvailable (return unit)
    installSortable ulProgram reprogramHandler

    -- set up keyboard event handlers
    addKeyboardEventListener KeydownEvent keyPress globalWindow

    -- set up 'change' handler for the level selector
    withElementById "levels" doc $ \selectLevel ->
        addChangeEventListener levelChangeHandler selectLevel

    -- load game state (or set initial one)
    gs <- fromMaybe initialGS <$> loadGameState
    saveGameState gs

    -- render initial state
    render true gs

module Main (main) where

import Control.Monad
import Control.Monad.Eff
import DOM
import Data.Array
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Events
import Data.DOM.Simple.Types
import Data.DOM.Simple.Window
import Data.Enum
import Data.Foldable
import Data.Maybe
import Data.String.Regex (regex, parseFlags, replace)
import Data.Traversable
import Debug.Trace
import qualified Data.StrMap as SM

import DOMHelper
import Isomer
import Level
import Sortable
import Storage
import Transformer
import Types

-- | RGB codes for the abstract colors
cubeColor :: Cube -> IsomerColor
cubeColor Blue = colorFromRGB 0 160 176
cubeColor Brown = colorFromRGB 106 74 60
cubeColor Red = colorFromRGB 204 51 63
cubeColor Orange = colorFromRGB 235 104 65
cubeColor Yellow = colorFromRGB 237 201 81

-- | Like traverse_, but specialized for arrays with an additional parameter (index of element)
traverseWithIndex_ :: forall a b m. (Applicative m) => (Number -> a -> m b) -> [a] -> m Unit
traverseWithIndex_ f xs = sequence_ (zipWith f (0 .. (length xs - 1)) xs)

-- | Render a single stack of cubes
renderStack :: forall eff. IsomerInstance -> Number -> Number -> Stack -> Eff (isomer :: Isomer | eff) Unit
renderStack isomer y x stack =
    traverseWithIndex_ (renderCube isomer x (-6 * y)) $ map cubeColor stack

-- | Render a wall (multiple stacks)
renderWall :: forall eff. IsomerInstance -> Number -> Wall -> Eff (isomer :: Isomer | eff) Unit
renderWall isomer y wall =
    traverseWithIndex_ (\x -> renderStack isomer y (length wall - x)) (reverse wall)

-- | Render a series of walls
renderWalls :: forall eff. IsomerInstance -> [Wall] -> Eff (isomer :: Isomer | eff) Unit
renderWalls isomer walls = do
    setIsomerConfig isomer 40 40 400
    traverseWithIndex_ (renderWall isomer) walls

-- | Render the target shape
renderTarget isomer target = do
    setIsomerConfig isomer 22 1200 250
    renderWall isomer 0 target

-- | Get program (list of transformer ids) of the active level
getCurrentIds :: GameState -> [TransformerId]
getCurrentIds gs = case (SM.lookup gs.currentLevel gs.levelState) of
                       Just ids -> ids
                       Nothing -> []

-- | Traverse a StrMap while performing monadic side effects
traverseWithKey_ :: forall a m. (Monad m) => (String -> a -> m Unit) -> SM.StrMap a -> m Unit
traverseWithKey_ f sm = SM.foldM (const f) unit sm

-- | Render all UI components, DOM and canvas
render :: Boolean -> GameState -> _
render setupUI gs = do
    doc <- document globalWindow
    isomer <- getIsomerInstance "canvas"

    let level = getLevel gs.currentLevel
        chapter = getChapter gs.currentLevel
        tids = getCurrentIds gs

    -- Set up UI, only if new level is loaded
    when setupUI $ do
        Just ulAvailable <- getElementById "available" doc
        Just ulProgram <- getElementById "program" doc

        setInnerHTML "" ulAvailable
        setInnerHTML "" ulProgram

        let unused = foldl (flip SM.delete) chapter.transformers tids
        let active = foldl (\sm id -> SM.insert id (getTransformerRecord chapter id) sm) SM.empty tids

        -- create li elements for transformers
        traverseWithKey_ (appendTransformerElement ulAvailable) unused
        traverseWithKey_ (appendTransformerElement ulProgram) active

        -- set up mouse event handlers
        let installClickHandler li = addMouseEventListener MouseClickEvent (clickLi li) li
        children ulAvailable >>= traverse_ installClickHandler

        withElementById "levels" doc $ \selectLevel -> do
            setInnerHTML "levels" selectLevel
            traverseWithKey_ (appendLevelElement selectLevel gs.currentLevel) allLevels

    let transformers = map (getTransformer chapter) tids
    let steps = allSteps transformers level.initial

    -- On-canvas rendering
    clearCanvas isomer
    renderWalls isomer steps
    renderTarget isomer level.target

    -- DOM 'rendering'
    let message = if (maybe false (== (level.target)) (last steps))
                  then "Solved!"
                  else "Target"
    withElementById "message" doc (setInnerHTML message)

    -- DEBUG:
    trace $ "Program: " ++ show tids
    trace $ "Initial: " ++ show level.initial
    trace "Steps:"
    traverse_ print steps
    trace "---"
    trace $ "Target: " ++ show level.target
    trace ""

-- | Replace color placeholders in the transformer description by colored rectangular divs
replaceColors :: String -> String
replaceColors s =
    foldl replaceColor s ("X" : map show (Blue `enumFromTo` Yellow))
        where replaceColor s c = replace (regex (pattern c) rf) (replacement c) s
              rf = parseFlags "g"
              pattern c = "{" ++ c ++ "}"
              replacement c = "<div class=\"rect " ++ c ++ "\"> </div>"

-- | General key press handler
keyPress :: forall eff. DOMEvent -> _
keyPress event = do
    doc <- document globalWindow
    code <- keyCode event
    case code of
         -- 'r': reset lists
         82 -> modifyGameStateAndRender true $ \gs ->
                   gs { levelState = SM.insert gs.currentLevel [] gs.levelState }
         _ -> return unit
    return unit

-- | Click handler for the <li> elements (transformers)
clickLi :: forall eff. HTMLElement
        -> DOMEvent
        -> Eff (dom :: DOM, trace :: Trace, isomer :: Isomer, storage :: Storage | eff) Unit
clickLi liEl event = do
    newId <- getAttribute "id" liEl
    modifyGameStateAndRender true (modify newId)

    where modify new gs = let program = getCurrentIds gs
                              program' = program `snoc` new
                          in  gs { levelState = SM.insert gs.currentLevel program' gs.levelState }

-- | Add a li-element corresponding to the given Transformer
appendTransformerElement :: forall eff. HTMLElement -> String -> TransformerRecord -> Eff (dom :: DOM | eff) Unit
appendTransformerElement ul id t = do
    doc <- document globalWindow
    li <- createElement doc "li"
    setAttribute "id" id li
    setInnerHTML (replaceColors t.name) li
    appendChild ul li

-- | Add an option-element corresponding to the given Level
appendLevelElement :: forall eff. HTMLElement -> String -> LevelId -> Level -> Eff (dom :: DOM | eff) Unit
appendLevelElement select currentId id l = do
    let chapter = getChapter id
    doc <- document globalWindow
    option <- createElement doc "option"
    setAttribute "value" id option
    when (currentId == id) $
        setAttribute "selected" "selected" option
    setTextContent (chapter.name ++ ": " ++ l.name ++ " (" ++ show l.difficulty ++ ")") option
    appendChild select option

-- | Initial game state for first-time visitors
initialGS :: GameState
initialGS = { currentLevel: "1_1", levelState: SM.empty }

-- | Load game, modify and store the game state. Render the new state
modifyGameStateAndRender :: forall eff.  Boolean
                         -> (GameState -> GameState)
                         -> Eff (storage :: Storage, dom :: DOM, isomer :: Isomer, trace :: Trace | eff) Unit
modifyGameStateAndRender setupUI modifyGS = do
    -- Load old game state from local storage
    mgs <- loadGameState
    let gs = fromMaybe initialGS mgs

    -- Modify by supplied function
    let gs' = modifyGS gs

    -- Render the new state and save back to local storage
    render setupUI gs'
    saveGameState gs'

-- | Event handler for a level change
levelChangeHandler :: forall eff. HTMLElement -> _
levelChangeHandler selectLevel = do
    levelId <- getSelectedValue selectLevel

    modifyGameStateAndRender true $ \gs ->
        gs { currentLevel = levelId }

-- | Event handler for a 'reprogram' (new instruction, re-ordering, ..)
reprogramHandler = do
    doc <- document globalWindow

    -- Retrieve current 'program'
    Just ulAvailable <- getElementById "program" doc
    lis <- children ulAvailable
    program <- traverse (getAttribute "id") lis

    modifyGameStateAndRender false $ \gs ->
        gs { levelState = SM.insert gs.currentLevel program gs.levelState }

main = do
    doc <- document globalWindow

    -- install sortable
    Just ulAvailable <- getElementById "available" doc
    Just ulProgram   <- getElementById "program" doc
    installSortable ulAvailable (return unit)
    installSortable ulProgram reprogramHandler

    -- set up keyboard event handlers
    addKeyboardEventListener KeydownEvent keyPress globalWindow

    -- set up 'change' handler for the level selector
    withElementById "levels" doc $ \selectLevel ->
        addChangeEventListener levelChangeHandler selectLevel

    -- load game state (or set initial one)
    gs <- fromMaybe initialGS <$> loadGameState
    saveGameState gs

    -- render initial state
    render true gs


Fixed isValidMove funktion

Fixed isValidMove funktion

module Main where

import Data.Char
import Data.String
import Data.Maybe
import Data.Tuple
import qualified Data.Map as M
import Control.Monad.Eff
import qualified Control.Monad.JQuery as J
import Debug.Trace

import Graphics.CanvasConsole
import GameData
import Utils
import Level

type GameState = { level :: Level, player :: Creature }

initialState :: GameState
initialState = { level: stringToLevel testLevel, player: pl }
    where
        pl :: Creature
        pl = { pos: {x: 3, y: 3}, ctype: Player, stats: defaultStats }

onUpdate :: Console -> Number -> GameState -> ConsoleEff GameState
onUpdate console dt state = do
    drawGame console state
    return state

drawGame :: Console -> GameState -> ConsoleEff GameState
drawGame console state = do
    clear console
    mapM_ (\p -> drawTile p (getTile state.level p)) (levelPoints state.level)
    drawString console "Hello worlllddd" "0000FF" 2 8
    drawCreature state.player
    return state
    where
        drawCreature :: Creature -> ConsoleEff Unit
        drawCreature c | c.ctype == Player  = drawChar console "@" "FF0000" c.pos.x c.pos.y
        drawCreature c | c.ctype == Guard   = drawChar console "G" "0000FF" c.pos.x c.pos.y
        drawCreature c | c.ctype == Archer  = drawChar console "A" "00FF00" c.pos.x c.pos.y
        drawCreature c | c.ctype == Peasant = drawChar console "P" "AAAAFF" c.pos.x c.pos.y
        drawCreature _                      = drawChar console "?" "FFFFFF" 0 0

        drawTile :: Point -> Maybe Tile -> ConsoleEff Unit
        drawTile p (Just Air)    = drawChar console "." "FFFFFF" p.x p.y
        drawTile p (Just Ground) = drawChar console "#" "AAAAAA" p.x p.y
        drawTile p (Just Wall)   = drawChar console "#" "331A00" p.x p.y
        drawTile p _             = drawChar console "?" "FFFFFF" p.x p.y

updateWorld :: GameState -> GameState
updateWorld state = state

isValidMove :: Level -> Point -> Boolean
isValidMove level = isTileSolid <<< fromMaybe Air <<< getTile level

movePlayer :: Tuple Number Number -> GameState -> GameState
movePlayer (Tuple dx dy) state | (isValidMove (state.level) ({ x: state.player.pos.x + dx, y: state.player.pos.y + dy })) == true = state
movePlayer (Tuple dx dy) state | otherwise = state { player = state.player { pos = clampPos { x: state.player.pos.x + dx, y: state.player.pos.y + dy } } }
    where
        clamp x min max | x < min = min
        clamp x min max | x > max = max
        clamp x min max = x

        clampPos :: Point -> Point
        clampPos pos = { x: clamp pos.x 0 79, y: clamp pos.y 0 24 }

movementkeys :: M.Map Number (Tuple Number Number)
movementkeys = M.fromList [numpad 8 // ( 0 // -1)
                          ,numpad 2 // ( 0 //  1)
                          ,numpad 4 // (-1 //  0)
                          ,numpad 6 // ( 1 //  0)]

onKeyPress :: Console -> GameState -> Number -> ConsoleEff GameState
onKeyPress console state key = case M.lookup key movementkeys of
    Just delta -> drawGame console $ movePlayer delta state
    Nothing    -> return state

onKeyPress console state key = trace $ show key >> return state

main = J.ready $ withConsole 80 25 initialState {onKeyPress: onKeyPress, onUpdate: onUpdate}

module Main where

import Data.Char
import Data.String
import Data.Maybe
import Data.Tuple
import qualified Data.Map as M
import Control.Monad.Eff
import qualified Control.Monad.JQuery as J
import Debug.Trace

import Graphics.CanvasConsole
import GameData
import Utils
import Level

type GameState = { level :: Level, player :: Creature }

initialState :: GameState
initialState = { level: stringToLevel testLevel, player: pl }
    where
        pl :: Creature
        pl = { pos: {x: 3, y: 3}, ctype: Player, stats: defaultStats }

onUpdate :: Console -> Number -> GameState -> ConsoleEff GameState
onUpdate console dt state = do
    drawGame console state
    return state

drawGame :: Console -> GameState -> ConsoleEff GameState
drawGame console state = do
    clear console
    mapM_ (\p -> drawTile p (getTile state.level p)) (levelPoints state.level)
    drawString console "Hello worlllddd" "0000FF" 2 8
    drawCreature state.player
    return state
    where
        drawCreature :: Creature -> ConsoleEff Unit
        drawCreature c | c.ctype == Player  = drawChar console "@" "FF0000" c.pos.x c.pos.y
        drawCreature c | c.ctype == Guard   = drawChar console "G" "0000FF" c.pos.x c.pos.y
        drawCreature c | c.ctype == Archer  = drawChar console "A" "00FF00" c.pos.x c.pos.y
        drawCreature c | c.ctype == Peasant = drawChar console "P" "AAAAFF" c.pos.x c.pos.y
        drawCreature _                      = drawChar console "?" "FFFFFF" 0 0

        drawTile :: Point -> Maybe Tile -> ConsoleEff Unit
        drawTile p (Just Air)    = drawChar console "." "FFFFFF" p.x p.y
        drawTile p (Just Ground) = drawChar console "#" "AAAAAA" p.x p.y
        drawTile p (Just Wall)   = drawChar console "#" "331A00" p.x p.y
        drawTile p _             = drawChar console "?" "FFFFFF" p.x p.y

updateWorld :: GameState -> GameState
updateWorld state = state

--isValidMove :: Level -> Point -> Boolean
--isValidMove = isTileSolid <<< fromMaybe Air <<< getTile

movePlayer :: Tuple Number Number -> GameState -> GameState
--movePlayer (Tuple dx dy) state | (isValidMove (state.level) ({ x: state.player.pos.x + dx, y: state.player.pos.y + dy })) == true = state
--movePlayer (Tuple dx dy) state | otherwise = state { player = state.player { pos = clampPos { x: state.player.pos.x + dx, y: state.player.pos.y + dy } } }
movePlayer (Tuple dx dy) state = state { player = state.player { pos = clampPos { x: state.player.pos.x + dx, y: state.player.pos.y + dy } } }
    where
        clamp x min max | x < min = min
        clamp x min max | x > max = max
        clamp x min max = x

        clampPos :: Point -> Point
        clampPos pos = { x: clamp pos.x 0 79, y: clamp pos.y 0 24 }

movementkeys :: M.Map Number (Tuple Number Number)
movementkeys = M.fromList [numpad 8 // ( 0 // -1)
                          ,numpad 2 // ( 0 //  1)
                          ,numpad 4 // (-1 //  0)
                          ,numpad 6 // ( 1 //  0)]

onKeyPress :: Console -> GameState -> Number -> ConsoleEff GameState
onKeyPress console state key = case M.lookup key movementkeys of
    Just delta -> drawGame console $ movePlayer delta state
    Nothing    -> return state

onKeyPress console state key = trace $ show key >> return state

main = J.ready $ withConsole 80 25 initialState {onKeyPress: onKeyPress, onUpdate: onUpdate}


made a wee counter thing to get my feet wet. wee!

module Main where

import Prelude

import Control.Monad.Aff (runAff)
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Exception (throwException)

import Halogen
import Halogen.Util (appendToBody, onLoad)
import qualified Halogen.HTML.Indexed as H
import qualified Halogen.HTML.Events.Indexed as E

data Query a = ToggleState a
             | Inc a
             | Dec a

type State = { on :: Boolean
             , count :: Int
             }

initialState :: State
initialState = { on: false, count: 0 }

ui :: forall g. (Functor g) => Component State Query g
ui = component render eval
  where

  render :: State -> ComponentHTML Query
  render state =
    H.div_
      [ H.h1_
          [ H.text "Hello world!" ]
      , H.p_
          [ H.text "Why not toggle this button:" ]
      , H.button
          [ E.onClick (E.input_ ToggleState) ]
          [ H.text
              if not state.on
              then "Don't push me"
              else "I said don't push me!"
          ]
      , H.p_
          [ H.button
                [ E.onClick (E.input_ Inc) ]
                [ H.text
                    if state.count < 1
                    then "I've never been pressed!"
                    else "I've been pressed " <> show state.count <> " times."
                ]
          , H.button
                [ E.onClick (E.input_ Dec) ]
                [ H.text "Memory Hole! ¯\\_(ツ)_/¯" ]
          ]
      ]

  eval :: Natural Query (ComponentDSL State Query g)
  eval (ToggleState next) = do
    modify (\state -> state { on = not state.on })
    pure next
  eval (Inc next) = do
    modify (\state -> state { count = state.count + 1 })
    pure next
  eval (Dec next) = do
    modify (\state -> state { count = state.count - 1})
    pure next

main :: Eff (HalogenEffects ()) Unit
main = runAff throwException (const (pure unit)) $ do
  app <- runUI ui initialState
  onLoad $ appendToBody app.node

module Main where

import Prelude

import Control.Monad.Aff (runAff)
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Exception (throwException)

import Halogen
import Halogen.Util (appendToBody, onLoad)
import qualified Halogen.HTML.Indexed as H
import qualified Halogen.HTML.Events.Indexed as E

data Query a = ToggleState a

type State = { on :: Boolean }

initialState :: State
initialState = { on: false }

ui :: forall g. (Functor g) => Component State Query g
ui = component render eval
  where

  render :: State -> ComponentHTML Query
  render state =
    H.div_
      [ H.h1_
          [ H.text "Hello world!" ]
      , H.p_
          [ H.text "Why not toggle this button:" ]
      , H.button
          [ E.onClick (E.input_ ToggleState) ]
          [ H.text
              if not state.on
              then "Don't push me"
              else "I said don't push me!"
          ]
      ]

  eval :: Natural Query (ComponentDSL State Query g)
  eval (ToggleState next) = do
    modify (\state -> { on: not state.on })
    pure next

main :: Eff (HalogenEffects ()) Unit
main = runAff throwException (const (pure unit)) $ do
  app <- runUI ui initialState
  onLoad $ appendToBody app.node


Whoops, forgot to update FFI code from tuples

module Control.Monad.Eff.Ref where

import Control.Monad.Eff

foreign import data Ref :: !

foreign import data RefVal :: * -> *

foreign import newRef """
  function newRef(val) {
    return function () {
      return { value: val };
    };
  }
""" :: forall s r. s -> Eff (ref :: Ref | r) (RefVal s)

foreign import readRef """
  function readRef(ref) {
    return function() {
      return ref.value;
    };
  }
""" :: forall s r. RefVal s -> Eff (ref :: Ref | r) s

foreign import modifyRef' """
  function modifyRef$prime(ref) {
    return function(f) {
      return function() {
        var t = f(ref.value);
        ref.value = t.newState;
        return t.retVal;
      };
    };
  }
""" :: forall s b r. RefVal s -> (s -> {newState :: s, retVal :: b}) -> Eff (ref :: Ref | r) b

modifyRef :: forall s r. RefVal s -> (s -> s) -> Eff (ref :: Ref | r) Unit
modifyRef ref f = modifyRef' ref (\s -> {newState: f s, retVal: unit})

foreign import writeRef """
  function writeRef(ref) {
    return function(val) {
      return function() {
        ref.value = val;
        return {};
      };
    };
  }
""" :: forall s r. RefVal s -> s -> Eff (ref :: Ref | r) Unit

module Control.Monad.Eff.Ref where

import Control.Monad.Eff

foreign import data Ref :: !

foreign import data RefVal :: * -> *

foreign import newRef """
  function newRef(val) {
    return function () {
      return { value: val };
    };
  }
""" :: forall s r. s -> Eff (ref :: Ref | r) (RefVal s)

foreign import readRef """
  function readRef(ref) {
    return function() {
      return ref.value;
    };
  }
""" :: forall s r. RefVal s -> Eff (ref :: Ref | r) s

foreign import modifyRef' """
  function modifyRef$prime(ref) {
    return function(f) {
      return function() {
        var t = f(ref.value);
        ref.value = t.value0;
        return t.value1;
      };
    };
  }
""" :: forall s b r. RefVal s -> (s -> {newState :: s, retVal :: b}) -> Eff (ref :: Ref | r) b

modifyRef :: forall s r. RefVal s -> (s -> s) -> Eff (ref :: Ref | r) Unit
modifyRef ref f = modifyRef' ref (\s -> {newState: f s, retVal: unit})

foreign import writeRef """
  function writeRef(ref) {
    return function(val) {
      return function() {
        ref.value = val;
        return {};
      };
    };
  }
""" :: forall s r. RefVal s -> s -> Eff (ref :: Ref | r) Unit