{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-orphans #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}
{-# OPTIONS_GHC -Wno-duplicate-exports #-}
module Graphics.UI.Threepenny.Editors
(
Editor(..)
, Editable(..)
, dimapE
, (|*|), (|*), (*|)
, (-*-), (-*), (*-)
, field
, fieldLayout
, withSomeWidget
, editorUnit
, editorIdentity
, editorReadShow
, editorEnumBounded
, editorSelection
, editorSum
, editorJust
, editorString
, editorText
, editorCheckBox
, editorList
, editorCollection
, EditorCollection
, someEditor
, withSomeWidget
, Field
, ListField
, Purpose(..)
, editorGeneric
, editorGenericBi
, GenericWidget(..)
, edited
, contents
, Layout
, Vertical(..)
, Horizontal(..)
, Columns(..)
, Renderable(..)
, renderGeneric
, getLayoutGeneric
, HasEmpty(..)
) where
import Data.Biapplicative
import Data.Char
import Data.Functor.Compose
import Data.Functor.Identity
import Data.HasEmpty
import Data.Kind
import Data.Maybe
import qualified Data.Sequence as Seq
import Data.Text (Text)
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 (HasEmpty a, Renderable (EditorWidget a), Renderable (ListEditorWidget a)) => Editable a where
type family EditorWidget a
type family ListEditorWidget a
type EditorWidget a = Layout
type ListEditorWidget a = EditorCollection Int (EditorWidget a)
editor :: Editor a (EditorWidget a) a
listEditor :: Editor [a] (ListEditorWidget a) [a]
default editor :: (Generic a, HasDatatypeInfo a, (All (All Editable `And` All HasEmpty) (Code a)), EditorWidget a ~ Layout) => Editor a (EditorWidget a) a
editor = editorGeneric
default listEditor :: (HasEmpty a, ListEditorWidget a ~ EditorCollection Int (EditorWidget a)) => Editor [a] (ListEditorWidget a) [a]
listEditor = fmap snd $ Editor $ \ba -> mdo
e <- create (editorList editor) (liftA2 (,) bIndex ba)
bIndex <- stepper Nothing (fst <$> edited e)
return e
withSomeWidget :: Renderable w => Editor a w b -> Editor a Layout b
withSomeWidget = first getLayout
someEditor :: Editable a => Editor a Layout a
someEditor = withSomeWidget editor
data EditorWidgetFor a where
EditorWidgetFor :: Editable a => EditorWidget a -> EditorWidgetFor a
data Purpose = Data | Edit
type family Field (purpose :: Purpose) a where
Field 'Data a = a
Field 'Edit a = EditorWidget a
type family ListField (purpose :: Purpose) a where
ListField 'Data a = [a]
ListField 'Edit a = ListEditorWidget a
instance Editable () where
type EditorWidget () = Element
editor = editorUnit
instance Editable Char where
type EditorWidget Char = TextEntry
type ListEditorWidget Char = TextEntry
editor = editorJust editorReadShow
listEditor = editorString
instance Editable a => Editable [a] where
type EditorWidget [a] = ListEditorWidget a
editor = listEditor
instance Editable Text where
type EditorWidget Text = TextEntry
editor = editorText
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 (:|*|) (:|*|) <<*>> dimapE (\(x :|*| _) -> x) id editor
<<*>> dimapE (\(_ :|*| y) -> y) id editor
instance (Editable a, Editable b) => Editable (a -*- b) where
type EditorWidget (a -*- b) = EditorWidget a -*- EditorWidget b
editor = bipure (:-*-) (:-*-) <<*>> dimapE (\(x :-*- _) -> x) id editor
<<*>> dimapE (\(_ :-*- y) -> y) id editor
instance Editable a => Editable (Identity a) where
type EditorWidget (Identity a) = EditorWidget a
editor = editorIdentity editor
renderGeneric
:: forall a xs.
(Generic a, HasDatatypeInfo a, All Renderable xs, Code a ~ '[xs])
=> a -> UI Element
renderGeneric = render . (Grid . Seq.fromList . fmap Seq.fromList) . getLayoutGeneric
getLayoutGeneric
:: forall a xs.
(Generic a, HasDatatypeInfo a, All Renderable xs, Code a ~ '[xs])
=> a -> [[Layout]]
getLayoutGeneric = getLayoutGeneric' (datatypeInfo (Proxy @ a)) . from
getLayoutGeneric' :: (All Renderable xs) => DatatypeInfo '[xs] -> SOP I '[xs] -> [[Layout]]
getLayoutGeneric' (ADT _ _ (c :* Nil)) (SOP (Z x)) = getLayoutConstructor c x
getLayoutGeneric' (Newtype _ _ c) (SOP (Z x)) = getLayoutConstructor c x
getLayoutGeneric' _ _ = error "unreachable"
getLayoutConstructor :: All Renderable xs => ConstructorInfo xs -> NP I xs -> [[Layout]]
getLayoutConstructor (Record _ fields) renders = hcollapse $ hcliftA2 (Proxy @ Renderable) (\f (I x) -> K $ getLayoutField f x) fields renders
getLayoutConstructor Constructor{} renders = hcollapse $ hcliftA (Proxy @ Renderable) (\(I x) -> K [getLayout x]) renders
getLayoutConstructor (Infix name _ _) (I r1 :* I r2 :* Nil) = [[ getLayout r1, getLayout(string name), getLayout r2]]
getLayoutField :: Renderable x => FieldInfo x -> x -> [Layout]
getLayoutField (FieldInfo name) x = [getLayout(toFieldLabel name), getLayout x]
editorGenericBi
:: forall xs typ .
( Generic (typ 'Data)
, Generic (typ 'Edit)
, All Editable xs
, Code (typ 'Data) ~ '[xs]
, Code (typ 'Edit) ~ '[EditorWidgetsFor xs]
)
=> Editor (typ 'Data) (typ 'Edit) (typ 'Data)
editorGenericBi = dimapE from to $ bimap to id constructorEditorBi
constructorEditorBi
:: forall xs . (All Editable xs)
=> Editor (SOP I '[xs]) (SOP I '[EditorWidgetsFor xs]) (SOP I '[xs])
constructorEditorBi = dimapE (unZ . unSOP) (SOP . Z) . bimap (SOP . Z . unpackWidgets) id $ constructorEditorBi'
constructorEditorBi' :: (SListI xs, All Editable xs) => Editor (NP I xs) (NP EditorWidgetFor xs) (NP I xs)
constructorEditorBi' = sequence_NP2 fieldsEditorBi
unpackWidgets :: NP EditorWidgetFor xs -> NP I (EditorWidgetsFor xs)
unpackWidgets Nil = Nil
unpackWidgets (EditorWidgetFor e :* xs) = I e :* unpackWidgets xs
type family EditorWidgetsFor (xs :: [*]) where
EditorWidgetsFor '[] = '[]
EditorWidgetsFor (x ': xs) = EditorWidget x ': EditorWidgetsFor xs
fieldsEditorBi :: forall xs . All Editable xs => NP2 EditorWidgetFor (Editor (NP I xs)) xs
fieldsEditorBi = go id sList where
go :: forall ys. All Editable ys => (forall f . NP f xs -> NP f ys) -> SList ys -> NP2 EditorWidgetFor (Editor (NP I xs)) ys
go _ SNil = Nil2
go f SCons = bimap EditorWidgetFor id (dimapE (unI . hd . f) id editor) :** go (tl . f) sList
data NP2 :: (k -> *) -> (* -> k -> *) -> [k] -> * where
Nil2 :: NP2 ann f '[]
(:**) :: f (ann x) x -> NP2 ann f xs -> NP2 ann f (x ': xs)
sequence_NP2 :: Biapplicative f => NP2 w f xs -> f (NP w xs) (NP I xs)
sequence_NP2 Nil2 = bipure Nil Nil
sequence_NP2 (x :** xs) = bipure (:*) (\x xx -> I x :* xx) <<*>> x <<*>> sequence_NP2 xs
constructorEditorFor
:: (All Editable xs, All HasEmpty xs)
=> ConstructorInfo xs
-> Editor (SOP I '[xs]) Layout (SOP I '[xs])
constructorEditorFor (Record _ fields) = dimapE (unZ . unSOP) (SOP . Z) $ constructorEditorFor' fields
constructorEditorFor (Constructor _) = dimapE (unZ . unSOP) (SOP . Z) someEditor
constructorEditorFor Infix{} = dimapE (unZ . unSOP) (SOP . Z) someEditor
editorGeneric
:: forall a .
(Generic a, HasDatatypeInfo a, (All (All Editable `And` All HasEmpty) (Code a)))
=> Editor a Layout a
editorGeneric = dimapE from to $ editorGeneric' (datatypeInfo(Proxy @ a))
editorGeneric'
:: forall xx.
(All (All Editable `And` All HasEmpty) xx)
=> DatatypeInfo xx -> Editor (SOP I xx) Layout (SOP I xx)
editorGeneric' (ADT _ _ (c :* Nil)) = constructorEditorFor c
editorGeneric' (ADT _ _ cc) = editorSum above editors constructor where
editors :: [(Tag, Editor (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 HasEmpty) xx)
=> NP ConstructorInfo xx -> [(String, Editor (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 HasEmpty)
constructorEditorForUnion
:: (SListI xx, All Editable xs, All HasEmpty xs)
=> ConstructorInfo xs
-> Injection (NP I) xx xs
-> Projection (Compose Maybe (NP I)) xx xs
-> K (Editor (SOP I xx) Layout (SOP I xx)) xs
constructorEditorForUnion (Constructor _) inj prj = K $ composeEditor inj prj editor
constructorEditorForUnion Infix{} inj prj = K $ composeEditor inj prj editor
constructorEditorForUnion (Record _ fields) inj prj = K $ composeEditor inj prj $ constructorEditorFor' fields
composeEditor
:: forall xss xs.
(SListI xss, All HasEmpty xs) =>
Injection (NP I) xss xs
-> Projection (Compose Maybe (NP I)) xss xs
-> Editor (NP I xs) Layout (NP I xs)
-> Editor (SOP I xss) Layout (SOP I xss)
composeEditor (Fn inj) (Fn prj) = dimapE f (SOP . unK . inj)
where
f = fromMaybe emptyValue . getCompose . prj . K . hexpand (Compose Nothing) . hmap (Compose . Just) . unSOP
instance HasEmpty a => HasEmpty (I a) where emptyValue = I emptyValue
instance All HasEmpty xs => HasEmpty (NP I xs) where
emptyValue = hcpure (Proxy @ HasEmpty) emptyValue
constructorEditorFor' :: (SListI xs, All Editable xs) => NP FieldInfo xs -> Editor (NP I xs) Layout (NP I xs)
constructorEditorFor' fields = vertically $ hsequence $ hliftA Vertically $ fieldsEditor (hliftA (K . fieldName) fields)
instance (All Editable xs, All HasEmpty 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 (Editor (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 (Editor (NP I xs) Layout) ys
go _ SNil = Nil
go f SCons = dimapE (unI . hd . f) id someEditor :* go (tl . f) sList
fieldsEditor :: forall xs . All Editable xs => NP (K String) xs -> NP (Editor (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 (Editor (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 _ = ""