threepenny-editors 0.4.1 → 0.5.0

raw patch · 9 files changed

+911/−638 lines, 9 filesdep +bifunctorsdep +lensPVP ok

version bump matches the API change (PVP)

Dependencies added: bifunctors, lens

API changes (from Hackage documentation)

Files

• CHANGELOG.md +12/−0
• examples/Person.hs +99/−52
• src/Graphics/UI/Threepenny/Editors.hs +241/−9
• src/Graphics/UI/Threepenny/Editors/Base.hs +0/−276
• src/Graphics/UI/Threepenny/Editors/Layout.hs +214/−0
• src/Graphics/UI/Threepenny/Editors/Profunctor.hs +0/−297
• src/Graphics/UI/Threepenny/Editors/Types.hs +306/−0
• src/Graphics/UI/Threepenny/Editors/Utils.hs +31/−0
• threepenny-editors.cabal +8/−4

@@ -1,3 +1,15 @@+# 0.5.0 (2017-07-30)+    This is a major release with lots of internal rewrites and new features:+    * Introduced monoidal layout builders like `Columns` for easier layout of+      `field` style editors. Generic editors do not yet take advantage of this,+      but in the future they will via metadata.+    * Introduced a `Biapplicative` interface for defining editors with richly+      typed widgets. This is quite experimental and only record types are+      supported, examples/Person.hs contains an example.+    * Reorganized module and data type structure. The main changes are:+      - `EditorDef` no longer exists.+      - `Editor` has been generalized and now exposes the widget type.+      - `EditorFactory` is now a `Biapplicative` but no longer has a `Profunctor` instance. # 0.4.1 (2017-07-13)     * Improved the rendering of constructors in generic sum editors # 0.4.0 (2017-07-13)

@@ -1,23 +1,42 @@-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE ApplicativeDo              #-}+{-# LANGUAGE DataKinds                  #-}+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE FlexibleInstances          #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE DeriveGeneric       #-}-{-# LANGUAGE RecursiveDo         #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards            #-}+{-# LANGUAGE RecursiveDo                #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS_GHC -Wno-name-shadowing     #-}+{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} import           Control.Monad-import           Data.Coerce+import           Data.Biapplicative import           Data.Default import           Data.Maybe-import           Data.Profunctor-import qualified Generics.SOP                    as SOP+import qualified Generics.SOP                         as SOP import           GHC.Generics import           Graphics.UI.Threepenny.Core-import           Graphics.UI.Threepenny.Editors hiding (Single)+import           Graphics.UI.Threepenny.Editors+import           Graphics.UI.Threepenny.Editors.Types import           Graphics.UI.Threepenny.Elements  main :: IO () main = startGUI defaultConfig setup +-- | A dual purpose data type that doubles as a value and as a widget depending on the type argument.+data PersonF (usage :: Usage) = Person+  { education           :: Field usage Education+  , firstName, lastName :: Field usage String+  , age                 :: Field usage (Maybe Int)+  , brexiteer           :: Field usage Brexiteer+  , status              :: Field usage LegalStatus+  }+  deriving (Generic)++type Person = PersonF Value+type PersonEditor = PersonF Edit+ data LegalStatus   = Single   | Married@@ -42,15 +61,17 @@ getOther (Other s) = Just s getOther _         = Nothing -editorEducation :: EditorFactory Education Education+-- | 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 = do     let selector x = case x of             Other _ -> "Other"             _       -> show x-    editorSum horizontal-      [ ("Basic", const Basic <$> editorUnit)-      , ("Intermediate", const Intermediate <$> editorUnit)-      , ("Other", dimap (fromMaybe "" . getOther) Other editor)+    editorSum beside+      [ ("Basic", const Basic <$> withSomeWidget editorUnit)+      , ("Intermediate", const Intermediate <$> withSomeWidget editorUnit)+      , ("Other", dimapEF (fromMaybe "" . getOther) Other someEditor)       ]       selector @@ -65,63 +86,89 @@ instance SOP.HasDatatypeInfo Brexiteer instance SOP.Generic Brexiteer -data Person = Person-  { education           :: Education-  , firstName, lastName :: String-  , age                 :: Maybe Int-  , brexiteer           :: Brexiteer-  , status              :: LegalStatus-  }-  deriving (Generic, Show)+deriving instance Show Person  instance Editable Person instance SOP.HasDatatypeInfo Person instance SOP.Generic Person instance Default Person where def = Person Basic "First" "Last" (Just 18) def def -editorPersonRows :: EditorFactory Person Person-editorPersonRows = vertically $ do-  (firstName, lastName) <- coerce $ horizontally $ do-      firstName <- coerce $ field "First:"     firstName editor-      lastName  <- coerce $ field "Last:"      lastName editor+-- | An editor for 'Person' values that combines the 'Horizontal' and 'Vertical' layout builders+editorPersonHV :: EditorFactory 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) <- coerce $ horizontally $ do-      age       <- coerce $ field "Age:"       age editor-      education <- coerce $ field "Education:" education editorEducation+  (age, education) <- withLayout Vertical $ construct $ do+      age       <- fieldLayout Horizontal "Age:"       age editor+      education <- fieldLayout Horizontal "Education:" education editorEducation       return (age, education)-  (status, brexiteer) <- coerce $ horizontally $ do-      status    <- coerce $ field "Status"     status (editorJust $ editorSelection (pure [minBound..]) (pure (string.show)))-      brexiteer <- coerce $ field "Brexiter"   brexiteer editor+  (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{..} -editorPersonColumns :: EditorFactory Person Person-editorPersonColumns = horizontally $ do-  (firstName, lastName, age) <- coerce $ vertically $ do-      firstName <- coerce $ field "First:"     firstName editor-      lastName  <- coerce $ field "Last:"      lastName editor-      age       <- coerce $ field "Age:"       age editor-      return (firstName, lastName, age)-  (education, status, brexiteer) <- coerce $ vertically $ do-      education <- coerce $ field "Education:" education editorEducation-      status    <- coerce $ field "Status"     status (editorJust $ editorSelection (pure [minBound..]) (pure (string.show)))-      brexiteer <- coerce $ field "Brexiter"   brexiteer editor-      return (education, status, brexiteer)-  return Person{..}+-- | An editor for 'Person' values that uses the 'Columns' layout builder+editorPersonColumns :: EditorFactory Person Columns Person+editorPersonColumns = do+      firstName <- fieldLayout Next "First:"     firstName editor+      lastName  <- fieldLayout Next "Last:"      lastName editor+      age       <- fieldLayout Next "Age:"       age editor+      education <- fieldLayout Break "Education:" education editorEducation+      status    <- fieldLayout Next "Status"     status (withSomeWidget $ editorJust $ editorSelection (pure [minBound..]) (pure (string.show)))+      brexiteer <- fieldLayout Next "Brexiter"   brexiteer editor+      return Person{..} ++-- | 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 =+    bipure Person Person+      <<*>> edit education editor+      <<*>> edit firstName editor+      <<*>> edit lastName  editor+      <<*>> edit age       editor+      <<*>> edit brexiteer editor+      <<*>> edit status    editor++instance Renderable PersonEditor where+  getLayout Person{..} =+    ( ("First: "  ||| firstName) ===+      ("Last: "   ||| lastName)  ===+      ("Status: " ||| status)+    ) |||+    (("Age:" ||| age) ===+     ("Brexiteer: " ||| brexiteer) ===+     ("Education: " ||| education))+   where+    a ||| b = getLayout a `beside` getLayout b+    a === b = getLayout a `above`  getLayout b++-- Driver setup :: Window -> UI () setup w = void $ mdo   _ <- return w # set title "Threepenny editors example"-  person1r <- createEditor editorPersonRows person1B-  person1c <- createEditor editorPersonColumns person1B+  person1HV <- createEditor editorPersonHV person1B+  person1C <- createEditor editorPersonColumns person1B   person2 <- createEditor editorGeneric person1B-  person1B <- stepper def (head <$> unions [edited person1r, edited person1c, edited person2])+  person3 <- createEditor personEditor person1B+  person1B <- stepper def (head <$> unions+                            [ edited person1HV+                            , edited person1C+                            , edited person2+                            , edited person3+                            ])    getBody w #+ [grid-    [ [return $ editorElement person1r]+    [ [return $ _editorElement person1HV]     , [hr]-    , [return $ editorElement person1c]+    , [return $ _editorElement person1C]     , [hr]-    , [return $ editorElement person2]+    , [return $ _editorElement person2]+    , [hr]+    , [return $ _editorElement person3]     , [hr]     ]]

@@ -1,18 +1,46 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds                  #-}+{-# LANGUAGE DefaultSignatures          #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE PatternSynonyms            #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TupleSections              #-}+{-# LANGUAGE TypeApplications           #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE TypeOperators              #-}+{-# LANGUAGE ViewPatterns               #-}+{-# OPTIONS_GHC -Wno-orphans            #-}+{-# OPTIONS_GHC -Wno-name-shadowing     #-}+{-# OPTIONS_GHC -Wno-duplicate-exports  #-}  module Graphics.UI.Threepenny.Editors   ( -- * Editors     Editor(..)   , edited   , contents-  , EditorFactory+  , editorElement+    -- * Editor factories+  , EditorFactory(Horizontally, horizontally, Vertically, vertically)+  , someEditor   , createEditor   , Editable(..)+  , EditorWidgetFor(..)+  , Field+  , Usage(..)     -- ** Editor composition   , (|*|), (|*), (*|)   , (-*-), (-*), (*-)   , field-  , Vertically(..)-  , Horizontally(..)+  , fieldLayout+  , pattern Horizontally+  , pattern Vertically+    -- ** Editor layout+  , withLayout+  , withSomeWidget+  , construct     -- ** Editor constructors   , editorUnit   , editorIdentity@@ -24,10 +52,214 @@     -- ** Generic editors   , editorGeneric   , editorGenericSimple-    -- ** Layouts-  , Layout(Grid, Single)-  , horizontal-  , vertical-  )where+    -- * Layouts+  , Layout+  , above+  , beside+  -- ** Monoidal layouts+  , Vertical(..)+  , Horizontal(..)+  , Columns(..)+  -- ** Type level layouts+  , type (|*|)(..)+  , type (-*-)(..)+  -- ** Layout manipulation+  , Renderable(..)+  ) where -import Graphics.UI.Threepenny.Editors.Profunctor+import           Data.Biapplicative+import           Data.Char+import           Data.Default+import           Data.Functor.Compose+import           Data.Functor.Identity+import           Data.Maybe+import           Generics.SOP                          hiding (Compose)+import           Graphics.UI.Threepenny.Core           as UI+import           Graphics.UI.Threepenny.Widgets+import           Text.Casing++import           Graphics.UI.Threepenny.Editors.Layout+import           Graphics.UI.Threepenny.Editors.Types++-- | The class of 'Editable' datatypes.+--   .+--   Define your own instance by using the 'Applicative' composition operators or+--   derive it via 'Generics.SOP'.+class Renderable (EditorWidget a) => Editable a where+  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))) => EditorFactory a Layout a+  editor = editorGeneric++-- | Conceal the widget type of some 'Editor'+withSomeWidget :: Renderable w => EditorFactory a w b -> EditorFactory a Layout b+withSomeWidget = first getLayout++-- | A version of 'editor' with a concealed widget type.+someEditor :: Editable a => EditorFactory a Layout a+someEditor = withSomeWidget editor++-- | A container for 'EditorWidget'.+data EditorWidgetFor a where+  EditorWidgetFor :: Editable a => EditorWidget a -> EditorWidgetFor a++-- | 'Usage' is a kind for type level 'Field's+data Usage = Value | Edit++-- | Type level fields. Use this helper to define EditorWidget types. Example:+--+-- > data PersonF (usage :: Usage) = Person+-- >   { education           :: Field usage Education+-- >   , firstName, lastName :: Field usage String+-- >   , age                 :: Field usage (Maybe Int)+--+-- > type Person = PersonF Value+-- > type PersonEditor = PersonF Edit+type family Field (usage :: Usage) a where+  Field 'Value  a = a+  Field 'Edit a = EditorWidget a++instance Editable () where+  type EditorWidget () = Element+  editor = editorUnit++instance a ~ Char => Editable [a] where+  type EditorWidget [a] = TextEntry+  editor = editorString++instance Editable Bool where+  type EditorWidget Bool = Element+  editor = editorCheckBox++instance Editable (Maybe Int) where+  type EditorWidget (Maybe Int) = TextEntry+  editor = editorReadShow+instance Editable (Maybe Double) where+  type EditorWidget (Maybe Double) = TextEntry+  editor = editorReadShow+instance Editable Int where+  type EditorWidget Int = TextEntry+  editor = editorJust editor+instance Editable Double where+  type EditorWidget Double = TextEntry+  editor = editorJust editor++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++instance Editable a => Editable (Identity a) where+  type EditorWidget (Identity a) = EditorWidget a+  editor = editorIdentity editor++{--------------------------------------------+  Generic derivations+---------------------------------------------}+-- | A generic editor for record types.+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))++editorGenericSimple'+  :: forall xs.+     (All Editable xs)+  => DatatypeInfo '[xs] -> EditorFactory (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++-- | 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))++editorGeneric'+  :: forall xx.+     (All (All Editable `And` All Default) xx)+  => DatatypeInfo xx -> EditorFactory (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 = first Tag <$> constructorEditorsFor cc+  constructors = hmap (K . constructorName) cc+  constructor a = Tag $ hcollapse $ hliftA2 const constructors (unSOP a)+editorGeneric' (Newtype _ _ c) = constructorEditorFor c++newtype Tag = Tag String deriving (Eq, Ord)+instance Show Tag where show (Tag t) = init $ toFieldLabel t++constructorEditorsFor+  :: forall xx . (All (All Editable `And` All Default) xx)+  => NP ConstructorInfo xx -> [(String, EditorFactory (SOP I xx) Layout (SOP I xx))]+constructorEditorsFor cc =+  hcollapse $ hcliftA3 p (\c i p -> (constructorName c,) `mapKK` constructorEditorForUnion c i p) cc+    (injections  :: NP (Injection  (NP I) xx) xx)+    (projections :: NP (Projection (Compose Maybe (NP I)) xx) xx)+  where+    p = Proxy @ (All Editable `And` All Default)++constructorEditorForUnion+  :: (SListI xx, All Editable xs, All Default xs)+  => 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++composeEditorFactory+  :: 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)+  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' fields = vertically $ hsequence $ hliftA Vertically $ fieldsEditor (hliftA (K . fieldName) fields)++-- | Tuple editor without fields+instance All Editable xs => Editable (NP I xs) where+  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 = 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 _ SNil  = Nil+  go f SCons = lmapEF (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 = 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 _ SNil Nil = Nil+  go f SCons (K fn :* xs) = field (toFieldLabel fn) (unI . hd . f) someEditor :* go (tl . f) sList xs++toFieldLabel :: String -> String+toFieldLabel (fromAny -> Identifier (x:xx)) =+  unwords (onHead toUpper x : fmap (onHead toLower) xx) ++ ":"+    where+      onHead f (x:xx) = f x : xx+      onHead _ []     = []+toFieldLabel _ = ""++instance (Applicative f, All Default xs) => Default (NP f xs) where+  def = hcpure (Proxy @ Default) (pure def)

@@ -1,276 +0,0 @@-{-# LANGUAGE DeriveFunctor     #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedLists   #-}-{-# LANGUAGE PatternSynonyms   #-}-{-# LANGUAGE TupleSections     #-}-{-# LANGUAGE TypeFamilies      #-}-{-# LANGUAGE ViewPatterns #-}-{-# OPTIONS_GHC  #-}-module Graphics.UI.Threepenny.Editors.Base-  ( -- * Editors-    Editor(..)-  , edited-  , contents-  , Editable(..)-    -- ** Editor definitions-  , EditorDef(..)-  , runEditorDef-    -- ** Layouts-  , Layout(Grid, Single)-  , horizontal-  , vertical-    -- ** Editor composition-  , (|*|), (|*), (*|)-  , (-*-), (-*), (*-)-    -- ** Editor constructors-  , editorReadShow-  , editorEnumBounded-  , editorSelection-  , editorSum-  , editorJust-  -- * Reexports-  , Compose(..)-  )where--import           Data.Foldable (length)-import           Data.Functor.Compose-import           Data.Maybe-import           Data.Monoid-import           Data.Sequence (Seq, viewl, ViewL(..))-import qualified Data.Sequence as Seq-import           GHC.Exts (IsList(..))-import           Graphics.UI.Threepenny.Attributes-import           Graphics.UI.Threepenny.Core as UI-import           Graphics.UI.Threepenny.Elements-import           Graphics.UI.Threepenny.Events-import           Graphics.UI.Threepenny.Widgets-import           Text.Read---- | A widget for editing values of type @a@.-data Editor a = Editor-  { editorTidings :: Tidings a-  , editorElement :: Element-  }-  deriving Functor--edited :: Editor a -> Event a-edited = rumors . editorTidings--contents :: Editor a -> Behavior a-contents = facts . editorTidings--instance Widget (Editor a) where-  getElement = editorElement--newtype Layout-  = Grid (Seq (Seq (Maybe Element))) -- ^ A non empty list of rows, where all the rows are assumed to have the same length--pattern Single :: Element -> Layout-pattern Single x <- Grid (Singleton (Singleton (Just x))) where Single x = Grid [[Just x]]--pattern Singleton :: a -> Seq a-pattern Singleton x <- (viewl -> x :< (viewl -> EmptyL)) where Singleton x = [x]--vertical, horizontal :: Layout -> Layout -> Layout-vertical (Grid rows@(length.head.toList -> l1)) (Grid rows'@(length.head.toList -> l2)) =-    Grid $ fmap pad1 rows <> fmap pad2 rows'-  where-    pad l1 l2 | l1 >= l2  = id-              | otherwise = (<> Seq.replicate (l2-l1) Nothing)-    pad1 = pad l1 l2-    pad2 = pad l2 l1--horizontal (Grid rows@(length -> l1)) (Grid rows'@(length -> l2)) =-  Grid $ Seq.zipWith (<>) (pad1 rows) (pad2 rows')-  where-    pad l1 l2-      | l1 >= l2  = id-      | otherwise = \x ->-          let padding = Seq.replicate (length $ head $ toList x) Nothing-          in x <> Seq.replicate (l2 - l1) padding-    pad1 = pad l1 l2-    pad2 = pad l2 l1--runLayout :: Layout -> UI Element-runLayout (Grid rows) = grid (toList $ fmap (fmap (maybe new return). toList) rows)--data EditorDef a = EditorDef-  { editorDefTidings :: Tidings a-  , editorDefLayout  :: Layout-  }-  deriving Functor--editedDef :: EditorDef a -> Event a-editedDef = rumors . editorDefTidings--runEditorDef :: EditorDef a -> UI (Editor a)-runEditorDef def = do-  el <- runLayout (editorDefLayout def) -  return $ Editor (editorDefTidings def) el---- | The class of Editable datatypes.-class Editable a where-  -- | The editor factory-  editor :: Behavior a -> Compose UI EditorDef a--infixl 4 |*|, -*--infixl 5 |*, *|, -*, *----- | Left-right editor composition-(|*|) :: Compose UI EditorDef (b -> a) -> Compose UI EditorDef b -> Compose UI EditorDef a-a |*| b = Compose $ do-  a <- getCompose a-  b <- getCompose b-  let ab = horizontal (editorDefLayout a) (editorDefLayout b)-  return $ EditorDef (editorDefTidings a <*> editorDefTidings b) ab---- | Left-right composition of an element with a editor-(*|) :: UI Element -> Compose UI EditorDef a -> Compose UI EditorDef a-e *| a = Compose $ do-  e <- e-  a <- getCompose a-  let ea = horizontal (Single e) (editorDefLayout a)-  return $ EditorDef (editorDefTidings a) ea---- | Left-right composition of an element with a editor-(|*) :: Compose UI EditorDef a -> UI Element -> Compose UI EditorDef a-a |* e = Compose $ do-  e <- e-  a <- getCompose a-  let ea = horizontal (editorDefLayout a) (Single e)-  return $ EditorDef (editorDefTidings a) ea---- | Top-down editor composition-(-*-) :: Compose UI EditorDef (b -> a) -> Compose UI EditorDef b -> Compose UI EditorDef a-a -*- b = Compose $ do-  a <- getCompose a-  b <- getCompose b-  let ab = vertical (editorDefLayout a) (editorDefLayout b)-  return $ EditorDef (editorDefTidings a <*> editorDefTidings b) ab---- | Top-down composition of an element with a editor-(*-) :: UI Element -> Compose UI EditorDef a -> Compose UI EditorDef a-e *- a = Compose $ do-  e <- e-  a <- getCompose a-  let ea = vertical (Single e) (editorDefLayout a)-  return $ EditorDef (editorDefTidings a) ea---- | Top-down composition of an element with a editor-(-*) :: Compose UI EditorDef a -> UI Element -> Compose UI EditorDef a-a -* e = Compose $ do-  e <- e-  a <- getCompose a-  let ea = vertical (editorDefLayout a) (Single e)-  return $ EditorDef (editorDefTidings a) ea--editorReadShow :: (Read a, Show a) => Behavior (Maybe a) -> Compose UI EditorDef (Maybe a)-editorReadShow b = Compose $ do-    e <- getCompose $ editor (maybe "" show <$> b)-    let readIt "" = Nothing-        readIt x  = readMaybe x-    let t = tidings b (readIt <$> editedDef e)-    return $ EditorDef t (editorDefLayout e)---- An editor that presents a choice of values.-editorEnumBounded-  :: (Bounded a, Enum a, Ord a, Show a)-  => Behavior(a -> UI Element) -> Behavior (Maybe a) -> Compose UI EditorDef (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) -> Behavior (Maybe a) -> Compose UI EditorDef (Maybe a)-editorSelection options display b = Compose $ do-  l <- listBox options b display-  return $ EditorDef (tidings b (rumors $ userSelection l)) (Single $ getElement l)---- | Ignores 'Nothing' values and only updates for 'Just' values-editorJust :: (Behavior (Maybe b) -> Compose UI EditorDef (Maybe b))-  -> Behavior b-  -> Compose UI EditorDef b-editorJust editor b = Compose $ do-  e <- getCompose $ editor (Just <$> b)-  let ev = filterJust (editedDef e)-  return $ EditorDef (tidings b ev) (editorDefLayout e)---- | An editor for union types, built from editors for its constructors.-editorSum-  :: (Ord tag, Show tag)-  => (Layout -> Layout -> Layout) -> [(tag, Compose UI EditorDef a)] -> (a -> tag) -> Behavior a -> Compose UI EditorDef a-editorSum combineLayout options selector ba = Compose $ do-  options <- mapM (\(tag, Compose mk) -> (tag,) <$> (mk >>= runEditorDef)) options-  let tag = selector <$> ba-  tag' <- calmB tag-  let build a = lookup a options-  -- build a tag selector following the current tag-  l <- listBox (pure $ fmap fst options) (Just <$> tag) (pure (string . show))-  -- a placeholder for the constructor editor-  nestedEditorDef <--    new # sink children ((\x -> [maybe (error "editorSum") editorElement (build x)]) <$> tag')-  ---  let composed = combineLayout (Single (getElement l)) (Single nestedEditorDef)-  -- the result event fires when any of the nested editors or the tag selector fire.-  let editedEvents = fmap (edited . snd) options-      eTag = filterJust $ rumors (userSelection l)-      taggedOptions = sequenceA [(tag, ) <$> contents e | (tag, e) <- options]-      editedTag = filterJust $ flip lookup <$> taggedOptions <@> eTag-      editedE = head <$> unions (editedTag : editedEvents)-  return $ EditorDef (tidings ba editedE) composed---- | Returns a new behavior that only notifies for new values.-calmB :: Eq a => Behavior a -> UI (Behavior a)-calmB b = do-  w <- askWindow-  (e, trigger) <- liftIO newEvent-  liftIOLater $ do-    current <- currentValue b-    trigger current-    runUI w $ onChanges b (liftIO . trigger)-  eCalm <- calmE e-  fmap (fromMaybe (error "calmB")) <$> stepper Nothing (Just <$> eCalm)--data Memory a = Empty | New a | Same a-updateMemory :: Eq a => a -> Memory a -> Memory a-updateMemory x Empty  = New x-updateMemory x (New  a) | a /= x = New x-updateMemory x (Same a) | a /= x = New x-updateMemory x _ = Same x-isNew :: Memory a -> Maybe a-isNew (New x) = Just x-isNew _ = Nothing---- | Returns a new 'Event' that skips consecutive triggers with the same value.-calmE :: Eq a => Event a -> UI (Event a)-calmE e =-  filterJust . fmap isNew <$> accumE Empty (updateMemory <$> e)--instance Editable () where-  editor b = Compose $ do-    t <- new-    return $ EditorDef (tidings b never) (Single t)--instance a ~ Char => Editable [a] where-  editor b = Compose $ do-    w <- askWindow-    t <- entry b-    liftIOLater $ do-      initialValue <- currentValue b-      _ <- runUI w $ set value initialValue (element t)-      return ()-    return $ EditorDef (userText t) (Single $ getElement t)--instance Editable Bool where-  editor b = Compose $ do-    t <- sink checked b $ input # set type_ "checkbox"-    return $ EditorDef (tidings b $ checkedChange t) (Single t)--instance Editable (Maybe Int) where editor = editorReadShow-instance Editable (Maybe Double) where editor = editorReadShow-instance Editable Int where editor = editorJust editor-instance Editable Double where editor = editorJust editor---instance (Editable a, Editable b) => Editable (a,b) where-  editor b = (,) <$> editor (fst <$> b) |*| editor (snd <$> b)

@@ -0,0 +1,214 @@+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE NamedFieldPuns       #-}+{-# LANGUAGE OverloadedLists      #-}+{-# LANGUAGE PatternSynonyms      #-}+{-# LANGUAGE RecordWildCards      #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns         #-}+{-# OPTIONS_GHC -Wno-name-shadowing     #-}++module Graphics.UI.Threepenny.Editors.Layout+  (+  -- * Renderableable widgets+    Renderable(..)+  -- * Layout engine+  , Layout(Grid, Single)+  , beside+  , above+  -- * Layout monoids+  -- ** Flat+  , Vertical(..)+  , vertical+  , Horizontal(..)+  , horizontal+  -- ** Columns+  , Columns (Break, Next)+  -- * Type level layouts+  , type (|*|)(..)+  , type (-*-)(..)+  ) where++import           Data.Biapplicative+import           Data.Bifoldable+import           Data.Foldable                   (length)+import           Data.Map.Strict                 (Map)+import qualified Data.Map.Strict                 as Map+import           Data.Maybe+import           Data.Monoid+import           Data.Sequence                   (Seq)+import qualified Data.Sequence                   as Seq+import           GHC.Exts                        (IsList (..))+import           Graphics.UI.Threepenny.Core     as UI+import           Graphics.UI.Threepenny.Elements+import           Graphics.UI.Threepenny.Widgets++-- | Closely related to 'Widget', this class represents types that can be rendered to an 'Element'+class Renderable w where+  render    :: w -> UI Element+  getLayout :: w -> Layout+  render = runLayout . getLayout+  getLayout = Cell . Just . render++instance Renderable Element where+  render = return++instance Renderable a => Renderable (UI a) where+  render = (>>= render)++instance Renderable TextEntry where+  render = return . getElement++instance Renderable (ListBox a) where+  render = return . getElement++instance Renderable String where+  render = string++data Layout+  = Grid (Seq (Seq Layout)) -- ^ A non empty list of rows, where all the rows are assumed to have the same length+  | Cell (Maybe (UI Element))++pattern Empty :: Layout+pattern Empty = Cell Nothing++pattern Single :: UI Element -> Layout+pattern Single x = Cell (Just x)++above, beside :: Layout -> Layout -> Layout+above (Grid rows@(length.head.toList -> l1)) (Grid rows'@(length.head.toList -> l2)) =+    Grid $ fmap pad1 rows <> fmap pad2 rows'+  where+    pad l1 l2 | l1 >= l2  = id+              | otherwise = (<> Seq.replicate (l2-l1) (Cell Nothing))+    pad1 = pad l1 l2+    pad2 = pad l2 l1+above x (Cell Nothing) = x+above (Cell Nothing) x = x+above cell@(Cell Just{}) x = above (Grid [[cell]]) x+above x cell@(Cell Just{}) = above x (Grid [[cell]])++beside (Grid rows@(length -> l1)) (Grid rows'@(length -> l2)) =+  Grid $ Seq.zipWith (<>) (pad1 rows) (pad2 rows')+  where+    pad l1 l2+      | l1 >= l2  = id+      | otherwise = \x ->+          let padding = Seq.replicate (length $ head $ toList x) (Cell Nothing)+          in x <> Seq.replicate (l2 - l1) padding+    pad1 = pad l1 l2+    pad2 = pad l2 l1+beside x (Cell Nothing) = x+beside (Cell Nothing) x = x+beside cell@(Cell Just{}) x = beside (Grid [[cell]]) x+beside x cell@(Cell Just{}) = beside x (Grid [[cell]])++instance Renderable Layout where+  getLayout = id++runLayout :: Layout -> UI Element+runLayout (Grid rows) = grid (toList $ fmap (fmap runLayout . toList) rows)+runLayout (Cell el)   = fromMaybe new el++-- | A layout monoid that places everything in a single column+newtype Vertical = Vertical { getVertical :: Layout}++vertical :: Renderable w => w -> Vertical+vertical = Vertical . getLayout++instance Monoid Vertical where+  mempty = Vertical Empty+  mappend (Vertical a) (Vertical b)= Vertical $ above a b++instance Renderable Vertical where+  getLayout = getVertical++-- | A layout monoid that places everything in a single row+newtype Horizontal = Horizontal { getHorizontal :: Layout}++horizontal :: Renderable w => w -> Horizontal+horizontal = Horizontal . getLayout++instance Monoid Horizontal where+  mempty = Horizontal Empty+  mappend (Horizontal a) (Horizontal b)= Horizontal $ beside a b++instance Renderable Horizontal where+  getLayout = getHorizontal++-- | A layout monoid that lays elements in columns+data Columns+  = Next  Layout -- ^ Continue in the same column+  | Break Layout -- ^ Continue in the next column+  | Columns { next    :: (Int, Int)            -- ^ (row, column)+            , acc     :: Map (Int, Int) Layout+            }++instance Renderable Columns where+  getLayout = layoutColumns++instance Show Columns where+  show(Next _)   = "Next"+  show(Break _)  = "Break"+  show Columns{..} = unwords ["Columns", show next, show (Map.keys acc)]++layoutColumns :: Columns -> Layout+layoutColumns (Next l) = l+layoutColumns (Break l) = l+layoutColumns Columns{acc}+  | Map.null acc = Empty+  | otherwise =+    getLayout $+    foldMap Vertical+      [ getLayout $+        foldMap Horizontal $ catMaybes [Map.lookup (i, j) acc | j <- [0 .. c]]+        | i <- [0 .. r]+      ]+  where+    r = maximum $ fst <$> Map.keys acc+    c = maximum $ snd <$> Map.keys acc++instance Monoid Columns where+  mempty = Columns (-1,-1) mempty+  mappend (Next a) (Columns (r,c) g) = let xy = (r+1, max 0 c) in Columns xy (Map.insert xy a g)+  mappend (Break a) (Columns (_,c) g) = let xy = (0, c + 1) in Columns xy (Map.insert xy a g)+  -- merging two columns should not ever happen, but if it does we will merge the columns and Break into a new one+  mappend (Columns (r,c) g) (Columns (r',_) g') = Columns (r+r'+1, -1) (Map.union g (Map.mapKeys (\(x,y) -> (x+r+1,y+c+1)) g'))+  mappend c@Columns{} other = mappend other c+  -- Next and Break merges should not arise in practice either+  mappend (Next  a) (Next  b) = Columns ( 1,0) (Map.fromList [((0,0),a), ((1,0),b)])+  mappend (Next  a) (Break b) = Columns ( 0,1) (Map.fromList [((0,0),a), ((0,1),b)])+  mappend (Break a) (Break b) = mappend (Next a) (Break b)+  mappend (Break a) (Next  b) = mappend (Next a) (Next  b)++-- | Type level Horizontal layouts+data a |*| b = a :|*| b++instance Bifunctor (|*|) where+  bimap f g (a :|*| b) = f a :|*| g b++instance Bifoldable (|*|) where+  bifoldMap f g (a :|*| b) = f a `mappend` g b++instance Biapplicative (|*|) where+  bipure a b = a :|*| b+  fa :|*| fb <<*>> a :|*| b = fa a :|*| fb b++instance (Renderable a, Renderable b) => Renderable (a |*| b) where+  getLayout (a :|*| b) = getLayout a `beside` getLayout b++-- | Type level Vertical layouts+data a -*- b = a :-*- b++instance Bifunctor (-*-) where+  bimap f g (a :-*- b) = f a :-*- g b++instance Bifoldable (-*-) where+  bifoldMap f g (a :-*- b) = f a `mappend` g b++instance Biapplicative (-*-) where+  bipure a b = a :-*- b+  fa :-*- fb <<*>> a :-*- b = fa a :-*- fb b++instance (Renderable a, Renderable b) => Renderable (a -*- b) where+  getLayout (a :-*- b) = getLayout a `above` getLayout b

@@ -1,297 +0,0 @@-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeInType #-}-{-# OPTIONS -Wno-orphans #-}--module Graphics.UI.Threepenny.Editors.Profunctor-  ( -- * Editors-    Base.Editor(..)-  , Base.edited-  , Base.contents-  , EditorFactory(..)-  , createEditor-  , Editable(..)-    -- ** Editor composition-  , (|*|), (|*), (*|)-  , (-*-), (-*), (*-)-  , field-  , Vertically(..)-  , Horizontally(..)-    -- ** Editor constructors-  , editorUnit-  , editorIdentity-  , editorReadShow-  , editorEnumBounded-  , editorSelection-  , editorSum-  , editorJust-    -- ** Generic editors-  , editorGeneric-  , editorGenericSimple-    -- ** Layouts-  , Base.Layout(Grid, Single)-  , Base.horizontal-  , Base.vertical-  )where--import           Data.Bifunctor-import           Data.Char-import           Data.Default-import           Data.Functor.Compose-import           Data.Functor.Identity-import           Data.Maybe-import           Data.Profunctor-import           Data.Proxy-import           Generics.SOP hiding (Compose)-import           Graphics.UI.Threepenny.Core-import qualified Graphics.UI.Threepenny.Editors.Base as Base-import           Text.Casing---- | A function from 'Behavior' @a@ to 'Editor' @a@-newtype EditorFactory a b = EditorFactory-  { run :: Behavior a -> Compose UI Base.EditorDef b-  }---- | Create an editor to display the argument.---   User edits are fed back via the 'edited' 'Event'.-createEditor :: EditorFactory b a -> Behavior b -> UI (Base.Editor a)-createEditor e b = getCompose (run e b) >>= Base.runEditorDef--instance Functor (EditorFactory a) where-  fmap = dimap id--instance Profunctor EditorFactory where-  dimap g h (EditorFactory f) = EditorFactory $ \b -> h <$> f (g <$> b)----- | The class of 'Editable' datatypes.---   .---   Define your own instance by using the 'Applicative' composition operators or---   derive it via 'Generics.SOP'.-class Editable a where-  editor :: EditorFactory a a-  default editor :: (Generic a, HasDatatypeInfo a, (All (All Editable `And` All Default) (Code a))) => EditorFactory a a-  editor = editorGeneric--infixl 4 |*|, -*--infixl 5 |*, *|, -*, *----- | Horizontal applicative composition.-(|*|) :: EditorFactory s (b->a) -> EditorFactory s b -> EditorFactory s a-a |*| b = EditorFactory $ \s -> run a s Base.|*| run b s--(|*) :: EditorFactory s a -> UI Element -> EditorFactory s a-a |* e = EditorFactory $ \s -> run a s Base.|* e--(*|) :: UI Element -> EditorFactory s a -> EditorFactory s a-e *| a = EditorFactory $ \s -> e Base.*| run a s---- | Vertical applicative composition.-(-*-) :: EditorFactory s (b->a) -> EditorFactory s b -> EditorFactory s a-a -*- b = EditorFactory $ \s -> run a s Base.-*- run b s--(-*) :: EditorFactory s a -> UI Element -> EditorFactory s a-a -* e = EditorFactory $ \s -> run a s Base.-* e--(*-) :: UI Element -> EditorFactory s a -> EditorFactory s a-e *- a = EditorFactory $ \s -> e Base.*- run a s---- | A helper that arranges a label with the field name---   and the editor horizontally.-field :: String -> (out -> inn) -> EditorFactory inn a -> EditorFactory out a-field name f e = string name *| lmap f e--editorUnit :: EditorFactory a ()-editorUnit = EditorFactory $ \_ -> Base.editor (pure ())---- | An editor that presents a free form input.-editorReadShow :: (Read a, Show a) => EditorFactory (Maybe a) (Maybe a)-editorReadShow = EditorFactory Base.editorReadShow---- | An editor that presents a choice of values.-editorEnumBounded-  :: (Show a, Ord a, Enum a, Bounded a)-  => Behavior (a -> UI Element) -> EditorFactory (Maybe a) (Maybe a )-editorEnumBounded display = EditorFactory $ Base.editorEnumBounded display---- | Ignores 'Nothing' values and only updates for 'Just' values-editorJust :: EditorFactory (Maybe a) (Maybe a) -> EditorFactory a a-editorJust e = EditorFactory $ Base.editorJust (run e)---- | An editor that presents a dynamic choice of values.-editorSelection :: Ord a => Behavior [a] -> Behavior(a -> UI Element) -> EditorFactory (Maybe a) (Maybe a)-editorSelection opts displ = EditorFactory $ Base.editorSelection opts displ---- | An editor for union types, built from editors for its constructors.-editorSum-  :: (Show tag, Ord tag)-  => (Base.Layout -> Base.Layout -> Base.Layout) -> [(tag, EditorFactory b b)] -> (b -> tag) -> EditorFactory b b-editorSum layout nested tagger = EditorFactory $ \b ->-  let nested' = [ (tag, run f b) | (tag, f) <- nested ]-  in Base.editorSum layout nested' tagger b--instance Editable () where editor = EditorFactory Base.editor-instance Editable String where editor = EditorFactory Base.editor-instance Editable Bool where editor = EditorFactory Base.editor-instance Editable Int where editor = EditorFactory Base.editor-instance Editable Double where editor = EditorFactory Base.editor-instance Editable (Maybe Int) where editor = EditorFactory Base.editor-instance Editable (Maybe Double) where editor = EditorFactory Base.editor--instance (Editable a, Editable b) => Editable (a,b) where-  editor = (,) <$> lmap fst editor |*| lmap snd editor--instance Editable a => Editable (Identity a) where-  editor = editorIdentity editor--editorIdentity :: EditorFactory a a -> EditorFactory (Identity a) (Identity a)-editorIdentity = dimap runIdentity Identity--{---------------------------------------------  Generic derivations----------------------------------------------}--- | A generic editor for record types.-editorGenericSimple-  :: forall a xs.-     (Generic a, HasDatatypeInfo a, All Editable xs, Code a ~ '[xs])-  => EditorFactory a a-editorGenericSimple = dimap from to $ editorGenericSimple' (datatypeInfo(Proxy @ a))--editorGenericSimple'-  :: forall xs.-     (All Editable xs)-  => DatatypeInfo '[xs] -> EditorFactory (SOP I '[xs]) (SOP I '[xs])-editorGenericSimple' (ADT _ _ (c :* Nil)) = constructorEditorFor c-editorGenericSimple' (Newtype _ _ c) = constructorEditorFor c--constructorEditorFor-  :: (All Editable xs)-  => ConstructorInfo xs-  -> EditorFactory (SOP I '[xs]) (SOP I '[xs])-constructorEditorFor (Record _ fields) = dimap (unZ . unSOP) (SOP . Z) $ constructorEditorFor' fields-constructorEditorFor (Constructor _) = dimap (unZ . unSOP) (SOP . Z) editor-constructorEditorFor Infix{} = dimap (unZ . unSOP) (SOP . Z) editor---- | A generic editor for SOP types.-editorGeneric-  :: forall a .-     (Generic a, HasDatatypeInfo a, (All (All Editable `And` All Default) (Code a)))-  => EditorFactory a a-editorGeneric = dimap from to $ editorGeneric' (datatypeInfo(Proxy @ a))--editorGeneric'-  :: forall xx.-     (All (All Editable `And` All Default) xx)-  => DatatypeInfo xx -> EditorFactory (SOP I xx) (SOP I xx)-editorGeneric' (ADT _ _ (c :* Nil)) = constructorEditorFor c-editorGeneric' (ADT _ _ cc) = editorSum Base.vertical editors constructor where-  editors :: [(Tag, EditorFactory (SOP I xx) (SOP I xx))]-  editors = map (first Tag) $ constructorEditorsFor cc-  constructors = hmap (K . constructorName) cc-  constructor a = Tag $ hcollapse $ hliftA2 const constructors (unSOP a)-editorGeneric' (Newtype _ _ c) = constructorEditorFor c--newtype Tag = Tag String deriving (Eq, Ord)-instance Show Tag where show (Tag t) = init $ toFieldLabel t--constructorEditorsFor-  :: forall xx . (All (All Editable `And` All Default) xx)-  => NP ConstructorInfo xx -> [(String, EditorFactory (SOP I xx) (SOP I xx))]-constructorEditorsFor cc =-  hcollapse $ hcliftA3 p (\c i p -> (constructorName c,) `mapKK` constructorEditorForUnion c i p) cc-    (injections  :: NP (Injection  (NP I) xx) xx)-    (projections :: NP (Projection (Compose Maybe (NP I)) xx) xx)-  where-    p = Proxy @ (All Editable `And` All Default)--constructorEditorForUnion-  :: (SListI xx, All Editable xs, All Default xs)-  => ConstructorInfo xs-  -> Injection (NP I) xx xs-  -> Projection (Compose Maybe (NP I)) xx xs-  -> K (EditorFactory (SOP I xx) (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--composeEditorFactory-  :: forall xss xs.-    (SListI xss, All Default xs) =>-     Injection (NP I) xss xs-  -> Projection (Compose Maybe (NP I)) xss xs-  -> EditorFactory (NP I xs) (NP I xs)-  -> EditorFactory (SOP I xss) (SOP I xss)-composeEditorFactory (Fn inj) (Fn prj) = dimap 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) (NP I xs)-constructorEditorFor' fields = vertically $ hsequence $ hliftA Vertically $ fieldsEditor (hliftA (K . fieldName) fields)---- | Tuple editor without fields-instance All Editable xs => Editable (NP I xs) where-  editor = horizontally $ hsequence $ hliftA Horizontally tupleEditor--tupleEditor :: forall xs . All Editable xs => NP (EditorFactory (NP I xs)) 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)) ys-  go _ SNil = Nil-  go f SCons = lmap (unI . hd . f) editor :* go (tl . f) sList--fieldsEditor :: forall xs . All Editable xs => NP (K String) xs -> NP (EditorFactory (NP I xs)) 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)) ys-  go _ SNil Nil = Nil-  go f SCons (K fn :* xs) = field (toFieldLabel fn) (unI . hd . f) editor :* go (tl . f) sList xs--toFieldLabel :: String -> String-toFieldLabel (fromAny -> Identifier (x:xx)) =-  unwords (onHead toUpper x : map (onHead toLower) xx) ++ ":"-    where-      onHead f (x:xx) = f x : xx-      onHead _ [] = []-toFieldLabel _ = ""---- | Applicative instance for vertical composition of editor factories.------   This can be used in conjunction with ApplicativeDo as:------ > editorPerson = vertically $ do--- >       firstName <- Vertically $ field "First:" firstName editor--- >       lastName  <- Vertically $ field "Last:"  lastName editor--- >       age       <- Vertically $ field "Age:"   age editor--- >       return Person{..}--newtype Vertically a b = Vertically {vertically :: EditorFactory a b} deriving (Functor, Profunctor)-instance Applicative (Vertically a) where-  pure x = Vertically $ const x <$> editorUnit-  Vertically a <*> Vertically b = Vertically (a -*- b)---- | Applicative instance for horizontal composition of editor factories.---   This can be used in conjunction with ApplicativeDo as:------ > editorPerson = horizontally $ do--- >       firstName <- Horizontally $ field "First:" firstName editor--- >       lastName  <- Horizontally $ field "Last:"  lastName editor--- >       age       <- Horizontally $ field "Age:"   age editor--- >       return Person{..}-newtype Horizontally a b = Horizontally {horizontally :: EditorFactory a b} deriving (Functor, Profunctor)-instance Applicative (Horizontally a) where-  pure x = Horizontally $ const x <$> editorUnit-  Horizontally a <*> Horizontally b = Horizontally (a |*| b)--instance (Applicative f, All Default xs) => Default (NP f xs) where-  def = hcpure (Proxy @ Default) (pure def)

@@ -0,0 +1,306 @@+{-# LANGUAGE DataKinds       #-}+{-# LANGUAGE DeriveFunctor   #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TupleSections   #-}+{-# LANGUAGE ViewPatterns    #-}+{-# OPTIONS_GHC -Wno-name-shadowing     #-}+{-# OPTIONS_GHC -Wno-duplicate-exports  #-}++module Graphics.UI.Threepenny.Editors.Types+  (+  -- * Editors+    Editor(..)+  , edited+  , contents+  , editorElement+  , EditorFactory(.., Horizontally, horizontally, Vertically, vertically)+  , dimapEF+  , lmapEF+  , applyEF+  , createEditor+  , renderEditor+  , editorFactoryElement+  , editorFactoryInput+  , editorFactoryOutput+    -- ** Editor composition+  , (|*|), (|*), (*|)+  , (-*-), (-*), (*-)+  , field+  , fieldLayout+  , edit+  , pattern Horizontally+  , pattern Vertically+    -- ** Editor constructors+  , editorUnit+  , editorIdentity+  , editorString+  , editorCheckBox+  , editorReadShow+  , editorEnumBounded+  , editorSelection+  , editorSum+  , editorJust+    -- ** Editor layout+  , withLayout+  , construct+  ) where++import           Control.Applicative+import           Control.Lens                          hiding (beside, children,+                                                        element, set, ( # ))+import           Data.Biapplicative+import           Data.Functor.Compose+import           Graphics.UI.Threepenny.Attributes+import           Graphics.UI.Threepenny.Core           as UI+import           Graphics.UI.Threepenny.Editors.Layout+import           Graphics.UI.Threepenny.Editors.Utils+import           Graphics.UI.Threepenny.Elements+import           Graphics.UI.Threepenny.Events+import           Graphics.UI.Threepenny.Widgets+import           Text.Read++-- | A widget for editing values of type @a@.+data Editor editorElement a = Editor+  { _editorTidings :: Tidings a+  , _editorElement :: editorElement+  }+  deriving Functor++instance Bifunctor Editor where+  bimap f g (Editor t e) = Editor (g <$> t) (f e)++-- | 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++edited :: Editor el a -> Event a+edited = rumors . _editorTidings++contents :: Editor el a -> Behavior a+contents = facts . _editorTidings++instance Widget el => Widget (Editor el a) where+  getElement = getElement . _editorElement++renderEditor :: Renderable w => Editor w a -> UI (Editor Element a)+renderEditor = mapMOf editorElement 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@+--   All the three type arguments are functorial, but @a@ is contravariant.+--   'EditorFactory' 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)}++_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++-- | 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++-- | A 'Setter' over the input thing+editorFactoryInput :: Setter (EditorFactory a el b) (EditorFactory a' el b) a' a+editorFactoryInput = _EditorFactory.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++liftElement :: UI el -> EditorFactory a el ()+liftElement el = EF $ \_ -> Editor (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++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))++-- | Applies a function over the input+lmapEF :: (a' -> a) -> EditorFactory a el b -> EditorFactory a' el b+lmapEF f = dimapEF 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 =+-- >     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++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)++instance Functor (EditorFactory a el) where+  fmap = dimapEF id++instance Bifunctor (EditorFactory a) where+  bimap = bimapEF++instance Biapplicative (EditorFactory a) where+  bipure w o = EF $ \_ -> return $ Editor (pure o) w+  (<<*>>) = applyEF ($)++instance Monoid el => Applicative (EditorFactory a el) where+  pure = bipure mempty+  (<*>) = applyEF mappend++-- | Applicative modifier for vertical composition of editor factories.+--   This can be used in conjunction with ApplicativeDo as:+--+-- > editorPerson = vertically $ do+-- >       firstName <- Vertically $ field "First:" firstName editor+-- >       lastName  <- Vertically $ field "Last:"  lastName editor+-- >       age       <- Vertically $ field "Age:"   age editor+-- >       return Person{..}+--+-- DEPRECATED: Use the 'Vertical' layout builder instead+pattern Vertically :: EditorFactory a Layout b -> EditorFactory a Vertical b+pattern Vertically {vertically} <- (withLayout getVertical -> vertically) where Vertically a = withLayout Vertical a++-- | Applicative modifier for horizontal composition of editor factories.+--   This can be used in conjunction with ApplicativeDo as:+--+-- > editorPerson = horizontally $ do+-- >       firstName <- Horizontally $ field "First:" firstName editor+-- >       lastName  <- Horizontally $ field "Last:"  lastName editor+-- >       age       <- Horizontally $ field "Age:"   age editor+-- >       return Person{..}+--+-- DEPRECATED: Use the 'Horizontal' layout builder instead+pattern Horizontally :: EditorFactory a Layout b -> EditorFactory 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 = over editorFactoryElement++-- | Construct a concrete 'Layout'. Useful when combining heterogeneours layout builders.+construct :: Renderable m => EditorFactory a m b -> EditorFactory a Layout b+construct = withLayout getLayout++-- | Left-right editor composition+(|*|) :: EditorFactory s Layout (b -> a) -> EditorFactory s Layout b -> EditorFactory 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+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+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+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+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+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))++-- | 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)++editorUnit :: EditorFactory b Element b+editorUnit = EF $ \b -> do+    t <- new+    return $ Editor (tidings b never) t++editorCheckBox :: EditorFactory Bool Element Bool+editorCheckBox = EF $ \b -> do+    t <- sink checked b $ input # set type_ "checkbox"+    return $ Editor (tidings b $ checkedChange t) t++editorString :: EditorFactory String TextEntry String+editorString = EF $ \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++editorReadShow :: (Read a, Show a) => EditorFactory (Maybe a) TextEntry (Maybe a)+editorReadShow = EF $ \b -> do+    e <- runEF editorString (maybe "" show <$> b)+    let readIt "" = Nothing+        readIt x  = readMaybe x+    let t = tidings b (readIt <$> edited e)+    return $ Editor t (_editorElement 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)+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+  l <- listBox options b display+  return $ Editor (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+  e <- editor (Just <$> b)+  let ev = filterJust (edited e)+  return $ Editor (tidings b ev) (_editorElement 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+  let tag = selector <$> ba+  tag' <- calmB tag+  let build a = lookup a options+  -- build a tag selector following the current tag+  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')+  --+  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.+  let editedEvents = fmap (edited . snd) options+      eTag = filterJust $ rumors (userSelection l)+      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++editorIdentity :: EditorFactory a el a -> EditorFactory (Identity a) el (Identity a)+editorIdentity = dimapEF runIdentity Identity

@@ -0,0 +1,31 @@+module Graphics.UI.Threepenny.Editors.Utils (calmB, calmE) where++import           Data.Maybe+import           Graphics.UI.Threepenny.Core as UI++-- | Returns a new behavior that only notifies for new values.+calmB :: Eq a => Behavior a -> UI (Behavior a)+calmB b = do+  w <- askWindow+  (e, trigger) <- liftIO newEvent+  liftIOLater $ do+    current <- currentValue b+    trigger current+    runUI w $ onChanges b (liftIO . trigger)+  eCalm <- calmE e+  fmap (fromMaybe (error "calmB")) <$> stepper Nothing (Just <$> eCalm)++data Memory a = Empty | New a | Same a+updateMemory :: Eq a => a -> Memory a -> Memory a+updateMemory x Empty  = New x+updateMemory x (New  a) | a /= x = New x+updateMemory x (Same a) | a /= x = New x+updateMemory x _ = Same x+isNew :: Memory a -> Maybe a+isNew (New x) = Just x+isNew _ = Nothing++-- | Returns a new 'Event' that skips consecutive triggers with the same value.+calmE :: Eq a => Event a -> UI (Event a)+calmE e =+  filterJust . fmap isNew <$> accumE Empty (updateMemory <$> e)

@@ -1,9 +1,9 @@--- This file has been generated from package.yaml by hpack version 0.17.0.+-- This file has been generated from package.yaml by hpack version 0.17.1. -- -- see: https://github.com/sol/hpack  name:           threepenny-editors-version:        0.4.1+version:        0.5.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.@@ -37,16 +37,19 @@   ghc-options: -Wall -Wno-name-shadowing   build-depends:       base >= 4.7 && < 5+    , bifunctors     , containers     , data-default     , generics-sop+    , lens     , profunctors     , threepenny-gui > 0.7     , casing   exposed-modules:       Graphics.UI.Threepenny.Editors-      Graphics.UI.Threepenny.Editors.Base-      Graphics.UI.Threepenny.Editors.Profunctor+      Graphics.UI.Threepenny.Editors.Layout+      Graphics.UI.Threepenny.Editors.Utils+      Graphics.UI.Threepenny.Editors.Types   other-modules:       Paths_threepenny_editors   default-language: Haskell2010@@ -59,6 +62,7 @@   if flag(buildExamples)     build-depends:         base+      , bifunctors       , data-default       , generics-sop       , profunctors