Hoodlums meetup 10 Aug 2017

CRUD.hs

{-# LANGUAGE ScopedTypeVariables #-}
{-----------------------------------------------------------------------------
    threepenny-gui

    Example:
    Small database with CRUD operations and filtering.
    To keep things simple, the list box is rebuild every time
    that the database is updated. This is perfectly fine for rapid prototyping.
    A more sophisticated approach would use incremental updates.
------------------------------------------------------------------------------}
{-# LANGUAGE RecursiveDo         #-}

import           Control.Monad               (void)
import           Data.List                   (isPrefixOf)
import qualified Data.Map                    as Map
import           Data.Maybe
import           Data.Monoid
import qualified Data.Set                    as Set
import           Prelude                     hiding (lookup)

import qualified Graphics.UI.Threepenny      as UI
import           Graphics.UI.Threepenny.Core hiding (delete)

{-----------------------------------------------------------------------------
    Main
------------------------------------------------------------------------------}
main :: IO ()
main = startGUI defaultConfig{jsPort=Just 8084} setup

setup :: Window -> UI ()
setup window =
  void $
  mdo return window # set title "CRUD Example (Simple)"
      filterEntry <- string "filter entry"
      createBtn <- UI.button # set text "Create"
      deleteBtn <- UI.button # set text "Delete"
      resetBtn <- UI.button # set text "Reset"

      listBox <- UI.listBox (keys <$> database) selectedItem bDisplayItem
      uiDataItem <- UI.entry ( (\db item -> maybe "" (displayElement db) item) <$> database <*> selectedItem)

      let databaseChanges = foldr (.) id <$> unions
              [ create "Foo" <$ UI.click createBtn
              , filterJust $ fmap delete <$> selectedItem <@ UI.click deleteBtn
              , const emptydb <$ UI.click resetBtn
              , update <$> (fromMaybe 0 <$> selectedItem) <@> rumors (UI.userText uiDataItem)
              ]


      let bDisplayItem = (\db -> string . displayElement db) <$> database

      let displayElement :: Database String -> DatabaseKey -> String
          displayElement db key = fromMaybe "impossible" $ lookup key db

      database :: Behavior (Database String) <- accumB emptydb databaseChanges
      selectedItem :: Behavior (Maybe DatabaseKey) <- stepper Nothing (rumors $ UI.userSelection listBox)

      contents <- string "data item" # sink text (show <$> database)
      getBody window #+
        [ grid
            [ [row [string "Filter prefix:", element filterEntry]]
            , [element listBox, element uiDataItem]
            , [row [element createBtn, element deleteBtn, element resetBtn]]
            , [element contents]

            ]
        ]


{-----------------------------------------------------------------------------
    Database Model
------------------------------------------------------------------------------}
type DatabaseKey = Int
data Database a = Database
  { nextKey :: !Int
  , db      :: Map.Map DatabaseKey a
  }
  deriving Show

emptydb = Database 0 Map.empty
keys    = Map.keys . db

create x     (Database newkey db) = Database (newkey+1) $ Map.insert newkey x db
update key x (Database newkey db) = Database newkey     $ Map.insert key    x db
delete :: DatabaseKey -> Database a -> Database a
delete key   (Database newkey db) = Database newkey     $ Map.delete key db
lookup key   (Database _      db) = Map.lookup key db

{-----------------------------------------------------------------------------
    Data items that are stored in the data base
------------------------------------------------------------------------------}
type DataItem = (String, String)
showDataItem (firstname, lastname) = lastname ++ ", " ++ firstname

-- | Data item widget, consisting of two text entries
dataItem
    :: Behavior (Maybe DataItem)
    -> UI ((Element, Element), Tidings DataItem)
dataItem bItem = do
    entry1 <- UI.entry $ fst . maybe ("","") id <$> bItem
    entry2 <- UI.entry $ snd . maybe ("","") id <$> bItem

    return ( (getElement entry1, getElement entry2)
           , (,) <$> UI.userText entry1 <*> UI.userText entry2
           )