{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}
{-# OPTIONS_GHC -Wno-duplicate-exports #-}
module Graphics.UI.Threepenny.Editors.Types
(
GenericWidget(..)
, edited
, contents
, widgetControl
, widgetTidings
, Editor(.., Horizontally, horizontally, Vertically, vertically)
, liftElement
, dimapE
, applyE
, (|*|), (|*), (*|)
, (-*-), (-*), (*-)
, field
, fieldLayout
, editorUnit
, editorIdentity
, editorString
, editorText
, editorCheckBox
, editorReadShow
, editorEnumBounded
, editorSelection
, editorSum
, editorJust
, EditorCollection(..)
, editorCollection
, editorList
, EditorCollectionConfig(..)
, defaultEditorCollectionConfig
, HasEmpty(..)
) where
import Control.Monad
import Data.Biapplicative
import Data.Maybe
import Data.HasEmpty
import qualified Data.Foldable as F
import Data.Functor.Compose
import Data.Functor.Identity
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Profunctor
import Data.Text (Text)
import qualified Data.Text as Text
import Graphics.UI.Threepenny.Attributes
import Graphics.UI.Threepenny.Core as UI hiding (empty)
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
instance Bifunctor GenericWidget where
bimap f g (GenericWidget t e) = GenericWidget (g <$> t) (f e)
traverseControl :: Applicative f => (control -> f control') -> GenericWidget control a -> f (GenericWidget control' a)
traverseControl f (GenericWidget t e) = GenericWidget 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 = traverseControl render
newtype Editor outer widget inner = Editor {
create :: Behavior outer -> UI (GenericWidget widget inner)
}
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 = unCoer . dimap (fmap g) h . coer
where
coer = Star . (Compose .) . create
unCoer = Editor . fmap getCompose . runStar
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 f = bimap f id
(|*|) :: 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
editorText :: Editor Text TextEntry Text
editorText = dimapE Text.unpack Text.pack editorString
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
data EditorCollection k w = EditorCollection
{ selector :: ListBox k
, add, remove :: Element
, selected :: w
}
instance Renderable w => Renderable (EditorCollection k w) where
render EditorCollection{..} =
column
[row [ element selector, element add, element remove]
,render selected]
data EditorCollectionConfig k v = EditorCollectionConfig
{ eccNewKey :: Behavior k
, eccAfterDelKey :: Behavior (Maybe k)
, eccTemplate :: v
, eccOptions :: Behavior (Set k)
, eccDisplay :: Behavior (k -> UI Element)
}
defaultEditorCollectionConfig
:: (Enum k, Ord k, Show k, HasEmpty v)
=> Behavior (Maybe k, Map k v) -> EditorCollectionConfig k v
defaultEditorCollectionConfig db = EditorCollectionConfig
{ eccTemplate = emptyValue
, eccOptions = options
, eccDisplay = pure (UI.string . show)
, eccNewKey = maybe (toEnum 0) succ . Set.lookupMax <$> options
, eccAfterDelKey = deletedKey <$> (fst <$> db) <*> options
}
where
options = Map.keysSet . snd <$> db
deletedKey Nothing _ = Nothing
deletedKey (Just k) kk = Set.lookupLT k kk `mplus` Set.lookupGT k kk
editorCollection
:: forall k v w.
(Ord k, Renderable w)
=> (Behavior (Maybe k, Map k v) -> EditorCollectionConfig k v)
-> Editor v w v
-> Editor (Maybe k, Map k v) (EditorCollection k w) (Maybe k, Map k v)
editorCollection mkConfig editorOne = Editor $ \(ba :: Behavior (Maybe k, Map k v)) -> mdo
let EditorCollectionConfig{..} = mkConfig ba
(selectedKey, db) = (fst <$> ba, snd <$> ba)
sel <- create (editorSelection (Set.toList <$> eccOptions) eccDisplay) (fst <$> ba)
one <- create editorOne $ (\(k, db) -> fromMaybe eccTemplate (k >>= (`Map.lookup` db))) <$> ba
addB <- button #+ [string "+"]
remB <- button #+ [string "-"]
let insert i = Map.insert i eccTemplate
editsDb = head <$> unions
[ replace <$> ba <@> edited one
, insert <$> eccNewKey <*> db <@ click addB
, delete <$> ba <@ click remB
]
editsKey = head <$> unions
[ edited sel
, Just <$> eccNewKey <@ click addB
, eccAfterDelKey <@ click remB
]
tids = (,) <$> tidings selectedKey editsKey <*> tidings db editsDb
return $ GenericWidget tids (EditorCollection (widgetControl sel) addB remB (widgetControl one))
where
replace (Just i,xx) x = Map.alter (const $ Just x) i xx
replace (Nothing,x) _ = x
delete (Just i,xx) = Map.delete i xx
delete (_,xx) = xx
editorList
:: (HasEmpty a, Renderable w)
=> Editor a w a -> Editor (Maybe Int, [a]) (EditorCollection Int w) (Maybe Int, [a])
editorList e =
dimapE (second (Map.fromAscList . zip [0 ..])) (second F.toList) $
editorCollection config e
where
(<&>) = flip (<$>)
infixl 1 <&>
config ba =
(defaultEditorCollectionConfig ba)
{ eccAfterDelKey =
ba <&> (\(i,m) ->
i >>= (\i ->
if Map.member (i + 1) m
then return i
else let i' = max 0 (i - 1)
in guard(i'>=0) >> return i'))
}