threepenny-editors 0.1.0.1 → 0.2.0.0
raw patch · 7 files changed
+386/−191 lines, 7 files
Files
- README.md +1/−1
- examples/Person.hs +28/−27
- src/Graphics/UI/Threepenny/Editors.hs +11/−161
- src/Graphics/UI/Threepenny/Editors/Base.hs +189/−0
- src/Graphics/UI/Threepenny/Editors/Generic.hs +45/−0
- src/Graphics/UI/Threepenny/Editors/Profunctor.hs +106/−0
- threepenny-editors.cabal +6/−2
README.md view
@@ -3,4 +3,4 @@ [](http://stackage.org/nightly/package/threepenny-editors) # threepenny-editors-A library for writing composable algebraic widgets with three penny. +A library for writing composable algebraic widgets with threepenny-gui.
examples/Person.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE ScopedTypeVariables #-} import Control.Monad import Data.Maybe+import Data.Profunctor import Graphics.UI.Threepenny.Core import Graphics.UI.Threepenny.Editors import Graphics.UI.Threepenny.Elements@@ -28,48 +29,48 @@ data EducationTag = Basic | Intermediate | Other deriving (Eq,Ord,Show) -data Person = Person- { education :: Education- , firstName, lastName :: String- , age :: Int- , brexiteer :: Bool- , status :: Maybe LegalStatus- }- deriving Show- instance Editable Education where- editor b = do- basicEditor <- fmap (const Basic_) <$> editor (pure ())- intermediateEditor <- fmap (const Intermediate_) <$> editor (pure ())- otherEditor <- fmap Other_ <$> editor (fromMaybe "" . getOther <$> b)+ editor = do let selector x = case x of Basic_ -> Basic Intermediate_ -> Intermediate Other_ _ -> Other editorSum- [ (Basic, basicEditor)- , (Intermediate, intermediateEditor)- , (Other, otherEditor)+ [ (Basic, const Basic_ <$> editorUnit)+ , (Intermediate, const Intermediate_ <$> editorUnit)+ , (Other, dimap (fromMaybe "" . getOther) Other_ editor) ] selector- b ++data Person = Person+ { education :: Education+ , firstName, lastName :: String+ , age :: Maybe Int+ , brexiteer :: Bool+ , status :: LegalStatus+ }+ deriving Show++instance Editable LegalStatus where+ editor = editorJust $ editorEnumBounded(pure(string.show))+ instance Editable Person where- editor b =- fmap (\fn ln a e ls b -> Person e fn ln a b ls)- <$> string "First:" *| editor (firstName <$> b)- -*- string "Last:" *| editor (lastName <$> b)- -*- string "Age:" *| editor (age <$> b)- -*- string "Education:" *| editor (education <$> b)- -*- string "Status" *| editorEnumBounded(pure(string.show)) (status <$> b)- -*- string "Brexiter" *| editor (brexiteer <$> b)+ editor =+ (\fn ln a e ls b -> Person e fn ln a b ls)+ <$> field "First:" firstName editor+ -*- field "Last:" lastName editor+ -*- field "Age:" age editor+ -*- field "Education:" education editor+ -*- field "Status" status editor+ -*- field "Brexiter" brexiteer editor setup :: Window -> UI () setup w = void $ mdo _ <- return w # set title "Threepenny editors example"- person1 :: Editor Person <- editor person1B- person1B <- stepper (Person Basic_ "" "" 0 False Nothing) (edited person1)+ person1 <- createEditor editor person1B+ person1B <- stepper (Person Basic_ "" "" Nothing False Single) (edited person1) getBody w #+ [grid [ [return $ editorElement person1]
src/Graphics/UI/Threepenny/Editors.hs view
@@ -1,174 +1,24 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE RecursiveDo #-}-{-# LANGUAGE TupleSections #-}-{-# OPTIONS_GHC #-}+ module Graphics.UI.Threepenny.Editors ( -- * Editors Editor(..) , edited , contents+ , EditorFactory+ , createEditor+ , Editable(..) -- ** Editor compoosition , (|*|), (|*), (*|) , (-*-), (-*), (*-)+ , field -- ** Editor constructors+ , editorUnit , editorReadShow , editorEnumBounded- , withDefault+ , editorSum+ , editorJust+ -- * Reexports+ , Compose(..) )where -import Data.Maybe-import Data.Profunctor-import Graphics.UI.Threepenny.Attributes-import Graphics.UI.Threepenny.Core-import Graphics.UI.Threepenny.Elements-import Graphics.UI.Threepenny.Events-import Graphics.UI.Threepenny.Widgets-import Text.Read--data Editor a = Editor- { editorTidings :: Tidings a- , editorElement :: Element- }- deriving Functor--instance Widget (Editor a) where- getElement = editorElement---- | A newtype wrapper that provides a 'Profunctor' instance.-newtype EditorFactory a b = EditorFactory { run :: Behavior a -> UI (Editor b) }--instance Profunctor EditorFactory where- dimap g h (EditorFactory f) = EditorFactory $ \b -> fmap h <$> f (g <$> b)---- | The class of Editable datatypes.-class Editable a where- -- | The editor factory- editor :: Behavior a -> UI (Editor a)--edited :: Editor a -> Event a-edited = rumors . editorTidings--contents :: Editor a -> Behavior a-contents = facts . editorTidings--infixl 4 |*|, -*--infixl 5 |*, *|, -*, *----- | Left-right editor composition-(|*|) :: UI(Editor (b -> a)) -> UI(Editor b) -> UI(Editor a)-a |*| b = do- a <- a- b <- b- ab <- row [return $ getElement a, return $ getElement b]- return $ Editor (editorTidings a <*> editorTidings b) ab---- | Left-right composition of an element with a editor-(*|) :: UI Element -> UI (Editor a) -> UI (Editor a)-e *| a = do- e <- e- a <- a- ea <- row [return e, return $ getElement a]- return $ Editor (editorTidings a) ea---- | Left-right composition of an element with a editor-(|*) :: UI (Editor a) -> UI Element -> UI (Editor a)-a |* e = do- e <- e- a <- a- ea <- row [return $ getElement a, return e]- return $ Editor (editorTidings a) ea---- | Top-down editor composition-(-*-) :: UI(Editor (b -> a)) -> UI(Editor b) -> UI(Editor a)-a -*- b = do- a <- a- b <- b- ab <- column [return $ getElement a, return $ getElement b]- return $ Editor (editorTidings a <*> editorTidings b) ab---- | Top-down composition of an element with a editor-(*-) :: UI Element -> UI (Editor a) -> UI (Editor a)-e *- a = do- e <- e- a <- a- ea <- column [return e, return $ getElement a]- return $ Editor (editorTidings a) ea---- | Top-down composition of an element with a editor-(-*) :: UI (Editor a) -> UI Element -> UI (Editor a)-a -* e = do- e <- e- a <- a- ea <- column [return $ getElement a, return e]- return $ Editor (editorTidings a) ea--editorReadShow :: (Read a, Show a) => Behavior (Maybe a) -> UI (Editor (Maybe a))-editorReadShow b =- do- e <- editor (show <$> b)- let t = tidings b (filterJust $ readMaybe <$> edited e)- return $ Editor t (getElement e)--editorEnumBounded- :: (Bounded a, Enum a, Ord a, Show a)- => Behavior(a -> UI Element) -> Behavior (Maybe a) -> UI (Editor (Maybe a))-editorEnumBounded display b = do- l <- listBox (pure $ enumFrom minBound) b display- return $ Editor (userSelection l) (getElement l)--withDefault- :: EditorFactory (Maybe a) (Maybe b)- -> b- -> EditorFactory a b-withDefault editor def = dimap Just (fromMaybe def) editor--data SumWrapper tag a = A {display :: tag, factory :: Editor a}--instance Eq tag => Eq (SumWrapper tag a) where A a _ == A b _ = a == b-instance Ord tag => Ord (SumWrapper tag a) where compare (A a _) (A b _) = compare a b-instance Show tag => Show (SumWrapper tag a) where show = show . display---- | * Experimental editor, do not use yet.-editorSum- :: (Ord tag, Show tag)- => [(tag, Editor a)] -> (a -> tag) -> Behavior a -> UI (Editor a)-editorSum options selector ba = mdo- let bSelected =- let build a =- let tag = selector a- in A tag <$> lookup tag options- in build <$> ba- l <- listBox (pure $ fmap (uncurry A) options) bSelected (pure (string . show))- let nestedEditor = factory . fromMaybe (uncurry A $ head options) <$> bSelected- nestedElement <- sink children ((:[]) . getElement <$> nestedEditor) new- composed <- column [element l, widget nestedElement]- let joinE :: Event (Event a) -> UI(Event a)- joinE = undefined -- missing in threepenny-gui- event <- joinE (edited <$> nestedEditor <@ rumors (userSelection l))- return $ Editor (tidings ba event) composed--instance Editable () where- editor b = do- t <- new- return $ Editor (tidings b never) (getElement t)--instance a ~ Char => Editable [a] where- editor b = do- t <- entry b- return $ Editor (userText t) (getElement t)--instance Editable Int where- editor = run $ EditorFactory editor `withDefault` 0--instance Editable Double where- editor = run $ EditorFactory editor `withDefault` 0--instance Editable Bool where- editor b = do- t <- sink checked b $ input # set type_ "checkbox"- return $ Editor (tidings b $ checkedChange t) t--instance Editable (Maybe Int) where editor = editorReadShow-instance Editable (Maybe Double) where editor = editorReadShow+import Graphics.UI.Threepenny.Editors.Profunctor
+ src/Graphics/UI/Threepenny/Editors/Base.hs view
@@ -0,0 +1,189 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC #-}+module Graphics.UI.Threepenny.Editors.Base+ ( -- * Editors+ Editor(..)+ , edited+ , contents+ , Editable(..)+ -- ** Editor compoosition+ , (|*|), (|*), (*|)+ , (-*-), (-*), (*-)+ -- ** Editor constructors+ , editorReadShow+ , editorEnumBounded+ , editorSum+ , editorJust+ -- * Reexports+ , Compose(..)+ )where++import Data.Functor.Compose+import Graphics.UI.Threepenny.Attributes+import Graphics.UI.Threepenny.Core+import Graphics.UI.Threepenny.Elements+import Graphics.UI.Threepenny.Events+import Graphics.UI.Threepenny.Widgets+import Text.Read++-- | A widget for editing values of type @a@.+data Editor a = Editor+ { editorTidings :: Tidings a+ , editorElement :: Element+ }+ deriving Functor++instance Widget (Editor a) where+ getElement = editorElement++-- | The class of Editable datatypes.+class Editable a where+ -- | The editor factory+ editor :: Behavior a -> Compose UI Editor a++edited :: Editor a -> Event a+edited = rumors . editorTidings++contents :: Editor a -> Behavior a+contents = facts . editorTidings++infixl 4 |*|, -*-+infixl 5 |*, *|, -*, *-++-- | Left-right editor composition+(|*|) :: Compose UI Editor (b -> a) -> Compose UI Editor b -> Compose UI Editor a+a |*| b = Compose $ do+ a <- getCompose a+ b <- getCompose b+ ab <- row [return $ getElement a, return $ getElement b]+ return $ Editor (editorTidings a <*> editorTidings b) ab++-- | Left-right composition of an element with a editor+(*|) :: UI Element -> Compose UI Editor a -> Compose UI Editor a+e *| a = Compose $ do+ e <- e+ a <- getCompose a+ ea <- row [return e, return $ getElement a]+ return $ Editor (editorTidings a) ea++-- | Left-right composition of an element with a editor+(|*) :: Compose UI Editor a -> UI Element -> Compose UI Editor a+a |* e = Compose $ do+ e <- e+ a <- getCompose a+ ea <- row [+ return $ getElement a, return e]+ return $ Editor (editorTidings a) ea++-- | Top-down editor composition+(-*-) :: Compose UI Editor (b -> a) -> Compose UI Editor b -> Compose UI Editor a+a -*- b = Compose $ do+ a <- getCompose a+ b <- getCompose b+ ab <- column [return $ getElement a, return $ getElement b]+ return $ Editor (editorTidings a <*> editorTidings b) ab++-- | Top-down composition of an element with a editor+(*-) :: UI Element -> Compose UI Editor a -> Compose UI Editor a+e *- a = Compose $ do+ e <- e+ a <- getCompose a+ ea <- column [return e, return $ getElement a]+ return $ Editor (editorTidings a) ea++-- | Top-down composition of an element with a editor+(-*) :: Compose UI Editor a -> UI Element -> Compose UI Editor a+a -* e = Compose $ do+ e <- e+ a <- getCompose a+ ea <- column [return $ getElement a, return e]+ return $ Editor (editorTidings a) ea++editorReadShow :: (Read a, Show a) => Behavior (Maybe a) -> Compose UI Editor (Maybe a)+editorReadShow b = Compose $ do+ e <- getCompose $ editor (maybe "" show <$> b)+ let readIt "" = Nothing+ readIt x = readMaybe x+ let t = tidings b (readIt <$> edited e)+ return $ Editor t (getElement e)++editorEnumBounded+ :: (Bounded a, Enum a, Ord a, Show a)+ => Behavior(a -> UI Element) -> Behavior (Maybe a) -> Compose UI Editor (Maybe a)+editorEnumBounded display b = Compose $ do+ l <- listBox (pure $ enumFrom minBound) b display+ return $ Editor (tidings b (rumors $ userSelection l)) (getElement l)+++editorJust :: (Behavior (Maybe b) -> Compose UI Editor (Maybe b))+ -> Behavior b+ -> Compose UI Editor b+editorJust editor b = Compose $ do+ e <- getCompose $ editor (Just <$> b)+ let ev = filterJust (edited e)+ return $ Editor (tidings b ev) (editorElement e)++data SumWrapper tag a = A {display :: tag, theEditor :: Editor a}++instance Eq tag => Eq (SumWrapper tag a) where A a _ == A b _ = a == b+instance Ord tag => Ord (SumWrapper tag a) where compare (A a _) (A b _) = compare a b+instance Show tag => Show (SumWrapper tag a) where show = show . display++-- | An editor for union types, built from editors for its constructors.+editorSum+ :: (Ord tag, Show tag)+ => [(tag, Compose UI Editor a)] -> (a -> tag) -> Behavior a -> Compose UI Editor a+editorSum options selector ba = Compose $ do+ w <- askWindow+ options <- traverse (\(tag, Compose mk) -> (tag,) <$> mk) options+ -- extract the tag from the current value+ let bSelected =+ let build a =+ let tag = selector a+ in A tag <$> lookup tag options+ in build <$> ba+ -- build a tag selector following the current tag+ l <-+ listBox (pure $ fmap (uncurry A) options) bSelected (pure (string . show))+ -- a placeholder for the constructor editor+ nestedEditor <- new+ -- when the user selects a tag, refresh the nested editor+ _ <-+ liftIO $+ register (filterJust $ rumors (userSelection l)) $ \x ->+ runUI w $ set' children [getElement $ theEditor x] nestedEditor+ --+ composed <- column [element l, widget nestedEditor]+ -- the result event fires when any of the nested editors or the tag selector fire.+ let editedEvents = fmap (edited . snd) options+ eTag = filterJust $ fmap display <$> rumors (userSelection l)+ taggedOptions = sequenceA [(tag, ) <$> contents e | (tag, e) <- options]+ editedTag = filterJust $ flip lookup <$> taggedOptions <@> eTag+ editedE = head <$> unions (editedTag : editedEvents)+ return $ Editor (tidings ba editedE) composed++instance Editable () where+ editor b = Compose $ do+ t <- new+ return $ Editor (tidings b never) (getElement t)++instance a ~ Char => Editable [a] where+ editor b = Compose $ do+ t <- entry b+ return $ Editor (userText t) (getElement t)+instance Editable Bool where+ editor b = Compose $ do+ t <- sink checked b $ input # set type_ "checkbox"+ return $ Editor (tidings b $ checkedChange t) t++instance Editable (Maybe Int) where editor = editorReadShow+instance Editable (Maybe Double) where editor = editorReadShow+instance Editable Int where editor = editorJust editor+instance Editable Double where editor = editorJust editor+++instance (Editable a, Editable b) => Editable (a,b) where+ editor b = (,) <$> editor (fst <$> b) |*| editor (snd <$> b)
+ src/Graphics/UI/Threepenny/Editors/Generic.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeInType #-}+module Graphics.UI.Threepenny.Editors.Generic where++import Data.Profunctor+import Data.Proxy+import Generics.SOP+import Graphics.UI.Threepenny.Core+import Graphics.UI.Threepenny.Editors.Profunctor++genericEditor+ :: forall a .+ (Generic a, HasDatatypeInfo a, All2 Editable (Code a))+ => EditorFactory a a+genericEditor = dimap from to $ genericEditor' (datatypeInfo(Proxy @ a))++genericEditor' :: (All2 Editable xx) => DatatypeInfo xx -> EditorFactory (SOP I xx) (SOP I xx)+genericEditor' (ADT _ _ (c :* Nil)) = dimap (unZ . unSOP) (SOP . Z) $ snd $ constructorEditorFor c+genericEditor' (ADT _ _ cc) = editorSum (_f editors) discriminator where+ editors = hcollapse $ hcliftA p (constructorEditorFor) cc++constructorEditorFor :: All Editable xs => ConstructorInfo xs -> (String, EditorFactory (NP I xs) (NP I xs))+constructorEditorFor (Record name fields) = K $ (name,) $ unVEF $ hsequence $ hliftA VEF $ fieldsEditors (hliftA (K . fieldName) fields)++fieldsEditors :: forall xs . All Editable xs => NP (K String) xs -> NP (EditorFactory (NP I xs)) xs+fieldsEditors = 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++p :: Proxy Editable+p = Proxy++-- | EditorFactory with an Applicative instance for vertical composition+newtype VEF a b = VEF {unVEF :: EditorFactory a b} deriving (Functor, Profunctor)+instance Applicative (VEF a) where+ pure = error "VEF: pure"+ VEF a <*> VEF b = VEF (a |*| b)
+ src/Graphics/UI/Threepenny/Editors/Profunctor.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC #-}+module Graphics.UI.Threepenny.Editors.Profunctor+ ( -- * Editors+ Base.Editor(..)+ , Base.edited+ , Base.contents+ , EditorFactory+ , createEditor+ , Editable(..)+ -- ** Editor compoosition+ , (|*|), (|*), (*|)+ , (-*-), (-*), (*-)+ , field+ -- ** Editor constructors+ , editorUnit+ , editorReadShow+ , editorEnumBounded+ , editorSum+ , editorJust+ -- * Reexports+ , Compose(..)+ )where++import Data.Functor.Compose+import Data.Profunctor+import Graphics.UI.Threepenny.Core+import qualified Graphics.UI.Threepenny.Editors.Base as Base++-- | A newtype wrapper that provides a 'Profunctor' instance.+newtype EditorFactory a b = EditorFactory+ { run :: Behavior a -> Compose UI Base.Editor b+ }++createEditor :: EditorFactory b a -> Behavior b -> UI (Base.Editor a)+createEditor e b = getCompose $ run e b++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++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++-- | A helper that arranges a label with the field name+-- and the editor horizontally.+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++-- | Ignores 'Nothing' values and only updates for 'Just' values+editorJust :: EditorFactory (Maybe a) (Maybe a) -> EditorFactory a a+editorJust e = EditorFactory $ Base.editorJust (run e)++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
threepenny-editors.cabal view
@@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack name: threepenny-editors-version: 0.1.0.1+version: 0.2.0.0 synopsis: Composable algebraic editors description: This package provides a type class 'Editable' and combinators to easily put together form-like editors for algebraic datatypes.@@ -13,7 +13,7 @@ . @cabal install threepenny-editors -fbuildExamples@ category: Web-homepage: https://github.com/pepeiborra/threepenny-forms#readme+homepage: https://github.com/pepeiborra/threepenny-editors author: Jose Iborra maintainer: pepeiborra@gmail.com copyright: All Rights Reserved@@ -40,7 +40,10 @@ , threepenny-gui > 0.7 exposed-modules: Graphics.UI.Threepenny.Editors+ Graphics.UI.Threepenny.Editors.Base+ Graphics.UI.Threepenny.Editors.Profunctor other-modules:+ Graphics.UI.Threepenny.Editors.Generic Paths_threepenny_editors default-language: Haskell2010 @@ -52,6 +55,7 @@ if flag(buildExamples) build-depends: base+ , profunctors , threepenny-gui , threepenny-editors else