module Graphics.UI.Threepenny.Editors
(
Editor(..)
, edited
, contents
, editorElement
, EditorFactory(Horizontally, horizontally, Vertically, vertically)
, someEditor
, createEditor
, Editable(..)
, EditorWidgetFor(..)
, Field
, Usage(..)
, (|*|), (|*), (*|)
, (-*-), (-*), (*-)
, field
, fieldLayout
, pattern Horizontally
, pattern Vertically
, withLayout
, withSomeWidget
, construct
, editorUnit
, editorIdentity
, editorReadShow
, editorEnumBounded
, editorSelection
, editorSum
, editorJust
, editorGeneric
, editorGenericSimple
, Layout
, above
, beside
, Vertical(..)
, Horizontal(..)
, Columns(..)
, type (|*|)(..)
, type (-*-)(..)
, Renderable(..)
) where
import Data.Biapplicative
import Data.Char
import Data.Default
import Data.Functor.Compose
import Data.Functor.Identity
import Data.Maybe
import Generics.SOP hiding (Compose)
import Graphics.UI.Threepenny.Core as UI
import Graphics.UI.Threepenny.Widgets
import Text.Casing
import Graphics.UI.Threepenny.Editors.Layout
import Graphics.UI.Threepenny.Editors.Types
class Renderable (EditorWidget a) => Editable a where
type family EditorWidget a
type EditorWidget a = Layout
editor :: EditorFactory a (EditorWidget a) a
default editor :: (Generic a, HasDatatypeInfo a, (All (All Editable `And` All Default) (Code a)), EditorWidget a ~ Layout) => EditorFactory a (EditorWidget a) a
editor = editorGeneric
withSomeWidget :: Renderable w => EditorFactory a w b -> EditorFactory a Layout b
withSomeWidget = first getLayout
someEditor :: Editable a => EditorFactory a Layout a
someEditor = withSomeWidget editor
data EditorWidgetFor a where
EditorWidgetFor :: Editable a => EditorWidget a -> EditorWidgetFor a
data Usage = Value | Edit
type family Field (usage :: Usage) a where
Field 'Value a = a
Field 'Edit a = EditorWidget a
instance Editable () where
type EditorWidget () = Element
editor = editorUnit
instance a ~ Char => Editable [a] where
type EditorWidget [a] = TextEntry
editor = editorString
instance Editable Bool where
type EditorWidget Bool = Element
editor = editorCheckBox
instance Editable (Maybe Int) where
type EditorWidget (Maybe Int) = TextEntry
editor = editorReadShow
instance Editable (Maybe Double) where
type EditorWidget (Maybe Double) = TextEntry
editor = editorReadShow
instance Editable Int where
type EditorWidget Int = TextEntry
editor = editorJust editor
instance Editable Double where
type EditorWidget Double = TextEntry
editor = editorJust editor
instance (Editable a, Editable b) => Editable (a,b) where
type EditorWidget (a,b) = EditorWidget a |*| EditorWidget b
editor = bipure (:|*|) (,) <<*>> lmapEF fst editor <<*>> lmapEF snd editor
instance Editable a => Editable (Identity a) where
type EditorWidget (Identity a) = EditorWidget a
editor = editorIdentity editor
editorGenericSimple
:: forall a xs.
(Generic a, HasDatatypeInfo a, All Editable xs, Code a ~ '[xs])
=> EditorFactory a Layout a
editorGenericSimple = dimapEF from to $ editorGenericSimple' (datatypeInfo(Proxy @ a))
editorGenericSimple'
:: forall xs.
(All Editable xs)
=> DatatypeInfo '[xs] -> EditorFactory (SOP I '[xs]) Layout (SOP I '[xs])
editorGenericSimple' (ADT _ _ (c :* Nil)) = constructorEditorFor c
editorGenericSimple' (Newtype _ _ c) = constructorEditorFor c
constructorEditorFor
:: (All Editable xs)
=> ConstructorInfo xs
-> EditorFactory (SOP I '[xs]) Layout (SOP I '[xs])
constructorEditorFor (Record _ fields) = dimapEF (unZ . unSOP) (SOP . Z) $ constructorEditorFor' fields
constructorEditorFor (Constructor _) = dimapEF (unZ . unSOP) (SOP . Z) someEditor
constructorEditorFor Infix{} = dimapEF (unZ . unSOP) (SOP . Z) someEditor
editorGeneric
:: forall a .
(Generic a, HasDatatypeInfo a, (All (All Editable `And` All Default) (Code a)))
=> EditorFactory a Layout a
editorGeneric = dimapEF from to $ editorGeneric' (datatypeInfo(Proxy @ a))
editorGeneric'
:: forall xx.
(All (All Editable `And` All Default) xx)
=> DatatypeInfo xx -> EditorFactory (SOP I xx) Layout (SOP I xx)
editorGeneric' (ADT _ _ (c :* Nil)) = constructorEditorFor c
editorGeneric' (ADT _ _ cc) = editorSum above editors constructor where
editors :: [(Tag, EditorFactory (SOP I xx) Layout (SOP I xx))]
editors = first Tag <$> constructorEditorsFor cc
constructors = hmap (K . constructorName) cc
constructor a = Tag $ hcollapse $ hliftA2 const constructors (unSOP a)
editorGeneric' (Newtype _ _ c) = constructorEditorFor c
newtype Tag = Tag String deriving (Eq, Ord)
instance Show Tag where show (Tag t) = init $ toFieldLabel t
constructorEditorsFor
:: forall xx . (All (All Editable `And` All Default) xx)
=> NP ConstructorInfo xx -> [(String, EditorFactory (SOP I xx) Layout (SOP I xx))]
constructorEditorsFor cc =
hcollapse $ hcliftA3 p (\c i p -> (constructorName c,) `mapKK` constructorEditorForUnion c i p) cc
(injections :: NP (Injection (NP I) xx) xx)
(projections :: NP (Projection (Compose Maybe (NP I)) xx) xx)
where
p = Proxy @ (All Editable `And` All Default)
constructorEditorForUnion
:: (SListI xx, All Editable xs, All Default xs)
=> ConstructorInfo xs
-> Injection (NP I) xx xs
-> Projection (Compose Maybe (NP I)) xx xs
-> K (EditorFactory (SOP I xx) Layout (SOP I xx)) xs
constructorEditorForUnion (Constructor _) inj prj = K $ composeEditorFactory inj prj editor
constructorEditorForUnion Infix{} inj prj = K $ composeEditorFactory inj prj editor
constructorEditorForUnion (Record _ fields) inj prj = K $ composeEditorFactory inj prj $ constructorEditorFor' fields
composeEditorFactory
:: forall xss xs.
(SListI xss, All Default xs) =>
Injection (NP I) xss xs
-> Projection (Compose Maybe (NP I)) xss xs
-> EditorFactory (NP I xs) Layout (NP I xs)
-> EditorFactory (SOP I xss) Layout (SOP I xss)
composeEditorFactory (Fn inj) (Fn prj) = dimapEF f (SOP . unK . inj)
where
f :: SOP I xss -> NP I xs
f = fromMaybe def . getCompose . prj . K . hexpand (Compose Nothing) . hmap (Compose . Just) . unSOP
constructorEditorFor' :: (SListI xs, All Editable xs) => NP FieldInfo xs -> EditorFactory (NP I xs) Layout (NP I xs)
constructorEditorFor' fields = vertically $ hsequence $ hliftA Vertically $ fieldsEditor (hliftA (K . fieldName) fields)
instance All Editable xs => Editable (NP I xs) where
type EditorWidget (NP I xs) = Layout
editor = horizontally $ hsequence $ hliftA Horizontally tupleEditor
tupleEditor :: forall xs . All Editable xs => NP (EditorFactory (NP I xs) Layout) xs
tupleEditor = go id sList where
go :: forall ys. All Editable ys => (forall f . NP f xs -> NP f ys) -> SList ys -> NP (EditorFactory (NP I xs) Layout) ys
go _ SNil = Nil
go f SCons = lmapEF (unI . hd . f) someEditor :* go (tl . f) sList
fieldsEditor :: forall xs . All Editable xs => NP (K String) xs -> NP (EditorFactory (NP I xs) Layout) xs
fieldsEditor = go id sList where
go :: forall ys. All Editable ys => (forall f . NP f xs -> NP f ys) -> SList ys -> NP (K String) ys -> NP (EditorFactory (NP I xs) Layout) ys
go _ SNil Nil = Nil
go f SCons (K fn :* xs) = field (toFieldLabel fn) (unI . hd . f) someEditor :* go (tl . f) sList xs
toFieldLabel :: String -> String
toFieldLabel (fromAny -> Identifier (x:xx)) =
unwords (onHead toUpper x : fmap (onHead toLower) xx) ++ ":"
where
onHead f (x:xx) = f x : xx
onHead _ [] = []
toFieldLabel _ = ""
instance (Applicative f, All Default xs) => Default (NP f xs) where
def = hcpure (Proxy @ Default) (pure def)