LayoutT.hs

{-# OPTIONS -fglasgow-exts #-}

----------------------------------------------------------------------
-- |
-- Module      :  Graphics.UI.Phooey.LayoutT
-- Copyright   :  (c) Conal Elliott 2006
-- License     :  LGPL
-- 
-- Maintainer  :  conal@conal.net
-- Stability   :  provisional
-- Portability :  portable
-- 
-- A monad transformer for managing GUI layout.
-- Specializes 'TagT' to layouts as tag values.
----------------------------------------------------------------------

module Graphics.UI.Phooey.LayoutT
  ( 
  -- * The /layout manager/ monad transformer (or laid-out value makers)
    LayoutT, runLayout, runL, LayoutTOp
  -- * 'LayoutT' combinators
  , flipL , fromTopL, fromBottomL, fromLeftL, fromRightL
  -- , above, beside, fempty , setLayoutL
  -- * Miscellany
  , panelWrap
  ) where

import Data.Maybe (fromMaybe)
import Graphics.UI.WX

import Graphics.UI.Phooey.Imperative (Win, runWio)
import Graphics.UI.Phooey.TagT

{----------------------------------------------------------
    /Layout manager/ monad transformer (or laid-out value makers)
----------------------------------------------------------}

-- | /Layout manager/ monad transformer (or laid-out value maker)
type LayoutT m = TagT Layout m

-- | /Run/ a 'LayoutT'.
runLayout :: Monad m => LayoutT m a -> m (Layout,a)
runLayout lt =
  do  ~(mbl,a) <- runTag above lt
      return (fromMaybe fempty mbl, a)

-- | Create a window, and run a 'LayoutT' in it.
runL :: String -> (Win -> LayoutT IO (IO ())) -> IO ()
runL name f = runWio name $ \ win -> 
  do ~(l,upd) <- runLayout (f win)
     upd
     return l


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

-- | Layout combiner
type LayoutTOp m = TagTOp Layout m

-- | Identity for 'above' and 'beside'.
fempty :: Layout
fempty = fill empty

-- | Temporarily /replace/ the layout combiner
setLayoutL  ::  Monad m => Binop Layout
            ->  Unop (LayoutT m a)
setLayoutL = setTagComb


-- | Lay out from top to bottom
fromTopL :: Monad m => Unop (LayoutT m a)
fromTopL = setLayoutL above

-- | Lay out from bottom to top
fromBottomL :: Monad m => Unop (LayoutT m a)
fromBottomL  = setLayoutL (flip above)

-- | Lay out from left to right
fromLeftL :: Monad m => Unop (LayoutT m a)
fromLeftL = setLayoutL beside

-- | Lay out from right to left
fromRightL :: Monad m => Unop (LayoutT m a)
fromRightL = setLayoutL (flip beside)

-- | Temporarily /reverse/ the layout combiner
flipL :: Monad m => Unop (LayoutT m a)
flipL = flipTagComb


-- Layout binops used above
above, beside :: Binop Layout
la  `above`   lb = fill (column  0 [la,lb])
la  `beside`  lb = fill (row     0 [la,lb])

-- The following definitions are simpler, but they don't work!  I get
-- 'fromTopL' and 'fromLeftL', so it seems that 'flipTagComb' doesn't work.

-- fromBottomL  = flipL . fromTopL
-- fromRightL   = flipL . fromLeftL


{----------------------------------------------------------
    Miscellany
----------------------------------------------------------}

-- | Wrap another panel and layout unop (probably id, hfill, vfill, or fill)
-- to get desired stretchiness.
panelWrap :: Unop Layout -> Unop (Win -> IO (Maybe Layout, b))
panelWrap layf f w = do  pan     <- panel w []
                         ~(mbl,b) <- f pan
                         -- if we get a layout, use it for the panel.
                         maybe (return ()) (\ l -> set pan [ layout := l ]) mbl
                         return (Just (layf (widget pan)), b)