threepenny-editors 0.5.1 → 0.5.2

raw patch · 6 files changed

+328/−169 lines, 6 filesdep +haskell-src-extsdep ~basedep ~threepenny-guinew-component:exe:parserPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: haskell-src-exts

Dependency ranges changed: base, threepenny-gui

API changes (from Hackage documentation)

Files

• examples/Parser.hs +86/−0
• examples/Person.hs +37/−17
• src/Graphics/UI/Threepenny/Editors.hs +40/−37
• src/Graphics/UI/Threepenny/Editors/Types.hs +116/−114
• src/Graphics/UI/Threepenny/Editors/Validation.hs +24/−0
• threepenny-editors.cabal +25/−1

@@ -0,0 +1,86 @@+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# LANGUAGE RecursiveDo #-}++module Main(main) where++import qualified Graphics.UI.Threepenny         as UI+import           Graphics.UI.Threepenny.Core+import           Graphics.UI.Threepenny.Editors++import           Control.Monad+import           Data.Maybe+import           Language.Haskell.Exts+++{-----------------------------------------------------------------------------+    Main+------------------------------------------------------------------------------}+main :: IO ()+main = startGUI defaultConfig setup++example :: String+example = unlines+    ["module Main(main) where"+    ,""+    ,"main :: IO ()"+    ,"main = putStrLn \"Hello World!\""+    ]+++parser :: ParseMode -> String -> String+parser mode x = case parseFileContentsWithMode mode x of+    ParseOk x       -> show $ Control.Monad.void x+    x@ParseFailed{} -> show x+++pMode :: UI (Element, Behavior ParseMode)+pMode = do+    filename <- UI.input+    language <- UI.select+        #+ [UI.option # set text (show x) | x <- knownLanguages]+        # set UI.selection (Just 0)+    ignore <- UI.input # set (attr "type") "checkbox"++    layout <- grid+        [[string "Filename", element filename]+        ,[string "Language", element language]+        ,[string "Ignore pragmas", element ignore]]++    filename <- stepper "" $ UI.valueChange filename+    language <- fmap (fmap ((!!) knownLanguages . fromMaybe 0)) $ stepper Nothing $ UI.selectionChange language+    ignore <- stepper False $ UI.checkedChange ignore++    let val = (\f l i -> defaultParseMode{parseFilename=f, baseLanguage=l, ignoreLanguagePragmas=i}) <$>+            filename <*> language <*> ignore+    return (layout, val)++pModeEditor :: Editor ParseMode Layout ParseMode+pModeEditor =+  (\f l i  -> defaultParseMode{parseFilename=f, baseLanguage=l, ignoreLanguagePragmas=i})+    <$> field "Filename" parseFilename editor+    -*- field "Language" baseLanguage (editorJust $ editorSelection (pure knownLanguages) (pure (string . show)))+    -*- field "Ignore pragmas" ignoreLanguagePragmas editor++pMode' :: UI (UI Element, Behavior ParseMode)+pMode' = mdo+  parseModeE <- create pModeEditor parseModeB+  parseModeB <- stepper defaultParseMode (edited parseModeE)+  return (render parseModeE, parseModeB)++setup :: Window -> UI ()+setup window = void $ do+    _ <- return window # set title "HSE parser"+    mode <- pMode+    mode2 <- pMode'++    source <- UI.textarea+        # set UI.style [("width","600px"),("height","250px")]+        # set value example+    sourceVal <- stepper example $ UI.valueChange source++    output <- UI.textarea+        # set UI.style [("width","600px"),("height","250px")]+        # set (attr "readonly") "readonly"+        # sink value (parser <$> snd mode <*> sourceVal)++    getBody window #+ [row [column [element source, element output], element $ fst mode, fst mode2]]

@@ -14,12 +14,14 @@ import           Data.Biapplicative import           Data.Default import           Data.Maybe-import qualified Generics.SOP                         as SOP-import           GHC.Generics+import qualified Generics.SOP                              as SOP+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)  main :: IO () main = startGUI defaultConfig setup@@ -37,6 +39,13 @@ type Person = PersonF Value 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+ data LegalStatus   = Single   | Married@@ -63,7 +72,7 @@  -- | A manually defined editor for 'Education'. --   It is also possible to derive this 'Editor' via Generics.SOP, as done below.-editorEducation :: EditorFactory Education Layout Education+editorEducation :: Editor Education Layout Education editorEducation = do     let selector x = case x of             Other _ -> "Other"@@ -71,7 +80,7 @@     editorSum beside       [ ("Basic", const Basic <$> withSomeWidget editorUnit)       , ("Intermediate", const Intermediate <$> withSomeWidget editorUnit)-      , ("Other", dimapEF (fromMaybe "" . getOther) Other someEditor)+      , ("Other", dimapE (fromMaybe "" . getOther) Other someEditor)       ]       selector @@ -94,7 +103,7 @@ 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 :: EditorFactory Person Vertical Person+editorPersonHV :: Editor Person Vertical Person editorPersonHV = do   (firstName, lastName) <- withLayout Vertical $ construct $ do       firstName <- fieldLayout Horizontal "First:"     firstName editor@@ -111,7 +120,7 @@   return Person{..}  -- | An editor for 'Person' values that uses the 'Columns' layout builder-editorPersonColumns :: EditorFactory Person Columns Person+editorPersonColumns :: Editor Person Columns Person editorPersonColumns = do       firstName <- fieldLayout Next "First:"     firstName editor       lastName  <- fieldLayout Next "Last:"      lastName editor@@ -124,7 +133,7 @@  -- | A editor for 'Person' values with a fully fledged Widget type. --   The UI and layout are defined in the 'Renderable' instance for the widget.-personEditor :: EditorFactory Person PersonEditor Person+personEditor :: Editor Person PersonEditor Person personEditor =     bipure Person Person       <<*>> edit education editor@@ -151,24 +160,35 @@ setup :: Window -> UI () setup w = void $ mdo   _ <- return w # set title "Threepenny editors example"-  person1HV <- createEditor editorPersonHV person1B-  person1C <- createEditor editorPersonColumns person1B-  person2 <- createEditor editorGeneric person1B-  person3 <- createEditor personEditor person1B-  person1B <- stepper def (head <$> unions+  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")]+  person1B <- accumB def (updateIfValid . head <$> unions                             [ edited person1HV                             , edited person1C                             , edited person2-                            , edited person3+                            , edited person3e                             ]) +  -- We can attach validation to any editor+  validation <-+      stepper Ok (validate . head <$>+                  unions [ edited person1HV+                          , edited person1C+                          , edited person2+                          , edited person3e])+   getBody w #+ [grid-    [ [return $ _editorElement person1HV]+    [ [span # sink text (show <$> validation) # set style [("color", "red")]]+    , [render person1HV]     , [hr]-    , [return $ _editorElement person1C]+    , [render person1C]     , [hr]-    , [return $ _editorElement person2]+    , [render person2]     , [hr]-    , [return $ _editorElement person3]+    , [render person3e]     , [hr]     ]]

@@ -17,15 +17,18 @@ {-# OPTIONS_GHC -Wno-duplicate-exports  #-}  module Graphics.UI.Threepenny.Editors-  ( -- * Editors-    Editor(..)+  ( -- * Widgets+    GenericWidget(..)   , edited   , contents-  , editorElement-    -- * Editor factories-  , EditorFactory(Horizontally, horizontally, Vertically, vertically)+  , widgetControl+  , widgetTidings+    -- * Editors+  , Editor(Horizontally, horizontally, Vertically, vertically)   , someEditor-  , createEditor+  , create+  , lmapE+  , dimapE   , Editable(..)   , EditorWidgetFor(..)   , Field@@ -89,16 +92,16 @@   type family EditorWidget a   type EditorWidget a = Layout   -- | The editor factory-  editor :: EditorFactory a (EditorWidget a) a-  default editor :: (Generic a, HasDatatypeInfo a, (All (All Editable `And` All Default) (Code a)), EditorWidget a ~ Layout) => EditorFactory a (EditorWidget a) a+  editor :: Editor a (EditorWidget a) a+  default editor :: (Generic a, HasDatatypeInfo a, (All (All Editable `And` All Default) (Code a)), EditorWidget a ~ Layout) => Editor a (EditorWidget a) a   editor = editorGeneric  -- | Conceal the widget type of some 'Editor'-withSomeWidget :: Renderable w => EditorFactory a w b -> EditorFactory a Layout b+withSomeWidget :: Renderable w => Editor a w b -> Editor a Layout b withSomeWidget = first getLayout  -- | A version of 'editor' with a concealed widget type.-someEditor :: Editable a => EditorFactory a Layout a+someEditor :: Editable a => Editor a Layout a someEditor = withSomeWidget editor  -- | A container for 'EditorWidget'.@@ -148,7 +151,7 @@  instance (Editable a, Editable b) => Editable (a,b) where   type EditorWidget (a,b) = EditorWidget a |*| EditorWidget b-  editor = bipure (:|*|) (,) <<*>> lmapEF fst editor <<*>> lmapEF snd editor+  editor = bipure (:|*|) (,) <<*>> lmapE fst editor <<*>> lmapE snd editor  instance Editable a => Editable (Identity a) where   type EditorWidget (Identity a) = EditorWidget a@@ -161,38 +164,38 @@ editorGenericSimple   :: forall a xs.      (Generic a, HasDatatypeInfo a, All Editable xs, Code a ~ '[xs])-  => EditorFactory a Layout a-editorGenericSimple = dimapEF from to $ editorGenericSimple' (datatypeInfo(Proxy @ a))+  => Editor a Layout a+editorGenericSimple = dimapE from to $ editorGenericSimple' (datatypeInfo(Proxy @ a))  editorGenericSimple'   :: forall xs.      (All Editable xs)-  => DatatypeInfo '[xs] -> EditorFactory (SOP I '[xs]) Layout (SOP I '[xs])+  => DatatypeInfo '[xs] -> Editor (SOP I '[xs]) Layout (SOP I '[xs]) editorGenericSimple' (ADT _ _ (c :* Nil)) = constructorEditorFor c editorGenericSimple' (Newtype _ _ c)      = constructorEditorFor c  constructorEditorFor   :: (All Editable xs)   => ConstructorInfo xs-  -> EditorFactory (SOP I '[xs]) Layout (SOP I '[xs])-constructorEditorFor (Record _ fields) = dimapEF (unZ . unSOP) (SOP . Z) $ constructorEditorFor' fields-constructorEditorFor (Constructor _) = dimapEF (unZ . unSOP) (SOP . Z) someEditor-constructorEditorFor Infix{} = dimapEF (unZ . unSOP) (SOP . Z) someEditor+  -> Editor (SOP I '[xs]) Layout (SOP I '[xs])+constructorEditorFor (Record _ fields) = dimapE (unZ . unSOP) (SOP . Z) $ constructorEditorFor' fields+constructorEditorFor (Constructor _) = dimapE (unZ . unSOP) (SOP . Z) someEditor+constructorEditorFor Infix{} = dimapE (unZ . unSOP) (SOP . Z) someEditor  -- | A generic editor for SOP types. editorGeneric   :: forall a .      (Generic a, HasDatatypeInfo a, (All (All Editable `And` All Default) (Code a)))-  => EditorFactory a Layout a-editorGeneric = dimapEF from to $ editorGeneric' (datatypeInfo(Proxy @ a))+  => Editor a Layout a+editorGeneric = dimapE from to $ editorGeneric' (datatypeInfo(Proxy @ a))  editorGeneric'   :: forall xx.      (All (All Editable `And` All Default) xx)-  => DatatypeInfo xx -> EditorFactory (SOP I xx) Layout (SOP I 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-  editors :: [(Tag, EditorFactory (SOP I xx) Layout (SOP I xx))]+  editors :: [(Tag, Editor (SOP I xx) Layout (SOP I xx))]   editors = first Tag <$> constructorEditorsFor cc   constructors = hmap (K . constructorName) cc   constructor a = Tag $ hcollapse $ hliftA2 const constructors (unSOP a)@@ -203,7 +206,7 @@  constructorEditorsFor   :: forall xx . (All (All Editable `And` All Default) xx)-  => NP ConstructorInfo xx -> [(String, EditorFactory (SOP I xx) Layout (SOP I 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)@@ -216,24 +219,24 @@   => ConstructorInfo xs   -> Injection (NP I) xx xs   -> Projection (Compose Maybe (NP I)) xx xs-  -> K (EditorFactory (SOP I xx) Layout (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+  -> K (Editor (SOP I xx) Layout (SOP I xx)) xs+constructorEditorForUnion (Constructor _) inj prj = K $ composeEditor inj prj editor+constructorEditorForUnion Infix{} inj prj = K $ composeEditor inj prj editor+constructorEditorForUnion (Record _ fields) inj prj = K $ composeEditor inj prj $ constructorEditorFor' fields -composeEditorFactory+composeEditor   :: forall xss xs.     (SListI xss, All Default xs) =>      Injection (NP I) xss xs   -> Projection (Compose Maybe (NP I)) xss xs-  -> EditorFactory (NP I xs) Layout (NP I xs)-  -> EditorFactory (SOP I xss) Layout (SOP I xss)-composeEditorFactory (Fn inj) (Fn prj) = dimapEF f (SOP . unK . inj)+  -> 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 . getCompose . prj . K . hexpand (Compose Nothing) . hmap (Compose . Just) . unSOP -constructorEditorFor' :: (SListI xs, All Editable xs) => NP FieldInfo xs -> EditorFactory (NP I xs) Layout (NP I xs)+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@@ -241,15 +244,15 @@   type EditorWidget (NP I xs) = Layout   editor = horizontally $ hsequence $ hliftA Horizontally tupleEditor -tupleEditor :: forall xs . All Editable xs => NP (EditorFactory (NP I xs) Layout) xs+tupleEditor :: forall xs . All Editable xs => NP (Editor (NP I xs) Layout) 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) Layout) ys+  go :: forall ys. All Editable ys => (forall f . NP f xs -> NP f ys) -> SList ys -> NP (Editor (NP I xs) Layout) ys   go _ SNil  = Nil-  go f SCons = lmapEF (unI . hd . f) someEditor :* go (tl . f) sList+  go f SCons = lmapE (unI . hd . f) someEditor :* go (tl . f) sList -fieldsEditor :: forall xs . All Editable xs => NP (K String) xs -> NP (EditorFactory (NP I xs) Layout) xs+fieldsEditor :: forall xs . All Editable xs => NP (K String) xs -> NP (Editor (NP I xs) Layout) 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) Layout) ys+  go :: forall ys. All Editable ys => (forall f . NP f xs -> NP f ys) -> SList ys -> NP (K String) ys -> NP (Editor (NP I xs) Layout) ys   go _ SNil Nil = Nil   go f SCons (K fn :* xs) = field (toFieldLabel fn) (unI . hd . f) someEditor :* go (tl . f) sList xs 

@@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds       #-} {-# LANGUAGE DeriveFunctor   #-} {-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections   #-} {-# LANGUAGE ViewPatterns    #-} {-# OPTIONS_GHC -Wno-name-shadowing     #-}@@ -8,21 +9,21 @@  module Graphics.UI.Threepenny.Editors.Types   (-  -- * Editors-    Editor(..)+  -- * GenericWidgets+    GenericWidget(..)   , edited   , contents-  , editorElement-  , EditorFactory(.., Horizontally, horizontally, Vertically, vertically)-  , dimapEF-  , lmapEF-  , applyEF-  , createEditor-  , renderEditor+  , widgetControl+  , widgetTidings+  , liftElement+  , Editor(.., Horizontally, horizontally, Vertically, vertically)+  , dimapE+  , lmapE+  , applyE   , editorFactoryElement   , editorFactoryInput   , editorFactoryOutput-    -- ** Editor composition+    -- ** GenericWidget composition   , (|*|), (|*), (*|)   , (-*-), (-*), (*-)   , field@@ -30,7 +31,7 @@   , edit   , pattern Horizontally   , pattern Vertically-    -- ** Editor constructors+    -- ** GenericWidget constructors   , editorUnit   , editorIdentity   , editorString@@ -40,7 +41,7 @@   , editorSelection   , editorSum   , editorJust-    -- ** Editor layout+    -- ** GenericWidget layout   , withLayout   , construct   ) where@@ -60,103 +61,104 @@ import           Text.Read  -- | A widget for editing values of type @a@.-data Editor editorElement a = Editor-  { _editorTidings :: Tidings a-  , _editorElement :: editorElement+data GenericWidget control a = GenericWidget+  { _widgetTidings :: Tidings a+  , _widgetControl :: control   }   deriving Functor -instance Bifunctor Editor where-  bimap f g (Editor t e) = Editor (g <$> t) (f e)+makeLenses ''GenericWidget --- | A lens over the 'editorElement' field-editorElement :: Lens (Editor el a) (Editor el' a) el el'-editorElement f (Editor t el) = Editor t <$> f el+instance Bifunctor GenericWidget where+  bimap f g (GenericWidget t e) = GenericWidget (g <$> t) (f e) -edited :: Editor el a -> Event a-edited = rumors . _editorTidings+edited :: GenericWidget el a -> Event a+edited = rumors . _widgetTidings -contents :: Editor el a -> Behavior a-contents = facts . _editorTidings+contents :: GenericWidget el a -> Behavior a+contents = facts . _widgetTidings -instance Widget el => Widget (Editor el a) where-  getElement = getElement . _editorElement+instance Widget el => Widget (GenericWidget el a) where+  getElement = getElement . _widgetControl -renderEditor :: Renderable w => Editor w a -> UI (Editor Element a)-renderEditor = mapMOf editorElement render+instance Renderable el => Renderable (GenericWidget el a) where+  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) --- | Create an editor to display the argument.---   User edits are fed back via the 'edited' 'Event'.-createEditor :: Renderable w => EditorFactory a w b -> Behavior a -> UI (Editor Element b)-createEditor e b = runEF e b >>= renderEditor---- | A function from 'Behavior' @a@ to 'Editor' @b@+-- | A function from 'Behavior' @a@ to 'GenericWidget' @b@ --   All the three type arguments are functorial, but @a@ is contravariant.---   'EditorFactory' is a 'Biapplicative' functor on @el@ and @b@, and+--   'Editor' is a 'Biapplicative' functor on @el@ and @b@, and --   a 'Profunctor' on @a@ and @b@.-newtype EditorFactory a el b = EF {runEF :: Behavior a -> UI (Editor el b)}+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)+  } -_EditorFactory :: Iso (EditorFactory a el b) (EditorFactory a' el' b') (Behavior a -> UI (Editor el b)) (Behavior a' -> UI (Editor el' b'))-_EditorFactory = iso runEF EF+_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 (EditorFactory a el b) (EditorFactory a el' b) el el'-editorFactoryElement = _EditorFactory.mapped.mapped.editorElement+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 (EditorFactory a el b) (EditorFactory a' el b) a' a-editorFactoryInput = _EditorFactory.argument.mapped+editorFactoryInput :: Setter (Editor a el b) (Editor a' el b) a' a+editorFactoryInput = _Editor.argument.mapped  -- | A 'Setter' over the output thing-editorFactoryOutput :: Setter (EditorFactory a el b) (EditorFactory a el b') b b'-editorFactoryOutput = _EditorFactory.mapped.mapped.mapped+editorFactoryOutput :: Setter (Editor a el b) (Editor a el b') b b'+editorFactoryOutput = _Editor.mapped.mapped.mapped -liftElement :: UI el -> EditorFactory a el ()-liftElement el = EF $ \_ -> Editor (pure ()) <$> el+-- | Lift an HTML element into a vacuous editor.+liftElement :: UI el -> Editor a el ()+liftElement el = Editor $ \_ -> GenericWidget (pure ()) <$> el -bimapEF :: (el -> el') -> (b -> b') -> EditorFactory a el b -> EditorFactory a el' b'-bimapEF g h = EF . fmap (fmap (bimap g h)) . runEF+bimapEditor :: (el -> el') -> (b -> b') -> Editor a el b -> Editor a el' b'+bimapEditor g h = Editor . fmap (fmap (bimap g h)) . create -dimapEF :: (a' -> a) -> (b -> b') -> EditorFactory a el b -> EditorFactory a' el b'-dimapEF g h (EF f) = EF $ \b -> getCompose $ h <$> Compose (f (g <$> b))+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))  -- | Applies a function over the input-lmapEF :: (a' -> a) -> EditorFactory a el b -> EditorFactory a' el b-lmapEF f = dimapEF f id+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 ----- > personEditor :: EditorFactory Person PersonEditor Person+-- > personEditor :: Editor Person PersonEditor Person -- > personEditor = -- >     bipure Person Person -- >       <<*>> edit education editor -- >       <<*>> edit firstName editor -- >       <<*>> edit lastName  editor-edit :: (a' -> a) -> EditorFactory a el b -> EditorFactory a' el b-edit = lmapEF+edit :: (a' -> a) -> Editor a el b -> Editor a' el b+edit = lmapE -applyEF :: (el1 -> el2 -> el) -> EditorFactory in_ el1 (a -> b) -> EditorFactory in_ el2 a -> EditorFactory in_ el b-applyEF combineElements a b = EF $ \s -> do-    a <- runEF a s-    b <- runEF b s-    return $ Editor (_editorTidings a <*> _editorTidings b) (_editorElement a `combineElements` _editorElement b)+applyE :: (el1 -> el2 -> el) -> Editor in_ el1 (a -> b) -> Editor in_ el2 a -> Editor in_ el b+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) -instance Functor (EditorFactory a el) where-  fmap = dimapEF id+instance Functor (Editor a el) where+  fmap = dimapE id -instance Bifunctor (EditorFactory a) where-  bimap = bimapEF+instance Bifunctor (Editor a) where+  bimap = bimapEditor -instance Biapplicative (EditorFactory a) where-  bipure w o = EF $ \_ -> return $ Editor (pure o) w-  (<<*>>) = applyEF ($)+instance Biapplicative (Editor a) where+  bipure w o = Editor $ \_ -> return $ GenericWidget (pure o) w+  (<<*>>) = applyE ($) -instance Monoid el => Applicative (EditorFactory a el) where+instance Monoid el => Applicative (Editor a el) where   pure = bipure mempty-  (<*>) = applyEF mappend+  (<*>) = applyE mappend  -- | Applicative modifier for vertical composition of editor factories. --   This can be used in conjunction with ApplicativeDo as:@@ -168,7 +170,7 @@ -- >       return Person{..} -- -- DEPRECATED: Use the 'Vertical' layout builder instead-pattern Vertically :: EditorFactory a Layout b -> EditorFactory a Vertical b+pattern Vertically :: Editor a Layout b -> Editor a Vertical b pattern Vertically {vertically} <- (withLayout getVertical -> vertically) where Vertically a = withLayout Vertical a  -- | Applicative modifier for horizontal composition of editor factories.@@ -181,109 +183,109 @@ -- >       return Person{..} -- -- DEPRECATED: Use the 'Horizontal' layout builder instead-pattern Horizontally :: EditorFactory a Layout b -> EditorFactory a Horizontal b+pattern Horizontally :: Editor a Layout b -> Editor a Horizontal b pattern Horizontally {horizontally} <- (withLayout getHorizontal -> horizontally) where Horizontally a = withLayout Horizontal a  infixl 4 |*|, -*- infixl 5 |*, *|, -*, *-  -- | Apply a layout builder.-withLayout :: (layout -> layout') -> EditorFactory a layout b -> EditorFactory a layout' b+withLayout :: (layout -> layout') -> Editor a layout b -> Editor a layout' b withLayout = over editorFactoryElement  -- | Construct a concrete 'Layout'. Useful when combining heterogeneours layout builders.-construct :: Renderable m => EditorFactory a m b -> EditorFactory a Layout b+construct :: Renderable m => Editor a m b -> Editor a Layout b construct = withLayout getLayout  -- | Left-right editor composition-(|*|) :: EditorFactory s Layout (b -> a) -> EditorFactory s Layout b -> EditorFactory s Layout a+(|*|) :: Editor s Layout (b -> a) -> Editor s Layout b -> Editor s Layout a a |*| b = withLayout getHorizontal $ withLayout Horizontal a <*> withLayout Horizontal b --- | Left-right composition of an editorElement with a editor-(*|) :: UI Element -> EditorFactory s Layout a -> EditorFactory s Layout a+-- | Left-right composition of an element with a editor+(*|) :: UI Element -> Editor s Layout a -> Editor s Layout a e *| a = withLayout getHorizontal $ liftElement(return $ horizontal e) *> withLayout Horizontal a --- | Left-right composition of an editorElement with a editor-(|*) :: EditorFactory s Layout a -> UI Element -> EditorFactory s Layout a+-- | Left-right composition of an element with a editor+(|*) :: Editor s Layout a -> UI Element -> Editor s Layout a a |* e = withLayout getHorizontal $ withLayout Horizontal a <* liftElement(return $ horizontal e)  -- | Left-right editor composition-(-*-) :: EditorFactory s Layout (b -> a) -> EditorFactory s Layout b -> EditorFactory s Layout a+(-*-) :: Editor s Layout (b -> a) -> Editor s Layout b -> Editor s Layout a a -*- b = withLayout getVertical $ withLayout Vertical a <*> withLayout Vertical b --- | Left-right composition of an editorElement with a editor-(*-) :: UI Element -> EditorFactory s Layout a -> EditorFactory s Layout a+-- | Left-right composition of an element with a editor+(*-) :: UI Element -> Editor s Layout a -> Editor s Layout a e *- a = withLayout getVertical $ liftElement(return $ vertical e) *> withLayout Vertical a --- | Left-right composition of an editorElement with a editor-(-*) :: EditorFactory s Layout a -> UI Element -> EditorFactory s Layout a+-- | Left-right composition of an element with a editor+(-*) :: Editor s Layout a -> UI Element -> Editor s Layout a a -* e = withLayout getVertical $ withLayout Vertical a <* liftElement(return $ vertical e)  -- | A helper that arranges a label with the field name --   and the editor horizontally. This version takes a Layout builder as well.-fieldLayout :: (Renderable m, Renderable m') => (Layout -> m') -> String -> (out -> inn) -> EditorFactory inn m a -> EditorFactory out m' a-fieldLayout l name f e = withLayout l (string name *| first getLayout (dimapEF f id e))+fieldLayout :: (Renderable m, Renderable m') => (Layout -> m') -> String -> (out -> inn) -> Editor inn m a -> Editor out m' a+fieldLayout l name f e = withLayout l (string name *| first getLayout (dimapE f id e))  -- | A helper that arranges a label with the field name --   and the editor horizontally.-field :: Renderable m => String -> (out -> inn) -> EditorFactory inn m a -> EditorFactory out Layout a-field name f e = string name *| first getLayout (dimapEF f id e)+field :: Renderable m => String -> (out -> inn) -> Editor inn m a -> Editor out Layout a+field name f e = string name *| first getLayout (dimapE f id e) -editorUnit :: EditorFactory b Element b-editorUnit = EF $ \b -> do+editorUnit :: Editor b Element b+editorUnit = Editor $ \b -> do     t <- new-    return $ Editor (tidings b never) t+    return $ GenericWidget (tidings b never) t -editorCheckBox :: EditorFactory Bool Element Bool-editorCheckBox = EF $ \b -> do+editorCheckBox :: Editor Bool Element Bool+editorCheckBox = Editor $ \b -> do     t <- sink checked b $ input # set type_ "checkbox"-    return $ Editor (tidings b $ checkedChange t) t+    return $ GenericWidget (tidings b $ checkedChange t) t -editorString :: EditorFactory String TextEntry String-editorString = EF $ \b -> do+editorString :: Editor String TextEntry String+editorString = Editor $ \b -> do     w <- askWindow     t <- entry b     liftIOLater $ do       initialValue <- currentValue b       _ <- runUI w $ set value initialValue (element t)       return ()-    return $ Editor (userText t) t+    return $ GenericWidget (userText t) t -editorReadShow :: (Read a, Show a) => EditorFactory (Maybe a) TextEntry (Maybe a)-editorReadShow = EF $ \b -> do-    e <- runEF editorString (maybe "" show <$> b)+editorReadShow :: (Read a, Show a) => Editor (Maybe a) TextEntry (Maybe a)+editorReadShow = Editor $ \b -> do+    e <- create editorString (maybe "" show <$> b)     let readIt "" = Nothing         readIt x  = readMaybe x     let t = tidings b (readIt <$> edited e)-    return $ Editor t (_editorElement e)+    return $ GenericWidget t (_widgetControl e)  -- An editor that presents a choice of values. editorEnumBounded   :: (Bounded a, Enum a, Ord a, Show a)-  => Behavior(a -> UI Element) -> EditorFactory (Maybe a) (ListBox a) (Maybe a)+  => Behavior(a -> UI Element) -> Editor (Maybe a) (ListBox a) (Maybe a) editorEnumBounded = editorSelection (pure $ enumFrom minBound)  -- | An editor that presents a dynamic choice of values. editorSelection   :: Ord a-  => Behavior [a] -> Behavior(a -> UI Element) -> EditorFactory (Maybe a) (ListBox a) (Maybe a)-editorSelection options display = EF $ \b -> do+  => Behavior [a] -> Behavior(a -> UI Element) -> Editor (Maybe a) (ListBox a) (Maybe a)+editorSelection options display = Editor $ \b -> do   l <- listBox options b display-  return $ Editor (tidings b (rumors $ userSelection l)) l+  return $ GenericWidget (tidings b (rumors $ userSelection l)) l  -- | Ignores 'Nothing' values and only updates for 'Just' values-editorJust :: EditorFactory (Maybe b) el (Maybe b) -> EditorFactory b el b-editorJust (EF editor) = EF $ \b -> do+editorJust :: Editor (Maybe b) el (Maybe b) -> Editor b el b+editorJust (Editor editor) = Editor $ \b -> do   e <- editor (Just <$> b)   let ev = filterJust (edited e)-  return $ Editor (tidings b ev) (_editorElement e)+  return $ GenericWidget (tidings b ev) (_widgetControl e)  -- | An editor for union types, built from editors for its constructors. editorSum   :: (Ord tag, Show tag, Renderable el)-  => (Layout -> Layout -> Layout) -> [(tag, EditorFactory a el a)] -> (a -> tag) -> EditorFactory a Layout a-editorSum combineLayout options selector = EF $ \ba -> do-  options <- mapM (\(tag, EF mk) -> (tag,) <$> (mk ba >>= renderEditor)) options+  => (Layout -> Layout -> Layout) -> [(tag, Editor a el a)] -> (a -> tag) -> Editor a Layout a+editorSum combineLayout options selector = Editor $ \ba -> do+  options <- mapM (\(tag, Editor mk) -> (tag,) <$> (mk ba >>= renderEditor)) options   let tag = selector <$> ba   tag' <- calmB tag   let build a = lookup a options@@ -291,7 +293,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") _editorElement (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.@@ -300,7 +302,7 @@       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+  return $ GenericWidget (tidings ba editedE) composed -editorIdentity :: EditorFactory a el a -> EditorFactory (Identity a) el (Identity a)-editorIdentity = dimapEF runIdentity Identity+editorIdentity :: Editor a el a -> Editor (Identity a) el (Identity a)+editorIdentity = dimapE runIdentity Identity

@@ -0,0 +1,24 @@+module Graphics.UI.Threepenny.Editors.Validation+  ( ValidationResult(..)+  , Validable(..)+  , isValid+  , updateIfValid+  ) where++data ValidationResult = Ok | Invalid String+instance Show ValidationResult where+  show Ok            = ""+  show (Invalid msg) = msg++class Validable a where+  validate :: a -> ValidationResult++isValid :: Validable a => a -> Bool+isValid x+  | Ok <- validate x = True+  | otherwise = False++updateIfValid :: Validable a => a -> a -> a+updateIfValid new old+  | isValid new = new+  | otherwise   = old

@@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack  name:           threepenny-editors-version:        0.5.1+version:        0.5.2 synopsis:       Composable algebraic editors description:    This package provides a type class 'Editable' and combinators to                 easily put together form-like editors for algebraic datatypes.@@ -50,10 +50,32 @@       Graphics.UI.Threepenny.Editors.Layout       Graphics.UI.Threepenny.Editors.Utils       Graphics.UI.Threepenny.Editors.Types+      Graphics.UI.Threepenny.Editors.Validation   other-modules:       Paths_threepenny_editors   default-language: Haskell2010 +executable parser+  main-is: Parser.hs+  hs-source-dirs:+      examples+  ghc-options: -Wall -Wno-name-shadowing+  if flag(buildExamples)+    build-depends:+        base+      , bifunctors+      , data-default+      , generics-sop+      , profunctors+      , threepenny-gui+      , threepenny-editors+      , haskell-src-exts+  else+    buildable: False+  other-modules:+      Person+  default-language: Haskell2010+ executable person   main-is: Person.hs   hs-source-dirs:@@ -70,4 +92,6 @@       , threepenny-editors   else     buildable: False+  other-modules:+      Parser   default-language: Haskell2010