module Graphics.UI.Threepenny.Editors.Profunctor
(
Base.Editor(..)
, Base.edited
, Base.contents
, EditorFactory(..)
, createEditor
, liftEditor
, Editable(..)
, (|*|), (|*), (*|)
, (-*-), (-*), (*-)
, field
, editorUnit
, editorIdentity
, editorReadShow
, editorEnumBounded
, editorSelection
, editorSum
, editorJust
, editorGeneric
, editorGenericSimple
)where
import Data.Bifunctor
import Data.Char
import Data.Default
import Data.Functor.Compose
import Data.Functor.Identity
import Data.Maybe
import Data.Profunctor
import Data.Proxy
import Generics.SOP hiding (Compose)
import Graphics.UI.Threepenny.Core
import qualified Graphics.UI.Threepenny.Editors.Base as Base
import Text.Casing
newtype EditorFactory a b = EditorFactory
{ run :: Behavior a -> Compose UI Base.EditorDef b
}
liftEditor :: (UI Element -> UI Element) -> EditorFactory a b -> EditorFactory a b
liftEditor f (EditorFactory run) = EditorFactory $ \b ->
case run b of
Compose uidef -> Compose $ fmap (Base.liftEditorDef f) uidef
createEditor :: EditorFactory b a -> Behavior b -> UI (Base.Editor a)
createEditor e b = getCompose (run e b) >>= Base.runEditorDef
instance Functor (EditorFactory a) where
fmap = dimap id
instance Profunctor EditorFactory where
dimap g h (EditorFactory f) = EditorFactory $ \b -> h <$> f (g <$> b)
class Editable a where
editor :: EditorFactory a a
default editor :: (Generic a, HasDatatypeInfo a, (All (All Editable `And` All Default) (Code a))) => EditorFactory a a
editor = editorGeneric
infixl 4 |*|, -*-
infixl 5 |*, *|, -*, *-
(|*|) :: EditorFactory s (b->a) -> EditorFactory s b -> EditorFactory s a
a |*| b = EditorFactory $ \s -> run a s Base.|*| run b s
(|*) :: EditorFactory s a -> UI Element -> EditorFactory s a
a |* e = EditorFactory $ \s -> run a s Base.|* e
(*|) :: UI Element -> EditorFactory s a -> EditorFactory s a
e *| a = EditorFactory $ \s -> e Base.*| run a s
(-*-) :: EditorFactory s (b->a) -> EditorFactory s b -> EditorFactory s a
a -*- b = EditorFactory $ \s -> run a s Base.-*- run b s
(-*) :: EditorFactory s a -> UI Element -> EditorFactory s a
a -* e = EditorFactory $ \s -> run a s Base.-* e
(*-) :: UI Element -> EditorFactory s a -> EditorFactory s a
e *- a = EditorFactory $ \s -> e Base.*- run a s
field :: String -> (out -> inn) -> EditorFactory inn a -> EditorFactory out a
field name f e = string name *| lmap f e
editorUnit :: EditorFactory a ()
editorUnit = EditorFactory $ \_ -> Base.editor (pure ())
editorReadShow :: (Read a, Show a) => EditorFactory (Maybe a) (Maybe a)
editorReadShow = EditorFactory Base.editorReadShow
editorEnumBounded
:: (Show a, Ord a, Enum a, Bounded a)
=> Behavior (a -> UI Element) -> EditorFactory (Maybe a) (Maybe a )
editorEnumBounded display = EditorFactory $ Base.editorEnumBounded display
editorJust :: EditorFactory (Maybe a) (Maybe a) -> EditorFactory a a
editorJust e = EditorFactory $ Base.editorJust (run e)
editorSelection :: Ord a => Behavior [a] -> Behavior(a -> UI Element) -> EditorFactory (Maybe a) (Maybe a)
editorSelection opts displ = EditorFactory $ Base.editorSelection opts displ
editorSum
:: (Show tag, Ord tag)
=> [(tag, EditorFactory b b)] -> (b -> tag) -> EditorFactory b b
editorSum nested tagger = EditorFactory $ \b ->
let nested' = [ (tag, run f b) | (tag, f) <- nested ]
in Base.editorSum nested' tagger b
instance Editable () where editor = EditorFactory Base.editor
instance Editable String where editor = EditorFactory Base.editor
instance Editable Bool where editor = EditorFactory Base.editor
instance Editable Int where editor = EditorFactory Base.editor
instance Editable Double where editor = EditorFactory Base.editor
instance Editable (Maybe Int) where editor = EditorFactory Base.editor
instance Editable (Maybe Double) where editor = EditorFactory Base.editor
instance (Editable a, Editable b) => Editable (a,b) where
editor = (,) <$> lmap fst editor |*| lmap snd editor
instance Editable a => Editable (Identity a) where
editor = editorIdentity editor
editorIdentity :: EditorFactory a a -> EditorFactory (Identity a) (Identity a)
editorIdentity = dimap runIdentity Identity
editorGenericSimple
:: forall a xs.
(Generic a, HasDatatypeInfo a, All Editable xs, Code a ~ '[xs])
=> EditorFactory a a
editorGenericSimple = dimap from to $ editorGenericSimple' (datatypeInfo(Proxy @ a))
editorGenericSimple'
:: forall xs.
(All Editable xs)
=> DatatypeInfo '[xs] -> EditorFactory (SOP I '[xs]) (SOP I '[xs])
editorGenericSimple' (ADT _ _ (c :* Nil)) = constructorEditorFor c
editorGenericSimple' (Newtype _ _ c) = constructorEditorFor c
constructorEditorFor
:: (All Editable xs)
=> ConstructorInfo xs
-> EditorFactory (SOP I '[xs]) (SOP I '[xs])
constructorEditorFor (Record _ fields) = dimap (unZ . unSOP) (SOP . Z) $ constructorEditorFor' fields
constructorEditorFor (Constructor _) = dimap (unZ . unSOP) (SOP . Z) editor
constructorEditorFor Infix{} = dimap (unZ . unSOP) (SOP . Z) editor
editorGeneric
:: forall a .
(Generic a, HasDatatypeInfo a, (All (All Editable `And` All Default) (Code a)))
=> EditorFactory a a
editorGeneric = dimap from to $ editorGeneric' (datatypeInfo(Proxy @ a))
editorGeneric'
:: forall xx.
(All (All Editable `And` All Default) xx)
=> DatatypeInfo xx -> EditorFactory (SOP I xx) (SOP I xx)
editorGeneric' (ADT _ _ (c :* Nil)) = constructorEditorFor c
editorGeneric' (ADT _ _ cc) = editorSum editors constructor where
editors :: [(Tag, EditorFactory (SOP I xx) (SOP I xx))]
editors = map (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) = t
constructorEditorsFor
:: forall xx . (All (All Editable `And` All Default) xx)
=> NP ConstructorInfo xx -> [(String, EditorFactory (SOP I xx) (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) (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) (NP I xs)
-> EditorFactory (SOP I xss) (SOP I xss)
composeEditorFactory (Fn inj) (Fn prj) = dimap 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) (NP I xs)
constructorEditorFor' fields = unVEF $ hsequence $ hliftA VEF $ fieldsEditor (hliftA (K . fieldName) fields)
instance All Editable xs => Editable (NP I xs) where
editor = unHEF $ hsequence $ hliftA HEF tupleEditor
tupleEditor :: forall xs . All Editable xs => NP (EditorFactory (NP I xs)) 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)) ys
go _ SNil = Nil
go f SCons = lmap (unI . hd . f) editor :* go (tl . f) sList
fieldsEditor :: forall xs . All Editable xs => NP (K String) xs -> NP (EditorFactory (NP I xs)) 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)) ys
go _ SNil Nil = Nil
go f SCons (K fn :* xs) = field (toFieldLabel fn) (unI . hd . f) editor :* go (tl . f) sList xs
toFieldLabel :: String -> String
toFieldLabel (fromAny -> Identifier (x:xx)) =
unwords (onHead toUpper x : map (onHead toLower) xx) ++ ":"
where
onHead f (x:xx) = f x : xx
onHead _ [] = []
toFieldLabel _ = ""
newtype VEF a b = VEF {unVEF :: EditorFactory a b} deriving (Functor, Profunctor)
instance Applicative (VEF a) where
pure x = VEF $ const x <$> editorUnit
VEF a <*> VEF b = VEF (a -*- b)
newtype HEF a b = HEF {unHEF :: EditorFactory a b} deriving (Functor, Profunctor)
instance Applicative (HEF a) where
pure x = HEF $ const x <$> editorUnit
HEF a <*> HEF b = HEF (a |*| b)
instance (Applicative f, All Default xs) => Default (NP f xs) where
def = hcpure (Proxy @ Default) (pure def)