diff --git a/COPYRIGHT.txt b/COPYRIGHT.txt new file mode 100644 --- /dev/null +++ b/COPYRIGHT.txt @@ -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 diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,4 @@ +#! /usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain diff --git a/SybWidget.cabal b/SybWidget.cabal new file mode 100644 --- /dev/null +++ b/SybWidget.cabal @@ -0,0 +1,31 @@ +Name: SybWidget +Version: 0.4.0 +Copyright: Mads Lindstrøm +License: LGPL +License-file: COPYRIGHT.txt +Author: Mads Lindstrøm +Maintainer: Mads Lindstrøm +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 + + diff --git a/src/Graphics/UI/SybWidget.hs b/src/Graphics/UI/SybWidget.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/SybWidget.hs @@ -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 diff --git a/src/Graphics/UI/SybWidget/InstanceCreator.hs b/src/Graphics/UI/SybWidget/InstanceCreator.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/SybWidget/InstanceCreator.hs @@ -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)) + diff --git a/src/Graphics/UI/SybWidget/MySYB.hs b/src/Graphics/UI/SybWidget/MySYB.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/SybWidget/MySYB.hs @@ -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 + diff --git a/src/Graphics/UI/SybWidget/PriLabel.hs b/src/Graphics/UI/SybWidget/PriLabel.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/SybWidget/PriLabel.hs @@ -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 diff --git a/src/Graphics/UI/SybWidget/SybOuter.hs b/src/Graphics/UI/SybWidget/SybOuter.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/SybWidget/SybOuter.hs @@ -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