Add Unfoldable1 for ListT

Add Unfoldable1 for ListT

-- | This module defines the list monad transformer, `ListT`.

module Control.Monad.List.Trans
  ( ListT(..)
  , Step(..)
  , catMaybes
  , cons
  , drop
  , dropWhile
  , filter
  , foldl
  , foldlRec
  , foldl'
  , foldlRec'
  , fromEffect
  , head
  , iterate
  , mapMaybe
  , nil
  , prepend
  , prepend'
  , repeat
  , runListT
  , runListTRec
  , scanl
  , singleton
  , tail
  , take
  , takeWhile
  , uncons
  , unfold
  , wrapEffect
  , wrapLazy
  , zipWith
  , zipWith'
  , module Control.Monad.Trans.Class
  ) where

import Prelude

import Control.Alt (class Alt)
import Control.Alternative (class Alternative)
import Control.Monad.Rec.Class as MR
import Control.Monad.Trans.Class (class MonadTrans, lift)
import Control.MonadPlus (class MonadPlus)
import Control.MonadZero (class MonadZero)
import Control.Plus (class Plus)
import Data.Lazy (Lazy, defer, force)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Newtype (class Newtype)
import Data.Tuple (Tuple(..), fst, snd)
import Data.Unfoldable (class Unfoldable)
import Data.Unfoldable1 (class Unfoldable1)
import Effect.Class (class MonadEffect, liftEffect)

-- | The list monad transformer.
-- |
-- | This monad transformer extends the base monad with _non-determinism_.
-- | That is, the transformed monad supports the same effects as the base monad
-- | but with multiple return values.
newtype ListT f a = ListT (f (Step a (ListT f a)))

-- | The result of a single step in a `ListT` computation. Either:
-- |
-- | - Computation has finished (`Done`), or
-- | - A result has been returned, along with the next part of the computation (`Yield`).
-- |
-- | The `Skip` constructor allows us to avoid traversing lists during certain operations.
data Step a s
  = Yield a (Lazy s)
  | Skip (Lazy s)
  | Done

-- | Drain a `ListT`, running it to completion and discarding all values.
runListT :: forall f a. Monad f => ListT f a -> f Unit
runListT = foldl' (\_ _ -> pure unit) unit

-- | Drain a `ListT`, running it to completion and discarding all values.
-- | Stack safe: Uses tail call optimization.
runListTRec :: forall f a. MR.MonadRec f => ListT f a -> f Unit
runListTRec = foldlRec' (\_ _ -> pure unit) unit

-- | The empty list.
nil :: forall f a. Applicative f => ListT f a
nil = ListT $ pure Done

-- | Attach an element to the front of a list.
cons :: forall f a. Applicative f => Lazy a -> Lazy (ListT f a) -> ListT f a
cons lh t = ListT $ pure $ Yield (force lh) t

-- | Prepend an element to a lazily-evaluated list.
prepend' :: forall f a. Applicative f => a -> Lazy (ListT f a) -> ListT f a
prepend' h t = ListT $ pure (Yield h t)

-- | Prepend an element to a list.
prepend :: forall f a. Applicative f => a -> ListT f a -> ListT f a
prepend h t = prepend' h (defer $ const t)

-- | Lift a computation on list steps to a computation on whole lists.
stepMap :: forall f a b. Functor f => (Step a (ListT f a) -> Step b (ListT f b)) -> ListT f a -> ListT f b
stepMap f (ListT l) = ListT $ f <$> l

-- | Append one list to another.
concat :: forall f a. Applicative f => ListT f a -> ListT f a -> ListT f a
concat x y = stepMap f x where
  f (Yield a s) = Yield a ((_ <> y) <$> s)
  f (Skip s)    = Skip ((_ <> y) <$> s)
  f Done        = Skip (defer $ const y)

-- | Create a list with one element.
singleton :: forall f a. Applicative f => a -> ListT f a
singleton a = prepend a nil

-- | Lift a computation from the base functor.
fromEffect :: forall f a. Applicative f => f a -> ListT f a
fromEffect fa = ListT $ (flip Yield (defer $ \_ -> nil)) <$> fa

-- | Lift a computation from the base monad.
wrapEffect :: forall f a. Functor f => f (ListT f a) -> ListT f a
wrapEffect v = ListT $ Skip <<< defer <<< const <$> v

-- | Defer evaluation of a list.
wrapLazy :: forall f a. Applicative f => Lazy (ListT f a) -> ListT f a
wrapLazy v = ListT $ pure (Skip v)

-- | Unfold a list using an effectful generator function.
unfold :: forall f a z. Monad f => (z -> f (Maybe (Tuple z a))) -> z -> ListT f a
unfold f z = ListT $ g <$> f z
  where
  g (Just (Tuple z' a)) = Yield a (defer \_ -> unfold f z')
  g Nothing            = Done

-- | Generate an infinite list by iterating a function.
iterate :: forall f a. Monad f => (a -> a) -> a -> ListT f a
iterate f a = unfold g a
  where
  g x = pure $ Just (Tuple (f x) x)

-- | Generate an infinite list by repeating a value.
repeat :: forall f a. Monad f => a -> ListT f a
repeat = iterate identity

-- | Take a number of elements from the front of a list.
take :: forall f a. Applicative f => Int -> ListT f a -> ListT f a
take 0 fa = nil
take n fa = stepMap f fa where
  f (Yield a s) = Yield a (take (n - 1) <$> s)
  f (Skip s)    = Skip (take n <$> s)
  f Done        = Done

-- | Take elements from the front of a list while a predicate holds.
takeWhile :: forall f a. Applicative f => (a -> Boolean) -> ListT f a -> ListT f a
takeWhile f = stepMap g where
  g (Yield a s) = if f a then Yield a (takeWhile f <$> s) else Done
  g (Skip s)    = Skip $ takeWhile f <$> s
  g Done        = Done

-- | Drop a number of elements from the front of a list.
drop :: forall f a. Applicative f => Int -> ListT f a -> ListT f a
drop 0 fa = fa
drop n fa = stepMap f fa where
  f (Yield a s) = Skip (drop (n - 1) <$> s)
  f (Skip s)    = Skip (drop n <$> s)
  f Done        = Done

-- | Drop elements from the front of a list while a predicate holds.
dropWhile :: forall f a. Applicative f => (a -> Boolean) -> ListT f a -> ListT f a
dropWhile f = stepMap g where
  g (Yield a s) = if f a then Skip (dropWhile f <$> s) else Yield a s
  g (Skip s)    = Skip $ dropWhile f <$> s
  g Done        = Done

-- | Remove elements from a list for which a predicate fails to hold.
filter :: forall f a. Functor f => (a -> Boolean) -> ListT f a -> ListT f a
filter f = stepMap g where
  g (Yield a s) = if f a then Yield a s' else Skip s' where s' = filter f <$> s
  g (Skip s)    = Skip s' where s' = filter f <$> s
  g Done        = Done

-- | Apply a function to the elements of a list, keeping only those return values which contain a result.
mapMaybe :: forall f a b. Functor f => (a -> Maybe b) -> ListT f a -> ListT f b
mapMaybe f = stepMap g where
  g (Yield a s) = (fromMaybe Skip (Yield <$> (f a))) (mapMaybe f <$> s)
  g (Skip s)    = Skip $ mapMaybe f <$> s
  g Done        = Done

-- | Remove elements from a list which do not contain a value.
catMaybes :: forall f a. Functor f => ListT f (Maybe a) -> ListT f a
catMaybes = mapMaybe identity

-- | Perform the first step of a computation in the `ListT` monad.
uncons :: forall f a. Monad f => ListT f a -> f (Maybe (Tuple a (ListT f a)))
uncons (ListT l) = l >>= g
  where
  g (Yield a s) = pure $ Just $ Tuple a (force s)
  g (Skip s)    = uncons (force s)
  g Done        = pure Nothing

-- | Extract the first element of a list.
head :: forall f a. Monad f => ListT f a -> f (Maybe a)
head l = ((<$>) fst) <$> uncons l

-- | Extract all but the first element of a list.
tail :: forall f a. Monad f => ListT f a -> f (Maybe (ListT f a))
tail l = ((<$>) snd) <$> uncons l

-- | Fold a list from the left, accumulating the result (effectfully) using the specified function.
foldl' :: forall f a b. Monad f => (b -> a -> f b) -> b -> ListT f a -> f b
foldl' f = loop where
  loop b l = uncons l >>= g
    where
    g Nothing             = pure b
    g (Just (Tuple a as)) = (f b a) >>= (flip loop as)

-- | Fold a list from the left, accumulating the result (effectfully) using the specified function.
-- | Uses tail call optimization.
foldlRec' :: forall f a b. MR.MonadRec f => (b -> a -> f b) -> b -> ListT f a -> f b
foldlRec' f = MR.tailRecM2 loop where
  loop b l = uncons l >>= g
    where
    g Nothing             = pure (MR.Done b)
    g (Just (Tuple a as)) = (f b a) >>= \b' -> pure (MR.Loop {a: b', b: as})

-- | Fold a list from the left, accumulating the result using the specified function.
foldl :: forall f a b. Monad f => (b -> a -> b) -> b -> ListT f a -> f b
foldl f = loop where
  loop b l = uncons l >>= g
    where
    g Nothing             = pure b
    g (Just (Tuple a as)) = loop (f b a) as

-- | Fold a list from the left, accumulating the result using the specified function.
-- | Uses tail call optimization.
foldlRec :: forall f a b. MR.MonadRec f => (b -> a -> b) -> b -> ListT f a -> f b
foldlRec f = MR.tailRecM2 loop
  where
    loop b l = uncons l >>= g
      where
      g Nothing             = pure (MR.Done b)
      g (Just (Tuple a as)) = pure (MR.Loop {a: f b a, b: as})

-- | Fold a list from the left, accumulating the list of results using the specified function.
scanl :: forall f a b. Monad f => (b -> a -> b) -> b -> ListT f a -> ListT f b
scanl f b l = unfold g (Tuple b l)
  where
  g (Tuple b' (ListT l')) = h <$> l'
    where
    h (Yield a s) = let b'' = f b' a in Just $ Tuple (Tuple b'' (force s)) b'
    h (Skip s)    = Just $ Tuple (Tuple b' (force s)) b'
    h Done        = Nothing

-- | Zip the elements of two lists, combining elements at the same position from each list.
zipWith' :: forall f a b c. Monad f => (a -> b -> f c) -> ListT f a -> ListT f b -> ListT f c
zipWith' f = loop where
  loop fa fb = wrapEffect do
    ua <- uncons fa
    ub <- uncons fb
    g ua ub

  g _ Nothing = pure nil
  g Nothing _ = pure nil
  g (Just (Tuple ha ta)) (Just (Tuple hb tb)) = (flip prepend') (defer \_ -> zipWith' f ta tb) <$> (f ha hb)

-- | Zip the elements of two lists, combining elements at the same position from each list.
zipWith :: forall f a b c. Monad f => (a -> b -> c) -> ListT f a -> ListT f b -> ListT f c
zipWith f = zipWith' g
  where
  g a b = pure $ f a b

derive instance newtypeListT :: Newtype (ListT f a) _

instance semigroupListT :: Applicative f => Semigroup (ListT f a) where
  append = concat

instance monoidListT :: Applicative f => Monoid (ListT f a) where
  mempty = nil

instance functorListT :: Functor f => Functor (ListT f) where
  map f = stepMap g where
    g (Yield a s) = Yield (f a) ((<$>) f <$> s)
    g (Skip s)    = Skip ((<$>) f <$> s)
    g Done        = Done

instance unfoldableListT :: Monad f => Unfoldable (ListT f) where
  unfoldr f b = go (f b)
    where
      go = case _ of
        Nothing -> nil
        Just (Tuple x y) -> cons (pure x) (defer \_ -> (go (f y)))

instance unfoldable1ListT :: Monad f => Unfoldable1 (ListT f) where
  unfoldr1 f b = go (f b)
    where
      go = case _ of
        Tuple x Nothing -> singleton x
        Tuple x (Just y) -> cons (pure x) (defer \_ -> (go (f y)))

instance applyListT :: Monad f => Apply (ListT f) where
  apply = ap

instance applicativeListT :: Monad f => Applicative (ListT f) where
  pure = singleton

instance bindListT :: Monad f => Bind (ListT f) where
  bind fa f = stepMap g fa where
    g (Yield a s) = Skip (h <$> s)
      where
      h s' = f a <> (s' >>= f)
    g (Skip s) = Skip ((_ >>= f) <$> s)
    g Done = Done

instance monadListT :: Monad f => Monad (ListT f)

instance monadTransListT :: MonadTrans ListT where
  lift = fromEffect

instance altListT :: Applicative f => Alt (ListT f) where
  alt = concat

instance plusListT :: Monad f => Plus (ListT f) where
  empty = nil

instance alternativeListT :: Monad f => Alternative (ListT f)

instance monadZeroListT :: Monad f => MonadZero (ListT f)

instance monadPlusListT :: Monad f => MonadPlus (ListT f)

instance monadEffectListT :: MonadEffect m => MonadEffect (ListT m) where
  liftEffect = lift <<< liftEffect

-- | This module defines the list monad transformer, `ListT`.

module Control.Monad.List.Trans
  ( ListT(..)
  , Step(..)
  , catMaybes
  , cons
  , drop
  , dropWhile
  , filter
  , foldl
  , foldlRec
  , foldl'
  , foldlRec'
  , fromEffect
  , head
  , iterate
  , mapMaybe
  , nil
  , prepend
  , prepend'
  , repeat
  , runListT
  , runListTRec
  , scanl
  , singleton
  , tail
  , take
  , takeWhile
  , uncons
  , unfold
  , wrapEffect
  , wrapLazy
  , zipWith
  , zipWith'
  , module Control.Monad.Trans.Class
  ) where

import Prelude

import Control.Alt (class Alt)
import Control.Alternative (class Alternative)
import Control.Monad.Rec.Class as MR
import Control.Monad.Trans.Class (class MonadTrans, lift)
import Control.MonadPlus (class MonadPlus)
import Control.MonadZero (class MonadZero)
import Control.Plus (class Plus)
import Data.Lazy (Lazy, defer, force)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Newtype (class Newtype)
import Data.Tuple (Tuple(..), fst, snd)
import Data.Unfoldable (class Unfoldable)
import Effect.Class (class MonadEffect, liftEffect)

-- | The list monad transformer.
-- |
-- | This monad transformer extends the base monad with _non-determinism_.
-- | That is, the transformed monad supports the same effects as the base monad
-- | but with multiple return values.
newtype ListT f a = ListT (f (Step a (ListT f a)))

-- | The result of a single step in a `ListT` computation. Either:
-- |
-- | - Computation has finished (`Done`), or
-- | - A result has been returned, along with the next part of the computation (`Yield`).
-- |
-- | The `Skip` constructor allows us to avoid traversing lists during certain operations.
data Step a s
  = Yield a (Lazy s)
  | Skip (Lazy s)
  | Done

-- | Drain a `ListT`, running it to completion and discarding all values.
runListT :: forall f a. Monad f => ListT f a -> f Unit
runListT = foldl' (\_ _ -> pure unit) unit

-- | Drain a `ListT`, running it to completion and discarding all values.
-- | Stack safe: Uses tail call optimization.
runListTRec :: forall f a. MR.MonadRec f => ListT f a -> f Unit
runListTRec = foldlRec' (\_ _ -> pure unit) unit

-- | The empty list.
nil :: forall f a. Applicative f => ListT f a
nil = ListT $ pure Done

-- | Attach an element to the front of a list.
cons :: forall f a. Applicative f => Lazy a -> Lazy (ListT f a) -> ListT f a
cons lh t = ListT $ pure $ Yield (force lh) t

-- | Prepend an element to a lazily-evaluated list.
prepend' :: forall f a. Applicative f => a -> Lazy (ListT f a) -> ListT f a
prepend' h t = ListT $ pure (Yield h t)

-- | Prepend an element to a list.
prepend :: forall f a. Applicative f => a -> ListT f a -> ListT f a
prepend h t = prepend' h (defer $ const t)

-- | Lift a computation on list steps to a computation on whole lists.
stepMap :: forall f a b. Functor f => (Step a (ListT f a) -> Step b (ListT f b)) -> ListT f a -> ListT f b
stepMap f (ListT l) = ListT $ f <$> l

-- | Append one list to another.
concat :: forall f a. Applicative f => ListT f a -> ListT f a -> ListT f a
concat x y = stepMap f x where
  f (Yield a s) = Yield a ((_ <> y) <$> s)
  f (Skip s)    = Skip ((_ <> y) <$> s)
  f Done        = Skip (defer $ const y)

-- | Create a list with one element.
singleton :: forall f a. Applicative f => a -> ListT f a
singleton a = prepend a nil

-- | Lift a computation from the base functor.
fromEffect :: forall f a. Applicative f => f a -> ListT f a
fromEffect fa = ListT $ (flip Yield (defer $ \_ -> nil)) <$> fa

-- | Lift a computation from the base monad.
wrapEffect :: forall f a. Functor f => f (ListT f a) -> ListT f a
wrapEffect v = ListT $ Skip <<< defer <<< const <$> v

-- | Defer evaluation of a list.
wrapLazy :: forall f a. Applicative f => Lazy (ListT f a) -> ListT f a
wrapLazy v = ListT $ pure (Skip v)

-- | Unfold a list using an effectful generator function.
unfold :: forall f a z. Monad f => (z -> f (Maybe (Tuple z a))) -> z -> ListT f a
unfold f z = ListT $ g <$> f z
  where
  g (Just (Tuple z' a)) = Yield a (defer \_ -> unfold f z')
  g Nothing            = Done

-- | Generate an infinite list by iterating a function.
iterate :: forall f a. Monad f => (a -> a) -> a -> ListT f a
iterate f a = unfold g a
  where
  g x = pure $ Just (Tuple (f x) x)

-- | Generate an infinite list by repeating a value.
repeat :: forall f a. Monad f => a -> ListT f a
repeat = iterate identity

-- | Take a number of elements from the front of a list.
take :: forall f a. Applicative f => Int -> ListT f a -> ListT f a
take 0 fa = nil
take n fa = stepMap f fa where
  f (Yield a s) = Yield a (take (n - 1) <$> s)
  f (Skip s)    = Skip (take n <$> s)
  f Done        = Done

-- | Take elements from the front of a list while a predicate holds.
takeWhile :: forall f a. Applicative f => (a -> Boolean) -> ListT f a -> ListT f a
takeWhile f = stepMap g where
  g (Yield a s) = if f a then Yield a (takeWhile f <$> s) else Done
  g (Skip s)    = Skip $ takeWhile f <$> s
  g Done        = Done

-- | Drop a number of elements from the front of a list.
drop :: forall f a. Applicative f => Int -> ListT f a -> ListT f a
drop 0 fa = fa
drop n fa = stepMap f fa where
  f (Yield a s) = Skip (drop (n - 1) <$> s)
  f (Skip s)    = Skip (drop n <$> s)
  f Done        = Done

-- | Drop elements from the front of a list while a predicate holds.
dropWhile :: forall f a. Applicative f => (a -> Boolean) -> ListT f a -> ListT f a
dropWhile f = stepMap g where
  g (Yield a s) = if f a then Skip (dropWhile f <$> s) else Yield a s
  g (Skip s)    = Skip $ dropWhile f <$> s
  g Done        = Done

-- | Remove elements from a list for which a predicate fails to hold.
filter :: forall f a. Functor f => (a -> Boolean) -> ListT f a -> ListT f a
filter f = stepMap g where
  g (Yield a s) = if f a then Yield a s' else Skip s' where s' = filter f <$> s
  g (Skip s)    = Skip s' where s' = filter f <$> s
  g Done        = Done

-- | Apply a function to the elements of a list, keeping only those return values which contain a result.
mapMaybe :: forall f a b. Functor f => (a -> Maybe b) -> ListT f a -> ListT f b
mapMaybe f = stepMap g where
  g (Yield a s) = (fromMaybe Skip (Yield <$> (f a))) (mapMaybe f <$> s)
  g (Skip s)    = Skip $ mapMaybe f <$> s
  g Done        = Done

-- | Remove elements from a list which do not contain a value.
catMaybes :: forall f a. Functor f => ListT f (Maybe a) -> ListT f a
catMaybes = mapMaybe identity

-- | Perform the first step of a computation in the `ListT` monad.
uncons :: forall f a. Monad f => ListT f a -> f (Maybe (Tuple a (ListT f a)))
uncons (ListT l) = l >>= g
  where
  g (Yield a s) = pure $ Just $ Tuple a (force s)
  g (Skip s)    = uncons (force s)
  g Done        = pure Nothing

-- | Extract the first element of a list.
head :: forall f a. Monad f => ListT f a -> f (Maybe a)
head l = ((<$>) fst) <$> uncons l

-- | Extract all but the first element of a list.
tail :: forall f a. Monad f => ListT f a -> f (Maybe (ListT f a))
tail l = ((<$>) snd) <$> uncons l

-- | Fold a list from the left, accumulating the result (effectfully) using the specified function.
foldl' :: forall f a b. Monad f => (b -> a -> f b) -> b -> ListT f a -> f b
foldl' f = loop where
  loop b l = uncons l >>= g
    where
    g Nothing             = pure b
    g (Just (Tuple a as)) = (f b a) >>= (flip loop as)

-- | Fold a list from the left, accumulating the result (effectfully) using the specified function.
-- | Uses tail call optimization.
foldlRec' :: forall f a b. MR.MonadRec f => (b -> a -> f b) -> b -> ListT f a -> f b
foldlRec' f = MR.tailRecM2 loop where
  loop b l = uncons l >>= g
    where
    g Nothing             = pure (MR.Done b)
    g (Just (Tuple a as)) = (f b a) >>= \b' -> pure (MR.Loop {a: b', b: as})

-- | Fold a list from the left, accumulating the result using the specified function.
foldl :: forall f a b. Monad f => (b -> a -> b) -> b -> ListT f a -> f b
foldl f = loop where
  loop b l = uncons l >>= g
    where
    g Nothing             = pure b
    g (Just (Tuple a as)) = loop (f b a) as

-- | Fold a list from the left, accumulating the result using the specified function.
-- | Uses tail call optimization.
foldlRec :: forall f a b. MR.MonadRec f => (b -> a -> b) -> b -> ListT f a -> f b
foldlRec f = MR.tailRecM2 loop
  where
    loop b l = uncons l >>= g
      where
      g Nothing             = pure (MR.Done b)
      g (Just (Tuple a as)) = pure (MR.Loop {a: f b a, b: as})

-- | Fold a list from the left, accumulating the list of results using the specified function.
scanl :: forall f a b. Monad f => (b -> a -> b) -> b -> ListT f a -> ListT f b
scanl f b l = unfold g (Tuple b l)
  where
  g (Tuple b' (ListT l')) = h <$> l'
    where
    h (Yield a s) = let b'' = f b' a in Just $ Tuple (Tuple b'' (force s)) b'
    h (Skip s)    = Just $ Tuple (Tuple b' (force s)) b'
    h Done        = Nothing

-- | Zip the elements of two lists, combining elements at the same position from each list.
zipWith' :: forall f a b c. Monad f => (a -> b -> f c) -> ListT f a -> ListT f b -> ListT f c
zipWith' f = loop where
  loop fa fb = wrapEffect do
    ua <- uncons fa
    ub <- uncons fb
    g ua ub

  g _ Nothing = pure nil
  g Nothing _ = pure nil
  g (Just (Tuple ha ta)) (Just (Tuple hb tb)) = (flip prepend') (defer \_ -> zipWith' f ta tb) <$> (f ha hb)

-- | Zip the elements of two lists, combining elements at the same position from each list.
zipWith :: forall f a b c. Monad f => (a -> b -> c) -> ListT f a -> ListT f b -> ListT f c
zipWith f = zipWith' g
  where
  g a b = pure $ f a b

derive instance newtypeListT :: Newtype (ListT f a) _

instance semigroupListT :: Applicative f => Semigroup (ListT f a) where
  append = concat

instance monoidListT :: Applicative f => Monoid (ListT f a) where
  mempty = nil

instance functorListT :: Functor f => Functor (ListT f) where
  map f = stepMap g where
    g (Yield a s) = Yield (f a) ((<$>) f <$> s)
    g (Skip s)    = Skip ((<$>) f <$> s)
    g Done        = Done

instance unfoldableListT :: Monad f => Unfoldable (ListT f) where
  unfoldr f b = go (f b)
    where go Nothing = nil
          go (Just (Tuple x y)) = cons (pure x) (defer \_ -> (go (f y)))

instance applyListT :: Monad f => Apply (ListT f) where
  apply = ap

instance applicativeListT :: Monad f => Applicative (ListT f) where
  pure = singleton

instance bindListT :: Monad f => Bind (ListT f) where
  bind fa f = stepMap g fa where
    g (Yield a s) = Skip (h <$> s)
      where
      h s' = f a <> (s' >>= f)
    g (Skip s) = Skip ((_ >>= f) <$> s)
    g Done = Done

instance monadListT :: Monad f => Monad (ListT f)

instance monadTransListT :: MonadTrans ListT where
  lift = fromEffect

instance altListT :: Applicative f => Alt (ListT f) where
  alt = concat

instance plusListT :: Monad f => Plus (ListT f) where
  empty = nil

instance alternativeListT :: Monad f => Alternative (ListT f)

instance monadZeroListT :: Monad f => MonadZero (ListT f)

instance monadPlusListT :: Monad f => MonadPlus (ListT f)

instance monadEffectListT :: MonadEffect m => MonadEffect (ListT m) where
  liftEffect = lift <<< liftEffect


Dismiss backside before trashing

Dismiss backside before trashing

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Deck.Component
  ( component
  , module SlamData.Workspace.Deck.Component.Query
  , module DCS
  , module SlamData.Workspace.Deck.DeckPath
  ) where

import SlamData.Prelude

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

import Data.Array as Array
import Data.Lens ((.~), (%~), _Left, _Just, is)
import Data.List as L
import Data.List ((:))
import Data.Set as Set

import DOM.HTML.HTMLElement (getBoundingClientRect)

import Halogen as H
import Halogen.Component.Utils (sendAfter, busEventSource)
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP

import SlamData.ActionList.Component as ActionList
import SlamData.ActionList.Filter.Component as ActionFilter
import SlamData.Config as Config
import SlamData.FileSystem.Routing (parentURL)
import SlamData.GlobalError as GE
import SlamData.Quasar as Api
import SlamData.Wiring (DeckMessage(..))
import SlamData.Wiring as Wiring
import SlamData.Wiring.Cache as Cache
import SlamData.Workspace.AccessType as AT
import SlamData.Workspace.Action as WA
import SlamData.Workspace.Card.CardId (CardId)
import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Card.Component.Query as CQ
import SlamData.Workspace.Card.InsertableCardType as ICT
import SlamData.Workspace.Card.Model as Card
import SlamData.Workspace.Card.Next.Component as Next
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Class (navigateToDeck)
import SlamData.Workspace.Deck.BackSide as Back
import SlamData.Workspace.Deck.Common (DeckOptions, DeckHTML, DeckDSL, sizerRef)
import SlamData.Workspace.Deck.Component.ChildSlot (cpCard, cpDialog, cpBackSide, cpNext)
import SlamData.Workspace.Deck.Component.Cycle (DeckComponent)
import SlamData.Workspace.Deck.Component.Query (Query(..), Message(..))
import SlamData.Workspace.Deck.Component.Render as DCR
import SlamData.Workspace.Deck.Component.State as DCS
import SlamData.Workspace.Deck.DeckId (DeckId)
import SlamData.Workspace.Deck.DeckPath (deckPath, deckPath')
import SlamData.Workspace.Deck.Dialog.Component as Dialog
import SlamData.Workspace.Deck.Gripper.Def as GD
import SlamData.Workspace.Deck.Slider as Slider
import SlamData.Workspace.Eval.Card as EC
import SlamData.Workspace.Eval.Deck as ED
import SlamData.Workspace.Eval.Persistence as P
import SlamData.Workspace.Eval.Traverse as ET
import SlamData.Workspace.Guide as Guide
import SlamData.Workspace.Routing (mkWorkspaceURL)

import Utils (hush)
import Utils.DOM as DOM
import Utils.LocalStorage as LocalStorage

component ∷ DeckOptions → DeckComponent
component opts =
  H.lifecycleParentComponent
    { render: render opts
    , eval: eval opts
    , initialState: const DCS.initialState
    , receiver: const Nothing
    , initializer: Just (H.action Init)
    , finalizer: Nothing
    }

render ∷ DeckOptions → DCS.State → DeckHTML
render opts st =
  case st.loadError of
    Just error →
      HH.div
        [ HP.class_ $ HH.ClassName "sd-workspace-error" ]
        [ DCR.renderError error ]
    _ → DCR.renderDeck opts component st

eval ∷ DeckOptions → Query ~> DeckDSL
eval opts = case _ of
  Init next → do
    { bus } ← H.lift Wiring.expose
    H.subscribe $ busEventSource (\msg → HandleMessage msg H.Listening) bus.decks
    when (L.null opts.displayCursor) do
      H.subscribe $ busEventSource (\msg → HandleError msg H.Listening) bus.globalError
    updateCardSize
    loadDeck opts
    pure next
  PresentAccessNextActionCardGuide next → do
    H.modify (DCS._presentAccessNextActionCardGuide .~ true) $> next
  HideAccessNextActionCardGuide next →
    dismissAccessNextActionCardGuide $> next
  Publish next → do
    { path } ← H.lift Wiring.expose
    let deckPath = deckPath' path opts.deckId
    H.liftEff ∘ Browser.newTab $ mkWorkspaceURL deckPath (WA.Load AT.ReadOnly)
    pure next
  FlipDeck next → do
    displayMode ← H.gets _.displayMode
    if DCS.isFrontSide displayMode
      then switchToFlipside opts
      else switchToFrontside
    pure next
  UpdateCardSize next → do
    updateCardSize
    pure next
  ZoomIn next → do
    navigateToDeck (opts.deckId L.: opts.cursor)
    pure next
  ZoomOut next → do
    { path } ← H.lift Wiring.expose
    if L.null opts.cursor
      then void $ H.liftEff $ Browser.setHref $ parentURL $ Left path
      else navigateToDeck opts.cursor
    pure next
  StartSliding gDef mouseEvent next → do
    H.getHTMLElementRef sizerRef >>= traverse_ \el → do
      width ← getBoundingClientWidth el
      Slider.startSliding mouseEvent gDef width
      preloadCard gDef
    pure next
  StopSlidingAndSnap mouseEvent next → do
    st ← H.get
    Slider.stopSlidingAndSnap mouseEvent
    updateActiveState opts
    when (DCS.activeCard st # is (_Just ∘ _Left ∘ DCS._NextActionCard)) do
      dismissAccessNextActionCardGuide
    pure next
  UpdateSliderPosition mouseEvent next →
    Slider.updateSliderPosition mouseEvent $> next
  StopSliderTransition next → do
    sliderTransition ← H.gets _.sliderTransition
    when sliderTransition $
      H.modify $ DCS._sliderTransition .~ false
    pure next
  Focus ev next → do
    st ← H.get
    H.liftEff $ DOM.stopPropagation ev
    when (not st.focused) do
      H.modify (DCS._focused .~ true)
      { bus } ← H.lift Wiring.expose
      H.liftAff $ Bus.write (DeckFocused opts.deckId) bus.decks
    pure next
  Defocus ev next → do
    st ← H.get
    H.liftEff $ DOM.stopPropagation ev
    isFrame ← H.liftEff $ DOM.nodeEq (DOM.target ev) (DOM.currentTarget ev)
    when (st.focused && not (L.null opts.displayCursor)) do
      H.modify (DCS._presentAccessNextActionCardGuide .~ false)
      when isFrame do
        for_ (L.last opts.cursor) \rootId → do
          { bus } ← H.lift Wiring.expose
          H.liftAff $ Bus.write (DeckFocused rootId) bus.decks
    pure next
  DismissedCardGuide next → do
    when (L.null opts.displayCursor) $ void do
      queryNextAction (Next.PresentAddCardGuide unit)
    pure next
  GetActiveCard k → do
    active ← H.gets DCS.activeCard
    pure (k (hush ∘ map _.cardId =<< active))
  DismissDialog next →
    H.modify (DCS._displayMode %~ DCS.noDialog) $> next
  HandleEval msg next →
    handleEval opts msg $> next
  HandleMessage msg next → do
    st ← H.get
    case msg of
      DeckFocused focusedDeckId → do
        when (opts.deckId ≡ focusedDeckId && not st.focused) do
          H.modify (DCS._focused .~ true)
          presentAccessNextActionCardGuideAfterDelay
        when (opts.deckId ≠ focusedDeckId && st.focused) $
          H.modify (DCS._focused .~ false)
    pure next
  HandleError ge next → do
    showDialog $ Dialog.Error $ GE.print ge
    pure next
  HandleNextAction msg next → handleNextAction opts msg $> next
  HandleDialog msg next → handleDialog opts msg $> next
  HandleBackFilter msg next → handleBackSideFilter msg $> next
  HandleBackAction msg next → handleBackSide opts msg $> next
  HandleGrab ev next → H.raise (GrabbedDeck ev) $> next
  where
  getBoundingClientWidth =
    H.liftEff ∘ map _.width ∘ getBoundingClientRect

-- If an ActionList has the style display: none; then calculating its dimensions
-- will give 0, 0. (This is Mapped to Nothing.)
--
-- If we recalculate after flipping then there may be a momentary flash
-- (observed).
--
-- Sending the dimensions of the next action list to the flip side action list
-- prevents this.
--
-- If there is no next action card this can't be done so just flip and
-- recalculate.
switchToFlipside ∷ DeckOptions → DeckDSL Unit
switchToFlipside opts = do
  updateBackSide opts
  presentFlipGuideFirstTime
  queryNextActionList $ H.action $ ActionList.CalculateBoundingRect
  nextBoundingRect ← queryNextActionList $ H.request ActionList.GetBoundingRect
  case nextBoundingRect of
    Just (Just dimensions) → do
      queryBacksideActionList $ H.action $ ActionList.SetBoundingRect dimensions
      H.modify (DCS._displayMode .~ DCS.FlipSide DCS.NoDialog)
    _ → do
      H.modify (DCS._displayMode .~ DCS.FlipSide DCS.NoDialog)
      void $ queryBacksideActionList $ H.action $ ActionList.CalculateBoundingRect

switchToFrontside ∷ DeckDSL Unit
switchToFrontside = do
  queryBacksideActionList $ H.action $ ActionList.CalculateBoundingRect
  flipSideBoundingRect ← queryBacksideActionList $ H.request ActionList.GetBoundingRect
  case flipSideBoundingRect of
    Just (Just dimensions) → do
      queryNextActionList $ H.action $ ActionList.SetBoundingRect dimensions
      H.modify (DCS._displayMode .~ DCS.FrontSide DCS.NoDialog)
    _ → do
      H.modify (DCS._displayMode .~ DCS.FrontSide DCS.NoDialog)
      void $ queryNextActionList $ H.action $ ActionList.CalculateBoundingRect

handleDialog ∷ DeckOptions → Dialog.Message → DeckDSL Unit
handleDialog opts = case _ of
  Dialog.Dismiss → do
    H.modify (DCS._displayMode %~ DCS.noDialog)
  Dialog.FlipToFront →
    switchToFrontside
  Dialog.SetDeckName name → do
    void $ H.lift $ P.renameDeck opts.deckId name
    switchToFrontside
  Dialog.Confirm d b → do
    switchToFlipside opts
    case d of
      Dialog.DeleteDeck | b → deleteDeck opts
      _ → pure unit

handleBackSide ∷ DeckOptions → ActionList.Message Back.BackAction → DeckDSL Unit
handleBackSide opts = case _ of
  ActionList.Selected action → do
    { path } ← H.lift Wiring.expose
    st ← H.get
    case action of
      Back.Trash → do
        let
          active = DCS.activeCard st
          activeIx = DCS.activeCardIndex st
        switchToFrontside
        for_ (join $ hush <$> active) \{ cardId } → do
          when (activeIx > 0) do
            H.modify _ { activeCardIndex = Just (activeIx - 1) }
            updateActiveState opts
          H.lift $ P.removeCard opts.deckId cardId
          H.modify
            $ (DCS._presentAccessNextActionCardGuide .~ false)
      Back.Rename → do
        showDialog $ Dialog.Rename st.name
      Back.Share → do
        getDeckTree opts.deckId >>= traverse_
          (showDialog ∘ Dialog.Share ∘ ET.getSharingInput path)
      Back.Unshare → do
        getDeckTree opts.deckId >>= traverse_
          (showDialog ∘ Dialog.Unshare ∘ ET.getSharingInput path)
      Back.Embed → do
        getDeckTree opts.deckId >>= traverse_ \tree →
          showDialog $ Dialog.Embed
            (ET.getSharingInput path tree)
            (ET.getVarMaps tree)
      Back.Publish → do
        getDeckTree opts.deckId >>= traverse_ \tree →
          showDialog $ Dialog.Publish
            (ET.getSharingInput path tree)
            (ET.getVarMaps tree)
      Back.DeleteDeck →
        if Array.length st.displayCards <= 1
          then deleteDeck opts
          else showDialog Dialog.DeleteDeck
      Back.Mirror → do
        let mirrorCard = (hush =<< DCS.activeCard st) <|> DCS.findLastRealCard st
        deck ← H.lift $ P.getDeck opts.deckId
        case deck >>= _.parent, mirrorCard <#> _.cardId of
          Just parentId, Just cardId | not (L.null opts.displayCursor) → do
            H.lift $ P.mirrorDeck parentId cardId opts.deckId
            switchToFrontside
          _, Just cardId → do
            parentId ← H.lift $ P.wrapAndMirrorDeck cardId opts.deckId
            navigateToDeck (parentId L.: opts.cursor)
          _, _ → pure unit
      Back.WrapChoice CT.Draftboard → wrapDeck Card.singletonDraftboard
      Back.WrapChoice CT.Tabs → wrapDeck Card.singletonTabs
      Back.WrapChoice _ → pure unit
      Back.Wrap → pure unit
      Back.Unwrap → do
        deck ← H.lift $ P.getDeck opts.deckId
        for_ (_.parent <$> deck) case _ of
          Just cardId | not (L.null opts.displayCursor) → do
            void $ H.lift $ P.collapseDeck opts.deckId cardId
          _ → do
            childId ← H.lift $ P.unwrapDeck opts.deckId
            navigateToDeck (childId L.: opts.cursor)
  where
  wrapDeck ∷ (DeckId → Card.AnyCardModel) → DeckDSL Unit
  wrapDeck wrapper = do
    parentId ← H.lift $ P.wrapDeck opts.deckId (wrapper opts.deckId)
    if L.null opts.displayCursor
      then navigateToDeck (parentId L.: opts.cursor)
      else switchToFrontside

handleBackSideFilter ∷ ActionFilter.Message → DeckDSL Unit
handleBackSideFilter = case _ of
  ActionFilter.FilterChanged str → do
    queryBacksideActionList $ H.action $ ActionList.UpdateFilter str
    pure unit

showDialog ∷ Dialog.Dialog → DeckDSL Unit
showDialog dlg = do
  queryDialog $ H.action $ Dialog.Show dlg
  H.modify (DCS._displayMode %~ DCS.dialog)

queryDialog ∷ Dialog.Query Unit → DeckDSL Unit
queryDialog = void ∘ H.query' cpDialog unit

queryBacksideActionList ∷ ∀ a. ActionList.Query Back.BackAction a → DeckDSL (Maybe a)
queryBacksideActionList =
  H.query' cpBackSide unit

queryNextActionList ∷ ∀ a. ActionList.Query Next.NextAction a → DeckDSL (Maybe a)
queryNextActionList =
  H.query' cpNext unit ∘ Next.ToActionList

queryCardEval ∷ ∀ a. CardId → CQ.CardQuery a → DeckDSL (Maybe a)
queryCardEval cid =
  H.query' cpCard cid

queryNextAction ∷ ∀ a. Next.Query a → DeckDSL (Maybe a)
queryNextAction =
  H.query' cpNext unit

updateActiveState ∷ DeckOptions → DeckDSL Unit
updateActiveState opts = do
  st ← H.get
  { cache } ← H.lift Wiring.expose
  for_ st.activeCardIndex \cardIndex →
    H.lift $ Cache.put opts.deckId { cardIndex } cache.activeState

updateBackSide ∷ DeckOptions → DeckDSL Unit
updateBackSide { deckId, displayCursor } = do
  st ← H.get
  let
    ty = join (hush <$> DCS.activeCard st)
    tys = Array.mapMaybe hush st.displayCards
  void ∘ H.query' cpBackSide unit ∘ H.action ∘ ActionList.UpdateActions
    =<< getUpdatedBackActions { deckId, displayCursor } ty tys

getUpdatedBackActions
  ∷ Back.BackSideOptions
  → Maybe DCS.CardDef
  → Array DCS.CardDef
  → DeckDSL (Array (ActionList.Action Back.BackAction))
getUpdatedBackActions opts activeCard cards = do
  uw ← fromMaybe false <$> traverse (calculateUnwrappable opts) activeCard
  isAdvanced ← isRight <$> Api.retrieveAuthProviders
  pure $ Back.toActionListAction uw activeCard cards <$> Back.allBackActions isAdvanced

calculateUnwrappable ∷ Back.BackSideOptions → DCS.CardDef → DeckDSL Boolean
calculateUnwrappable { displayCursor, deckId } { cardId } =
  fromMaybe false <$> runMaybeT do
    deck ← MaybeT $ H.lift (P.getDeck deckId)
    card ← MaybeT $ H.lift (P.getCard cardId)
    let
      cardLen = Array.length deck.model.cards
      deckIds = Card.childDeckIds card.model
      mirrorLen = Set.size card.decks
    pure case card.model, displayCursor, deckIds of
      Card.Draftboard _, L.Nil    , _ : L.Nil → cardLen ≡ 1
      Card.Draftboard _, _ : L.Nil, _ → cardLen ≡ 1 && mirrorLen ≡ 1
      _, _, _ → false

dismissedAccessNextActionCardGuideKey ∷ String
dismissedAccessNextActionCardGuideKey = "dismissedAccessNextActionCardGuide"

getDismissedAccessNextActionCardGuideBefore ∷ DeckDSL Boolean
getDismissedAccessNextActionCardGuideBefore =
  H.lift
    $ either (const $ false) id
    <$> LocalStorage.getLocalStorage dismissedAccessNextActionCardGuideKey

storeDismissedAccessNextActionCardGuide ∷ DeckDSL Unit
storeDismissedAccessNextActionCardGuide =
  H.lift $ LocalStorage.setLocalStorage dismissedAccessNextActionCardGuideKey true

presentAccessNextActionCardGuideAfterDelay ∷ DeckDSL Unit
presentAccessNextActionCardGuideAfterDelay = do
  dismissedBefore ← getDismissedAccessNextActionCardGuideBefore
  focused ← H.gets _.focused
  when (not dismissedBefore && focused) do
    cancelPresentAccessNextActionCardGuide
    canceler ← sendAfter Config.addCardGuideDelay PresentAccessNextActionCardGuide
    H.modify $ DCS._presentAccessNextActionCardGuideCanceler .~ Just canceler

cancelPresentAccessNextActionCardGuide ∷ DeckDSL Boolean
cancelPresentAccessNextActionCardGuide =
  H.liftAff ∘ maybe (pure false) (flip Aff.cancel $ Exception.error "Cancelled")
    =<< H.gets _.presentAccessNextActionCardGuideCanceler

dismissAccessNextActionCardGuide ∷ DeckDSL Unit
dismissAccessNextActionCardGuide =
  H.gets _.presentAccessNextActionCardGuide >>=
    flip when do
      H.modify (DCS._presentAccessNextActionCardGuide .~ false)
      storeDismissedAccessNextActionCardGuide

resetAccessNextActionCardGuideDelay ∷ DeckDSL Unit
resetAccessNextActionCardGuideDelay =
  whenM cancelPresentAccessNextActionCardGuide
    presentAccessNextActionCardGuideAfterDelay

handleNextAction ∷ DeckOptions → Next.Message → DeckDSL Unit
handleNextAction opts = case _ of
  Next.AddCard cardType → do
    void $ H.lift $ P.addCard opts.deckId cardType
    updateBackSide opts
  Next.PresentReason input cardType → do
    presentReason input cardType

presentReason ∷ Port.Port → CT.CardType → DeckDSL Unit
presentReason input cardType =
  showDialog dialog
  where
  insertableCardType = ICT.fromCardType cardType
  ioType = ICT.fromPort input
  reason = ICT.reason ioType cardType
  cardPaths = ICT.cardPathsBetween ioType insertableCardType
  dialog = Dialog.Reason cardType reason cardPaths

deleteDeck ∷ DeckOptions → DeckDSL Unit
deleteDeck opts = do
  st ← H.get
  H.lift $ P.deleteDeck opts.deckId
  navigateToDeck opts.cursor
  pure unit

loadDeck ∷ DeckOptions → DeckDSL Unit
loadDeck opts = mbLoadError =<< runMaybeT do
  deck ← MaybeT $ H.lift $ P.getDeck opts.deckId
  cardDefs ← MaybeT $ getCardDefs deck.model.cards
  lift $ H.subscribe $ busEventSource (\msg → HandleEval msg H.Listening) deck.bus
  lift case deck.status of
    ED.NeedsEval cardId → do
      let displayCards = [ Left DCS.PendingCard ]
      H.modify $ DCS.fromModel { name: deck.model.name, displayCards }
      H.lift $ P.queueEval 13 (opts.deckId L.: opts.cursor × cardId)
    ED.PendingEval cardId → do
      st ← H.get
      active ← activeCardIndex
      let displayCards = map Right cardDefs <> [ Left DCS.PendingCard ]
      H.modify
        $ (DCS._pendingCardIndex .~ DCS.cardIndexFromId cardId st)
        ∘ (DCS._activeCardIndex .~ active)
        ∘ DCS.fromModel { name: deck.model.name, displayCards }
      updateActiveState opts
    ED.Completed (port × _) → do
      active ← activeCardIndex
      H.modify
        $ (DCS.updateCompletedCards cardDefs port)
        ∘ (DCS._activeCardIndex .~ active)
        ∘ (DCS._pendingCardIndex .~ Nothing)
        ∘ DCS.fromModel { name: deck.model.name, displayCards: [] }
      updateActiveState opts
  where
  activeCardIndex = do
    { cache } ← H.lift Wiring.expose
    map _.cardIndex <$> H.lift (Cache.get opts.deckId cache.activeState)

  mbLoadError = case _ of
    Nothing → H.modify _ { loadError = Just "Unable to load deck due to an inconsistent model" }
    Just a  → pure a

handleEval ∷ DeckOptions → ED.EvalMessage → DeckDSL Unit
handleEval opts = case _ of
  ED.Pending cardId → do
    st ← H.get
    H.modify
      $ (DCS._pendingCardIndex .~ DCS.cardIndexFromId cardId st)
      ∘ (DCS.addMetaCard DCS.PendingCard)
  ED.Complete cardIds output@(port × _) → do
    getCardDefs cardIds >>= case _ of
      Nothing →
        H.modify _ { loadError = Just "Deck references non-existent cards" }
      Just cardDefs → do
        queryNextAction $ H.action $ Next.UpdateInput port
        H.modify (DCS.updateCompletedCards cardDefs port)
        updateActiveState opts
  ED.NameChange name → H.modify _ { name = name }
  ED.CardComplete cardId → do
    H.modify \st →
      let
        ix = DCS.cardIndexFromId cardId st
        lastIx = DCS.findLastCardIndex st
        pendingCardIndex = case ix, lastIx of
          Nothing, _ → st.pendingCardIndex
          _, Nothing → st.pendingCardIndex
          Just ix', Just lastIx'
            | lastIx' > ix' → Just $ ix' + one
            | otherwise → Nothing
      in st # DCS._pendingCardIndex .~ pendingCardIndex

  _ → pure unit

getCardDefs ∷ Array CardId → DeckDSL (Maybe (Array DCS.CardDef))
getCardDefs cardIds =
  sequence <$> for cardIds \cardId →
    map (mkCardDef cardId) <$> H.lift (P.getCard cardId)

mkCardDef ∷ CardId → EC.Cell → DCS.CardDef
mkCardDef cardId cell = { cardId, cardType: Card.modelCardType cell.model }

getDeckTree ∷ DeckId → DeckDSL (Maybe (ET.TraverseDeck ED.Cell EC.Cell))
getDeckTree deckId = do
  wiring ← H.lift Wiring.expose
  decks ← H.lift $ Cache.snapshot wiring.eval.decks
  cards ← H.lift $ Cache.snapshot wiring.eval.cards
  pure (ET.unfoldEvalTree decks cards deckId)

preloadCard ∷ GD.GripperDef → DeckDSL Unit
preloadCard gDef = do
  st ← H.get
  let
    ix = case gDef of
      GD.Previous true → (_ - 1) <$> st.activeCardIndex
      GD.Next true → (_ + 1) <$> st.activeCardIndex
      _ → Nothing
  for_ (ix >>= flip DCS.cardIdFromIndex st) \cardId → do
    void $ queryCardEval cardId $ H.action CQ.PreloadCard

updateCardSize ∷ DeckDSL Unit
updateCardSize =
  H.getHTMLElementRef sizerRef >>= traverse_ \el → void do
    { width, height } ← H.liftEff $ getBoundingClientRect el
    H.modify $ DCS._responsiveSize .~ breakpoint width
    queryNextActionList $ H.action ActionList.CalculateBoundingRect
    queryBacksideActionList $ H.action ActionList.CalculateBoundingRect
    H.queryAll' cpCard $ H.action CQ.UpdateDimensions
  where
  breakpoint w
    | w < 240.0 = DCS.XSmall
    | w < 320.0 = DCS.Small
    | w < 420.0 = DCS.Medium
    | w < 540.0 = DCS.Large
    | w < 720.0 = DCS.XLarge
    | otherwise = DCS.XXLarge

presentFlipGuideFirstTime ∷ DeckDSL Unit
presentFlipGuideFirstTime = do
  whenM shouldPresentFlipGuide do
    { bus } ← H.lift Wiring.expose
    H.liftAff $ Bus.write Guide.FlipGuide bus.stepByStep

shouldPresentFlipGuide ∷ DeckDSL Boolean
shouldPresentFlipGuide =
  H.lift
    $ either (const true) not
    <$> LocalStorage.getLocalStorage Guide.dismissedFlipGuideKey

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Deck.Component
  ( component
  , module SlamData.Workspace.Deck.Component.Query
  , module DCS
  , module SlamData.Workspace.Deck.DeckPath
  ) where

import SlamData.Prelude

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

import Data.Array as Array
import Data.Lens ((.~), (%~), _Left, _Just, is)
import Data.List as L
import Data.List ((:))
import Data.Set as Set

import DOM.HTML.HTMLElement (getBoundingClientRect)

import Halogen as H
import Halogen.Component.Utils (sendAfter, busEventSource)
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP

import SlamData.ActionList.Component as ActionList
import SlamData.ActionList.Filter.Component as ActionFilter
import SlamData.Config as Config
import SlamData.FileSystem.Routing (parentURL)
import SlamData.GlobalError as GE
import SlamData.Quasar as Api
import SlamData.Wiring (DeckMessage(..))
import SlamData.Wiring as Wiring
import SlamData.Wiring.Cache as Cache
import SlamData.Workspace.AccessType as AT
import SlamData.Workspace.Action as WA
import SlamData.Workspace.Card.CardId (CardId)
import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Card.Component.Query as CQ
import SlamData.Workspace.Card.InsertableCardType as ICT
import SlamData.Workspace.Card.Model as Card
import SlamData.Workspace.Card.Next.Component as Next
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Class (navigateToDeck)
import SlamData.Workspace.Deck.BackSide as Back
import SlamData.Workspace.Deck.Common (DeckOptions, DeckHTML, DeckDSL, sizerRef)
import SlamData.Workspace.Deck.Component.ChildSlot (cpCard, cpDialog, cpBackSide, cpNext)
import SlamData.Workspace.Deck.Component.Cycle (DeckComponent)
import SlamData.Workspace.Deck.Component.Query (Query(..), Message(..))
import SlamData.Workspace.Deck.Component.Render as DCR
import SlamData.Workspace.Deck.Component.State as DCS
import SlamData.Workspace.Deck.DeckId (DeckId)
import SlamData.Workspace.Deck.DeckPath (deckPath, deckPath')
import SlamData.Workspace.Deck.Dialog.Component as Dialog
import SlamData.Workspace.Deck.Gripper.Def as GD
import SlamData.Workspace.Deck.Slider as Slider
import SlamData.Workspace.Eval.Card as EC
import SlamData.Workspace.Eval.Deck as ED
import SlamData.Workspace.Eval.Persistence as P
import SlamData.Workspace.Eval.Traverse as ET
import SlamData.Workspace.Guide as Guide
import SlamData.Workspace.Routing (mkWorkspaceURL)

import Utils (hush)
import Utils.DOM as DOM
import Utils.LocalStorage as LocalStorage

component ∷ DeckOptions → DeckComponent
component opts =
  H.lifecycleParentComponent
    { render: render opts
    , eval: eval opts
    , initialState: const DCS.initialState
    , receiver: const Nothing
    , initializer: Just (H.action Init)
    , finalizer: Nothing
    }

render ∷ DeckOptions → DCS.State → DeckHTML
render opts st =
  case st.loadError of
    Just error →
      HH.div
        [ HP.class_ $ HH.ClassName "sd-workspace-error" ]
        [ DCR.renderError error ]
    _ → DCR.renderDeck opts component st

eval ∷ DeckOptions → Query ~> DeckDSL
eval opts = case _ of
  Init next → do
    { bus } ← H.lift Wiring.expose
    H.subscribe $ busEventSource (\msg → HandleMessage msg H.Listening) bus.decks
    when (L.null opts.displayCursor) do
      H.subscribe $ busEventSource (\msg → HandleError msg H.Listening) bus.globalError
    updateCardSize
    loadDeck opts
    pure next
  PresentAccessNextActionCardGuide next → do
    H.modify (DCS._presentAccessNextActionCardGuide .~ true) $> next
  HideAccessNextActionCardGuide next →
    dismissAccessNextActionCardGuide $> next
  Publish next → do
    { path } ← H.lift Wiring.expose
    let deckPath = deckPath' path opts.deckId
    H.liftEff ∘ Browser.newTab $ mkWorkspaceURL deckPath (WA.Load AT.ReadOnly)
    pure next
  FlipDeck next → do
    displayMode ← H.gets _.displayMode
    if DCS.isFrontSide displayMode
      then switchToFlipside opts
      else switchToFrontside
    pure next
  UpdateCardSize next → do
    updateCardSize
    pure next
  ZoomIn next → do
    navigateToDeck (opts.deckId L.: opts.cursor)
    pure next
  ZoomOut next → do
    { path } ← H.lift Wiring.expose
    if L.null opts.cursor
      then void $ H.liftEff $ Browser.setHref $ parentURL $ Left path
      else navigateToDeck opts.cursor
    pure next
  StartSliding gDef mouseEvent next → do
    H.getHTMLElementRef sizerRef >>= traverse_ \el → do
      width ← getBoundingClientWidth el
      Slider.startSliding mouseEvent gDef width
      preloadCard gDef
    pure next
  StopSlidingAndSnap mouseEvent next → do
    st ← H.get
    Slider.stopSlidingAndSnap mouseEvent
    updateActiveState opts
    when (DCS.activeCard st # is (_Just ∘ _Left ∘ DCS._NextActionCard)) do
      dismissAccessNextActionCardGuide
    pure next
  UpdateSliderPosition mouseEvent next →
    Slider.updateSliderPosition mouseEvent $> next
  StopSliderTransition next → do
    sliderTransition ← H.gets _.sliderTransition
    when sliderTransition $
      H.modify $ DCS._sliderTransition .~ false
    pure next
  Focus ev next → do
    st ← H.get
    H.liftEff $ DOM.stopPropagation ev
    when (not st.focused) do
      H.modify (DCS._focused .~ true)
      { bus } ← H.lift Wiring.expose
      H.liftAff $ Bus.write (DeckFocused opts.deckId) bus.decks
    pure next
  Defocus ev next → do
    st ← H.get
    H.liftEff $ DOM.stopPropagation ev
    isFrame ← H.liftEff $ DOM.nodeEq (DOM.target ev) (DOM.currentTarget ev)
    when (st.focused && not (L.null opts.displayCursor)) do
      H.modify (DCS._presentAccessNextActionCardGuide .~ false)
      when isFrame do
        for_ (L.last opts.cursor) \rootId → do
          { bus } ← H.lift Wiring.expose
          H.liftAff $ Bus.write (DeckFocused rootId) bus.decks
    pure next
  DismissedCardGuide next → do
    when (L.null opts.displayCursor) $ void do
      queryNextAction (Next.PresentAddCardGuide unit)
    pure next
  GetActiveCard k → do
    active ← H.gets DCS.activeCard
    pure (k (hush ∘ map _.cardId =<< active))
  DismissDialog next →
    H.modify (DCS._displayMode %~ DCS.noDialog) $> next
  HandleEval msg next →
    handleEval opts msg $> next
  HandleMessage msg next → do
    st ← H.get
    case msg of
      DeckFocused focusedDeckId → do
        when (opts.deckId ≡ focusedDeckId && not st.focused) do
          H.modify (DCS._focused .~ true)
          presentAccessNextActionCardGuideAfterDelay
        when (opts.deckId ≠ focusedDeckId && st.focused) $
          H.modify (DCS._focused .~ false)
    pure next
  HandleError ge next → do
    showDialog $ Dialog.Error $ GE.print ge
    pure next
  HandleNextAction msg next → handleNextAction opts msg $> next
  HandleDialog msg next → handleDialog opts msg $> next
  HandleBackFilter msg next → handleBackSideFilter msg $> next
  HandleBackAction msg next → handleBackSide opts msg $> next
  HandleGrab ev next → H.raise (GrabbedDeck ev) $> next
  where
  getBoundingClientWidth =
    H.liftEff ∘ map _.width ∘ getBoundingClientRect

-- If an ActionList has the style display: none; then calculating its dimensions
-- will give 0, 0. (This is Mapped to Nothing.)
--
-- If we recalculate after flipping then there may be a momentary flash
-- (observed).
--
-- Sending the dimensions of the next action list to the flip side action list
-- prevents this.
--
-- If there is no next action card this can't be done so just flip and
-- recalculate.
switchToFlipside ∷ DeckOptions → DeckDSL Unit
switchToFlipside opts = do
  updateBackSide opts
  presentFlipGuideFirstTime
  queryNextActionList $ H.action $ ActionList.CalculateBoundingRect
  nextBoundingRect ← queryNextActionList $ H.request ActionList.GetBoundingRect
  case nextBoundingRect of
    Just (Just dimensions) → do
      queryBacksideActionList $ H.action $ ActionList.SetBoundingRect dimensions
      H.modify (DCS._displayMode .~ DCS.FlipSide DCS.NoDialog)
    _ → do
      H.modify (DCS._displayMode .~ DCS.FlipSide DCS.NoDialog)
      void $ queryBacksideActionList $ H.action $ ActionList.CalculateBoundingRect

switchToFrontside ∷ DeckDSL Unit
switchToFrontside = do
  queryBacksideActionList $ H.action $ ActionList.CalculateBoundingRect
  flipSideBoundingRect ← queryBacksideActionList $ H.request ActionList.GetBoundingRect
  case flipSideBoundingRect of
    Just (Just dimensions) → do
      queryNextActionList $ H.action $ ActionList.SetBoundingRect dimensions
      H.modify (DCS._displayMode .~ DCS.FrontSide DCS.NoDialog)
    _ → do
      H.modify (DCS._displayMode .~ DCS.FrontSide DCS.NoDialog)
      void $ queryNextActionList $ H.action $ ActionList.CalculateBoundingRect

handleDialog ∷ DeckOptions → Dialog.Message → DeckDSL Unit
handleDialog opts = case _ of
  Dialog.Dismiss → do
    H.modify (DCS._displayMode %~ DCS.noDialog)
  Dialog.FlipToFront →
    switchToFrontside
  Dialog.SetDeckName name → do
    void $ H.lift $ P.renameDeck opts.deckId name
    switchToFrontside
  Dialog.Confirm d b → do
    switchToFlipside opts
    case d of
      Dialog.DeleteDeck | b → deleteDeck opts
      _ → pure unit

handleBackSide ∷ DeckOptions → ActionList.Message Back.BackAction → DeckDSL Unit
handleBackSide opts = case _ of
  ActionList.Selected action → do
    { path } ← H.lift Wiring.expose
    st ← H.get
    case action of
      Back.Trash → do
        let
          active = DCS.activeCard st
          activeIx = DCS.activeCardIndex st
        for_ (join $ hush <$> active) \{ cardId } → do
          when (activeIx > 0) do
            H.modify _ { activeCardIndex = Just (activeIx - 1) }
            updateActiveState opts
          H.lift $ P.removeCard opts.deckId cardId
          H.modify
            $ (DCS._presentAccessNextActionCardGuide .~ false)
        switchToFrontside
      Back.Rename → do
        showDialog $ Dialog.Rename st.name
      Back.Share → do
        getDeckTree opts.deckId >>= traverse_
          (showDialog ∘ Dialog.Share ∘ ET.getSharingInput path)
      Back.Unshare → do
        getDeckTree opts.deckId >>= traverse_
          (showDialog ∘ Dialog.Unshare ∘ ET.getSharingInput path)
      Back.Embed → do
        getDeckTree opts.deckId >>= traverse_ \tree →
          showDialog $ Dialog.Embed
            (ET.getSharingInput path tree)
            (ET.getVarMaps tree)
      Back.Publish → do
        getDeckTree opts.deckId >>= traverse_ \tree →
          showDialog $ Dialog.Publish
            (ET.getSharingInput path tree)
            (ET.getVarMaps tree)
      Back.DeleteDeck →
        if Array.length st.displayCards <= 1
          then deleteDeck opts
          else showDialog Dialog.DeleteDeck
      Back.Mirror → do
        let mirrorCard = (hush =<< DCS.activeCard st) <|> DCS.findLastRealCard st
        deck ← H.lift $ P.getDeck opts.deckId
        case deck >>= _.parent, mirrorCard <#> _.cardId of
          Just parentId, Just cardId | not (L.null opts.displayCursor) → do
            H.lift $ P.mirrorDeck parentId cardId opts.deckId
            switchToFrontside
          _, Just cardId → do
            parentId ← H.lift $ P.wrapAndMirrorDeck cardId opts.deckId
            navigateToDeck (parentId L.: opts.cursor)
          _, _ → pure unit
      Back.WrapChoice CT.Draftboard → wrapDeck Card.singletonDraftboard
      Back.WrapChoice CT.Tabs → wrapDeck Card.singletonTabs
      Back.WrapChoice _ → pure unit
      Back.Wrap → pure unit
      Back.Unwrap → do
        deck ← H.lift $ P.getDeck opts.deckId
        for_ (_.parent <$> deck) case _ of
          Just cardId | not (L.null opts.displayCursor) → do
            void $ H.lift $ P.collapseDeck opts.deckId cardId
          _ → do
            childId ← H.lift $ P.unwrapDeck opts.deckId
            navigateToDeck (childId L.: opts.cursor)
  where
  wrapDeck ∷ (DeckId → Card.AnyCardModel) → DeckDSL Unit
  wrapDeck wrapper = do
    parentId ← H.lift $ P.wrapDeck opts.deckId (wrapper opts.deckId)
    if L.null opts.displayCursor
      then navigateToDeck (parentId L.: opts.cursor)
      else switchToFrontside

handleBackSideFilter ∷ ActionFilter.Message → DeckDSL Unit
handleBackSideFilter = case _ of
  ActionFilter.FilterChanged str → do
    queryBacksideActionList $ H.action $ ActionList.UpdateFilter str
    pure unit

showDialog ∷ Dialog.Dialog → DeckDSL Unit
showDialog dlg = do
  queryDialog $ H.action $ Dialog.Show dlg
  H.modify (DCS._displayMode %~ DCS.dialog)

queryDialog ∷ Dialog.Query Unit → DeckDSL Unit
queryDialog = void ∘ H.query' cpDialog unit

queryBacksideActionList ∷ ∀ a. ActionList.Query Back.BackAction a → DeckDSL (Maybe a)
queryBacksideActionList =
  H.query' cpBackSide unit

queryNextActionList ∷ ∀ a. ActionList.Query Next.NextAction a → DeckDSL (Maybe a)
queryNextActionList =
  H.query' cpNext unit ∘ Next.ToActionList

queryCardEval ∷ ∀ a. CardId → CQ.CardQuery a → DeckDSL (Maybe a)
queryCardEval cid =
  H.query' cpCard cid

queryNextAction ∷ ∀ a. Next.Query a → DeckDSL (Maybe a)
queryNextAction =
  H.query' cpNext unit

updateActiveState ∷ DeckOptions → DeckDSL Unit
updateActiveState opts = do
  st ← H.get
  { cache } ← H.lift Wiring.expose
  for_ st.activeCardIndex \cardIndex →
    H.lift $ Cache.put opts.deckId { cardIndex } cache.activeState

updateBackSide ∷ DeckOptions → DeckDSL Unit
updateBackSide { deckId, displayCursor } = do
  st ← H.get
  let
    ty = join (hush <$> DCS.activeCard st)
    tys = Array.mapMaybe hush st.displayCards
  void ∘ H.query' cpBackSide unit ∘ H.action ∘ ActionList.UpdateActions
    =<< getUpdatedBackActions { deckId, displayCursor } ty tys

getUpdatedBackActions
  ∷ Back.BackSideOptions
  → Maybe DCS.CardDef
  → Array DCS.CardDef
  → DeckDSL (Array (ActionList.Action Back.BackAction))
getUpdatedBackActions opts activeCard cards = do
  uw ← fromMaybe false <$> traverse (calculateUnwrappable opts) activeCard
  isAdvanced ← isRight <$> Api.retrieveAuthProviders
  pure $ Back.toActionListAction uw activeCard cards <$> Back.allBackActions isAdvanced

calculateUnwrappable ∷ Back.BackSideOptions → DCS.CardDef → DeckDSL Boolean
calculateUnwrappable { displayCursor, deckId } { cardId } =
  fromMaybe false <$> runMaybeT do
    deck ← MaybeT $ H.lift (P.getDeck deckId)
    card ← MaybeT $ H.lift (P.getCard cardId)
    let
      cardLen = Array.length deck.model.cards
      deckIds = Card.childDeckIds card.model
      mirrorLen = Set.size card.decks
    pure case card.model, displayCursor, deckIds of
      Card.Draftboard _, L.Nil    , _ : L.Nil → cardLen ≡ 1
      Card.Draftboard _, _ : L.Nil, _ → cardLen ≡ 1 && mirrorLen ≡ 1
      _, _, _ → false

dismissedAccessNextActionCardGuideKey ∷ String
dismissedAccessNextActionCardGuideKey = "dismissedAccessNextActionCardGuide"

getDismissedAccessNextActionCardGuideBefore ∷ DeckDSL Boolean
getDismissedAccessNextActionCardGuideBefore =
  H.lift
    $ either (const $ false) id
    <$> LocalStorage.getLocalStorage dismissedAccessNextActionCardGuideKey

storeDismissedAccessNextActionCardGuide ∷ DeckDSL Unit
storeDismissedAccessNextActionCardGuide =
  H.lift $ LocalStorage.setLocalStorage dismissedAccessNextActionCardGuideKey true

presentAccessNextActionCardGuideAfterDelay ∷ DeckDSL Unit
presentAccessNextActionCardGuideAfterDelay = do
  dismissedBefore ← getDismissedAccessNextActionCardGuideBefore
  focused ← H.gets _.focused
  when (not dismissedBefore && focused) do
    cancelPresentAccessNextActionCardGuide
    canceler ← sendAfter Config.addCardGuideDelay PresentAccessNextActionCardGuide
    H.modify $ DCS._presentAccessNextActionCardGuideCanceler .~ Just canceler

cancelPresentAccessNextActionCardGuide ∷ DeckDSL Boolean
cancelPresentAccessNextActionCardGuide =
  H.liftAff ∘ maybe (pure false) (flip Aff.cancel $ Exception.error "Cancelled")
    =<< H.gets _.presentAccessNextActionCardGuideCanceler

dismissAccessNextActionCardGuide ∷ DeckDSL Unit
dismissAccessNextActionCardGuide =
  H.gets _.presentAccessNextActionCardGuide >>=
    flip when do
      H.modify (DCS._presentAccessNextActionCardGuide .~ false)
      storeDismissedAccessNextActionCardGuide

resetAccessNextActionCardGuideDelay ∷ DeckDSL Unit
resetAccessNextActionCardGuideDelay =
  whenM cancelPresentAccessNextActionCardGuide
    presentAccessNextActionCardGuideAfterDelay

handleNextAction ∷ DeckOptions → Next.Message → DeckDSL Unit
handleNextAction opts = case _ of
  Next.AddCard cardType → do
    void $ H.lift $ P.addCard opts.deckId cardType
    updateBackSide opts
  Next.PresentReason input cardType → do
    presentReason input cardType

presentReason ∷ Port.Port → CT.CardType → DeckDSL Unit
presentReason input cardType =
  showDialog dialog
  where
  insertableCardType = ICT.fromCardType cardType
  ioType = ICT.fromPort input
  reason = ICT.reason ioType cardType
  cardPaths = ICT.cardPathsBetween ioType insertableCardType
  dialog = Dialog.Reason cardType reason cardPaths

deleteDeck ∷ DeckOptions → DeckDSL Unit
deleteDeck opts = do
  st ← H.get
  H.lift $ P.deleteDeck opts.deckId
  navigateToDeck opts.cursor
  pure unit

loadDeck ∷ DeckOptions → DeckDSL Unit
loadDeck opts = mbLoadError =<< runMaybeT do
  deck ← MaybeT $ H.lift $ P.getDeck opts.deckId
  cardDefs ← MaybeT $ getCardDefs deck.model.cards
  lift $ H.subscribe $ busEventSource (\msg → HandleEval msg H.Listening) deck.bus
  lift case deck.status of
    ED.NeedsEval cardId → do
      let displayCards = [ Left DCS.PendingCard ]
      H.modify $ DCS.fromModel { name: deck.model.name, displayCards }
      H.lift $ P.queueEval 13 (opts.deckId L.: opts.cursor × cardId)
    ED.PendingEval cardId → do
      st ← H.get
      active ← activeCardIndex
      let displayCards = map Right cardDefs <> [ Left DCS.PendingCard ]
      H.modify
        $ (DCS._pendingCardIndex .~ DCS.cardIndexFromId cardId st)
        ∘ (DCS._activeCardIndex .~ active)
        ∘ DCS.fromModel { name: deck.model.name, displayCards }
      updateActiveState opts
    ED.Completed (port × _) → do
      active ← activeCardIndex
      H.modify
        $ (DCS.updateCompletedCards cardDefs port)
        ∘ (DCS._activeCardIndex .~ active)
        ∘ (DCS._pendingCardIndex .~ Nothing)
        ∘ DCS.fromModel { name: deck.model.name, displayCards: [] }
      updateActiveState opts
  where
  activeCardIndex = do
    { cache } ← H.lift Wiring.expose
    map _.cardIndex <$> H.lift (Cache.get opts.deckId cache.activeState)

  mbLoadError = case _ of
    Nothing → H.modify _ { loadError = Just "Unable to load deck due to an inconsistent model" }
    Just a  → pure a

handleEval ∷ DeckOptions → ED.EvalMessage → DeckDSL Unit
handleEval opts = case _ of
  ED.Pending cardId → do
    st ← H.get
    H.modify
      $ (DCS._pendingCardIndex .~ DCS.cardIndexFromId cardId st)
      ∘ (DCS.addMetaCard DCS.PendingCard)
  ED.Complete cardIds output@(port × _) → do
    getCardDefs cardIds >>= case _ of
      Nothing →
        H.modify _ { loadError = Just "Deck references non-existent cards" }
      Just cardDefs → do
        queryNextAction $ H.action $ Next.UpdateInput port
        H.modify (DCS.updateCompletedCards cardDefs port)
        updateActiveState opts
  ED.NameChange name → H.modify _ { name = name }
  ED.CardComplete cardId → do
    H.modify \st →
      let
        ix = DCS.cardIndexFromId cardId st
        lastIx = DCS.findLastCardIndex st
        pendingCardIndex = case ix, lastIx of
          Nothing, _ → st.pendingCardIndex
          _, Nothing → st.pendingCardIndex
          Just ix', Just lastIx'
            | lastIx' > ix' → Just $ ix' + one
            | otherwise → Nothing
      in st # DCS._pendingCardIndex .~ pendingCardIndex

  _ → pure unit

getCardDefs ∷ Array CardId → DeckDSL (Maybe (Array DCS.CardDef))
getCardDefs cardIds =
  sequence <$> for cardIds \cardId →
    map (mkCardDef cardId) <$> H.lift (P.getCard cardId)

mkCardDef ∷ CardId → EC.Cell → DCS.CardDef
mkCardDef cardId cell = { cardId, cardType: Card.modelCardType cell.model }

getDeckTree ∷ DeckId → DeckDSL (Maybe (ET.TraverseDeck ED.Cell EC.Cell))
getDeckTree deckId = do
  wiring ← H.lift Wiring.expose
  decks ← H.lift $ Cache.snapshot wiring.eval.decks
  cards ← H.lift $ Cache.snapshot wiring.eval.cards
  pure (ET.unfoldEvalTree decks cards deckId)

preloadCard ∷ GD.GripperDef → DeckDSL Unit
preloadCard gDef = do
  st ← H.get
  let
    ix = case gDef of
      GD.Previous true → (_ - 1) <$> st.activeCardIndex
      GD.Next true → (_ + 1) <$> st.activeCardIndex
      _ → Nothing
  for_ (ix >>= flip DCS.cardIdFromIndex st) \cardId → do
    void $ queryCardEval cardId $ H.action CQ.PreloadCard

updateCardSize ∷ DeckDSL Unit
updateCardSize = do
  H.queryAll' cpCard $ H.action CQ.UpdateDimensions
  displayMode ← H.gets _.displayMode
  if DCS.isFrontSide displayMode
    then queryNextActionList $ H.action ActionList.CalculateBoundingRect
    else queryBacksideActionList $ H.action ActionList.CalculateBoundingRect
  H.getHTMLElementRef sizerRef >>= traverse_ \el → do
    { width } ← H.liftEff $ getBoundingClientRect el
    H.modify $ DCS._responsiveSize .~ breakpoint width
  where
  breakpoint w
    | w < 240.0 = DCS.XSmall
    | w < 320.0 = DCS.Small
    | w < 420.0 = DCS.Medium
    | w < 540.0 = DCS.Large
    | w < 720.0 = DCS.XLarge
    | otherwise = DCS.XXLarge

presentFlipGuideFirstTime ∷ DeckDSL Unit
presentFlipGuideFirstTime = do
  whenM shouldPresentFlipGuide do
    { bus } ← H.lift Wiring.expose
    H.liftAff $ Bus.write Guide.FlipGuide bus.stepByStep

shouldPresentFlipGuide ∷ DeckDSL Boolean
shouldPresentFlipGuide =
  H.lift
    $ either (const true) not
    <$> LocalStorage.getLocalStorage Guide.dismissedFlipGuideKey


Added answer match

Added answer match

module Flag.Core (Event, view, foldp, init) where

import Prelude hiding (div)
import Data.Maybe (Maybe(..))
import Data.Array (uncons, length, replicate, zip, sortBy, drop, head)
import Control.Monad.Eff.Exception (Error)
import Data.Either (Either(..))
import Control.Monad.Eff.Random (RANDOM, random)
import Control.Monad.Aff (liftEff')
import Data.Tuple (Tuple(..), fst)
import Data.Traversable (sequence)
import Data.Foldable (for_)
import Pux (EffModel, noEffects)
import Pux.DOM.HTML (HTML)
import Pux.DOM.Events (onClick)
import Text.Smolder.HTML (h1, img, button, ul, li, div)
import Text.Smolder.Markup (text, (!), (#!))
import Text.Smolder.HTML.Attributes (src, alt, className, disabled)

type Name = String
type Countries = Array Name

type State = { countries ∷ Countries, correct ∷ Int, incorrect ∷ Int }
data Event = Answer Name Name | RequestCountries | ReceiveCountries (Either Error Countries)

init ∷ State
init = { countries: [], correct: 0, incorrect: 0 }

foldp ∷ Event → State → EffModel State Event (random ∷ RANDOM)
foldp (Answer a b) st
  | a == b    = noEffects $ st { countries = drop 1 st.countries, correct = st.correct + 1 }
  | a /= b    = noEffects $ st { countries = drop 1 st.countries, incorrect = st.incorrect + 1 }
  | otherwise = noEffects $ st { countries = drop 1 st.countries }
foldp (ReceiveCountries (Left err)) st = noEffects $ st { countries = [] }
foldp (ReceiveCountries (Right xs)) st = noEffects $ st { countries = xs }
foldp (RequestCountries)            st = { state: st, effects: [do
  xs <- liftEff' $ map fst <$> sortBy compareSnd <$> pairs
  pure $ Just $ ReceiveCountries xs
]}
  where
    pairs = zip countries <$> (sequence $ replicate (length countries) random)
    compareSnd (Tuple _ a) (Tuple _ b) = compare a b
    countries = ["Russia", "Japan", "Thailand"]

view ∷ State → HTML Event
view state = div ! className "flagship" $ case uncons state.countries of
  Nothing -> toolbar state
  Just _  -> toolbar state <> flag state

toolbar ∷ State → HTML Event
toolbar state = ul ! className "header" $ do
  li $ h1 $ text "Flagship"
  li $ button ! disabled isDisabled #! onClick (const RequestCountries) $ text "Start"
  li ! className "score correct" $ text $ show state.correct
  li ! className "score incorrect" $ text $ show state.incorrect
  li ! className "score" $ text $ show $ state.correct + state.incorrect
    where
      isDisabled = if (length state.countries == 0) then "" else "disabled"

flag ∷ State → HTML Event
flag state = div ! className "prompt" $ do
  case head state.countries of
    Just name -> do
      img ! src ("images/flags/" <> name <> ".svg") ! alt "Flag"
      ul ! className "countries" $ for_ state.countries $ choice name
    Nothing   -> div $ text "All done!"

choice ∷ Name → Name → HTML Event
choice answer name = li $ button #! onClick (const $ Answer answer name) $ text name

module Flag.Core (Event, view, foldp, init) where

import Prelude hiding (div)
import Data.Maybe (Maybe(..))
import Data.Array (uncons, length, replicate, zip, sortBy)
import Control.Monad.Eff.Exception (Error)
import Data.Either (Either(..))
import Control.Monad.Eff.Random (RANDOM, random)
import Control.Monad.Aff (liftEff')
import Data.Tuple (Tuple(..), fst)
import Data.Traversable (sequence)
import Data.Foldable (for_)
import Pux (EffModel, noEffects)
import Pux.DOM.HTML (HTML)
import Pux.DOM.Events (onClick)
import Text.Smolder.HTML (h1, img, button, ul, li, div)
import Text.Smolder.Markup (text, (!), (#!))
import Text.Smolder.HTML.Attributes (src, alt, className, disabled)

type Name = String
type Countries = Array Name

type State = { name ∷ Name, countries ∷ Countries, correct ∷ Int, incorrect ∷ Int }
data Event = Answer Name | RequestCountries | ReceiveCountries (Either Error Countries)

init ∷ State
init = { name: "", countries: [], correct: 0, incorrect: 0 }

foldp ∷ Event → State → EffModel State Event (random ∷ RANDOM)
foldp (Answer x) st
  | st.name == x = noEffects $ st { name = x, correct = st.correct + 1 }
  | st.name /= x = noEffects $ st { name = x, incorrect = st.incorrect + 1 }
  | otherwise    = noEffects $ st { name = x }
foldp (ReceiveCountries (Left err)) st = noEffects $ st { countries = [] }
foldp (ReceiveCountries (Right xs)) st = noEffects $ st { name = "Russia", countries = xs }
foldp (RequestCountries)            st = { state: st, effects: [do
  xs <- liftEff' $ map fst <$> sortBy compareSnd <$> zip countries <$> (sequence $ replicate (length countries) random)
  pure $ Just $ ReceiveCountries xs
]}
  where
    compareSnd (Tuple _ a) (Tuple _ b) = compare a b
    countries = ["Russia", "Japan", "Thailand"]

view ∷ State → HTML Event
view state = div ! className "flagship" $ case uncons state.countries of
  Nothing -> toolbar state
  Just _  -> toolbar state <> flag state

toolbar ∷ State → HTML Event
toolbar state = ul ! className "header" $ do
  li $ h1 $ text "Flagship"
  li $ button ! disabled isDisabled #! onClick (const RequestCountries) $ text "Start"
  li ! className "score correct" $ text $ show state.correct
  li ! className "score incorrect" $ text $ show state.incorrect
  li ! className "score" $ text $ show $ state.correct + state.incorrect
    where
      isDisabled = if (length state.countries == 0) then "" else "disabled"

flag ∷ State → HTML Event
flag state = div ! className "prompt" $ do
  img ! src path ! alt "Flag"
  ul ! className "countries" $ for_ state.countries choice
    where
      path = ("images/flags/" <> state.name <> ".svg")

choice ∷ Name → HTML Event
choice name =
  li $ button #! onClick (const $ Answer name) $ text name