Gadgets.hs

module Barrie.Gadgets (Gadget, Behaviour,
                       displayG, editorG, commandG, sectionG,
                       chooserG, enumChooserG, chooseEqG, childG,
                       gadgetDisplay, gadgetUpdate, gadgetCommand,
                       gadgetChooser, gadgetChild,
                       findGadget, gadgetName, flatName,
                       gadgetConfig, gadgetEnabled, enabled, dynamicLabel,
                       gadgets, abstract,
                       createLayout)
where

import Control.Monad

import Data.Dynamic
import Data.List
import Data.Maybe
import Data.Typeable

import Barrie.Config
import Barrie.Style
import Barrie.Widgets

data Gadget a = G { gadgetName     :: [String],
                    gadgetConfig   :: Config a,
                    gadgetElement  :: Maybe (Element a),
                    gadgetInner    :: Maybe (Interface a),
                    gadgetLayout   :: AutoLayoutFunction a,
                    gadgetChildren :: [Gadget a]
                  }

data AutoLayout = AL { alDirection :: LayoutDirection,
                       alEditable  :: Bool,
                       alNames     :: [String]
                     }

instance (Typeable a) => Typeable (Gadget a) where
    typeOf g = mkTyConApp (mkTyCon "Barrie.Gadgets.Gadget")
                          [typeOf (elementType (fromJust (gadgetElement g)))]

data Element a = E { elementType      :: TypeRep,
                     elementGet       :: a -> Dynamic,
                     elementSet       :: Dynamic -> a -> a,
                     elementChoices   :: Maybe (a -> [(Dynamic, Dynamic)]),
                     elementRender    :: Dynamic -> Dynamic
                   }

data Interface a = IF { ifGadget :: Gadget a }

instance (Typeable a) => Typeable (Element a) where
    typeOf e = mkTyConApp (mkTyCon "Barrie.Gadgets.Element") [elementType e]

data Behaviour a = B [Gadget a]

flatName :: Gadget a -> String
flatName = intercalate "." . gadgetName

mkGadget :: String -> Element a -> Gadget a
mkGadget name e = G [name] defaultConfig (Just e) Nothing boxLayout []

mkElement :: (Typeable b) =>
             (a -> b)
          -> (b -> a -> a)
          -> Element a
mkElement get set = E tyrep (toDyn . get) (\ x -> set (get' x)) Nothing id
    where get' x = case fromDynamic x of
                     Nothing -> error $ "'impossible' type error detected: " ++
                                        show x ++ " " ++ show (typeOf (get' x))
                     Just v  -> v
          tyrep = typeOf (get undefined)

updateElement :: (Element a -> Element a) -> Gadget a -> Gadget a
updateElement update g = case gadgetElement g of
                           Nothing -> g
                           Just e  -> g { gadgetElement = Just $ update e }

renderWith :: (Dynamic -> Dynamic) -> Gadget a -> Gadget a
renderWith r = updateElement (\ e -> e { elementRender = r })

setChoices :: (a -> [(Dynamic, Dynamic)]) -> Gadget a -> Gadget a
setChoices getChoices =
    updateElement (\ e -> e { elementChoices = Just getChoices })

autoLayout :: AutoLayoutFunction a -> Gadget a -> Gadget a
autoLayout f g = g { gadgetLayout = f }

displayG :: (Typeable b) => String -> (a -> b) -> Gadget a
displayG name get = autoLayout (typeableLayout (typeOf $ get undefined)) $
                       mkGadget name (mkElement get (\ _ st -> st))

editorG :: (Typeable b) => String -> (a -> b) -> (b -> a -> a) -> Gadget a
editorG name get set = autoLayout (typeableLayout (typeOf $ get undefined)) $
                            mkGadget name (mkElement get set)

commandG :: String -> (a -> a) -> Gadget a
commandG name update = autoLayout buttonLayout $
                          mkGadget name (mkElement (const ()) (\ () -> update))

sectionG :: String -> [Gadget a] -> Gadget a
sectionG name gs = G [name] defaultConfig Nothing Nothing boxLayout gs

childG :: String            -- ^ gadget name
       -> (a -> b)          -- ^ get child state
       -> (b -> a -> a)     -- ^ update parent state with child state
       -> Gadget b          -- ^ child gadget
       -> Gadget a
childG name get set child =
   G { gadgetName     = [name],
       gadgetConfig   = defaultConfig,
       gadgetElement  = Nothing,
       gadgetInner    = Just $ IF $ transform get set child,
       gadgetLayout   = boxLayout,
       gadgetChildren = []
     }

transform :: (a -> b) -> (b -> a -> a) -> Gadget b -> Gadget a
transform get set g =
    G { gadgetName     = gadgetName g,
        gadgetConfig   = transformConfig get (gadgetConfig g),
        gadgetElement  = liftM (transformE get set) (gadgetElement g),
        gadgetInner    = liftM (transformI get set) (gadgetInner g),
        gadgetLayout   = boxLayout,
        gadgetChildren = map (transform get set) (gadgetChildren g)
      }

-- transformL :: (a -> b) -> (b -> a -> a) -> AutoLayoutFunction b
--            -> AutoLayoutFunction a
-- transformL get set f = \ layout gs = map

transformI :: (a -> b) -> (b -> a -> a) -> Interface b -> Interface a
transformI get set (IF g) = IF (transform get set g)

transformE :: (a -> b) -> (b -> a -> a) -> Element b -> Element a
transformE get set e = e { elementGet = elementGet e . get,
                           elementSet = xfset (elementSet e),
                           elementChoices = xfchoices (elementChoices e)
                         }
   where xfset setb = (\ v st -> set (setb v (get st)) st)
         xfchoices Nothing      = Nothing
         xfchoices (Just getcs) = Just $ getcs . get

-- |A gadget that offers a choice between alternatives.  This function
-- creates a gadget that expects an Int representing the index of the
-- chosen item from the state.  If it's more convenient to supply the
-- actual chosen value, use chooseEqG instead.

chooserG :: (Typeable b) =>
            String
         -> (a -> Int)
         -> (b -> a -> a)
         -> (a -> [b])
         -> Gadget a
chooserG name get set getChoices =
    autoLayout chooserLayout $ setChoices choices $ editorG name get' set'
        where get' st = (choices st, get st)
              set' (vs, v) = if v >= length vs
                             then error ("chooser index " ++ show v ++
                                         " was not in value list " ++
                                         show vs)
                             else set (getValues vs !! v)
              choices st = zip (map toDyn (getChoices st))
                               (map toDyn [0 :: Int ..])
              getValues ds = map (fromJust . fromDynamic . fst) ds

enumChooserG :: (Enum b, Bounded b, Read b, Show b) =>
                String
             -> (a -> b)
             -> (b -> a -> a)
             -> Gadget a
enumChooserG name get set =
    autoLayout enumLayout $
    setChoices elems $ renderWith toStr $ editorG name get' set'
        where get' st = (elems st, fromEnum $ get st)
              set' (_, v) = set $ toEnum v
              elems st = let vs = [minBound ..] `asTypeOf` [get st]
                             is = map fromEnum vs
                             ts = map show vs
                         in zip (map toDyn ts) (map toDyn is)
              toStr d = let (xs, v) = fromDyn d ([], -100)
                            e = toEnum ((v :: Int))
                            _ = xs :: [(Dynamic,Dynamic)]
                        in toDyn (show (e `asTypeOf` get undefined))

chooseEqG :: (Typeable b, Eq b) =>
             String
         -> (a -> b)
         -> (b -> a -> a)
         -> (a -> [b])
         -> Gadget a
chooseEqG name get set choices = chooserG name get' set choices
    where get' st = case elemIndex (get st) (choices st) of
                      Nothing -> -1
                      Just n  -> n

findGadget :: [String] -> Behaviour a -> Maybe (Gadget a)
findGadget name (B gs) = case filter (match name) gs of
                           []  -> Nothing
                           g:_ -> Just g
    where match [] _ = False
          match nm G { gadgetName = gnm } =
              isPrefixOf (reverse nm) (reverse gnm)

-- |Gadgets can change their properties based on the value of their state.
-- Currently, the following configurations are implemented:

-- |dynamicLabel: for write-only gadgets like Command, this can add
-- some state read functionality.  It is interpreted by the
-- renderer.

-- |enabled: a function on the state returning Bool.  If False, the
-- gadget is disabled in some widget- or renderer-specific way
-- (e.g. dimmed, hidden).

addConfig :: (Config a -> Config a) -> Gadget a -> Gadget a
addConfig f g = g { gadgetConfig = f (gadgetConfig g) }

enabled :: (a -> Bool) -> Gadget a -> Gadget a
enabled f = addConfig (enabledCfg f)

gadgetEnabled :: Gadget a -> a -> Bool
gadgetEnabled = isEnabled . gadgetConfig

dynamicLabel :: (a -> String) -> Gadget a -> Gadget a
dynamicLabel f = addConfig (labelConfig f)

walk :: [String] -> ([String] -> Gadget a -> [b]) -> Gadget a -> [b]
walk prefix f gadget@(G nm _ _ inner _ gs) =
    f (prefix ++ nm) gadget ++ innerg ++ concatMap (walk (prefix ++ nm) f) gs
        where innerg = case inner of
                         Nothing -> []
                         Just (IF g) -> walk (prefix ++ nm) f g

gadgets :: Gadget a -> Behaviour a
gadgets = B . walk [] getGadget
     where getGadget name g = [g { gadgetName = name }]

abstract :: Gadget a -> [String]
abstract = map flatName . walk [] (\ name g -> [g { gadgetName = name }])

gadgetCommand :: Gadget a -> a -> a
gadgetCommand G { gadgetElement = Just e } = elementSet e (toDyn ())
gadgetCommand _ = id

gadgetDisplay :: Gadget a -> a -> Dynamic
gadgetDisplay G { gadgetElement = Just e } = elementGet e
gadgetDisplay g = error $ "Can't connect a display to empty gadget " ++
                          flatName g

gadgetUpdate :: Gadget a -> Dynamic -> a -> a
gadgetUpdate G { gadgetElement = Just e } = elementSet e
gadgetUpdate g = error $ "Can't connect an update to empty gadget " ++
                          flatName g

gadgetChooser :: Gadget a -> a -> [(Dynamic, Dynamic)]
gadgetChooser g = case getChoices of
                    Nothing -> error $ "Can't connect a chooser to gadget " ++
                                       flatName g
                    Just get -> get
    where getChoices = gadgetElement g >>= elementChoices

gadgetChild :: Gadget a -> Gadget a
gadgetChild g = case gadgetInner g of
                  Just (IF child) -> child
                  Nothing         -> error $ "Gadget " ++ flatName g ++
                                             " has no inner child"

startLayout :: AutoLayout
startLayout = AL { alDirection = Vertical,
                   alEditable  = False,
                   alNames     = []
                 }

editableLayout :: AutoLayout -> AutoLayout
editableLayout al = al { alEditable = True }

type AutoLayoutFunction a = AutoLayout -> [Gadget a] -> Widget

boxLayout :: AutoLayoutFunction a
boxLayout al = boxLayout' . map (createLayout' al')
    where (boxLayout', al') =
              case alDirection al of
                Vertical   -> (vbox, al { alDirection = Horizontal })
                Horizontal -> (hbox, al { alDirection = Vertical })


textLayout :: AutoLayoutFunction a
textLayout = \ al _ -> case alEditable al of
                           True -> textBox
                           False -> textLabel ""

intLayout :: Int -> Int -> AutoLayoutFunction a
intLayout lo hi = \ al _ -> case alEditable al of
                              True -> slider (alDirection al) lo hi 1
                              False -> textLabel ""

boolLayout :: AutoLayoutFunction a
boolLayout = \ _ _ -> checkButton

buttonLayout :: AutoLayoutFunction a
buttonLayout = \ al _ -> caption (last (alNames al)) $ button []

enumLayout :: AutoLayoutFunction a
enumLayout = chooserLayout

chooserLayout :: AutoLayoutFunction a
chooserLayout = \ _ _ -> listView

typeableLayout :: TypeRep -> AutoLayoutFunction a
typeableLayout t = case filter ((t==) . fst) typeableLayouts of
                     []      -> textLayout
                     layouts -> snd (head layouts)
    where typeableLayouts = [(typeOf (1::Int), intLayout 0 999),
                             (typeOf False, boolLayout)]

createLayout :: Gadget a -> Widget
createLayout = createLayout' startLayout

createLayout' :: AutoLayout -> Gadget a -> Widget
createLayout' layout g =
    ui' nm $ gadgetLayout g layout' (gadgetChildren g)
        where nm = alNames layout ++ gadgetName g
              layout' = layout { alNames = nm }