{-
 *  Programmer:	Piotr Borek
 *  E-mail:     piotrborek@op.pl
 *  Copyright 2017 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 BangPatterns #-}

module Simple.UI.Core.Attribute (
    Attribute,
    AttributeList,
    attributeNew,
--    attributeNewOverride,
    get,
    set,
    modify,
    add,
    add',
    readAttr,
    writeAttr,
    modifyAttr,
    connectAttrTo
) where

import           Control.Monad
import           Control.Monad.IO.Class
import           Data.IORef

newtype Attribute a = Attribute (IORef (a, [Attribute a]))

type AttributeList a = Attribute [a]

attributeNew :: MonadIO m => a -> m (Attribute a)
attributeNew :: a -> m (Attribute a)
attributeNew !a
x = IO (Attribute a) -> m (Attribute a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Attribute a) -> m (Attribute a))
-> IO (Attribute a) -> m (Attribute a)
forall a b. (a -> b) -> a -> b
$ IORef (a, [Attribute a]) -> Attribute a
forall a. IORef (a, [Attribute a]) -> Attribute a
Attribute (IORef (a, [Attribute a]) -> Attribute a)
-> IO (IORef (a, [Attribute a])) -> IO (Attribute a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a, [Attribute a]) -> IO (IORef (a, [Attribute a]))
forall a. a -> IO (IORef a)
newIORef (a
x, [])

get :: MonadIO m => s -> (s -> Attribute a) -> m a
get :: s -> (s -> Attribute a) -> m a
get s
obj s -> Attribute a
getAttr = Attribute a -> m a
forall (m :: * -> *) a. MonadIO m => Attribute a -> m a
readAttr (Attribute a -> m a) -> Attribute a -> m a
forall a b. (a -> b) -> a -> b
$ s -> Attribute a
getAttr s
obj

set :: MonadIO m => s -> (s -> Attribute a) -> a -> m ()
set :: s -> (s -> Attribute a) -> a -> m ()
set s
obj s -> Attribute a
getAttr = Attribute a -> a -> m ()
forall (m :: * -> *) a. MonadIO m => Attribute a -> a -> m ()
writeAttr (Attribute a -> a -> m ()) -> Attribute a -> a -> m ()
forall a b. (a -> b) -> a -> b
$ s -> Attribute a
getAttr s
obj

modify :: MonadIO m => s -> (s -> Attribute a) -> (a -> a) -> m ()
modify :: s -> (s -> Attribute a) -> (a -> a) -> m ()
modify s
obj s -> Attribute a
getAttr = Attribute a -> (a -> a) -> m ()
forall (m :: * -> *) a.
MonadIO m =>
Attribute a -> (a -> a) -> m ()
modifyAttr (Attribute a -> (a -> a) -> m ())
-> Attribute a -> (a -> a) -> m ()
forall a b. (a -> b) -> a -> b
$ s -> Attribute a
getAttr s
obj

add :: MonadIO m => s -> (s -> AttributeList a) -> (b -> a) -> b -> m ()
add :: s -> (s -> AttributeList a) -> (b -> a) -> b -> m ()
add s
obj s -> AttributeList a
getAttr b -> a
cast !b
x = s -> (s -> AttributeList a) -> ([a] -> [a]) -> m ()
forall (m :: * -> *) s a.
MonadIO m =>
s -> (s -> Attribute a) -> (a -> a) -> m ()
modify s
obj s -> AttributeList a
getAttr (([a] -> [a]) -> m ()) -> ([a] -> [a]) -> m ()
forall a b. (a -> b) -> a -> b
$ \[a]
xs -> [a]
xs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [b -> a
cast b
x]

add' :: MonadIO m => s -> (s -> AttributeList a) -> a -> m ()
add' :: s -> (s -> AttributeList a) -> a -> m ()
add' s
obj s -> AttributeList a
getAttr !a
x = s -> (s -> AttributeList a) -> (a -> a) -> a -> m ()
forall (m :: * -> *) s a b.
MonadIO m =>
s -> (s -> AttributeList a) -> (b -> a) -> b -> m ()
add s
obj s -> AttributeList a
getAttr a -> a
forall a. a -> a
id a
x

readAttr :: MonadIO m => Attribute a -> m a
readAttr :: Attribute a -> m a
readAttr (Attribute IORef (a, [Attribute a])
attr) = IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ (a, [Attribute a]) -> a
forall a b. (a, b) -> a
fst ((a, [Attribute a]) -> a) -> IO (a, [Attribute a]) -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (a, [Attribute a]) -> IO (a, [Attribute a])
forall a. IORef a -> IO a
readIORef IORef (a, [Attribute a])
attr

writeAttr :: MonadIO m => Attribute a -> a -> m ()
writeAttr :: Attribute a -> a -> m ()
writeAttr (Attribute IORef (a, [Attribute a])
attr) !a
x = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    (a
_ , [Attribute a]
z1) <- IORef (a, [Attribute a]) -> IO (a, [Attribute a])
forall a. IORef a -> IO a
readIORef IORef (a, [Attribute a])
attr
    IORef (a, [Attribute a]) -> (a, [Attribute a]) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (a, [Attribute a])
attr (a
x, [Attribute a]
z1)
    [Attribute a] -> (Attribute a -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Attribute a]
z1 ((Attribute a -> IO ()) -> IO ())
-> (Attribute a -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ (Attribute a -> a -> IO ()) -> a -> Attribute a -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Attribute a -> a -> IO ()
forall (m :: * -> *) a. MonadIO m => Attribute a -> a -> m ()
writeAttr a
x

modifyAttr :: MonadIO m => Attribute a -> (a -> a) -> m ()
modifyAttr :: Attribute a -> (a -> a) -> m ()
modifyAttr Attribute a
attr a -> a
f           = Attribute a -> m a
forall (m :: * -> *) a. MonadIO m => Attribute a -> m a
readAttr Attribute a
attr m a -> (a -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
x -> Attribute a -> a -> m ()
forall (m :: * -> *) a. MonadIO m => Attribute a -> a -> m ()
writeAttr Attribute a
attr (a -> a
f a
x)

connectAttrTo :: MonadIO m => Attribute a -> Attribute a -> m ()
connectAttrTo :: Attribute a -> Attribute a -> m ()
connectAttrTo (Attribute IORef (a, [Attribute a])
from) Attribute a
to = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef (a, [Attribute a])
-> ((a, [Attribute a]) -> (a, [Attribute a])) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (a, [Attribute a])
from (((a, [Attribute a]) -> (a, [Attribute a])) -> IO ())
-> ((a, [Attribute a]) -> (a, [Attribute a])) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(a
x, [Attribute a]
z) -> (a
x, Attribute a
toAttribute a -> [Attribute a] -> [Attribute a]
forall a. a -> [a] -> [a]
:[Attribute a]
z)

{-
data Attribute a = Attribute { _get :: IO a, _set :: a -> IO () }

attributeNew :: MonadIO m => a -> m (Attribute a)
attributeNew !x = do
    ref <- liftIO $ newIORef x
    return Attribute {
        _get = liftIO $ readIORef ref,
        _set = liftIO . writeIORef ref
    }

attributeNewOverride :: IO a -> (a -> IO ()) -> Attribute a
attributeNewOverride getter setter =
    Attribute {
        _get = getter,
        _set = setter
    }

get :: MonadIO m => s -> (s -> Attribute a) -> m a
get obj getAttr = liftIO $ _get (getAttr obj)

set :: MonadIO m => s -> (s -> Attribute a) -> a -> m ()
set obj getAttr !x = liftIO $ _set (getAttr obj) x

modify :: MonadIO m => s -> (s -> Attribute a) -> (a -> a) -> m ()
modify obj getAttr f = liftIO $ do
    x <- _get (getAttr obj)
    _set (getAttr obj) (f x)
-}