hscurses-1.5.0.0: example/ContactManager.hs

-- Copyright (c) 2005-2011 Stefan Wehr (http://www.stefanwehr.de)
--
-- Permission is hereby granted, free of charge, to any person obtaining a
-- copy of this software and associated documentation files (the
-- "Software"), to deal in the Software without restriction, including
-- without limitation the rights to use, copy, modify, merge, publish,
-- distribute, sublicense, and/or sell copies of the Software, and to
-- permit persons to whom the Software is furnished to do so, subject to
-- the following conditions:
--
-- The above copyright notice and this permission notice shall be included
-- in all copies or substantial portions of the Software.
--
-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
-- IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
-- CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
-- TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
-- SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

-- Simple addressbook application to show the capabilities of the hscurses
-- library, especially its widget set.

module Main where

{-
TODO:

\* save
\* add
-}

import Prelude hiding ((<>))

import Control.Exception
import Control.Monad.State
import Data.List (sort)
import System.Environment (getArgs, getProgName)
import System.Exit (exitFailure)
import Text.PrettyPrint.HughesPJ

import qualified UI.HSCurses.Curses as Curses
import qualified UI.HSCurses.CursesHelper as CursesH
import UI.HSCurses.Logging
import UI.HSCurses.Widgets

type Name = String
type Email = String
type Address = String
type ZIPCode = String
type City = String
type Province = String
type Country = String
type PhoneNumber = String

data Contact = Contact
    { lastName :: Name
    , firstName :: Name
    , emailAddress :: Email
    , address :: Address
    , zipCode :: ZIPCode
    , city :: City
    , province :: Province
    , country :: Country
    , phoneNumber :: PhoneNumber
    }
    deriving (Show, Read, Eq, Ord)

emptyContact =
    Contact
        { lastName = ""
        , firstName = ""
        , emailAddress = ""
        , address = ""
        , zipCode = ""
        , city = ""
        , province = ""
        , country = ""
        , phoneNumber = ""
        }

pprContact c =
    pprLine (combine (lastName c) ", " (firstName c)) $
        pprLine (address c) $
            pprLine (combine (zipCode c) " " (city c)) $
                pprLine (province c) $
                    pprLine (country c) $
                        pprLine (phoneNumber c) $
                            pprLine (emailAddress c) $
                                empty
  where
    pprLine :: String -> Doc -> Doc
    pprLine [] = (<>) empty
    pprLine s = ($$) (text s)
    combine [] _ s2 = s2
    combine s1 _ [] = s1
    combine s1 delim s2 = s1 ++ delim ++ s2

contactToLabelValueList :: Contact -> [(String, String)]
contactToLabelValueList c =
    [ ("Last Name", lastName c)
    , ("First Name", firstName c)
    , ("Email", emailAddress c)
    , ("Address", address c)
    , ("ZIP Code", zipCode c)
    , ("City", city c)
    , ("State/Province", province c)
    , ("Country", country c)
    , ("Phone", phoneNumber c)
    ]

readContacts :: FilePath -> IO [Contact]
readContacts f =
    do
        s <- readFile f
        case reads s of
            [(contacts, [])] -> return (sort contacts)
            _ -> error ("corrupt contact file: " ++ f)

writeContacts :: FilePath -> [Contact] -> IO ()
writeContacts f contacts =
    writeFile f (show contacts)

sampleContacts =
    [ emptyContact
        { lastName = "Wehr"
        , firstName = "Stefan"
        , emailAddress = "mail AT stefanwehr DOT de"
        , address = "28 Loch Maree St"
        , zipCode = "2032"
        , city = "Kingsford"
        , province = "NSW"
        , country = "Australia"
        }
    , emptyContact
        { lastName = "Thorpe"
        , firstName = "Ian"
        , emailAddress = "ian@aol7.com.au"
        , city = "Perth"
        , country = "Australia"
        }
    , emptyContact
        { lastName = "Gates"
        , firstName = "Bill"
        , emailAddress = "billy@microsoft.com"
        }
    , emptyContact
        { lastName = "Stewart"
        , firstName = "Don"
        , address = "CSE, UNSW, 501-16, k17 building"
        , city = "Sydney"
        , country = "Australia"
        }
    ]

title = "contact-manager"

help = "q:quit, d:delete, a:add"

data CMState = CMState
    { cm_styles :: [CursesH.CursesStyle]
    , cm_contacts :: [Contact]
    }
type CM = StateT CMState IO

runCM :: [CursesH.CursesStyle] -> [Contact] -> CM a -> IO a
runCM stys contacts cm =
    evalStateT
        cm
        ( CMState
            { cm_styles = stys
            , cm_contacts = contacts
            }
        )

nthStyle :: Int -> CM CursesH.CursesStyle
nthStyle n =
    do
        cs <- gets cm_styles
        return $ cs !! n

getSize = liftIO $ Curses.scrSize

styles =
    [ CursesH.defaultStyle
    , CursesH.AttributeStyle [CursesH.Bold] CursesH.GreenF CursesH.DarkBlueB
    ]

defStyle = nthStyle 0
lineStyle = nthStyle 1

lineDrawingStyle =
    do
        sty <- lineStyle
        return $ mkDrawingStyle sty

lineOptions =
    do
        sz <- getSize
        ds <- lineDrawingStyle
        return $
            TWOptions
                { twopt_size = TWSizeFixed (1, getWidth sz)
                , twopt_style = ds
                , twopt_halign = AlignLeft
                }

type ToplineWidget = TextWidget
type MidlineWidget = TextWidget
type BotlineWidget = TextWidget
type MsglineWidget = TableWidget
type ContactListWidget = TableWidget
type ContactDetailsWidget = TextWidget
type ContactEditWidget = TableWidget

mkToplineWidget =
    do
        opts <- lineOptions
        return $
            newTextWidget
                (opts {twopt_halign = AlignCenter})
                title

mkMidlineWidget :: ContactListWidget -> CM MidlineWidget
mkMidlineWidget listWidget =
    do
        opts <- lineOptions
        contacts <- gets cm_contacts
        let s = case tbw_pos listWidget of
                Nothing -> show (length contacts)
                Just (row, _) -> show (1 + row) ++ "/" ++ show (length contacts)
        return $ newTextWidget (opts {twopt_halign = AlignRight}) s

mkBotlineWidget =
    do
        opts <- lineOptions
        return $ newTextWidget opts help

-- We need to insert a dummy widget at the lower-right corner of the window,
-- i.e. at the lower-right corner of the message line. Otherwise, an
-- error occurs because drawing a character to this position moves the
-- cursor to the next line, which doesn't exist.
mkMsglineWidget =
    do
        sz <- getSize
        let width = getWidth sz
            opts =
                TWOptions
                    { twopt_size = TWSizeFixed (1, width - 1)
                    , twopt_style = defaultDrawingStyle
                    , twopt_halign = AlignLeft
                    }
            tw = newTextWidget opts "msgline"
            row = [TableCell tw, TableCell $ EmptyWidget (1, 1)]
            tabOpts = defaultTBWOptions {tbwopt_minSize = (1, width)}
        return $ newTableWidget tabOpts [row]

nlines = 4

contactListHeight (h, _) = (h - nlines) `div` 2

contactDetailsHeight (h, _) =
    let n = h - nlines
     in n `div` 2 + (n `mod` 2)

contactListOptions =
    do
        sz <- getSize
        return $
            TBWOptions
                { tbwopt_fillCol = Nothing
                , tbwopt_fillRow = None
                , tbwopt_activeCols = [0]
                , tbwopt_minSize = (contactListHeight sz, getWidth sz)
                }

contactDetailsOptions =
    do
        sz <- getSize
        return $
            TWOptions
                { twopt_size =
                    TWSizeFixed
                        ( contactDetailsHeight sz
                        , getWidth sz
                        )
                , twopt_style = defaultDrawingStyle
                , twopt_halign = AlignLeft
                }

mkContactListWidget :: CM ContactListWidget
mkContactListWidget =
    do
        contacts <- gets cm_contacts
        sz <- getSize
        let lines = alignRows (map contactLine contacts) ' ' "  "
            rows = map (contactRow $ getWidth sz) lines
        opts <- contactListOptions
        return $ newTableWidget opts rows
  where
    contactLine c = [lastName c, firstName c, emailAddress c]
    contactRow w s =
        [ TableCell $
            newTextWidget
                (defaultTWOptions {twopt_size = TWSizeFixed (1, w)})
                s
        ]
    lastRow = [TableCell (EmptyWidget (0, 0))]

mkContactDetailsWidget :: ContactListWidget -> CM ContactDetailsWidget
mkContactDetailsWidget listWidget =
    do
        contacts <- gets cm_contacts
        let contact = case tbw_pos listWidget of
                Nothing -> ""
                Just (row, _) ->
                    let c = contacts !! row
                     in show $ pprContact c
        opts <- contactDetailsOptions
        return $ newTextWidget opts contact

mkContactEditWidget :: Contact -> CM ContactEditWidget
mkContactEditWidget contact =
    let l = contactToLabelValueList contact
        rows = map mkRow l
     in do
            sz <- getSize
            let opts =
                    TBWOptions
                        { tbwopt_fillCol = Just 1
                        , tbwopt_fillRow = None
                        , tbwopt_activeCols = [1]
                        , tbwopt_minSize = (getHeight sz - 3, getWidth sz)
                        }
            return $ newTableWidget opts rows
  where
    mkRow (label, value) =
        let labelW = newTextWidget defaultTWOptions label
            valueW = newEditWidget defaultEWOptions value
         in [TableCell labelW, ActiveTableCell valueW]

mkMainEditWidget contact =
    do
        tlw <- mkToplineWidget
        blw <- mkBotlineWidget
        msglw <- mkMsglineWidget
        ew <- mkContactEditWidget contact
        return $ MainEditWidget tlw blw msglw ew

data MainEditWidget = MainEditWidget
    { toplineEditWidget :: ToplineWidget
    , botlineEditWidget :: BotlineWidget
    , msglineEditWidget :: MsglineWidget
    , contactEditWidget :: ContactEditWidget
    }

mkMainWidget =
    do
        tlw <- mkToplineWidget
        clw <- mkContactListWidget
        mlw <- mkMidlineWidget clw
        cdw <- mkContactDetailsWidget clw
        blw <- mkBotlineWidget
        msglw <- mkMsglineWidget
        return $ MainWidget tlw mlw blw msglw clw cdw

instance Widget MainEditWidget where
    draw pos sz hint w = draw pos sz hint (mkRealMainEditWidget (Just sz) w)
    minSize w = minSize (mkRealMainEditWidget Nothing w)

mkRealMainEditWidget :: (Maybe Size) -> MainEditWidget -> TableWidget
mkRealMainEditWidget msz w =
    let cells =
            [ TableCell $ toplineEditWidget w
            , TableCell $ contactEditWidget w
            , TableCell $ botlineEditWidget w
            , TableCell $ msglineEditWidget w
            ]
        rows = map singletonRow cells
        opts = case msz of
            Nothing -> defaultTBWOptions
            Just sz -> defaultTBWOptions {tbwopt_minSize = sz}
     in newTableWidget opts rows

data MainWidget = MainWidget
    { toplineWidget :: ToplineWidget
    , midlineWidget :: MidlineWidget
    , botlineWidget :: BotlineWidget
    , msglineWidget :: MsglineWidget
    , contactListWidget :: ContactListWidget
    , contactDetailsWidget :: ContactDetailsWidget
    }

instance Widget MainWidget where
    draw pos sz hint w = draw pos sz hint (mkRealMainWidget (Just sz) w)
    minSize w = minSize (mkRealMainWidget Nothing w)

mkRealMainWidget msz w =
    let cells =
            [ TableCell $ toplineWidget w
            , TableCell $ contactListWidget w
            , TableCell $ midlineWidget w
            , TableCell $ contactDetailsWidget w
            , TableCell $ botlineWidget w
            , TableCell $ msglineWidget w
            ]
        rows = map singletonRow cells
        opts = case msz of
            Nothing -> defaultTBWOptions
            Just sz -> defaultTBWOptions {tbwopt_minSize = sz}
     in newTableWidget opts rows

updateStateDependentWidgets :: MainWidget -> ContactListWidget -> CM MainWidget
updateStateDependentWidgets w listWidget =
    do
        detailsWidget <- mkContactDetailsWidget listWidget
        midlineWidget <- mkMidlineWidget listWidget
        return $
            w
                { contactListWidget = listWidget
                , contactDetailsWidget = detailsWidget
                , midlineWidget = midlineWidget
                }

move :: Direction -> MainWidget -> CM MainWidget
move dir w =
    do
        sz <- getSize
        let listWidget = tableWidgetMove dir sz (contactListWidget w)
        updateStateDependentWidgets w listWidget

delete w =
    let lw = contactListWidget w
     in case tbw_pos lw of
            Nothing -> return w
            Just (row, _) ->
                let lw' = tableWidgetDeleteRow row lw
                 in do
                        modify
                            ( \s ->
                                s
                                    { cm_contacts =
                                        deleteAt row (cm_contacts s)
                                    }
                            )
                        updateStateDependentWidgets w lw'

{-
editEventloop w ewm =
    do k <- CursesH.getKey (resize mkMainEditWidget)
       case k of
         Curses.KeyChar 'q' -> return w
         Curses.KeyChar '\r' ->
             do debug "editing..."
                sz <- getSize
                let ewm' = mkRealMainEditWidget (Just sz) ewm
                    (epos, esz) = getCellInfo (0,0) sz ewm' (1,0)
                    ew = contactEditWidget ewm
                (ew', res) <-
                    tableWidgetActivateCurrent (redraw ewm) epos esz DHFocus ew
                editEventloop w ewm
         _ -> editEventloop w ewm
-}

edit w =
    let lw = contactListWidget w
     in case tbw_pos lw of
            Nothing -> return w
            Just (row, _) ->
                do
                    contacts <- gets cm_contacts
                    let c = contacts !! row
                    ew <- mkMainEditWidget c
                    redraw ew
                    return w

-- editEventloop w ew

resize :: (Widget w) => CM w -> CM ()
resize f =
    do
        liftIO $ do
            Curses.endWin
            Curses.resetParams
            Curses.cursSet Curses.CursorInvisible
            Curses.refresh
        w <- f
        redraw w

redraw :: (Widget w) => w -> CM ()
redraw w =
    do
        sz <- getSize
        liftIO $ draw (0, 0) sz DHNormal w
        liftIO $ Curses.refresh

eventloop w =
    do
        k <- CursesH.getKey (resize mkMainWidget)
        debug ("Got key " ++ show k)
        case k of
            Curses.KeyChar 'q' -> return ()
            Curses.KeyChar 'd' -> process $ delete w
            Curses.KeyChar 'e' -> process $ edit w
            Curses.KeyUp -> process $ move DirUp w
            Curses.KeyDown -> process $ move DirDown w
            _ -> eventloop w
  where
    process f =
        do
            w' <- f
            redraw w'
            eventloop w'
cmMain :: CM ()
cmMain =
    do
        w <- mkMainWidget
        redraw w
        eventloop w

main :: IO ()
main =
    do
        args <- getArgs
        contacts <-
            if length args /= 1
                then do
                    p <- getProgName
                    putStrLn ("Usage: " ++ p ++ " contact-file")
                    exitFailure
                else readContacts (args !! 0)
        runCurses contacts `finally` CursesH.end
  where
    runCurses contacts =
        do
            CursesH.start
            cstyles <- CursesH.convertStyles styles
            Curses.cursSet Curses.CursorInvisible
            runCM cstyles contacts cmMain