vty-ui-1.9: demos/PhoneInputDemo.hs

{-# LANGUAGE OverloadedStrings #-}
module Main where

-- This demo is discussed in the vty-ui user's manual.

import Control.Monad
import qualified Data.Text as T

import Graphics.Vty hiding (pad)
import Graphics.Vty.Widgets.All

data PhoneNumber = PhoneNumber T.Text T.Text T.Text
                   deriving (Show)

-- This type isn't pretty, but we have to specify the type of the
-- complete interface.  Initially you can let the compiler tell you
-- what it is.
type T = Box (Box
              (Box (Box (HFixed Edit) FormattedText) (HFixed Edit))
              FormattedText) (HFixed Edit)

data PhoneInput =
   PhoneInput { phoneInputWidget :: Widget T
              , edit1 :: Widget Edit
              , edit2 :: Widget Edit
              , edit3 :: Widget Edit
              , activateHandlers :: Handlers PhoneNumber
              }

newPhoneInput :: IO (PhoneInput, Widget FocusGroup)
newPhoneInput = do
   ahs <- newHandlers
   e1 <- editWidget
   e2 <- editWidget
   e3 <- editWidget
   ui <- (hFixed 4 e1) <++>
         (plainText "-") <++>
         (hFixed 4 e2) <++>
         (plainText "-") <++>
         (hFixed 5 e3)

   let w = PhoneInput ui e1 e2 e3 ahs
       doFireEvent = const $ do
         num <- mkPhoneNumber
         fireEvent w (return . activateHandlers) num

       mkPhoneNumber = do
         s1 <- getEditText e1
         s2 <- getEditText e2
         s3 <- getEditText e3
         return $ PhoneNumber s1 s2 s3

   e1 `onActivate` doFireEvent
   e2 `onActivate` doFireEvent
   e3 `onActivate` doFireEvent

   e1 `onChange` \s -> when (T.length s == 3) $ focus e2
   e2 `onChange` \s -> when (T.length s == 3) $ focus e3

   fg <- newFocusGroup
   mapM_ (addToFocusGroup fg) [e1, e2, e3]
   return (w, fg)

onPhoneInputActivate :: PhoneInput
                     -> (PhoneNumber -> IO ()) -> IO ()
onPhoneInputActivate input handler =
    addHandler (return . activateHandlers) input handler

main :: IO ()
main = do
  (p, fg) <- newPhoneInput
  p `onPhoneInputActivate` (error . show)

  ui <- padded (phoneInputWidget p) (padLeftRight 5 `pad` padTopBottom 2)

  c <- newCollection
  _ <- addToCollection c ui fg

  runUi c $ defaultContext { focusAttr = white `on` blue
                           }