diff --git a/marlowe-playground-client/spago.dhall b/marlowe-playground-client/spago.dhall index 8b67f8a905..451fc73538 100644 --- a/marlowe-playground-client/spago.dhall +++ b/marlowe-playground-client/spago.dhall @@ -32,8 +32,10 @@ You can edit this file as you like. , "gen" , "halogen" , "halogen-hooks" + , "halogen-hooks-extra" , "halogen-subscriptions" , "http-methods" + , "infinite-lists" , "integers" , "js-timers" , "json-helpers" diff --git a/marlowe-playground-client/src/Contrib/Data/Unfoldable.purs b/marlowe-playground-client/src/Contrib/Data/Unfoldable.purs new file mode 100644 index 0000000000..024d9c7ceb --- /dev/null +++ b/marlowe-playground-client/src/Contrib/Data/Unfoldable.purs @@ -0,0 +1,48 @@ +module Contrib.Data.Unfoldable where + +import Prelude +import Data.Foldable (length) +import Data.FoldableWithIndex (class FoldableWithIndex, foldrWithIndex) +import Data.List (List(..), uncons) as List +import Data.Maybe (Maybe(..)) +import Data.Tuple.Nested ((/\)) +import Data.Unfoldable (class Unfoldable, unfoldr) + +type Move = { from :: Int, to :: Int } + +-- | This function resides here in the `Unfoldable` namespace because +-- | `unfoldable` depends on `foldable-traversable` package and `Data` +-- | namespace seems to general for it. +move + :: forall a f g + . FoldableWithIndex Int f + => Unfoldable g + => Move + -> f a + -> Maybe (g a) +move { from, to } foldable = do + when (to > length foldable) + Nothing + let + foldStep idx elem acc + | idx == from = acc { elem = Just elem } + | otherwise = acc { items = List.Cons elem acc.items } + + { elem, items } = foldrWithIndex foldStep { elem: Nothing, items: List.Nil } + foldable + let + unfoldStep seed@{ idx, elem, items } = do + let + idx' = idx + 1 + + result + | idx == to = Just (elem /\ seed { idx = idx' }) + | otherwise = do + { head, tail } <- List.uncons items + Just (head /\ seed { idx = idx', items = tail }) + result + -- | There is no UnfoldableWithIndex unfortunatelly... yet: + -- | https://github.com/purescript/purescript-foldable-traversable/issues/84 + -- | so we have to carry the index ourselves. + seed <- { idx: 0, elem: _, items } <$> elem + pure $ unfoldr unfoldStep seed diff --git a/marlowe-playground-client/src/Contrib/Halogen/Sortable.purs b/marlowe-playground-client/src/Contrib/Halogen/Sortable.purs new file mode 100644 index 0000000000..139d161c26 --- /dev/null +++ b/marlowe-playground-client/src/Contrib/Halogen/Sortable.purs @@ -0,0 +1,175 @@ +module Contrib.Halogen.Components.Sortable where + +import Prelude + +import Contrib.Data.Unfoldable (Move) as Unfoldable +import Control.Alternative (guard) as Alternative +import Control.Monad.Maybe.Extra (hoistMaybe) +import Control.Monad.Maybe.Trans (MaybeT(..), runMaybeT) +import Control.Monad.Trans.Class (lift) +import Data.Lens (Lens') +import Data.Lens (set, view) as Lens +import Data.List.Infinite (List, unfold) as Infinite +import Data.Maybe (Maybe(..), isJust) +import Data.Tuple (Tuple(..)) +import Data.Tuple.Nested ((/\)) +import Effect.Class (class MonadEffect, liftEffect) +import Halogen (HalogenM) +import Halogen (get, put) as H +import Halogen.HTML (IProp) +import Halogen.HTML.Events (onDragEnd, onDragEnter, onDragStart) as Events +import Web.Event.Event (preventDefault) +import Web.HTML.Event.DragEvent (DragEvent) +import Web.HTML.Event.DragEvent (toEvent) as DragEvent + +newtype OrderingVersion + = OrderingVersion Int + +derive newtype instance eqOrderingVersion :: Eq OrderingVersion + +nextVersion :: OrderingVersion -> OrderingVersion +nextVersion (OrderingVersion i) = OrderingVersion (i + 1) + +-- | We have to keep ordering version because sorting can trigger +-- | reordering which assynchronously is repainted. If in between +-- | we trigger some other reordering it is going to be inconsisten +-- | with the new one so we have to ignore all events till everything is +-- | repainted +type State + = { orderingVersion :: OrderingVersion, dragging :: Maybe Int } + +initialState :: State +initialState = { orderingVersion: OrderingVersion 0, dragging: Nothing } + +data Action + = DragStart OrderingVersion DragEvent Int + | DragEnd + | MoveTo OrderingVersion Int + +type DragHandler r action + = IProp + ( onDragEnd :: DragEvent + , onDragEnter :: DragEvent + , onDragStart :: DragEvent + | r + ) + action + +-- | We need this `newtype` because of escaping type variable `r` error. +-- | The benefit is that we get a Functor out of it. +newtype DragHandlers action + = DragHandlers + { onDragEnd :: forall r. DragHandler r action + , onDragEnter :: forall r. DragHandler r action + , onDragStart :: forall r. DragHandler r action + } + +instance functorDragHandlers :: Functor DragHandlers where + map f (DragHandlers r) = + DragHandlers + { onDragStart: map f r.onDragStart + , onDragEnter: map f r.onDragEnter + , onDragEnd: map f r.onDragEnd + } + +type GenDragHandlers action + = Infinite.List (DragHandlers action) + +mkGenDragHandlers :: OrderingVersion -> GenDragHandlers Action +mkGenDragHandlers orderingVersion = + Infinite.unfold 0 \idx -> do + let + onDragStart :: forall r. DragHandler r Action + onDragStart = + Events.onDragStart \event -> + DragStart orderingVersion event idx + + onDragEnd :: forall r. DragHandler r Action + onDragEnd = Events.onDragEnd $ const DragEnd + + onDragEnter :: forall r. DragHandler r Action + onDragEnter = + Events.onDragEnter + $ const do + -- | The action handler is going to check if + -- | idices are different etc. + MoveTo orderingVersion idx + Tuple + ( DragHandlers + { onDragStart + , onDragEnd + , onDragEnter + } + ) + (idx + 1) + +mkGenDragHandlers' + :: forall state. Lens' state State -> state -> GenDragHandlers Action +mkGenDragHandlers' l = mkGenDragHandlers <<< _.orderingVersion <<< Lens.view l + +-- | We provide a reordering function instead of assuming that items +-- | container is accessible through local state because it is usually +-- | not the case (it can be in `halogen-store` and local state etc.) +handleAction + :: forall m + . MonadEffect m + => (Unfoldable.Move -> m Unit) + -> Action + -> State + -> m (Maybe State) +handleAction handleReordering action state = case action of + DragStart orderingVersion event dragging -> + if + ( orderingVersion == state.orderingVersion && state.dragging /= Just + dragging + ) then + pure $ Just $ state { dragging = Just dragging } + else do + liftEffect $ preventDefault (DragEvent.toEvent event) + pure Nothing + DragEnd -> + pure + $ + Alternative.guard + (isJust state.dragging) + $> state { dragging = Nothing } + MoveTo orderingVersion idx -> + runMaybeT do + dragging <- hoistMaybe state.dragging + st /\ f <- + hoistMaybe $ + Alternative.guard + (state.orderingVersion == orderingVersion && dragging /= idx) + $> do + let + orderingVersion' = nextVersion state.orderingVersion + + state' = + { dragging: Just idx, orderingVersion: orderingVersion' } + + -- f i = fromMaybe i (Unfoldable.moveTo dragging idx i) + move = { from: dragging, to: idx } + state' /\ move + lift $ handleReordering f + pure st + +handleActionH + :: forall action m output slots state + . MonadEffect m + => (Unfoldable.Move -> HalogenM state action slots output m Unit) + -> Lens' state State + -> Action + -> HalogenM state action slots output m Unit +handleActionH handleReordering stateL action = do + state <- H.get + let + updated = + runMaybeT do + state' <- MaybeT $ handleAction handleReordering action $ Lens.view + stateL + state + pure $ Lens.set stateL state' state + updated + >>= case _ of + Just state' -> H.put state' + Nothing -> pure unit diff --git a/marlowe-playground-client/src/Contrib/Halogen/Sortable/Hook.purs b/marlowe-playground-client/src/Contrib/Halogen/Sortable/Hook.purs new file mode 100644 index 0000000000..468f3c8d3e --- /dev/null +++ b/marlowe-playground-client/src/Contrib/Halogen/Sortable/Hook.purs @@ -0,0 +1,138 @@ +module Contrib.Halogen.Components.Sortable.Hook where + +import Prelude + +import Contrib.Data.Unfoldable (Move) as Unfoldable +import Contrib.Halogen.Components.Sortable + ( DragHandlers(..) + , OrderingVersion + , initialState + , nextVersion + ) as Sortable +import Contrib.Halogen.Components.Sortable (OrderingVersion, GenDragHandlers) +import Data.List.Infinite (unfold) as Infinite +import Data.Maybe (Maybe(..), isJust) +import Data.Tuple.Nested ((/\)) +import Effect.Class (class MonadEffect, liftEffect) +import Halogen.HTML.Events (onDragEnd, onDragEnter, onDragStart) as Events +import Halogen.Hooks (class HookNewtype, type (<>), Hook, HookM, UseEffect) +import Halogen.Hooks as Hooks +import Halogen.Hooks.Extra.Hooks (UseGet, UseStateFn, useGet, useModifyState_) +import Web.Event.Event (preventDefault) as Event +import Web.HTML.Event.DragEvent (toEvent) as DragEvent + +foreign import data UseSortable :: Hooks.HookType + +type State + = + { dragging :: Maybe Int + , orderingVersion :: Sortable.OrderingVersion + , move :: Maybe Unfoldable.Move + } + +type UseSortable' + = UseStateFn State <> UseGet State <> Hooks.Pure + +instance newtypeUseSortable :: HookNewtype UseSortable UseSortable' + +useSortable + :: forall m + . MonadEffect m + => Hook + m + UseSortable + { dragging :: Maybe Int + , genDragHandlers :: GenDragHandlers (HookM m Unit) + , reordering :: + { move :: Maybe Unfoldable.Move + , version :: OrderingVersion + } + } +useSortable = Hooks.wrap hook + where + hook :: Hook m UseSortable' _ + hook = Hooks.do + state /\ modifyState <- + useModifyState_ + { dragging: Sortable.initialState.dragging + , orderingVersion: Sortable.initialState.orderingVersion + , move: Nothing + } + getState <- useGet state + let + genDragHandlers = + Infinite.unfold 0 \idx -> do + let + handlers = + Sortable.DragHandlers + { onDragStart: + Events.onDragStart \event -> do + { dragging, orderingVersion } <- getState + if + ( orderingVersion == state.orderingVersion && dragging + /= Just idx + ) then + modifyState _ { dragging = Just idx } + else do + liftEffect $ Event.preventDefault + (DragEvent.toEvent event) + , onDragEnd: + Events.onDragEnd + $ \_ -> do + { dragging } <- getState + when (isJust dragging) do + modifyState _ { dragging = Nothing } + , onDragEnter: + Events.onDragEnter + $ \_ -> + getState + >>= case _ of + { dragging: Just dragging, orderingVersion } + | orderingVersion == state.orderingVersion && + dragging /= idx -> do + let + orderingVersion' = Sortable.nextVersion + orderingVersion + + move = Just { from: dragging, to: idx } + + state' = + { dragging: Just idx + , orderingVersion: orderingVersion' + , move + } + modifyState $ const state' + _ -> pure unit + } + handlers /\ (idx + 1) + Hooks.pure + { dragging: state.dragging + , genDragHandlers + , reordering: + { move: state.move + , version: state.orderingVersion + } + } + +useSortable' + :: forall m + . MonadEffect m + => (Unfoldable.Move -> HookM m Unit) + -> Hook + m + (UseSortable <> UseEffect <> UseEffect) + { dragging :: Maybe Int + , genDragHandlers :: GenDragHandlers (HookM m Unit) + } +useSortable' handleReordering = Hooks.do + { dragging, genDragHandlers, reordering } <- useSortable + Hooks.captures { version: reordering.version } + $ flip Hooks.useTickEffect do + case reordering.move of + Just m -> handleReordering m + Nothing -> pure unit + pure Nothing + Hooks.pure + { dragging + , genDragHandlers + } diff --git a/packages.dhall b/packages.dhall index c4815f91f6..aea1158f5d 100644 --- a/packages.dhall +++ b/packages.dhall @@ -1,41 +1,53 @@ let upstream = https://github.com/input-output-hk/purescript-web-common/releases/download/v1.2.2/packages.dhall sha256:264991f1254aabddf9e1cfc83ea9c2ad356ebc3aa1f462a63d3087db09d5f3b7 -let overrides = {=} +let mkPackage = + https://raw.githubusercontent.com/purescript/package-sets/psc-0.13.0-20190626/src/mkPackage.dhall sha256:0b197efa1d397ace6eb46b243ff2d73a3da5638d8d0ac8473e8e4a8fc528cf57 -let additions = - { polyform = - { dependencies = - [ "arrays" - , "bifunctors" - , "control" - , "effect" - , "either" - , "enums" - , "functors" - , "identity" - , "invariant" - , "lists" - , "maybe" - , "newtype" - , "parallel" - , "partial" - , "prelude" - , "profunctor" - , "psci-support" - , "quickcheck" - , "quickcheck-laws" - , "record" - , "transformers" - , "tuples" - , "typelevel-prelude" - , "unsafe-coerce" - , "validation" - , "variant" - ] - , repo = "https://github.com/purescript-polyform/polyform" - , version = "d177fa5e04a29babf0f86cf57561ea6bf2317c36" - } - } -in upstream // overrides // additions +in upstream + with + infinite-lists = mkPackage + [ "console" + , "control" + , "effect" + , "lazy" + , "maybe" + , "prelude" + , "psci-support" + , "tuples" + ] + "https://git@github.com/Thimoteus/purescript-infinite-lists" + "v3.2.0" + + with + polyform = mkPackage + [ "arrays" + , "bifunctors" + , "control" + , "effect" + , "either" + , "enums" + , "functors" + , "identity" + , "invariant" + , "lists" + , "maybe" + , "newtype" + , "parallel" + , "partial" + , "prelude" + , "profunctor" + , "psci-support" + , "quickcheck" + , "quickcheck-laws" + , "record" + , "transformers" + , "tuples" + , "typelevel-prelude" + , "unsafe-coerce" + , "validation" + , "variant" + ] + "https://github.com/purescript-polyform/polyform" + "d177fa5e04a29babf0f86cf57561ea6bf2317c36"