Arrow.hs

{-# OPTIONS -fglasgow-exts #-}

----------------------------------------------------------------------
-- |
-- Module      :  Graphics.UI.Phooey.Arrow
-- Copyright   :  (c) Conal Elliott 2006
-- License     :  LGPL
-- 
-- Maintainer  :  conal@conal.net
-- Stability   :  provisional
-- Portability :  portable
-- 
-- A functional UI arrow.  See explanation and examples in
-- "Graphics.UI.Phooey".
----------------------------------------------------------------------

module Graphics.UI.Phooey.Arrow
  ( 
  -- * The UI arrow
    UI(..), runUI, runNamedUI
  -- * High-level widgets
  , IWidget, OWidget
  , stringDisplay, showDisplay, stringEntry, islider, isliderDyn
  , checkBoxDisplay, checkBoxEntry, title
  -- * Explicit layout
  , fromTop, fromBottom, fromLeft, fromRight, flipLayout
  -- * Internal (extensibility)
  , ui, sourceOp, onLayoutT
  ) where


import Control.Arrow
import Data.Monoid

import Graphics.UI.Phooey.TagT (Unop)
import Graphics.UI.Phooey.LayoutT
import qualified Graphics.UI.Phooey.Monad as M

import Control.Compose

{----------------------------------------------------------
    The UI arrow
----------------------------------------------------------}

-- | The UI arrow
newtype UI i o = UI ((ArrowAp (Kleisli M.UI) M.Source) i o)
  deriving (Arrow,ArrowLoop)

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

-- | Run a 'UI' with given window title.
runNamedUI :: String -> UI () () -> IO ()
runNamedUI str (UI (ArrowAp (Kleisli f))) = M.runNamedUI str (f mempty)

-- runNamedUI str (UI (ArrowAp (Kleisli f))) = M.runNamedUI str (f mempty)

-- | Wrap up monadic UI function as a 'UI'
ui :: (M.Source i -> M.UI (M.Source o)) -> UI i o
ui = UI . ArrowAp . Kleisli


{----------------------------------------------------------
    High-level widgets
----------------------------------------------------------}

-- | Input widget type (with initial value)
type IWidget  a = a -> UI () a
-- | Output widget type
type OWidget  a = UI a ()

-- | String display widget
stringDisplay :: OWidget String
stringDisplay = ui M.stringDisplay

-- | Showable display widget
showDisplay :: Show a => OWidget a
showDisplay = pure show >>> stringDisplay
              -- or: ui M.showDisplay

-- | Simple text input widget
stringEntry :: IWidget String
stringEntry initial = ui (const (M.stringEntry initial))

-- | Slider widget with initial value and /static/ bounds (min,max)
islider :: (Int,Int) -> IWidget Int
islider bounds initial = ui (const (M.islider bounds initial))

-- | Slider widget with static initial value and /dynamic/ bounds (min,max)
isliderDyn :: Int -> UI (Int,Int) Int
isliderDyn initial = ui (flip M.isliderDyn initial)

-- | String display widget
checkBoxDisplay :: UI Bool ()
checkBoxDisplay = ui M.checkBoxDisplay

-- | Simple checkbox input widget
checkBoxEntry :: Bool -> UI () Bool
checkBoxEntry initial = ui (const (M.checkBoxEntry initial))

-- | Wrap a title around a 'UI'
title :: String -> Unop (UI a b)
title str = sourceOp (M.title str)


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

-- | Lay out from top to bottom
fromTop :: Unop (UI a b)
fromTop = onLayoutT fromTopL

-- | Lay out from bottom to top
fromBottom :: Unop (UI a b)
fromBottom = onLayoutT fromBottomL

-- | Lay out from left to right
fromLeft :: Unop (UI a b)
fromLeft = onLayoutT fromLeftL

-- | Lay out from right to left
fromRight :: Unop (UI a b)
fromRight = onLayoutT fromRightL

-- | Reverse layout
flipLayout :: Unop (UI a b)
flipLayout = onLayoutT flipL


---- Misc unexported

sourceOp :: Unop (M.UI (M.Source b)) -> Unop (UI a b)
sourceOp f (UI (ArrowAp (Kleisli g))) = ui (f . g)

onLayoutT :: LayoutTOp IO -> Unop (UI a b)
onLayoutT f = sourceOp (M.onLayoutT f)