{-# LANGUAGE RecordWildCards, ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wno-unused-do-bind #-}
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 <- Bool -> Event Bool -> UI (Behavior Bool)
forall (m :: * -> *) a. MonadIO m => a -> Event a -> m (Behavior a)
stepper Bool
False (Event Bool -> UI (Behavior Bool))
-> Event Bool -> UI (Behavior Bool)
forall a b. (a -> b) -> a -> b
$ [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> Event [Bool] -> Event Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        [Event Bool] -> Event [Bool]
forall a. [Event a] -> Event [a]
unions [Bool
True Bool -> Event () -> Event Bool
forall a b. a -> Event b -> Event a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Element -> Event ()
UI.focus Element
input, Bool
False Bool -> Event () -> Event Bool
forall a b. a -> Event b -> Event a
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 (IO () -> UI ()) -> IO () -> UI ()
forall a b. (a -> b) -> a -> b
$ Behavior String -> Handler String -> IO ()
forall a. Behavior a -> Handler a -> IO ()
onChange Behavior String
bValue (Handler String -> IO ()) -> Handler String -> IO ()
forall a b. (a -> b) -> a -> b
$ \String
s -> Window -> UI () -> IO ()
forall a. Window -> UI a -> IO a
runUI Window
window (UI () -> IO ()) -> UI () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Bool
editing <- IO Bool -> UI Bool
forall a. IO a -> UI a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> UI Bool) -> IO Bool -> UI Bool
forall a b. (a -> b) -> a -> b
$ Behavior Bool -> IO Bool
forall (m :: * -> *) a. MonadIO m => Behavior a -> m a
currentValue Behavior Bool
bEditing
        Bool -> UI () -> UI ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
editing) (UI () -> UI ()) -> UI () -> UI ()
forall a b. (a -> b) -> a -> b
$ UI Element -> UI ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (UI Element -> UI ()) -> UI Element -> UI ()
forall a b. (a -> b) -> a -> b
$ Element -> UI Element
forall (m :: * -> *) w. (MonadIO m, Widget w) => w -> m Element
element Element
input UI Element -> (UI Element -> UI Element) -> UI Element
forall a b. a -> (a -> b) -> b
# ReadWriteAttr Element String String
-> String -> UI Element -> UI Element
forall x i o. ReadWriteAttr x i o -> i -> UI x -> UI x
set ReadWriteAttr Element String String
value String
s

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

{-----------------------------------------------------------------------------
    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 = ListBox a -> Element
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 = ListBox a -> Tidings (Maybe a)
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
    Element -> UI Element
forall (m :: * -> *) w. (MonadIO m, Widget w) => w -> m Element
element Element
list UI Element -> (UI Element -> UI Element) -> UI Element
forall a b. a -> (a -> b) -> b
# ReadWriteAttr Element [UI Element] ()
-> Behavior [UI Element] -> UI Element -> UI Element
forall x i o. ReadWriteAttr x i o -> Behavior i -> UI x -> UI x
sink ReadWriteAttr Element [UI Element] ()
items ((a -> UI Element) -> [a] -> [UI Element]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> UI Element) -> [a] -> [UI Element])
-> Behavior (a -> UI Element) -> Behavior ([a] -> [UI Element])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Behavior (a -> UI Element)
bdisplay Behavior ([a] -> [UI Element])
-> Behavior [a] -> Behavior [UI Element]
forall a b. Behavior (a -> b) -> Behavior a -> Behavior b
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 = ([(a, Int)] -> Map a Int
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(a, Int)] -> Map a Int)
-> ([a] -> [(a, Int)]) -> [a] -> Map a Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([a] -> [Int] -> [(a, Int)]) -> [Int] -> [a] -> [(a, Int)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [a] -> [Int] -> [(a, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..]) ([a] -> Map a Int) -> Behavior [a] -> Behavior (Map a Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Behavior [a]
bitems
        bindex :: Behavior (Maybe Int)
bindex   = Map a Int -> Maybe a -> Maybe Int
forall {k} {a}. Ord k => Map k a -> Maybe k -> Maybe a
lookupIndex (Map a Int -> Maybe a -> Maybe Int)
-> Behavior (Map a Int) -> Behavior (Maybe a -> Maybe Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Behavior (Map a Int)
bindices Behavior (Maybe a -> Maybe Int)
-> Behavior (Maybe a) -> Behavior (Maybe Int)
forall a b. Behavior (a -> b) -> Behavior a -> Behavior b
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   = Maybe a
forall a. Maybe a
Nothing
        lookupIndex Map k a
indices (Just k
sel) = k -> Map k a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
sel Map k a
indices

    Element -> UI Element
forall (m :: * -> *) w. (MonadIO m, Widget w) => w -> m Element
element Element
list UI Element -> (UI Element -> UI Element) -> UI Element
forall a b. a -> (a -> b) -> b
# ReadWriteAttr Element (Maybe Int) (Maybe Int)
-> Behavior (Maybe Int) -> UI Element -> UI Element
forall x i o. ReadWriteAttr x i o -> Behavior i -> UI x -> UI x
sink ReadWriteAttr Element (Maybe Int) (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 = [(Int, a)] -> Map Int a
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Int, a)] -> Map Int a)
-> ([a] -> [(Int, a)]) -> [a] -> Map Int a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [a] -> [(Int, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] ([a] -> Map Int a) -> Behavior [a] -> Behavior (Map Int a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Behavior [a]
bitems

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

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