Applicative.hs

{-# OPTIONS -fglasgow-exts #-}

----------------------------------------------------------------------
-- |
-- Module      :  Graphics.UI.Phooey.Applicative
-- Copyright   :  (c) Conal Elliott 2007
-- License     :  LGPL
-- 
-- Maintainer  :  conal@conal.net
-- Stability   :  experimental
-- Portability :  portable
-- 
-- 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, Upd, Snk
  -- * Tools for high-level widgets
  , IWidget, OWidget
  -- * Some high-level widgets
  , stringEntry, stringDisplay, showDisplay
  , islider, isliderDyn, isliderDisplay
  , checkBoxEntry, checkBoxDisplay
  , title
  -- * Explicit layout
  , fromTop, fromBottom, fromLeft, fromRight, flipLayout
  ) where

import Control.Monad.Reader
import Control.Applicative
import Control.Compose

import Graphics.UI.Phooey.LayoutT
import Graphics.UI.Phooey.TagT

import qualified Graphics.UI.Phooey.Monad as M
import Graphics.UI.Phooey.Monad (Source,Upd,Snk)


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

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

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

-- | Run a 'UI' with given window title.
runNamedUI :: String -> UI Upd -> IO ()
runNamedUI name = M.runNamedUI' name . unComp


{----------------------------------------------------------
    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 (Snk a)

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

-- | Make an output widget
owidget :: M.OWidget' a -> OWidget a
owidget mwid = Comp (fmap pure mwid)


{----------------------------------------------------------
    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 with static bounds
islider :: (Int,Int) -> IWidget Int
islider bounds = iwidget (M.islider bounds)

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

-- | Slider widget with dynamic bounds.
isliderDyn :: UI (Int,Int) -> IWidget Int
isliderDyn (Comp bounds) initial = Comp $
  bounds >>= flip M.isliderDyn initial

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

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

-- | Wrap a title around a 'UI'
title :: String -> Unop (UI a)
title str = onComp (M.title str)
            -- mapLayout (boxed str)

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

-- | Tweak the 'LayoutT'
onLayoutT :: LayoutTOp IO -> Unop (UI a)
onLayoutT f = onComp (M.onLayoutT f)

-- | Lay out from top to bottom
fromTop :: Unop (UI a)

-- | Lay out from bottom to top
fromBottom :: Unop (UI a)

-- | Lay out from left to right
fromLeft :: Unop (UI a)

-- | Lay out from right to left
fromRight :: Unop (UI a)

-- | Reverse layout
flipLayout :: Unop (UI a)

fromTop    = onLayoutT fromTopL
fromBottom = onLayoutT fromBottomL
fromLeft   = onLayoutT fromLeftL
fromRight  = onLayoutT fromRightL
flipLayout = onLayoutT flipL


-----

{-

-- 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

-}