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