module Graphics.UI.Threepenny.Editors.Types
(
Editor(..)
, edited
, contents
, editorElement
, EditorFactory(.., Horizontally, horizontally, Vertically, vertically)
, dimapEF
, lmapEF
, applyEF
, createEditor
, renderEditor
, 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 Editor editorElement a = Editor
{ _editorTidings :: Tidings a
, _editorElement :: editorElement
}
deriving Functor
instance Bifunctor Editor where
bimap f g (Editor t e) = Editor (g <$> t) (f e)
editorElement :: Lens (Editor el a) (Editor el' a) el el'
editorElement f (Editor t el) = Editor t <$> f el
edited :: Editor el a -> Event a
edited = rumors . _editorTidings
contents :: Editor el a -> Behavior a
contents = facts . _editorTidings
instance Widget el => Widget (Editor el a) where
getElement = getElement . _editorElement
renderEditor :: Renderable w => Editor w a -> UI (Editor Element a)
renderEditor = mapMOf editorElement render
where
mapMOf l cmd = unwrapMonad . l (WrapMonad . cmd)
createEditor :: Renderable w => EditorFactory a w b -> Behavior a -> UI (Editor Element b)
createEditor e b = runEF e b >>= renderEditor
newtype EditorFactory a el b = EF {runEF :: Behavior a -> UI (Editor el b)}
_EditorFactory :: Iso (EditorFactory a el b) (EditorFactory a' el' b') (Behavior a -> UI (Editor el b)) (Behavior a' -> UI (Editor el' b'))
_EditorFactory = iso runEF EF
editorFactoryElement :: Setter (EditorFactory a el b) (EditorFactory a el' b) el el'
editorFactoryElement = _EditorFactory.mapped.mapped.editorElement
editorFactoryInput :: Setter (EditorFactory a el b) (EditorFactory a' el b) a' a
editorFactoryInput = _EditorFactory.argument.mapped
editorFactoryOutput :: Setter (EditorFactory a el b) (EditorFactory a el b') b b'
editorFactoryOutput = _EditorFactory.mapped.mapped.mapped
liftElement :: UI el -> EditorFactory a el ()
liftElement el = EF $ \_ -> Editor (pure ()) <$> el
bimapEF :: (el -> el') -> (b -> b') -> EditorFactory a el b -> EditorFactory a el' b'
bimapEF g h = EF . fmap (fmap (bimap g h)) . runEF
dimapEF :: (a' -> a) -> (b -> b') -> EditorFactory a el b -> EditorFactory a' el b'
dimapEF g h (EF f) = EF $ \b -> getCompose $ h <$> Compose (f (g <$> b))
lmapEF :: (a' -> a) -> EditorFactory a el b -> EditorFactory a' el b
lmapEF f = dimapEF f id
edit :: (a' -> a) -> EditorFactory a el b -> EditorFactory a' el b
edit = lmapEF
applyEF :: (el1 -> el2 -> el) -> EditorFactory in_ el1 (a -> b) -> EditorFactory in_ el2 a -> EditorFactory in_ el b
applyEF combineElements a b = EF $ \s -> do
a <- runEF a s
b <- runEF b s
return $ Editor (_editorTidings a <*> _editorTidings b) (_editorElement a `combineElements` _editorElement b)
instance Functor (EditorFactory a el) where
fmap = dimapEF id
instance Bifunctor (EditorFactory a) where
bimap = bimapEF
instance Biapplicative (EditorFactory a) where
bipure w o = EF $ \_ -> return $ Editor (pure o) w
(<<*>>) = applyEF ($)
instance Monoid el => Applicative (EditorFactory a el) where
pure = bipure mempty
(<*>) = applyEF mappend
pattern Vertically :: EditorFactory a Layout b -> EditorFactory a Vertical b
pattern Vertically {vertically} <- (withLayout getVertical -> vertically) where Vertically a = withLayout Vertical a
pattern Horizontally :: EditorFactory a Layout b -> EditorFactory a Horizontal b
pattern Horizontally {horizontally} <- (withLayout getHorizontal -> horizontally) where Horizontally a = withLayout Horizontal a
infixl 4 |*|, -*-
infixl 5 |*, *|, -*, *-
withLayout :: (layout -> layout') -> EditorFactory a layout b -> EditorFactory a layout' b
withLayout = over editorFactoryElement
construct :: Renderable m => EditorFactory a m b -> EditorFactory a Layout b
construct = withLayout getLayout
(|*|) :: EditorFactory s Layout (b -> a) -> EditorFactory s Layout b -> EditorFactory s Layout a
a |*| b = withLayout getHorizontal $ withLayout Horizontal a <*> withLayout Horizontal b
(*|) :: UI Element -> EditorFactory s Layout a -> EditorFactory s Layout a
e *| a = withLayout getHorizontal $ liftElement(return $ horizontal e) *> withLayout Horizontal a
(|*) :: EditorFactory s Layout a -> UI Element -> EditorFactory s Layout a
a |* e = withLayout getHorizontal $ withLayout Horizontal a <* liftElement(return $ horizontal e)
(-*-) :: EditorFactory s Layout (b -> a) -> EditorFactory s Layout b -> EditorFactory s Layout a
a -*- b = withLayout getVertical $ withLayout Vertical a <*> withLayout Vertical b
(*-) :: UI Element -> EditorFactory s Layout a -> EditorFactory s Layout a
e *- a = withLayout getVertical $ liftElement(return $ vertical e) *> withLayout Vertical a
(-*) :: EditorFactory s Layout a -> UI Element -> EditorFactory s Layout a
a -* e = withLayout getVertical $ withLayout Vertical a <* liftElement(return $ vertical e)
fieldLayout :: (Renderable m, Renderable m') => (Layout -> m') -> String -> (out -> inn) -> EditorFactory inn m a -> EditorFactory out m' a
fieldLayout l name f e = withLayout l (string name *| first getLayout (dimapEF f id e))
field :: Renderable m => String -> (out -> inn) -> EditorFactory inn m a -> EditorFactory out Layout a
field name f e = string name *| first getLayout (dimapEF f id e)
editorUnit :: EditorFactory b Element b
editorUnit = EF $ \b -> do
t <- new
return $ Editor (tidings b never) t
editorCheckBox :: EditorFactory Bool Element Bool
editorCheckBox = EF $ \b -> do
t <- sink checked b $ input # set type_ "checkbox"
return $ Editor (tidings b $ checkedChange t) t
editorString :: EditorFactory String TextEntry String
editorString = EF $ \b -> do
w <- askWindow
t <- entry b
liftIOLater $ do
initialValue <- currentValue b
_ <- runUI w $ set value initialValue (element t)
return ()
return $ Editor (userText t) t
editorReadShow :: (Read a, Show a) => EditorFactory (Maybe a) TextEntry (Maybe a)
editorReadShow = EF $ \b -> do
e <- runEF editorString (maybe "" show <$> b)
let readIt "" = Nothing
readIt x = readMaybe x
let t = tidings b (readIt <$> edited e)
return $ Editor t (_editorElement e)
editorEnumBounded
:: (Bounded a, Enum a, Ord a, Show a)
=> Behavior(a -> UI Element) -> EditorFactory (Maybe a) (ListBox a) (Maybe a)
editorEnumBounded = editorSelection (pure $ enumFrom minBound)
editorSelection
:: Ord a
=> Behavior [a] -> Behavior(a -> UI Element) -> EditorFactory (Maybe a) (ListBox a) (Maybe a)
editorSelection options display = EF $ \b -> do
l <- listBox options b display
return $ Editor (tidings b (rumors $ userSelection l)) l
editorJust :: EditorFactory (Maybe b) el (Maybe b) -> EditorFactory b el b
editorJust (EF editor) = EF $ \b -> do
e <- editor (Just <$> b)
let ev = filterJust (edited e)
return $ Editor (tidings b ev) (_editorElement e)
editorSum
:: (Ord tag, Show tag, Renderable el)
=> (Layout -> Layout -> Layout) -> [(tag, EditorFactory a el a)] -> (a -> tag) -> EditorFactory a Layout a
editorSum combineLayout options selector = EF $ \ba -> do
options <- mapM (\(tag, EF 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") _editorElement (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 $ Editor (tidings ba editedE) composed
editorIdentity :: EditorFactory a el a -> EditorFactory (Identity a) el (Identity a)
editorIdentity = dimapEF runIdentity Identity