{-# LANGUAGE ExistentialQuantification, FlexibleContexts, RankNTypes #-}
{-# OPTIONS -Wall #-}

{- | Parameters to functions creating 'GenWid'-s. 

If a 'GenWid' has sub-'GenWid' the parameters will be passed on to those.

-}
module Graphics.UI.WxGeneric.GenericWidget.Parameters
    ( Parms
    , subParms
    , getParent, setParent
    , getJoinLayout, transformLabel
    -- * Initial parameters
    , GenWidParameters(..), defaultParms, toParms
    -- * Labels
    , TransformLabel, mkTransformLabel, idLabel, greedyShortcuts
    )
where

import Graphics.UI.WX
import qualified Graphics.UI.WxGeneric.Layout as L
import qualified Data.Set                     as Set
import qualified Data.Char                    as Char
import Control.Monad.State                    as St

data GenWidParameters = GenWidParameters
    { joinLayout     :: L.JoinLayout
    , labelTransform :: TransformLabel
    }

defaultParms :: (GenWidParameters -> GenWidParameters) -> GenWidParameters
defaultParms f = f (GenWidParameters L.smartLayout (greedyShortcuts []))

-- | Initial parameters. Should only be called at the top-level. If
-- already in a 'GenWid' function then use 'subParms'.
toParms :: Window w -> GenWidParameters -> IO (Parms w)
toParms w parms = do lblTrans <- varCreate (labelTransform parms)
                     return $ Parms w True (joinLayout parms) L.oneColumnLayout lblTrans

data Parms w = Parms
    { pickParent         :: Window w
    , pickIsTop          :: Bool
    , pickTopLayout      :: L.JoinLayout
    , pickLayout         :: L.JoinLayout
    , pickLabelTransform :: Var TransformLabel
    }

-- | When a 'GenWid' has sub-'GenWid' use this function to update
-- 'GenWidParms'.
-- 
-- Currently, only GenericClass.singleConstr uses this function. But,
-- in principle, it should be called by functions using sub-widget.
subParms :: Parms w -> Parms w
subParms parms
    = parms { pickIsTop  = False }

setParent :: Window w -> Parms w' -> Parms w
setParent w parms
    = parms { pickParent = w }

-- | Use this parent when constructing new widgets.
getParent :: Parms w -> Window w
getParent = pickParent

getJoinLayout :: Parms w -> L.JoinLayout
getJoinLayout p =
    case pickIsTop p of
      True  -> pickTopLayout p
      False -> pickLayout p

-- *** Label handling

transformLabel :: Parms w -> String -> IO String
transformLabel parms lbl
    = do lblTrans <- varGet $ pickLabelTransform parms
         case lblTrans of
           TL s f -> do let (newLbl, newSt) = runState (f lbl) s
                        varSet (pickLabelTransform parms) $ TL newSt f
                        return newLbl

data TransformLabel = forall s. TL s (String -> State s String)

mkTransformLabel :: s -> (String -> State s String) -> TransformLabel
mkTransformLabel = TL

idLabel :: TransformLabel
idLabel = mkTransformLabel () return

greedyShortcuts :: [Char] -> TransformLabel
greedyShortcuts usedShortcutLetters = mkTL
    where 
      mkTL = mkTransformLabel (Set.fromList usedShortcutLetters) (State . newLbl)
      newLbl lbl used 
          = case span (\x -> Set.member (Char.toLower x) used || (not $ Char.isAlpha x)) lbl of
              (_, [])               -> (lbl, used) -- no available shortcut letter
              (alreadyUsed, (x:xs)) -> (alreadyUsed ++ ('&':x:xs), Set.insert (Char.toLower x) used)