1 {-# LANGUAGE ExistentialQuantification, FunctionalDependencies 2 , KindSignatures, MultiParamTypeClasses 3 , RankNTypes, ScopedTypeVariables #-} 4 5 {- | Helper functions to creates generic widgets. 6 7 The /parent type/, which is refered thoughout the module 8 documentation, could also be called the enclosing type. For example 9 given: 10 11 data Foo = Foo Bar Boo 12 13 then the parent type of Bar and Boo will be Foo. 14 15 -} 16 module Graphics.UI.SybWidget.SybOuter 17 ( OuterWidget(..), FullPart(..) 18 , mkGetterSetter, mkFullSpliter 19 , isSingleConstructor, mkSpliterSingleConstr 20 -- * Spliter 21 , Spliter(..) 22 , mapParts, mapPartsM, mapPartsMDelay 23 , spliterToList, zipSpliterWithList 24 -- * Constructor-value map 25 , mkConstrValMap, updateConstrValMap, lookupValue, alwaysValue 26 , ConstrValMap 27 -- * Creating numeric widgets 28 , numericGetSet, sybRead, sybShow 29 -- * Type label 30 , typeLabel 31 ) 32 where 33 34 import Maybe 35 import Data.RefMonad 36 import qualified Data.Map as M 37 38 import Graphics.UI.SybWidget.MySYB 39 import Graphics.UI.SybWidget.InstanceCreator 40 import Graphics.UI.SybWidget.PriLabel 41 42 class OuterWidget outer where 43 updateLabel :: (PriLabel -> PriLabel) -> outer a -> outer a 44 45 -- |Widget with getter and setter. 46 data FullPart wid parent b = FullPart 47 { partWidget :: wid b 48 , partGetter :: parent -> b -- ^Extracts this parts value from the parent type 49 , partSetter :: parent -> b -> parent -- ^Sets this value on a parent type 50 } 51 52 -- |Has this type exactly one constructor? This function is 53 -- undefined for Int, Float, Double and Char. 54 isSingleConstructor :: (Data ctx a) => Proxy ctx -> a -> Bool 55 isSingleConstructor ctx x = length (constructors ctx x) == 1 56 57 -- |Constructs a Spliter using the constructor in the input type 58 -- ('y'). If 'y' has field labels, the individual parts are updated 59 -- with the field label names. 60 mkSpliterSingleConstr 61 :: forall (ctx :: * -> *) a outer. 62 (Data ctx a, OuterWidget outer) => 63 Proxy ctx 64 -> (forall a1. (Data ctx a1) => a1 -> outer a1) 65 -> a -> Spliter outer a a 66 mkSpliterSingleConstr ctx childToOuter y = spliter 67 where 68 spliter = zipSpliterWithList updateLabel' fieldLabels foldType 69 foldType :: Spliter outer a a 70 foldType = gfoldl ctx k z y where 71 k c x = Part (childToOuter x) c 72 z :: c -> Spliter outer a c 73 z c = Constructor c 74 updateLabel' lbl p = updateLabel (bestLabel (fieldNameLabel lbl)) p 75 fieldLabels = constrFields $ toConstr ctx y 76 77 {- 78 type UpdateLabel part = forall a. (PriLabel -> PriLabel) -> part a -> part a 79 80 relabel :: UpdateLabel part -> [String] 81 -> Spliter part m a -> Spliter part m a 82 relabel updateLabel lbls = zipSpliterWithList updateLabel' lbls 83 where updateLabel' lbl = updateLabel (bestLabel (PriLabel FieldName lbl)) 84 85 relabelWithFieldNames :: Data ctx m => 86 Proxy ctx -> UpdateLabel part -> m 87 -> Spliter part m a -> Spliter part m a 88 relabelWithFieldNames ctx updateLabel x = zipSpliterWithList updateLabel' fieldLabels 89 where updateLabel' lbl = updateLabel (bestLabel (PriLabel FieldName lbl)) 90 fieldLabels = constrFields $ toConstr ctx x 91 -} 92 93 94 -- |Creates a Spliter containing 'FullPart'-s. 95 mkFullSpliter 96 :: forall ctx parent part. (Data ctx parent) => 97 Proxy ctx -> Spliter part parent parent 98 -> Spliter (FullPart part parent) parent parent 99 mkFullSpliter ctx = fst . mapPartsAcc helper 0 where 100 helper depth bWid = (FullPart bWid (getFieldFun ctx depth) (setFieldFun ctx depth), depth + 1) 101 102 -- ****************** Get/Set actions ************** 103 104 -- |Creates getter and setter command for a Spliter. That is, it will 105 -- create two function which sets/gets all the parts of the Spliter. 106 mkGetterSetter :: forall ctx wid getM setM parent. 107 (Monad getM, Monad setM, Data ctx parent) => 108 Proxy ctx 109 -> (forall a. wid a -> getM a) 110 -> (forall a. wid a -> a -> setM ()) 111 -> Spliter wid parent parent 112 -> (getM parent, parent -> setM ()) 113 mkGetterSetter ctx getWidValue setWidValue = helper . mkFullSpliter ctx 114 where 115 helper :: Spliter (FullPart wid parent) parent b -> (getM b, parent -> setM ()) 116 helper (Constructor c) = (return c, \_ -> return ()) 117 helper (Part (FullPart innerWid getter _) towardsConstr) = 118 let (getTC, setTC) = helper towardsConstr 119 getValue = do getX <- getWidValue innerWid 120 getTC' <- getTC 121 return (getTC' getX) 122 setValue parent = do setTC parent 123 setWidValue innerWid (getter parent) 124 in (getValue, setValue) 125 126 -- ****************** Spliter ********************* 127 128 {- | The Splitter type contains the splitting of a type into a 129 Constructor and Parts. 130 131 The Spliter structure is reverse, in the sense that a type C a b c, 132 where C is a constructor and a, b and c is values to the constructor, 133 will be represented as (Splitter type in brackets): 134 135 (Part (part c) { C a b c } 136 (Part (part b) { c -> C a b c } 137 (Part (part a) { b -> c -> C a b c } 138 (Constructor C)))) { a -> b -> c -> C a b c } 139 -} 140 data Spliter part parent a 141 = Constructor a 142 | forall b. (Typeable b) => Part (part b) (Spliter part parent (b -> a)) 143 144 -- |Maps each part in a Spliter type. 145 mapParts :: forall (partA :: * -> *) (partB :: * -> *) parent. 146 (forall q. (Typeable q) => partA q -> partB q) 147 -> Spliter partA parent parent 148 -> Spliter partB parent parent 149 mapParts f = fst . mapPartsAcc (\_ part -> (f part, ())) () 150 151 -- |Accumulator version of mapParts. 152 mapPartsAcc :: forall (partA :: * -> *) (partB :: * -> *) parent acc. 153 (forall q. (Typeable q) => acc -> partA q -> (partB q, acc)) 154 -> acc 155 -> Spliter partA parent parent 156 -> (Spliter partB parent parent, acc) 157 mapPartsAcc f initialAcc = helper where 158 helper :: Spliter partA parent q -> (Spliter partB parent q, acc) 159 helper (Constructor c) = (Constructor c, initialAcc) 160 helper (Part x rest) 161 = let (newRest, restAcc) = helper rest 162 (part, acc) = f restAcc x 163 in (Part part newRest, acc) 164 165 -- |Monadic version of mapParts. The mapping is done deep first. It 166 -- is done deep first as we will then process the elements in the 167 -- field order. E.g. if the spliter is based on the: 168 -- 169 -- data Foo = Foo Int Double 170 -- 171 -- then the Int will be processed first, then the Double. 172 mapPartsM :: forall (partA :: * -> *) (partB :: * -> *) parent m. 173 (Monad m) => 174 (forall q. (Typeable q) => partA q -> m (partB q)) 175 -> Spliter partA parent parent 176 -> m (Spliter partB parent parent) 177 mapPartsM f = helper where 178 helper :: Spliter partA parent q -> m (Spliter partB parent q) 179 helper (Constructor c) = return $ Constructor c 180 helper (Part a rest) 181 = do rest' <- helper rest 182 newPart <- f a 183 return $ Part newPart rest' 184 185 data Delay partA partB a 186 = First (partB a) 187 | Delayed (partA a) 188 189 -- |Like mapPartsM, except that processing of certain parts can be delayed. 190 -- The first parameter decides which parts processing should be delayed. 191 -- 192 -- This is usefull when fine grained control of execution order is desired. 193 mapPartsMDelay :: forall (partA :: * -> *) (partB :: * -> *) parent m. 194 (Monad m) => 195 (forall q. (Typeable q) => partA q -> Bool) 196 -> (forall q. (Typeable q) => partA q -> m (partB q)) 197 -> Spliter partA parent parent 198 -> m (Spliter partB parent parent) 199 mapPartsMDelay delay f spliter = mapPartsM secondF =<< mapPartsM firstF spliter where 200 firstF :: forall y. (Typeable y) => partA y -> m (Delay partA partB y) 201 firstF part = case delay part of 202 True -> return $ Delayed part 203 False -> do part' <- f part 204 return $ First part' 205 secondF :: forall y. (Typeable y) => Delay partA partB y -> m (partB y) 206 secondF part = do case part of 207 Delayed p -> f p 208 First p -> return $ p 209 210 -- |Transforms a spiltter to a list. The list will follow the constructor fields order. 211 spliterToList :: (forall c. Typeable c => part c -> abstractPart) 212 -- ^Function to transform each part in the spliter to a list element. Note 213 -- that the parts have kind * -> *, but the output must be of kind *. 214 -> Spliter part a b -> [abstractPart] 215 spliterToList _ (Constructor _) = [] 216 spliterToList f (Part part rest) = (spliterToList f rest) ++ [f part] 217 218 -- |Zips a list with a spliter using 'f'. The list members are zipped 219 -- in the order of the constructor fields. If not enough list members 220 -- are present the rest of the spilter is un-mapped. 221 zipSpliterWithList :: forall a m n part. 222 (forall q. (Typeable q) => a -> part q -> part q) 223 -> [a] 224 -> Spliter part m n -> Spliter part m n 225 zipSpliterWithList f xs spliter = fst $ helper xs spliter where 226 helper :: forall b c. [a] -> Spliter part b c -> (Spliter part b c, [a]) 227 helper [] spliter' = (spliter', []) 228 helper ys (Constructor c) = (Constructor c, ys) 229 helper ys (Part p rest) = 230 case helper ys rest of 231 (rest', []) -> (Part p rest', []) 232 (rest', (z:zs)) -> (Part (f z p) rest', zs) 233 234 -- ******************** Constr/value map ************* 235 236 data ConstrValMap ref ctx a = ConstrValMap 237 { pickConstrValMap :: ref (M.Map String a) 238 , pickCtx :: Proxy ctx 239 } 240 241 -- |A map from from constructors to values. Used as memory when 242 -- creating multi-constructor widgtes. This way each time the 243 -- constructor is changed, we can look in the map to see if we had a 244 -- privious value for the new constructor. 245 mkConstrValMap :: (Data ctx a, RefMonad m ref) => Proxy ctx -> a -> m (ConstrValMap ref ctx a) 246 mkConstrValMap ctx x = 247 do mapVar <- newRef (M.singleton (showConstr $ toConstr ctx x) x) 248 return $ ConstrValMap mapVar ctx 249 250 -- |Updates the map with a new value. 251 updateConstrValMap :: (Data ctx a, RefMonad m ref) => ConstrValMap ref ctx a -> a -> m () 252 updateConstrValMap valueMemory x = 253 do let con = showConstr $ toConstr (pickCtx valueMemory) x 254 modifyRef (pickConstrValMap valueMemory) (M.insert con x) 255 return () 256 257 -- |Look in the map to see if we have a value for the constructor. 258 lookupValue :: (Data ctx a, RefMonad m ref) => ConstrValMap ref ctx a -> Constr -> m (Maybe a) 259 lookupValue valueMemory constr = 260 do cvMap <- readRef (pickConstrValMap valueMemory) 261 return $ M.lookup (showConstr constr) cvMap 262 263 -- |Like 'lookupValue', except if it cannot find a value in the map 264 -- one will be created using 'createInstance'. 265 alwaysValue :: (Data ctx a, RefMonad m ref) => 266 ConstrValMap ref ctx a -> Constr -> m a 267 alwaysValue valueMemory constr = 268 do maybeVal <- lookupValue valueMemory constr 269 return $ case maybeVal of 270 Nothing -> fromJust $ instanceFromConstr (pickCtx valueMemory) constr 271 Just y -> y 272 273 -- ************** Numeric helper functions *************** 274 275 {- | 276 277 Returns a getter and setter command for numeric types. The getter and 278 setter are applicable when numeric types are represented using 279 String. The function uses 'sybRead' and 'sybShow' to parse and 280 construct strings. In this way we avoid dependency on Show and Read 281 type classes. 282 283 It is generally a good idea to avoid dependencies. And it can be 284 essential to avoid dependency on Show and Read, if we want to 285 implement generic widgets for functions, as we cannot define Show and 286 Read for those. 287 288 It could be argued that Int, Double, Float, .. all are instances of 289 Read and Show, and it therefore unneccesary to avoid using these 290 classes. However, SYB will force any dependencies for these types on 291 all types for which we want generic functionality. SYB does that as we 292 make one piece of code handling all integer-like types, and one 293 handling all real-numbered types. Thus, we only have access to the 294 classes that are in the generic class's context. 295 296 The getter uses the last legitimate value when the input string is 297 non-parseable. 298 -} 299 numericGetSet :: (Data ctx a, RefMonad m ref) => Proxy ctx -> a 300 -> m (String -> m a, a -> m String) 301 numericGetSet ctx initial = 302 do lastVal <- newRef initial 303 let getter textVal = 304 do case sybRead ctx initial textVal of 305 Nothing -> readRef lastVal 306 Just x -> do writeRef lastVal x 307 return x 308 setter x = do writeRef lastVal x 309 return $ sybShow ctx x 310 return (getter, setter) 311 312 -- |Avoid dependency on the Read class, by using SYB to read a 313 -- value. It has _only_ been tested for numeric types. 314 -- 315 -- See also 'numericGetSet'. 316 sybRead :: Data ctx a => Proxy ctx -> a -> String -> Maybe a 317 sybRead ctx typeProxy textVal = 318 maybeConstr >>= (Just . fromConstr ctx) where 319 maybeConstr = readConstr (dataTypeOf ctx typeProxy) textVal 320 321 -- |Avoid dependency on the Show class, by using SYB to show a 322 -- value. It has _only_ been tested for numeric types. 323 -- 324 -- See also 'numericGetSet'. 325 sybShow :: Data ctx a => Proxy ctx -> a -> String 326 sybShow ctx x = showConstr $ toConstr ctx x 327 328 -- ************** Generating a label for a type ************* 329 330 -- |Creates a default label for a type. 331 typeLabel :: Data ctx a => Proxy ctx -> a -> PriLabel 332 typeLabel ctx x = badConstrLabel $ dataTypeName $ dataTypeOf ctx x