{-# LANGUAGE RecordWildCards #-}

module Monomer.SaveManager.SaveManagerEvent
    ( SaveManagerEvent(..)
    , handleEvent
    ) where

import Control.Lens
import Data.Maybe
import Data.Text (Text)
import Data.Time.LocalTime
import Monomer.Widgets.Composite
import qualified Data.Sequence as Seq
import qualified Data.Text as T

import Monomer.SaveManager.SaveManagerCfg
import Monomer.SaveManager.SaveManagerModel

data SaveManagerEvent a
    = EventNewSlot
    | EventSave
    | EventLoad
    | EventRemove
    | EventConfirmRemove
    | EventCancel
    | EventSetCurrentData a
    | EventSetSavedData (Saves a)
    | EventSetSelectedData (Maybe Int)
    | EventFocus Path
    | EventBlur Path
    deriving SaveManagerEvent a -> SaveManagerEvent a -> Bool
forall a. Eq a => SaveManagerEvent a -> SaveManagerEvent a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SaveManagerEvent a -> SaveManagerEvent a -> Bool
$c/= :: forall a. Eq a => SaveManagerEvent a -> SaveManagerEvent a -> Bool
== :: SaveManagerEvent a -> SaveManagerEvent a -> Bool
$c== :: forall a. Eq a => SaveManagerEvent a -> SaveManagerEvent a -> Bool
Eq

type EventHandle a sp ep
    = (SaveManagerCfg sp ep a)
    -> (SaveManagerModel a)
    -> [EventResponse
            (SaveManagerModel a) (SaveManagerEvent a) sp ep]

handleEvent
    :: (SaveManagerCfg sp ep a)
    -> EventHandler (SaveManagerModel a) (SaveManagerEvent a) sp ep
handleEvent :: forall sp ep a.
SaveManagerCfg sp ep a
-> EventHandler (SaveManagerModel a) (SaveManagerEvent a) sp ep
handleEvent SaveManagerCfg sp ep a
config WidgetEnv (SaveManagerModel a) (SaveManagerEvent a)
_ WidgetNode (SaveManagerModel a) (SaveManagerEvent a)
node SaveManagerModel a
model SaveManagerEvent a
event = case SaveManagerEvent a
event of
    SaveManagerEvent a
EventNewSlot -> forall a sp ep. EventHandle a sp ep
newSlotHandle SaveManagerCfg sp ep a
config SaveManagerModel a
model
    SaveManagerEvent a
EventSave -> forall a sp ep. EventHandle a sp ep
saveHandle SaveManagerCfg sp ep a
config SaveManagerModel a
model
    SaveManagerEvent a
EventLoad -> forall a sp ep. EventHandle a sp ep
loadHandle SaveManagerCfg sp ep a
config SaveManagerModel a
model
    SaveManagerEvent a
EventRemove -> forall a sp ep. EventHandle a sp ep
removeHandle SaveManagerCfg sp ep a
config SaveManagerModel a
model
    SaveManagerEvent a
EventConfirmRemove -> forall a sp ep. EventHandle a sp ep
confirmRemoveHandle SaveManagerCfg sp ep a
config SaveManagerModel a
model
    SaveManagerEvent a
EventCancel -> forall a sp ep. EventHandle a sp ep
cancelHandle SaveManagerCfg sp ep a
config SaveManagerModel a
model
    EventSetCurrentData a
s -> forall a sp ep. a -> EventHandle a sp ep
setCurrentDataHandle a
s SaveManagerCfg sp ep a
config SaveManagerModel a
model
    EventSetSavedData Saves a
s -> forall a sp ep. Saves a -> EventHandle a sp ep
setSavedDataHandle Saves a
s SaveManagerCfg sp ep a
config SaveManagerModel a
model
    EventSetSelectedData Maybe Int
s -> forall a sp ep. Maybe Int -> EventHandle a sp ep
setSelectedDataHandle Maybe Int
s SaveManagerCfg sp ep a
config SaveManagerModel a
model
    EventFocus Path
prev -> forall s e a sp ep. WidgetNode s e -> Path -> EventHandle a sp ep
focusHandle WidgetNode (SaveManagerModel a) (SaveManagerEvent a)
node Path
prev SaveManagerCfg sp ep a
config SaveManagerModel a
model
    EventBlur Path
next -> forall s e a sp ep. WidgetNode s e -> Path -> EventHandle a sp ep
blurHandle WidgetNode (SaveManagerModel a) (SaveManagerEvent a)
node Path
next SaveManagerCfg sp ep a
config SaveManagerModel a
model

newSlotHandle :: EventHandle a sp ep
newSlotHandle :: forall a sp ep. EventHandle a sp ep
newSlotHandle SaveManagerCfg sp ep a
config SaveManagerModel{a
Bool
Maybe Int
Seq (a, Text)
_smmShowConfirmRemove :: forall a. SaveManagerModel a -> Bool
_smmSelectedData :: forall a. SaveManagerModel a -> Maybe Int
_smmCurrentData :: forall a. SaveManagerModel a -> a
_smmSavedData :: forall a. SaveManagerModel a -> Seq (a, Text)
_smmShowConfirmRemove :: Bool
_smmSelectedData :: Maybe Int
_smmCurrentData :: a
_smmSavedData :: Seq (a, Text)
..} = [forall s e sp ep. ProducerHandler e -> EventResponse s e sp ep
Producer forall {b}. (SaveManagerEvent a -> IO b) -> IO b
handler] where
    handler :: (SaveManagerEvent a -> IO b) -> IO b
handler SaveManagerEvent a -> IO b
raiseEvent = do
        (a, Text)
x <- forall s e a. SaveManagerCfg s e a -> a -> IO (a, Text)
makeCaption SaveManagerCfg sp ep a
config a
_smmCurrentData
        b
_ <- SaveManagerEvent a -> IO b
raiseEvent forall a b. (a -> b) -> a -> b
$ forall a. Saves a -> SaveManagerEvent a
EventSetSavedData forall a b. (a -> b) -> a -> b
$ (a, Text)
x forall s a. Cons s s a a => a -> s -> s
<| Seq (a, Text)
_smmSavedData
        SaveManagerEvent a -> IO b
raiseEvent forall a b. (a -> b) -> a -> b
$ forall a. Maybe Int -> SaveManagerEvent a
EventSetSelectedData forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Int
0

saveHandle :: EventHandle a sp ep
saveHandle :: forall a sp ep. EventHandle a sp ep
saveHandle SaveManagerCfg sp ep a
config SaveManagerModel{a
Bool
Maybe Int
Seq (a, Text)
_smmShowConfirmRemove :: Bool
_smmSelectedData :: Maybe Int
_smmCurrentData :: a
_smmSavedData :: Seq (a, Text)
_smmShowConfirmRemove :: forall a. SaveManagerModel a -> Bool
_smmSelectedData :: forall a. SaveManagerModel a -> Maybe Int
_smmCurrentData :: forall a. SaveManagerModel a -> a
_smmSavedData :: forall a. SaveManagerModel a -> Seq (a, Text)
..} = forall {s} {sp} {ep}. [EventResponse s (SaveManagerEvent a) sp ep]
response where
    response :: [EventResponse s (SaveManagerEvent a) sp ep]
response = [forall s e sp ep. ProducerHandler e -> EventResponse s e sp ep
Producer forall {b}. (SaveManagerEvent a -> IO b) -> IO b
handler | Bool
selected]
    handler :: (SaveManagerEvent a -> IO b) -> IO b
handler SaveManagerEvent a -> IO b
raiseEvent = do
        (a, Text)
x <- forall s e a. SaveManagerCfg s e a -> a -> IO (a, Text)
makeCaption SaveManagerCfg sp ep a
config a
_smmCurrentData
        let newSavedData :: Seq (a, Text)
newSavedData = forall a. Int -> a -> Seq a -> Seq a
Seq.update Int
i (a, Text)
x Seq (a, Text)
_smmSavedData
        SaveManagerEvent a -> IO b
raiseEvent forall a b. (a -> b) -> a -> b
$ forall a. Saves a -> SaveManagerEvent a
EventSetSavedData Seq (a, Text)
newSavedData
    selected :: Bool
selected = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null Maybe Int
_smmSelectedData
    i :: Int
i = forall a. HasCallStack => Maybe a -> a
fromJust Maybe Int
_smmSelectedData

loadHandle :: EventHandle a sp ep
loadHandle :: forall a sp ep. EventHandle a sp ep
loadHandle SaveManagerCfg sp ep a
_ SaveManagerModel{a
Bool
Maybe Int
Seq (a, Text)
_smmShowConfirmRemove :: Bool
_smmSelectedData :: Maybe Int
_smmCurrentData :: a
_smmSavedData :: Seq (a, Text)
_smmShowConfirmRemove :: forall a. SaveManagerModel a -> Bool
_smmSelectedData :: forall a. SaveManagerModel a -> Maybe Int
_smmCurrentData :: forall a. SaveManagerModel a -> a
_smmSavedData :: forall a. SaveManagerModel a -> Seq (a, Text)
..} = forall {s} {sp} {ep}. [EventResponse s (SaveManagerEvent a) sp ep]
response where
    response :: [EventResponse s (SaveManagerEvent a) sp ep]
response = [forall s e sp ep. e -> EventResponse s e sp ep
Event SaveManagerEvent a
setCurrentData | Bool
selected]
    setCurrentData :: SaveManagerEvent a
setCurrentData = forall a. a -> SaveManagerEvent a
EventSetCurrentData a
d
    selected :: Bool
selected = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null Maybe Int
_smmSelectedData
    d :: a
d = forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. Seq a -> Int -> a
Seq.index Seq (a, Text)
_smmSavedData Int
i
    i :: Int
i = forall a. HasCallStack => Maybe a -> a
fromJust Maybe Int
_smmSelectedData

removeHandle :: EventHandle a sp ep
removeHandle :: forall a sp ep. EventHandle a sp ep
removeHandle SaveManagerCfg sp ep a
_ SaveManagerModel{a
Bool
Maybe Int
Seq (a, Text)
_smmShowConfirmRemove :: Bool
_smmSelectedData :: Maybe Int
_smmCurrentData :: a
_smmSavedData :: Seq (a, Text)
_smmShowConfirmRemove :: forall a. SaveManagerModel a -> Bool
_smmSelectedData :: forall a. SaveManagerModel a -> Maybe Int
_smmCurrentData :: forall a. SaveManagerModel a -> a
_smmSavedData :: forall a. SaveManagerModel a -> Seq (a, Text)
..} = forall {s} {sp} {ep}. [EventResponse s (SaveManagerEvent a) sp ep]
responses where
    responses :: [EventResponse s (SaveManagerEvent a) sp ep]
responses = if Bool
selected
        then
            [ forall s e sp ep. e -> EventResponse s e sp ep
Event forall a b. (a -> b) -> a -> b
$ forall a. Maybe Int -> SaveManagerEvent a
EventSetSelectedData Maybe Int
newSelectedData
            , forall s e sp ep. e -> EventResponse s e sp ep
Event forall a b. (a -> b) -> a -> b
$ forall a. Saves a -> SaveManagerEvent a
EventSetSavedData Seq (a, Text)
newSavedData
            , forall s e sp ep. e -> EventResponse s e sp ep
Event forall a b. (a -> b) -> a -> b
$ forall a. SaveManagerEvent a
EventCancel
            ]
        else []
    selected :: Bool
selected = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null Maybe Int
_smmSelectedData
    newSavedData :: Seq (a, Text)
newSavedData = forall a. Int -> Seq a -> Seq a
Seq.deleteAt Int
i Seq (a, Text)
_smmSavedData
    i :: Int
i = forall a. HasCallStack => Maybe a -> a
fromJust Maybe Int
_smmSelectedData
    newSelectedData :: Maybe Int
newSelectedData = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null Seq (a, Text)
newSavedData
        then forall a. Maybe a
Nothing
        else forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> a -> a
min Int
i forall a b. (a -> b) -> a -> b
$ forall a. Seq a -> Int
Seq.length Seq (a, Text)
newSavedData forall a. Num a => a -> a -> a
- Int
1

confirmRemoveHandle :: EventHandle a sp ep
confirmRemoveHandle :: forall a sp ep. EventHandle a sp ep
confirmRemoveHandle SaveManagerCfg sp ep a
_ SaveManagerModel a
model = forall {e} {sp} {ep}. [EventResponse (SaveManagerModel a) e sp ep]
responses where
    responses :: [EventResponse (SaveManagerModel a) e sp ep]
responses = [forall s e sp ep. s -> EventResponse s e sp ep
Model forall a b. (a -> b) -> a -> b
$ SaveManagerModel a
model forall a b. a -> (a -> b) -> b
& forall s a. HasShowConfirmRemove s a => Lens' s a
showConfirmRemove forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
True]

cancelHandle :: EventHandle a sp ep
cancelHandle :: forall a sp ep. EventHandle a sp ep
cancelHandle SaveManagerCfg sp ep a
_ SaveManagerModel a
model = [forall s e sp ep. s -> EventResponse s e sp ep
Model forall a b. (a -> b) -> a -> b
$ SaveManagerModel a
model forall a b. a -> (a -> b) -> b
& forall s a. HasShowConfirmRemove s a => Lens' s a
showConfirmRemove forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
False]

setCurrentDataHandle :: a -> EventHandle a sp ep
setCurrentDataHandle :: forall a sp ep. a -> EventHandle a sp ep
setCurrentDataHandle a
newCurrentData SaveManagerCfg sp ep a
config SaveManagerModel a
model = forall {e}. [EventResponse (SaveManagerModel a) e sp ep]
responses where
    responses :: [EventResponse (SaveManagerModel a) e sp ep]
responses = (forall s e sp ep. s -> EventResponse s e sp ep
Model forall a b. (a -> b) -> a -> b
$ SaveManagerModel a
model forall a b. a -> (a -> b) -> b
& forall s a. HasCurrentData s a => Lens' s a
currentData forall s t a b. ASetter s t a b -> b -> s -> t
.~ a
newCurrentData)forall a. a -> [a] -> [a]
:forall {s} {e}. [EventResponse s e sp ep]
req
    req :: [EventResponse s e sp ep]
req = forall s e sp ep. WidgetRequest sp ep -> EventResponse s e sp ep
RequestParent forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((forall a b. (a -> b) -> a -> b
$ a
newCurrentData) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a -> WidgetRequest sp ep]
onChangeReq')
    onChangeReq' :: [a -> WidgetRequest sp ep]
onChangeReq' = forall s e a. SaveManagerCfg s e a -> [a -> WidgetRequest s e]
_smcOnChangeReq SaveManagerCfg sp ep a
config

setSavedDataHandle :: Saves a -> EventHandle a sp ep
setSavedDataHandle :: forall a sp ep. Saves a -> EventHandle a sp ep
setSavedDataHandle Saves a
newSavedData SaveManagerCfg sp ep a
config SaveManagerModel a
model = forall {e}. [EventResponse (SaveManagerModel a) e sp ep]
responses where
    responses :: [EventResponse (SaveManagerModel a) e sp ep]
responses = (forall s e sp ep. s -> EventResponse s e sp ep
Model forall a b. (a -> b) -> a -> b
$ SaveManagerModel a
model forall a b. a -> (a -> b) -> b
& forall s a. HasSavedData s a => Lens' s a
savedData forall s t a b. ASetter s t a b -> b -> s -> t
.~ Saves a
newSavedData)forall a. a -> [a] -> [a]
:forall {s} {e}. [EventResponse s e sp ep]
req
    req :: [EventResponse s e sp ep]
req = forall s e sp ep. WidgetRequest sp ep -> EventResponse s e sp ep
RequestParent forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((forall a b. (a -> b) -> a -> b
$ Saves a
newSavedData) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Saves a -> WidgetRequest sp ep]
onSavesChangeReq')
    onSavesChangeReq' :: [Saves a -> WidgetRequest sp ep]
onSavesChangeReq' = forall s e a.
SaveManagerCfg s e a -> [Saves a -> WidgetRequest s e]
_smcOnSavesChangeReq SaveManagerCfg sp ep a
config

setSelectedDataHandle :: Maybe Int -> EventHandle a sp ep
setSelectedDataHandle :: forall a sp ep. Maybe Int -> EventHandle a sp ep
setSelectedDataHandle Maybe Int
newSelectedData SaveManagerCfg sp ep a
_ SaveManagerModel a
model = [forall s e sp ep. s -> EventResponse s e sp ep
Model SaveManagerModel a
model'] where
    model' :: SaveManagerModel a
model' = SaveManagerModel a
model forall a b. a -> (a -> b) -> b
& forall s a. HasSelectedData s a => Lens' s a
selectedData forall s t a b. ASetter s t a b -> b -> s -> t
.~ Maybe Int
newSelectedData

focusHandle :: WidgetNode s e -> Path -> EventHandle a sp ep
focusHandle :: forall s e a sp ep. WidgetNode s e -> Path -> EventHandle a sp ep
focusHandle WidgetNode s e
node Path
prev SaveManagerCfg sp ep a
config SaveManagerModel a
_ = forall {s} {e}. [EventResponse s e sp ep]
response where
    response :: [EventResponse s e sp ep]
response = if Bool
valid
        then forall s e sp ep. WidgetRequest sp ep -> EventResponse s e sp ep
RequestParent forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((forall a b. (a -> b) -> a -> b
$ Path
prev) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s e a. SaveManagerCfg s e a -> [Path -> WidgetRequest s e]
_smcOnFocusReq SaveManagerCfg sp ep a
config)
        else []
    valid :: Bool
valid = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall s e. WidgetNode s e -> Path -> Bool
isNodeParentOfPath WidgetNode s e
node Path
prev

blurHandle :: WidgetNode s e -> Path -> EventHandle a sp ep
blurHandle :: forall s e a sp ep. WidgetNode s e -> Path -> EventHandle a sp ep
blurHandle WidgetNode s e
node Path
next SaveManagerCfg{[a -> WidgetRequest sp ep]
[Path -> WidgetRequest sp ep]
[Saves a -> WidgetRequest sp ep]
Maybe Bool
Maybe (a -> ZonedTime -> Text)
_smcNoConfirm :: forall s e a. SaveManagerCfg s e a -> Maybe Bool
_smcCaptionMethod :: forall s e a.
SaveManagerCfg s e a -> Maybe (a -> ZonedTime -> Text)
_smcOnBlurReq :: forall s e a. SaveManagerCfg s e a -> [Path -> WidgetRequest s e]
_smcNoConfirm :: Maybe Bool
_smcCaptionMethod :: Maybe (a -> ZonedTime -> Text)
_smcOnSavesChangeReq :: [Saves a -> WidgetRequest sp ep]
_smcOnChangeReq :: [a -> WidgetRequest sp ep]
_smcOnBlurReq :: [Path -> WidgetRequest sp ep]
_smcOnFocusReq :: [Path -> WidgetRequest sp ep]
_smcOnFocusReq :: forall s e a. SaveManagerCfg s e a -> [Path -> WidgetRequest s e]
_smcOnSavesChangeReq :: forall s e a.
SaveManagerCfg s e a -> [Saves a -> WidgetRequest s e]
_smcOnChangeReq :: forall s e a. SaveManagerCfg s e a -> [a -> WidgetRequest s e]
..} SaveManagerModel a
_ = forall {s} {e}. [EventResponse s e sp ep]
response where
    response :: [EventResponse s e sp ep]
response = if Bool
valid
        then forall s e sp ep. WidgetRequest sp ep -> EventResponse s e sp ep
RequestParent forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((forall a b. (a -> b) -> a -> b
$ Path
next) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Path -> WidgetRequest sp ep]
_smcOnBlurReq)
        else []
    valid :: Bool
valid = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall s e. WidgetNode s e -> Path -> Bool
isNodeParentOfPath WidgetNode s e
node Path
next

makeCaption :: (SaveManagerCfg s e a) -> a -> IO (a, Text)
makeCaption :: forall s e a. SaveManagerCfg s e a -> a -> IO (a, Text)
makeCaption SaveManagerCfg{[a -> WidgetRequest s e]
[Path -> WidgetRequest s e]
[Saves a -> WidgetRequest s e]
Maybe Bool
Maybe (a -> ZonedTime -> Text)
_smcNoConfirm :: Maybe Bool
_smcCaptionMethod :: Maybe (a -> ZonedTime -> Text)
_smcOnSavesChangeReq :: [Saves a -> WidgetRequest s e]
_smcOnChangeReq :: [a -> WidgetRequest s e]
_smcOnBlurReq :: [Path -> WidgetRequest s e]
_smcOnFocusReq :: [Path -> WidgetRequest s e]
_smcNoConfirm :: forall s e a. SaveManagerCfg s e a -> Maybe Bool
_smcCaptionMethod :: forall s e a.
SaveManagerCfg s e a -> Maybe (a -> ZonedTime -> Text)
_smcOnBlurReq :: forall s e a. SaveManagerCfg s e a -> [Path -> WidgetRequest s e]
_smcOnFocusReq :: forall s e a. SaveManagerCfg s e a -> [Path -> WidgetRequest s e]
_smcOnSavesChangeReq :: forall s e a.
SaveManagerCfg s e a -> [Saves a -> WidgetRequest s e]
_smcOnChangeReq :: forall s e a. SaveManagerCfg s e a -> [a -> WidgetRequest s e]
..} a
d = do
    ZonedTime
time <- IO ZonedTime
getZonedTime
    let defCaption :: Text
defCaption = String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show ZonedTime
time
        cfgCaption :: Maybe Text
cfgCaption = ((forall a b. (a -> b) -> a -> b
$ ZonedTime
time) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. (a -> b) -> a -> b
$ a
d)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (a -> ZonedTime -> Text)
_smcCaptionMethod
    forall (m :: * -> *) a. Monad m => a -> m a
return (a
d, forall a. a -> Maybe a -> a
fromMaybe Text
defCaption Maybe Text
cfgCaption)