UI.hs

{-# LANGUAGE TypeOperators, PatternSignatures, ScopedTypeVariables
           , TypeSynonymInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- For ghc 6.6 compatibility
-- {-# OPTIONS -fglasgow-exts #-}

----------------------------------------------------------------------
-- |
-- Module      :  Interface.TV.UI
-- Copyright   :  (c) Conal Elliott 2006
-- License     :  BSD3
-- 
-- Maintainer  :  conal@conal.net
-- Stability   :  experimental
-- Portability :  TypeOperators, PatternSigs
-- 
-- Graphical 'UI' instances of TV classes, plus UI-specific tools
----------------------------------------------------------------------

module Interface.TV.UI
  (
    -- * Types
    IU, InU, OutU, TVU, unIU
  , UI, module Interface.TV            -- re-exports
    -- * Some high-level widgets
  , oPrim'
  , stringEntry, stringDisplay, showDisplay
  , islider, isliderDisplay, fslider, fsliderDisplay
  , checkBoxEntry, checkBoxDisplay, choices
  , timedPoll
  , runUI
  ) where

import Control.Applicative

import Control.Compose
import Data.Pair

-- import Data.Source (Sink)

import Graphics.UI.Phooey.Applicative (UI,fromLeft,Action,OWidget)
import qualified Graphics.UI.Phooey.Applicative as P

import Interface.TV


instance Pair UI where
  a `pair` b = fromLeft (liftA2 (,) a b)


{----------------------------------------------------------
    Types
----------------------------------------------------------}

-- | GUI Sink
type IU = UI :. OI


-- | GUI input
type InU  = Input UI

-- | GUI output
type OutU = Output UI IU

-- |GUI-based TV
type TVU  = TV UI IU


-- Standard instance
instance Cofunctor IU where cofmap = cofmapFC

instance Pair IU where pair = copair

-- unIU :: IU a -> UI (a -> IO ())
unIU :: Functor f => (f :. Flip (->) o) a -> f (a -> o)
unIU (O h) = fmap unFlip h


instance CommonIns UI where
  getString = P.stringEntry
  getRead   = getReadF
  getBool   = P.checkBoxEntry

instance CommonOuts IU where
  putString = mkO P.stringDisplay
  putShow   = putShowC
  putBool   = mkO P.checkBoxDisplay

mkO :: Functor f => f (a ~> b) -> (f :. Flip (~>) b) a
mkO = O . fmap Flip


{----------------------------------------------------------
    Some high-level widgets
----------------------------------------------------------}

oPrim' :: OWidget a -> OutU a
oPrim' = oPrim . mkO

-- standard Monoid instance for Applicative applied to Monoid
instance Monoid_f IU where
  { mempty_f = O (pure mempty_f); mappend_f = inO2 (liftA2 mappend_f) }

instance ToOI IU where
  toOI (iu :: IU a) = Flip $ \ a -> P.runUI (unIU iu <*> pure a :: UI Action)

-- | Int slider input
islider :: (Int,Int)                    -- ^ bounds
        -> Int                          -- ^ initial value
        -> InU Int
islider bounds = iPrim . P.islider bounds

-- | Fractional slider input
fslider :: RealFrac a =>
           (a,a)                    -- ^ bounds
        -> a                        -- ^ initial value
        -> InU a
fslider bounds = iPrim . P.fslider bounds

-- | Int slider output
isliderDisplay :: (Int,Int) -> OutU Int
isliderDisplay bounds = oPrim' (P.isliderDisplay bounds)

-- | Fractional slider output
fsliderDisplay :: RealFrac a => (a,a) -> OutU a
fsliderDisplay bounds = oPrim' (P.fsliderDisplay bounds)

-- | Showable output
showDisplay :: Show a => OutU a
showDisplay = oPrim' P.showDisplay

-- | Boolean input
checkBoxEntry :: Bool -> InU Bool
checkBoxEntry =  iPrim . P.checkBoxEntry

-- | Boolean output
checkBoxDisplay :: OutU Bool
checkBoxDisplay = oPrim' P.checkBoxDisplay

-- | String input
stringEntry :: InU String
stringEntry = iPrim (P.stringEntry "")

-- | String output
stringDisplay :: OutU String
stringDisplay = oPrim' P.stringDisplay

-- | Input from a \"menu\" of choices.
choices :: [String] -> String -> InU String
choices strs = iPrim . P.choices strs

-- | Input from a timer and a means of polling.  Interval is in seconds.
-- Caches in case 'poll' is expensive.
timedPoll :: Double -> IO a -> InU a
timedPoll secs poll = iPrim (P.timedPoll secs poll)

-- TODO: Is it possible to define a caching function for Input?

-- | Type-disambiguating alias for 'runTV'
runUI :: RunTV UI IU
runUI = runTV