diff --git a/examples/Parser.hs b/examples/Parser.hs new file mode 100644 --- /dev/null +++ b/examples/Parser.hs @@ -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]] diff --git a/examples/Person.hs b/examples/Person.hs --- a/examples/Person.hs +++ b/examples/Person.hs @@ -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] ]] diff --git a/src/Graphics/UI/Threepenny/Editors.hs b/src/Graphics/UI/Threepenny/Editors.hs --- a/src/Graphics/UI/Threepenny/Editors.hs +++ b/src/Graphics/UI/Threepenny/Editors.hs @@ -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 diff --git a/src/Graphics/UI/Threepenny/Editors/Types.hs b/src/Graphics/UI/Threepenny/Editors/Types.hs --- a/src/Graphics/UI/Threepenny/Editors/Types.hs +++ b/src/Graphics/UI/Threepenny/Editors/Types.hs @@ -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 diff --git a/src/Graphics/UI/Threepenny/Editors/Validation.hs b/src/Graphics/UI/Threepenny/Editors/Validation.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/Threepenny/Editors/Validation.hs @@ -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 diff --git a/threepenny-editors.cabal b/threepenny-editors.cabal --- a/threepenny-editors.cabal +++ b/threepenny-editors.cabal @@ -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