More accurate handling of close event

More accurate handling of close event

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 (unless)
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
      let updatedSubs = updateSubscriptions subs
      writeRef impl.orders updatedSubs
      unless (StrMap.isEmpty updatedSubs)
        $ 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 =
  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


Guarantee recalc on mirror (#1350)

Guarantee recalc on mirror (#1350)

{-
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.Draftboard.Component where

import SlamData.Prelude

import Control.Monad.Aff (later)

import Data.Foldable (and, all, find)
import Data.Int as Int
import Data.List (List(..), (:))
import Data.List as List
import Data.Map as Map
import Data.Ord (abs)
import Data.Rational (Rational, (%))

import Halogen as H
import Halogen.Component.Utils (liftH')
import Halogen.Component.Utils.Drag as Drag

import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Card.Component as CC
import SlamData.Workspace.Card.Draftboard.Layout as Layout
import SlamData.Workspace.Card.Draftboard.Orientation as Orn
import SlamData.Workspace.Card.Draftboard.Pane as Pane
import SlamData.Workspace.Card.Model as Card
import SlamData.Workspace.Card.Common (CardOptions)
import SlamData.Workspace.Card.Draftboard.Component.Common (DraftboardDSL)
import SlamData.Workspace.Card.Draftboard.Component.Query (Query(..))
import SlamData.Workspace.Card.Draftboard.Component.Render (render)
import SlamData.Workspace.Card.Draftboard.Component.State (MoveLocation(..), initialState, modelFromState, updateRect, updateLayout)
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Deck.Component.Nested.Query as DNQ
import SlamData.Workspace.Deck.Component.Query as DCQ
import SlamData.Workspace.Deck.DeckId (DeckId)
import SlamData.Workspace.Deck.Model (emptyDeck)
import SlamData.Workspace.Eval.Deck as ED
import SlamData.Workspace.Eval.Persistence as P

import Utils.DOM (getOffsetClientRect)

draftboardComponent ∷ CardOptions → CC.CardComponent
draftboardComponent options = CC.makeCardComponent
  { options
  , cardType: CT.Draftboard
  , component: H.parentComponent
      { render: render options
      , eval: coproduct evalCard (evalBoard options)
      , peek: Just (peek options)
      }
  , initialState: H.parentState initialState
  , _State: CC._DraftboardState
  , _Query: CC.makeQueryPrism' CC._DraftboardQuery
  }

evalCard ∷ CC.CardEvalQuery ~> DraftboardDSL
evalCard = case _ of
  CC.Activate next →
    pure next
  CC.Deactivate next →
    pure next
  CC.Save k →
    map (k ∘ Card.Draftboard ∘ modelFromState) H.get
  CC.Load card next → do
    case card of
      Card.Draftboard model → do
        H.modify (updateLayout model.layout)
        -- TODO: Why??? Remove this when we update to newer Halogen
        H.fromAff (later (pure unit))
        void $ H.queryAll (right (H.action DCQ.UpdateCardSize))
      _ → pure unit
    pure next
  CC.ReceiveInput _ _ next →
    pure next
  CC.ReceiveOutput _ _ next →
    pure next
  CC.ReceiveState _ next →
    pure next
  CC.ReceiveDimensions dims next → do
    recalcRect
    H.queryAll (right (H.action DCQ.UpdateCardSize))
    pure next
  CC.ModelUpdated _ next →
    pure next
  CC.ZoomIn next →
    pure next

evalBoard ∷ CardOptions → Query ~> DraftboardDSL
evalBoard opts = case _ of
  SetRoot el next → do
    st ← H.get
    H.modify _ { root = el }
    pure next
  SplitStart orientation bias root ev next → do
    st ← H.get
    Drag.subscribe' ev (right ∘ H.action ∘ Splitting)
    H.modify _ { splitOpts = Just { orientation, bias, root } }
    pure next
  Splitting ev next → do
    st ← H.get
    case ev of
      Drag.Move _ d → do
        let
          x = d.x - st.rootRect.left
          y = d.y - st.rootRect.top
          result = do
            { orientation, bias, root } ← st.splitOpts
            { cursor } ← overlapping x y st.cellLayout
            let
              rectR = st.rootRect
              cursor' =
                if not root
                  then fromMaybe Nil (Layout.findSplit orientation cursor st.layout)
                  else Nil
            rs ←
              if List.null cursor'
                then pure Nil
                else getRatios =<< Pane.getAt cursor' st.layout
            rectT ← Layout.absoluteRect rectR <$> Layout.rectAt cursor' st.layout
            let
              relX = d.x - (rectR.left + rectT.left)
              relY = d.y - (rectR.top + rectT.top)
            pure case orientation of
              Orn.Horizontal →
                let
                  ratio = Layout.closestSnapRatio (relX / rectT.width)
                  valid = isSensibleSplit ratio rs && not (isEdge ratio)
                in
                  { orientation
                  , bias
                  , cursor: cursor'
                  , ratio
                  , valid
                  , x: d.x - rectR.left
                  , y: rectT.top
                  , z: rectT.height
                  }
              Orn.Vertical →
                let
                  ratio = Layout.closestSnapRatio (relY / rectT.height)
                  valid = isSensibleSplit ratio rs && not (isEdge ratio)
                in
                  { orientation
                  , bias
                  , cursor: cursor'
                  , ratio
                  , valid
                  , x: rectT.left
                  , y: d.y - rectR.top
                  , z: rectT.width
                  }
        H.modify _ { splitLocation = result }
      Drag.Done _ → do
        let
          result = do
            splitOpts ← st.splitOpts
            loc ← st.splitLocation
            guard loc.valid
            if splitOpts.root
              then pure (Layout.insertRootSplit (Pane.Cell Nothing) loc.orientation loc.ratio loc.bias st.layout)
              else Layout.insertSplit (Pane.Cell Nothing) loc.orientation loc.ratio loc.bias loc.cursor st.layout
        H.modify
          $ updateLayout (fromMaybe st.layout result)
          ∘ _ { splitOpts = Nothing, splitLocation = Nothing }
        H.queryAll (right (H.action DCQ.UpdateCardSize))
        CC.raiseUpdatedP' CC.EvalModelUpdate
    pure next
  ResizeStart edge ev next → do
    let
      loc =
        { edge
        , ratio: edge.ratio
        , valid: true
        , collapse: Nothing
        , offset: 0.0
        , initial: case edge.orientation of
            Orn.Horizontal → ev.pageX
            Orn.Vertical   → ev.pageY
        }
    Drag.subscribe' ev (right ∘ H.action ∘ Resizing)
    H.modify _ { resizeLocation = Just loc }
    pure next
  Resizing ev next → do
    st ← H.get
    case ev of
      Drag.Move _ d → do
        let
          rectR = st.rootRect
          result = do
            loc   ← st.resizeLocation
            rectT ← Layout.absoluteRect rectR <$> Layout.rectAt loc.edge.parent st.layout
            sibs  ← Pane.children <$> Pane.getAt loc.edge.parent st.layout
            let
              ix   = loc.edge.index + 1
              relX = d.x - (rectR.left + rectT.left)
              relY = d.y - (rectR.top + rectT.top)
              pre  = List.take ix sibs
              post = List.drop ix sibs
            pure case loc.edge.orientation of
              Orn.Horizontal →
                let
                  ratio = Layout.closestSnapRatio (relX / rectT.width)
                  collapse = isCollapsing ratio pre post
                  valid = not (isEdge ratio) || isJust collapse
                in loc
                  { offset = d.x - loc.initial
                  , ratio = ratio
                  , valid = valid
                  , collapse = collapse
                  }
              Orn.Vertical →
                let
                  ratio = Layout.closestSnapRatio (relY / rectT.height)
                  collapse = isCollapsing ratio pre post
                  valid = not (isEdge ratio) || isJust collapse
                in loc
                  { offset = d.y - loc.initial
                  , ratio = ratio
                  , valid = valid
                  , collapse = collapse
                  }
        H.modify _ { resizeLocation = result }
      Drag.Done _ → do
        let
          result = do
            loc ← st.resizeLocation
            guard loc.valid
            Layout.resizeEdge' loc.edge.index loc.ratio loc.edge.parent st.layout
        H.modify
          $ updateLayout (fromMaybe st.layout result)
          ∘ _ { resizeLocation = Nothing }
        H.queryAll (right (H.action DCQ.UpdateCardSize))
        CC.raiseUpdatedP' CC.EvalModelUpdate
    pure next
  DeleteCell cursor next → do
    st ← H.get
    let
      result = Layout.deleteCell cursor st.layout
    H.modify (updateLayout (fromMaybe st.layout result))
    H.queryAll (right (H.action DCQ.UpdateCardSize))
    CC.raiseUpdatedP' CC.EvalModelUpdate
    pure next
  Grabbing (deckId × cursor) ev next → do
    st ← H.get
    case ev of
      Drag.Move _ d → do
        let
          x = d.x - st.rootRect.left
          y = d.y - st.rootRect.top
        case overlapping x y st.cellLayout of
          Just cell@{ value: Nothing } →
            H.modify _ { moveLocation = Just (Move cell) }
          Just cell@{ value: (Just deckId'), rect } | deckId /= deckId' → do
            let
              relX = Int.floor (x - rect.left) % Int.floor rect.width
              relY = Int.floor (y - rect.top) % Int.floor rect.height
              move = case relX < 1%2, relY < 1%2 of
                xa, ya | xa && ya && relY < relX   → Group cell Orn.Vertical Layout.SideA
                xa, ya | xa && ya                  → Group cell Orn.Horizontal Layout.SideA
                xa, ya | xa && one - relY < relX   → Group cell Orn.Vertical Layout.SideB
                xa, ya | xa                        → Group cell Orn.Horizontal Layout.SideA
                xa, ya | ya && relY < one - relX   → Group cell Orn.Vertical Layout.SideA
                xa, ya | ya                        → Group cell Orn.Horizontal Layout.SideB
                xa, ya | one - relY < one - relX   → Group cell Orn.Vertical Layout.SideB
                _ , _                              → Group cell Orn.Horizontal Layout.SideB
            H.modify _ { moveLocation = Just move }
          _ →
            H.modify _ { moveLocation = Just (Floating x y) }
      Drag.Done _ → do
        for_ st.moveLocation case _ of
          Floating _ _ →
            H.modify _ { moveLocation = Nothing }
          Group cell orn bias →
            for_ cell.value \deckId' → do
              H.modify _ { moveLocation = Nothing }
              groupDeck orn bias deckId deckId'
          Move cell → do
            let
              result =
                pure st.layout
                  >>= Pane.modifyAt (const (Pane.Cell Nothing)) cursor
                  >>= Pane.modifyAt (const (Pane.Cell (Just deckId))) cell.cursor
            H.modify
              $ updateLayout (fromMaybe st.layout result)
              ∘ _ { moveLocation = Nothing }
            void $ queryDeck deckId $ H.action DCQ.UpdateCardSize
        CC.raiseUpdatedP' CC.EvalModelUpdate
    pure next
  AddDeck cursor next → do
    addDeck opts cursor
    CC.raiseUpdatedP' CC.EvalModelUpdate
    pure next

peek ∷ ∀ a. CardOptions → H.ChildF DeckId DNQ.QueryP a → DraftboardDSL Unit
peek opts (H.ChildF deckId q) = coproduct (const (pure unit)) peekDeck q
  where
  peekDeck ∷ DCQ.Query a → DraftboardDSL Unit
  peekDeck q' = do
    st ← H.get
    for_ (Map.lookup deckId st.cursors) \cursor →
      case q' of
        DCQ.GrabDeck ev _ → do
          startDragging ev (Grabbing (deckId × cursor))
        _ → pure unit

  startDragging ev tag =
    void $ Drag.subscribe' ev $ right ∘ H.action ∘ tag

isCollapsing
  ∷ ∀ a
  . Rational
  → List (Pane.Pane (Maybe a))
  → List (Pane.Pane (Maybe a))
  → Maybe Layout.SplitBias
isCollapsing ratio pre post
  | ratio == zero && and (map (all isNothing) pre) = Just Layout.SideA
  | ratio == one && and (map (all isNothing) post) = Just Layout.SideB
  | otherwise = Nothing

isSensibleSplit ∷ Rational → List (Rational) → Boolean
isSensibleSplit ratio = go zero
  where
  go off Nil = true
  go off (r : xs) =
    if abs (ratio - off) < 1%16
      then false
      else go (off + r) xs

getRatios ∷ ∀ a . Pane.Pane a → Maybe (List Rational)
getRatios (Pane.Split _ ps) = Just (map fst ps)
getRatios _ = Nothing

isEdge ∷ Rational → Boolean
isEdge r = r == zero || r == one

overlapping
  ∷ ∀ a
  . Number
  → Number
  → List (Layout.Cell a Number)
  → Maybe (Layout.Cell a Number)
overlapping x y = find go
  where
  go { rect: { top, left, width, height } } =
    y >= top && x >= left && y < top + height && x < left + width

recalcRect ∷ DraftboardDSL Unit
recalcRect = do
  st ← H.get
  for_ st.root \root → do
    rect ← H.fromEff (getOffsetClientRect root)
    H.modify (updateRect rect)

addDeck ∷ CardOptions → Pane.Cursor → DraftboardDSL Unit
addDeck _ cursor = do
  deckId × _ ← liftH' $ P.freshDeck emptyDeck (ED.Completed Port.emptyOut)
  st ← H.get
  let
    layout = Pane.modifyAt (const (Pane.Cell (Just deckId))) cursor st.layout
  H.modify
    $ updateLayout (fromMaybe st.layout layout)
    ∘ _ { inserting = false }
  void $ queryDeck deckId (H.action DCQ.Focus)

groupDeck
  ∷ Orn.Orientation
  → Layout.SplitBias
  → DeckId
  → DeckId
  → DraftboardDSL Unit
groupDeck orn bias deckFrom deckTo = do
  mbActive ← queryDeck deckTo (H.request DCQ.GetActiveCard)
  for_ mbActive case _ of
    Just coord → liftH' $ P.groupDeck orn bias deckFrom deckTo coord
    Nothing → liftH' $ P.wrapAndGroupDeck orn bias deckFrom deckTo

queryDeck ∷ ∀ a. DeckId → DCQ.Query a → DraftboardDSL (Maybe a)
queryDeck slot = H.query slot ∘ right

{-
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.Draftboard.Component where

import SlamData.Prelude

import Data.Foldable (and, all, find)
import Data.Int as Int
import Data.List (List(..), (:))
import Data.List as List
import Data.Map as Map
import Data.Ord (abs)
import Data.Rational (Rational, (%))

import Halogen as H
import Halogen.Component.Utils (liftH')
import Halogen.Component.Utils.Drag as Drag

import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Card.Component as CC
import SlamData.Workspace.Card.Draftboard.Layout as Layout
import SlamData.Workspace.Card.Draftboard.Orientation as Orn
import SlamData.Workspace.Card.Draftboard.Pane as Pane
import SlamData.Workspace.Card.Model as Card
import SlamData.Workspace.Card.Common (CardOptions)
import SlamData.Workspace.Card.Draftboard.Component.Common (DraftboardDSL)
import SlamData.Workspace.Card.Draftboard.Component.Query (Query(..))
import SlamData.Workspace.Card.Draftboard.Component.Render (render)
import SlamData.Workspace.Card.Draftboard.Component.State (MoveLocation(..), initialState, modelFromState, updateRect, updateLayout)
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Deck.Component.Nested.Query as DNQ
import SlamData.Workspace.Deck.Component.Query as DCQ
import SlamData.Workspace.Deck.DeckId (DeckId)
import SlamData.Workspace.Deck.Model (emptyDeck)
import SlamData.Workspace.Eval.Deck as ED
import SlamData.Workspace.Eval.Persistence as P

import Utils.DOM (getOffsetClientRect)

draftboardComponent ∷ CardOptions → CC.CardComponent
draftboardComponent options = CC.makeCardComponent
  { options
  , cardType: CT.Draftboard
  , component: H.parentComponent
      { render: render options
      , eval: coproduct evalCard (evalBoard options)
      , peek: Just (peek options)
      }
  , initialState: H.parentState initialState
  , _State: CC._DraftboardState
  , _Query: CC.makeQueryPrism' CC._DraftboardQuery
  }

evalCard ∷ CC.CardEvalQuery ~> DraftboardDSL
evalCard = case _ of
  CC.Activate next →
    pure next
  CC.Deactivate next →
    pure next
  CC.Save k →
    map (k ∘ Card.Draftboard ∘ modelFromState) H.get
  CC.Load card next → do
    case card of
      Card.Draftboard model → do
        H.modify (updateLayout model.layout)
        void $ H.queryAll (right (H.action DCQ.UpdateCardSize))
      _ → pure unit
    pure next
  CC.ReceiveInput _ _ next →
    pure next
  CC.ReceiveOutput _ _ next →
    pure next
  CC.ReceiveState _ next →
    pure next
  CC.ReceiveDimensions dims next → do
    recalcRect
    H.queryAll (right (H.action DCQ.UpdateCardSize))
    pure next
  CC.ModelUpdated _ next →
    pure next
  CC.ZoomIn next →
    pure next

evalBoard ∷ CardOptions → Query ~> DraftboardDSL
evalBoard opts = case _ of
  SetRoot el next → do
    st ← H.get
    H.modify _ { root = el }
    pure next
  SplitStart orientation bias root ev next → do
    st ← H.get
    Drag.subscribe' ev (right ∘ H.action ∘ Splitting)
    H.modify _ { splitOpts = Just { orientation, bias, root } }
    pure next
  Splitting ev next → do
    st ← H.get
    case ev of
      Drag.Move _ d → do
        let
          x = d.x - st.rootRect.left
          y = d.y - st.rootRect.top
          result = do
            { orientation, bias, root } ← st.splitOpts
            { cursor } ← overlapping x y st.cellLayout
            let
              rectR = st.rootRect
              cursor' =
                if not root
                  then fromMaybe Nil (Layout.findSplit orientation cursor st.layout)
                  else Nil
            rs ←
              if List.null cursor'
                then pure Nil
                else getRatios =<< Pane.getAt cursor' st.layout
            rectT ← Layout.absoluteRect rectR <$> Layout.rectAt cursor' st.layout
            let
              relX = d.x - (rectR.left + rectT.left)
              relY = d.y - (rectR.top + rectT.top)
            pure case orientation of
              Orn.Horizontal →
                let
                  ratio = Layout.closestSnapRatio (relX / rectT.width)
                  valid = isSensibleSplit ratio rs && not (isEdge ratio)
                in
                  { orientation
                  , bias
                  , cursor: cursor'
                  , ratio
                  , valid
                  , x: d.x - rectR.left
                  , y: rectT.top
                  , z: rectT.height
                  }
              Orn.Vertical →
                let
                  ratio = Layout.closestSnapRatio (relY / rectT.height)
                  valid = isSensibleSplit ratio rs && not (isEdge ratio)
                in
                  { orientation
                  , bias
                  , cursor: cursor'
                  , ratio
                  , valid
                  , x: rectT.left
                  , y: d.y - rectR.top
                  , z: rectT.width
                  }
        H.modify _ { splitLocation = result }
      Drag.Done _ → do
        let
          result = do
            splitOpts ← st.splitOpts
            loc ← st.splitLocation
            guard loc.valid
            if splitOpts.root
              then pure (Layout.insertRootSplit (Pane.Cell Nothing) loc.orientation loc.ratio loc.bias st.layout)
              else Layout.insertSplit (Pane.Cell Nothing) loc.orientation loc.ratio loc.bias loc.cursor st.layout
        H.modify
          $ updateLayout (fromMaybe st.layout result)
          ∘ _ { splitOpts = Nothing, splitLocation = Nothing }
        H.queryAll (right (H.action DCQ.UpdateCardSize))
        CC.raiseUpdatedP' CC.EvalModelUpdate
    pure next
  ResizeStart edge ev next → do
    let
      loc =
        { edge
        , ratio: edge.ratio
        , valid: true
        , collapse: Nothing
        , offset: 0.0
        , initial: case edge.orientation of
            Orn.Horizontal → ev.pageX
            Orn.Vertical   → ev.pageY
        }
    Drag.subscribe' ev (right ∘ H.action ∘ Resizing)
    H.modify _ { resizeLocation = Just loc }
    pure next
  Resizing ev next → do
    st ← H.get
    case ev of
      Drag.Move _ d → do
        let
          rectR = st.rootRect
          result = do
            loc   ← st.resizeLocation
            rectT ← Layout.absoluteRect rectR <$> Layout.rectAt loc.edge.parent st.layout
            sibs  ← Pane.children <$> Pane.getAt loc.edge.parent st.layout
            let
              ix   = loc.edge.index + 1
              relX = d.x - (rectR.left + rectT.left)
              relY = d.y - (rectR.top + rectT.top)
              pre  = List.take ix sibs
              post = List.drop ix sibs
            pure case loc.edge.orientation of
              Orn.Horizontal →
                let
                  ratio = Layout.closestSnapRatio (relX / rectT.width)
                  collapse = isCollapsing ratio pre post
                  valid = not (isEdge ratio) || isJust collapse
                in loc
                  { offset = d.x - loc.initial
                  , ratio = ratio
                  , valid = valid
                  , collapse = collapse
                  }
              Orn.Vertical →
                let
                  ratio = Layout.closestSnapRatio (relY / rectT.height)
                  collapse = isCollapsing ratio pre post
                  valid = not (isEdge ratio) || isJust collapse
                in loc
                  { offset = d.y - loc.initial
                  , ratio = ratio
                  , valid = valid
                  , collapse = collapse
                  }
        H.modify _ { resizeLocation = result }
      Drag.Done _ → do
        let
          result = do
            loc ← st.resizeLocation
            guard loc.valid
            Layout.resizeEdge' loc.edge.index loc.ratio loc.edge.parent st.layout
        H.modify
          $ updateLayout (fromMaybe st.layout result)
          ∘ _ { resizeLocation = Nothing }
        H.queryAll (right (H.action DCQ.UpdateCardSize))
        CC.raiseUpdatedP' CC.EvalModelUpdate
    pure next
  DeleteCell cursor next → do
    st ← H.get
    let
      result = Layout.deleteCell cursor st.layout
    H.modify (updateLayout (fromMaybe st.layout result))
    H.queryAll (right (H.action DCQ.UpdateCardSize))
    CC.raiseUpdatedP' CC.EvalModelUpdate
    pure next
  Grabbing (deckId × cursor) ev next → do
    st ← H.get
    case ev of
      Drag.Move _ d → do
        let
          x = d.x - st.rootRect.left
          y = d.y - st.rootRect.top
        case overlapping x y st.cellLayout of
          Just cell@{ value: Nothing } →
            H.modify _ { moveLocation = Just (Move cell) }
          Just cell@{ value: (Just deckId'), rect } | deckId /= deckId' → do
            let
              relX = Int.floor (x - rect.left) % Int.floor rect.width
              relY = Int.floor (y - rect.top) % Int.floor rect.height
              move = case relX < 1%2, relY < 1%2 of
                xa, ya | xa && ya && relY < relX   → Group cell Orn.Vertical Layout.SideA
                xa, ya | xa && ya                  → Group cell Orn.Horizontal Layout.SideA
                xa, ya | xa && one - relY < relX   → Group cell Orn.Vertical Layout.SideB
                xa, ya | xa                        → Group cell Orn.Horizontal Layout.SideA
                xa, ya | ya && relY < one - relX   → Group cell Orn.Vertical Layout.SideA
                xa, ya | ya                        → Group cell Orn.Horizontal Layout.SideB
                xa, ya | one - relY < one - relX   → Group cell Orn.Vertical Layout.SideB
                _ , _                              → Group cell Orn.Horizontal Layout.SideB
            H.modify _ { moveLocation = Just move }
          _ →
            H.modify _ { moveLocation = Just (Floating x y) }
      Drag.Done _ → do
        for_ st.moveLocation case _ of
          Floating _ _ →
            H.modify _ { moveLocation = Nothing }
          Group cell orn bias →
            for_ cell.value \deckId' → do
              H.modify _ { moveLocation = Nothing }
              groupDeck orn bias deckId deckId'
          Move cell → do
            let
              result =
                pure st.layout
                  >>= Pane.modifyAt (const (Pane.Cell Nothing)) cursor
                  >>= Pane.modifyAt (const (Pane.Cell (Just deckId))) cell.cursor
            H.modify
              $ updateLayout (fromMaybe st.layout result)
              ∘ _ { moveLocation = Nothing }
            void $ queryDeck deckId $ H.action DCQ.UpdateCardSize
        CC.raiseUpdatedP' CC.EvalModelUpdate
    pure next
  AddDeck cursor next → do
    addDeck opts cursor
    CC.raiseUpdatedP' CC.EvalModelUpdate
    pure next

peek ∷ ∀ a. CardOptions → H.ChildF DeckId DNQ.QueryP a → DraftboardDSL Unit
peek opts (H.ChildF deckId q) = coproduct (const (pure unit)) peekDeck q
  where
  peekDeck ∷ DCQ.Query a → DraftboardDSL Unit
  peekDeck q' = do
    st ← H.get
    for_ (Map.lookup deckId st.cursors) \cursor →
      case q' of
        DCQ.GrabDeck ev _ → do
          startDragging ev (Grabbing (deckId × cursor))
        _ → pure unit

  startDragging ev tag =
    void $ Drag.subscribe' ev $ right ∘ H.action ∘ tag

isCollapsing
  ∷ ∀ a
  . Rational
  → List (Pane.Pane (Maybe a))
  → List (Pane.Pane (Maybe a))
  → Maybe Layout.SplitBias
isCollapsing ratio pre post
  | ratio == zero && and (map (all isNothing) pre) = Just Layout.SideA
  | ratio == one && and (map (all isNothing) post) = Just Layout.SideB
  | otherwise = Nothing

isSensibleSplit ∷ Rational → List (Rational) → Boolean
isSensibleSplit ratio = go zero
  where
  go off Nil = true
  go off (r : xs) =
    if abs (ratio - off) < 1%16
      then false
      else go (off + r) xs

getRatios ∷ ∀ a . Pane.Pane a → Maybe (List Rational)
getRatios (Pane.Split _ ps) = Just (map fst ps)
getRatios _ = Nothing

isEdge ∷ Rational → Boolean
isEdge r = r == zero || r == one

overlapping
  ∷ ∀ a
  . Number
  → Number
  → List (Layout.Cell a Number)
  → Maybe (Layout.Cell a Number)
overlapping x y = find go
  where
  go { rect: { top, left, width, height } } =
    y >= top && x >= left && y < top + height && x < left + width

recalcRect ∷ DraftboardDSL Unit
recalcRect = do
  st ← H.get
  for_ st.root \root → do
    rect ← H.fromEff (getOffsetClientRect root)
    H.modify (updateRect rect)

addDeck ∷ CardOptions → Pane.Cursor → DraftboardDSL Unit
addDeck _ cursor = do
  deckId × _ ← liftH' $ P.freshDeck emptyDeck (ED.Completed Port.emptyOut)
  st ← H.get
  let
    layout = Pane.modifyAt (const (Pane.Cell (Just deckId))) cursor st.layout
  H.modify
    $ updateLayout (fromMaybe st.layout layout)
    ∘ _ { inserting = false }
  void $ queryDeck deckId (H.action DCQ.Focus)

groupDeck
  ∷ Orn.Orientation
  → Layout.SplitBias
  → DeckId
  → DeckId
  → DraftboardDSL Unit
groupDeck orn bias deckFrom deckTo = do
  mbActive ← queryDeck deckTo (H.request DCQ.GetActiveCard)
  for_ mbActive case _ of
    Just coord → liftH' $ P.groupDeck orn bias deckFrom deckTo coord
    Nothing → liftH' $ P.wrapAndGroupDeck orn bias deckFrom deckTo

queryDeck ∷ ∀ a. DeckId → DCQ.Query a → DraftboardDSL (Maybe a)
queryDeck slot = H.query slot ∘ right


fix update

fix update

module Command.Update
  ( command
  ) where

import Prelude

import Bouzuya.CommandLineOption as CommandLineOption
import Client (Client)
import Client as Client
import Data.Array as Array
import Data.Either as Either
import Data.Maybe (Maybe(..))
import Data.Maybe as Maybe
import Effect.Aff (Aff)
import Effect.Class (liftEffect)
import Effect.Class.Console as Console
import Effect.Exception as Exception
import Record as Record

command :: Client -> Array String -> Aff Unit
command client args = do
  { arguments, options } <-
    Either.either
      (const (liftEffect (Exception.throw "invalid option")))
      pure
      (CommandLineOption.parse
        { title:
            CommandLineOption.stringOption
              "title" (Just 't') "<TITLE>" "title" ""
        }
        args)
  id <-
    Maybe.maybe
      (liftEffect (Exception.throw "no id"))
      pure
      (Array.index arguments 0)
  response <- client `Client.update` (Record.merge options { id })
  Console.log "updated"

module Command.Update
  ( command
  ) where

import Prelude

import Bouzuya.CommandLineOption as CommandLineOption
import Client (Client)
import Client as Client
import Data.Array as Array
import Data.Either as Either
import Data.Maybe (Maybe(..))
import Data.Maybe as Maybe
import Effect.Aff (Aff)
import Effect.Class (liftEffect)
import Effect.Class.Console as Console
import Effect.Exception as Exception
import Record as Record

command :: Client -> Array String -> Aff Unit
command client args = do
  { arguments, options } <-
    Either.either
      (const (liftEffect (Exception.throw "invalid option")))
      pure
      (CommandLineOption.parse
        { title:
            CommandLineOption.stringOption
              "title" (Just 't') "<TITLE>" "title" ""
        }
        args)
  id <-
    Maybe.maybe
      (liftEffect (Exception.throw "no id"))
      pure
      (Array.index arguments 0)
  response <- client `Client.update` (Record.merge options { id })
  Console.log (Client.showResponse response)


Add roles declarations to allow safe coercions

module Control.Monad.ST.Internal
  ( kind Region
  , ST
  , run
  , while
  , for
  , foreach
  , STRef
  , new
  , read
  , modify'
  , modify
  , write
  ) where

import Prelude

import Control.Monad.Rec.Class (class MonadRec, Step(..))
import Partial.Unsafe (unsafePartial)

-- | `ST` is concerned with _restricted_ mutation. Mutation is restricted to a
-- | _region_ of mutable references. This kind is inhabited by phantom types
-- | which represent regions in the type system.
foreign import kind Region

-- | The `ST` type constructor allows _local mutation_, i.e. mutation which
-- | does not "escape" into the surrounding computation.
-- |
-- | An `ST` computation is parameterized by a phantom type which is used to
-- | restrict the set of reference cells it is allowed to access.
-- |
-- | The `run` function can be used to run a computation in the `ST` monad.
foreign import data ST :: Region -> Type -> Type

type role ST nominal representational

foreign import map_ :: forall r a b. (a -> b) -> ST r a -> ST r b

foreign import pure_ :: forall r a. a -> ST r a

foreign import bind_ :: forall r a b. ST r a -> (a -> ST r b) -> ST r b

instance functorST :: Functor (ST r) where
  map = map_

instance applyST :: Apply (ST r) where
  apply = ap

instance applicativeST :: Applicative (ST r) where
  pure = pure_

instance bindST :: Bind (ST r) where
  bind = bind_

instance monadST :: Monad (ST r)

instance monadRecST :: MonadRec (ST r) where
  tailRecM f a = do
    r <- new =<< f a
    while (isLooping <$> read r) do
      read r >>= case _ of
        Loop a' -> do
          e <- f a'
          void (write e r)
        Done b -> pure unit
    fromDone <$> read r
    where
      fromDone :: forall a b. Step a b -> b
      fromDone = unsafePartial \(Done b) -> b

      isLooping = case _ of
        Loop _ -> true
        _ -> false

-- | Run an `ST` computation.
-- |
-- | Note: the type of `run` uses a rank-2 type to constrain the phantom
-- | type `r`, such that the computation must not leak any mutable references
-- | to the surrounding computation. It may cause problems to apply this
-- | function using the `$` operator. The recommended approach is to use
-- | parentheses instead.
foreign import run :: forall a. (forall r. ST r a) -> a

-- | Loop while a condition is `true`.
-- |
-- | `while b m` is ST computation which runs the ST computation `b`. If its
-- | result is `true`, it runs the ST computation `m` and loops. If not, the
-- | computation ends.
foreign import while :: forall r a. ST r Boolean -> ST r a -> ST r Unit

-- | Loop over a consecutive collection of numbers
-- |
-- | `ST.for lo hi f` runs the computation returned by the function `f` for each
-- | of the inputs between `lo` (inclusive) and `hi` (exclusive).
foreign import for :: forall r a. Int -> Int -> (Int -> ST r a) -> ST r Unit

-- | Loop over an array of values.
-- |
-- | `ST.foreach xs f` runs the computation returned by the function `f` for each
-- | of the inputs `xs`.
foreign import foreach :: forall r a. Array a -> (a -> ST r Unit) -> ST r Unit

-- | The type `STRef r a` represents a mutable reference holding a value of
-- | type `a`, which can be used with the `ST r` effect.
foreign import data STRef :: Region -> Type -> Type

type role STRef nominal representational

-- | Create a new mutable reference.
foreign import new :: forall a r. a -> ST r (STRef r a)

-- | Read the current value of a mutable reference.
foreign import read :: forall a r. STRef r a -> ST r a

-- | Update the value of a mutable reference by applying a function
-- | to the current value, computing a new state value for the reference and
-- | a return value.
modify' :: forall r a b. (a -> { state :: a, value :: b }) -> STRef r a -> ST r b
modify' = modifyImpl

foreign import modifyImpl :: forall r a b. (a -> { state :: a, value :: b }) -> STRef r a -> ST r b

-- | Modify the value of a mutable reference by applying a function to the
-- | current value. The modified value is returned.
modify :: forall r a. (a -> a) -> STRef r a -> ST r a
modify f = modify' \s -> let s' = f s in { state: s', value: s' }

-- | Set the value of a mutable reference.
foreign import write :: forall a r. a -> STRef r a -> ST r a

module Control.Monad.ST.Internal
  ( kind Region
  , ST
  , run
  , while
  , for
  , foreach
  , STRef
  , new
  , read
  , modify'
  , modify
  , write
  ) where

import Prelude

import Control.Monad.Rec.Class (class MonadRec, Step(..))
import Partial.Unsafe (unsafePartial)

-- | `ST` is concerned with _restricted_ mutation. Mutation is restricted to a
-- | _region_ of mutable references. This kind is inhabited by phantom types
-- | which represent regions in the type system.
foreign import kind Region

-- | The `ST` type constructor allows _local mutation_, i.e. mutation which
-- | does not "escape" into the surrounding computation.
-- |
-- | An `ST` computation is parameterized by a phantom type which is used to
-- | restrict the set of reference cells it is allowed to access.
-- |
-- | The `run` function can be used to run a computation in the `ST` monad.
foreign import data ST :: Region -> Type -> Type

foreign import map_ :: forall r a b. (a -> b) -> ST r a -> ST r b

foreign import pure_ :: forall r a. a -> ST r a

foreign import bind_ :: forall r a b. ST r a -> (a -> ST r b) -> ST r b

instance functorST :: Functor (ST r) where
  map = map_

instance applyST :: Apply (ST r) where
  apply = ap

instance applicativeST :: Applicative (ST r) where
  pure = pure_

instance bindST :: Bind (ST r) where
  bind = bind_

instance monadST :: Monad (ST r)

instance monadRecST :: MonadRec (ST r) where
  tailRecM f a = do
    r <- new =<< f a
    while (isLooping <$> read r) do
      read r >>= case _ of
        Loop a' -> do
          e <- f a'
          void (write e r)
        Done b -> pure unit
    fromDone <$> read r
    where
      fromDone :: forall a b. Step a b -> b
      fromDone = unsafePartial \(Done b) -> b

      isLooping = case _ of
        Loop _ -> true
        _ -> false

-- | Run an `ST` computation.
-- |
-- | Note: the type of `run` uses a rank-2 type to constrain the phantom
-- | type `r`, such that the computation must not leak any mutable references
-- | to the surrounding computation. It may cause problems to apply this
-- | function using the `$` operator. The recommended approach is to use
-- | parentheses instead.
foreign import run :: forall a. (forall r. ST r a) -> a

-- | Loop while a condition is `true`.
-- |
-- | `while b m` is ST computation which runs the ST computation `b`. If its
-- | result is `true`, it runs the ST computation `m` and loops. If not, the
-- | computation ends.
foreign import while :: forall r a. ST r Boolean -> ST r a -> ST r Unit

-- | Loop over a consecutive collection of numbers
-- |
-- | `ST.for lo hi f` runs the computation returned by the function `f` for each
-- | of the inputs between `lo` (inclusive) and `hi` (exclusive).
foreign import for :: forall r a. Int -> Int -> (Int -> ST r a) -> ST r Unit

-- | Loop over an array of values.
-- |
-- | `ST.foreach xs f` runs the computation returned by the function `f` for each
-- | of the inputs `xs`.
foreign import foreach :: forall r a. Array a -> (a -> ST r Unit) -> ST r Unit

-- | The type `STRef r a` represents a mutable reference holding a value of
-- | type `a`, which can be used with the `ST r` effect.
foreign import data STRef :: Region -> Type -> Type

-- | Create a new mutable reference.
foreign import new :: forall a r. a -> ST r (STRef r a)

-- | Read the current value of a mutable reference.
foreign import read :: forall a r. STRef r a -> ST r a

-- | Update the value of a mutable reference by applying a function
-- | to the current value, computing a new state value for the reference and
-- | a return value.
modify' :: forall r a b. (a -> { state :: a, value :: b }) -> STRef r a -> ST r b
modify' = modifyImpl

foreign import modifyImpl :: forall r a b. (a -> { state :: a, value :: b }) -> STRef r a -> ST r b

-- | Modify the value of a mutable reference by applying a function to the
-- | current value. The modified value is returned.
modify :: forall r a. (a -> a) -> STRef r a -> ST r a
modify f = modify' \s -> let s' = f s in { state: s', value: s' }

-- | Set the value of a mutable reference.
foreign import write :: forall a r. a -> STRef r a -> ST r a