module Graphics.UI.XTC (
Labeled( toLabel )
, TypedValued( typedValue )
, TypedItems( typedItems )
, TypedSelection( typedSelection )
, TypedMaybeSelection( typedMaybeSelection )
, TypedSelections( typedSelections )
, Observable( change )
, RadioView, mkRadioView, mkRadioViewEx
, ListView, mkListView, mkListViewEx
, MultiListView, mkMultiListView, mkMultiListViewEx
, ChoiceView, mkChoiceView, mkChoiceViewEx
, ValueEntry, mkValueEntry, mkValueEntryEx
) where
import Graphics.UI.WX hiding (window, label,ListView)
import Graphics.UI.WXCore hiding (label, Event)
import Data.List
import Data.Maybe
class Labeled x where
toLabel :: x -> String
instance Labeled String where
toLabel str = str
class Selection w => TypedSelection x w | w -> x where
typedSelection :: Attr w x
class Selection w => TypedMaybeSelection x w | w -> x where
typedMaybeSelection :: Attr w (Maybe x)
class Selections w => TypedSelections x w | w -> x where
typedSelections :: Attr w [x]
class Items w String => TypedItems x w | w -> x where
typedItems :: Attr w [x]
class TypedValued x w | w -> x where
typedValue :: Attr w (Maybe x)
data CRadioView x b
type RadioView x b = RadioBox (CRadioView x b)
instance TypedSelection x (RadioView x ()) where
typedSelection
= newAttr "typedSelection" radioViewGetTypedSelection radioViewSetTypedSelection
instance TypedItems x (RadioView x ()) where
typedItems = newAttr "typedItems" viewGetTypedItems viewSetTypedItems
mkRadioView :: Labeled x => Window a -> Orientation -> [x] -> [Prop (RadioView x ())] -> IO (RadioView x ())
mkRadioView window orientation viewItems props =
mkRadioViewEx window toLabel orientation viewItems props
mkRadioViewEx :: Window a -> (x -> String) -> Orientation -> [x] -> [Prop (RadioView x ())] -> IO (RadioView x ())
mkRadioViewEx window present orientation viewItems props =
do { model <- varCreate viewItems
; radioView <- fmap objectCast $ radioBox window orientation (map present viewItems) []
; objectSetClientData radioView (return ()) (model, present)
; set radioView props
; return radioView
}
radioViewSetTypedSelection :: RadioView x () -> x -> IO ()
radioViewSetTypedSelection radioView x = viewSetTypedMaybeSelection radioView (Just x)
radioViewGetTypedSelection :: RadioView x () -> IO x
radioViewGetTypedSelection radioView =
do { mSel <- viewGetTypedMaybeSelection radioView
; case mSel of
Just item -> return item
Nothing -> internalError "XTC" "radioViewGetTypedSelection" "Radio view has empty selection"
}
data CListView a b
type ListView a b = SingleListBox (CListView a b)
instance TypedMaybeSelection x (ListView x ()) where
typedMaybeSelection = newAttr "typedMaybeSelection" viewGetTypedMaybeSelection viewSetTypedMaybeSelection
instance TypedItems x (ListView x ()) where
typedItems = newAttr "typedItems" viewGetTypedItems viewSetTypedItems
mkListView :: Labeled x => Window a -> [Prop (ListView x ())] -> IO (ListView x ())
mkListView window props = mkListViewEx window toLabel props
mkListViewEx :: Window a -> (x -> String) -> [Prop (ListView x ())] -> IO (ListView x ())
mkListViewEx window present props = mkViewEx singleListBox window present props
data CMultiListView a b
type MultiListView a b = MultiListBox (CMultiListView a b)
instance TypedSelections x (MultiListView x ()) where
typedSelections = newAttr "typedSelections" multiListViewGetTypedSelections multiListViewSetTypedSelections
instance TypedItems x (MultiListView x ()) where
typedItems = newAttr "typedItems" viewGetTypedItems viewSetTypedItems
mkMultiListView :: Labeled x => Window a -> [Prop (MultiListView x ())] -> IO (MultiListView x ())
mkMultiListView window props = mkMultiListViewEx window toLabel props
mkMultiListViewEx :: Window a -> (x -> String) -> [Prop (MultiListView x ())] -> IO (MultiListView x ())
mkMultiListViewEx window present props = mkViewEx multiListBox window present props
multiListViewSetTypedSelections :: MultiListView x () -> [x] -> IO ()
multiListViewSetTypedSelections (multiListView :: MultiListView x ()) selectionItems =
do { Just ((model, present) :: (Var [x], x -> String)) <-
unsafeObjectGetClientData multiListView
; viewItems <- get model value
; let labels = map present selectionItems
; let indices = catMaybes [ findIndex (\it -> present it == label) viewItems
| label <- labels ]
; set multiListView [ selections := indices ]
}
multiListViewGetTypedSelections :: forall x . MultiListView x () -> IO [x]
multiListViewGetTypedSelections multiListView =
do { Just ((model, _) :: (Var [x], x -> String)) <-
unsafeObjectGetClientData multiListView
; selectedIndices <- get multiListView selections
; viewItems <- get model value
; return (map (safeIndex "XTC.multiListViewGetTypedSelections" viewItems)
selectedIndices)
}
data CChoiceView a b
type ChoiceView a b = Choice (CChoiceView a b)
instance TypedMaybeSelection x (ChoiceView x ()) where
typedMaybeSelection = newAttr "typedMaybeSelection" viewGetTypedMaybeSelection viewSetTypedMaybeSelection
instance TypedItems x (ChoiceView x ()) where
typedItems = newAttr "typedItems" viewGetTypedItems viewSetTypedItems
mkChoiceView :: Labeled x => Window a -> [Prop (ChoiceView x ())] -> IO (ChoiceView x ())
mkChoiceView window (props :: [Prop (ChoiceView x ())]) =
mkViewEx choice window (toLabel :: x -> String) props
mkChoiceViewEx :: Window a -> (x -> String) -> Style -> [Prop (ChoiceView x ())] -> IO (ChoiceView x ())
mkChoiceViewEx window present stl props =
mkViewEx (\win -> choiceEx win stl) window present props
mkViewEx :: (parent -> [p] -> IO (Object a)) -> parent -> (x -> String) -> [Prop (WxObject b)] ->
IO (WxObject b)
mkViewEx mkView window present props =
do { model <- varCreate []
; view <- fmap objectCast $ mkView window []
; objectSetClientData view (return ()) (model, present)
; set view props
; return view
}
viewGetTypedMaybeSelection :: forall x a . Selection (WxObject a) => WxObject a -> IO (Maybe x)
viewGetTypedMaybeSelection view =
do { Just ((model, _) :: (Var [x], x -> String)) <-
unsafeObjectGetClientData view
; selectedIndex <- get view selection
; if selectedIndex == 1
then return Nothing
else do { viewItems <- get model value
; return $ Just (safeIndex "XTC.viewGetTypedMaybeSelection" viewItems selectedIndex)
}
}
viewSetTypedMaybeSelection :: forall x a . Selection (WxObject a) => WxObject a -> Maybe x -> IO ()
viewSetTypedMaybeSelection view mSelectionItem =
do { Just ((model, present) :: (Var [x], x -> String)) <-
unsafeObjectGetClientData view
; viewItems <- get model value
; let index = case mSelectionItem of
Nothing -> 1
Just selectionItem -> let label = present selectionItem
in findLabelIndex present label viewItems
; set view [ selection := index ]
}
where findLabelIndex :: (x -> String) -> String -> [x] -> Int
findLabelIndex present label theItems =
case findIndex (\it -> present it == label) theItems of
Just ix -> ix
Nothing -> 1
viewGetTypedItems :: forall x a . TypedItems x (WxObject a) => WxObject a -> IO [x]
viewGetTypedItems view =
do { Just ((model, _) :: (Var [x], x -> String)) <-
unsafeObjectGetClientData view
; viewItems <- get model value
; return viewItems
}
viewSetTypedItems :: forall x a . TypedItems x (WxObject a) => WxObject a -> [x] -> IO ()
viewSetTypedItems view viewItems =
do { Just ((model, present) :: (Var [x], x -> String)) <-
unsafeObjectGetClientData view
; set model [ value := viewItems ]
; set view [ items := map present viewItems ]
}
data CValueEntry x b
type ValueEntry x b = TextCtrl (CValueEntry x b)
instance TypedValued x (ValueEntry x ()) where
typedValue
= newAttr "typedValue" valueEntryGetTypedValue valueEntrySetTypedValue
mkValueEntry :: (Show x, Read x) => Window b -> [ Prop (ValueEntry x ()) ] -> IO (ValueEntry x ())
mkValueEntry window props = mkValueEntryEx window show readParse props
mkValueEntryEx :: Window b -> (x -> String) -> (String -> Maybe x) -> [ Prop (ValueEntry x ()) ] -> IO (ValueEntry x ())
mkValueEntryEx window present parse props =
do { valueEntry <- fmap objectCast $ textEntry window []
; objectSetClientData valueEntry (return ()) (present, parse)
; set valueEntry $ props ++ [ on change :~ \handler -> do {validate valueEntry; handler} ]
; validate valueEntry
; return valueEntry
}
where validate :: ValueEntry x () -> IO ()
validate valueEntry =
do { mVal <- get valueEntry typedValue
; set valueEntry [ bgcolor := case mVal of
Nothing -> rgb 255 100 100
_ -> white
]
; repaint valueEntry
}
valueEntryGetTypedValue :: forall x . ValueEntry x () -> IO (Maybe x)
valueEntryGetTypedValue valueEntry =
do { Just ((_, parse) :: (x -> String, String -> Maybe x)) <- unsafeObjectGetClientData valueEntry
; valueStr <- get valueEntry text
; return $ parse valueStr
}
valueEntrySetTypedValue :: forall x . ValueEntry x () -> Maybe x -> IO ()
valueEntrySetTypedValue valueEntry mValue =
do { Just ((present, _) :: (x -> String, String -> Maybe x)) <- unsafeObjectGetClientData valueEntry
; case mValue of
Nothing -> return ()
Just theValue -> set valueEntry [ text := present theValue ]
}
readParse :: Read x => String -> Maybe x
readParse str = case reads str of
[(x, "")] -> Just x
_ -> Nothing
safeIndex :: String -> [a] -> Int -> a
safeIndex msg xs i
| i >= 0 && i < length xs = xs !! i
| otherwise = internalError "XTC" "safeIndex" msg
internalError :: String -> String -> String -> a
internalError moduleName functionName errorString =
error (moduleName ++ "." ++ functionName ++ ": " ++ errorString)
instance Selecting (ChoiceView x ()) where
select = newEvent "select" choiceGetOnCommand choiceOnCommand
instance Selection (ChoiceView x ()) where
selection = newAttr "selection" choiceGetSelection choiceSetSelection
class Observable w where
change :: Event w (IO ())
instance Observable (TextCtrl a) where
change = newEvent "change" (controlGetOnText) (controlOnText)