EditorComponent.hs

{-# LANGUAGE FlexibleInstances, FunctionalDependencies, KindSignatures
  , MultiParamTypeClasses, RankNTypes
  , ScopedTypeVariables, TypeOperators #-}

module Graphics.UI.AF.WxForm.EditorComponent
    ( EC
    , MakeEC, runEC
    , mkEC, builderToCom', makeGUIlessEC
    , InnerEC, guilessInnerEC, innerECWithGui
    --
    , SetOn(..)
    --
    , updateGui, updateComIO, updateWxM
    , layoutAs
    --
    , module Graphics.UI.AF.WxForm.GUI
    , module Graphics.UI.AF.WxForm.WxM
    , extEC
    , chooseEC
    , getComIO
    , addCustomGui, addCustomGuiNoEquals, ComIO.GuiComHelper(..)
    , addGui, guilessInnerEC', TypeLift(..)
    )
where

import Graphics.UI.WX hiding (close, command, enabled, entry, item, items, label, menu, panel, Parent, value, widget, Widget, window)
import qualified Graphics.UI.WX as WX

import Graphics.UI.AF.WxForm.ComIO as ComIO
import Graphics.UI.AF.WxForm.GUI
import Graphics.UI.AF.WxForm.WxM

import qualified Graphics.UI.AF.General.AutoForm as AF
import Graphics.UI.AF.General.PriLabel
import Graphics.UI.AF.General.MySYB

import Control.Monad(liftM)

type MakeEC a = a -> EC a

-- |Component type for the Wx instance of AutoForm
newtype EC a = EC (WxM (InnerEC a))
data InnerEC a = WithGui (ComIO a) Widget GUI
               | NoGui (ComIO a)

getComIO :: InnerEC a -> ComIO a
getComIO (WithGui cio _ _) = cio
getComIO (NoGui cio)       = cio

class TypeLift (from :: * -> *) (to :: * -> *) | to -> from where
    typeLift :: (from a -> from b) -> (to a -> to b)

instance TypeLift ComIO InnerEC where
    typeLift f (WithGui cio wid gui) = WithGui (f cio) wid gui
    typeLift f (NoGui cio)           = NoGui (f cio)

instance Labeled (EC a) where
    updateLabel f ec = updateGui ec (updateLabel f)

instance Labeled (WxM (ComIO a, Widget, GUI)) where
    updateLabel f wxi = do (comIO, wid, gui) <- wxi
                           return (comIO, wid, updateLabel f gui)

instance LabelGetter (InnerEC a) where
    guiLabel (WithGui _ _ gui) = guiLabel gui
    guiLabel _                 = defaultLabel ""

instance AF.Valued EC where
    mapValue old2NewFun new2OldFun ec
        = updateComIO ec (return . AF.mapValue old2NewFun new2OldFun)
    noValue ec = updateComIO ec (return . AF.noValue)

instance AF.Action WxAct InnerEC where
    closeWindow        = getCloseWindow >>= io
    setEnabled innerEC enabled
        = liftIO $ pickSetEnabled (getComIO innerEC) enabled
    giveFocus innerEC = withWidget innerEC focusOn where
          withWidget :: InnerEC a -> (forall w. Window w -> IO b) -> WxAct ()
          withWidget (NoGui _) _ 
              = return ()
          withWidget (WithGui _ (Widget widget) _) f
              = do liftIO $ f widget
                   return ()

instance AF.Valued InnerEC where
    mapValue old2NewFun new2OldFun = typeLift (AF.mapValue old2NewFun new2OldFun)
    noValue                        = typeLift AF.noValue

-- instance (AF.Valued ComIO m) => AF.Valued InnerEC m where
instance AF.ValuedAction InnerEC WxAct where
    getValue innerEC   = AF.getValue (getComIO innerEC)
    setValue innerEC x = AF.setValue (getComIO innerEC) x
    nonRecursiveSetValue innerEC x
        = AF.nonRecursiveSetValue (getComIO innerEC) x
    appendValue innerEC xs = AF.appendValue (getComIO innerEC) xs

addCustomGui
    :: (Eq a, Show a) =>
       a
    -> (a -> IO ())
    -> Window w
    -> GUI
    -> WxM (InnerEC a, GuiComHelper a)
addCustomGui value setGuiValue wid gui =
    guiComM addGui (Just (==)) value setGuiValue wid gui

-- |Like `addCustomGui`, but do check if a value set by the user is
--differen than the last value. Thus events can be triggered even
--if no change were actually made. Thus, the callee should make sure
--that does not happen.
addCustomGuiNoEquals
    :: (Show a) =>
       a
    -> (a -> IO ())
    -> Window w
    -> GUI
    -> WxM (InnerEC a, GuiComHelper a)
addCustomGuiNoEquals value setGuiValue wid gui =
    guiComM addGui Nothing value setGuiValue wid gui

addGui :: AddGui WxM InnerEC a
addGui w gui comIO =
    do comIO' <- comIOAddGui w gui comIO
       return $ WithGui comIO' (toWidget w) gui


-- |Constructs an 'EC', but leaving most of the work to the callee.
mkEC :: WxM (InnerEC a) ->
        EC a
mkEC = EC

builderToCom' :: WxM (InnerEC a) -> EC a
builderToCom' wxi 
    = mkEC $ do (cio, wid, gui) <- extractGui (liftM getComIO wxi)
                innerECWithGui cio wid gui

-- |Constructs a EC type without a GUI. It should be used when no GUI
-- can be created for a type.
makeGUIlessEC :: String     -- ^If non-empty then this string will displayed
                            --  on standard output. It should be an error message
                            --  explaining why the GUI could not be created.
              -> a
              -> EC a
makeGUIlessEC msg x = EC $ guilessInnerEC msg x

guilessInnerEC :: String    -- ^If non-empty then this string will displayed
                            --  on standard output. It should be an error message
                            --  explaining why the GUI could not be created.
               -> a
               -> WxM (InnerEC a)
guilessInnerEC msg x =  do io $ when (msg /= "") (putStrLn msg)
                           cio <- staticComIO x
                           return $ NoGui cio

innerECWithGui :: ComIO a
               -> Widget
               -> GUI 
               -> WxM (InnerEC a)
innerECWithGui cio wid gui = return $ WithGui cio wid gui

guilessInnerEC' :: ComIO a
                -> InnerEC a
guilessInnerEC' = NoGui

runEC :: forall a. EC a -> WxM (ComIO a, Maybe (Widget, GUI))
runEC (EC wxi) = 
    do wxi' <- wxi
       return $ case wxi' of
                  NoGui comIO
                      -> (comIO, Nothing)
                  WithGui comIO widget gui
                      -> (comIO, Just (widget, updateLabel humanizeLabel gui))

-- |Used to update the ComIO functions
updateComIO :: EC a -> (ComIO a -> IO (ComIO b)) -> EC b
updateComIO (EC wxi) transformer = EC $
    do wxi' <- wxi
       case wxi' of
         NoGui comIO
             -> do comIO' <- io $ transformer comIO
                   return $ NoGui comIO'
         WithGui comIO widget gui
             -> do comIO' <- io $ transformer comIO
                   return $ WithGui comIO' widget gui

updateWxM :: (forall b. WxM b -> WxM b) -> EC a -> EC a
updateWxM f (EC wxi) = EC (f wxi)

updateGui :: EC a -> (GUI -> GUI) -> EC a
updateGui (EC wxi) transformer = EC $
    do wxi' <- wxi
       return $ case wxi' of
                  NoGui comIO
                      -> NoGui comIO
                  WithGui comIO widget gui
                      -> WithGui comIO widget (transformer gui)

-- |Attach a new layout manager to an 'EC'. Layout manager such as
--  'dualColumn' or 'singleRow' can be used.
layoutAs :: LayoutManager -> EC a -> EC a
layoutAs layoutManager ec = updateGui ec (layoutGuiAs layoutManager)

-- | Chooses either the EC onTrue or the EC onFalse, based on which of
-- them that has a GUI. If both have then prefer decides which one to
-- use. If neither has a run-time error is made.
chooseEC :: EC a
         -> EC a
         -> EC a
chooseEC (EC firstChoice) (EC secondChoice) = 
    EC $ do first <- firstChoice
            case first of
              gui@(WithGui _ _ _) -> return gui
              NoGui _             -> secondChoice

extEC :: (Typeable b, Typeable a) => (a -> EC a)
         -> (b -> EC b) -> a -> EC a
extEC fn spec_fn arg = case gcast (M spec_fn) of
                          Just (M spec_fn') -> spec_fn' arg
                          Nothing           -> fn       arg
newtype M a = M (a -> EC a)