module Graphics.UI.Threepenny.Editors.Profunctor
(
Base.Editor(..)
, Base.edited
, Base.contents
, EditorFactory
, createEditor
, Editable(..)
, (|*|), (|*), (*|)
, (-*-), (-*), (*-)
, field
, editorUnit
, editorIdentity
, editorReadShow
, editorEnumBounded
, editorSelection
, editorSum
, editorJust
, editorGeneric
, editorGenericSimple
)where
import Data.Bifunctor
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
newtype EditorFactory a b = EditorFactory
{ run :: Behavior a -> Compose UI Base.EditorDef b
}
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 :: Eq a => Behavior [(String,a)] -> EditorFactory a a
editorSelection sel = EditorFactory $ Base.editorSelection sel
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 fn (unI . hd . f) editor :* go (tl . f) sList xs
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)