Wed Jan 24 20:42:46 WET 2007 Miguel Vilaca <jmvilaca@di.uminho.pt>
* Update for new compilers and libraries versions
- Update module XTC to a more recent available online
- The code was using some deprecated libraries that have been
definitively removed in GHC 6.6; this patch update to the new
corresponding libraries, allowing compatibility with previous
GHC versions.
- Update to allow the use of HaXml 1.17 or 1.16 or 1.15 indifferently.
{
hunk ./Makefile 6
-# MAC = yes # comment this line if not in MAC
+# MAC = yes # uncomment this line if in MAC
+HDOCLIB = /usr/share/haddock-0.7
hunk ./Makefile 13
-EXTRA_OPTS = $(MAC_OPTS) -ignore-package network-1.0 # remove -ignore option if not with ghc 6.4
+EXTRA_OPTS = $(MAC_OPTS) # -ignore-package network-1.0 # uncomment this option if with ghc 6.4
hunk ./Makefile 15
-HC_OPTS = -package HaXml -package wx -package lang -fglasgow-exts -i$(IFACES) -Wall -static $(EXTRA_OPTS) [_$_]
+HC_OPTS = -package HaXml -package wx -fglasgow-exts -i$(IFACES) -Wall -static $(EXTRA_OPTS) [_$_]
hunk ./Makefile 69
-# Documentation target (use Haddock 0.7 in combination with GHC 6.4)[_^I_][_$_]
+# Documentation target (use Haddock 0.7 in combination with GHC 6.X)[_^I_][_$_]
hunk ./Makefile 75
- --lib /usr/local/share/haddock-0.7 \
- --use-package=wx --use-package=HaXml \
+ --lib $(HDOCLIB) \
+ --use-package=base --use-package=wx --use-package=HaXml \
hunk ./makeDist.bat 10
-xcopy examples INblobs\examples [_^M_][_$_]
+xcopy /S examples INblobs\examples [_^M_][_$_]
hunk ./src/Common.hs 1
-module Common (module Common, module IOExts, module Colors) where
+module Common (module Common, module Debug.Trace, module Colors) where
hunk ./src/Common.hs 4
-import IOExts(trace)
+import Debug.Trace(trace)
hunk ./src/Document.hs 146
- where erro ruleName = error $ "This shouldn't happen because «"
- ++ ruleName ++ "» must be a rule."
+ where erro ruleName = error $ "This shouldn't happen because << "
+ ++ ruleName ++ " >> must be a rule."
hunk ./src/DocumentFile.hs 10
+import Text.XML.HaXml.Types
hunk ./src/InfoKind.hs 1
+{-# OPTIONS -fallow-undecidable-instances #-}
hunk ./src/NetworkFile.hs 1
+{-# OPTIONS -fallow-undecidable-instances #-}
+
hunk ./src/NetworkUI.hs 1303
- , ("Management rules template's",DefaultRule)
+ , ("Rule template",DefaultRule)
hunk ./src/NetworkView.hs 28
-import Exception
+import Control.Exception
hunk ./src/PersistentDocument.hs 57
-import IOExts(IORef, newIORef, writeIORef, readIORef)
+import Data.IORef(IORef, newIORef, writeIORef, readIORef)
hunk ./src/SafetyNet.hs 5
-import Exception
+import Control.Exception
hunk ./src/XTC.hs 1
-{-# OPTIONS -fglasgow-exts #-}
-{-
- | Module : XTC
+--------------------------------------------------------------------------------
+{-| [_$_]
+ Module : XTC
+ Copyright : (c) Martijn Schrage 2005
+
hunk ./src/XTC.hs 7
+ Stability : experimental
+ Portability : portable
+
+
+ XTC: eXtended & Typed Controls for wxHaskell
hunk ./src/XTC.hs 13
- eXtended & Typed Controls for wxHaskell
- [_$_]
- [_$_]
- TODO: - how to handle duplicates (up to presentation) in item lists
- - check (!!) error that occured in Dazzle
- - implement tSelecting and other events
- - Check: instance selection etc. <Control> () or <Control> a
- - Maybe it should be () to prevent subclassing (which may cause a problem
- with the client data field
- - Items w String??
- - value of selection when nothing selected? add Maybe?
- - WxObject vs Object?
--}
+ The XTC library provides a typed interface to several wxHaskell controls.
+
+ - radio view (typed radio box)
+
+ - single-selection list view (typed single-selection list box)
hunk ./src/XTC.hs 19
-module XTC ( Labeled( toLabel )
- , TValued( tValue )
- , TItems( tItems )
- , TSelection( tSelection )
- , TSelections( tSelections )
+ - muliple-selection list view (typed multiple-selection list box)
+
+ - choice view (typed choice box)
+
+ - value entry (typed text entry)
+
+ XTC controls keep track of typed values and items, rather than
+ being string based. Selections in XTC controls consist of actual values
+ instead of indices.
+-}
+--------------------------------------------------------------------------------
+module XTC ( -- * Classes
+ Labeled( toLabel )
+ , TypedValued( typedValue )
+ , TypedItems( typedItems )
+ , TypedSelection( typedSelection )
+ , TypedMaybeSelection( typedMaybeSelection )
+ , TypedSelections( typedSelections )
+ -- * Controls
+ -- ** Radio view
hunk ./src/XTC.hs 40
+ -- ** Single-selection list view
hunk ./src/XTC.hs 42
+ -- ** Multiple-selection list view
hunk ./src/XTC.hs 44
+ -- ** Choice view
hunk ./src/XTC.hs 46
- , ComboView, mkComboView, mkComboViewEx
+ -- ** Value entry
hunk ./src/XTC.hs 48
- , change -- TODO wx should take care of this
--- , ObservableVar, mkObservableVar -- temporarily disabled due to name clash
- , xtc -- for testing, exported to avoid a warning in Dazzle
hunk ./src/XTC.hs 56
+-- | The labeled class is used by 'mkRadioView', 'mkListView', 'mkMultiListView', and
+-- 'mkChoiceView' for conveniently passing the function that maps an item onto its label.
hunk ./src/XTC.hs 64
-class Selection w => TSelection x w | w -> x where
- tSelection :: Attr w x
+-- | Widgets that have a typed selection. The selection can be accessed via the attribute 'typedSelection', and has type @x@.
+class Selection w => TypedSelection x w | w -> x where
+ typedSelection :: Attr w x
hunk ./src/XTC.hs 68
-class Selections w => TSelections x w | w -> x where
- tSelections :: Attr w [x]
+-- | Widgets that have a typed selection that may be empty. The selection can be accessed via the attribute 'typedMaybeSelection', and has type @Maybe x@.
+class Selection w => TypedMaybeSelection x w | w -> x where
+ typedMaybeSelection :: Attr w (Maybe x)
hunk ./src/XTC.hs 72
-class Items w String => TItems x w | w -> x where
- tItems :: Attr w [x]
+-- | Widgets that have a typed list of selections. The selection list can be accessed via the attribute 'typedSelections', and has type @[x]@.
+class Selections w => TypedSelections x w | w -> x where
+ typedSelections :: Attr w [x]
hunk ./src/XTC.hs 76
+-- | Widgets that have a typed list of items. The item list can be accessed via the attribute 'typedItems', and has type @[x]@.
+class Items w String => TypedItems x w | w -> x where
+ typedItems :: Attr w [x]
hunk ./src/XTC.hs 80
--- RadioView
+-- | Widgets that have a typed value. The value can be accessed via the attribute 'typedValue', and has type @x@.
+class TypedValued x w | w -> x where
+ typedValue :: Attr w (Maybe x)
+
+
+{--------------------------------------------------------------------------------
+ Radio view
+--------------------------------------------------------------------------------}
hunk ./src/XTC.hs 91
+-- | Pointer to a radio view, deriving from 'RadioBox'.
hunk ./src/XTC.hs 94
--- TODO: instance of tItems?
-instance Labeled x => TSelection x (RadioView x ()) where
- tSelection
- = newAttr "tSelection" viewGetTSelection viewSetTSelection
+instance TypedSelection x (RadioView x ()) where
+ typedSelection
+ = newAttr "typedSelection" radioViewGetTypedSelection radioViewSetTypedSelection
+
+instance TypedItems x (RadioView x ()) where
+ typedItems = newAttr "typedItems" viewGetTypedItems viewSetTypedItems
hunk ./src/XTC.hs 101
+-- | Create a new radio view with an initial orientation and a list of
+-- typed items. The item type (@x@) must be an instance of 'Labeled' to show each item's
+-- label. Use attribute 'typedSelection' to access the currently selected item, and 'typedItems' to access the list of items. Note:
+-- for a radio view (or radio box) the items may not be modified dynamically.
+--
+-- * Instances: 'TypedSelection', 'TypedItems', 'Selecting','Selection','Items' -- 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child',
+-- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'.
+--
hunk ./src/XTC.hs 110
-mkRadioView window orientation viewItems props = [_$_]
+mkRadioView window orientation viewItems props =
hunk ./src/XTC.hs 113
+-- | Create a new radio view with an initial orientation and a list of
+-- typed items. A function of type @(x -> String)@ maps items onto labels. [_$_]
+-- Use attribute 'typedSelection' to access the currently selected item, and 'typedItems' to access the list of items. Note:
+-- for a radio view (or radio box) the items may not be modified dynamically.
+--
+-- * Instances: 'TypedSelection', 'Selecting','Selection','Items' -- 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child',
+-- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'.
+--
hunk ./src/XTC.hs 122
-mkRadioViewEx window present orientation viewItems props = [_$_]
- do { model <- varCreate viewItems [_$_]
+mkRadioViewEx window present orientation viewItems props =
+ do { model <- varCreate viewItems
hunk ./src/XTC.hs 130
--- ListView
+
+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"
+ }
+ [_$_]
+{--------------------------------------------------------------------------------
+ Single-selection list view
+--------------------------------------------------------------------------------}
hunk ./src/XTC.hs 148
+-- | Pointer to a single-selection list view, deriving from 'SingleListBox'.
hunk ./src/XTC.hs 151
-instance TSelection x (ListView x ()) where
- tSelection = newAttr "tSelection" viewGetTSelection viewSetTSelection
+instance TypedMaybeSelection x (ListView x ()) where
+ typedMaybeSelection = newAttr "typedMaybeSelection" viewGetTypedMaybeSelection viewSetTypedMaybeSelection
hunk ./src/XTC.hs 154
-instance TItems x (ListView x ()) where
- tItems = newAttr "tItems" viewGetTItems viewSetTItems
+instance TypedItems x (ListView x ()) where
+ typedItems = newAttr "typedItems" viewGetTypedItems viewSetTypedItems
hunk ./src/XTC.hs 157
+-- | Create a single-selection list view. The item type (@x@) must be an instance of 'Labeled' to show each item's
+-- label. Use attribute 'typedMaybeSelection' to access the currently selected item, and 'typedItems' to access the list of items.
+--
+-- * Instances: 'TypedMaybeSelection', 'TypedItems', 'Sorted','Selecting','Selection','Items' -- 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child',
+-- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'.
+--
hunk ./src/XTC.hs 165
- [_$_]
+
+-- | Create a single-selection list view. A function of type @(x -> String)@ maps items onto labels. [_$_]
+-- Use attribute 'typedMaybeSelection' to access the currently selected item, and 'typedItems' to access the list of items.
+--
+-- * Instances: 'TypedMaybeSelection', 'TypedItems', 'Sorted','Selecting','Selection','Items' -- 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child',
+-- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'.
+--
hunk ./src/XTC.hs 176
--- MultiListView
+{--------------------------------------------------------------------------------
+ Multiple-selection list view
+--------------------------------------------------------------------------------}
hunk ./src/XTC.hs 182
+-- | Pointer to a multiple-selection list view, deriving from 'MultiListBox'.
hunk ./src/XTC.hs 185
-instance Labeled x => TSelections x (MultiListView x ()) where
- tSelections = newAttr "tSelections" multiListViewGetTSelections multiListViewSetTSelections
+instance TypedSelections x (MultiListView x ()) where
+ typedSelections = newAttr "typedSelections" multiListViewGetTypedSelections multiListViewSetTypedSelections
hunk ./src/XTC.hs 188
-instance Labeled x => TItems x (MultiListView x ()) where
- tItems = newAttr "tItems" viewGetTItems viewSetTItems
+instance TypedItems x (MultiListView x ()) where
+ typedItems = newAttr "typedItems" viewGetTypedItems viewSetTypedItems
hunk ./src/XTC.hs 191
+-- | Create a multiple-selection list view. The item type (@x@) must be an instance of 'Labeled' to show each item's
+-- label.
+-- Use attribute 'typedSelections' to access the currently selected items, and 'typedItems' to access the list of items.
+--
+-- * Instances: 'TypedSelections', 'TypedItems', 'Sorted', 'Selecting','Selections','Items' -- 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child',
+-- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'.
+--
hunk ./src/XTC.hs 201
+-- | Create a multiple-selection list view. A function of type @(x -> String)@ maps items onto labels. [_$_]
+-- Use attribute 'typedSelections' to access the currently selected items, and 'typedItems' to access the list of items.
+--
+-- * Instances: 'TypedSelections', 'TypedItems', 'Sorted', 'Selecting','Selections','Items' -- 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child',
+-- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'.
+--
hunk ./src/XTC.hs 210
-multiListViewSetTSelections :: MultiListView x () -> [x] -> IO ()
-multiListViewSetTSelections (multiListView :: MultiListView x ()) selectionItems =
+multiListViewSetTypedSelections :: MultiListView x () -> [x] -> IO ()
+multiListViewSetTypedSelections (multiListView :: MultiListView x ()) selectionItems =
hunk ./src/XTC.hs 221
-multiListViewGetTSelections :: MultiListView x () -> IO [x]
-multiListViewGetTSelections multiListView =
+multiListViewGetTypedSelections :: forall x. MultiListView x () -> IO [x]
+multiListViewGetTypedSelections multiListView =
hunk ./src/XTC.hs 227
- ; return (map (safeIndex "XTC.multiListViewGetTSelections" viewItems)
+ ; return (map (safeIndex "XTC.multiListViewGetTypedSelections" viewItems)
hunk ./src/XTC.hs 232
--- ChoiceView
+{--------------------------------------------------------------------------------
+ Choice view
+--------------------------------------------------------------------------------}
hunk ./src/XTC.hs 238
+-- | Pointer to a choice view, deriving from 'Choice'.
hunk ./src/XTC.hs 241
-instance Selecting (ChoiceView x ()) where
- select = newEvent "select" choiceGetOnCommand choiceOnCommand
--- Necessary because wxHaskell declares "instance Selecting (Choice ())" instead of
--- "Selecting (Choice a)". TODO: let/make Daan fix this
+instance TypedMaybeSelection x (ChoiceView x ()) where
+ typedMaybeSelection = newAttr "typedMaybeSelection" viewGetTypedMaybeSelection viewSetTypedMaybeSelection
hunk ./src/XTC.hs 244
-instance Selection (ChoiceView x ()) where
- selection = newAttr "selection" choiceGetSelection choiceSetSelection
--- Necessary because wxHaskell declares "instance Selection (Choice ())" instead of
--- "Selection (Choice a)".
-
-instance TSelection x (ChoiceView x ()) where
- tSelection = newAttr "tSelection" viewGetTSelection viewSetTSelection
-
-instance TItems x (ChoiceView x ()) where
- tItems = newAttr "tItems" viewGetTItems viewSetTItems
+instance TypedItems x (ChoiceView x ()) where
+ typedItems = newAttr "typedItems" viewGetTypedItems viewSetTypedItems
hunk ./src/XTC.hs 247
+-- | Create a choice view to select one item from a list of typed items. The item type (@x@) must be an instance of 'Labeled' to show each item's
+-- label.
+-- Use attribute 'typedMaybeSelection' to access the currently selected item, and 'typedItems' to access the list of items.
+--
+-- * Instances: 'TypedMaybeSelection', 'TypedItems', 'Sorted', 'Selecting','Selection','Items' -- 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child',
+-- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'.
+--
hunk ./src/XTC.hs 258
+-- | Create a choice view to select one item from a list of typed items. A function of type @(x -> String)@ maps items onto labels. [_$_]
+-- Use attribute 'typedMaybeSelection' to access the currently selected item, and 'typedItems' to access the list of items.
+--
+-- * Instances: 'TypedMaybeSelection', 'TypedItems', 'Sorted', 'Selecting','Selection','Items' -- 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child',
+-- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'.
+--
hunk ./src/XTC.hs 269
--- ComboView
-
-data CComboView a b
-
-type ComboView a b = ComboBox (CComboView a b)
+-- Generic constructors, getters, and setters
hunk ./src/XTC.hs 271
-
-instance TSelection x (ComboView x ()) where
- tSelection = newAttr "tSelection" viewGetTSelection viewSetTSelection
-
-instance TItems x (ComboView x ()) where
- tItems = newAttr "tItems" viewGetTItems viewSetTItems
-
-mkComboView :: Labeled x => Window a -> [Prop (ComboView x ())] -> IO (ComboView x ())
-mkComboView window (props :: [Prop (ComboView x ())]) =
- mkViewEx comboBox window (toLabel :: x -> String) props
-
-mkComboViewEx :: Window a -> (x -> String) -> Style -> [Prop (ComboView x ())] -> IO (ComboView x ())
-mkComboViewEx window present stl props = [_$_]
- mkViewEx (\win -> comboBoxEx win stl) window present props
-
-
-
--- generic mk function that puts a model and a present function in the client data
+-- Generic mk function that puts a model and a present function in the client data.
+-- Used for ListView, MultiListView, and ChoiceView.
hunk ./src/XTC.hs 283
--- generic set/getTSelection for RadioView, ListView, and ChoiceView
-
-viewGetTSelection :: TSelection x (WxObject a) => WxObject a -> IO x
-viewGetTSelection view =
+-- Generic getTypedMaybeSelection for RadioView, ListView, and ChoiceView.
+viewGetTypedMaybeSelection :: forall a x. Selection (WxObject a) => WxObject a -> IO (Maybe x)
+viewGetTypedMaybeSelection view =
hunk ./src/XTC.hs 289
- ; viewItems <- get model value
- ; return (safeIndex "XTC.viewGetTSelection" viewItems selectedIndex)
+ ; if selectedIndex == -1
+ then return Nothing
+ else do { viewItems <- get model value
+ ; return $ Just (safeIndex "XTC.viewGetTypedMaybeSelection" viewItems selectedIndex)
+ }
hunk ./src/XTC.hs 296
--- if non unique, set to first viewItem with same label
--- selection is set to 0 if object is not found, maybe -1 is better?
-viewSetTSelection :: TSelection x (WxObject a) => WxObject a -> x -> IO ()
-viewSetTSelection view selectionItem =
+-- Generic setTypedMaybeSelection for RadioView, ListView, and ChoiceView.
+viewSetTypedMaybeSelection :: forall a x. Selection (WxObject a) => WxObject a -> Maybe x -> IO ()
+viewSetTypedMaybeSelection view mSelectionItem =
hunk ./src/XTC.hs 302
- ; let label = present selectionItem
- ; let index = findLabelIndex present label viewItems
+ ; let index = case mSelectionItem of
+ Nothing -> -1
+ Just selectionItem -> let label = present selectionItem
+ in findLabelIndex present label viewItems
hunk ./src/XTC.hs 312
- Nothing -> 0
-
-viewGetTItems :: TItems x (WxObject a) => WxObject a -> IO [x]
-viewGetTItems view =
+ Nothing -> -1
+ [_$_]
+-- Generic getTypedItems for ListView, MultiListView, and ChoiceView.
+viewGetTypedItems :: forall a x. TypedItems x (WxObject a) => WxObject a -> IO [x]
+viewGetTypedItems view =
hunk ./src/XTC.hs 323
-viewSetTItems :: TItems x (WxObject a) => WxObject a -> [x] -> IO ()
-viewSetTItems view viewItems =
+-- Generic setTypedItems for ListView, MultiListView, and ChoiceView.
+viewSetTypedItems :: forall a x. TypedItems x (WxObject a) => WxObject a -> [x] -> IO ()
+viewSetTypedItems view viewItems =
hunk ./src/XTC.hs 333
-
-
-
-
--- ValueEntry
-
-class Parseable x where
- parse :: String -> Maybe x
-
-instance Parseable String where
- parse = Just
-
-{- When a type is instance of Read, a simple Parseable instance can be declared with readParse
- e.g. for Int: instance Parseable Int where parse = readParse
-
-TODO: can we make this some kind of default?
--}
-readParse :: Read x => String -> Maybe x [_$_]
-readParse str = case reads str of
- [(x, "")] -> Just x
- _ -> Nothing
-
-class TValued x w | w -> x where
- tValue :: Attr w (Maybe x)
+{--------------------------------------------------------------------------------
+ Value entry
+--------------------------------------------------------------------------------}
hunk ./src/XTC.hs 339
+-- | Pointer to a choice view, deriving from 'TextCtrl'.
hunk ./src/XTC.hs 342
-instance TValued x (ValueEntry x ()) where
- tValue
- = newAttr "tValue" valueEntryGetTValue valueEntrySetTValue
+instance TypedValued x (ValueEntry x ()) where
+ typedValue
+ = newAttr "typedValue" valueEntryGetTypedValue valueEntrySetTypedValue
hunk ./src/XTC.hs 346
+-- | Create a single-line value entry control. The value type (@x@) must be an instance of 'Show' and 'Read'
+-- to present a value as a string in the entry and parse the string from the entry back to (maybe) a value.
+-- Use 'typedValue' to access the value.
+-- Note: 'alignment' has to
+-- be set at creation time (or the entry has default alignment (=left) ).
+--
+-- * Instances: 'TypedValued', 'Wrap', 'Aligned', 'Commanding' -- 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child',
+-- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'.
+--
hunk ./src/XTC.hs 357
- [_$_]
+
+-- | Create a single-line value entry control. The two functions of type @(x -> String)@ and @(String -> Maybe x)@ are used
+-- to present a value as a string in the entry and parse the string from the entry back to (maybe) a value.
+-- Use 'typedValue' to access the value.
+-- Note: 'alignment' has to
+-- be set at creation time (or the entry has default alignment (=left) ).
+--
+-- * Instances: 'TypedValued', 'Wrap', 'Aligned', 'Commanding' -- 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child',
+-- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'.
+--
hunk ./src/XTC.hs 370
- ; objectSetClientData valueEntry (return ()) (present, parse) [_$_]
+ ; objectSetClientData valueEntry (return ()) (present, parse)
hunk ./src/XTC.hs 372
- [_$_]
+
hunk ./src/XTC.hs 377
- do { mVal <- get valueEntry tValue
- ; set valueEntry [ bgcolor := case mVal of -- TODO: add property for error color?
+ do { mVal <- get valueEntry typedValue
+ ; set valueEntry [ bgcolor := case mVal of
hunk ./src/XTC.hs 383
- } -- drawing a squiggly doesn't work because font metrics are not available
+ } -- drawing a squiggly is not possible because font metrics are not available
hunk ./src/XTC.hs 385
-valueEntryGetTValue :: ValueEntry x () -> IO (Maybe x)
-valueEntryGetTValue valueEntry =
+valueEntryGetTypedValue :: forall x. ValueEntry x () -> IO (Maybe x)
+valueEntryGetTypedValue valueEntry =
hunk ./src/XTC.hs 392
-valueEntrySetTValue :: ValueEntry x () -> Maybe x -> IO ()
-valueEntrySetTValue valueEntry mValue =
+valueEntrySetTypedValue :: forall x. ValueEntry x () -> Maybe x -> IO ()
+valueEntrySetTypedValue valueEntry mValue =
hunk ./src/XTC.hs 401
-class Observable w where
- change :: Event w (IO ())
- [_$_]
-instance Observable (TextCtrl a) where
- change = newEvent "change" (controlGetOnText) (controlOnText)
-
-
-
--- ObservableVar
-
--- add variable as WxObject
-{-
-type Observer x = (WxObject (), x -> IO ())
-
-data ObservableVar x = ObservableVar (Var [Observer x]) (Var x)
-
-instance Valued ObservableVar where
- value
- = newAttr "value" observableVarGetValue observableVarSetValue
-
-mkObservableVar :: x -> IO (ObservableVar x)
-mkObservableVar x =
- do { observersV <- variable [ value := [] ]
- ; var <- variable [ value := x ]
- ; return $ ObservableVar observersV var
- }
- [_$_]
-observableVarGetValue :: ObservableVar x -> IO x
-observableVarGetValue (ObservableVar _ var) = get var value
+-- Utility functions
hunk ./src/XTC.hs 403
-observableVarSetValue :: ObservableVar x -> x -> IO ()
-observableVarSetValue (ObservableVar observersV var) x =
- do { myObservers <- get observersV value
- ; set var [ value := x ]
- ; sequence_ [ obs x | (_, obs) <- myObservers ]
- }
+-- A variation of 'read' that returns Nothing if the string cannot be parsed.
+readParse :: Read x => String -> Maybe x
+readParse str = case reads str of
+ [(x, "")] -> Just x
+ _ -> Nothing
hunk ./src/XTC.hs 409
-class Observable x w | w -> x where
- observers :: Attr w [Observer x]
+safeIndex :: String -> [a] -> Int -> a
+safeIndex msg xs i
+ | i >= 0 && i < length xs = xs !! i
+ | otherwise = internalError "XTC" "safeIndex" msg
hunk ./src/XTC.hs 414
-instance Observable x (ObservableVar x) where
- observers
- = newAttr "observers" observableVarGetObservers observableVarSetObservers
+internalError :: String -> String -> String -> a
+internalError moduleName functionName errorString =
+ error (moduleName ++ "." ++ functionName ++ ": " ++ errorString)
hunk ./src/XTC.hs 418
-observableVarGetObservers :: ObservableVar x -> IO [Observer x]
-observableVarGetObservers (ObservableVar observersV _) = get observersV value [_$_]
hunk ./src/XTC.hs 419
-observableVarSetObservers :: ObservableVar x -> [Observer x] -> IO ()
-observableVarSetObservers (ObservableVar observersV var) myObservers = -- return ()
- do { set observersV [ value := myObservers ]
- ; x <- get var value
- ; sequence_ [ obs x | (_, obs) <- myObservers ]
- }
+-- Some bits that should be part of wxHaskell
hunk ./src/XTC.hs 421
+instance Selecting (ChoiceView x ()) where
+ select = newEvent "select" choiceGetOnCommand choiceOnCommand
+-- Necessary because wxHaskell declares "instance Selecting (Choice ())" instead of
+-- "Selecting (Choice a)".
hunk ./src/XTC.hs 426
--- all WxObjects get the event 'change'
+instance Selection (ChoiceView x ()) where
+ selection = newAttr "selection" choiceGetSelection choiceSetSelection
+-- Necessary because wxHaskell declares "instance Selection (Choice ())" instead of
+-- "Selection (Choice a)".
hunk ./src/XTC.hs 431
-class Observing w where
- change :: ObservableVar x -> Event w (x -> IO ())
- [_$_]
-instance Observing (WxObject a) where
- change observableVar
- = newEvent "change" (getOnObserve observableVar) (setOnObserve observableVar)
hunk ./src/XTC.hs 432
-setOnObserve :: ObservableVar x -> Object a -> (x -> IO ()) -> IO ()
-setOnObserve (ObservableVar observersV var) obj observer = [_$_]
- do { oldObservers <- get observersV value
- ; let otherObservers = filter ((/= objectCast obj) . fst) oldObservers
- ; set observersV [ value := (objectCast obj, observer) : otherObservers ]
- ; x <- get var value
- ; observer x
- }
+-- The Observable class is missing from wxHaskell, even though the components are there.
+class Observable w where
+ change :: Event w (IO ())
hunk ./src/XTC.hs 436
-getOnObserve :: ObservableVar x -> Object a -> IO (x -> IO ())
-getOnObserve (ObservableVar observersV _) obj =
- do { myObservers <- get observersV value
- ; case lookup (objectCast obj) myObservers of
- Just obs -> return obs
- Nothing -> do { internalError "XTC" "getOnObserve" "object is not an observer" [_$_]
- ; return $ \_ -> return ()
- }
- } [_$_]
--}
+instance Observable (TextCtrl a) where
+ change = newEvent "change" (controlGetOnText) (controlOnText)
hunk ./src/XTC.hs 440
--- Utility functions
hunk ./src/XTC.hs 441
-safeIndex :: String -> [a] -> Int -> a
-safeIndex msg xs i
- | i >= 0 && i < length xs = xs !! i
- | otherwise = internalError "XTC" "safeIndex" msg
hunk ./src/XTC.hs 442
-internalError :: String -> String -> String -> a
-internalError moduleName functionName errorString =
- error (moduleName ++ "." ++ functionName ++ ": " ++ errorString)
hunk ./src/XTC.hs 444
--- Test function
hunk ./src/XTC.hs 449
- [_$_]
- [_$_]
- ; listV <- mkListView f [ tItems := ["sdfsdf", "fdssd"]
- , enabled := True
- ]
- [_$_]
- ; choiceV <- mkChoiceView f [ tItems := ["sdfsdf", "fdssd"]
- , enabled := True
- ]
- ; comboV <- mkComboView f [ tItems := ["sdfsdf", "fdssd"]
+
+-- ; listV <- singleListBox f [items := ["hallo"]]
+ ; listV <- mkListView f [ typedItems := ["sdfsdf", "fdssd"]
+ , enabled := True
+ ]
+
+ ; radioV <- mkRadioView f Vertical [ "Een", "Twee" ] []
+ ; choiceV <- mkChoiceView f [ typedItems := ["sdfsdf", "fdssd"]
hunk ./src/XTC.hs 459
+ -- ; comboV <- mkComboView f [ typedItems := ["sdfsdf", "fdssd"]
+ -- , enabled := True
+ -- ]
hunk ./src/XTC.hs 463
- ; ve <- mkValueEntry f [ tValue := Just True ]
- -- ; set t [ on (change counterV) := \i -> set t [ text := show i ] ] [_$_]
- [_$_]
- ; bUp <- button f [ text := "increase", on command := do { s1 <- get comboV tSelection
- ; s2 <- get listV text
- ; print (s1,s2)
+ ; ve <- mkValueEntry f [ typedValue := Just True ]
+ -- ; set t [ on (change counterV) := \i -> set t [ text := show i ] ]
+
+ ; bUp <- button f [ text := "increase", on command := do { -- s1 <- get comboV typedSelection
+ ; s1 <- get radioV typedSelection
+ ; print (s1)
+ ; s2 <- get listV typedMaybeSelection
+ ; print (s2)
hunk ./src/XTC.hs 473
- [_$_]
+
hunk ./src/XTC.hs 477
- -- , hfloatCenter $ row 5 [ widget bUp, widget bDown ] [_$_]
+ , widget bUp
+ -- , hfloatCenter $ row 5 [ widget bUp, widget bDown ]
hunk ./src/XTC.hs 481
- , widget choiceV
- , widget comboV
- , widget ve
+ -- , widget choiceV
+ -- , widget comboV
+ -- , widget ve
hunk ./src/XTC.hs 486
- [_$_]
+
hunk ./startghc.bat 1
-ghc -ffi -package wx -package HaXml -package lang -Wall -fglasgow-exts -ilib\DData:src src\Main.hs --make -o INblobs.exe [_$_]
+ghc -ffi -package wx -package HaXml -Wall -fglasgow-exts -ilib\DData:src src\Main.hs --make -o INblobs.exe -ignore-package network-1.0
hunk ./startghci.bat 1
-ghci -ffi -package wx -package HaXml -package lang -Wall -fglasgow-exts -ilib\DData:src src\Main.hs [_$_]
+ghci -ffi -package wx -package HaXml -Wall -fglasgow-exts -ilib\DData:src src\Main.hs -ignore-package network-1.0
}