barrie-0.3.1: src/Barrie/Gadgets.lhs
> 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]