module Graphics.UI.Threepenny.Editors.Types
(
GenericWidget(..)
, edited
, contents
, widgetControl
, widgetTidings
, liftElement
, Editor(.., Horizontally, horizontally, Vertically, vertically)
, dimapE
, lmapE
, applyE
, editorFactoryElement
, editorFactoryInput
, editorFactoryOutput
, (|*|), (|*), (*|)
, (-*-), (-*), (*-)
, field
, fieldLayout
, edit
, pattern Horizontally
, pattern Vertically
, editorUnit
, editorIdentity
, editorString
, editorCheckBox
, editorReadShow
, editorEnumBounded
, editorSelection
, editorSum
, editorJust
, withLayout
, construct
) where
import Control.Applicative
import Control.Lens hiding (beside, children,
element, set, ( # ))
import Data.Biapplicative
import Data.Functor.Compose
import Graphics.UI.Threepenny.Attributes
import Graphics.UI.Threepenny.Core as UI
import Graphics.UI.Threepenny.Editors.Layout
import Graphics.UI.Threepenny.Editors.Utils
import Graphics.UI.Threepenny.Elements
import Graphics.UI.Threepenny.Events
import Graphics.UI.Threepenny.Widgets
import Text.Read
data GenericWidget control a = GenericWidget
{ _widgetTidings :: Tidings a
, _widgetControl :: control
}
deriving Functor
makeLenses ''GenericWidget
instance Bifunctor GenericWidget where
bimap f g (GenericWidget t e) = GenericWidget (g <$> t) (f e)
edited :: GenericWidget el a -> Event a
edited = rumors . _widgetTidings
contents :: GenericWidget el a -> Behavior a
contents = facts . _widgetTidings
instance Widget el => Widget (GenericWidget el a) where
getElement = getElement . _widgetControl
instance Renderable el => Renderable (GenericWidget el a) where
render = render . _widgetControl
renderEditor :: Renderable w => GenericWidget w a -> UI (GenericWidget Element a)
renderEditor = mapMOf widgetControl render
where
mapMOf l cmd = unwrapMonad . l (WrapMonad . cmd)
newtype Editor a el b = Editor {
create :: Behavior a -> UI (GenericWidget el b)
}
_Editor :: Iso (Editor a el b) (Editor a' el' b') (Behavior a -> UI (GenericWidget el b)) (Behavior a' -> UI (GenericWidget el' b'))
_Editor = iso create Editor
editorFactoryElement :: Setter (Editor a el b) (Editor a el' b) el el'
editorFactoryElement = _Editor.mapped.mapped.widgetControl
editorFactoryInput :: Setter (Editor a el b) (Editor a' el b) a' a
editorFactoryInput = _Editor.argument.mapped
editorFactoryOutput :: Setter (Editor a el b) (Editor a el b') b b'
editorFactoryOutput = _Editor.mapped.mapped.mapped
liftElement :: UI el -> Editor a el ()
liftElement el = Editor $ \_ -> GenericWidget (pure ()) <$> el
bimapEditor :: (el -> el') -> (b -> b') -> Editor a el b -> Editor a el' b'
bimapEditor g h = Editor . fmap (fmap (bimap g h)) . create
dimapE :: (a' -> a) -> (b -> b') -> Editor a el b -> Editor a' el b'
dimapE g h (Editor f) = Editor $ \b -> getCompose $ h <$> Compose (f (g <$> b))
lmapE :: (a' -> a) -> Editor a el b -> Editor a' el b
lmapE f = dimapE f id
edit :: (a' -> a) -> Editor a el b -> Editor a' el b
edit = lmapE
applyE :: (el1 -> el2 -> el) -> Editor in_ el1 (a -> b) -> Editor in_ el2 a -> Editor in_ el b
applyE combineElements a b = Editor $ \s -> do
a <- create a s
b <- create b s
return $ GenericWidget (_widgetTidings a <*> _widgetTidings b) (_widgetControl a `combineElements` _widgetControl b)
instance Functor (Editor a el) where
fmap = dimapE id
instance Bifunctor (Editor a) where
bimap = bimapEditor
instance Biapplicative (Editor a) where
bipure w o = Editor $ \_ -> return $ GenericWidget (pure o) w
(<<*>>) = applyE ($)
instance Monoid el => Applicative (Editor a el) where
pure = bipure mempty
(<*>) = applyE mappend
pattern Vertically :: Editor a Layout b -> Editor a Vertical b
pattern Vertically {vertically} <- (withLayout getVertical -> vertically) where Vertically a = withLayout Vertical a
pattern Horizontally :: Editor a Layout b -> Editor a Horizontal b
pattern Horizontally {horizontally} <- (withLayout getHorizontal -> horizontally) where Horizontally a = withLayout Horizontal a
infixl 4 |*|, -*-
infixl 5 |*, *|, -*, *-
withLayout :: (layout -> layout') -> Editor a layout b -> Editor a layout' b
withLayout = over editorFactoryElement
construct :: Renderable m => Editor a m b -> Editor a Layout b
construct = withLayout getLayout
(|*|) :: Editor s Layout (b -> a) -> Editor s Layout b -> Editor s Layout a
a |*| b = withLayout getHorizontal $ withLayout Horizontal a <*> withLayout Horizontal b
(*|) :: UI Element -> Editor s Layout a -> Editor s Layout a
e *| a = withLayout getHorizontal $ liftElement(return $ horizontal e) *> withLayout Horizontal a
(|*) :: Editor s Layout a -> UI Element -> Editor s Layout a
a |* e = withLayout getHorizontal $ withLayout Horizontal a <* liftElement(return $ horizontal e)
(-*-) :: Editor s Layout (b -> a) -> Editor s Layout b -> Editor s Layout a
a -*- b = withLayout getVertical $ withLayout Vertical a <*> withLayout Vertical b
(*-) :: UI Element -> Editor s Layout a -> Editor s Layout a
e *- a = withLayout getVertical $ liftElement(return $ vertical e) *> withLayout Vertical a
(-*) :: Editor s Layout a -> UI Element -> Editor s Layout a
a -* e = withLayout getVertical $ withLayout Vertical a <* liftElement(return $ vertical e)
fieldLayout :: (Renderable m, Renderable m') => (Layout -> m') -> String -> (out -> inn) -> Editor inn m a -> Editor out m' a
fieldLayout l name f e = withLayout l (string name *| first getLayout (dimapE f id e))
field :: Renderable m => String -> (out -> inn) -> Editor inn m a -> Editor out Layout a
field name f e = string name *| first getLayout (dimapE f id e)
editorUnit :: Editor b Element b
editorUnit = Editor $ \b -> do
t <- new
return $ GenericWidget (tidings b never) t
editorCheckBox :: Editor Bool Element Bool
editorCheckBox = Editor $ \b -> do
t <- sink checked b $ input # set type_ "checkbox"
return $ GenericWidget (tidings b $ checkedChange t) t
editorString :: Editor String TextEntry String
editorString = Editor $ \b -> do
w <- askWindow
t <- entry b
liftIOLater $ do
initialValue <- currentValue b
_ <- runUI w $ set value initialValue (element t)
return ()
return $ GenericWidget (userText t) t
editorReadShow :: (Read a, Show a) => Editor (Maybe a) TextEntry (Maybe a)
editorReadShow = Editor $ \b -> do
e <- create editorString (maybe "" show <$> b)
let readIt "" = Nothing
readIt x = readMaybe x
let t = tidings b (readIt <$> edited e)
return $ GenericWidget t (_widgetControl e)
editorEnumBounded
:: (Bounded a, Enum a, Ord a, Show a)
=> Behavior(a -> UI Element) -> Editor (Maybe a) (ListBox a) (Maybe a)
editorEnumBounded = editorSelection (pure $ enumFrom minBound)
editorSelection
:: Ord a
=> Behavior [a] -> Behavior(a -> UI Element) -> Editor (Maybe a) (ListBox a) (Maybe a)
editorSelection options display = Editor $ \b -> do
l <- listBox options b display
return $ GenericWidget (tidings b (rumors $ userSelection l)) l
editorJust :: Editor (Maybe b) el (Maybe b) -> Editor b el b
editorJust (Editor editor) = Editor $ \b -> do
e <- editor (Just <$> b)
let ev = filterJust (edited e)
return $ GenericWidget (tidings b ev) (_widgetControl e)
editorSum
:: (Ord tag, Show tag, Renderable el)
=> (Layout -> Layout -> Layout) -> [(tag, Editor a el a)] -> (a -> tag) -> Editor a Layout a
editorSum combineLayout options selector = Editor $ \ba -> do
options <- mapM (\(tag, Editor mk) -> (tag,) <$> (mk ba >>= renderEditor)) options
let tag = selector <$> ba
tag' <- calmB tag
let build a = lookup a options
l <- listBox (pure $ fmap fst options) (Just <$> tag) (pure (string . show))
nestedEditor <-
new # sink children ((\x -> [maybe (error "editorSum") _widgetControl (build x)]) <$> tag')
let composed = combineLayout (Single (return $ getElement l)) (Single $ return nestedEditor)
let editedEvents = fmap (edited . snd) options
eTag = filterJust $ rumors (userSelection l)
taggedOptions = sequenceA [(tag, ) <$> contents e | (tag, e) <- options]
editedTag = filterJust $ flip lookup <$> taggedOptions <@> eTag
editedE = head <$> unions (editedTag : editedEvents)
return $ GenericWidget (tidings ba editedE) composed
editorIdentity :: Editor a el a -> Editor (Identity a) el (Identity a)
editorIdentity = dimapE runIdentity Identity