Gadgets.hs

module Barrie.Gadgets (Gadget, Behaviour,
                       displayG, editorG, commandG, sectionG,
                       chooserG, chooserG', enumChooserG, chooseEqG,
                       childG, initG, returnG,
                       gadgetDisplay, gadgetUpdate, gadgetCommand,
                       gadgetChooser, gadgetChild,
                       findGadget, gadgetName, flatName,
                       gadgetElementType,
                       gadgetConfig, gadgetEnabled, enabled, dynamicLabel,
                       columnTitles,
                       renderWith, gadgetRenderer,
                       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 (Gadget 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]),
                     elementRender    :: [Dynamic -> Dynamic]
                   }

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 :: (Typeable b) =>
              ([b -> Dynamic]) -> Gadget a -> Gadget a
renderWith rs = updateElement
                  (\ e -> e { elementRender = map (. fromJust . fromDynamic) rs
                            })

gadgetRenderer :: Gadget a -> [Dynamic -> Dynamic]
gadgetRenderer G { gadgetElement = Nothing } = []
gadgetRenderer G { gadgetElement = Just e } = elementRender e

setChoices :: (a -> [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 }

lowLevelGadget :: (Typeable b) =>
                  String
               -> (a -> b)
               -> (b -> a -> a)
               -> TypeRep
               -> Gadget a
lowLevelGadget name get set ty = mkGadget name elmt { elementType = ty }
    where elmt = mkElement get set



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))

initG :: (Typeable b) => String -> (b -> a) -> Gadget a
initG name initfn = autoLayout textLayout $
                        mkGadget name (mkElement initError (\ x _ -> initfn x))
    where initError _ = error "can't get value from an init gadget"

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

returnG :: String -> Gadget a
returnG name = G [name] (quitConfig True defaultConfig)
                        Nothing Nothing buttonLayout []

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 $ 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 (transform get set) (gadgetInner g),
        gadgetLayout   = boxLayout,
        gadgetChildren = map (transform get set) (gadgetChildren 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)
         -> (Int -> a -> a)
         -> (a -> [b])
         -> Gadget a
chooserG name get set getChoices =
    chooserG' name get set getChoices [toDyn]

chooserG' :: (Typeable b) =>
             String
          -> (a -> Int)
          -> (Int -> a -> a)
          -> (a -> [b])
          -> ([b -> Dynamic])
          -> Gadget a
chooserG' name get set getChoices renderer =
    autoLayout chooserLayout $ setChoices choices $ renderWith renderer $
               lowLevelGadget name get' set'
                                  (typeOf (head (getChoices undefined)))
        where get' st = (choices st, get st)
              set' (_, v) = set 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 = map toDyn (getChoices st)
              --  getValues ds = map (fromJust . fromDynamic) 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 [renderEnum] $ editorG name get' set'
        where get' st = (elems st, fromEnum $ get st)
              set' (_, v) = if v < 0
                              then error ("not setting enum to " ++ show v)
                              else set $ toEnum v
              elems st = let vs = [minBound .. maxBound] `asTypeOf` [get st]
                             ts = map fromEnum vs
                         in map toDyn ts
              renderEnum v = let e = toEnum v
                                 str = show (e `asTypeOf` get undefined)
                             in toDyn str

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
          set' v st = set (choices st !! v) st

findGadget :: [String] -> Gadget a -> Maybe (Gadget a)
findGadget [] = Just
findGadget (name:names) = \ top -> case filter fst (tries top) of
                                     []        -> Nothing
                                     (_,g):_   -> findGadget names g
    where tries g = [match g, matchInner g] ++
                    map match (gadgetChildren g) ++
                    concatMap tries (gadgetChildren g)
          match g = ([name] == gadgetName g, g)
          matchInner g = case gadgetInner g of
                           Nothing -> (False, g)
                           Just inner -> match inner

-- |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)

columnTitles :: [String] -> Gadget a -> Gadget a
columnTitles ts = addConfig (titleConfig ts)

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 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 }])

gadgetElementType :: Gadget a -> Maybe TypeRep
gadgetElementType g = gadgetElement g >>= return . elementType

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]
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 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 }