module Graphics.UI.Threepenny.Editors
(
Editor(..)
, edited
, contents
, (|*|), (|*), (*|)
, (-*-), (-*), (*-)
, editorReadShow
, editorEnumBounded
, withDefault
)where
import Data.Maybe
import Data.Profunctor
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
newtype EditorFactory a b = EditorFactory { run :: Behavior a -> UI (Editor b) }
instance Profunctor EditorFactory where
dimap g h (EditorFactory f) = EditorFactory $ \b -> fmap h <$> f (g <$> b)
class Editable a where
editor :: Behavior a -> UI (Editor a)
edited :: Editor a -> Event a
edited = rumors . editorTidings
contents :: Editor a -> Behavior a
contents = facts . editorTidings
infixl 4 |*|, -*-
infixl 5 |*, *|, -*, *-
(|*|) :: UI(Editor (b -> a)) -> UI(Editor b) -> UI(Editor a)
a |*| b = do
a <- a
b <- b
ab <- row [return $ getElement a, return $ getElement b]
return $ Editor (editorTidings a <*> editorTidings b) ab
(*|) :: UI Element -> UI (Editor a) -> UI (Editor a)
e *| a = do
e <- e
a <- a
ea <- row [return e, return $ getElement a]
return $ Editor (editorTidings a) ea
(|*) :: UI (Editor a) -> UI Element -> UI (Editor a)
a |* e = do
e <- e
a <- a
ea <- row [return $ getElement a, return e]
return $ Editor (editorTidings a) ea
(-*-) :: UI(Editor (b -> a)) -> UI(Editor b) -> UI(Editor a)
a -*- b = do
a <- a
b <- b
ab <- column [return $ getElement a, return $ getElement b]
return $ Editor (editorTidings a <*> editorTidings b) ab
(*-) :: UI Element -> UI (Editor a) -> UI (Editor a)
e *- a = do
e <- e
a <- a
ea <- column [return e, return $ getElement a]
return $ Editor (editorTidings a) ea
(-*) :: UI (Editor a) -> UI Element -> UI (Editor a)
a -* e = do
e <- e
a <- a
ea <- column [return $ getElement a, return e]
return $ Editor (editorTidings a) ea
editorReadShow :: (Read a, Show a) => Behavior (Maybe a) -> UI (Editor (Maybe a))
editorReadShow b =
do
e <- editor (show <$> b)
let t = tidings b (filterJust $ readMaybe <$> edited e)
return $ Editor t (getElement e)
editorEnumBounded
:: (Bounded a, Enum a, Ord a, Show a)
=> Behavior(a -> UI Element) -> Behavior (Maybe a) -> UI (Editor (Maybe a))
editorEnumBounded display b = do
l <- listBox (pure $ enumFrom minBound) b display
return $ Editor (userSelection l) (getElement l)
withDefault
:: EditorFactory (Maybe a) (Maybe b)
-> b
-> EditorFactory a b
withDefault editor def = dimap Just (fromMaybe def) editor
data SumWrapper tag a = A {display :: tag, factory :: 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, Editor a)] -> (a -> tag) -> Behavior a -> UI (Editor a)
editorSum options selector ba = mdo
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))
let nestedEditor = factory . fromMaybe (uncurry A $ head options) <$> bSelected
nestedElement <- sink children ((:[]) . getElement <$> nestedEditor) new
composed <- column [element l, widget nestedElement]
let joinE :: Event (Event a) -> UI(Event a)
joinE = undefined
event <- joinE (edited <$> nestedEditor <@ rumors (userSelection l))
return $ Editor (tidings ba event) composed
instance Editable () where
editor b = do
t <- new
return $ Editor (tidings b never) (getElement t)
instance a ~ Char => Editable [a] where
editor b = do
t <- entry b
return $ Editor (userText t) (getElement t)
instance Editable Int where
editor = run $ EditorFactory editor `withDefault` 0
instance Editable Double where
editor = run $ EditorFactory editor `withDefault` 0
instance Editable Bool where
editor b = 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