threepenny-editors 0.5.5 → 0.5.6
raw patch · 11 files changed
+497/−68 lines, 11 filesdep +textnew-component:exe:crud2new-component:exe:person2
Dependencies added: text
Files
- examples/CRUD.hs +11/−1
- examples/CRUD2.hs +70/−0
- examples/Parser.hs +1/−1
- examples/Person.hs +18/−10
- examples/Person2.hs +77/−0
- src/Data/HasEmpty.hs +54/−0
- src/Graphics/UI/Threepenny/Editors.hs +71/−43
- src/Graphics/UI/Threepenny/Editors/Layout.hs +19/−6
- src/Graphics/UI/Threepenny/Editors/Types.hs +126/−5
- src/Graphics/UI/Threepenny/Editors/Validation.hs +1/−1
- threepenny-editors.cabal +49/−1
examples/CRUD.hs view
@@ -15,7 +15,15 @@ A more sophisticated approach would use incremental updates. ------------------------------------------------------------------------------} {-# LANGUAGE RecursiveDo #-}-module CRUD (main) where+module CRUD+ ( main+ , Database+ , DatabaseKey+ , create+ , update+ , delete+ , lookup+ ) where import Control.Monad (void) import Data.List (isPrefixOf) import qualified Data.Map as Map@@ -135,6 +143,8 @@ showDataItem :: DataItem -> String showDataItem DataItem{..} = lastName ++ ", " ++ firstName++instance HasEmpty DataItem instance Editable DataItem where type EditorWidget DataItem = DataItemEditor
+ examples/CRUD2.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE TypeApplications #-}+module CRUD2 (main) where++import Control.Monad+import Data.Bifunctor+import Data.List+import Data.Map (Map)+import Data.Set (Set)+import qualified Data.Map as Map+import qualified Data.Set as Set+import Person2 hiding (main)++import qualified Graphics.UI.Threepenny as UI+import Graphics.UI.Threepenny.Core hiding (delete)+import Graphics.UI.Threepenny.Editors hiding (create)+import qualified Graphics.UI.Threepenny.Editors as Editors+import Graphics.UI.Threepenny.Editors.Types++type Database = Map Int Person++main :: IO ()+main = startGUI defaultConfig setup++setup :: Window -> UI ()+setup window = void $ mdo+ filterEditor <- Editors.create (editor @String) bFilter+ dbEditor <- Editors.create (editorCollection dbEditorConfig editor) db++ -- debug <- UI.new # sink text (show <$> db)++ db :: Behavior (Maybe Int, Database) <-+ stepper (Nothing, mempty) $ head <$> unions+ [ edited dbEditor+ , (\kk -> first( (`mplus` (Set.lookupMin kk))+ . (>>= \k -> guard (k `Set.member` kk) >> return k)))+ <$> options <*> db <@ edited filterEditor+ ]++ bFilter <- stepper "" (edited filterEditor)++ let dbEditorConfig ba = (defaultEditorCollectionConfig ba)+ { eccDisplay = displayPerson . snd <$> ba+ , eccOptions = options+ }+ options = applyFilter <$> bFilter <*> db++ void $ return window # set title "CRUD Example (editorCollection)"+ getBody window+ #+ [column [ render filterEditor+ , string ""+ , render dbEditor+ , string ""+ --, render debug+ ]]+ where+ displayPerson db i =+ UI.option # set text (maybe "" showPerson (Map.lookup i db))+ showPerson :: Person -> String+ showPerson Person{..} = lastName ++ ", " ++ firstName++ applyFilter :: String -> (_,Database) -> Set Int+ applyFilter pat (_,db) =+ Set.fromList [ k | (k,Person{..}) <- Map.toList db+ , pat `isPrefixOf` firstName || pat `isPrefixOf` lastName]+
examples/Parser.hs view
@@ -56,7 +56,7 @@ pModeEditor :: Editor ParseMode Layout ParseMode pModeEditor = (\f l i -> defaultParseMode{parseFilename=f, baseLanguage=l, ignoreLanguagePragmas=i})- <$> field "Filename" parseFilename editor+ <$> field "Filename" parseFilename editorString -*- field "Language" baseLanguage (editorJust $ editorSelection (pure knownLanguages) (pure (string . show))) -*- field "Ignore pragmas" ignoreLanguagePragmas editor
examples/Person.hs view
@@ -15,6 +15,8 @@ module Person (main) where import Control.Monad import Data.Maybe+import Data.Text (Text)+import qualified Data.Text as T import qualified Generics.SOP as SOP import Generics.SOP.TH import GHC.Generics (Generic)@@ -31,7 +33,7 @@ -- | A dual purpose data type that doubles as a value and as a widget depending on the type argument. data PersonF (purpose :: Purpose) = Person { education :: Field purpose Education- , firstName, lastName :: Field purpose String+ , firstName, lastName :: Field purpose Text , age :: Field purpose (Maybe Int) , brexiteer :: Field purpose Brexiteer , status :: Field purpose LegalStatus@@ -41,13 +43,10 @@ type Person = PersonF Data type PersonEditor = PersonF Edit -defPerson :: Person-defPerson = Person Basic "First" "Last" Nothing (Brexiteer False) Single- instance Validable Person where validate Person{..} = fromWarnings $- [ "First name cannot be null" | null firstName ] ++- [ "Last name cannot be null" | null lastName ] +++ [ "First name cannot be null" | T.null firstName ] +++ [ "Last name cannot be null" | T.null lastName ] ++ [ "Age must be a natural number" | Just x <- [age], x <= 0] data LegalStatus@@ -57,6 +56,7 @@ | Widowed deriving (Bounded, Enum, Eq, Ord, Show, Generic) +instance HasEmpty LegalStatus instance Editable LegalStatus instance SOP.HasDatatypeInfo LegalStatus instance SOP.Generic LegalStatus@@ -64,10 +64,10 @@ data Education = Basic | Intermediate- | Other String+ | Other Text deriving (Eq, Ord, Read, Show, Generic) -getOther :: Education -> Maybe String+getOther :: Education -> Maybe Text getOther (Other s) = Just s getOther _ = Nothing @@ -81,23 +81,26 @@ editorSum beside [ ("Basic", const Basic <$> withSomeWidget editorUnit) , ("Intermediate", const Intermediate <$> withSomeWidget editorUnit)- , ("Other", dimapE (fromMaybe "" . getOther) Other someEditor)+ , ("Other", dimapE (fromMaybe mempty . getOther) Other someEditor) ] selector +instance HasEmpty Education instance Editable Education instance SOP.HasDatatypeInfo Education instance SOP.Generic Education newtype Brexiteer = Brexiteer Bool deriving (Eq, Show, Ord, Generic) +instance HasEmpty Brexiteer instance Editable Brexiteer where editor = editorGeneric instance SOP.HasDatatypeInfo Brexiteer instance SOP.Generic Brexiteer deriving instance Show Person -instance Editable Person+instance HasEmpty Person+instance Editable Person where editor = editorGeneric -- | An editor for 'Person' values that uses the 'Columns' layout builder editorPersonColumns :: Editor Person Columns Person@@ -129,7 +132,12 @@ a ||| b = getLayout a `beside` getLayout b a === b = getLayout a `above` getLayout b +-- ------- -- Driver++defPerson :: Person+defPerson = Person Basic (T.pack "First") (T.pack "Last") Nothing (Brexiteer False) Single+ setup :: Window -> UI () setup w = void $ mdo _ <- return w # set title "Threepenny editors example"
+ examples/Person2.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-}+module Person2 where++import Control.Monad+import Generics.SOP.TH+import Graphics.UI.Threepenny+import Graphics.UI.Threepenny.Editors++data Education+ = Basic+ | Intermediate+ | Other String+ deriving Show++instance Editable Education+instance HasEmpty Education++newtype Brexiteer = Brexiteer Bool deriving Show++instance Editable Brexiteer where editor = editorGeneric+instance HasEmpty Brexiteer++data LegalStatus+ = Single+ | Married+ | Divorced+ | Widowed+ deriving Show++instance HasEmpty LegalStatus+instance Editable LegalStatus++data PersonDual (purpose :: Purpose) = Person+ { education :: Field purpose Education+ , firstName, lastName :: Field purpose String+ , age :: Field purpose (Maybe Int)+ , brexiteer :: Field purpose Brexiteer+ , status :: Field purpose LegalStatus+ , addresses :: ListField purpose String+ -- , children :: ListField purpose Person+ }++deriving instance Show Person++type Person = PersonDual 'Data+type PersonEditor = PersonDual 'Edit++instance HasEmpty Person++instance Editable Person where+ type EditorWidget Person = PersonEditor+ editor = editorGenericBi++instance Renderable PersonEditor where+ render = renderGeneric++deriveGeneric ''Education+deriveGeneric ''Brexiteer+deriveGeneric ''LegalStatus+deriveGeneric ''PersonDual++main :: IO ()+main = startGUI defaultConfig $ \w -> mdo+ personE :: GenericWidget PersonEditor Person <- create editor personB+ personB :: Behavior Person <- stepper emptyValue (edited personE)++ void $ getBody w #+ [render personE]+ void $ element (firstName (widgetControl personE)) # set style [("background-color", "Blue")]
+ src/Data/HasEmpty.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+module Data.HasEmpty where++import Data.Functor.Identity+import Data.Map (Map)+import Data.Sequence+import Data.Set (Set)+import Data.Text (Text)+import qualified Data.Text as Text+import Generics.SOP+import Generics.SOP.Constraint hiding (Compose)++-- | This class defines how to represent empty values in a UI.+-- A generic derivation is available for every SOP type.+class HasEmpty a where+ emptyValue :: a+ default emptyValue :: (Generic a , HasEmptyCode (Code a) , All HasEmpty (Head (Code a))) => a+ emptyValue = gEmptyValue++instance HasEmpty Bool where emptyValue = False+instance HasEmpty Char where emptyValue = '?'+instance HasEmpty Int where emptyValue = 0+instance HasEmpty Double where emptyValue = 0+instance HasEmpty Text where emptyValue = Text.pack emptyValue+instance HasEmpty [a] where emptyValue = []+instance HasEmpty (Maybe a) where emptyValue = Nothing+instance HasEmpty () where emptyValue = ()+instance (HasEmpty a, HasEmpty b) => HasEmpty (a,b) where emptyValue = (emptyValue, emptyValue)+instance HasEmpty a => HasEmpty (Identity a) where emptyValue = Identity emptyValue+instance Ord k => HasEmpty (Map k v) where emptyValue = mempty+instance Ord k => HasEmpty (Set k) where emptyValue = mempty+instance HasEmpty (Seq k) where emptyValue = mempty++-- Generic HasEmpty values+-- -----------------------++class HasEmptyCode (xs :: [k])+instance HasEmptyCode (x ': xs)++gEmptyValue :: forall a. ( Generic a , HasEmptyCode (Code a) , All HasEmpty (Head (Code a))) => a+gEmptyValue = case sList :: SList (Code a) of+ SCons -> to $ SOP $ Z $ hcpure (Proxy @ HasEmpty) (I emptyValue)+ SNil -> error "unreachable"
src/Graphics/UI/Threepenny/Editors.hs view
@@ -7,6 +7,7 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecursiveDo #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-}@@ -85,10 +86,17 @@ , editorSelection , editorSum , editorJust+ , editorString+ , editorText+ , editorCheckBox+ , editorList+ , editorCollection+ , EditorCollection , someEditor , withSomeWidget -- ** Dual purpose datatypes , Field+ , ListField , Purpose(..) -- ** Generic editors , editorGeneric@@ -107,16 +115,19 @@ , Renderable(..) , renderGeneric , getLayoutGeneric+ -- ** Representing empty values+ , HasEmpty(..) ) where import Data.Biapplicative import Data.Char import Data.Functor.Compose import Data.Functor.Identity+import Data.HasEmpty import Data.Maybe import qualified Data.Sequence as Seq+import Data.Text (Text) import Generics.SOP hiding (Compose)-import Generics.SOP.Constraint hiding (Compose) import Graphics.UI.Threepenny.Core as UI import Graphics.UI.Threepenny.Widgets import Text.Casing@@ -150,14 +161,26 @@ -- > type EditorWidget (MyDatatype Data) = MyDatatype Edit -- > editor = editorGenericBi ---class Renderable (EditorWidget a) => Editable a where+class (HasEmpty a, Renderable (EditorWidget a), Renderable (ListEditorWidget a)) => Editable a where -- | The widget type that realizes the editor. Defaults to 'Layout' and only needs to be manually defined when using custom renderables. type family EditorWidget a+ -- | The widget type that realizes the editor for lists. Defaults to ''EditorCollection'.+ type family ListEditorWidget a type EditorWidget a = Layout+ type ListEditorWidget a = EditorCollection Int (EditorWidget a)+ editor :: Editor a (EditorWidget a) a- default editor :: (Generic a, HasDatatypeInfo a, (All (All Editable `And` All NonEmpty) (Code a)), EditorWidget a ~ Layout) => 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+ -- | Conceal the widget type of some 'Editor' withSomeWidget :: Renderable w => Editor a w b -> Editor a Layout b withSomeWidget = first getLayout@@ -173,27 +196,54 @@ -- | 'Purpose' is a kind for type level 'Field's data Purpose = Data | Edit --- | Type level fields. Used to define dual purpose datatypes, example:+-- | Type level fields. Used to define dual purpose datatype constructors, which can be instantiated to either store data or widgets.+-- Example: -- -- > data PersonF (purpose :: Purpose) = Person -- > { education :: Field purpose Education--- > , firstName, lastName :: Field purpose String+-- > , firstName, lastName :: Field purpose Text -- > , age :: Field purpose (Maybe Int)+-- > } -- -- > type Person = PersonF Data -- > type PersonEditor = PersonF Edit type family Field (purpose :: Purpose) a where Field 'Data a = a- Field 'Edit a = EditorWidget a+ Field 'Edit a = EditorWidget a +-- | List version of 'Field'. Example:+--+-- > data PersonF (purpose :: Purpose) = Person+-- > { education :: Field purpose Education+-- > , firstName, lastName :: Field purpose Text+-- > , age :: Field purpose (Maybe Int)+-- > , addresses :: ListField purpose String+-- > }+--+-- > type Person = PersonF Data+-- > type PersonEditor = PersonF Edit+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 a ~ Char => Editable [a] where- type EditorWidget [a] = TextEntry- editor = editorString+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@@ -355,7 +405,7 @@ -----------------------------------------------} constructorEditorFor- :: (All Editable xs)+ :: (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@@ -368,13 +418,13 @@ -- field names if available. editorGeneric :: forall a .- (Generic a, HasDatatypeInfo a, (All (All Editable `And` All NonEmpty) (Code 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 NonEmpty) 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@@ -388,17 +438,17 @@ instance Show Tag where show (Tag t) = init $ toFieldLabel t constructorEditorsFor- :: forall xx . (All (All Editable `And` All NonEmpty) xx)+ :: 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 NonEmpty)+ p = Proxy @ (All Editable `And` All HasEmpty) constructorEditorForUnion- :: (SListI xx, All Editable xs, All NonEmpty xs)+ :: (SListI xx, All Editable xs, All HasEmpty xs) => ConstructorInfo xs -> Injection (NP I) xx xs -> Projection (Compose Maybe (NP I)) xx xs@@ -409,24 +459,24 @@ composeEditor :: forall xss xs.- (SListI xss, All NonEmpty 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 :: SOP I xss -> NP I xs- f = fromMaybe def_np . getCompose . prj . K . hexpand (Compose Nothing) . hmap (Compose . Just) . unSOP+ f = fromMaybe emptyValue . getCompose . prj . K . hexpand (Compose Nothing) . hmap (Compose . Just) . unSOP -def_np :: (All NonEmpty xs) => NP I xs-def_np = hcpure (Proxy @ NonEmpty) gdef+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) -- Tuple editor without fields-instance All Editable xs => Editable (NP I xs) where+instance (All Editable xs, All HasEmpty xs) => Editable (NP I xs) where type EditorWidget (NP I xs) = Layout editor = horizontally $ hsequence $ hliftA Horizontally tupleEditor @@ -449,25 +499,3 @@ onHead f (x:xx) = f x : xx onHead _ [] = [] toFieldLabel _ = ""--------------------------------------- Generic default values--class NonEmpty2 (xs :: [k])-instance NonEmpty2 (x ': xs)--class ( Generic a- , NonEmpty2 (Code a)- , All NonEmpty (Head (Code a))- ) =>- NonEmpty a-instance ( Generic a- , NonEmpty2 (Code a)- , All NonEmpty (Head (Code a))- ) =>- NonEmpty a--gdef :: forall a. (NonEmpty a) => a-gdef = case sList :: SList (Code a) of- SCons -> to $ SOP $ Z $ hcpure (Proxy @ NonEmpty) (I gdef)- SNil -> error "unreachable"
src/Graphics/UI/Threepenny/Editors/Layout.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NamedFieldPuns #-}@@ -32,6 +35,7 @@ import Data.Biapplicative import Data.Bifoldable+import Data.HasEmpty import Data.Foldable (length) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map@@ -39,8 +43,9 @@ import Data.Monoid import Data.Sequence (Seq) import qualified Data.Sequence as Seq+import Generics.SOP.TH import GHC.Exts (IsList (..))-import Graphics.UI.Threepenny.Core as UI+import Graphics.UI.Threepenny.Core as UI hiding (empty) import Graphics.UI.Threepenny.Elements import Graphics.UI.Threepenny.Widgets @@ -67,12 +72,13 @@ instance Renderable String where render = string +-- | A rathe limited, grid layout builder, probably not fit for general purpose use yet. data Layout = Grid (Seq (Seq Layout)) -- ^ A non empty list of rows, where all the rows are assumed to have the same length | Cell (Maybe (UI Element)) -pattern Empty :: Layout-pattern Empty = Cell Nothing+pattern HasEmpty :: Layout+pattern HasEmpty = Cell Nothing pattern Single :: UI Element -> Layout pattern Single x = Cell (Just x)@@ -119,7 +125,7 @@ vertical = Vertical . getLayout instance Monoid Vertical where- mempty = Vertical Empty+ mempty = Vertical HasEmpty mappend (Vertical a) (Vertical b)= Vertical $ above a b instance Renderable Vertical where@@ -132,7 +138,7 @@ horizontal = Horizontal . getLayout instance Monoid Horizontal where- mempty = Horizontal Empty+ mempty = Horizontal HasEmpty mappend (Horizontal a) (Horizontal b)= Horizontal $ beside a b instance Renderable Horizontal where@@ -158,7 +164,7 @@ layoutColumns (Next l) = l layoutColumns (Break l) = l layoutColumns Columns{acc}- | Map.null acc = Empty+ | Map.null acc = HasEmpty | otherwise = getLayout $ foldMap Vertical@@ -199,6 +205,8 @@ instance (Renderable a, Renderable b) => Renderable (a |*| b) where getLayout (a :|*| b) = getLayout a `beside` getLayout b +instance (HasEmpty a, HasEmpty b) => HasEmpty (a |*| b) where emptyValue = emptyValue :|*| emptyValue+ -- | Type level Vertical layouts data a -*- b = a :-*- b @@ -214,3 +222,8 @@ instance (Renderable a, Renderable b) => Renderable (a -*- b) where getLayout (a :-*- b) = getLayout a `above` getLayout b++instance (HasEmpty a, HasEmpty b) => HasEmpty (a -*- b) where emptyValue = emptyValue :-*- emptyValue++deriveGeneric ''(|*|)+deriveGeneric ''(-*-)
src/Graphics/UI/Threepenny/Editors/Types.hs view
@@ -1,9 +1,10 @@+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RecursiveDo #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} {-# OPTIONS_GHC -Wno-duplicate-exports #-}@@ -30,21 +31,38 @@ , editorUnit , editorIdentity , editorString+ , editorText , editorCheckBox , editorReadShow , editorEnumBounded , editorSelection , editorSum , editorJust+ , EditorCollection(..)+ , editorCollection+ , editorList+ , EditorCollectionConfig(..)+ , defaultEditorCollectionConfig+ -- ** Representation of empty values+ , HasEmpty(..) ) where +import Control.Monad import Data.Biapplicative-import Data.Coerce+import Data.Maybe+import Data.HasEmpty+import qualified Data.Foldable as F import Data.Functor.Compose import Data.Functor.Identity+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Set (Set)+import qualified Data.Set as Set import Data.Profunctor+import Data.Text (Text)+import qualified Data.Text as Text import Graphics.UI.Threepenny.Attributes-import Graphics.UI.Threepenny.Core as UI+import Graphics.UI.Threepenny.Core as UI hiding (empty) import Graphics.UI.Threepenny.Editors.Layout import Graphics.UI.Threepenny.Editors.Utils import Graphics.UI.Threepenny.Elements@@ -102,9 +120,10 @@ bimapEditor g h = Editor . fmap (fmap (bimap g h)) . create dimapE :: (a' -> a) -> (b -> b') -> Editor a el b -> Editor a' el b'-dimapE g h (Editor f) = Editor $ dimap (fmap g) (fmapUIGW h) f+dimapE g h = unCoer . dimap (fmap g) h . coer where- fmapUIGW = coerce (fmap @ (Compose UI _))+ coer = Star . (Compose .) . create+ unCoer = Editor . fmap getCompose . runStar applyE :: (el1 -> el2 -> el) -> Editor in_ el1 (a -> b) -> Editor in_ el2 a -> Editor in_ el b applyE combineElements a b = Editor $ \s -> do@@ -213,6 +232,9 @@ return () return $ GenericWidget (userText t) t +editorText :: Editor Text TextEntry Text+editorText = dimapE Text.unpack Text.pack editorString+ editorReadShow :: (Read a, Show a) => Editor (Maybe a) TextEntry (Maybe a) editorReadShow = Editor $ \b -> do e <- create editorString (maybe "" show <$> b)@@ -268,3 +290,102 @@ editorIdentity :: Editor a el a -> Editor (Identity a) el (Identity a) editorIdentity = dimapE runIdentity Identity++--------------------------+-- EditorCollection++data EditorCollection k w = EditorCollection+ { selector :: ListBox k+ , add, remove :: Element+ , selected :: w+ }++instance Renderable w => Renderable (EditorCollection k w) where+ render EditorCollection{..} =+ column+ [row [ element selector, element add, element remove]+ ,render selected]++data EditorCollectionConfig k v = EditorCollectionConfig+ { eccNewKey :: Behavior k -- ^ Current value to use for creating a new key+ , eccAfterDelKey :: Behavior (Maybe k) -- ^ Current value to use if the selected key is deleted+ , eccTemplate :: v -- ^ Value to use for creating new items+ , eccOptions :: Behavior (Set k) -- ^ Currently user select able keys+ , eccDisplay :: Behavior (k -> UI Element) -- ^ How to render a key+ }++defaultEditorCollectionConfig+ :: (Enum k, Ord k, Show k, HasEmpty v)+ => Behavior (Maybe k, Map k v) -> EditorCollectionConfig k v+defaultEditorCollectionConfig db = EditorCollectionConfig+ { eccTemplate = emptyValue+ , eccOptions = options+ , eccDisplay = pure (UI.string . show)+ , eccNewKey = maybe (toEnum 0) succ . Set.lookupMax <$> options+ , eccAfterDelKey = deletedKey <$> (fst <$> db) <*> options+ }+ where+ options = Map.keysSet . snd <$> db++ deletedKey Nothing _ = Nothing+ deletedKey (Just k) kk = Set.lookupLT k kk `mplus` Set.lookupGT k kk++-- | A barebones editor for collections of editable items.+-- Displays an index selector, add and delete buttons, and an editor for the selected item.+-- Limitations:+-- - Won't work with recursive data structures, due to the lack of FRP switch.+editorCollection+ :: forall k v w.+ (Ord k, Renderable w)+ => (Behavior (Maybe k, Map k v) -> EditorCollectionConfig k v)+ -> Editor v w v+ -> Editor (Maybe k, Map k v) (EditorCollection k w) (Maybe k, Map k v)+editorCollection mkConfig editorOne = Editor $ \(ba :: Behavior (Maybe k, Map k v)) -> mdo+ let EditorCollectionConfig{..} = mkConfig ba+ (selectedKey, db) = (fst <$> ba, snd <$> ba)+ sel <- create (editorSelection (Set.toList <$> eccOptions) eccDisplay) (fst <$> ba)+ one <- create editorOne $ (\(k, db) -> fromMaybe eccTemplate (k >>= (`Map.lookup` db))) <$> ba+ addB <- button #+ [string "+"]+ remB <- button #+ [string "-"]+ let insert i = Map.insert i eccTemplate+ editsDb = head <$> unions+ [ replace <$> ba <@> edited one+ , insert <$> eccNewKey <*> db <@ click addB+ , delete <$> ba <@ click remB+ ]+ editsKey = head <$> unions+ [ edited sel+ , Just <$> eccNewKey <@ click addB+ , eccAfterDelKey <@ click remB+ ]+ tids = (,) <$> tidings selectedKey editsKey <*> tidings db editsDb+ return $ GenericWidget tids (EditorCollection (widgetControl sel) addB remB (widgetControl one))+ where+ replace (Just i,xx) x = Map.alter (const $ Just x) i xx+ replace (Nothing,x) _ = x+ delete (Just i,xx) = Map.delete i xx+ delete (_,xx) = xx++-- | A barebones editor for collections of editable items.+-- Displays an index selector, add and delete buttons, and an editor for the selected item.+-- Limitations:+-- - Won't work with recursive data structures, due to the lack of FRP switch.+editorList+ :: (HasEmpty a, Renderable w)+ => Editor a w a -> Editor (Maybe Int, [a]) (EditorCollection Int w) (Maybe Int, [a])+editorList e =+ dimapE (second (Map.fromAscList . zip [0 ..])) (second F.toList) $+ editorCollection config e+ where+ (<&>) = flip (<$>)+ infixl 1 <&>+ config ba =+ (defaultEditorCollectionConfig ba)+ { eccAfterDelKey =+ ba <&> (\(i,m) ->+ i >>= (\i ->+ if Map.member (i + 1) m+ then return i+ else let i' = max 0 (i - 1)+ in guard(i'>=0) >> return i'))+ }
src/Graphics/UI/Threepenny/Editors/Validation.hs view
@@ -2,7 +2,7 @@ @ -- update only if valid- value <- accumB def updateIfValid userEdits+ value <- accumB emptyValue updateIfValid userEdits -- collect validation warnings warnings <- stepper ok validate userEdits
threepenny-editors.cabal view
@@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack name: threepenny-editors-version: 0.5.5+version: 0.5.6 synopsis: Composable algebraic editors description: This package provides a type class 'Editable' and combinators to easily put together form-like editors for algebraic datatypes.@@ -43,7 +43,9 @@ , profunctors , threepenny-gui > 0.7 , casing+ , text exposed-modules:+ Data.HasEmpty Graphics.UI.Threepenny.Editors Graphics.UI.Threepenny.Editors.Layout Graphics.UI.Threepenny.Editors.Utils@@ -66,6 +68,7 @@ , profunctors , threepenny-gui > 0.7 , casing+ , text if flag(buildExamples) build-depends: threepenny-editors@@ -74,6 +77,28 @@ buildable: False default-language: Haskell2010 +executable crud2+ main-is: CRUD2.hs+ hs-source-dirs:+ examples+ ghc-options: -Wall -Wno-name-shadowing -main-is CRUD2+ build-depends:+ base >= 4.7 && < 5+ , bifunctors+ , containers+ , generics-sop+ , profunctors+ , threepenny-gui > 0.7+ , casing+ , text+ if flag(buildExamples)+ build-depends:+ threepenny-editors+ , containers+ else+ buildable: False+ default-language: Haskell2010+ executable parser main-is: Parser.hs hs-source-dirs:@@ -87,6 +112,7 @@ , profunctors , threepenny-gui > 0.7 , casing+ , text if flag(buildExamples) build-depends: threepenny-editors@@ -108,6 +134,28 @@ , profunctors , threepenny-gui > 0.7 , casing+ , text+ if flag(buildExamples)+ build-depends:+ threepenny-editors+ else+ buildable: False+ default-language: Haskell2010++executable person2+ main-is: Person2.hs+ hs-source-dirs:+ examples+ ghc-options: -Wall -Wno-name-shadowing -main-is Person2+ build-depends:+ base >= 4.7 && < 5+ , bifunctors+ , containers+ , generics-sop+ , profunctors+ , threepenny-gui > 0.7+ , casing+ , text if flag(buildExamples) build-depends: threepenny-editors