SetView.hs

module Examples.Grapefruit.SetView (

    mainCircuit

) where

    -- Control
    import Control.Applicative as Applicative
    import Control.Arrow       as Arrow

    -- Data
    import Data.Monoid          as Monoid
    import Data.Sequence        as Seq
    import Data.Set             as Set
    import Data.Colour.RGBSpace as RGBSpace
    import Data.Record          as Record

    -- FRP.Grapefruit
    import FRP.Grapefruit.Signal                 as Signal
    import FRP.Grapefruit.Signal.Discrete        as DSignal
    import FRP.Grapefruit.Signal.Incremental     as ISignal
    import FRP.Grapefruit.Signal.Incremental.Set as SetISignal

    -- Graphics.UI.Grapefruit
    import Graphics.UI.Grapefruit.Item              as UIItem             hiding (box)
    import Graphics.UI.Grapefruit.Circuit           as UICircuit
    import Graphics.UI.Grapefruit.Backend.Basic     as BasicUIBackend
    import Graphics.UI.Grapefruit.Backend.Container as ContainerUIBackend

    -- |The circuit describing the whole application.
    mainCircuit :: (ContainerUIBackend uiBackend) =>
                   UICircuit Window uiBackend era () (DSignal era ())
    mainCircuit = proc _ -> do
        X :& Closure := closure
             `With` X
             `With` _           <- mainWindow -< X :& Title := pure "Set view"
                                                      `With` X
                                                      `With` ()
        returnA -< closure where

        mainWindow = window `with` box Vertical `with` content

    content :: (ContainerUIBackend uiBackend) => UICircuit Widget uiBackend era () ()
    content = proc _ -> do
        rec let

                names             = ISignal.construct Set.empty (DSignal.union insertions deletions)

                insertions        = elementInsertion <$> insertionNames

                deletions         = elementDeletion <$> deletionNames

                cols              = ISignal.const (Seq.fromList [firstNameCol,familyNameCol])

                firstNameCol      = Column "first name" firstNameDisplay textCell

                firstNameDisplay  = \(Name firstName _) -> TextCellDisplay firstName backgroundColor

                familyNameCol     = Column "family name" familyNameDisplay textCell

                familyNameDisplay = \(Name _ familyName) -> TextCellDisplay familyName
                                                                            backgroundColor

                backgroundColor   = RGB mempty mempty mempty

            _              <- display           -< (names,cols)
            insertionNames <- modifier "Insert" -< ()
            deletionNames  <- modifier "Delete" -< ()

        returnA -< ()

    display :: (ContainerUIBackend uiBackend) =>
               UICircuit Widget
                         uiBackend
                         era
                         (ISignal era (Set Name),ISignal era (Seq (Column uiBackend Name)))
                         ()
    display = proc (names,cols) -> do
        X :& Selection := selection <- just setView -< X :& Elements := names
                                                         :& Columns  := cols
        X                           <- just label   -< X :& Text     := fmap (show . Set.toList)
                                                                             selection
        returnA -< ()

    modifier :: (BasicUIBackend uiBackend) =>
                String -> UICircuit Widget uiBackend era () (DSignal era Name)
    modifier actionText = proc _ -> do
        X :& Content := firstName  <- just lineEditor -< X
        X :& Content := familyName <- just lineEditor -< X
        X :& Push    := push       <- just pushButton -< X :& Text := pure actionText
        returnA -< Name <$ push <#> firstName <#> familyName

    data Name = Name String String deriving (Eq, Ord, Show)