ArrowUI.hs

{-# OPTIONS -fglasgow-exts #-}

----------------------------------------------------------------------
-- |
-- Module      :  Graphics.UI.Phooey.ArrowUI
-- 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.ArrowUI
  ( 
  -- * The UI arrow
    UI(..), runUI, runNamedUI
  -- * High-level widgets
  , stringDisplay, showDisplay, textEntry, islider
  , checkBoxDisplay, checkBoxEntry, title
  -- * Explicit layout
  , fromTop, fromBottom, fromLeft, fromRight, flipLayout
  -- * Internal (extensibility)
  , ui, sourceOp, onLayoutT
  ) where


import Control.Arrow

import Graphics.UI.Phooey.Imperative (Source,skip)
import Graphics.UI.Phooey.TagT (Unop)
import Graphics.UI.Phooey.LayoutT
import qualified Graphics.UI.Phooey.MonadUI as M
import Graphics.UI.Phooey.AFA


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

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

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

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

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


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

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

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

-- | Simple text input widget
textEntry :: UI () String
textEntry = ui (const M.textEntry)

-- | Slider widget with static initial value and dynamic bounds (min,max)
islider :: Int -> UI (Int,Int) Int
islider initial = ui (M.islider 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 (Source b)) -> Unop (UI a b)
sourceOp f (UI (AFA (Kleisli g))) = ui (f . g)

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