threepenny-editors 0.5.2 → 0.5.3
raw patch · 8 files changed
+368/−117 lines, 8 filesdep +template-haskelldep −lensdep ~basedep ~threepenny-guinew-component:exe:crudPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: template-haskell
Dependencies removed: lens
Dependency ranges changed: base, threepenny-gui
API changes (from Hackage documentation)
- Graphics.UI.Threepenny.Editors: [_widgetControl] :: GenericWidget control a -> control
- Graphics.UI.Threepenny.Editors: [_widgetTidings] :: GenericWidget control a -> Tidings a
- Graphics.UI.Threepenny.Editors: widgetControl :: forall control_asaT a_asaU control_asnj. Lens (GenericWidget control_asaT a_asaU) (GenericWidget control_asnj a_asaU) control_asaT control_asnj
- Graphics.UI.Threepenny.Editors: widgetTidings :: forall control_asaT a_asaU a_asnk. Lens (GenericWidget control_asaT a_asaU) (GenericWidget control_asaT a_asnk) (Tidings a_asaU) (Tidings a_asnk)
- Graphics.UI.Threepenny.Editors.Types: [_widgetControl] :: GenericWidget control a -> control
- Graphics.UI.Threepenny.Editors.Types: [_widgetTidings] :: GenericWidget control a -> Tidings a
- Graphics.UI.Threepenny.Editors.Types: editorFactoryElement :: Setter (Editor a el b) (Editor a el' b) el el'
- Graphics.UI.Threepenny.Editors.Types: editorFactoryInput :: Setter (Editor a el b) (Editor a' el b) a' a
- Graphics.UI.Threepenny.Editors.Types: editorFactoryOutput :: Setter (Editor a el b) (Editor a el b') b b'
- Graphics.UI.Threepenny.Editors.Types: widgetControl :: forall control_asaT a_asaU control_asnj. Lens (GenericWidget control_asaT a_asaU) (GenericWidget control_asnj a_asaU) control_asaT control_asnj
- Graphics.UI.Threepenny.Editors.Types: widgetTidings :: forall control_asaT a_asaU a_asnk. Lens (GenericWidget control_asaT a_asaU) (GenericWidget control_asaT a_asnk) (Tidings a_asaU) (Tidings a_asnk)
- Graphics.UI.Threepenny.Editors.Validation: Invalid :: String -> ValidationResult
- Graphics.UI.Threepenny.Editors.Validation: Ok :: ValidationResult
+ Graphics.UI.Threepenny.Editors: [widgetControl] :: GenericWidget control a -> control
+ Graphics.UI.Threepenny.Editors: [widgetTidings] :: GenericWidget control a -> Tidings a
+ Graphics.UI.Threepenny.Editors: class Validable a
+ Graphics.UI.Threepenny.Editors: data ValidationResult
+ Graphics.UI.Threepenny.Editors: edit :: (a' -> a) -> Editor a el b -> Editor a' el b
+ Graphics.UI.Threepenny.Editors: fromWarnings :: [String] -> ValidationResult
+ Graphics.UI.Threepenny.Editors: getLayoutGeneric :: forall a xs. (Generic a, HasDatatypeInfo a, All Renderable xs, Code a ~ '[xs]) => a -> [[Layout]]
+ Graphics.UI.Threepenny.Editors: getWarnings :: ValidationResult -> [String]
+ Graphics.UI.Threepenny.Editors: isValid :: Validable a => a -> Bool
+ Graphics.UI.Threepenny.Editors: ok :: ValidationResult
+ Graphics.UI.Threepenny.Editors: renderGeneric :: forall a xs. (Generic a, HasDatatypeInfo a, All Renderable xs, Code a ~ '[xs]) => a -> UI Element
+ Graphics.UI.Threepenny.Editors: updateIfValid :: Validable a => a -> a -> a
+ Graphics.UI.Threepenny.Editors: validate :: Validable a => a -> ValidationResult
+ Graphics.UI.Threepenny.Editors.Types: [widgetControl] :: GenericWidget control a -> control
+ Graphics.UI.Threepenny.Editors.Types: [widgetTidings] :: GenericWidget control a -> Tidings a
+ Graphics.UI.Threepenny.Editors.Validation: fromWarnings :: [String] -> ValidationResult
+ Graphics.UI.Threepenny.Editors.Validation: getWarnings :: ValidationResult -> [String]
+ Graphics.UI.Threepenny.Editors.Validation: ok :: ValidationResult
Files
- CHANGELOG.md +11/−0
- examples/CRUD.hs +149/−0
- examples/Parser.hs +1/−2
- examples/Person.hs +11/−35
- src/Graphics/UI/Threepenny/Editors.hs +76/−4
- src/Graphics/UI/Threepenny/Editors/Types.hs +41/−49
- src/Graphics/UI/Threepenny/Editors/Validation.hs +33/−5
- threepenny-editors.cabal +46/−22
CHANGELOG.md view
@@ -1,3 +1,14 @@+# 0.5.3 (2017-08-28)+ * Generic derivation for `render`.+ * Dropped dependency on the lens package.+ * Added a new example CRUD exercising the Biapplicative interface.+ * Fixed building of examples with Cabal 2.+ * Changes to the validation module type signatures.+# 0.5.2 (2017-08-13)+ * Name changes:+ - `EditorFactory` is now `Editor`.+ - `Editor` is now `GenericWidget`.+ * Added a module with utilities for doing data validation. # 0.5.1 (2017-07-30) * Fix a build issue with GHC 8.2.1 # 0.5.0 (2017-07-30)
+ examples/CRUD.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DeriveGeneric #-}+{-----------------------------------------------------------------------------+ Example from threepenny-gui extended with Editors:++ Small database with CRUD operations and filtering.+ To keep things simple, the list box is rebuild every time+ that the database is updated. This is perfectly fine for rapid prototyping.+ A more sophisticated approach would use incremental updates.+------------------------------------------------------------------------------}+{-# LANGUAGE RecursiveDo #-}+module CRUD (main) where+import Prelude hiding (lookup)+import Control.Monad (void)+import Data.Biapplicative+import Data.List (isPrefixOf)+import Data.Maybe+import qualified Data.Map as Map+import Generics.SOP.TH++import qualified Graphics.UI.Threepenny as UI+import Graphics.UI.Threepenny.Editors hiding (create)+import qualified Graphics.UI.Threepenny.Editors as Editors+import Graphics.UI.Threepenny.Core hiding (delete)++{-----------------------------------------------------------------------------+ Main+------------------------------------------------------------------------------}+main :: IO ()+main = startGUI defaultConfig setup++setup :: Window -> UI ()+setup window = void $ mdo+ return window # set title "CRUD Example (Simple)"++ -- GUI elements+ createBtn <- UI.button #+ [string "Create"]+ deleteBtn <- UI.button #+ [string "Delete"]+ listBox <- UI.listBox bListBoxItems bSelection bDisplayDataItem+ filterEntry <- UI.entry bFilterString+ dataItem <- Editors.create editor (fromMaybe (DataItem "" "") <$> bSelectionDataItem)++ -- GUI layout+ element listBox # set (attr "size") "10" # set style [("width","200px")]++ let glue = string " "+ getBody window #+ [grid+ [[row [string "Filter prefix:", element filterEntry], glue]+ ,[element listBox, render dataItem]+ ,[row [element createBtn, element deleteBtn], glue]+ ]]++ -- events and behaviors+ bFilterString <- stepper "" . rumors $ UI.userText filterEntry+ let tFilter = isPrefixOf <$> UI.userText filterEntry+ bFilter = facts tFilter+ eFilter = rumors tFilter++ let eSelection = rumors $ UI.userSelection listBox+ eDataItemIn = edited dataItem+ eCreate = UI.click createBtn+ eDelete = UI.click deleteBtn++ -- database+ -- bDatabase :: Behavior (Database DataItem)+ let update' mkey x = flip update x <$> mkey+ bDatabase <- accumB emptydb $ concatenate <$> unions+ [ create (DataItem "Emil" "Example") <$ eCreate+ , filterJust $ update' <$> bSelection <@> eDataItemIn+ , delete <$> filterJust (bSelection <@ eDelete)+ ]++ -- selection+ -- bSelection :: Behavior (Maybe DatabaseKey)+ bSelection <- stepper Nothing $ head <$> unions+ [ eSelection+ , Nothing <$ eDelete+ , Just . nextKey <$> bDatabase <@ eCreate+ , (\b s p -> b >>= \a -> if p (s a) then Just a else Nothing)+ <$> bSelection <*> bShowDataItem <@> eFilter+ ]++ let bLookup :: Behavior (DatabaseKey -> Maybe DataItem)+ bLookup = flip lookup <$> bDatabase++ bShowDataItem :: Behavior (DatabaseKey -> String)+ bShowDataItem = (maybe "" showDataItem .) <$> bLookup++ bDisplayDataItem = (UI.string .) <$> bShowDataItem++ bListBoxItems :: Behavior [DatabaseKey]+ bListBoxItems = (\p show -> filter (p. show) . keys)+ <$> bFilter <*> bShowDataItem <*> bDatabase++ bSelectionDataItem :: Behavior (Maybe DataItem)+ bSelectionDataItem = (=<<) <$> bLookup <*> bSelection++ -- automatically enable / disable editing+ let+ bDisplayItem :: Behavior Bool+ bDisplayItem = isJust <$> bSelection++ element deleteBtn # sink UI.enabled bDisplayItem+ element (firstName $ widgetControl dataItem) # sink UI.enabled bDisplayItem+ element (lastName $ widgetControl dataItem) # sink UI.enabled bDisplayItem+++{-----------------------------------------------------------------------------+ Database Model+------------------------------------------------------------------------------}+type DatabaseKey = Int+data Database a = Database { nextKey :: !Int, db :: Map.Map DatabaseKey a }++emptydb = Database 0 Map.empty+keys = Map.keys . db++create x (Database newkey db) = Database (newkey+1) $ Map.insert newkey x db+update key x (Database newkey db) = Database newkey $ Map.insert key x db+delete key (Database newkey db) = Database newkey $ Map.delete key db+lookup key (Database _ db) = Map.lookup key db++{-----------------------------------------------------------------------------+ Data items that are stored in the data base+------------------------------------------------------------------------------}+data DataItemDual (usage :: Usage) = DataItem+ { firstName, lastName :: Field usage String+ }++showDataItem :: DataItem -> String+showDataItem DataItem{..} = lastName ++ ", " ++ firstName++type DataItem = DataItemDual Value+type DataItemEditor = DataItemDual Edit++instance Editable DataItem where+ type EditorWidget DataItem = DataItemEditor+ editor = bipure DataItem DataItem+ <<*>> edit firstName editor+ <<*>> edit lastName editor++deriveGeneric ''DataItemDual+instance Renderable DataItemEditor where+ render = renderGeneric
examples/Parser.hs view
@@ -1,7 +1,6 @@ {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# LANGUAGE RecursiveDo #-}--module Main(main) where+module Parser(main) where import qualified Graphics.UI.Threepenny as UI import Graphics.UI.Threepenny.Core
examples/Person.hs view
@@ -10,6 +10,7 @@ {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}+module Person (main) where import Control.Monad import Data.Biapplicative import Data.Default@@ -18,8 +19,6 @@ import GHC.Generics (Generic) import Graphics.UI.Threepenny.Core import Graphics.UI.Threepenny.Editors-import Graphics.UI.Threepenny.Editors.Types-import Graphics.UI.Threepenny.Editors.Validation import Graphics.UI.Threepenny.Elements import Prelude hiding (span) @@ -40,11 +39,10 @@ type PersonEditor = PersonF Edit instance Validable Person where- validate Person{..}- | null firstName = Invalid "First name cannot be null"- | null lastName = Invalid "Last name cannot be null"- | Just x <- age, x <= 0 = Invalid "Age must be a natural number"- | otherwise = Ok+ validate Person{..} = fromWarnings $ + [ "First name cannot be null" | null firstName ] +++ [ "Last name cannot be null" | null lastName ] +++ [ "Age must be a natural number" | Just x <- [age], x <= 0] data LegalStatus = Single@@ -102,23 +100,6 @@ instance SOP.Generic Person instance Default Person where def = Person Basic "First" "Last" (Just 18) def def --- | An editor for 'Person' values that combines the 'Horizontal' and 'Vertical' layout builders-editorPersonHV :: Editor Person Vertical Person-editorPersonHV = do- (firstName, lastName) <- withLayout Vertical $ construct $ do- firstName <- fieldLayout Horizontal "First:" firstName editor- lastName <- fieldLayout Horizontal "Last:" lastName editor- return (firstName, lastName)- (age, education) <- withLayout Vertical $ construct $ do- age <- fieldLayout Horizontal "Age:" age editor- education <- fieldLayout Horizontal "Education:" education editorEducation- return (age, education)- (status, brexiteer) <- withLayout Vertical $ construct $ do- status <- fieldLayout Horizontal "Status" status (withSomeWidget $ editorJust $ editorSelection (pure [minBound..]) (pure (string.show)))- brexiteer <- fieldLayout Horizontal "Brexiter" brexiteer editor- return (status, brexiteer)- return Person{..}- -- | An editor for 'Person' values that uses the 'Columns' layout builder editorPersonColumns :: Editor Person Columns Person editorPersonColumns = do@@ -160,31 +141,26 @@ setup :: Window -> UI () setup w = void $ mdo _ <- return w # set title "Threepenny editors example"- person1HV <- create editorPersonHV person1B person1C <- create editorPersonColumns person1B person2 <- create editorGeneric person1B person3e <- create personEditor person1B -- When using a biapplicative editor, we can set the attributes of the field editors after creation.- _ <- element (firstName (_widgetControl person3e)) # set style [("background-color", "Blue")]+ _ <- element (firstName (widgetControl person3e)) # set style [("background-color", "Blue")] person1B <- accumB def (updateIfValid . head <$> unions- [ edited person1HV- , edited person1C+ [ edited person1C , edited person2 , edited person3e ]) -- We can attach validation to any editor validation <-- stepper Ok (validate . head <$>- unions [ edited person1HV- , edited person1C- , edited person2- , edited person3e])+ stepper ok (validate . head <$>+ unions [ edited person1C+ , edited person2+ , edited person3e]) getBody w #+ [grid [ [span # sink text (show <$> validation) # set style [("color", "red")]]- , [render person1HV]- , [hr] , [render person1C] , [hr] , [render person2]
src/Graphics/UI/Threepenny/Editors.hs view
@@ -27,6 +27,7 @@ , Editor(Horizontally, horizontally, Vertically, vertically) , someEditor , create+ , edit , lmapE , dimapE , Editable(..)@@ -66,8 +67,18 @@ -- ** Type level layouts , type (|*|)(..) , type (-*-)(..)- -- ** Layout manipulation+ -- ** Custom layout definition , Renderable(..)+ , renderGeneric+ , getLayoutGeneric+ -- * Validation+ , Validable(..)+ , ValidationResult+ , ok+ , fromWarnings+ , getWarnings+ , isValid+ , updateIfValid ) where import Data.Biapplicative@@ -76,6 +87,7 @@ import Data.Functor.Compose import Data.Functor.Identity import Data.Maybe+import qualified Data.Sequence as Seq import Generics.SOP hiding (Compose) import Graphics.UI.Threepenny.Core as UI import Graphics.UI.Threepenny.Widgets@@ -83,6 +95,7 @@ import Graphics.UI.Threepenny.Editors.Layout import Graphics.UI.Threepenny.Editors.Types+import Graphics.UI.Threepenny.Editors.Validation -- | The class of 'Editable' datatypes. -- .@@ -157,9 +170,68 @@ type EditorWidget (Identity a) = EditorWidget a editor = editorIdentity editor -{--------------------------------------------- Generic derivations----------------------------------------------}+{----------------------------------------------+ Generic derivations for Renderable datatypes+-----------------------------------------------}+-- | A generic implementation of 'render' for data types with a single constructor+-- which renders the (labelled) fields in a vertical layout.+-- For custom layouts use `getLayoutGeneric`.+--+-- /e.g./ given the declarations+--+-- @+-- data PersonEditor = PersonEditor { firstName, lastName :: EditorWidget String }+-- deriveGeneric ''PersonEditor+-- @+--+-- using `renderGeneric` to instantiate `Renderable`+--+-- @+-- instance Renderable PersonEditor where+-- getLayout = renderGeneric+-- @+--+-- will be equivalent to writing the below by hand+--+-- @+-- instance Renderable PersonEditor where+-- getLayout PersonEditor{..} =+-- grid [ [string "First name:", element firstName]+-- , [string "Last name:", element lastName ]+-- ]+-- @++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++-- | A helper to implement `getLayout` for data types with a single constructor.+-- Given a value, `getLayoutGeneric` returns a grid of `Layout`s with one row per field.+-- Rows can carry one element, for unnamed fields; two elements, for named fields; or three elements, for operators.+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]++{----------------------------------------------+ Generic derivations for Applicative Editables+-----------------------------------------------} -- | A generic editor for record types. editorGenericSimple :: forall a xs.
src/Graphics/UI/Threepenny/Editors/Types.hs view
@@ -1,9 +1,10 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} {-# OPTIONS_GHC -Wno-duplicate-exports #-} @@ -20,9 +21,6 @@ , dimapE , lmapE , applyE- , editorFactoryElement- , editorFactoryInput- , editorFactoryOutput -- ** GenericWidget composition , (|*|), (|*), (*|) , (-*-), (-*), (*-)@@ -46,11 +44,11 @@ , construct ) where -import Control.Applicative-import Control.Lens hiding (beside, children,- element, set, ( # )) import Data.Biapplicative+import Data.Coerce import Data.Functor.Compose+import Data.Functor.Identity+import Data.Profunctor import Graphics.UI.Threepenny.Attributes import Graphics.UI.Threepenny.Core as UI import Graphics.UI.Threepenny.Editors.Layout@@ -62,58 +60,51 @@ -- | A widget for editing values of type @a@. data GenericWidget control a = GenericWidget- { _widgetTidings :: Tidings a- , _widgetControl :: control+ { widgetTidings :: Tidings a+ , widgetControl :: control } deriving Functor -makeLenses ''GenericWidget- instance Bifunctor GenericWidget where bimap f g (GenericWidget t e) = GenericWidget (g <$> t) (f e) +traverseControl :: Applicative f => (control -> f control') -> GenericWidget control a -> f (GenericWidget control' a)+traverseControl f (GenericWidget t e) = GenericWidget t <$> f e+ edited :: GenericWidget el a -> Event a-edited = rumors . _widgetTidings+edited = rumors . widgetTidings contents :: GenericWidget el a -> Behavior a-contents = facts . _widgetTidings+contents = facts . widgetTidings instance Widget el => Widget (GenericWidget el a) where- getElement = getElement . _widgetControl+ getElement = getElement . widgetControl instance Renderable el => Renderable (GenericWidget el a) where- render = render . _widgetControl+ render = render . widgetControl renderEditor :: Renderable w => GenericWidget w a -> UI (GenericWidget Element a)-renderEditor = mapMOf widgetControl render- where- mapMOf l cmd = unwrapMonad . l (WrapMonad . cmd)+renderEditor = traverseControl render --- | A function from 'Behavior' @a@ to 'GenericWidget' @b@+-- | A widget @el@ for editing @b@ values while displaying @a@ values.+-- For obvious reasons, @a@ and @b@ are usually the same type, except while composing editors. -- All the three type arguments are functorial, but @a@ is contravariant.--- 'Editor' is a 'Biapplicative' functor on @el@ and @b@, and--- a 'Profunctor' on @a@ and @b@.+-- 'Editor' is a 'Biapplicative' functor on @el@ and @b@, and a 'Profunctor' on @a@ and @b@.+--+-- Editors compose using the Applicative interface when @el@ is monoidal+-- or more generally with the Biapplicative interface. In both cases the+-- Profunctor 'lmap' is used to select the value to display.+--+-- For an example of the Applicative interface, let's assemble the editor for a tuple of values:+--+-- > editorTuple = (,) <$> lmap fst editable <*> lmap snd editable+ newtype Editor a el b = Editor { -- | Create an editor to display the argument. -- User edits are fed back via the 'edited' 'Event'. create :: Behavior a -> UI (GenericWidget el b) } -_Editor :: Iso (Editor a el b) (Editor a' el' b') (Behavior a -> UI (GenericWidget el b)) (Behavior a' -> UI (GenericWidget el' b'))-_Editor = iso create Editor---- | A 'Setter' over the element of the editor being built-editorFactoryElement :: Setter (Editor a el b) (Editor a el' b) el el'-editorFactoryElement = _Editor.mapped.mapped.widgetControl---- | A 'Setter' over the input thing-editorFactoryInput :: Setter (Editor a el b) (Editor a' el b) a' a-editorFactoryInput = _Editor.argument.mapped---- | A 'Setter' over the output thing-editorFactoryOutput :: Setter (Editor a el b) (Editor a el b') b b'-editorFactoryOutput = _Editor.mapped.mapped.mapped- -- | Lift an HTML element into a vacuous editor. liftElement :: UI el -> Editor a el () liftElement el = Editor $ \_ -> GenericWidget (pure ()) <$> el@@ -122,14 +113,15 @@ 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 $ \b -> getCompose $ h <$> Compose (f (g <$> b))+dimapE g h (Editor f) = Editor $ dimap (fmap g) (fmapUIGW h) f+ where+ fmapUIGW = coerce (fmap @ (Compose UI _)) -- | Applies a function over the input lmapE :: (a' -> a) -> Editor a el b -> Editor a' el b lmapE f = dimapE f id --- | Focus the editor on the field retrieved by the getter.--- Use when composing editors via the Biapplicative interface+-- | Use when composing Biapplicative editors to focus on a field. -- -- > personEditor :: Editor Person PersonEditor Person -- > personEditor =@@ -144,7 +136,7 @@ applyE combineElements a b = Editor $ \s -> do a <- create a s b <- create b s- return $ GenericWidget (_widgetTidings a <*> _widgetTidings b) (_widgetControl a `combineElements` _widgetControl b)+ return $ GenericWidget (widgetTidings a <*> widgetTidings b) (widgetControl a `combineElements` widgetControl b) instance Functor (Editor a el) where fmap = dimapE id@@ -191,7 +183,7 @@ -- | Apply a layout builder. withLayout :: (layout -> layout') -> Editor a layout b -> Editor a layout' b-withLayout = over editorFactoryElement+withLayout f = bimap f id -- | Construct a concrete 'Layout'. Useful when combining heterogeneours layout builders. construct :: Renderable m => Editor a m b -> Editor a Layout b@@ -257,7 +249,7 @@ let readIt "" = Nothing readIt x = readMaybe x let t = tidings b (readIt <$> edited e)- return $ GenericWidget t (_widgetControl e)+ return $ GenericWidget t (widgetControl e) -- An editor that presents a choice of values. editorEnumBounded@@ -278,7 +270,7 @@ editorJust (Editor editor) = Editor $ \b -> do e <- editor (Just <$> b) let ev = filterJust (edited e)- return $ GenericWidget (tidings b ev) (_widgetControl e)+ return $ GenericWidget (tidings b ev) (widgetControl e) -- | An editor for union types, built from editors for its constructors. editorSum@@ -293,7 +285,7 @@ l <- listBox (pure $ fmap fst options) (Just <$> tag) (pure (string . show)) -- a placeholder for the constructor editor nestedEditor <-- new # sink children ((\x -> [maybe (error "editorSum") _widgetControl (build x)]) <$> tag')+ new # sink children ((\x -> [maybe (error "editorSum") widgetControl (build x)]) <$> tag') -- let composed = combineLayout (Single (return $ getElement l)) (Single $ return nestedEditor) -- the result event fires when any of the nested editors or the tag selector fire.
src/Graphics/UI/Threepenny/Editors/Validation.hs view
@@ -1,21 +1,49 @@+{- | Simple helpers to perform validation of user input.++ @+ -- update only if valid+ value <- accumB def updateIfValid userEdits++ -- collect validation warnings+ warnings <- stepper ok validate userEdits+ @+-}+ module Graphics.UI.Threepenny.Editors.Validation- ( ValidationResult(..)+ ( ValidationResult+ , ok+ , fromWarnings+ , getWarnings , Validable(..) , isValid , updateIfValid ) where -data ValidationResult = Ok | Invalid String+newtype ValidationResult = ValidationResult [String]++-- | All is good+ok :: ValidationResult+ok = ValidationResult []++-- | Create a validation result from a list of warnings.+--+-- > fromWarnings [] = ok+fromWarnings :: [String] -> ValidationResult+fromWarnings = ValidationResult++getWarnings :: ValidationResult -> [String]+getWarnings (ValidationResult ww) = ww+ instance Show ValidationResult where- show Ok = ""- show (Invalid msg) = msg+ show = unlines . getWarnings +-- | The class of values that support validation. class Validable a where validate :: a -> ValidationResult isValid :: Validable a => a -> Bool isValid x- | Ok <- validate x = True+ | ValidationResult [] <- validate x = True | otherwise = False updateIfValid :: Validable a => a -> a -> a
threepenny-editors.cabal view
@@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack name: threepenny-editors-version: 0.5.2+version: 0.5.3 synopsis: Composable algebraic editors description: This package provides a type class 'Editable' and combinators to easily put together form-like editors for algebraic datatypes.@@ -41,10 +41,10 @@ , containers , data-default , generics-sop- , lens , profunctors , threepenny-gui > 0.7 , casing+ , template-haskell exposed-modules: Graphics.UI.Threepenny.Editors Graphics.UI.Threepenny.Editors.Layout@@ -55,43 +55,67 @@ Paths_threepenny_editors default-language: Haskell2010 +executable crud+ main-is: CRUD.hs+ hs-source-dirs:+ examples+ ghc-options: -Wall -Wno-name-shadowing -main-is CRUD+ build-depends:+ base >= 4.7 && < 5+ , bifunctors+ , containers+ , data-default+ , generics-sop+ , profunctors+ , threepenny-gui > 0.7+ , casing+ if flag(buildExamples)+ build-depends:+ threepenny-editors+ , containers+ else+ buildable: False+ default-language: Haskell2010+ executable parser main-is: Parser.hs hs-source-dirs: examples- ghc-options: -Wall -Wno-name-shadowing+ ghc-options: -Wall -Wno-name-shadowing -main-is Parser+ build-depends:+ base >= 4.7 && < 5+ , bifunctors+ , containers+ , data-default+ , generics-sop+ , profunctors+ , threepenny-gui > 0.7+ , casing if flag(buildExamples) build-depends:- base- , bifunctors- , data-default- , generics-sop- , profunctors- , threepenny-gui- , threepenny-editors+ threepenny-editors , haskell-src-exts else buildable: False- other-modules:- Person default-language: Haskell2010 executable person main-is: Person.hs hs-source-dirs: examples- ghc-options: -Wall -Wno-name-shadowing+ ghc-options: -Wall -Wno-name-shadowing -main-is Person+ build-depends:+ base >= 4.7 && < 5+ , bifunctors+ , containers+ , data-default+ , generics-sop+ , profunctors+ , threepenny-gui > 0.7+ , casing if flag(buildExamples) build-depends:- base- , bifunctors- , data-default- , generics-sop- , profunctors- , threepenny-gui- , threepenny-editors+ threepenny-editors else buildable: False- other-modules:- Parser default-language: Haskell2010