diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Jose Iborra (c) 2017 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Jose Iborra nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,6 @@ +[![Travis Build Status](https://travis-ci.org/pepeiborra/threepenny-editors.svg)](https://travis-ci.org/pepeiborra/threepenny-editors) +[![Hackage](https://img.shields.io/hackage/v/threepenny-editors.svg)](https://hackage.haskell.org/package/threepenny-editors) +[![Stackage Nightly](http://stackage.org/package/threepenny-editors/badge/nightly)](http://stackage.org/nightly/package/threepenny-editors) + +# threepenny-editors +A library for writing composable algebraic widgets with three penny. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/examples/Person.hs b/examples/Person.hs new file mode 100644 --- /dev/null +++ b/examples/Person.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE ScopedTypeVariables #-} +import Control.Monad +import Data.Maybe +import Graphics.UI.Threepenny.Core +import Graphics.UI.Threepenny.Editors +import Graphics.UI.Threepenny.Elements + +main :: IO () +main = startGUI defaultConfig setup + +data LegalStatus + = Single + | Married + | Divorced + | Widowed + deriving (Bounded, Enum, Eq, Ord, Show) + +data Education + = Basic_ + | Intermediate_ + | Other_ String + deriving (Eq, Ord, Read, Show) + +getOther :: Education -> Maybe String +getOther (Other_ s) = Just s +getOther _ = Nothing + +data EducationTag = Basic | Intermediate | Other deriving (Eq,Ord,Show) + +data Person = Person + { education :: Education + , firstName, lastName :: String + , age :: Int + , brexiteer :: Bool + , status :: Maybe LegalStatus + } + deriving Show + +instance Editable Education where + editor b = do + basicEditor <- fmap (const Basic_) <$> editor (pure ()) + intermediateEditor <- fmap (const Intermediate_) <$> editor (pure ()) + otherEditor <- fmap Other_ <$> editor (fromMaybe "" . getOther <$> b) + let selector x = + case x of + Basic_ -> Basic + Intermediate_ -> Intermediate + Other_ _ -> Other + editorSum + [ (Basic, basicEditor) + , (Intermediate, intermediateEditor) + , (Other, otherEditor) + ] + selector + b + +instance Editable Person where + editor b = + fmap (\fn ln a e ls b -> Person e fn ln a b ls) + <$> string "First:" *| editor (firstName <$> b) + -*- string "Last:" *| editor (lastName <$> b) + -*- string "Age:" *| editor (age <$> b) + -*- string "Education:" *| editor (education <$> b) + -*- string "Status" *| editorEnumBounded(pure(string.show)) (status <$> b) + -*- string "Brexiter" *| editor (brexiteer <$> b) + +setup :: Window -> UI () +setup w = void $ mdo + _ <- return w # set title "Threepenny editors example" + person1 :: Editor Person <- editor person1B + person1B <- stepper (Person Basic_ "" "" 0 False Nothing) (edited person1) + + getBody w #+ [grid + [ [return $ editorElement person1] + , [sink text (show <$> contents person1) p] + ]] diff --git a/src/Graphics/UI/Threepenny/Editors.hs b/src/Graphics/UI/Threepenny/Editors.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/Threepenny/Editors.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC #-} +module Graphics.UI.Threepenny.Editors + ( -- * Editors + Editor(..) + , edited + , contents + -- ** Editor compoosition + , (|*|), (|*), (*|) + , (-*-), (-*), (*-) + -- ** Editor constructors + , editorReadShow + , editorEnumBounded + , withDefault + )where + +import Data.Maybe +import Data.Profunctor +import Graphics.UI.Threepenny.Attributes +import Graphics.UI.Threepenny.Core +import Graphics.UI.Threepenny.Elements +import Graphics.UI.Threepenny.Events +import Graphics.UI.Threepenny.Widgets +import Text.Read + +data Editor a = Editor + { editorTidings :: Tidings a + , editorElement :: Element + } + deriving Functor + +instance Widget (Editor a) where + getElement = editorElement + +-- | A newtype wrapper that provides a 'Profunctor' instance. +newtype EditorFactory a b = EditorFactory { run :: Behavior a -> UI (Editor b) } + +instance Profunctor EditorFactory where + dimap g h (EditorFactory f) = EditorFactory $ \b -> fmap h <$> f (g <$> b) + +-- | The class of Editable datatypes. +class Editable a where + -- | The editor factory + editor :: Behavior a -> UI (Editor a) + +edited :: Editor a -> Event a +edited = rumors . editorTidings + +contents :: Editor a -> Behavior a +contents = facts . editorTidings + +infixl 4 |*|, -*- +infixl 5 |*, *|, -*, *- + +-- | Left-right editor composition +(|*|) :: UI(Editor (b -> a)) -> UI(Editor b) -> UI(Editor a) +a |*| b = do + a <- a + b <- b + ab <- row [return $ getElement a, return $ getElement b] + return $ Editor (editorTidings a <*> editorTidings b) ab + +-- | Left-right composition of an element with a editor +(*|) :: UI Element -> UI (Editor a) -> UI (Editor a) +e *| a = do + e <- e + a <- a + ea <- row [return e, return $ getElement a] + return $ Editor (editorTidings a) ea + +-- | Left-right composition of an element with a editor +(|*) :: UI (Editor a) -> UI Element -> UI (Editor a) +a |* e = do + e <- e + a <- a + ea <- row [return $ getElement a, return e] + return $ Editor (editorTidings a) ea + +-- | Top-down editor composition +(-*-) :: UI(Editor (b -> a)) -> UI(Editor b) -> UI(Editor a) +a -*- b = do + a <- a + b <- b + ab <- column [return $ getElement a, return $ getElement b] + return $ Editor (editorTidings a <*> editorTidings b) ab + +-- | Top-down composition of an element with a editor +(*-) :: UI Element -> UI (Editor a) -> UI (Editor a) +e *- a = do + e <- e + a <- a + ea <- column [return e, return $ getElement a] + return $ Editor (editorTidings a) ea + +-- | Top-down composition of an element with a editor +(-*) :: UI (Editor a) -> UI Element -> UI (Editor a) +a -* e = do + e <- e + a <- a + ea <- column [return $ getElement a, return e] + return $ Editor (editorTidings a) ea + +editorReadShow :: (Read a, Show a) => Behavior (Maybe a) -> UI (Editor (Maybe a)) +editorReadShow b = + do + e <- editor (show <$> b) + let t = tidings b (filterJust $ readMaybe <$> edited e) + return $ Editor t (getElement e) + +editorEnumBounded + :: (Bounded a, Enum a, Ord a, Show a) + => Behavior(a -> UI Element) -> Behavior (Maybe a) -> UI (Editor (Maybe a)) +editorEnumBounded display b = do + l <- listBox (pure $ enumFrom minBound) b display + return $ Editor (userSelection l) (getElement l) + +withDefault + :: EditorFactory (Maybe a) (Maybe b) + -> b + -> EditorFactory a b +withDefault editor def = dimap Just (fromMaybe def) editor + +data SumWrapper tag a = A {display :: tag, factory :: Editor a} + +instance Eq tag => Eq (SumWrapper tag a) where A a _ == A b _ = a == b +instance Ord tag => Ord (SumWrapper tag a) where compare (A a _) (A b _) = compare a b +instance Show tag => Show (SumWrapper tag a) where show = show . display + +-- | * Experimental editor, do not use yet. +editorSum + :: (Ord tag, Show tag) + => [(tag, Editor a)] -> (a -> tag) -> Behavior a -> UI (Editor a) +editorSum options selector ba = mdo + let bSelected = + let build a = + let tag = selector a + in A tag <$> lookup tag options + in build <$> ba + l <- listBox (pure $ fmap (uncurry A) options) bSelected (pure (string . show)) + let nestedEditor = factory . fromMaybe (uncurry A $ head options) <$> bSelected + nestedElement <- sink children ((:[]) . getElement <$> nestedEditor) new + composed <- column [element l, widget nestedElement] + let joinE :: Event (Event a) -> UI(Event a) + joinE = undefined -- missing in threepenny-gui + event <- joinE (edited <$> nestedEditor <@ rumors (userSelection l)) + return $ Editor (tidings ba event) composed + +instance Editable () where + editor b = do + t <- new + return $ Editor (tidings b never) (getElement t) + +instance a ~ Char => Editable [a] where + editor b = do + t <- entry b + return $ Editor (userText t) (getElement t) + +instance Editable Int where + editor = run $ EditorFactory editor `withDefault` 0 + +instance Editable Double where + editor = run $ EditorFactory editor `withDefault` 0 + +instance Editable Bool where + editor b = do + t <- sink checked b $ input # set type_ "checkbox" + return $ Editor (tidings b $ checkedChange t) t + +instance Editable (Maybe Int) where editor = editorReadShow +instance Editable (Maybe Double) where editor = editorReadShow diff --git a/threepenny-editors.cabal b/threepenny-editors.cabal new file mode 100644 --- /dev/null +++ b/threepenny-editors.cabal @@ -0,0 +1,59 @@ +-- This file has been generated from package.yaml by hpack version 0.17.0. +-- +-- see: https://github.com/sol/hpack + +name: threepenny-editors +version: 0.1.0.0 +synopsis: Composable algebraic editors +description: This package provides a type class 'Editable' and combinators to + easily put together form-like editors for algebraic datatypes. + . + NOTE: This library contains examples, but they are not built by default. + To build and install the example, use the @buildExamples@ flag like this + . + @cabal install threepenny-gui -fbuildExamples@ +category: Web +homepage: https://github.com/pepeiborra/threepenny-forms#readme +author: Jose Iborra +maintainer: pepeiborra@gmail.com +copyright: All Rights Reserved +license: BSD3 +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 + +extra-source-files: + README.md + +flag buildExamples + description: build the examples + manual: True + default: False + +library + hs-source-dirs: + src + ghc-options: -Wall -Wno-name-shadowing + build-depends: + base >= 4.7 && < 5 + , profunctors + , threepenny-gui > 0.7 + exposed-modules: + Graphics.UI.Threepenny.Editors + other-modules: + Paths_threepenny_editors + default-language: Haskell2010 + +executable person + main-is: Person.hs + hs-source-dirs: + examples + ghc-options: -Wall -Wno-name-shadowing + if flag(buildExamples) + build-depends: + base + , threepenny-gui + , threepenny-editors + else + buildable: False + default-language: Haskell2010