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 }