Applicative.hs

{-# LANGUAGE TypeSynonymInstances, TypeOperators #-}
-- For ghc 6.6 compatibility
-- {-# OPTIONS -fglasgow-exts #-}

----------------------------------------------------------------------
-- |
-- Module      :  Graphics.UI.Phooey.Applicative
-- Copyright   :  (c) Conal Elliott 2007
-- License     :  BSD3
-- 
-- Maintainer  :  conal@conal.net
-- Stability   :  experimental
-- Portability :  TypeSynonymInstances
-- 
-- UIs as applicative functors.  This module is a very simple layering
-- over "Graphics.UI.Phooey.Monad".  It serves to hide the 'Source' types
-- and give an applicative feel to UI construction.
----------------------------------------------------------------------

module Graphics.UI.Phooey.Applicative
  (
  -- * The UI applicative functor
    UI, runUI, runNamedUI, Action, Sink
  -- * Tools for high-level widgets
  , IWidget, OWidget, iwidget, owidget
  -- * Some high-level widgets
  , stringEntry, stringDisplay, showDisplay
  , islider, isliderDisplay
  , fslider, fsliderDisplay
  , checkBoxEntry, checkBoxDisplay, choices
  , timedPoll
  -- * Explicit layout
  , fromTop, fromBottom, fromLeft, fromRight
  ) where

-- Base
import Control.Applicative (pure)

-- TypeCompose
import Control.Compose
import Data.Title

-- reactive
import Data.Reactive

-- phooey
import qualified Graphics.UI.Phooey.Monad as M


{----------------------------------------------------------
    The UI applicative functor
----------------------------------------------------------}

-- | The UI applicative functor.
type UI = M.UI :. Source

-- | Run a 'UI' with window title \"Applicative Phooey GUI\".
runUI :: UI Action -> IO ()
runUI = runNamedUI "Applicative Phooey GUI"

-- | Run a 'UI' with given window title.
runNamedUI :: String -> UI Action -> IO ()
runNamedUI name =
  -- convert the @UI (Source Action)@ to a @UI ()@ and run.
  M.runNamedUI name . M.act . unO


{----------------------------------------------------------
    Tools for high-level widgets
----------------------------------------------------------}

-- | Input widget, with initial value.
type IWidget a = a -> UI a

-- | Output widget.  Yields a sink of values
type OWidget a = UI (Sink a)

-- | Make an input widget
iwidget :: M.IWidget a -> IWidget a
iwidget mwid a = O (mwid a)

-- | Make an output widget
owidget :: M.OWidget' a -> OWidget a
owidget = O . fmap pure


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

-- | String input widget
stringEntry :: IWidget String
stringEntry = iwidget M.stringEntry

-- | String display widget
stringDisplay :: OWidget String
stringDisplay = owidget M.stringDisplay'

-- | Showable output widget
showDisplay :: Show a => OWidget a
showDisplay = owidget M.showDisplay'


-- | Slider input widget
islider :: (Int,Int) -> IWidget Int
islider bounds = iwidget (M.islider bounds)

-- | Slider input widget over fractional values
fslider :: RealFrac a => (a,a) -> IWidget a
fslider bounds = iwidget (M.fslider bounds)

-- | Slider output widget with static bounds
isliderDisplay :: (Int,Int) -> OWidget Int
isliderDisplay bounds = owidget (M.isliderDisplay' bounds)

-- | Slider input widget over fractional values
fsliderDisplay :: RealFrac a => (a,a) -> OWidget a
fsliderDisplay bounds = owidget (M.fsliderDisplay' bounds)

-- | Boolean input widget
checkBoxEntry :: IWidget Bool
checkBoxEntry = iwidget M.checkBoxEntry

-- | Boolean display widget
checkBoxDisplay :: OWidget Bool
checkBoxDisplay = owidget M.checkBoxDisplay'

-- | Input from a \"menu\" of choices.
choices :: [String] -> IWidget String
choices strings = iwidget (M.choices strings)

-- | Input from a timer and a means of polling.  Interval is in seconds.
-- If 'poll' is expensive, then apply 'cache' to the resulting UI.
timedPoll :: Double -> IO a -> UI a
timedPoll secs poll = O (M.timedPoll secs poll)


-- Wrap a title around a 'UI'
instance Title_f UI where title_f str = inO (title_f str)

{----------------------------------------------------------
    Layout
----------------------------------------------------------}

-- | Lay out from top to bottom
fromTop :: Unop (UI a)
fromTop = inO M.fromTop

-- | Lay out from bottom to top
fromBottom :: Unop (UI a)
fromBottom = inO M.fromBottom

-- | Lay out from left to right
fromLeft :: Unop (UI a)
fromLeft = inO M.fromLeft

-- | Lay out from right to left
fromRight :: Unop (UI a)
fromRight = inO M.fromRight


-----

{-

-- Overloading mischief.  Standard incantation for applicative functors.

instance Show (UI a) where
  show _ = "<UI>"

instance Eq (UI a) where
   (==) = error "no Eq for UI"

instance Ord (UI a) where
  (<) = error "no Ord for UI"

instance Num a => Num (UI a) where
  (+) = liftA2 (+)
  fromInteger = pure . fromInteger
  -- etc

-}