module Graphics.UI.Threepenny.Editors.Base
(
Editor(..)
, edited
, contents
, Editable(..)
, (|*|), (|*), (*|)
, (-*-), (-*), (*-)
, editorReadShow
, editorEnumBounded
, editorSum
, editorJust
, Compose(..)
)where
import Data.Functor.Compose
import Graphics.UI.Threepenny.Attributes
import Graphics.UI.Threepenny.Core
import Graphics.UI.Threepenny.Elements
import Graphics.UI.Threepenny.Events
import Graphics.UI.Threepenny.Widgets
import Text.Read
data Editor a = Editor
{ editorTidings :: Tidings a
, editorElement :: Element
}
deriving Functor
instance Widget (Editor a) where
getElement = editorElement
class Editable a where
editor :: Behavior a -> Compose UI Editor a
edited :: Editor a -> Event a
edited = rumors . editorTidings
contents :: Editor a -> Behavior a
contents = facts . editorTidings
infixl 4 |*|, -*-
infixl 5 |*, *|, -*, *-
(|*|) :: Compose UI Editor (b -> a) -> Compose UI Editor b -> Compose UI Editor a
a |*| b = Compose $ do
a <- getCompose a
b <- getCompose b
ab <- row [return $ getElement a, return $ getElement b]
return $ Editor (editorTidings a <*> editorTidings b) ab
(*|) :: UI Element -> Compose UI Editor a -> Compose UI Editor a
e *| a = Compose $ do
e <- e
a <- getCompose a
ea <- row [return e, return $ getElement a]
return $ Editor (editorTidings a) ea
(|*) :: Compose UI Editor a -> UI Element -> Compose UI Editor a
a |* e = Compose $ do
e <- e
a <- getCompose a
ea <- row [
return $ getElement a, return e]
return $ Editor (editorTidings a) ea
(-*-) :: Compose UI Editor (b -> a) -> Compose UI Editor b -> Compose UI Editor a
a -*- b = Compose $ do
a <- getCompose a
b <- getCompose b
ab <- column [return $ getElement a, return $ getElement b]
return $ Editor (editorTidings a <*> editorTidings b) ab
(*-) :: UI Element -> Compose UI Editor a -> Compose UI Editor a
e *- a = Compose $ do
e <- e
a <- getCompose a
ea <- column [return e, return $ getElement a]
return $ Editor (editorTidings a) ea
(-*) :: Compose UI Editor a -> UI Element -> Compose UI Editor a
a -* e = Compose $ do
e <- e
a <- getCompose a
ea <- column [return $ getElement a, return e]
return $ Editor (editorTidings a) ea
editorReadShow :: (Read a, Show a) => Behavior (Maybe a) -> Compose UI Editor (Maybe a)
editorReadShow b = Compose $ do
e <- getCompose $ editor (maybe "" show <$> b)
let readIt "" = Nothing
readIt x = readMaybe x
let t = tidings b (readIt <$> edited e)
return $ Editor t (getElement e)
editorEnumBounded
:: (Bounded a, Enum a, Ord a, Show a)
=> Behavior(a -> UI Element) -> Behavior (Maybe a) -> Compose UI Editor (Maybe a)
editorEnumBounded display b = Compose $ do
l <- listBox (pure $ enumFrom minBound) b display
return $ Editor (tidings b (rumors $ userSelection l)) (getElement l)
editorJust :: (Behavior (Maybe b) -> Compose UI Editor (Maybe b))
-> Behavior b
-> Compose UI Editor b
editorJust editor b = Compose $ do
e <- getCompose $ editor (Just <$> b)
let ev = filterJust (edited e)
return $ Editor (tidings b ev) (editorElement e)
data SumWrapper tag a = A {display :: tag, theEditor :: Editor a}
instance Eq tag => Eq (SumWrapper tag a) where A a _ == A b _ = a == b
instance Ord tag => Ord (SumWrapper tag a) where compare (A a _) (A b _) = compare a b
instance Show tag => Show (SumWrapper tag a) where show = show . display
editorSum
:: (Ord tag, Show tag)
=> [(tag, Compose UI Editor a)] -> (a -> tag) -> Behavior a -> Compose UI Editor a
editorSum options selector ba = Compose $ do
w <- askWindow
options <- traverse (\(tag, Compose mk) -> (tag,) <$> mk) options
let bSelected =
let build a =
let tag = selector a
in A tag <$> lookup tag options
in build <$> ba
l <-
listBox (pure $ fmap (uncurry A) options) bSelected (pure (string . show))
nestedEditor <- new
_ <-
liftIO $
register (filterJust $ rumors (userSelection l)) $ \x ->
runUI w $ set' children [getElement $ theEditor x] nestedEditor
composed <- column [element l, widget nestedEditor]
let editedEvents = fmap (edited . snd) options
eTag = filterJust $ fmap display <$> rumors (userSelection l)
taggedOptions = sequenceA [(tag, ) <$> contents e | (tag, e) <- options]
editedTag = filterJust $ flip lookup <$> taggedOptions <@> eTag
editedE = head <$> unions (editedTag : editedEvents)
return $ Editor (tidings ba editedE) composed
instance Editable () where
editor b = Compose $ do
t <- new
return $ Editor (tidings b never) (getElement t)
instance a ~ Char => Editable [a] where
editor b = Compose $ do
w <- askWindow
t <- entry b
liftIOLater $ do
initialValue <- currentValue b
_ <- runUI w $ set value initialValue (element t)
return ()
return $ Editor (userText t) (getElement t)
instance Editable Bool where
editor b = Compose $ do
t <- sink checked b $ input # set type_ "checkbox"
return $ Editor (tidings b $ checkedChange t) t
instance Editable (Maybe Int) where editor = editorReadShow
instance Editable (Maybe Double) where editor = editorReadShow
instance Editable Int where editor = editorJust editor
instance Editable Double where editor = editorJust editor
instance (Editable a, Editable b) => Editable (a,b) where
editor b = (,) <$> editor (fst <$> b) |*| editor (snd <$> b)