{-----------------------------------------------------------------------------
    reactive-banana-wx
    
    Example: ListBox with CRUD operations
------------------------------------------------------------------------------}
{-# LANGUAGE RecursiveDo #-}
-- import Control.Monad
import qualified Data.List
import Data.Maybe
import qualified Data.Map as Map
import Graphics.UI.WX as WX hiding (Event)
import Reactive.Banana
import Reactive.Banana.WX

{-----------------------------------------------------------------------------
    Main
------------------------------------------------------------------------------}
main = start $ do
    -- GUI layout
    f        <- frame    [ text := "CRUD Example" ]
    listBox  <- singleListBox f []
    create   <- button f [ text := "Create" ]
    delete   <- button f [ text := "Delete" ]
    filter   <- entry f  [ processEnter := True ]
    
    name     <- entry f  [ processEnter := True ]
    surname  <- entry f  [ processEnter := True ]
    
    let dataItem = grid 10 10 [[label "Name:", widget name]
                              ,[label "Surname:", widget surname]]
    set f [layout := margin 10 $
            grid 10 5
                [[row 5 [label "Filter prefix:", widget filter], glue]
                ,[minsize (sz 200 300) $ widget listBox, dataItem]
                ,[row 10 [widget create, widget delete], glue]
                ]]

    -- event network
    network <- compile $ mdo
        -- events from buttons
        eDelete <- event0 delete command
        eCreate <- event0 create command       
        
        -- time-varying value corresponding to the filter string
        (bFilter, eFilter) <- reactimateTextEntry filter (pure "")
        let dFilter = stepperD "" $ bFilter <@ eFilter
        
        -- list box with selection
        dSelectedItem <- reactimateListBox listBox database dFilter
        -- data corresponding to the selected item in the list box
        (inDataItem, changeDataItem)
            <- reactimateDataItem (name, surname) outDataItem
        
        let
            -- update the database whenever
            -- a data item is created, updated or deleted
            database :: DatabaseTime DataItem
            database = accumDatabase $
                (Create Nothing ("Emil","Example") <$  eCreate)
                `union` (Update <$> dSelectedItem  <@>
                            (inDataItem <@ changeDataItem))
                `union` (Delete <$> dSelectedItem  <@  eDelete )
            
            -- display the data item whenever the selection changes
            outDataItem = stepperD ("","") $
                lookup <$> valueDB database <@> changes dSelectedItem
                where
                lookup database m = maybe ("","") id $
                    readDatabase database =<< m

        -- automatically enable / disable editing
        let dDisplayItem = maybe False (const True) <$> dSelectedItem
        sink delete  [ enabled :== dDisplayItem ]
        sink name    [ enabled :== dDisplayItem ]
        sink surname [ enabled :== dDisplayItem ]
    
    actuate network

{-----------------------------------------------------------------------------
    Database Model
------------------------------------------------------------------------------}
-- Create/Update/Delete data type for efficient updates
data CUD key a
    = Create { getKey :: key, getItem :: a }
    | Update { getKey :: key, getItem :: a }
    | Delete { getKey :: key }

instance Functor (CUD key) where
    fmap f (Delete x) = Delete x
    fmap f cud = cud { getItem = f $ getItem cud }

isDelete (Delete _) = True
isDelete _ = False

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

emptyDatabase = Database 0 Map.empty

-- Time-varying database,
-- similar to the Discrete type
data DatabaseTime a = DatabaseTime
    { valueDB   :: Behavior (Database a)
    , initialDB :: Database a
    , changesDB :: Event (CUD DatabaseKey a)
    }

-- accumulate a database from CUD operations
accumDatabase :: Event (CUD (Maybe DatabaseKey) a) -> DatabaseTime a
accumDatabase e = DatabaseTime valueDB initialDB changesDB
    where
    (changesDB, valueDB) = mapAccum initialDB $ acc <$> filterE valid e
    initialDB = emptyDatabase
    
    valid (Create Nothing _) = True
    valid cud = maybe False (const True) $ getKey cud
    
    -- accumulation function
    acc (Create Nothing x)    (Database newkey db)  
        = (Create newkey x, Database (newkey+1) $ Map.insert newkey x db)
    acc (Update (Just key) x) (Database newkey db)
        = (Update key x, Database newkey $ Map.insert key x db)
    acc (Delete (Just key))   (Database newkey db)
        = (Delete key  , Database newkey $ Map.delete key db)

-- read a value from the database
readDatabase :: Database a -> DatabaseKey -> Maybe a
readDatabase (Database _ db) = flip Map.lookup db

{-----------------------------------------------------------------------------
    Data items that are stored in the data base
------------------------------------------------------------------------------}
type DataItem = (String, String)

-- text entry widgets in terms of discrete time-varying values
reactimateTextEntry
    :: TextCtrl a
    -> Discrete String      -- set text programmatically (view)
    -> NetworkDescription
        (Behavior String    -- current text (both view & controller)
        ,Event ())          -- user changes (controller)
reactimateTextEntry entry input = do
    sink entry [ text :== input ]

    -- event: Enter key
    eEnter <- event0 entry command
    -- event: text entry loses focus
    eLeave <- (() <$) . filterE not <$> event1 entry focus
    b <- behavior entry text
    return (b, eEnter `union` eLeave)

-- whole data item (consisting of two text entries)
reactimateDataItem
    :: (TextCtrl a, TextCtrl b)
    -> Discrete DataItem
    -> NetworkDescription
        (Behavior DataItem, Event ())
reactimateDataItem (name,surname) input = do
    (d1,e1) <- reactimateTextEntry name    (fst <$> input)
    (d2,e2) <- reactimateTextEntry surname (snd <$> input)
    return ( (,) <$> d1 <*> d2 , e1 `union` e2 )

-- custom show function
showDataItem (name, surname) = surname ++ ", " ++ name 

{-----------------------------------------------------------------------------
    List Box View
------------------------------------------------------------------------------}
-- Display the data base in a list box (view).
-- Also keep track of the currently selected item (controller).
reactimateListBox
    :: SingleListBox b                 -- list box widget
    -> DatabaseTime DataItem           -- database
    -> Discrete String                 -- filter string
    -> NetworkDescription
        (Discrete (Maybe DatabaseKey)) -- current selection as database key

reactimateListBox listBox database filter = do
    -- The list box keeps track
    -- of which data items are displayed, at which positions
    let (eListBoxUpdates, bDisplayMap)
            = mapAccum Map.empty
            $ (cudUpdate . fmap showDataItem <$> changesDB database)
              `union` (filterUpdate <$> valueDB database <@> changes filter)
    
    -- "animate" changes to the list box
    reactimate $ eListBoxUpdates
    -- debug: reactimate $ fmap print $ bDisplayMap <@ eListBoxUpdates
        
    -- event: item selection, maps to database key
    fixSelectionEvent listBox
    bSelection <- behavior listBox selection
    eSelect    <- event0   listBox select
    let eDelete   = filterE isDelete $ changesDB database
    return $ stepperD Nothing $
        -- event: item deleted 
        (Nothing <$ eDelete) `union`
        -- event: filter string changed
        (Nothing <$ changes filter) `union`
        -- event: user changes selection
        (lookupPositon <$> bSelection <*> bDisplayMap <@ eSelect)

    where

    -- turn CUD into a function that updates
    --   ( the graphics of the list box
    --   , the map from database keys to list positions )
    cudUpdate
        :: CUD DatabaseKey String -> DisplayMap -> (IO (), DisplayMap)

    cudUpdate (Create key str) display
        = (itemAppend listBox str, appendKey key display)
    cudUpdate (Update key str) display
        = case lookupKey key display of
            Just position -> (set listBox [ item position := str ], display)
            Nothing       -> (return (), display)
    cudUpdate (Delete key) display
        = case lookupKey key display of
            Just position -> (itemDelete listBox position
                             ,deleteKey key position display)
            Nothing       -> (return (), display)
    
    -- rebuild listBox when filter string changes
    filterUpdate database s _ = (set listBox [ items := xs ], display)
        where
        dat = Map.filter (s `Data.List.isPrefixOf`)
            . Map.map showDataItem . db $ database
        xs  = Map.elems dat
        display = Map.fromList $ zip (Map.keys dat) [0..] 


-- Map between database keys and their position in the list box
type DisplayMap = Map.Map DatabaseKey Int

lookupKey = Map.lookup
lookupPositon pos = fmap fst . Data.List.find ((pos ==) . snd) . Map.toList
appendKey key display = Map.insert key (Map.size display) display
deleteKey key position display
    = Map.delete key
    -- recalculate positions of the other elements
    . Map.map (\pos -> if pos > position then pos - 1 else pos)
    $ display

{-----------------------------------------------------------------------------
    wxHaskell bug fixes
------------------------------------------------------------------------------}
-- Fix @select@ event not being fired when items are *un*selected
fixSelectionEvent listbox =
    liftIO $ set listbox [ on unclick := handler ]
    where
    handler _ = do
        propagateEvent
        s <- get listbox selection
        when (s == -1) $ (get listbox (on select)) >>= id