Update help links in global menu #1713 (#1732)

{-
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.GlobalMenu.Component
  ( component
  , Query(..)
  , Message(..)
  , AuthenticateOrPresentHelp(..)
  , State
  , module SlamData.GlobalMenu.Bus
  ) where

import SlamData.Prelude

import Control.UI.Browser as Browser
import Control.Monad.Aff.AVar as AVar
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Eff as Eff
import Control.Monad.Eff.Ref as Ref
import Control.Monad.Eff.Exception as Exception

import Halogen as H
import Halogen.Component.Utils (busEventSource)
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import Halogen.Menu.Component as Menu
import Halogen.Query.EventSource as ES
import Halogen.HTML.Events as HE

import OIDC.Crypt as Crypt

import Quasar.Advanced.Types (ProviderR)

import SlamData.AuthenticationMode as AuthenticationMode
import SlamData.Workspace.Eval.Card as EvalCard
import SlamData.GlobalError (GlobalError)
import SlamData.GlobalError as GlobalError
import SlamData.GlobalMenu.Bus (SignInMessage(..))
import SlamData.Monad (Slam)
import SlamData.Quasar as Api
import SlamData.Quasar.Auth as Auth
import SlamData.Quasar.Auth.Authentication (AuthenticationError, toNotificationOptions)
import SlamData.Quasar.Auth.Store as AuthStore
import SlamData.Wiring as Wiring
import SlamData.Workspace.Eval.Persistence as Persistence

data AuthenticateOrPresentHelp
  = Authenticate (Maybe ProviderR)
  | PresentHelp String
  | PresentAttribution

data Query a
  = DismissSubmenu a
  | HandleGlobalError GlobalError a
  | HandleMenuMessage (Menu.Message AuthenticateOrPresentHelp) a
  | Init a

type State =
  { loggedIn ∷ Boolean
  }

data Message =
  PresentAttributionsDialog

type HTML = H.ParentHTML Query (Menu.Query AuthenticateOrPresentHelp) Unit Slam
type DSL = H.ParentDSL State Query (Menu.Query AuthenticateOrPresentHelp) Unit Message Slam

component ∷ H.Component HH.HTML Query Unit Message Slam
component =
  H.lifecycleParentComponent
    { initialState: \_ → { loggedIn: false }
    , render
    , eval
    , initializer: Just (H.action Init)
    , finalizer: Nothing
    , receiver: const Nothing
    }

render ∷ State → HTML
render state =
  HH.div
    [ HP.classes $ [ HH.ClassName "sd-global-menu" ] ]
    [ HH.slot unit Menu.component helpMenu $ HE.input HandleMenuMessage
    ]

eval ∷ Query ~> DSL
eval (Init next) = do
  { bus } ← H.lift Wiring.expose
  H.subscribe $ busEventSource (flip HandleGlobalError ES.Listening) bus.globalError
  update
  pure next
eval (DismissSubmenu next) = do
  _ ← H.query unit $ H.action $ Menu.DismissSubmenu
  pure next
eval (HandleGlobalError error next) = case error of
  GlobalError.Unauthorized _ → update $> next
  _ → pure next
eval (HandleMenuMessage (Menu.Selected a) next) = do
  case a of
    Authenticate providerR → authenticate providerR
    PresentHelp uri → presentHelp uri
    PresentAttribution → H.raise PresentAttributionsDialog
  pure next

update ∷ DSL Unit
update = do
  maybeIdToken ← H.lift Auth.getIdToken
  case maybeIdToken of
    Just idToken → do
      either
        (const retrieveProvidersAndUpdateMenu)
        putEmailToMenu
        (Eff.runPure $ Exception.try $ Crypt.readPayload idToken)
    Nothing →
      retrieveProvidersAndUpdateMenu
  where
  putEmailToMenu ∷ Crypt.Payload → DSL Unit
  putEmailToMenu payload = do
    _ ← H.query unit
      $ H.action
      $ Menu.Set
        { chosen: Nothing
        , submenus:
            [ { label:
                fromMaybe "unknown user"
                $ map unwrap
                $ Crypt.pluckEmail
                $ payload
              , submenu:
                [ { label: "🔒 Sign out"
                  , shortcutLabel: Nothing
                  , value: Authenticate Nothing
                  }
                ]
              }
            ]
            ⊕ helpMenu
        }
    H.modify _{ loggedIn = true }

  retrieveProvidersAndUpdateMenu ∷ DSL Unit
  retrieveProvidersAndUpdateMenu = void do
    eProviders ← Api.retrieveAuthProviders
    H.query unit
      $ H.action
      $ Menu.Set
          { chosen: Nothing
          , submenus: case eProviders of
              Right (Just providers) →
                let
                  makeSubmenuItem provider =
                    { label: "Sign in with " ⊕ provider.displayName
                    , shortcutLabel: Nothing
                    , value: Authenticate $ Just provider
                    }
                in
                  [ { label: "🔓 Sign in"
                    , submenu: makeSubmenuItem <$> providers
                    }
                  ]
                ⊕ helpMenu
              _ → helpMenu
          }

helpMenu ∷ Array (Menu.MenuItem AuthenticateOrPresentHelp)
helpMenu =
  [ { label: "Help"
    , submenu:
      [ { label: "User guide"
        , shortcutLabel: Nothing
        , value: PresentHelp "http://docs.slamdata.com/en/v4.2/users-guide.html"
        }
      , { label: "Administrator guide"
        , shortcutLabel: Nothing
        , value: PresentHelp "http://docs.slamdata.com/en/v4.2/administration-guide.html"
        }
      , { label: "Developer guide"
        , shortcutLabel: Nothing
        , value: PresentHelp "http://docs.slamdata.com/en/v4.2/developers-guide.html"
        }
      , { label: "Helpful tips"
        , shortcutLabel: Nothing
        , value: PresentHelp "http://docs.slamdata.com/en/v4.2/helpful-tips.html"
        }
      , { label: "SQL² reference"
        , shortcutLabel: Nothing
        , value: PresentHelp "http://docs.slamdata.com/en/v4.2/sql-squared-reference.html"
        }
      , { label: "SlamDown reference"
        , shortcutLabel: Nothing
        , value: PresentHelp "http://docs.slamdata.com/en/v4.2/slamdown-reference.html"
        }
      , { label: "Troubleshooting FAQ"
        , shortcutLabel: Nothing
        , value: PresentHelp "http://docs.slamdata.com/en/v4.2/troubleshooting-faq.html"
        }
      , { label: "Attributions"
        , shortcutLabel: Nothing
        , value: PresentAttribution
        }
      ]
    }
  ]

authenticate ∷ Maybe ProviderR → DSL Unit
authenticate = maybe logOut logIn
  where
  keySuffix ∷ String
  keySuffix =
    AuthenticationMode.toKeySuffix AuthenticationMode.ChosenProvider

  logOut ∷ DSL Unit
  logOut = do
    AuthStore.removeIdToken keySuffix
    AuthStore.removeUnhashedNonce keySuffix
    AuthStore.removeProvider keySuffix
    update

  logIn ∷ ProviderR → DSL Unit
  logIn providerR = do
    { auth } ← H.lift Wiring.expose
    idToken ← H.liftAff AVar.makeVar
    H.liftAff $ Bus.write { providerR, idToken, prompt: true, keySuffix } auth.requestToken
    either signInFailure (const $ signInSuccess) =<< (H.liftAff $ AVar.takeVar idToken)

  signInSuccess ∷ DSL Unit
  signInSuccess = do
    wiring ← Wiring.expose
    update
    traverse_ (lift ∘ Persistence.queueEvalImmediate ∘ EvalCard.toAll)
      =<< (H.liftEff $ Ref.readRef wiring.auth.retryEval)
    whenM
      (H.liftEff $ Ref.readRef wiring.auth.retrySave)
      (void $ lift $ Persistence.saveWorkspace)
    H.liftAff $ Bus.write SignInSuccess wiring.auth.signIn

  signInFailure ∷ AuthenticationError → DSL Unit
  signInFailure error = do
    { auth, bus } ← H.lift Wiring.expose
    H.liftAff do
      maybe (pure unit) (flip Bus.write bus.notify) (toNotificationOptions error)
      Bus.write SignInFailure auth.signIn

presentHelp ∷ String → DSL Unit
presentHelp = H.liftEff ∘ Browser.newTab

{-
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.GlobalMenu.Component
  ( component
  , Query(..)
  , Message(..)
  , AuthenticateOrPresentHelp(..)
  , State
  , module SlamData.GlobalMenu.Bus
  ) where

import SlamData.Prelude

import Control.UI.Browser as Browser
import Control.Monad.Aff.AVar as AVar
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Eff as Eff
import Control.Monad.Eff.Ref as Ref
import Control.Monad.Eff.Exception as Exception

import Halogen as H
import Halogen.Component.Utils (busEventSource)
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import Halogen.Menu.Component as Menu
import Halogen.Query.EventSource as ES
import Halogen.HTML.Events as HE

import OIDC.Crypt as Crypt

import Quasar.Advanced.Types (ProviderR)

import SlamData.AuthenticationMode as AuthenticationMode
import SlamData.Workspace.Eval.Card as EvalCard
import SlamData.GlobalError (GlobalError)
import SlamData.GlobalError as GlobalError
import SlamData.GlobalMenu.Bus (SignInMessage(..))
import SlamData.Monad (Slam)
import SlamData.Quasar as Api
import SlamData.Quasar.Auth as Auth
import SlamData.Quasar.Auth.Authentication (AuthenticationError, toNotificationOptions)
import SlamData.Quasar.Auth.Store as AuthStore
import SlamData.Wiring as Wiring
import SlamData.Workspace.Eval.Persistence as Persistence

data AuthenticateOrPresentHelp
  = Authenticate (Maybe ProviderR)
  | PresentHelp String
  | PresentAttribution

data Query a
  = DismissSubmenu a
  | HandleGlobalError GlobalError a
  | HandleMenuMessage (Menu.Message AuthenticateOrPresentHelp) a
  | Init a

type State =
  { loggedIn ∷ Boolean
  }

data Message =
  PresentAttributionsDialog

type HTML = H.ParentHTML Query (Menu.Query AuthenticateOrPresentHelp) Unit Slam
type DSL = H.ParentDSL State Query (Menu.Query AuthenticateOrPresentHelp) Unit Message Slam

component ∷ H.Component HH.HTML Query Unit Message Slam
component =
  H.lifecycleParentComponent
    { initialState: \_ → { loggedIn: false }
    , render
    , eval
    , initializer: Just (H.action Init)
    , finalizer: Nothing
    , receiver: const Nothing
    }

render ∷ State → HTML
render state =
  HH.div
    [ HP.classes $ [ HH.ClassName "sd-global-menu" ] ]
    [ HH.slot unit Menu.component helpMenu $ HE.input HandleMenuMessage
    ]

eval ∷ Query ~> DSL
eval (Init next) = do
  { bus } ← H.lift Wiring.expose
  H.subscribe $ busEventSource (flip HandleGlobalError ES.Listening) bus.globalError
  update
  pure next
eval (DismissSubmenu next) = do
  _ ← H.query unit $ H.action $ Menu.DismissSubmenu
  pure next
eval (HandleGlobalError error next) = case error of
  GlobalError.Unauthorized _ → update $> next
  _ → pure next
eval (HandleMenuMessage (Menu.Selected a) next) = do
  case a of
    Authenticate providerR → authenticate providerR
    PresentHelp uri → presentHelp uri
    PresentAttribution → H.raise PresentAttributionsDialog
  pure next

update ∷ DSL Unit
update = do
  maybeIdToken ← H.lift Auth.getIdToken
  case maybeIdToken of
    Just idToken → do
      either
        (const retrieveProvidersAndUpdateMenu)
        putEmailToMenu
        (Eff.runPure $ Exception.try $ Crypt.readPayload idToken)
    Nothing →
      retrieveProvidersAndUpdateMenu
  where
  putEmailToMenu ∷ Crypt.Payload → DSL Unit
  putEmailToMenu payload = do
    _ ← H.query unit
      $ H.action
      $ Menu.Set
        { chosen: Nothing
        , submenus:
            [ { label:
                fromMaybe "unknown user"
                $ map unwrap
                $ Crypt.pluckEmail
                $ payload
              , submenu:
                [ { label: "🔒 Sign out"
                  , shortcutLabel: Nothing
                  , value: Authenticate Nothing
                  }
                ]
              }
            ]
            ⊕ helpMenu
        }
    H.modify _{ loggedIn = true }

  retrieveProvidersAndUpdateMenu ∷ DSL Unit
  retrieveProvidersAndUpdateMenu = void do
    eProviders ← Api.retrieveAuthProviders
    H.query unit
      $ H.action
      $ Menu.Set
          { chosen: Nothing
          , submenus: case eProviders of
              Right (Just providers) →
                let
                  makeSubmenuItem provider =
                    { label: "Sign in with " ⊕ provider.displayName
                    , shortcutLabel: Nothing
                    , value: Authenticate $ Just provider
                    }
                in
                  [ { label: "🔓 Sign in"
                    , submenu: makeSubmenuItem <$> providers
                    }
                  ]
                ⊕ helpMenu
              _ → helpMenu
          }

helpMenu ∷ Array (Menu.MenuItem AuthenticateOrPresentHelp)
helpMenu =
  [ { label: "Help"
    , submenu:
      [ { label: "User guide"
        , shortcutLabel: Nothing
        , value: PresentHelp "http://docs.slamdata.com/en/v4.1/users-guide.html"
        }
      , { label: "Administrator guide"
        , shortcutLabel: Nothing
        , value: PresentHelp "http://docs.slamdata.com/en/v4.1/administration-guide.html"
        }
      , { label: "Developer guide"
        , shortcutLabel: Nothing
        , value: PresentHelp "http://docs.slamdata.com/en/v4.1/developers-guide.html"
        }
      , { label: "Helpful tips"
        , shortcutLabel: Nothing
        , value: PresentHelp "http://docs.slamdata.com/en/v4.1/helpful-tips.html"
        }
      , { label: "SQL² reference"
        , shortcutLabel: Nothing
        , value: PresentHelp "http://docs.slamdata.com/en/v4.1/sql-squared-reference.html"
        }
      , { label: "SlamDown reference"
        , shortcutLabel: Nothing
        , value: PresentHelp "http://docs.slamdata.com/en/v4.1/slamdown-reference.html"
        }
      , { label: "Troubleshooting FAQ"
        , shortcutLabel: Nothing
        , value: PresentHelp "http://docs.slamdata.com/en/v4.1/troubleshooting-faq.html"
        }
      , { label: "Attributions"
        , shortcutLabel: Nothing
        , value: PresentAttribution
        }
      ]
    }
  ]

authenticate ∷ Maybe ProviderR → DSL Unit
authenticate = maybe logOut logIn
  where
  keySuffix ∷ String
  keySuffix =
    AuthenticationMode.toKeySuffix AuthenticationMode.ChosenProvider

  logOut ∷ DSL Unit
  logOut = do
    AuthStore.removeIdToken keySuffix
    AuthStore.removeUnhashedNonce keySuffix
    AuthStore.removeProvider keySuffix
    update

  logIn ∷ ProviderR → DSL Unit
  logIn providerR = do
    { auth } ← H.lift Wiring.expose
    idToken ← H.liftAff AVar.makeVar
    H.liftAff $ Bus.write { providerR, idToken, prompt: true, keySuffix } auth.requestToken
    either signInFailure (const $ signInSuccess) =<< (H.liftAff $ AVar.takeVar idToken)

  signInSuccess ∷ DSL Unit
  signInSuccess = do
    wiring ← Wiring.expose
    update
    traverse_ (lift ∘ Persistence.queueEvalImmediate ∘ EvalCard.toAll)
      =<< (H.liftEff $ Ref.readRef wiring.auth.retryEval)
    whenM
      (H.liftEff $ Ref.readRef wiring.auth.retrySave)
      (void $ lift $ Persistence.saveWorkspace)
    H.liftAff $ Bus.write SignInSuccess wiring.auth.signIn

  signInFailure ∷ AuthenticationError → DSL Unit
  signInFailure error = do
    { auth, bus } ← H.lift Wiring.expose
    H.liftAff do
      maybe (pure unit) (flip Bus.write bus.notify) (toNotificationOptions error)
      Bus.write SignInFailure auth.signIn

presentHelp ∷ String → DSL Unit
presentHelp = H.liftEff ∘ Browser.newTab


failing CatList stack-safety tests

failing CatList stack-safety tests

module Test.Data.CatList (testCatList) where

import Data.CatList

import Control.Bind (discard)
import Control.Category (id)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log, logShow)
import Data.CommutativeRing ((+))
import Data.Eq ((==))
import Data.Foldable (foldMap)
import Data.Function (($))
import Data.Functor ((<$>))
import Data.Maybe (Maybe(..), fromJust)
import Data.Monoid.Additive (Additive(..))
import Data.Tuple (fst, snd)
import Data.Unfoldable (range, replicate)
import Data.Unit (Unit)
import Partial.Unsafe (unsafePartial)
import Prelude ((<<<))
import Test.Assert (ASSERT, assert)

testCatList :: forall eff. Eff (console :: CONSOLE, assert :: ASSERT | eff) Unit
testCatList = unsafePartial do
  log "null should be true for the empty list"
  assert $ null empty

  log "singleton should create a queue with one element"
  assert $ (fst <$> uncons (singleton 1)) == Just 1
  assert $ (null <<< snd <$> uncons (singleton 1)) == Just true

  log "cons should add an item to the beginning of the list"
  assert $ fst (fromJust (uncons (20 `cons` (10 `cons` empty)))) == 20
  assert $ fst (fromJust (uncons (snd (fromJust (uncons (20 `cons` (10 `cons` empty))))))) == 10

  log "snoc should add an item to the end of the list"
  assert $ fst (fromJust (uncons ((empty `snoc` 10) `snoc` 20))) == 10
  assert $ fst (fromJust (uncons (snd (fromJust (uncons ((empty `snoc` 10) `snoc` 20)))))) == 20

  log "appending two empty lists should be empty"
  assert $ null (append empty empty)

  log "uncons of a list with left and right lists should remove items properly"
  let list1 = ((10 `cons` empty) `snoc` 20) `snoc` 30
  assert $ fst (fromJust (uncons list1)) == 10
  assert $ fst (fromJust (uncons (snd (fromJust (uncons list1))))) == 20
  assert $ fst (fromJust (uncons (snd (fromJust (uncons (snd (fromJust (uncons list1)))))))) == 30
  assert $ null (snd (fromJust (uncons (snd (fromJust (uncons (snd (fromJust (uncons list1)))))))))

  log "foldMap over a list of monoids should produce the concatenation of the monoids"
  let list2 = (("a" `cons` empty) `snoc` "b") `snoc` "c"
  assert $ foldMap id list2 == "abc"

  log "foldMap is stack safe"
  let longList :: CatList Int
      longList = range 0 10000
  logShow $ foldMap Additive longList

  log "foldl is stack-safe"
  logShow $ foldl (+) 0 longList

  log "fromFoldable should convert an array into a CatList with the same values"
  let list3 = fromFoldable ["a", "b", "c"]
  assert $ fst (fromJust (uncons list3)) == "a"
  assert $ fst (fromJust (uncons (snd (fromJust (uncons list3))))) == "b"
  assert $ fst (fromJust (uncons (snd (fromJust (uncons (snd (fromJust (uncons list3)))))))) == "c"
  assert $ null (snd (fromJust (uncons (snd (fromJust (uncons (snd (fromJust (uncons list3)))))))))

  log "functor should correctly map a function over the contents of a CatList"
  let list4 = (_ + 3) <$> fromFoldable [1, 2, 3]
  assert $ foldMap (\v -> [v]) list4 == [4, 5, 6]

  log "replicate should produce a CatList with a value repeated"
  let list5 = (replicate 3 "foo") :: CatList String
  assert $ foldMap (\v -> [v]) list5 == ["foo", "foo", "foo"]

module Test.Data.CatList (testCatList) where

import Data.CatList

import Control.Bind (discard)
import Control.Category (id)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Data.CommutativeRing ((+))
import Data.Eq ((==))
import Data.Foldable (foldMap)
import Data.Function (($))
import Data.Functor ((<$>))
import Data.Maybe (Maybe(..), fromJust)
import Data.Tuple (fst, snd)
import Data.Unfoldable (replicate)
import Data.Unit (Unit)
import Partial.Unsafe (unsafePartial)
import Prelude ((<<<))
import Test.Assert (ASSERT, assert)

testCatList :: forall eff. Eff (console :: CONSOLE, assert :: ASSERT | eff) Unit
testCatList = unsafePartial do
  log "null should be true for the empty list"
  assert $ null empty

  log "singleton should create a queue with one element"
  assert $ (fst <$> uncons (singleton 1)) == Just 1
  assert $ (null <<< snd <$> uncons (singleton 1)) == Just true

  log "cons should add an item to the beginning of the list"
  assert $ fst (fromJust (uncons (20 `cons` (10 `cons` empty)))) == 20
  assert $ fst (fromJust (uncons (snd (fromJust (uncons (20 `cons` (10 `cons` empty))))))) == 10

  log "snoc should add an item to the end of the list"
  assert $ fst (fromJust (uncons ((empty `snoc` 10) `snoc` 20))) == 10
  assert $ fst (fromJust (uncons (snd (fromJust (uncons ((empty `snoc` 10) `snoc` 20)))))) == 20

  log "appending two empty lists should be empty"
  assert $ null (append empty empty)

  log "uncons of a list with left and right lists should remove items properly"
  let list1 = ((10 `cons` empty) `snoc` 20) `snoc` 30
  assert $ fst (fromJust (uncons list1)) == 10
  assert $ fst (fromJust (uncons (snd (fromJust (uncons list1))))) == 20
  assert $ fst (fromJust (uncons (snd (fromJust (uncons (snd (fromJust (uncons list1)))))))) == 30
  assert $ null (snd (fromJust (uncons (snd (fromJust (uncons (snd (fromJust (uncons list1)))))))))

  log "foldMap over a list of monoids should produce the concatenation of the monoids"
  let list2 = (("a" `cons` empty) `snoc` "b") `snoc` "c"
  assert $ foldMap id list2 == "abc"

  log "fromFoldable should convert an array into a CatList with the same values"
  let list3 = fromFoldable ["a", "b", "c"]
  assert $ fst (fromJust (uncons list3)) == "a"
  assert $ fst (fromJust (uncons (snd (fromJust (uncons list3))))) == "b"
  assert $ fst (fromJust (uncons (snd (fromJust (uncons (snd (fromJust (uncons list3)))))))) == "c"
  assert $ null (snd (fromJust (uncons (snd (fromJust (uncons (snd (fromJust (uncons list3)))))))))

  log "functor should correctly map a function over the contents of a CatList"
  let list4 = (_ + 3) <$> fromFoldable [1, 2, 3]
  assert $ foldMap (\v -> [v]) list4 == [4, 5, 6]

  log "replicate should produce a CatList with a value repeated"
  let list5 = (replicate 3 "foo") :: CatList String
  assert $ foldMap (\v -> [v]) list5 == ["foo", "foo", "foo"]


little overzealous

little overzealous

{-
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.Card.Setups.Chart.Line.Eval
  ( eval
  , module SlamData.Workspace.Card.Setups.Chart.Line.Model
  ) where

import SlamData.Prelude

import Data.Argonaut (Json, decodeJson, (.?))
import Data.Array as A
import Data.Foldable as F
import Data.Int as Int
import Data.Lens ((^?))
import Data.List as L
import Data.Map as M
import Data.Set as Set

import ECharts.Monad (DSL)
import ECharts.Commands as E
import ECharts.Types as ET
import ECharts.Types.Phantom (OptionI)
import ECharts.Types.Phantom as ETP

import SlamData.Workspace.Card.CardType.ChartType (ChartType(Line))
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Card.Setups.Axis (Axes)
import SlamData.Workspace.Card.Setups.Axis as Ax
import SlamData.Workspace.Card.Setups.Chart.ColorScheme (colors)
import SlamData.Workspace.Card.Setups.Chart.Common as SCC
import SlamData.Workspace.Card.Setups.Chart.Common.Positioning as BCP
import SlamData.Workspace.Card.Setups.Chart.Line.Model (Model, ModelR)
import SlamData.Workspace.Card.Setups.Common.Eval (type (>>))
import SlamData.Workspace.Card.Setups.Common.Eval as BCE
import SlamData.Workspace.Card.Setups.Dimension as D
import SlamData.Workspace.Card.Setups.Semantics as Sem
import SqlSquared as Sql

eval ∷ ∀ m. BCE.ChartSetupEval ModelR m
eval = BCE.chartSetupEval (SCC.buildBasicSql buildProjections buildGroupBy) buildLine

type LineSerie =
  { name ∷ Maybe String
  , leftItems ∷ String >> LineItem
  , rightItems ∷ String >> LineItem
  }

type LineItem =
  { value ∷ Number
  , symbolSize ∷ Int
  }

type Item =
  { category ∷ String
  , measure1 ∷ Number
  , measure2 ∷ Maybe Number
  , size ∷ Maybe Number
  , series ∷ Maybe String
  }

decodeItem ∷ Json → Either String Item
decodeItem = decodeJson >=> \obj → do
  category ← Sem.requiredString "" <$> obj .? "category"
  measure1 ← Sem.requiredNumber zero <$> obj .? "measure1"
  measure2 ← Sem.maybeNumber <$> obj .? "measure2"
  size ← Sem.maybeNumber <$> obj .? "size"
  series ← Sem.maybeString <$> obj .? "series"
  pure { category, measure1, measure2, size, series }

buildProjections ∷ ModelR → L.List (Sql.Projection Sql.Sql)
buildProjections r = L.fromFoldable
  [ r.dimension # SCC.jcursorPrj # Sql.as "category"
  , r.value # SCC.jcursorPrj # Sql.as "measure1" # SCC.applyTransform r.value
  , r.size # maybe SCC.nullPrj SCC.jcursorPrj # Sql.as "size"
  , r.series # maybe SCC.nullPrj SCC.jcursorPrj # Sql.as "series"
  , secondValueF
  ]
  where
  secondValueF = case r.secondValue of
    Just sv → sv # SCC.jcursorPrj # Sql.as "measure2" # SCC.applyTransform sv
    Nothing → SCC.nullPrj # Sql.as "measure2"

buildGroupBy ∷ ModelR → Maybe (Sql.GroupBy Sql.Sql)
buildGroupBy r =
  SCC.groupBy $ L.fromFoldable $ A.catMaybes
    [ r.series <#> SCC.jcursorSql
    , Just r.dimension <#> SCC.jcursorSql
    ]

buildLine ∷ ModelR → Axes → Port.Port
buildLine m axes =
  Port.ChartInstructions
    { options: lineOptions axes m ∘ buildLineData m
    , chartType: Line
    }

buildLineData ∷ ModelR → Array Json → Array LineSerie
buildLineData r =
  foldMap (foldMap A.singleton ∘ decodeItem)
    >>> lineSeries

  where
  lineSeries ∷ Array Item → Array LineSerie
  lineSeries =
    BCE.groupOn _.series
      >>> map \(name × is) →
            { name
            , leftItems: adjustSymbolSizes $ M.fromFoldable (items (pure ∘ _.measure1) is)
            , rightItems: adjustSymbolSizes $ M.fromFoldable (items _.measure2 is)
            }

  items ∷ (Item → Maybe Number) → Array Item → Array (String × LineItem)
  items f = A.mapMaybe \i →
    Tuple i.category <$> case f i, i.size of
      Nothing, _ → Nothing
      Just value, _ | r.optionalMarkers → Just { value, symbolSize: Int.floor r.minSize }
      Just value, Nothing → Just { value, symbolSize: Int.floor r.minSize }
      Just value, Just size → Just { value, symbolSize: Int.floor size }

  adjustSymbolSizes ∷ ∀ f. Functor f ⇒ Foldable f ⇒ f LineItem → f LineItem
  adjustSymbolSizes is
    | r.optionalMarkers = is
    | otherwise =
      let
        minValue ∷ Number
        minValue =
          Int.toNumber
            $ fromMaybe bottom
            $ map _.symbolSize
            $ F.minimumBy (\a b → compare a.symbolSize b.symbolSize) is

        maxValue ∷ Number
        maxValue =
          Int.toNumber
            $ fromMaybe top
            $ map _.symbolSize
            $ F.maximumBy (\a b → compare a.symbolSize b.symbolSize) is

        distance ∷ Number
        distance =
          maxValue - minValue

        sizeDistance ∷ Number
        sizeDistance =
          r.maxSize - r.minSize

        relativeSize ∷ Int → Int
        relativeSize val
          | distance ≡ 0.0 = val
          | otherwise =
            Int.floor
            $ r.maxSize
            - sizeDistance / distance * (maxValue - Int.toNumber val)
      in
        map (\x → x{symbolSize = relativeSize x.symbolSize}) is

lineOptions ∷ Axes → ModelR → Array LineSerie → DSL OptionI
lineOptions axes r lineData = do
  E.tooltip do
    if isJust r.size then E.triggerItem else E.triggerAxis
    E.textStyle $ E.fontSize 12

  E.colors colors
  E.grid BCP.cartesian
  E.series series

  E.xAxis do
    E.axisType xAxisConfig.axisType
    case xAxisConfig.axisType of
      ET.Category →
        E.items $ map ET.strItem xValues
      _ → pure unit
    E.axisLabel do
      E.rotate r.axisLabelAngle
      traverse_ E.interval xAxisConfig.interval
      E.textStyle do
        E.fontFamily "Ubuntu, sans"

  E.yAxes do
    E.addYAxis yAxis
    when needTwoAxes $ E.addYAxis yAxis

  E.legend do
    E.items $ map ET.strItem seriesNames
    E.textStyle $ E.fontFamily "Ubuntu, sans"

  where
  xAxisType ∷ Ax.AxisType
  xAxisType =
    fromMaybe Ax.Category
    $ Ax.axisType
    <$> (r.dimension ^? D._value ∘ D._projection)
    <*> (pure axes)

  xAxisConfig ∷ Ax.EChartsAxisConfiguration
  xAxisConfig = Ax.axisConfiguration xAxisType

  xSortFn ∷ String → String → Ordering
  xSortFn = Ax.compareWithAxisType xAxisType

  xValues ∷ Array String
  xValues =
    A.sortBy xSortFn
      $ A.fromFoldable
      $ foldMap (\x → Set.fromFoldable $ M.keys x.leftItems ⊕ M.keys x.rightItems)
        lineData

  seriesNames ∷ Array String
  seriesNames = case r.series of
    Just _ → A.fromFoldable $ foldMap (_.name ⋙ foldMap Set.singleton) lineData
    Nothing →
      A.catMaybes
        [ Just $ D.jcursorLabel r.value
        , D.jcursorLabel <$> r.secondValue
        ]

  needTwoAxes ∷ Boolean
  needTwoAxes = isJust r.secondValue

  series ∷ ∀ i. DSL (line ∷ ETP.I|i)
  series = for_ lineData \lineSerie → do
    E.line do
      E.buildItems $ for_ xValues \key →
        case M.lookup key lineSerie.leftItems of
          Nothing → E.missingItem
          Just {value, symbolSize} → E.addItem do
            E.name key
            E.buildValues do
              E.addStringValue key
              E.addValue value
            E.symbolSize symbolSize
      E.yAxisIndex 0
      case r.series of
        Just _ →
          for_ lineSerie.name E.name
        Nothing →
          E.name $ D.jcursorLabel r.value

    when needTwoAxes $ E.line do
      E.buildItems $ for_ xValues \key →
        case M.lookup key lineSerie.rightItems of
          Nothing → E.missingItem
          Just {value, symbolSize} → E.addItem do
            E.name key
            E.buildValues do
              E.addStringValue key
              E.addValue value
            E.symbolSize symbolSize
      E.yAxisIndex 1
      case r.series of
        Just _ →
          for_ lineSerie.name E.name
        Nothing →
          for_ r.secondValue (E.name ∘ D.jcursorLabel)

  yAxis ∷ DSL ETP.YAxisI
  yAxis = do
    E.axisType ET.Value
    E.axisLabel $ E.textStyle do
      E.fontFamily "Ubuntu, sans"

{-
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.Card.Setups.Chart.Line.Eval
  ( eval
  , module SlamData.Workspace.Card.Setups.Chart.Line.Model
  ) where

import SlamData.Prelude

import Data.Argonaut (Json, decodeJson, (.?))
import Data.Array as A
import Data.Foldable as F
import Data.Int as Int
import Data.Lens ((^?))
import Data.List as L
import Data.Map as M
import Data.Set as Set

import ECharts.Monad (DSL)
import ECharts.Commands as E
import ECharts.Types as ET
import ECharts.Types.Phantom (OptionI)
import ECharts.Types.Phantom as ETP

import SlamData.Workspace.Card.CardType.ChartType (ChartType(Line))
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Card.Setups.Axis (Axes)
import SlamData.Workspace.Card.Setups.Axis as Ax
import SlamData.Workspace.Card.Setups.Chart.ColorScheme (colors)
import SlamData.Workspace.Card.Setups.Chart.Common as SCC
import SlamData.Workspace.Card.Setups.Chart.Common.Positioning as BCP
import SlamData.Workspace.Card.Setups.Chart.Line.Model (Model, ModelR)
import SlamData.Workspace.Card.Setups.Common.Eval (type (>>))
import SlamData.Workspace.Card.Setups.Common.Eval as BCE
import SlamData.Workspace.Card.Setups.Dimension as D
import SlamData.Workspace.Card.Setups.Semantics as Sem
import SqlSquared as Sql

eval ∷ ∀ m. BCE.ChartSetupEval ModelR m
eval = BCE.chartSetupEval (SCC.buildBasicSql buildProjections buildGroupBy) buildLine

type LineSerie =
  { name ∷ Maybe String
  , leftItems ∷ String >> LineItem
  , rightItems ∷ String >> LineItem
  }

type LineItem =
  { value ∷ Number
  , symbolSize ∷ Int
  }

type Item =
  { category ∷ String
  , measure1 ∷ Number
  , measure2 ∷ Maybe Number
  , size ∷ Maybe Number
  , series ∷ Maybe String
  }

decodeItem ∷ Json → Either String Item
decodeItem = decodeJson >⇒ \obj → do
  category ← Sem.requiredString "" <$> obj .? "category"
  measure1 ← Sem.requiredNumber zero <$> obj .? "measure1"
  measure2 ← Sem.maybeNumber <$> obj .? "measure2"
  size ← Sem.maybeNumber <$> obj .? "size"
  series ← Sem.maybeString <$> obj .? "series"
  pure { category, measure1, measure2, size, series }

buildProjections ∷ ModelR → L.List (Sql.Projection Sql.Sql)
buildProjections r = L.fromFoldable
  [ r.dimension # SCC.jcursorPrj # Sql.as "category"
  , r.value # SCC.jcursorPrj # Sql.as "measure1" # SCC.applyTransform r.value
  , r.size # maybe SCC.nullPrj SCC.jcursorPrj # Sql.as "size"
  , r.series # maybe SCC.nullPrj SCC.jcursorPrj # Sql.as "series"
  , secondValueF
  ]
  where
  secondValueF = case r.secondValue of
    Just sv → sv # SCC.jcursorPrj # Sql.as "measure2" # SCC.applyTransform sv
    Nothing → SCC.nullPrj # Sql.as "measure2"

buildGroupBy ∷ ModelR → Maybe (Sql.GroupBy Sql.Sql)
buildGroupBy r =
  SCC.groupBy $ L.fromFoldable $ A.catMaybes
    [ r.series <#> SCC.jcursorSql
    , Just r.dimension <#> SCC.jcursorSql
    ]

buildLine ∷ ModelR → Axes → Port.Port
buildLine m axes =
  Port.ChartInstructions
    { options: lineOptions axes m ∘ buildLineData m
    , chartType: Line
    }

buildLineData ∷ ModelR → Array Json → Array LineSerie
buildLineData r =
  foldMap (foldMap A.singleton ∘ decodeItem)
    >>> lineSeries

  where
  lineSeries ∷ Array Item → Array LineSerie
  lineSeries =
    BCE.groupOn _.series
      >>> map \(name × is) →
            { name
            , leftItems: adjustSymbolSizes $ M.fromFoldable (items (pure ∘ _.measure1) is)
            , rightItems: adjustSymbolSizes $ M.fromFoldable (items _.measure2 is)
            }

  items ∷ (Item → Maybe Number) → Array Item → Array (String × LineItem)
  items f = A.mapMaybe \i →
    Tuple i.category <$> case f i, i.size of
      Nothing, _ → Nothing
      Just value, _ | r.optionalMarkers → Just { value, symbolSize: Int.floor r.minSize }
      Just value, Nothing → Just { value, symbolSize: Int.floor r.minSize }
      Just value, Just size → Just { value, symbolSize: Int.floor size }

  adjustSymbolSizes ∷ ∀ f. Functor f ⇒ Foldable f ⇒ f LineItem → f LineItem
  adjustSymbolSizes is
    | r.optionalMarkers = is
    | otherwise =
      let
        minValue ∷ Number
        minValue =
          Int.toNumber
            $ fromMaybe bottom
            $ map _.symbolSize
            $ F.minimumBy (\a b → compare a.symbolSize b.symbolSize) is

        maxValue ∷ Number
        maxValue =
          Int.toNumber
            $ fromMaybe top
            $ map _.symbolSize
            $ F.maximumBy (\a b → compare a.symbolSize b.symbolSize) is

        distance ∷ Number
        distance =
          maxValue - minValue

        sizeDistance ∷ Number
        sizeDistance =
          r.maxSize - r.minSize

        relativeSize ∷ Int → Int
        relativeSize val
          | distance ≡ 0.0 = val
          | otherwise =
            Int.floor
            $ r.maxSize
            - sizeDistance / distance * (maxValue - Int.toNumber val)
      in
        map (\x → x{symbolSize = relativeSize x.symbolSize}) is

lineOptions ∷ Axes → ModelR → Array LineSerie → DSL OptionI
lineOptions axes r lineData = do
  E.tooltip do
    if isJust r.size then E.triggerItem else E.triggerAxis
    E.textStyle $ E.fontSize 12

  E.colors colors
  E.grid BCP.cartesian
  E.series series

  E.xAxis do
    E.axisType xAxisConfig.axisType
    case xAxisConfig.axisType of
      ET.Category →
        E.items $ map ET.strItem xValues
      _ → pure unit
    E.axisLabel do
      E.rotate r.axisLabelAngle
      traverse_ E.interval xAxisConfig.interval
      E.textStyle do
        E.fontFamily "Ubuntu, sans"

  E.yAxes do
    E.addYAxis yAxis
    when needTwoAxes $ E.addYAxis yAxis

  E.legend do
    E.items $ map ET.strItem seriesNames
    E.textStyle $ E.fontFamily "Ubuntu, sans"

  where
  xAxisType ∷ Ax.AxisType
  xAxisType =
    fromMaybe Ax.Category
    $ Ax.axisType
    <$> (r.dimension ^? D._value ∘ D._projection)
    <*> (pure axes)

  xAxisConfig ∷ Ax.EChartsAxisConfiguration
  xAxisConfig = Ax.axisConfiguration xAxisType

  xSortFn ∷ String → String → Ordering
  xSortFn = Ax.compareWithAxisType xAxisType

  xValues ∷ Array String
  xValues =
    A.sortBy xSortFn
      $ A.fromFoldable
      $ foldMap (\x → Set.fromFoldable $ M.keys x.leftItems ⊕ M.keys x.rightItems)
        lineData

  seriesNames ∷ Array String
  seriesNames = case r.series of
    Just _ → A.fromFoldable $ foldMap (_.name ⋙ foldMap Set.singleton) lineData
    Nothing →
      A.catMaybes
        [ Just $ D.jcursorLabel r.value
        , D.jcursorLabel <$> r.secondValue
        ]

  needTwoAxes ∷ Boolean
  needTwoAxes = isJust r.secondValue

  series ∷ ∀ i. DSL (line ∷ ETP.I|i)
  series = for_ lineData \lineSerie → do
    E.line do
      E.buildItems $ for_ xValues \key →
        case M.lookup key lineSerie.leftItems of
          Nothing → E.missingItem
          Just {value, symbolSize} → E.addItem do
            E.name key
            E.buildValues do
              E.addStringValue key
              E.addValue value
            E.symbolSize symbolSize
      E.yAxisIndex 0
      case r.series of
        Just _ →
          for_ lineSerie.name E.name
        Nothing →
          E.name $ D.jcursorLabel r.value

    when needTwoAxes $ E.line do
      E.buildItems $ for_ xValues \key →
        case M.lookup key lineSerie.rightItems of
          Nothing → E.missingItem
          Just {value, symbolSize} → E.addItem do
            E.name key
            E.buildValues do
              E.addStringValue key
              E.addValue value
            E.symbolSize symbolSize
      E.yAxisIndex 1
      case r.series of
        Just _ →
          for_ lineSerie.name E.name
        Nothing →
          for_ r.secondValue (E.name ∘ D.jcursorLabel)

  yAxis ∷ DSL ETP.YAxisI
  yAxis = do
    E.axisType ET.Value
    E.axisLabel $ E.textStyle do
      E.fontFamily "Ubuntu, sans"


Fixed showItem and simplified showPrefix

module GameData where

import Data.Tuple
import Data.Array (map)
import Data.String
import Data.Foldable
import qualified Data.Map as M
import Utils
import Math

type Point = { x :: Number, y :: Number }

(.+.) :: Point -> Point -> Point
(.+.) {x = x1, y = y1} {x = x2, y=y2} = {x: x1+x2, y: y1+y2}
infixl 9 .+.

(.-.) :: Point -> Point -> Point
(.-.) {x = x1, y = y1} {x = x2, y=y2} = {x: x1-x2, y: y1-y2}
infixl 9 .-.

(.==.) :: Point -> Point -> Boolean
(.==.) {x = x1, y = y1} {x = x2, y = y2} = x1 == x2 && y1 == y2

showPoint :: Point -> String
showPoint p = "(" ++ show p.x ++ ", " ++ show p.y ++ ")"

manhattanDistance :: Point -> Point -> Number
manhattanDistance {x = x1, y = y1} {x = x2, y=y2} = abs (x1 - x2) + abs (y1 - y2)

distanceSq :: Point -> Point -> Number
distanceSq {x = x1, y = y1} {x = x2, y=y2} = (x1 - x2) * (x1 - x2) + (y1 - y2) * (y1 - y2)

zerop :: Point
zerop = {x: 0, y: 0}

unitp :: Point -> Point
unitp p = {x: sign p.x, y: sign p.y}

type Stats =
    { hp  :: Number
    , def :: Number
    , str :: Number
    , dex :: Number
    , int :: Number
    }

defaultStats = { hp: 10, def: 10, str: 10, dex: 10, int: 10}

data SkillType = WeaponSkill | Sneak | Athletics | Lockpick

type Skill = { level :: Number, prog :: Number }

type Skills = M.Map SkillType Skill

instance showSkillType :: Show SkillType where
    show WeaponSkill = "weapon"
    show Sneak = "sneaking"
    show Athletics = "athletics"
    show Lockpick = "lockpicking"

instance ordSkillType :: Ord SkillType where
    compare a b = compare (show a) (show b)

instance eqSkillType :: Eq SkillType where
    (==) a b = show a == show b
    (/=) a b = not (a == b)

defaultSkills :: Skills
defaultSkills = M.fromList [Tuple WeaponSkill {level: 0, prog: 0}
                           ,Tuple Sneak { level: 0, prog: 0}
                           ,Tuple Athletics { level: 0, prog: 0}
                           ,Tuple Lockpick { level: 0, prog: 0}
                           ]

data CreatureType = Player | Guard | Archer | Peasant

instance showCT :: Show CreatureType where
    show Player = "player"
    show Guard   = "guard"
    show Archer  = "archer"
    show Peasant = "peasant"

instance eqCT :: Eq CreatureType where
    (==) a b = show a == show b
    (/=) a b = show a /= show b

data AIState = Sleep
             | Idle Point   -- idling position
             | Patrol Point -- where to go

data Alertness = NoAlert  -- Does not see player
               | MightSee -- There is LOS and a chance to turn into Suspicious
               | Suspicious Number -- Number = progress towards alert
               | Alert Number -- Number = number of turns to stay alert

data AI = AI Alertness AIState | NoAI

type Creature =
    { pos   :: Point -- Position
    , dir   :: Point -- Facing direction
    , ctype :: CreatureType
    , stats :: Stats
    , time  :: Number
    , vel   :: Point -- Velocity
    , ai    :: AI
    }

type WeaponMod = { damageMod :: Number, weightMod :: Number, attackSpeedMod :: Number }

data Material = Wood | Copper | Iron | Steel | Titanium | Adamantine

materialMod :: Material -> WeaponMod
materialMod Wood = { damageMod: -2, weightMod: -1, attackSpeedMod: 1 }
materialMod _ = zeromod

zeromod :: WeaponMod
zeromod = { damageMod: 0, weightMod: 0, attackSpeedMod:0 }

data WeaponPrefix = Broken | Rusty | Dull | Sharp | Lethal | Masterwork | Light | Balanced | Heavy | Godly

-- todo: add correct values
prefixMod :: WeaponPrefix -> WeaponMod
prefixMod Broken     = { damageMod: -3, weightMod: 0, attackSpeedMod: 0 }
prefixMod Rusty      = { damageMod: -2, weightMod: 0, attackSpeedMod: 0 }
prefixMod Dull       = { damageMod: -1, weightMod: 0, attackSpeedMod: 0 }
prefixMod Sharp      = { damageMod:  1, weightMod: 0, attackSpeedMod: 0 }
prefixMod Lethal     = { damageMod:  2, weightMod: 0, attackSpeedMod: 0 }
prefixMod Masterwork = { damageMod:  3, weightMod: 0, attackSpeedMod: 0 }
prefixMod Godly      = { damageMod:  4, weightMod: 0, attackSpeedMod: 0 }
prefixMod _          = zeromod

showPrefix :: [WeaponPrefix] -> String
showPrefix = joinWith " " <<< map show

instance showWeaponPrefix :: Show WeaponPrefix where
    show Rusty      = "rusty"
    show Broken     = "broken"
    show Dull       = "dull"
    show Masterwork = "masterwork"
    show Sharp      = "sharp"
    show Lethal     = "lethal"
    show Light      = "light"
    show Balanced   = "balanced"
    show Heavy      = "heavy"
    show Godly      = "godly"

data WeaponType = Sword | Axe | Dagger

instance showWeaponType :: Show WeaponType where
    show Sword  = "sword"
    show Axe    = "axe"
    show Dagger = "dagger"

baseDamage :: WeaponType -> Number
baseDamage Sword = 3
baseDamage Axe   = 5
baseDamage _     = 0

baseAttackBonus :: WeaponType -> Number
baseAttackBonus Sword = 2
baseAttackBonus Axe   = 0
baseAttackBonus _     = 0

data ItemType = Loot   { value :: Number }
              | Weapon { weaponType :: WeaponType, prefix :: [WeaponPrefix] }

instance showItemType :: Show ItemType where
    show (Loot   { value = val })                         = (show val) ++ " $"
    show (Weapon { weaponType = t, prefix = [] })         = show t
    show (Weapon { weaponType = t, prefix = prefixList }) = (showPrefix prefixList) ++ " " ++ (show t)

type Item = { itemType :: ItemType, pos :: Point, vel :: Point, weight :: Number }

-- Final item information functions:

-- todo: calculate weight with prefixes
itemWeight :: Item -> Number
itemWeight i = i.weight

-- todo: use prefixes
itemDamage :: Item -> Number
itemDamage { itemType = Weapon w } = baseDamage w.weaponType
itemDamage _ = 0

showItem :: Item -> String
showItem i@{ itemType = Weapon _ } = show i.itemType ++ ", Dmg: " ++ show (itemDamage i) ++ ", Weight: " ++ show (itemWeight i)
showItem i = show i.itemType

module GameData where

import Data.Tuple
import Data.Array (map)
import Data.String
import Data.Foldable
import qualified Data.Map as M
import Utils
import Math

type Point = { x :: Number, y :: Number }

(.+.) :: Point -> Point -> Point
(.+.) {x = x1, y = y1} {x = x2, y=y2} = {x: x1+x2, y: y1+y2}
infixl 9 .+.

(.-.) :: Point -> Point -> Point
(.-.) {x = x1, y = y1} {x = x2, y=y2} = {x: x1-x2, y: y1-y2}
infixl 9 .-.

(.==.) :: Point -> Point -> Boolean
(.==.) {x = x1, y = y1} {x = x2, y = y2} = x1 == x2 && y1 == y2

showPoint :: Point -> String
showPoint p = "(" ++ show p.x ++ ", " ++ show p.y ++ ")"

manhattanDistance :: Point -> Point -> Number
manhattanDistance {x = x1, y = y1} {x = x2, y=y2} = abs (x1 - x2) + abs (y1 - y2)

distanceSq :: Point -> Point -> Number
distanceSq {x = x1, y = y1} {x = x2, y=y2} = (x1 - x2) * (x1 - x2) + (y1 - y2) * (y1 - y2)

zerop :: Point
zerop = {x: 0, y: 0}

unitp :: Point -> Point
unitp p = {x: sign p.x, y: sign p.y}

type Stats =
    { hp  :: Number
    , def :: Number
    , str :: Number
    , dex :: Number
    , int :: Number
    }

defaultStats = { hp: 10, def: 10, str: 10, dex: 10, int: 10}

data SkillType = WeaponSkill | Sneak | Athletics | Lockpick

type Skill = { level :: Number, prog :: Number }

type Skills = M.Map SkillType Skill

instance showSkillType :: Show SkillType where
    show WeaponSkill = "weapon"
    show Sneak = "sneaking"
    show Athletics = "athletics"
    show Lockpick = "lockpicking"

instance ordSkillType :: Ord SkillType where
    compare a b = compare (show a) (show b)

instance eqSkillType :: Eq SkillType where
    (==) a b = show a == show b
    (/=) a b = not (a == b)

defaultSkills :: Skills
defaultSkills = M.fromList [Tuple WeaponSkill {level: 0, prog: 0}
                           ,Tuple Sneak { level: 0, prog: 0}
                           ,Tuple Athletics { level: 0, prog: 0}
                           ,Tuple Lockpick { level: 0, prog: 0}
                           ]

data CreatureType = Player | Guard | Archer | Peasant

instance showCT :: Show CreatureType where
    show Player = "player"
    show Guard   = "guard"
    show Archer  = "archer"
    show Peasant = "peasant"

instance eqCT :: Eq CreatureType where
    (==) a b = show a == show b
    (/=) a b = show a /= show b

data AIState = Sleep
             | Idle Point   -- idling position
             | Patrol Point -- where to go

data Alertness = NoAlert  -- Does not see player
               | MightSee -- There is LOS and a chance to turn into Suspicious
               | Suspicious Number -- Number = progress towards alert
               | Alert Number -- Number = number of turns to stay alert

data AI = AI Alertness AIState | NoAI

type Creature =
    { pos   :: Point -- Position
    , dir   :: Point -- Facing direction
    , ctype :: CreatureType
    , stats :: Stats
    , time  :: Number
    , vel   :: Point -- Velocity
    , ai    :: AI
    }

type WeaponMod = { damageMod :: Number, weightMod :: Number, attackSpeedMod :: Number }

data Material = Wood | Copper | Iron | Steel | Titanium | Adamantine

materialMod :: Material -> WeaponMod
materialMod Wood = { damageMod: -2, weightMod: -1, attackSpeedMod: 1 }
materialMod _ = zeromod

zeromod :: WeaponMod
zeromod = { damageMod: 0, weightMod: 0, attackSpeedMod:0 }

data WeaponPrefix = Broken | Rusty | Dull | Sharp | Lethal | Masterwork | Light | Balanced | Heavy | Godly

-- todo: add correct values
prefixMod :: WeaponPrefix -> WeaponMod
prefixMod Broken     = { damageMod: -3, weightMod: 0, attackSpeedMod: 0 }
prefixMod Rusty      = { damageMod: -2, weightMod: 0, attackSpeedMod: 0 }
prefixMod Dull       = { damageMod: -1, weightMod: 0, attackSpeedMod: 0 }
prefixMod Sharp      = { damageMod:  1, weightMod: 0, attackSpeedMod: 0 }
prefixMod Lethal     = { damageMod:  2, weightMod: 0, attackSpeedMod: 0 }
prefixMod Masterwork = { damageMod:  3, weightMod: 0, attackSpeedMod: 0 }
prefixMod Godly      = { damageMod:  4, weightMod: 0, attackSpeedMod: 0 }
prefixMod _          = zeromod

showPrefix :: [WeaponPrefix] -> String
showPrefix []     = ""
showPrefix (x:xs) = show x ++ showPrefix xs

instance showWeaponPrefix :: Show WeaponPrefix where
    show Rusty      = "rusty"
    show Broken     = "broken"
    show Dull       = "dull"
    show Masterwork = "masterwork"
    show Sharp      = "sharp"
    show Lethal     = "lethal"
    show Light      = "light"
    show Balanced   = "balanced"
    show Heavy      = "heavy"
    show Godly      = "godly"

data WeaponType = Sword | Axe | Dagger

instance showWeaponType :: Show WeaponType where
    show Sword  = "sword"
    show Axe    = "axe"
    show Dagger = "dagger"

baseDamage :: WeaponType -> Number
baseDamage Sword = 3
baseDamage Axe   = 5
baseDamage _     = 0

baseAttackBonus :: WeaponType -> Number
baseAttackBonus Sword = 2
baseAttackBonus Axe   = 0
baseAttackBonus _     = 0

data ItemType = Loot   { value :: Number }
              | Weapon { weaponType :: WeaponType, prefix :: [WeaponPrefix] }

instance showItemType :: Show ItemType where
    show (Loot   { value = val })                         = (show val) ++ " $"
    show (Weapon { weaponType = t, prefix = [] })         = show t
    show (Weapon { weaponType = t, prefix = prefixList }) = (showPrefix prefixList) ++ " " ++ (show t)

type Item = { itemType :: ItemType, pos :: Point, vel :: Point, weight :: Number }

-- Final item information functions:

-- todo: calculate weight with prefixes
-- itemWeight = ...

-- todo: use prefixes
itemDamage :: Item -> Number
itemDamage { itemType = Weapon w } = baseDamage w.weaponType
itemDamage _ = 0

showItem :: Item -> String
--showItem i@( { w@( Weapon _ ), weight = we } ) = show w  ++ ", Dmg: " ++ show i ++ ", Weight: " ++ show we
-- or (neather works)
--showItem ( Item { itemType = (Weapon { weaponType = w, prefix = pre }), weight = we } ) = show (Weapon { weaponType = w, prefix = pre }) ++ ", Dmg: " ++ show (itemDamage ( Item { t@{ Weapon w }, weight = we } )) ++ ", Weight: " ++ show we
showItem _ = "Empty"


connectStore - leight weight connect

connectStore - leight weight connect


Add additional state running functions

Add additional state running functions

module Control.Monad.State.Trans where

import Prelude
import Control.Monad.Trans

type StateData s a = { state :: s, value :: a }

data StateT s m a = StateT (s -> m (StateData s a))

instance monadStateT :: (Monad m) => Monad (StateT s m) where
  return a = StateT \s -> return { state: s, value: a }
  (>>=) (StateT x) f = StateT \s -> do
    { state = s', value = v } <- x s
    runStateT (f v) s'

instance monadTransStateT :: MonadTrans (StateT s) where
  lift m = StateT \s -> do
    x <- m
    return { state: s, value: x }

runStateT :: forall s m a. StateT s m a -> s -> m (StateData s a)
runStateT (StateT s) = s

evalStateT :: forall s m a. (Monad m) => StateT s m a -> s -> m a
evalStateT m s = runStateT m s >>= \x -> return x.value

execStateT :: forall s m a. (Monad m) => StateT s m a -> s -> m s
execStateT m s = runStateT m s >>= \x -> return x.state

mapStateT :: forall s m1 m2 a b. (m1 (StateData s a) -> m2 (StateData s b)) -> StateT s m1 a -> StateT s m2 b
mapStateT f m = StateT $ f <<< runStateT m

withStateT :: forall s m a. (s -> s) -> StateT s m a -> StateT s m a
withStateT f s = StateT $ runStateT s <<< f

module Control.Monad.State.Trans where

import Prelude
import Control.Monad.Trans

type StateData s a = { state :: s, value :: a }

data StateT s m a = StateT (s -> m (StateData s a))

instance monadStateT :: (Monad m) => Monad (StateT s m) where
  return a = StateT \s -> return { state: s, value: a }
  (>>=) (StateT x) f = StateT \s -> do
    { state = s', value = v } <- x s
    runStateT (f v) s'

instance monadTransStateT :: MonadTrans (StateT s) where
  lift m = StateT \s -> do
    x <- m
    return { state: s, value: x }

runStateT :: forall s m a. StateT s m a -> s -> m (StateData s a)
runStateT (StateT s) = s

withStateT :: forall s m a. (s -> s) -> StateT s m a -> StateT s m a
withStateT f s = StateT $ runStateT s <<< f


Fetch genes & chrs, render gemma + genes

module Genetics.Browser.Track.UI where

import Prelude

import Control.Alt ((<|>))
import Control.Monad.Aff (Aff, launchAff)
import Control.Monad.Aff.AVar (makeVar, putVar, tryPeekVar)
import Control.Monad.Eff (Eff, foreachE)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Error.Class (throwError)
import DOM.HTML.Types (HTMLElement)
import Data.Argonaut (Json, _Array, _Number, _Object, _String)
import Data.Array (take, zip)
import Data.Array as Array
import Data.Either (Either(..))
import Data.Filterable (class Filterable, filter, filterMap)
import Data.Filterable as Filterable
import Data.Foldable (class Foldable, for_, length)
import Data.Int (round)
import Data.Lens ((^?))
import Data.Lens.Index (ix)
import Data.List (List(..), (:))
import Data.List as List
import Data.Maybe (Maybe(..), fromJust, fromMaybe)
import Data.Monoid (mempty)
import Data.Newtype (over, unwrap, wrap)
import Data.Nullable (Nullable, toMaybe)
import Data.Traversable (traverse, traverse_)
import Data.Tuple (Tuple(..), snd)
import Debug.Trace (traceShow)
import FRP.Event (Event)
import FRP.Event as Event
import FRP.Event as FRP
import Genetics.Browser.Track.Backend (GWASFeature, Gene, drawGemma, drawGenes, fetchGemmaJSON, fetchGene'JSON, geneFetchChrId, mouseChrIds)
import Genetics.Browser.Types (ChrId(..))
import Genetics.Browser.View (Pixels)
import Global as Global
import Global.Unsafe (unsafeStringify)
import Graphics.Canvas (CanvasElement, Context2D, TranslateTransform, Transform, getCanvasElementById, getCanvasHeight, getContext2D, setCanvasWidth, transform, translate, withContext)
import Graphics.Drawing (Drawing, fillColor, filled, rectangle, white)
import Graphics.Drawing as Drawing
import Math as Math
import Network.HTTP.Affjax as Affjax
import Partial.Unsafe (unsafePartial)
import Unsafe.Coerce (unsafeCoerce)

foreign import getScreenSize :: forall eff. Eff eff { w :: Number, h :: Number }

-- 1st element is a backbuffer, 2nd the one shown on screen
-- foreign import scrollCanvas :: forall eff.
--                                CanvasElement
--                             -> CanvasElement
--                             -> Point
--                             -> Eff eff Unit

-- creates a new CanvasElement, not attached to the DOM and thus not visible
-- foreign import newCanvas :: forall eff.
--                             { w :: Number, h :: Number }
--                          -> Eff eff CanvasElement

foreign import clearCanvas :: forall eff. CanvasElement -> Eff eff Unit

-- set an event to fire on the given button id
foreign import buttonEvent :: String
                           -> Event Unit

-- foreign import canvasDragImpl :: CanvasElement -> Event { during :: Nullable Point
--                                                         , total :: Nullable Point }

-- foreign import canvasEvent :: String -> CanvasElement -> Event Point

foreign import setViewUI :: forall eff. String -> Eff eff Unit

type View = { lHand :: ChrId, rHand :: ChrId }

type ZipperRange a =
  { left  :: List a
  , focus :: List a
  , right :: List a
  }

zipSlideLeft :: forall a.
                ZipperRange a
             -> ZipperRange a
zipSlideLeft zr@{left, focus, right} = case List.uncons left, List.unsnoc focus of
    Nothing, _  -> zr
    _ , Nothing -> zr
    Just l, Just f ->
      let left'  = l.tail
          focus' = l.head : f.init
          right' = f.last : right
      in {left: left', focus: focus', right: right'}

zipSlideRight :: forall a.
                 ZipperRange a
              -> ZipperRange a
zipSlideRight zr@{left, focus, right} = case List.uncons focus, List.uncons right of
    Nothing, _  -> zr
    _ , Nothing -> zr
    Just f, Just r ->
      let left'  = f.head : left
          focus' = f.tail <> List.singleton r.head
          right' = r.tail
      in {left: left', focus: focus', right: right'}

zipZoomIn :: forall a.
             ZipperRange a
          -> ZipperRange a
zipZoomIn zr@{left, focus, right} = case List.uncons focus of
  Nothing -> zr
  Just {head, tail} -> case List.unsnoc tail of
    Nothing -> zr
    Just {init, last} ->
      let left'  = head : left
          focus' = init
          right' = last : right
      in {left: left', focus: focus', right: right'}

zipZoomOut :: forall a.
              ZipperRange a
           -> ZipperRange a
zipZoomOut zr@{left, focus, right} = case List.uncons left, List.uncons right of
  Nothing, Nothing -> zr
  Nothing, Just r ->
    let focus' = focus <> List.singleton r.head
        right' = r.tail
    in zr { focus = focus', right = right' }
  Just l, Nothing ->
    let left' = l.tail
        focus' = l.head : focus
    in zr { focus = focus', left = left' }
  Just l, Just r ->
    let left' = l.tail
        focus' = l.head : focus <> List.singleton r.head
        right' = r.tail
    in { left: left', focus: focus', right: right' }

focusArray :: forall a.
              ZipperRange a
           -> Array a
focusArray {focus} = Array.fromFoldable focus

unfocusArray :: forall a.
                Array a
             -> ZipperRange a
unfocusArray arr = { left: Nil
                   , focus: List.fromFoldable arr
                   , right: Nil
                   }

data UpdateView =
    GoLeft
  | GoRight
  | Out
  | In
  | NoOp

btnScroll :: Event UpdateView
btnScroll = const GoLeft  <$> buttonEvent "scrollLeft" <|>
            const GoRight <$> buttonEvent "scrollRight"

btnZoom :: Event UpdateView
btnZoom = const Out <$> buttonEvent "zoomOut" <|>
          const In  <$> buttonEvent "zoomIn"

btnUpdateView :: Event UpdateView
btnUpdateView = btnScroll <|> btnZoom

mkFoldView :: UpdateView
           -> ZipperRange ChrId
           -> ZipperRange ChrId
mkFoldView uv zr = case uv of
  GoLeft  -> zipSlideLeft zr
  GoRight -> zipSlideRight zr
  Out     -> zipZoomOut zr
  In      -> zipZoomIn zr
  NoOp    -> zr

chrZREvent :: Array ChrId
           -> Event UpdateView
           -> Event (ZipperRange ChrId)
chrZREvent chrs uv = Event.fold mkFoldView uv (unfocusArray chrs)

chrsArrayEvent :: Event (ZipperRange ChrId)
               -> Event (Array ChrId)
chrsArrayEvent = map (Array.fromFoldable <<< _.focus)

gemmaDrawingEvent :: forall r.
                     { w :: Pixels, h :: Pixels, p :: Pixels, y :: Pixels }
                  -> { min :: Number, max :: Number }
                  -> List (GWASFeature r)
                  -> Event (Array ChrId)
                  -> Event Drawing
gemmaDrawingEvent pos s gemma evChrs = drawing <$> evChrs
  where drawing chrs = drawGemma pos s chrs gemma

geneDrawingEvent :: forall r.
                    { w :: Pixels, h :: Pixels, p :: Pixels, y :: Pixels }
                 -> { min :: Number, max :: Number }
                 -> List (Gene r)
                 -> Event (Array ChrId)
                 -> Event Drawing
geneDrawingEvent pos s genes evChrs = drawing <$> evChrs
  where drawing chrs = drawGenes pos s genes chrs

main :: Eff _ _
main = launchAff do

  canvas <- liftEff $ unsafePartial $ fromJust <$> getCanvasElementById "canvas"
  ctx <- liftEff $ getContext2D canvas

  {w,h} <- liftEff do
    {w} <- getScreenSize
    h <- getCanvasHeight canvas
    _ <- setCanvasWidth (w-2.0) canvas
    pure {w, h}

  let height = h
      offset = 0.0
      yInfo = { height, offset }

      chrIds = mouseChrIds

  gwasData <- List.fromFoldable <$> fetchGemmaJSON "./gwas.json"

  liftEff $ log $ "parsed " <> show (length gwasData :: Int)

  let sizes = {w, h, p: 4.0, y: 10.0}
      score = {min: 0.1, max: 0.45}

  let viewEvent = chrsArrayEvent $ chrZREvent mouseChrIds btnUpdateView

  genes' <- fetchGene'JSON "./sample_genes.json"
  for_ genes' \gene -> liftEff do
    log $ "Gene: " <> gene.geneID

  liftEff $ log "fetching chrIds"
  genes <- List.fromFoldable <$> traverse geneFetchChrId genes'
  for_ genes \gene -> liftEff do
    log $ "Gene: " <> gene.geneID
    log $ "ChrId: " <> show gene.chrId
    log $ "Start: " <> show gene.start <> "\tEnd: " <> show gene.end

  let ev' :: Event Drawing
      ev' = (gemmaDrawingEvent sizes score gwasData viewEvent) <>
            (geneDrawingEvent sizes score genes viewEvent) <|> (pure mempty)

  let bg = filled (fillColor white) $ rectangle 0.0 0.0 w h

  void $ liftEff $ Event.subscribe viewEvent
       (\arr -> do
           let l = fromMaybe "N/A" $ show <$> Array.head arr
               r = fromMaybe "N/A" $ show <$> Array.last arr
           setViewUI $ show arr)

  -- TODO combine drawings by using layers -- keep the latest drawing per-layer until it gets updated
  liftEff $ log "drawing1"
  void $ liftEff $ Event.subscribe ev' (\d -> Drawing.render ctx (bg <> d))

module Genetics.Browser.Track.UI where

import Prelude

import Control.Alt ((<|>))
import Control.Monad.Aff (Aff, launchAff)
import Control.Monad.Aff.AVar (makeVar, putVar, tryPeekVar)
import Control.Monad.Eff (Eff, foreachE)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Error.Class (throwError)
import DOM.HTML.Types (HTMLElement)
import Data.Argonaut (Json, _Array, _Number, _Object, _String)
import Data.Array (take, zip)
import Data.Array as Array
import Data.Either (Either(..))
import Data.Filterable (class Filterable, filter, filterMap)
import Data.Filterable as Filterable
import Data.Foldable (class Foldable, for_, length)
import Data.Int (round)
import Data.Lens ((^?))
import Data.Lens.Index (ix)
import Data.List (List(..), (:))
import Data.List as List
import Data.Maybe (Maybe(..), fromJust, fromMaybe)
import Data.Newtype (over, unwrap, wrap)
import Data.Nullable (Nullable, toMaybe)
import Data.Traversable (traverse, traverse_)
import Data.Tuple (Tuple(..), snd)
import Debug.Trace (traceShow)
import FRP.Event (Event)
import FRP.Event as Event
import FRP.Event as FRP
import Genetics.Browser.Track.Backend (GWASFeature, drawGemma, fetchGemmaCSV, mouseChrIds)
import Genetics.Browser.Types (ChrId(..))
import Genetics.Browser.View (Pixels)
import Global as Global
import Global.Unsafe (unsafeStringify)
import Graphics.Canvas (CanvasElement, Context2D, TranslateTransform, Transform, getCanvasElementById, getCanvasHeight, getContext2D, setCanvasWidth, transform, translate, withContext)
import Graphics.Drawing (Drawing, fillColor, filled, rectangle, white)
import Graphics.Drawing as Drawing
import Math as Math
import Network.HTTP.Affjax as Affjax
import Partial.Unsafe (unsafePartial)
import Unsafe.Coerce (unsafeCoerce)

foreign import getScreenSize :: forall eff. Eff eff { w :: Number, h :: Number }

-- 1st element is a backbuffer, 2nd the one shown on screen
-- foreign import scrollCanvas :: forall eff.
--                                CanvasElement
--                             -> CanvasElement
--                             -> Point
--                             -> Eff eff Unit

-- creates a new CanvasElement, not attached to the DOM and thus not visible
-- foreign import newCanvas :: forall eff.
--                             { w :: Number, h :: Number }
--                          -> Eff eff CanvasElement

foreign import clearCanvas :: forall eff. CanvasElement -> Eff eff Unit

-- set an event to fire on the given button id
foreign import buttonEvent :: String
                           -> Event Unit

-- foreign import canvasDragImpl :: CanvasElement -> Event { during :: Nullable Point
--                                                         , total :: Nullable Point }

-- foreign import canvasEvent :: String -> CanvasElement -> Event Point

foreign import setViewUI :: forall eff. String -> Eff eff Unit

type View = { lHand :: ChrId, rHand :: ChrId }

type ZipperRange a =
  { left  :: List a
  , focus :: List a
  , right :: List a
  }

zipSlideLeft :: forall a.
                ZipperRange a
             -> ZipperRange a
zipSlideLeft zr@{left, focus, right} = case List.uncons left, List.unsnoc focus of
    Nothing, _  -> zr
    _ , Nothing -> zr
    Just l, Just f ->
      let left'  = l.tail
          focus' = l.head : f.init
          right' = f.last : right
      in {left: left', focus: focus', right: right'}

zipSlideRight :: forall a.
                 ZipperRange a
              -> ZipperRange a
zipSlideRight zr@{left, focus, right} = case List.uncons focus, List.uncons right of
    Nothing, _  -> zr
    _ , Nothing -> zr
    Just f, Just r ->
      let left'  = f.head : left
          focus' = f.tail <> List.singleton r.head
          right' = r.tail
      in {left: left', focus: focus', right: right'}

zipZoomIn :: forall a.
             ZipperRange a
          -> ZipperRange a
zipZoomIn zr@{left, focus, right} = case List.uncons focus of
  Nothing -> zr
  Just {head, tail} -> case List.unsnoc tail of
    Nothing -> zr
    Just {init, last} ->
      let left'  = head : left
          focus' = init
          right' = last : right
      in {left: left', focus: focus', right: right'}

zipZoomOut :: forall a.
              ZipperRange a
           -> ZipperRange a
zipZoomOut zr@{left, focus, right} = case List.uncons left, List.uncons right of
  Nothing, Nothing -> zr
  Nothing, Just r ->
    let focus' = focus <> List.singleton r.head
        right' = r.tail
    in zr { focus = focus', right = right' }
  Just l, Nothing ->
    let left' = l.tail
        focus' = l.head : focus
    in zr { focus = focus', left = left' }
  Just l, Just r ->
    let left' = l.tail
        focus' = l.head : focus <> List.singleton r.head
        right' = r.tail
    in { left: left', focus: focus', right: right' }

focusArray :: forall a.
              ZipperRange a
           -> Array a
focusArray {focus} = Array.fromFoldable focus

unfocusArray :: forall a.
                Array a
             -> ZipperRange a
unfocusArray arr = { left: Nil
                   , focus: List.fromFoldable arr
                   , right: Nil
                   }

data UpdateView =
    GoLeft
  | GoRight
  | Out
  | In
  | NoOp

btnScroll :: Event UpdateView
btnScroll = const GoLeft  <$> buttonEvent "scrollLeft" <|>
            const GoRight <$> buttonEvent "scrollRight"

btnZoom :: Event UpdateView
btnZoom = const Out <$> buttonEvent "zoomOut" <|>
          const In  <$> buttonEvent "zoomIn"

btnUpdateView :: Event UpdateView
btnUpdateView = btnScroll <|> btnZoom

mkFoldView :: UpdateView
           -> ZipperRange ChrId
           -> ZipperRange ChrId
mkFoldView uv zr = case uv of
  GoLeft  -> zipSlideLeft zr
  GoRight -> zipSlideRight zr
  Out     -> zipZoomOut zr
  In      -> zipZoomIn zr
  NoOp    -> zr

chrZREvent :: Array ChrId
           -> Event UpdateView
           -> Event (ZipperRange ChrId)
chrZREvent chrs uv = Event.fold mkFoldView uv (unfocusArray chrs)

chrsArrayEvent :: Event (ZipperRange ChrId)
               -> Event (Array ChrId)
chrsArrayEvent = map (Array.fromFoldable <<< _.focus)

gemmaDrawingEvent :: { w :: Pixels, h :: Pixels, p :: Pixels, y :: Pixels }
                  -> { min :: Number, max :: Number }
                  -> List (GWASFeature ())
                  -> Event (Array ChrId)
                  -> Event Drawing
gemmaDrawingEvent {w,h,p,y} s gemma evChrs = drawing <$> evChrs
  where drawing chrs = drawGemma w h p y s chrs gemma

foreign import effEvent :: forall eff. Unit -> { fun :: Eff eff Unit, ev :: Event Unit }

main :: Eff _ _
main = launchAff do

  canvas <- liftEff $ unsafePartial $ fromJust <$> getCanvasElementById "canvas"
  ctx <- liftEff $ getContext2D canvas

  {w,h} <- liftEff do
    {w} <- getScreenSize
    h <- getCanvasHeight canvas
    _ <- setCanvasWidth (w-2.0) canvas
    pure {w, h}

  let height = h
      offset = 0.0
      yInfo = { height, offset }

      chrIds = mouseChrIds

  gwasData <- fetchGemmaCSV "./gwas.csv"

  let sizes = {w, h, p: 4.0, y: 0.0}
      score = {min: 0.0, max: 0.4}

  let viewEvent = chrsArrayEvent $ chrZREvent mouseChrIds btnUpdateView

  let ev = gemmaDrawingEvent sizes score gwasData viewEvent
      bg = filled (fillColor white) $ rectangle 0.0 0.0 w h

  _ <- liftEff $ Event.subscribe viewEvent
       (\arr -> do
           let l = fromMaybe "N/A" $ show <$> Array.head arr
               r = fromMaybe "N/A" $ show <$> Array.last arr
           setViewUI $ show arr)

  liftEff $ Event.subscribe ev (\d -> Drawing.render ctx (bg <> d))


Fixed errorHandler

Fixed errorHandler

closeHandler should be called to when an error occurs - so a call to
realize in errorHandler should not be needed.

module Servant.Subscriber.Internal where

import Prelude
import Control.Monad.Eff.Ref as Ref
import Control.Monad.Eff.Var as Var
import Control.Monad.ST as ST
import DOM.HTML.Event.ErrorEvent as ErrorEvent
import DOM.Websocket.Event.CloseEvent as CloseEvent
import Data.List as List
import Data.StrMap as StrMap
import Data.StrMap.ST as SM
import Data.StrMap.ST.Unsafe as ST
import Servant.Subscriber.Response as Resp
import WebSocket as WS
import Control.Bind ((<=<))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (Error, EXCEPTION, catchException)
import Control.Monad.Eff.Ref (Ref, REF, modifyRef, readRef, writeRef)
import DOM (DOM)
import DOM.Event.Types (keyboardEventToEvent, Event)
import DOM.Websocket.Event.Types (CloseEvent, MessageEvent)
import Data.Argonaut.Core (Json)
import Data.Argonaut.Generic.Aeson (encodeJson, decodeJson)
import Data.Argonaut.Parser (jsonParser)
import Data.Argonaut.Printer (printJson)
import Data.Bifunctor (lmap)
import Data.Either (Either(Right, Left))
import Data.Foldable (traverse_, sequence_, elem, intercalate, foldl)
import Data.Function.Eff (EffFn2, runEffFn2)
import Data.Function.Uncurried (Fn4)
import Data.Generic (gShow, gEq, gCompare, class Generic)
import Data.Lens ((^.), view, prism, (.~), _Just, _2)
import Data.Lens.At (at)
import Data.Lens.Lens (lens)
import Data.Lens.Types (PrismP, LensP)
import Data.List (List, filter)
import Data.Maybe (Maybe(Nothing, Just))
import Data.StrMap (thawST, pureST, StrMap)
import Data.StrMap.ST (STStrMap)
import Data.Tuple (Tuple(Tuple), fst)
import Partial.Unsafe (unsafeCrashWith)
import Servant.PureScript.Util (reportError)
import Servant.Subscriber.Request (HttpRequest(HttpRequest), Request(Subscribe, Unsubscribe, SetPongRequest, SetCloseRequest))
import Servant.Subscriber.Response (HttpResponse)
import Servant.Subscriber.Types (Path(Path))
import Unsafe.Coerce (unsafeCoerce)
import WebSocket (WEBSOCKET, Message(Message), ReadyState(Open), newWebSocket)

type SubscriberEff eff = Eff (ref :: REF, ws :: WEBSOCKET, err :: EXCEPTION | eff)

type Orders a = StrMap (Order a)

type Connection eff a = {
    orders       :: Ref (Orders a)
  , url          :: WS.URL
  , callback     :: a -> SubscriberEff eff Unit
  , notify       :: Notification -> SubscriberEff eff Unit
  , connection   :: Ref ConnectionState
  , pongRequest  :: Ref (Maybe OrderKey)
  , closeRequest :: Ref (Maybe OrderKey)
  }

type OrderKey = String

data ConnectionState = NoConnection
                     | ConnectionRequested
                     | Established WS.Connection

makeOrderKey :: HttpRequest -> OrderKey
makeOrderKey = gShow

-- | Information about a subscription:
--   What to subscribe and whom to respond to.
type Subscription a = {
    req :: HttpRequest
  , parseResponses :: List (ToUserType a)
  }

data Notification = WebSocketError String
           | WebSocketClosed String
           | HttpRequestFailed HttpRequest HttpResponse
           | ParseError String -- |< Server response could not be parsed/ Server could not parse our request.

derive instance genericNotification :: Generic Notification

-- | Convert a json modified response to a user specified sum type.
--   The given parameter is 'Nothing' on a Deleted event.
type ToUserType a = Maybe Json -> Either String a

data SubscriptionState = Ordered | Sent | Confirmed

derive instance eqSubscriptionState :: Eq SubscriptionState

type Order a = {
    req :: Request
  , parseResponses :: List (ToUserType a)
  , state :: SubscriptionState
  }

req :: forall r a. LensP ({ req :: a | r}) a
req = lens _.req (\r -> r { req = _ })

state :: forall r a. LensP ({ state :: a | r}) a
state = lens _.state (\r -> r { state = _ })

coerceEffects :: forall eff0 eff1 a. Eff eff0 a -> Eff eff1 a
coerceEffects = unsafeCoerce

-- | Call this function to actually send requests to the server.
realize :: forall eff a. Connection eff a -> SubscriberEff eff Unit
realize impl = do
      mc <- readRef impl.connection
      case mc of
          NoConnection -> makeConnection impl
          ConnectionRequested -> pure unit
          Established c ->  sendRequests c impl

-- | Takes care of actually subscribing stuff.
sendRequests :: forall eff a. WS.Connection -> Connection eff a -> SubscriberEff eff Unit
sendRequests (WS.Connection conn) impl = do
      ordered <- List.filter ((_ == Ordered) <<< _.state) <<< StrMap.values <$> Ref.readRef impl.orders
      let
        mkMsg :: Request -> Message
        mkMsg = Message <<< printJson <<< encodeJson

        msgs = map (mkMsg <<< _.req) ordered

      sequence_ $ map conn.send msgs
    --  modifyRef impl.subscriptions $ over (mapped <<< state <<< match Requested) (const Sent) -- Does not work currently.
    --  modifyRef impl.subscriptions $ traverse <<< state <<< filtered (_ == Ordered) .~ Sent -- Does not work currently
      modifyRef impl.orders $ map (\sub -> if sub.state == Ordered then sub { state = Sent } else sub)

initConnection :: forall eff a. Connection eff a -> SubscriberEff eff Unit
initConnection impl = do
      mConn <- readRef impl.connection
      case mConn of
        NoConnection -> makeConnection impl
        _ -> pure unit

makeConnection :: forall eff a. Connection eff a -> SubscriberEff eff Unit
makeConnection impl = do
      WS.Connection conn <- newWebSocket impl.url []
      writeRef impl.connection ConnectionRequested
      Var.set conn.onclose   $ closeHandler impl
      Var.set conn.onmessage $ messageHandler impl
      Var.set conn.onerror   $ errorHandler impl
      Var.set conn.onopen    $ openHandler (WS.Connection conn) impl

openHandler :: forall eff a. WS.Connection -> Connection eff a -> Event -> SubscriberEff eff Unit
openHandler conn@(WS.Connection conn') impl _ = do
  prevState <- readRef impl.connection
  case prevState of
    ConnectionRequested -> do
      writeRef impl.connection $ Established conn
      sendRequests conn impl
    NoConnection -> -- Close was requested
      conn'.close' (WS.Code 1000) Nothing
    Established _ -> -- Anything else is an error - we have a bug in this library.
      unsafeCrashWith "purescript-subscriber: openHandler called, but connection was already open!"

closeHandler :: forall eff a. Connection eff a -> CloseEvent -> SubscriberEff eff Unit
closeHandler impl ev = do
      writeRef impl.connection NoConnection
      subs <- readRef impl.orders
      if StrMap.isEmpty subs
        then pure unit
        else do
          modifyRef impl.orders $ updateSubscriptions
          setTimeout (realize impl) 1500
      impl.notify $ WebSocketClosed ("code: " <> (show <<< CloseEvent.code) ev <> ", reason: " <> CloseEvent.reason ev)
  where
    isUnsubscribe :: Request -> Boolean
    isUnsubscribe (Unsubscribe _) = true
    isUnsubscribe _ = false

    updateSubscriptions :: Orders a -> Orders a
    updateSubscriptions subs = let
          forRemoval = map fst <<< List.filter (isUnsubscribe <<< view (_2 <<< req)) <<< StrMap.toList $ subs
          cleanedSubs = foldl (flip StrMap.delete) subs forRemoval
        in
          map ( _ { state = Ordered } ) cleanedSubs

errorHandler :: forall eff a. Connection eff a -> Event -> SubscriberEff eff Unit
errorHandler impl ev =
  impl.notify $ WebSocketError ((ErrorEvent.message <<< unsafeCoerce) ev)

messageHandler :: forall eff a. Connection eff a -> MessageEvent -> SubscriberEff eff Unit
messageHandler impl msgEvent =  do
      let msg = WS.runMessage <<< WS.runMessageEvent $ msgEvent
      let eDecoded = decodeJson <=< jsonParser $ msg
      case eDecoded of
        Left err -> impl.notify $ ParseError (err <> ", input: '" <> msg <> "'")
        Right resp -> do
            modifyRef impl.orders $ case resp of
                Resp.Subscribed req'          -> onlyIfSent req' $ \key -> at key <<< _Just <<< state .~ Confirmed
                Resp.Deleted path             -> handleDelete path
                Resp.Unsubscribed req'        -> onlyIfSent req' $ \key -> at key .~ (Nothing :: Maybe (Order a))
                Resp.Modified _ _             -> id
                Resp.HttpRequestFailed req' _ -> onlyIfSent req' $ \key -> at key .~ (Nothing :: Maybe (Order a))
                Resp.ParseError               -> id
            orders' <- readRef impl.orders
            case resp of
              Resp.Modified req' val            -> doCallback req' (Just val) impl
              Resp.Deleted  path                -> traverse_ (\order' -> doCallback (getHttpReq order'.req) Nothing impl)
                                                   $ getOrdersByPath path orders'
              Resp.HttpRequestFailed req' resp' -> impl.notify $ HttpRequestFailed req' resp'
              Resp.ParseError                   -> impl.notify $ ParseError "Server could not parse our request!"
              Resp.Subscribed _                 -> pure unit
              Resp.Unsubscribed _               -> pure unit

-- | Only update our orders from messageHandler if state is still `Sent` to avoid overriding of more recent user requests.
onlyIfSent :: forall a. HttpRequest -> (OrderKey -> Orders a -> Orders a) -> Orders a -> Orders a
onlyIfSent req' action orders' =
  let
    key = makeOrderKey req'
    order' = orders' ^. at key
  in
   case (_.state) <$> order' of
     Just Sent -> action key orders'
     _    -> orders'

handleDelete :: forall a. Path -> Orders a -> Orders a
handleDelete p = StrMap.fromList <<< filter canStay <<< StrMap.toList
  where
    canStay :: Tuple String (Order a) -> Boolean
    canStay (Tuple _ order) = let req' = runHttpRequest $ getHttpReq order.req
                              in
                               (not <<< eqPath) req'.httpPath p || order.state /= Confirmed -- Only delete if already successfully subscribed!

getOrdersByPath :: forall a. Path -> Orders a -> List (Order a)
getOrdersByPath path = filter (eqPath path <<< getPath <<< _.req) <<< StrMap.values

doCallback :: forall eff a. HttpRequest -> Maybe String -> Connection eff a -> SubscriberEff eff Unit
doCallback req' res impl = do
  orders' <- readRef impl.orders
  let
    order' = case StrMap.lookup (makeOrderKey req') orders' of
      Nothing -> unsafeCrashWith $ "Received a message for an unregistered handler: " <> gShow req'
      Just o -> o
    parsers = order'.parseResponses
    eitherVals :: List (Either String a)
    eitherVals = case res of
      Nothing ->  map (_ $ Nothing) parsers
      Just str -> flip doDecode str <$> parsers
    handleEitherVal :: Either String a -> SubscriberEff eff Unit
    handleEitherVal eitherVal =case eitherVal of
      Right decoded -> impl.callback decoded
      Left err -> impl.notify $ ParseError err
  traverse_ handleEitherVal eitherVals

doDecode :: forall a. ToUserType a -> String -> Either String a
doDecode parser str = do
      jVal <- lmap (reportError id str <<< ("Parsing json response failed: " <> _))
              <<< jsonParser $ str
      parser $ Just jVal

-- | Prism for only setting a value if it is equal to a.
match :: forall a. Eq a => a -> PrismP a a
match a = prism id $ \b -> if a == b then Right a else Left b

try :: forall a eff. Eff (err :: EXCEPTION | eff) a -> Eff eff (Either Error a)
try action = catchException (pure <<< Left) (map Right action)

eqPath :: Path -> Path -> Boolean
eqPath (Path p1) (Path p2) = eq p1 p2

getPath :: Request -> Path
getPath = _.httpPath <<< runHttpRequest <<< getHttpReq

getHttpReq :: Request -> HttpRequest
getHttpReq req' = case req' of
  Subscribe hreq   -> hreq
  Unsubscribe hreq -> hreq
  SetPongRequest hreq -> hreq
  SetCloseRequest hreq -> hreq

runHttpRequest (HttpRequest req') = req'

 -- Copied from Data.StrMap (not exported):
mutate :: forall a b. (forall h . SM.STStrMap h a -> Eff (st :: ST.ST h ) b) -> StrMap a -> StrMap a
mutate f m = ST.pureST (do
  s <- myThawST m
  f s
  ST.unsafeGet s)

foreign import _lookup :: forall a z. Fn4 z (a -> z) String (StrMap a) z

foreign import setTimeoutImpl :: forall eff.
  EffFn2 eff (Eff eff Unit) Int Unit

setTimeout :: forall eff. Eff eff Unit -> Int -> Eff eff Unit
setTimeout = runEffFn2 setTimeoutImpl

myThawST :: forall a h. StrMap a -> Eff ( st :: ST.ST h) (STStrMap h a)
myThawST = unsafeCoerce thawST

module Servant.Subscriber.Internal where

import Prelude
import Control.Monad.Eff.Ref as Ref
import Control.Monad.Eff.Var as Var
import Control.Monad.ST as ST
import DOM.HTML.Event.ErrorEvent as ErrorEvent
import DOM.Websocket.Event.CloseEvent as CloseEvent
import Data.List as List
import Data.StrMap as StrMap
import Data.StrMap.ST as SM
import Data.StrMap.ST.Unsafe as ST
import Servant.Subscriber.Response as Resp
import WebSocket as WS
import Control.Bind ((<=<))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (Error, EXCEPTION, catchException)
import Control.Monad.Eff.Ref (Ref, REF, modifyRef, readRef, writeRef)
import DOM (DOM)
import DOM.Event.Types (keyboardEventToEvent, Event)
import DOM.Websocket.Event.Types (CloseEvent, MessageEvent)
import Data.Argonaut.Core (Json)
import Data.Argonaut.Generic.Aeson (encodeJson, decodeJson)
import Data.Argonaut.Parser (jsonParser)
import Data.Argonaut.Printer (printJson)
import Data.Bifunctor (lmap)
import Data.Either (Either(Right, Left))
import Data.Foldable (traverse_, sequence_, elem, intercalate, foldl)
import Data.Function.Eff (EffFn2, runEffFn2)
import Data.Function.Uncurried (Fn4)
import Data.Generic (gShow, gEq, gCompare, class Generic)
import Data.Lens ((^.), view, prism, (.~), _Just, _2)
import Data.Lens.At (at)
import Data.Lens.Lens (lens)
import Data.Lens.Types (PrismP, LensP)
import Data.List (List, filter)
import Data.Maybe (Maybe(Nothing, Just))
import Data.StrMap (thawST, pureST, StrMap)
import Data.StrMap.ST (STStrMap)
import Data.Tuple (Tuple(Tuple), fst)
import Partial.Unsafe (unsafeCrashWith)
import Servant.PureScript.Util (reportError)
import Servant.Subscriber.Request (HttpRequest(HttpRequest), Request(Subscribe, Unsubscribe, SetPongRequest, SetCloseRequest))
import Servant.Subscriber.Response (HttpResponse)
import Servant.Subscriber.Types (Path(Path))
import Unsafe.Coerce (unsafeCoerce)
import WebSocket (WEBSOCKET, Message(Message), ReadyState(Open), newWebSocket)

type SubscriberEff eff = Eff (ref :: REF, ws :: WEBSOCKET, err :: EXCEPTION | eff)

type Orders a = StrMap (Order a)

type Connection eff a = {
    orders       :: Ref (Orders a)
  , url          :: WS.URL
  , callback     :: a -> SubscriberEff eff Unit
  , notify       :: Notification -> SubscriberEff eff Unit
  , connection   :: Ref ConnectionState
  , pongRequest  :: Ref (Maybe OrderKey)
  , closeRequest :: Ref (Maybe OrderKey)
  }

type OrderKey = String

data ConnectionState = NoConnection
                     | ConnectionRequested
                     | Established WS.Connection

makeOrderKey :: HttpRequest -> OrderKey
makeOrderKey = gShow

-- | Information about a subscription:
--   What to subscribe and whom to respond to.
type Subscription a = {
    req :: HttpRequest
  , parseResponses :: List (ToUserType a)
  }

data Notification = WebSocketError String
           | WebSocketClosed String
           | HttpRequestFailed HttpRequest HttpResponse
           | ParseError String -- |< Server response could not be parsed/ Server could not parse our request.

derive instance genericNotification :: Generic Notification

-- | Convert a json modified response to a user specified sum type.
--   The given parameter is 'Nothing' on a Deleted event.
type ToUserType a = Maybe Json -> Either String a

data SubscriptionState = Ordered | Sent | Confirmed

derive instance eqSubscriptionState :: Eq SubscriptionState

type Order a = {
    req :: Request
  , parseResponses :: List (ToUserType a)
  , state :: SubscriptionState
  }

req :: forall r a. LensP ({ req :: a | r}) a
req = lens _.req (\r -> r { req = _ })

state :: forall r a. LensP ({ state :: a | r}) a
state = lens _.state (\r -> r { state = _ })

coerceEffects :: forall eff0 eff1 a. Eff eff0 a -> Eff eff1 a
coerceEffects = unsafeCoerce

-- | Call this function to actually send requests to the server.
realize :: forall eff a. Connection eff a -> SubscriberEff eff Unit
realize impl = do
      mc <- readRef impl.connection
      case mc of
          NoConnection -> makeConnection impl
          ConnectionRequested -> pure unit
          Established c ->  sendRequests c impl

-- | Takes care of actually subscribing stuff.
sendRequests :: forall eff a. WS.Connection -> Connection eff a -> SubscriberEff eff Unit
sendRequests (WS.Connection conn) impl = do
      ordered <- List.filter ((_ == Ordered) <<< _.state) <<< StrMap.values <$> Ref.readRef impl.orders
      let
        mkMsg :: Request -> Message
        mkMsg = Message <<< printJson <<< encodeJson

        msgs = map (mkMsg <<< _.req) ordered

      sequence_ $ map conn.send msgs
    --  modifyRef impl.subscriptions $ over (mapped <<< state <<< match Requested) (const Sent) -- Does not work currently.
    --  modifyRef impl.subscriptions $ traverse <<< state <<< filtered (_ == Ordered) .~ Sent -- Does not work currently
      modifyRef impl.orders $ map (\sub -> if sub.state == Ordered then sub { state = Sent } else sub)

initConnection :: forall eff a. Connection eff a -> SubscriberEff eff Unit
initConnection impl = do
      mConn <- readRef impl.connection
      case mConn of
        NoConnection -> makeConnection impl
        _ -> pure unit

makeConnection :: forall eff a. Connection eff a -> SubscriberEff eff Unit
makeConnection impl = do
      WS.Connection conn <- newWebSocket impl.url []
      writeRef impl.connection ConnectionRequested
      Var.set conn.onclose   $ closeHandler impl
      Var.set conn.onmessage $ messageHandler impl
      Var.set conn.onerror   $ errorHandler impl
      Var.set conn.onopen    $ openHandler (WS.Connection conn) impl

openHandler :: forall eff a. WS.Connection -> Connection eff a -> Event -> SubscriberEff eff Unit
openHandler conn@(WS.Connection conn') impl _ = do
  prevState <- readRef impl.connection
  case prevState of
    ConnectionRequested -> do
      writeRef impl.connection $ Established conn
      sendRequests conn impl
    NoConnection -> -- Close was requested
      conn'.close' (WS.Code 1000) Nothing
    Established _ -> -- Anything else is an error - we have a bug in this library.
      unsafeCrashWith "purescript-subscriber: openHandler called, but connection was already open!"

closeHandler :: forall eff a. Connection eff a -> CloseEvent -> SubscriberEff eff Unit
closeHandler impl ev = do
      writeRef impl.connection NoConnection
      subs <- readRef impl.orders
      if StrMap.isEmpty subs
        then pure unit
        else do
          modifyRef impl.orders $ updateSubscriptions
          setTimeout (realize impl) 1500
      impl.notify $ WebSocketClosed ("code: " <> (show <<< CloseEvent.code) ev <> ", reason: " <> CloseEvent.reason ev)
  where
    isUnsubscribe :: Request -> Boolean
    isUnsubscribe (Unsubscribe _) = true
    isUnsubscribe _ = false

    updateSubscriptions :: Orders a -> Orders a
    updateSubscriptions subs = let
          forRemoval = map fst <<< List.filter (isUnsubscribe <<< view (_2 <<< req)) <<< StrMap.toList $ subs
          cleanedSubs = foldl (flip StrMap.delete) subs forRemoval
        in
          map ( _ { state = Ordered } ) cleanedSubs

errorHandler :: forall eff a. Connection eff a -> Event -> SubscriberEff eff Unit
errorHandler impl ev = do
      impl.notify $ WebSocketError ((ErrorEvent.message <<< unsafeCoerce) ev)
      setTimeout (realize impl) 1500 -- Something went wrong - retry.

messageHandler :: forall eff a. Connection eff a -> MessageEvent -> SubscriberEff eff Unit
messageHandler impl msgEvent =  do
      let msg = WS.runMessage <<< WS.runMessageEvent $ msgEvent
      let eDecoded = decodeJson <=< jsonParser $ msg
      case eDecoded of
        Left err -> impl.notify $ ParseError (err <> ", input: '" <> msg <> "'")
        Right resp -> do
            modifyRef impl.orders $ case resp of
                Resp.Subscribed req'          -> onlyIfSent req' $ \key -> at key <<< _Just <<< state .~ Confirmed
                Resp.Deleted path             -> handleDelete path
                Resp.Unsubscribed req'        -> onlyIfSent req' $ \key -> at key .~ (Nothing :: Maybe (Order a))
                Resp.Modified _ _             -> id
                Resp.HttpRequestFailed req' _ -> onlyIfSent req' $ \key -> at key .~ (Nothing :: Maybe (Order a))
                Resp.ParseError               -> id
            orders' <- readRef impl.orders
            case resp of
              Resp.Modified req' val            -> doCallback req' (Just val) impl
              Resp.Deleted  path                -> traverse_ (\order' -> doCallback (getHttpReq order'.req) Nothing impl)
                                                   $ getOrdersByPath path orders'
              Resp.HttpRequestFailed req' resp' -> impl.notify $ HttpRequestFailed req' resp'
              Resp.ParseError                   -> impl.notify $ ParseError "Server could not parse our request!"
              Resp.Subscribed _                 -> pure unit
              Resp.Unsubscribed _               -> pure unit

-- | Only update our orders from messageHandler if state is still `Sent` to avoid overriding of more recent user requests.
onlyIfSent :: forall a. HttpRequest -> (OrderKey -> Orders a -> Orders a) -> Orders a -> Orders a
onlyIfSent req' action orders' =
  let
    key = makeOrderKey req'
    order' = orders' ^. at key
  in
   case (_.state) <$> order' of
     Just Sent -> action key orders'
     _    -> orders'

handleDelete :: forall a. Path -> Orders a -> Orders a
handleDelete p = StrMap.fromList <<< filter canStay <<< StrMap.toList
  where
    canStay :: Tuple String (Order a) -> Boolean
    canStay (Tuple _ order) = let req' = runHttpRequest $ getHttpReq order.req
                              in
                               (not <<< eqPath) req'.httpPath p || order.state /= Confirmed -- Only delete if already successfully subscribed!

getOrdersByPath :: forall a. Path -> Orders a -> List (Order a)
getOrdersByPath path = filter (eqPath path <<< getPath <<< _.req) <<< StrMap.values

doCallback :: forall eff a. HttpRequest -> Maybe String -> Connection eff a -> SubscriberEff eff Unit
doCallback req' res impl = do
  orders' <- readRef impl.orders
  let
    order' = case StrMap.lookup (makeOrderKey req') orders' of
      Nothing -> unsafeCrashWith $ "Received a message for an unregistered handler: " <> gShow req'
      Just o -> o
    parsers = order'.parseResponses
    eitherVals :: List (Either String a)
    eitherVals = case res of
      Nothing ->  map (_ $ Nothing) parsers
      Just str -> flip doDecode str <$> parsers
    handleEitherVal :: Either String a -> SubscriberEff eff Unit
    handleEitherVal eitherVal =case eitherVal of
      Right decoded -> impl.callback decoded
      Left err -> impl.notify $ ParseError err
  traverse_ handleEitherVal eitherVals

doDecode :: forall a. ToUserType a -> String -> Either String a
doDecode parser str = do
      jVal <- lmap (reportError id str <<< ("Parsing json response failed: " <> _))
              <<< jsonParser $ str
      parser $ Just jVal

-- | Prism for only setting a value if it is equal to a.
match :: forall a. Eq a => a -> PrismP a a
match a = prism id $ \b -> if a == b then Right a else Left b

try :: forall a eff. Eff (err :: EXCEPTION | eff) a -> Eff eff (Either Error a)
try action = catchException (pure <<< Left) (map Right action)

eqPath :: Path -> Path -> Boolean
eqPath (Path p1) (Path p2) = eq p1 p2

getPath :: Request -> Path
getPath = _.httpPath <<< runHttpRequest <<< getHttpReq

getHttpReq :: Request -> HttpRequest
getHttpReq req' = case req' of
  Subscribe hreq   -> hreq
  Unsubscribe hreq -> hreq
  SetPongRequest hreq -> hreq
  SetCloseRequest hreq -> hreq

runHttpRequest (HttpRequest req') = req'

 -- Copied from Data.StrMap (not exported):
mutate :: forall a b. (forall h . SM.STStrMap h a -> Eff (st :: ST.ST h ) b) -> StrMap a -> StrMap a
mutate f m = ST.pureST (do
  s <- myThawST m
  f s
  ST.unsafeGet s)

foreign import _lookup :: forall a z. Fn4 z (a -> z) String (StrMap a) z

foreign import setTimeoutImpl :: forall eff.
  EffFn2 eff (Eff eff Unit) Int Unit

setTimeout :: forall eff. Eff eff Unit -> Int -> Eff eff Unit
setTimeout = runEffFn2 setTimeoutImpl

myThawST :: forall a h. StrMap a -> Eff ( st :: ST.ST h) (STStrMap h a)
myThawST = unsafeCoerce thawST


Allow anything inside angles: <ARG...>

Allow anything inside angles: <ARG...>


Fix typo: 'plain' -> 'plane'

Fix typo: 'plain' -> 'plane'

https://en.wikipedia.org/wiki/Plane_(Unicode)#Basic_Multilingual_Plane

module Data.Char.Gen where

import Prelude

import Control.Monad.Gen (class MonadGen, chooseInt, oneOf)
import Data.Char as C
import Data.NonEmpty ((:|))

-- | Generates a character of the Unicode basic multilingual plane.
genUnicodeChar :: forall m. MonadGen m => m Char
genUnicodeChar = C.fromCharCode <$> chooseInt 0 65536

-- | Generates a character in the ASCII character set, excluding control codes.
genAsciiChar :: forall m. MonadGen m => m Char
genAsciiChar = C.fromCharCode <$> chooseInt 32 127

-- | Generates a character in the ASCII character set.
genAsciiChar' :: forall m. MonadGen m => m Char
genAsciiChar' = C.fromCharCode <$> chooseInt 0 127

-- | Generates a character that is a numeric digit.
genDigitChar :: forall m. MonadGen m => m Char
genDigitChar = C.fromCharCode <$> chooseInt 48 57

-- | Generates a character from the basic latin alphabet.
genAlpha :: forall m. MonadGen m => m Char
genAlpha = oneOf (genAlphaLowercase :| [genAlphaUppercase])

-- | Generates a lowercase character from the basic latin alphabet.
genAlphaLowercase :: forall m. MonadGen m => m Char
genAlphaLowercase = C.fromCharCode <$> chooseInt 97 122

-- | Generates an uppercase character from the basic latin alphabet.
genAlphaUppercase :: forall m. MonadGen m => m Char
genAlphaUppercase = C.fromCharCode <$> chooseInt 65 90

module Data.Char.Gen where

import Prelude

import Control.Monad.Gen (class MonadGen, chooseInt, oneOf)
import Data.Char as C
import Data.NonEmpty ((:|))

-- | Generates a character of the Unicode basic multilingual plain.
genUnicodeChar :: forall m. MonadGen m => m Char
genUnicodeChar = C.fromCharCode <$> chooseInt 0 65536

-- | Generates a character in the ASCII character set, excluding control codes.
genAsciiChar :: forall m. MonadGen m => m Char
genAsciiChar = C.fromCharCode <$> chooseInt 32 127

-- | Generates a character in the ASCII character set.
genAsciiChar' :: forall m. MonadGen m => m Char
genAsciiChar' = C.fromCharCode <$> chooseInt 0 127

-- | Generates a character that is a numeric digit.
genDigitChar :: forall m. MonadGen m => m Char
genDigitChar = C.fromCharCode <$> chooseInt 48 57

-- | Generates a character from the basic latin alphabet.
genAlpha :: forall m. MonadGen m => m Char
genAlpha = oneOf (genAlphaLowercase :| [genAlphaUppercase])

-- | Generates a lowercase character from the basic latin alphabet.
genAlphaLowercase :: forall m. MonadGen m => m Char
genAlphaLowercase = C.fromCharCode <$> chooseInt 97 122

-- | Generates an uppercase character from the basic latin alphabet.
genAlphaUppercase :: forall m. MonadGen m => m Char
genAlphaUppercase = C.fromCharCode <$> chooseInt 65 90