{-# LANGUAGE RecordWildCards, ScopedTypeVariables #-}
module Graphics.UI.Threepenny.Widgets (
    -- * Synopsis
    -- | Widgets are reusable building blocks for a graphical user interface.
    -- This module collects useful widgets that are designed to work
    -- with functional reactive programming (FRP).
    -- 
    -- For more details and information on how to write your own widgets, see the
    -- <https://github.com/HeinrichApfelmus/threepenny-gui/blob/master/doc/design-widgets.md widget design guide>.
    
    -- * Tidings
    Tidings, rumors, facts, tidings,
    -- * Widgets
    -- ** Input widgets
    TextEntry, entry, userText,
    -- ** ListBox
    ListBox, listBox, userSelection,
    ) where

import Control.Monad (void, when)
import qualified Data.Map                          as Map

import qualified Graphics.UI.Threepenny.Attributes as UI
import qualified Graphics.UI.Threepenny.Events     as UI
import qualified Graphics.UI.Threepenny.Elements   as UI
import Graphics.UI.Threepenny.Core
import Reactive.Threepenny

{-----------------------------------------------------------------------------
    Input widgets
------------------------------------------------------------------------------}
-- | A single-line text entry.
data TextEntry = TextEntry
    { TextEntry -> Element
_elementTE :: Element
    , TextEntry -> Tidings String
_userTE    :: Tidings String
    }

instance Widget TextEntry where getElement :: TextEntry -> Element
getElement = TextEntry -> Element
_elementTE

-- | User changes to the text value.
userText :: TextEntry -> Tidings String
userText :: TextEntry -> Tidings String
userText = TextEntry -> Tidings String
_userTE

-- | Create a single-line text entry.
entry
    :: Behavior String  -- ^ Display value when the element does not have focus.
    -> UI TextEntry
entry :: Behavior String -> UI TextEntry
entry Behavior String
bValue = do -- single text entry
    Element
input <- UI Element
UI.input

    Behavior Bool
bEditing <- forall (m :: * -> *) a. MonadIO m => a -> Event a -> m (Behavior a)
stepper Bool
False forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *). Foldable t => t Bool -> Bool
and forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        forall a. [Event a] -> Event [a]
unions [Bool
True forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Element -> Event ()
UI.focus Element
input, Bool
False forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Element -> Event ()
UI.blur Element
input]
    
    Window
window <- UI Window
askWindow
    IO () -> UI ()
liftIOLater forall a b. (a -> b) -> a -> b
$ forall a. Behavior a -> Handler a -> IO ()
onChange Behavior String
bValue forall a b. (a -> b) -> a -> b
$ \String
s -> forall a. Window -> UI a -> IO a
runUI Window
window forall a b. (a -> b) -> a -> b
$ do
        Bool
editing <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => Behavior a -> m a
currentValue Behavior Bool
bEditing
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
editing) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) w. (MonadIO m, Widget w) => w -> m Element
element Element
input forall a b. a -> (a -> b) -> b
# forall x i o. ReadWriteAttr x i o -> i -> UI x -> UI x
set Attr Element String
value String
s

    let _elementTE :: Element
_elementTE = Element
input
        _userTE :: Tidings String
_userTE    = forall a. Behavior a -> Event a -> Tidings a
tidings Behavior String
bValue forall a b. (a -> b) -> a -> b
$ Element -> Event String
UI.valueChange Element
input 
    forall (m :: * -> *) a. Monad m => a -> m a
return TextEntry {Tidings String
Element
_userTE :: Tidings String
_elementTE :: Element
_userTE :: Tidings String
_elementTE :: Element
..}

{-----------------------------------------------------------------------------
    List box
------------------------------------------------------------------------------}
-- | A list of values. The user can select entries.
data ListBox a = ListBox
    { forall a. ListBox a -> Element
_elementLB   :: Element
    , forall a. ListBox a -> Tidings (Maybe a)
_selectionLB :: Tidings (Maybe a)
    }

instance Widget (ListBox a) where getElement :: ListBox a -> Element
getElement = forall a. ListBox a -> Element
_elementLB

-- | User changes to the current selection (possibly empty).
userSelection :: ListBox a -> Tidings (Maybe a)
userSelection :: forall a. ListBox a -> Tidings (Maybe a)
userSelection = forall a. ListBox a -> Tidings (Maybe a)
_selectionLB

-- | Create a 'ListBox'.
listBox :: forall a. Ord a
    => Behavior [a]               -- ^ list of items
    -> Behavior (Maybe a)         -- ^ selected item
    -> Behavior (a -> UI Element) -- ^ display for an item
    -> UI (ListBox a)
listBox :: forall a.
Ord a =>
Behavior [a]
-> Behavior (Maybe a)
-> Behavior (a -> UI Element)
-> UI (ListBox a)
listBox Behavior [a]
bitems Behavior (Maybe a)
bsel Behavior (a -> UI Element)
bdisplay = do
    Element
list <- UI Element
UI.select

    -- animate output items
    forall (m :: * -> *) w. (MonadIO m, Widget w) => w -> m Element
element Element
list forall a b. a -> (a -> b) -> b
# forall x i o. ReadWriteAttr x i o -> Behavior i -> UI x -> UI x
sink WriteAttr Element [UI Element]
items (forall a b. (a -> b) -> [a] -> [b]
map forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Behavior (a -> UI Element)
bdisplay forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Behavior [a]
bitems)

    -- animate output selection
    let bindices :: Behavior (Map.Map a Int)
        bindices :: Behavior (Map a Int)
bindices = (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Behavior [a]
bitems
        bindex :: Behavior (Maybe Int)
bindex   = forall {k} {a}. Ord k => Map k a -> Maybe k -> Maybe a
lookupIndex forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Behavior (Map a Int)
bindices forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Behavior (Maybe a)
bsel

        lookupIndex :: Map k a -> Maybe k -> Maybe a
lookupIndex Map k a
indices Maybe k
Nothing    = forall a. Maybe a
Nothing
        lookupIndex Map k a
indices (Just k
sel) = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
sel Map k a
indices

    forall (m :: * -> *) w. (MonadIO m, Widget w) => w -> m Element
element Element
list forall a b. a -> (a -> b) -> b
# forall x i o. ReadWriteAttr x i o -> Behavior i -> UI x -> UI x
sink Attr Element (Maybe Int)
UI.selection Behavior (Maybe Int)
bindex

    -- changing the display won't change the current selection
    -- eDisplay <- changes display
    -- sink listBox [ selection :== stepper (-1) $ bSelection <@ eDisplay ]

    -- user selection
    let bindices2 :: Behavior (Map.Map Int a)
        bindices2 :: Behavior (Map Int a)
bindices2 = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Behavior [a]
bitems

        _selectionLB :: Tidings (Maybe a)
_selectionLB = forall a. Behavior a -> Event a -> Tidings a
tidings Behavior (Maybe a)
bsel forall a b. (a -> b) -> a -> b
$
            forall {k} {a}. Ord k => Map k a -> Maybe k -> Maybe a
lookupIndex forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Behavior (Map Int a)
bindices2 forall a b. Behavior (a -> b) -> Event a -> Event b
<@> Element -> Event (Maybe Int)
UI.selectionChange Element
list
        _elementLB :: Element
_elementLB   = Element
list

    forall (m :: * -> *) a. Monad m => a -> m a
return ListBox {Tidings (Maybe a)
Element
_elementLB :: Element
_selectionLB :: Tidings (Maybe a)
_selectionLB :: Tidings (Maybe a)
_elementLB :: Element
..}

items :: WriteAttr Element [UI Element]
items = forall i x. (i -> x -> UI ()) -> WriteAttr x i
mkWriteAttr forall a b. (a -> b) -> a -> b
$ \[UI Element]
i Element
x -> forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ do
    forall (m :: * -> *) a. Monad m => a -> m a
return Element
x forall a b. a -> (a -> b) -> b
# forall x i o. ReadWriteAttr x i o -> i -> UI x -> UI x
set WriteAttr Element [Element]
children [] UI Element -> [UI Element] -> UI Element
#+ forall a b. (a -> b) -> [a] -> [b]
map (\UI Element
i -> UI Element
UI.option UI Element -> [UI Element] -> UI Element
#+ [UI Element
i]) [UI Element]
i