> module Barrie.Gadgets (Gadget, Behaviour, > findGadget, gadgets, abstract, gadgetName, > commandG, > displayG, displayG', textDisplayG, > editorG, editorG', textEditorG, > chooserG, chooserG', textChooserG, enumChooserG, > localG, innerG, > enabled, gadgetEnabled, dynamicLabel, > gadgetConfig, > connectChooserDisplay, > connectDisplayGadget, > connectEditorGadget, > connectCommandGadget, > connectInnerGadget > ) where > import Data.List > import Control.Monad > import Barrie.AbstractGadgets > import Barrie.Config > import Barrie.Trace > data Behaviour a = B [Gadget a] > -- |A gadget is a piece of user interface functionality (as opposed > -- to a widget, which is a piece of user interface rendering). > data Gadget a = G { gFullName :: [String], > gConfig :: Config a, > gElement :: Element a > } > -- |The semantics of a gadget are defined by its Element. > -- Internally, all element manipulation is perform via conversions > -- to and from String, which is a shame, but there it is. > -- It is not beyond the bounds of possibility that existential types > -- are a solution to this problem, but for now, this is where we > -- are. The exported constructor functions hide this wart, to some > -- extent (e.g. you can use showG for an instance of Show, or > -- showG' to supply your own show function). > -- |An element comes in five flavours: > -- |Display: presents a value to the user. For example: labels, > -- |read-only text boxes, check boxes, radio buttons -- anything > -- |with a simple display. > -- |Editor: a display that can edit, such as a text box, a check > -- |box, or a slider. > -- |Command: a gadget that updates the state, sort of like a > -- |write-only Editor for type (), where the only thing you know is > -- |that it's been activated (so the () argument can be dropped). > -- |Can be rendered with buttons, menu items, that sort of thing. > -- |Chooser: like displays and editors, but the values come from a > -- |restricted set of possiblities. The value is a Maybe String, > -- |because it's possible (and often reasonable) to not choose > -- |anything. > -- |Inner: a single gadget placed inside another one. Used to > -- |construct nested and pop-up gadgets. > -- |Local: gadgets nested inside another one. Sort of a superclass > -- |of Inner, but it's not possible to make a pop-up out of them. > -- |Used to structure gadgets (functionally, not in terms of > -- |layout). > -- |Constructor functions are used to create gadgets, which is how > -- |we pretend we're not dealing with Strings only. In general, for > -- |a gadget flavour F with signature SF a b, we have: > -- | fG :: (Show b, Read b) => String -> SF a b -> Gadget a > -- | textFG :: String -> SF a String -> Gadget a > -- | fG' :: (b -> String) -> (String -> b) -> SF a b -> Gadget a > -- |fG uses the built-in Read and Show to perform the conversions > -- |fStrG uses id for read and show > -- |fG' allows them to be specified. > -- |Display gadgets don't need the Read instance (or the > -- |corresponding function), and Command gadgets don't need either > -- |instance (so we have commandG but not commandG') > data Element a = Display (a -> String) > | Editor (a -> String) (String -> a -> a) > | Command (a -> a) > | Chooser (a -> Maybe String) > (String -> a -> a) (a -> [String]) > | Inner (Gadget a) > | Local [Gadget a] > -- data InnerElement a = forall b. InnerE (a -> b) (b -> a -> a) (Gadget b) > -- |Returns the name of the gadget. Internally (and > -- slightly externally), the name of a gadget is a list of Strings > -- containing the full path from the top to the gadget. This is > -- converted to a '.'-separated String. > gadgetName :: Gadget a -> String > gadgetName = intercalate ['.'] . gFullName > -- |Create a command gadget > commandG :: String -> (a -> a) -> Gadget a > commandG name f = G [name] defaultConfig (Command f) > -- |Create a display gadget > displayG :: (Show b) => String -> (a -> b) -> Gadget a > displayG = displayG' show > textDisplayG :: String -> (a -> String) -> Gadget a > textDisplayG = displayG' id > displayG' :: (b -> String) -> String -> (a -> b) -> Gadget a > displayG' toString name get = G [name] defaultConfig > (Display (toString . get)) > -- |editorG allows a gadget to show and edit part of the state. > editorG' :: (b -> String) -- ^ toString: convert to string > -> (String -> b) -- ^ fromString: convert from String > -> String -- ^ gadget name > -> (a -> b) -- ^ get value from state > -> (b -> a -> a) -- ^ update state > -> Gadget a > editorG' toString fromString name get set = > G [name] defaultConfig (Editor (toString . get) (set . fromString)) > editorG :: (Show b, Read b) => > String -- ^ gadget name > -> (a -> b) -- ^ get value from state > -> (b -> a -> a) -- ^ update state > -> Gadget a > editorG = editorG' show read > textEditorG :: String -- ^ gadget name > -> (a -> String) -- ^ get value from state > -> (String -> a -> a) -- ^ update state > -> Gadget a > textEditorG = editorG' id id > > -- |localG does not perform any state transformation directly, but > -- can be used to structure a gadget tree. > localG :: String -> [Gadget a] -> Gadget a > localG name gs = G [name] defaultConfig (Local gs) > -- |chooserG > chooserG' :: (b -> String) -- ^ toString: convert to string > -> (String -> b) -- ^ fromString: convert from String > -> String -- ^ the name of the chooser gadget > -> (a -> Maybe b) -- ^ current selected value > -> (b -> a -> a) -- ^ update the state with a new value > -> (a -> [b]) -- ^ list of available choices > -> Gadget a > chooserG' toString fromString name get set elems = > G [name] defaultConfig > (Chooser (liftM toString . get) (set . fromString) > (map toString . elems)) > chooserG :: (Read b, Show b) => > String -- ^ the name of the chooser gadget > -> (a -> Maybe b) -- ^ current selected value > -> (b -> a -> a) -- ^ update the state with a new value > -> (a -> [b]) -- ^ list of available choices > -> Gadget a > chooserG = chooserG' show read > textChooserG :: String -- ^ the name of the chooser gadget > -> (a -> Maybe String) -- ^ current selected value > -> (String -> a -> a) -- ^ update the state with a new value > -> (a -> [String]) -- ^ list of available choices > -> Gadget a > textChooserG = chooserG' id id > -- A convenient way to create a choice from a bounded enum. > enumChooserG :: (Enum b, Read b, Show b) => > String > -> (a -> Maybe b) > -> (b -> a -> a) > -> Gadget a > enumChooserG name get set = chooserG' show read name get set > (const [toEnum 0 ..]) > innerG :: String -> (a -> b) -> (b -> a -> a) -> Gadget b -> Gadget a > innerG name get set gadget = G [name] defaultConfig (Inner launch) > where launch = transform get set gadget > transform :: (a -> b) -> (b -> a -> a) -> Gadget b -> Gadget a > transform get set (G name config elmt) = > G name (transformConfig get config) (transformE get set elmt) > transformE :: (a -> b) -> (b -> a -> a) -> Element b -> Element a > transformE get set = xform > where xform (Display getb) = Display (getb . get) > xform (Editor getb setb) = Editor (getb . get) (xfset setb) > xform (Command update) = > Command (\ st -> set (update (get st)) st) > xform (Chooser getb setb getvs) = > Chooser (getb . get) (xfset setb) > (getvs . get) > xform (Inner g) = Inner (transform get set g) > xform (Local gs) = Local (map (transform get set) gs) > xfset setb = (\ v st -> set (setb v (get st)) st) > -- |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 { gConfig = f (gConfig g) } > enabled :: (a -> Bool) -> Gadget a -> Gadget a > enabled f = addConfig (enabledCfg f) > dynamicLabel :: (a -> String) -> Gadget a -> Gadget a > dynamicLabel f = addConfig (labelConfig f) > gadgetConfig :: Gadget a -> (Config a -> b) -> b > gadgetConfig gadget config = config $ gConfig gadget > gadgetEnabled :: Gadget a -> a -> Bool > gadgetEnabled g = gadgetConfig g isEnabled > findGadget :: [String] -> Behaviour a -> Maybe (Gadget a) > findGadget name (B gs) = > case filter (match name) gs of > [] -> Nothing > g:_ -> Just g > where match name1 (G name2 _ _) = > not (null name1) && > isPrefixOf (reverse name1) (reverse name2) > type Fetch a = a -> String > type Update a = String -> a -> a > gadgetEditor :: Gadget a -> (Fetch a, Update a) > gadgetEditor (G _ _ (Editor get set)) = (get, set) > gadgetEditor (G _ _ (Chooser get set _ )) = (maybe "" id . get, set) > gadgetEditor g = error $ "Can't connect an editor to gadget '" ++ > gadgetName g ++ "'" > gadgetChooser :: Gadget a -> (a -> [String], Fetch a) > gadgetChooser (G _ _ (Chooser get _ elems)) = (elems, maybe "" id . get) > gadgetChooser g = error $ "Can't connect a chooser to gadget '" ++ > gadgetName g ++ "'" > gadgetDisplay :: Gadget a -> Fetch a > gadgetDisplay (G _ _ (Display get)) = get > gadgetDisplay (G _ _ (Editor get _)) = get > gadgetDisplay (G _ _ (Chooser get _ _)) = (maybe "" id . get) > gadgetDisplay g = error $ "Can't connect a display to gadget '" ++ > gadgetName g ++ "'\n" ++ show (abstract g) > gadgetCommand :: Gadget a -> (a -> a) > gadgetCommand (G _ _ (Command update)) = update > gadgetCommand g = error $ "Can't connect a command to gadget '" ++ > gadgetName g ++ "'" > gadgetInner :: Gadget a -> Gadget a > gadgetInner (G _ _ (Inner g)) = g > gadgetInner g = error $ "Can't connect a inner to gadget '" ++ > gadgetName g ++ "'\n" ++ show (abstract g) > connectEditorGadget :: (IO () -> IO ()) -- ^ connection creator > -> IO a -- ^ gui state retriever > -> IO String -- ^ gadget value retriever > -> Maybe (Gadget a) -- ^ optional gadget > -> (a -> IO ()) -- ^ state change applier > -> IO () > connectEditorGadget onAction getState gadgetValue gadget apply = do > let connectEditor get set = onAction (do st <- getState > curr <- gadgetValue > when (get st /= curr) $ do > apply $ set curr st) > case liftM gadgetEditor gadget of > Nothing -> return () > Just (get,set) -> connectEditor get set > connectChooserDisplay :: ([String] -> IO ()) > -> (Int -> IO ()) > -> Maybe (Gadget a) > -> a -> IO () > connectChooserDisplay setChoices setValue gadget = do > let update getChoices get st = (do > let choices = getChoices st > value = get st > setChoices choices > case elemIndex value choices of > Nothing -> setValue (-1) > Just index -> setValue index) > case liftM gadgetChooser gadget of > Nothing -> \ _ -> return () > Just (getChoices, get) -> update getChoices get > connectDisplayGadget :: (String -> IO ()) -- GUI element updater > -> Maybe (Gadget a) > -> a -> IO () > connectDisplayGadget update gadget = do > let connectDisplay get = update . get > case liftM gadgetDisplay gadget of > Nothing -> \ _ -> return () > Just get -> connectDisplay get > connectCommandGadget :: (IO () -> IO ()) -- connection creator > -> IO a -- state retriever > -> Maybe (Gadget a) > -> (a -> IO ()) -- state updater > -> IO () > connectCommandGadget onCommand getState gadget setState = do > let connectCommand update = onCommand (do st <- getState > setState (update st)) > case liftM gadgetCommand gadget of > Nothing -> return () > Just update -> connectCommand update > connectInnerGadget :: (IO () -> IO ()) -- launch connector > -> (Gadget a -> a -> IO a) -- inner > -> IO a -- state retriever > -> Maybe (Gadget a) > -> (a -> IO ()) -- state updater > -> IO () > connectInnerGadget onLaunch inner getState gadget setState = do > let connectInner g = > onLaunch (do st <- getState > traceMessage $ "connecting: " ++ > gadgetName g > st' <- inner g st > traceMessage $ "finished: " ++ gadgetName g > setState st') > case liftM gadgetInner gadget of > Nothing -> return () > Just g -> connectInner g > walk :: [String] -> ([String] -> Gadget a -> [b]) -> Gadget a -> [b] > walk prefix f gadget@(G nm _ e) = > case e of > (Local ws) -> f (prefix ++ nm) gadget ++ > concatMap (walk (prefix ++ nm) f) ws > (Inner w) -> f (prefix ++ nm) gadget ++ walk (prefix ++ nm) f w > _ -> f (prefix ++ nm) gadget > abstract :: Gadget a -> [AbstractGadget] > abstract = walk [] abstractElem > where abstractElem name e = case gElement e of > Display _ -> [alabel name] > Editor _ _ -> [atext name] > Command _ -> [acommand name] > Chooser _ _ _ -> [achoice name] > Inner _ -> [ainner name] > Local _ -> [alocal name] > gadgets :: Gadget a -> Behaviour a > gadgets = B . walk [] getGadget > where getGadget name (G _ cfg elmt) = [G name cfg elmt]