{-
 *  Programmer:	Piotr Borek
 *  E-mail:     piotrborek@op.pl
 *  Copyright 2016 Piotr Borek
 *
 *  Distributed under the terms of the GPL (GNU Public License)
 *
 *  This program is free software; you can redistribute it and/or modify
 *  it under the terms of the GNU General Public License as published by
 *  the Free Software Foundation; either version 2 of the License, or
 *  (at your option) any later version.
 *
 *  This program is distributed in the hope that it will be useful,
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 *  GNU General Public License for more details.
 *
 *  You should have received a copy of the GNU General Public License
 *  along with this program; if not, write to the Free Software
 *  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
-}
{-# LANGUAGE RankNTypes      #-}
{-# LANGUAGE TemplateHaskell #-}

module Simple.UI.Core.Internal.UIApp where

import qualified Graphics.Vty                     as Vty

import           Control.Concurrent.STM
import           Control.Lens
import           Control.Monad.IO.Class
import           Control.Monad.State.Class
import           Control.Monad.Trans.Reader
import           Control.Monad.Trans.State.Strict hiding (get, put)

import           Simple.UI.Core.Draw

import {-# SOURCE #-} Simple.UI.Widgets.Widget


type UIApp u = ReaderT (AppConfig u) (StateT AppState IO)

type UIApp' = UIApp ()

data UIAppEvent = UIAppEventResize Int Int
                | UIAppEventKeyPressed Vty.Key [Vty.Modifier]
                | UIAppEventAction (UIApp' ())
                | UIAppEventQuit

type UIAppTasks = TChan UIAppEvent

data AppConfig u = AppConfig
    { AppConfig u -> Vty
_appVty      :: Vty.Vty
    , AppConfig u -> UIAppTasks
_appTasks    :: UIAppTasks
    , AppConfig u -> u
_appUserData :: u
    }

data AppState = AppState
    { AppState -> Integer
_appIdCounter :: Integer
    , AppState -> Int
_appWidth     :: Int
    , AppState -> Int
_appHeight    :: Int
    , AppState -> Drawing
_appDrawing   :: Drawing
    , AppState -> Maybe Widget
_appRoot      :: Maybe Widget
    }

makeLenses ''AppConfig
makeLenses ''AppState

instance Eq UIAppEvent where
    UIAppEvent
UIAppEventQuit == :: UIAppEvent -> UIAppEvent -> Bool
== UIAppEvent
UIAppEventQuit = Bool
True
    UIAppEvent
_ == UIAppEvent
_ = Bool
False

uniqueIdNew :: UIApp u Integer
uniqueIdNew :: UIApp u Integer
uniqueIdNew = (Integer -> (Integer, Integer)) -> AppState -> (Integer, AppState)
Lens' AppState Integer
appIdCounter ((Integer -> (Integer, Integer))
 -> AppState -> (Integer, AppState))
-> Integer -> UIApp u Integer
forall s (m :: * -> *) a.
(MonadState s m, Num a) =>
LensLike' ((,) a) s a -> a -> m a
<+= Integer
1

_runUIApp :: MonadIO m => AppConfig u -> AppState -> UIApp u a -> m (a, AppState)
_runUIApp :: AppConfig u -> AppState -> UIApp u a -> m (a, AppState)
_runUIApp AppConfig u
initConfig AppState
initState UIApp u a
app = IO (a, AppState) -> m (a, AppState)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (a, AppState) -> m (a, AppState))
-> IO (a, AppState) -> m (a, AppState)
forall a b. (a -> b) -> a -> b
$ StateT AppState IO a -> AppState -> IO (a, AppState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (UIApp u a -> AppConfig u -> StateT AppState IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT UIApp u a
app AppConfig u
initConfig) AppState
initState

liftUIApp' :: UIApp' a -> UIApp u a
liftUIApp' :: UIApp' a -> UIApp u a
liftUIApp' UIApp' a
app = do
    AppState
s <- ReaderT (AppConfig u) (StateT AppState IO) AppState
forall s (m :: * -> *). MonadState s m => m s
get
    AppConfig u
r <- ReaderT (AppConfig u) (StateT AppState IO) (AppConfig u)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    (a
x, AppState
s') <- AppConfig ()
-> AppState
-> UIApp' a
-> ReaderT (AppConfig u) (StateT AppState IO) (a, AppState)
forall (m :: * -> *) u a.
MonadIO m =>
AppConfig u -> AppState -> UIApp u a -> m (a, AppState)
_runUIApp (AppConfig u -> AppConfig ()
forall u. AppConfig u -> AppConfig ()
newConf AppConfig u
r) AppState
s UIApp' a
app
    AppState -> ReaderT (AppConfig u) (StateT AppState IO) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put AppState
s'
    a -> UIApp u a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
  where
    newConf :: AppConfig u -> AppConfig ()
    newConf :: AppConfig u -> AppConfig ()
newConf AppConfig u
conf = AppConfig :: forall u. Vty -> UIAppTasks -> u -> AppConfig u
AppConfig
        { _appVty :: Vty
_appVty = AppConfig u -> Vty
forall u. AppConfig u -> Vty
_appVty AppConfig u
conf
        , _appTasks :: UIAppTasks
_appTasks = AppConfig u -> UIAppTasks
forall u. AppConfig u -> UIAppTasks
_appTasks AppConfig u
conf
        , _appUserData :: ()
_appUserData = ()
forall a. HasCallStack => a
undefined
        }

liftUIApp :: u -> UIApp u a -> UIApp' a
liftUIApp :: u -> UIApp u a -> UIApp' a
liftUIApp u
userData UIApp u a
app = do
    AppState
s <- ReaderT (AppConfig ()) (StateT AppState IO) AppState
forall s (m :: * -> *). MonadState s m => m s
get
    AppConfig ()
r <- ReaderT (AppConfig ()) (StateT AppState IO) (AppConfig ())
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask

    let appConf :: AppConfig u
appConf = AppConfig :: forall u. Vty -> UIAppTasks -> u -> AppConfig u
AppConfig
            { _appVty :: Vty
_appVty = AppConfig () -> Vty
forall u. AppConfig u -> Vty
_appVty AppConfig ()
r
            , _appTasks :: UIAppTasks
_appTasks = AppConfig () -> UIAppTasks
forall u. AppConfig u -> UIAppTasks
_appTasks AppConfig ()
r
            , _appUserData :: u
_appUserData = u
userData
        }

    (a
x, AppState
s') <- AppConfig u
-> AppState
-> UIApp u a
-> ReaderT (AppConfig ()) (StateT AppState IO) (a, AppState)
forall (m :: * -> *) u a.
MonadIO m =>
AppConfig u -> AppState -> UIApp u a -> m (a, AppState)
_runUIApp AppConfig u
appConf AppState
s UIApp u a
app
    AppState -> ReaderT (AppConfig ()) (StateT AppState IO) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put AppState
s'
    a -> UIApp' a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x