module Graphics.UI.SybWidget.SybOuter
( OuterWidget(..), FullPart(..)
, mkGetterSetter, mkFullSpliter
, isSingleConstructor, mkSpliterSingleConstr
, Spliter(..)
, mapParts, mapPartsM, mapPartsMDelay
, spliterToList, zipSpliterWithList
, mkConstrValMap, updateConstrValMap, lookupValue, alwaysValue
, ConstrValMap
, numericGetSet, sybRead, sybShow
, 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
data FullPart wid parent b = FullPart
{ partWidget :: wid b
, partGetter :: parent -> b
, partSetter :: parent -> b -> parent
}
isSingleConstructor :: (Data ctx a) => Proxy ctx -> a -> Bool
isSingleConstructor ctx x = length (constructors ctx x) == 1
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
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)
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)
data Spliter part parent a
= Constructor a
| forall b. (Typeable b) => Part (part b) (Spliter part parent (b -> a))
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, ())) ()
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)
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)
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
spliterToList :: (forall c. Typeable c => part c -> abstractPart)
-> Spliter part a b -> [abstractPart]
spliterToList _ (Constructor _) = []
spliterToList f (Part part rest) = (spliterToList f rest) ++ [f part]
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)
data ConstrValMap ref ctx a = ConstrValMap
{ pickConstrValMap :: ref (M.Map String a)
, pickCtx :: Proxy ctx
}
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
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 ()
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
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
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)
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
sybShow :: Data ctx a => Proxy ctx -> a -> String
sybShow ctx x = showConstr $ toConstr ctx x
typeLabel :: Data ctx a => Proxy ctx -> a -> PriLabel
typeLabel ctx x = badConstrLabel $ dataTypeName $ dataTypeOf ctx x