SybWidget (empty) → 0.4.0
raw patch · 8 files changed
+631/−0 lines, 8 filesdep +TypeComposedep +basedep +containerssetup-changed
Dependencies added: TypeCompose, base, containers, haskell98, mtl, syb-with-class, template-haskell
Files
- COPYRIGHT.txt +20/−0
- Setup.lhs +4/−0
- SybWidget.cabal +31/−0
- src/Graphics/UI/SybWidget.hs +13/−0
- src/Graphics/UI/SybWidget/InstanceCreator.hs +85/−0
- src/Graphics/UI/SybWidget/MySYB.hs +56/−0
- src/Graphics/UI/SybWidget/PriLabel.hs +90/−0
- src/Graphics/UI/SybWidget/SybOuter.hs +332/−0
+ COPYRIGHT.txt view
@@ -0,0 +1,20 @@+SybWidget - A library to ease the constructions of user interfaces.++Copyright (C) 2006 Mads Lindstrøm++This library is free software; you can redistribute it and/or+modify it under the terms of the GNU Lesser General Public+License as published by the Free Software Foundation; either+version 2.1 of the License, or (at your option) any later version.++This library is distributed in the hope that it will be useful,+but WITHOUT ANY WARRANTY; without even the implied warranty of+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU+Lesser General Public License for more details.++You should have received a copy of the GNU Lesser General Public+License along with this library; if not, write to the Free Software+Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA+++The author can be contacted at mads_lindstroem@yahoo.dk
+ Setup.lhs view
@@ -0,0 +1,4 @@+#! /usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain
+ SybWidget.cabal view
@@ -0,0 +1,31 @@+Name: SybWidget+Version: 0.4.0+Copyright: Mads Lindstrøm <mads_lindstroem@yahoo.dk>+License: LGPL+License-file: COPYRIGHT.txt+Author: Mads Lindstrøm <mads_lindstroem@yahoo.dk>+Maintainer: Mads Lindstrøm <mads_lindstroem@yahoo.dk>+Category: GUI+Build-Depends: base,haskell98,mtl,template-haskell,syb-with-class>=0.4,+ TypeCompose>0.3,containers+Tested-with: GHC==6.8.2+Synopsis: Library which aids constructing generic (SYB3-based) widgets+Build-type: Simple+Stability: experimental+Description:+ Basic building block for creating libraries which can generically construct widgets.+ That is, the library cannot by it self construct any widgets, but+ makes it easier to build libraries which can. This also means that the+ library is not dependent on any particular GUI library.+Ghc-options: -Wall+Exposed-modules:+ Graphics.UI.SybWidget+ ,Graphics.UI.SybWidget.InstanceCreator+ ,Graphics.UI.SybWidget.MySYB+ ,Graphics.UI.SybWidget.PriLabel+ ,Graphics.UI.SybWidget.SybOuter+other-modules:+Extensions: +hs-source-dirs: src++
+ src/Graphics/UI/SybWidget.hs view
@@ -0,0 +1,13 @@+-- |Reexports all the SybWidget modules.+module Graphics.UI.SybWidget+ ( module Graphics.UI.SybWidget.InstanceCreator+ , module Graphics.UI.SybWidget.MySYB+ , module Graphics.UI.SybWidget.PriLabel+ , module Graphics.UI.SybWidget.SybOuter+ )+where++import Graphics.UI.SybWidget.InstanceCreator+import Graphics.UI.SybWidget.MySYB+import Graphics.UI.SybWidget.PriLabel+import Graphics.UI.SybWidget.SybOuter
+ src/Graphics/UI/SybWidget/InstanceCreator.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}++{-# OPTIONS -fglasgow-exts #-}++-- |Contains functions to automatically create instances from+-- data type definitions.+module Graphics.UI.SybWidget.InstanceCreator+ ( gGenUpTo+ , createInstance, createInstance'+ , instanceFromConstr+ )++where++import Graphics.UI.SybWidget.MySYB++-- |Creates an instance with a specific constructor.+instanceFromConstr :: forall a ctx. Data ctx a => + Proxy ctx+ -> Constr+ -> Maybe a -- ^Returns Nothing if it was not possible to create the value.+instanceFromConstr ctx constr = fromConstrM ctx (createInstance ctx) constr++-- The function below is heavily inspired of "Test-data generator"+-- example from SYB2 paper.+--+-- |Creates an instance of a Haskell type. For this to work the compiler+-- must be able to deduce the type from the callee's context.+createInstance :: forall a ctx. Data ctx a => + Proxy ctx+ -> Maybe a+createInstance ctx = helper 1 -- Zero newer returns anything+ where+ --helper :: Int -> a+ helper 8 = Nothing -- Make sure we do not to loop eternally or for a very, very long time.+ helper x = if (length generate) == 0+ then helper (x+1)+ else Just $ head generate+ where+ generate = gGenUpTo ctx x++-- |Like 'createInstance' excepts it uses a phantom type to elicit the+-- correct type to return.+createInstance' :: forall a ctx. Data ctx a => + Proxy ctx+ -> a+ -> Maybe a+createInstance' ctx _ = createInstance ctx++-- This code is heavily inspired of the "Test-data generator" example in the SYB2 paper.++-- |Generates all possible instances of a, while using no more+-- than n levels of recursion. Each subtype requires another level+-- of recursion. For example:+--+-- Branch (Branch Leaf 17) (Leaf 3)+--+-- would require 4 levels of recursion. One for the first branch,+-- one for second branch, one for the left Leaf, and one for the+-- Int (the seventeen). The right part of the first branch (Left+-- 3) would be done in two recursions.+gGenUpTo :: forall a ctx. Data ctx a =>+ Proxy ctx+ -> Int -- ^ Max number of recursions+ -> [a]+gGenUpTo _ 0 = []+gGenUpTo ctx d = result+ where+ -- Recurse per possible constructor+ result = concat (map recurse cons)+ -- Retrieve constructors of the requested type+ -- cons :: (Data ctx a) => ctx() -> [Constr]+ cons = case dataTypeRep ty of+ AlgRep cs -> cs+ IntRep -> [mkIntConstr ty 0]+ FloatRep -> [mkFloatConstr ty 0]+ StringRep -> [mkStringConstr ty "f"] -- Also used for char, so we changed foo to f+ -- Or Maybe SYB3/Instances.hs should be changed+ NoRep -> [] -- error "InstanceCreator: NoRep"+ where+ ty = dataTypeOf ctx (head result)+ -- Find all terms headed by a specific Constr+ recurse :: Constr -> [a]+ recurse = fromConstrM ctx (gGenUpTo ctx (d-1))+
+ src/Graphics/UI/SybWidget/MySYB.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE ExistentialQuantification, KindSignatures, ScopedTypeVariables #-}++{-|+ This module reexports the SYB3 library.+ + It also makes some extensions to SYB3, namely getFieldFun and+ setFieldFun.+-}++module Graphics.UI.SybWidget.MySYB+ ( module Data.Generics.SYB.WithClass.Basics+ , module Data.Generics.SYB.WithClass.Derive+ , constructors+ , getFieldFun, setFieldFun+ , gToString+ )+where++import Data.Generics.SYB.WithClass.Basics+import Data.Generics.SYB.WithClass.Derive+import Data.Generics.SYB.WithClass.Instances()++import Maybe++{- *** My SYB Helper functions *** -}+-- |Returns a set of constructors. This function is+-- undefined for Int, Float, Double and Char+constructors :: (Data ctx a) => Proxy ctx -> a -> [Constr]+constructors ctx x = dataTypeConstrs $ dataTypeOf ctx x+++data GetFieldHelper = forall a. Typeable a => GetFieldHelper a++-- |A get field fun: parent -> child+getFieldFun :: forall a m (ctx :: * -> *).+ (Typeable a, Data ctx m) =>+ Proxy ctx -> Int -> m -> a+getFieldFun ctx i m = case gmapQ ctx (\x -> GetFieldHelper x) m !! i of+ (GetFieldHelper x) -> fromJust $ cast x++-- |A set field fun: parent -> child -> parent+setFieldFun :: forall m a (ctx :: * -> *).+ (Data ctx m, Typeable a) =>+ Proxy ctx -> Int -> m -> a -> m+setFieldFun ctx i m a = snd $ gfoldl ctx k z m+ where+ k (0, c) _ = (-1, (c . fromJust . cast) a)+ k (i', c) x = (i'-1, c x)+ z c = (i, c)++-- |Function is similar to show, except that strings are shown without escaped \".+gToString :: (Show a, Typeable a) => a -> String+gToString x = case (cast x) of+ (Just y) -> y+ (Nothing) -> show x+
+ src/Graphics/UI/SybWidget/PriLabel.hs view
@@ -0,0 +1,90 @@+{-|+ PriLabels are labels with a priority.++ PriLabels are usefull when widgets can have their label set multiple+ times. This happens with genericcally created widgets. For example in:++ data Foo = Foo { someName :: Bar }+ data Bar = Bar Int++ widgets created from Bar instances can have labels set due it's+ constructor name and the fieldName in Foo (someName). A GUI+ application programmer may also set the widgets label.++ When a widget has set it's label multiple times, the priority can be+ used to decide which label should be chosen.+-}+module Graphics.UI.SybWidget.PriLabel+ ( PriLabel(..)+ , Priority(..)+ , badConstrLabel, goodConstrLabel, fieldNameLabel, userDefinedLabel+ , bestLabel, humanizeLabel+ , defaultLabel, labelless+ )+where++import Char++-- |Prioritized label. If two 'PriLabel' can be used for some+-- component, then the one with highest priority is used.+data PriLabel = PriLabel { priority :: Priority, labelString :: String } deriving (Show, Eq)+-- |The label priority.+data Priority = BadConstr | GoodConstr | FieldName | UserDefined deriving (Show, Ord, Eq, Bounded, Enum)++badConstrLabel, goodConstrLabel, fieldNameLabel, userDefinedLabel :: String -> PriLabel+badConstrLabel label = PriLabel BadConstr label+goodConstrLabel label = PriLabel GoodConstr label+fieldNameLabel label = PriLabel FieldName label+userDefinedLabel label = PriLabel UserDefined label++-- |Creates a default (lowest priority) PriLabel+defaultLabel :: String -> PriLabel+defaultLabel label = PriLabel BadConstr label++labelless :: PriLabel+labelless = defaultLabel ""++-- |Choose label with highest priority. If equal then choose the left+-- |(first parameter) label.+bestLabel :: PriLabel -> PriLabel -> PriLabel+bestLabel left@(PriLabel priL _) right@(PriLabel priR _)+ | priL >= priR = left+ | otherwise = right++-- |Humanized label strings, by turning labels like "someLabelName"+-- into "Some label name".+humanizeLabel :: PriLabel -> PriLabel+humanizeLabel (PriLabel pri label) = PriLabel pri label'+ where+ label' | pri == UserDefined || not (and (map isLegitChar label))+ -- safegaurd against accidentally calling humanizeLabel twice + -- and against parsing special labels like "()"+ = label+ | elem '_' label = (first toUpper . nonCamel) label+ | otherwise = camelCase label+ -- humanizing non-camel case identifiers+ isLegitChar x = isAlphaNum x || elem x ['_', '\'']+ nonCamel [] = []+ nonCamel ('_':[]) = []+ nonCamel (x:[]) = x:[]+ nonCamel ('_':x:[]) = ' ':toUpper x:[]+ nonCamel (x:y:[]) = x:nonCamel [y]+ nonCamel ('_':x:y:xs)+ | isUpper y = ' ':toUpper x:nonCamel (y:xs)+ | otherwise = ' ':toLower x:nonCamel (y:xs)+ nonCamel (x:xs) = x:nonCamel xs+ --+ camelCase [] = []+ camelCase (x:xs) = toUpper x : (seperateWords [] xs)+ seperateWords cs [] = cs+ seperateWords [] (x:xs)+ | isUpper x = ' ':seperateWords [x] xs+ | otherwise = x:seperateWords [] xs+ seperateWords (c:[]) (x:xs)+ | isUpper x = seperateWords (c:x:[]) xs+ | otherwise = toLower c:x:seperateWords [] (xs)+ seperateWords (cs) (x:xs)+ | isUpper x = seperateWords (cs ++ [x]) xs+ | otherwise = (init cs) ++ ' ':(toLower $ last cs):x:seperateWords [] xs+ first _ [] = []+ first f (x:xs) = (f x):xs
+ src/Graphics/UI/SybWidget/SybOuter.hs view
@@ -0,0 +1,332 @@+{-# LANGUAGE ExistentialQuantification, FunctionalDependencies+ , KindSignatures, MultiParamTypeClasses+ , RankNTypes, ScopedTypeVariables #-}++{- | Helper functions to creates generic widgets.++The /parent type/, which is refered thoughout the module+documentation, could also be called the enclosing type. For example+given:++data Foo = Foo Bar Boo++then the parent type of Bar and Boo will be Foo.++-}+module Graphics.UI.SybWidget.SybOuter+ ( OuterWidget(..), FullPart(..)+ , mkGetterSetter, mkFullSpliter+ , isSingleConstructor, mkSpliterSingleConstr+ -- * Spliter+ , Spliter(..)+ , mapParts, mapPartsM, mapPartsMDelay+ , spliterToList, zipSpliterWithList+ -- * Constructor-value map+ , mkConstrValMap, updateConstrValMap, lookupValue, alwaysValue+ , ConstrValMap+ -- * Creating numeric widgets+ , numericGetSet, sybRead, sybShow+ -- * Type label+ , typeLabel+ )+where++import Maybe+import Data.RefMonad+import qualified Data.Map as M++import Graphics.UI.SybWidget.MySYB+import Graphics.UI.SybWidget.InstanceCreator+import Graphics.UI.SybWidget.PriLabel++class OuterWidget outer where+ updateLabel :: (PriLabel -> PriLabel) -> outer a -> outer a++-- |Widget with getter and setter.+data FullPart wid parent b = FullPart + { partWidget :: wid b+ , partGetter :: parent -> b -- ^Extracts this parts value from the parent type+ , partSetter :: parent -> b -> parent -- ^Sets this value on a parent type+ }++-- |Has this type exactly one constructor? This function is+-- undefined for Int, Float, Double and Char.+isSingleConstructor :: (Data ctx a) => Proxy ctx -> a -> Bool+isSingleConstructor ctx x = length (constructors ctx x) == 1++-- |Constructs a Spliter using the constructor in the input type+-- ('y'). If 'y' has field labels, the individual parts are updated+-- with the field label names.+mkSpliterSingleConstr+ :: forall (ctx :: * -> *) a outer.+ (Data ctx a, OuterWidget outer) =>+ Proxy ctx+ -> (forall a1. (Data ctx a1) => a1 -> outer a1)+ -> a -> Spliter outer a a+mkSpliterSingleConstr ctx childToOuter y = spliter + where+ spliter = zipSpliterWithList updateLabel' fieldLabels foldType+ foldType :: Spliter outer a a+ foldType = gfoldl ctx k z y where+ k c x = Part (childToOuter x) c+ z :: c -> Spliter outer a c+ z c = Constructor c+ updateLabel' lbl p = updateLabel (bestLabel (fieldNameLabel lbl)) p+ fieldLabels = constrFields $ toConstr ctx y++{-+type UpdateLabel part = forall a. (PriLabel -> PriLabel) -> part a -> part a++relabel :: UpdateLabel part -> [String]+ -> Spliter part m a -> Spliter part m a+relabel updateLabel lbls = zipSpliterWithList updateLabel' lbls+ where updateLabel' lbl = updateLabel (bestLabel (PriLabel FieldName lbl))++relabelWithFieldNames :: Data ctx m =>+ Proxy ctx -> UpdateLabel part -> m+ -> Spliter part m a -> Spliter part m a+relabelWithFieldNames ctx updateLabel x = zipSpliterWithList updateLabel' fieldLabels+ where updateLabel' lbl = updateLabel (bestLabel (PriLabel FieldName lbl))+ fieldLabels = constrFields $ toConstr ctx x+-}+++-- |Creates a Spliter containing 'FullPart'-s.+mkFullSpliter+ :: forall ctx parent part. (Data ctx parent) => + Proxy ctx -> Spliter part parent parent+ -> Spliter (FullPart part parent) parent parent+mkFullSpliter ctx = fst . mapPartsAcc helper 0 where+ helper depth bWid = (FullPart bWid (getFieldFun ctx depth) (setFieldFun ctx depth), depth + 1)++-- ****************** Get/Set actions **************++-- |Creates getter and setter command for a Spliter. That is, it will+-- create two function which sets/gets all the parts of the Spliter.+mkGetterSetter :: forall ctx wid getM setM parent.+ (Monad getM, Monad setM, Data ctx parent) =>+ Proxy ctx+ -> (forall a. wid a -> getM a)+ -> (forall a. wid a -> a -> setM ())+ -> Spliter wid parent parent+ -> (getM parent, parent -> setM ())+mkGetterSetter ctx getWidValue setWidValue = helper . mkFullSpliter ctx+ where + helper :: Spliter (FullPart wid parent) parent b -> (getM b, parent -> setM ())+ helper (Constructor c) = (return c, \_ -> return ())+ helper (Part (FullPart innerWid getter _) towardsConstr) =+ let (getTC, setTC) = helper towardsConstr+ getValue = do getX <- getWidValue innerWid+ getTC' <- getTC+ return (getTC' getX)+ setValue parent = do setTC parent + setWidValue innerWid (getter parent)+ in (getValue, setValue)++-- ****************** Spliter *********************++{- | The Splitter type contains the splitting of a type into a+Constructor and Parts.++The Spliter structure is reverse, in the sense that a type C a b c,+where C is a constructor and a, b and c is values to the constructor,+will be represented as (Splitter type in brackets):++ (Part (part c) { C a b c }+ (Part (part b) { c -> C a b c }+ (Part (part a) { b -> c -> C a b c }+ (Constructor C)))) { a -> b -> c -> C a b c }+-}+data Spliter part parent a+ = Constructor a+ | forall b. (Typeable b) => Part (part b) (Spliter part parent (b -> a))++-- |Maps each part in a Spliter type.+mapParts :: forall (partA :: * -> *) (partB :: * -> *) parent. + (forall q. (Typeable q) => partA q -> partB q)+ -> Spliter partA parent parent+ -> Spliter partB parent parent+mapParts f = fst . mapPartsAcc (\_ part -> (f part, ())) ()++-- |Accumulator version of mapParts.+mapPartsAcc :: forall (partA :: * -> *) (partB :: * -> *) parent acc. + (forall q. (Typeable q) => acc -> partA q -> (partB q, acc))+ -> acc+ -> Spliter partA parent parent+ -> (Spliter partB parent parent, acc)+mapPartsAcc f initialAcc = helper where+ helper :: Spliter partA parent q -> (Spliter partB parent q, acc)+ helper (Constructor c) = (Constructor c, initialAcc)+ helper (Part x rest)+ = let (newRest, restAcc) = helper rest+ (part, acc) = f restAcc x+ in (Part part newRest, acc)++-- |Monadic version of mapParts. The mapping is done deep first. It+-- is done deep first as we will then process the elements in the+-- field order. E.g. if the spliter is based on the:+--+-- data Foo = Foo Int Double+--+-- then the Int will be processed first, then the Double.+mapPartsM :: forall (partA :: * -> *) (partB :: * -> *) parent m.+ (Monad m) =>+ (forall q. (Typeable q) => partA q -> m (partB q))+ -> Spliter partA parent parent+ -> m (Spliter partB parent parent)+mapPartsM f = helper where+ helper :: Spliter partA parent q -> m (Spliter partB parent q)+ helper (Constructor c) = return $ Constructor c+ helper (Part a rest)+ = do rest' <- helper rest+ newPart <- f a+ return $ Part newPart rest'++data Delay partA partB a+ = First (partB a)+ | Delayed (partA a)++-- |Like mapPartsM, except that processing of certain parts can be delayed.+-- The first parameter decides which parts processing should be delayed.+-- +-- This is usefull when fine grained control of execution order is desired.+mapPartsMDelay :: forall (partA :: * -> *) (partB :: * -> *) parent m.+ (Monad m) =>+ (forall q. (Typeable q) => partA q -> Bool)+ -> (forall q. (Typeable q) => partA q -> m (partB q))+ -> Spliter partA parent parent+ -> m (Spliter partB parent parent)+mapPartsMDelay delay f spliter = mapPartsM secondF =<< mapPartsM firstF spliter where+ firstF :: forall y. (Typeable y) => partA y -> m (Delay partA partB y)+ firstF part = case delay part of+ True -> return $ Delayed part+ False -> do part' <- f part+ return $ First part'+ secondF :: forall y. (Typeable y) => Delay partA partB y -> m (partB y)+ secondF part = do case part of+ Delayed p -> f p+ First p -> return $ p++-- |Transforms a spiltter to a list. The list will follow the constructor fields order.+spliterToList :: (forall c. Typeable c => part c -> abstractPart)+ -- ^Function to transform each part in the spliter to a list element. Note+ -- that the parts have kind * -> *, but the output must be of kind *.+ -> Spliter part a b -> [abstractPart]+spliterToList _ (Constructor _) = []+spliterToList f (Part part rest) = (spliterToList f rest) ++ [f part]++-- |Zips a list with a spliter using 'f'. The list members are zipped+-- in the order of the constructor fields. If not enough list members+-- are present the rest of the spilter is un-mapped.+zipSpliterWithList :: forall a m n part.+ (forall q. (Typeable q) => a -> part q -> part q)+ -> [a]+ -> Spliter part m n -> Spliter part m n+zipSpliterWithList f xs spliter = fst $ helper xs spliter where+ helper :: forall b c. [a] -> Spliter part b c -> (Spliter part b c, [a])+ helper [] spliter' = (spliter', [])+ helper ys (Constructor c) = (Constructor c, ys)+ helper ys (Part p rest) =+ case helper ys rest of+ (rest', []) -> (Part p rest', [])+ (rest', (z:zs)) -> (Part (f z p) rest', zs)++-- ******************** Constr/value map *************++data ConstrValMap ref ctx a = ConstrValMap+ { pickConstrValMap :: ref (M.Map String a)+ , pickCtx :: Proxy ctx+ }++-- |A map from from constructors to values. Used as memory when+-- creating multi-constructor widgtes. This way each time the+-- constructor is changed, we can look in the map to see if we had a+-- privious value for the new constructor.+mkConstrValMap :: (Data ctx a, RefMonad m ref) => Proxy ctx -> a -> m (ConstrValMap ref ctx a)+mkConstrValMap ctx x =+ do mapVar <- newRef (M.singleton (showConstr $ toConstr ctx x) x)+ return $ ConstrValMap mapVar ctx++-- |Updates the map with a new value.+updateConstrValMap :: (Data ctx a, RefMonad m ref) => ConstrValMap ref ctx a -> a -> m ()+updateConstrValMap valueMemory x =+ do let con = showConstr $ toConstr (pickCtx valueMemory) x+ modifyRef (pickConstrValMap valueMemory) (M.insert con x)+ return ()++-- |Look in the map to see if we have a value for the constructor.+lookupValue :: (Data ctx a, RefMonad m ref) => ConstrValMap ref ctx a -> Constr -> m (Maybe a)+lookupValue valueMemory constr =+ do cvMap <- readRef (pickConstrValMap valueMemory)+ return $ M.lookup (showConstr constr) cvMap++-- |Like 'lookupValue', except if it cannot find a value in the map+-- one will be created using 'createInstance'.+alwaysValue :: (Data ctx a, RefMonad m ref) => + ConstrValMap ref ctx a -> Constr -> m a+alwaysValue valueMemory constr =+ do maybeVal <- lookupValue valueMemory constr+ return $ case maybeVal of+ Nothing -> fromJust $ instanceFromConstr (pickCtx valueMemory) constr+ Just y -> y++-- ************** Numeric helper functions ***************++{- |++Returns a getter and setter command for numeric types. The getter and+setter are applicable when numeric types are represented using+String. The function uses 'sybRead' and 'sybShow' to parse and+construct strings. In this way we avoid dependency on Show and Read+type classes.++It is generally a good idea to avoid dependencies. And it can be+essential to avoid dependency on Show and Read, if we want to+implement generic widgets for functions, as we cannot define Show and+Read for those.++It could be argued that Int, Double, Float, .. all are instances of+Read and Show, and it therefore unneccesary to avoid using these+classes. However, SYB will force any dependencies for these types on+all types for which we want generic functionality. SYB does that as we+make one piece of code handling all integer-like types, and one+handling all real-numbered types. Thus, we only have access to the+classes that are in the generic class's context.++The getter uses the last legitimate value when the input string is+non-parseable.+-}+numericGetSet :: (Data ctx a, RefMonad m ref) => Proxy ctx -> a+ -> m (String -> m a, a -> m String)+numericGetSet ctx initial =+ do lastVal <- newRef initial+ let getter textVal =+ do case sybRead ctx initial textVal of+ Nothing -> readRef lastVal+ Just x -> do writeRef lastVal x+ return x+ setter x = do writeRef lastVal x+ return $ sybShow ctx x+ return (getter, setter)++-- |Avoid dependency on the Read class, by using SYB to read a+-- value. It has _only_ been tested for numeric types.+-- +-- See also 'numericGetSet'.+sybRead :: Data ctx a => Proxy ctx -> a -> String -> Maybe a+sybRead ctx typeProxy textVal =+ maybeConstr >>= (Just . fromConstr ctx) where+ maybeConstr = readConstr (dataTypeOf ctx typeProxy) textVal++-- |Avoid dependency on the Show class, by using SYB to show a+-- value. It has _only_ been tested for numeric types.+--+-- See also 'numericGetSet'.+sybShow :: Data ctx a => Proxy ctx -> a -> String+sybShow ctx x = showConstr $ toConstr ctx x++-- ************** Generating a label for a type *************++-- |Creates a default label for a type.+typeLabel :: Data ctx a => Proxy ctx -> a -> PriLabel+typeLabel ctx x = badConstrLabel $ dataTypeName $ dataTypeOf ctx x