module Graphics.UI.Threepenny.Editors.Base
(
Editor(..)
, edited
, contents
, Editable(..)
, EditorDef(..)
, runEditorDef
, Layout(Grid, Single)
, horizontal
, vertical
, (|*|), (|*), (*|)
, (-*-), (-*), (*-)
, editorReadShow
, editorEnumBounded
, editorSelection
, editorSum
, editorJust
, Compose(..)
)where
import Data.Foldable (length)
import Data.Functor.Compose
import Data.Maybe
import Data.Monoid
import Data.Sequence (Seq, viewl, ViewL(..))
import qualified Data.Sequence as Seq
import GHC.Exts (IsList(..))
import Graphics.UI.Threepenny.Attributes
import Graphics.UI.Threepenny.Core as UI
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
edited :: Editor a -> Event a
edited = rumors . editorTidings
contents :: Editor a -> Behavior a
contents = facts . editorTidings
instance Widget (Editor a) where
getElement = editorElement
newtype Layout
= Grid (Seq (Seq (Maybe Element)))
pattern Single :: Element -> Layout
pattern Single x <- Grid (Singleton (Singleton (Just x))) where Single x = Grid [[Just x]]
pattern Singleton :: a -> Seq a
pattern Singleton x <- (viewl -> x :< (viewl -> EmptyL)) where Singleton x = [x]
vertical, horizontal :: Layout -> Layout -> Layout
vertical (Grid rows@(length.head.toList -> l1)) (Grid rows'@(length.head.toList -> l2)) =
Grid $ fmap pad1 rows <> fmap pad2 rows'
where
pad l1 l2 | l1 >= l2 = id
| otherwise = (<> Seq.replicate (l2l1) Nothing)
pad1 = pad l1 l2
pad2 = pad l2 l1
horizontal (Grid rows@(length -> l1)) (Grid rows'@(length -> l2)) =
Grid $ Seq.zipWith (<>) (pad1 rows) (pad2 rows')
where
pad l1 l2
| l1 >= l2 = id
| otherwise = \x ->
let padding = Seq.replicate (length $ head $ toList x) Nothing
in x <> Seq.replicate (l2 l1) padding
pad1 = pad l1 l2
pad2 = pad l2 l1
runLayout :: Layout -> UI Element
runLayout (Grid rows) = grid (toList $ fmap (fmap (maybe new return). toList) rows)
data EditorDef a = EditorDef
{ editorDefTidings :: Tidings a
, editorDefLayout :: Layout
}
deriving Functor
editedDef :: EditorDef a -> Event a
editedDef = rumors . editorDefTidings
runEditorDef :: EditorDef a -> UI (Editor a)
runEditorDef def = do
el <- runLayout (editorDefLayout def)
return $ Editor (editorDefTidings def) el
class Editable a where
editor :: Behavior a -> Compose UI EditorDef a
infixl 4 |*|, -*-
infixl 5 |*, *|, -*, *-
(|*|) :: Compose UI EditorDef (b -> a) -> Compose UI EditorDef b -> Compose UI EditorDef a
a |*| b = Compose $ do
a <- getCompose a
b <- getCompose b
let ab = horizontal (editorDefLayout a) (editorDefLayout b)
return $ EditorDef (editorDefTidings a <*> editorDefTidings b) ab
(*|) :: UI Element -> Compose UI EditorDef a -> Compose UI EditorDef a
e *| a = Compose $ do
e <- e
a <- getCompose a
let ea = horizontal (Single e) (editorDefLayout a)
return $ EditorDef (editorDefTidings a) ea
(|*) :: Compose UI EditorDef a -> UI Element -> Compose UI EditorDef a
a |* e = Compose $ do
e <- e
a <- getCompose a
let ea = horizontal (editorDefLayout a) (Single e)
return $ EditorDef (editorDefTidings a) ea
(-*-) :: Compose UI EditorDef (b -> a) -> Compose UI EditorDef b -> Compose UI EditorDef a
a -*- b = Compose $ do
a <- getCompose a
b <- getCompose b
let ab = vertical (editorDefLayout a) (editorDefLayout b)
return $ EditorDef (editorDefTidings a <*> editorDefTidings b) ab
(*-) :: UI Element -> Compose UI EditorDef a -> Compose UI EditorDef a
e *- a = Compose $ do
e <- e
a <- getCompose a
let ea = vertical (Single e) (editorDefLayout a)
return $ EditorDef (editorDefTidings a) ea
(-*) :: Compose UI EditorDef a -> UI Element -> Compose UI EditorDef a
a -* e = Compose $ do
e <- e
a <- getCompose a
let ea = vertical (editorDefLayout a) (Single e)
return $ EditorDef (editorDefTidings a) ea
editorReadShow :: (Read a, Show a) => Behavior (Maybe a) -> Compose UI EditorDef (Maybe a)
editorReadShow b = Compose $ do
e <- getCompose $ editor (maybe "" show <$> b)
let readIt "" = Nothing
readIt x = readMaybe x
let t = tidings b (readIt <$> editedDef e)
return $ EditorDef t (editorDefLayout e)
editorEnumBounded
:: (Bounded a, Enum a, Ord a, Show a)
=> Behavior(a -> UI Element) -> Behavior (Maybe a) -> Compose UI EditorDef (Maybe a)
editorEnumBounded = editorSelection (pure $ enumFrom minBound)
editorSelection
:: Ord a
=> Behavior [a] -> Behavior(a -> UI Element) -> Behavior (Maybe a) -> Compose UI EditorDef (Maybe a)
editorSelection options display b = Compose $ do
l <- listBox options b display
return $ EditorDef (tidings b (rumors $ userSelection l)) (Single $ getElement l)
editorJust :: (Behavior (Maybe b) -> Compose UI EditorDef (Maybe b))
-> Behavior b
-> Compose UI EditorDef b
editorJust editor b = Compose $ do
e <- getCompose $ editor (Just <$> b)
let ev = filterJust (editedDef e)
return $ EditorDef (tidings b ev) (editorDefLayout e)
editorSum
:: (Ord tag, Show tag)
=> (Layout -> Layout -> Layout) -> [(tag, Compose UI EditorDef a)] -> (a -> tag) -> Behavior a -> Compose UI EditorDef a
editorSum combineLayout options selector ba = Compose $ do
options <- mapM (\(tag, Compose mk) -> (tag,) <$> (mk >>= runEditorDef)) 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))
nestedEditorDef <-
new # sink children ((\x -> [maybe (error "editorSum") editorElement (build x)]) <$> tag')
let composed = combineLayout (Single (getElement l)) (Single nestedEditorDef)
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 $ EditorDef (tidings ba editedE) composed
calmB :: Eq a => Behavior a -> UI (Behavior a)
calmB b = do
w <- askWindow
(e, trigger) <- liftIO newEvent
liftIOLater $ do
current <- currentValue b
trigger current
runUI w $ onChanges b (liftIO . trigger)
eCalm <- calmE e
fmap (fromMaybe (error "calmB")) <$> stepper Nothing (Just <$> eCalm)
data Memory a = Empty | New a | Same a
updateMemory :: Eq a => a -> Memory a -> Memory a
updateMemory x Empty = New x
updateMemory x (New a) | a /= x = New x
updateMemory x (Same a) | a /= x = New x
updateMemory x _ = Same x
isNew :: Memory a -> Maybe a
isNew (New x) = Just x
isNew _ = Nothing
calmE :: Eq a => Event a -> UI (Event a)
calmE e =
filterJust . fmap isNew <$> accumE Empty (updateMemory <$> e)
instance Editable () where
editor b = Compose $ do
t <- new
return $ EditorDef (tidings b never) (Single 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 $ EditorDef (userText t) (Single $ getElement t)
instance Editable Bool where
editor b = Compose $ do
t <- sink checked b $ input # set type_ "checkbox"
return $ EditorDef (tidings b $ checkedChange t) (Single 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)