AutoForms-0.4.0: src/Graphics/UI/AF/WxForm/GenericEC.hs
{-# LANGUAGE ExistentialQuantification, FlexibleContexts, FlexibleInstances, FunctionalDependencies
, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, TypeFamilies #-}
module Graphics.UI.AF.WxForm.GenericEC
( genericEC, singleCom
, join2, join3, Merge(..)
)
where
import Graphics.UI.AF.General.InstanceCreator
import Graphics.UI.AF.General.MySYB
import Graphics.UI.AF.General(Mergeable(..))
import Graphics.UI.AF.WxForm.EditorComponent
import Graphics.UI.AF.WxForm.WxEnumeration
import Graphics.UI.AF.WxForm.ComIO
import Monad (liftM)
import Maybe
import Char(toUpper)
import Graphics.UI.WX hiding (Parent, label, parent, command, widget, Widget)
import qualified Graphics.UI.WX as WX
import Control.Exception(assert)
-- |Generic function to construct (EC a) types from any data type.
genericEC :: (Data ctx a, GInstanceCreator a)
=> Proxy ctx -> (forall a1. (Data ctx a1) => MakeEC a1)
-> MakeEC a
genericEC ctx f y =
if singleConstructor
then singleCom ctx f y
else multiCom ctx f y
where
singleConstructor = length (constructors ctx y) == 1
{-
FIXME: Memory of past values for multiCom. But this can wait.
type Value a = (Constr, Var a)
retrieveValue :: ctx -> [Value] -> Constr -> a
setValue :: [Value] -> Constr -> a -> Values
-}
-- |Handles data types with multiple constructors
multiCom :: (Data ctx a, GInstanceCreator a)
=> Proxy ctx -> (forall a1. (Data ctx a1) => MakeEC a1)
-> MakeEC a
multiCom ctx childCom y = mkEC toInnerCom
where
priLabel = PriLabel GoodConstr (dataTypeName $ dataTypeOf ctx y)
toInnerCom =
do (getValVar, onChangeVar, getEnableVar, setEnableVar, limitVar) <- liftIO makeVars
(p, chooser, chooserLay, widget, gui) <- baseGui
--
let makeContents' x = withPanel p $ makeContents p chooserLay getValVar onChangeVar
getEnableVar setEnableVar limitVar x
makeContentsIO <- liftIO' (\local -> return (\x -> local $ makeContents' x))
makeContents' y
liftIO $ setAtNewConstructor chooser makeContentsIO onChangeVar
let getVal = do getXIO <- varGet getValVar
getXIO
setVal x = do makeContentsIO x
pickSetVal chooser (toConstr ctx x)
getEnabled = do getEnabledIO <- varGet getEnableVar
getEnabledIO
setEnabled enable = do setEnabled' <- varGet setEnableVar
setEnabled' enable
pickSetEnabled chooser enable
addLimit = addToLimitVar limitVar
comIO <- mkComIO getVal setVal onChangeVar getEnabled setEnabled addLimit
innerECWithGui comIO widget gui
where
makeVars = do getValue <- varCreate (error "The impossible happened: getValueVar unset")
onChange <- makeOnChangeVar
getEnabled <- varCreate (error "The impossible happened: getEnabledVar unset")
setEnabled <- varCreate (error "The impossible happened: setEnabledVar unset")
limit <- makeLimitVar
return (getValue, onChange, getEnabled, setEnabled, limit)
-- getValue & setEnabled will always be initialized by makeContents
baseGui = do Parent parentPanel <- getPanel
p <- liftIO $ panel parentPanel []
let toEnum' x = (show x, x, \z -> showConstr x == showConstr z)
(chooser, Just (widget, gui))
<- withPanel p $ runEC (enumeration "Choose constructor"
(map toEnum' (constructors ctx y))
(toConstr ctx y))
(chooserLay, _) <- liftIO $ boxedLayout gui
-- Would like to use container here instead of "set p" and "widget p", but
-- how do we then update p's layout afterwards?
-- However, not using container makes WxHaskell act weird - I think.
liftIO $ set p [ layout := chooserLay ]
let lay label' = return $ boxed (capitalize label') $ dynamic $ fill $ WX.widget p
capitalize l = (toUpper . head) l : tail l
gui' = SelfContained lay priLabel
return (p, chooser, chooserLay, widget, gui')
makeContents p chooserLay getValVar onChangeVar getEnableVar setEnableVar limitVar x =
do -- IParent p <- getPanel
liftIO $ do oldWidgets <- get p children
assert (length oldWidgets /= 0) (return ())
mapM_ objectDelete (tail oldWidgets)
(com, widgetAndGui) <- runEC (singleCom ctx childCom x)
liftIO $ do lay <- maybe (return glue) (liftM fst . unboxedLayout . snd) widgetAndGui
set p [ layout := column 15 (chooserLay:[dynamic lay]) ]
--
varSet getValVar (pickGetVal com)
setParentListener com (signalChange onChangeVar)
varSet getEnableVar (pickGetEnabled com)
varSet setEnableVar (pickSetEnabled com)
limits <- varGet limitVar
mapM_ (\l -> pickAddLimit com l) limits
-- refit ensures better layout of widgets
refit p
return ()
setAtNewConstructor chooser makeContents' onChangeVar
= do setParentListener chooser
(do con <- io $ pickGetVal chooser
io $ makeContents' $ fromJust (constructorToInstance y con)
signalChange onChangeVar
return ()
)
-- constructorToInstance _ con = fromConstrM ctx (createInstance ctx) con
constructorToInstance _ con = fromConstrM gInstanceCreatorCtx createInstance con
-- This function is far from easy to understand. Therefore, do not try
-- unless you have a more than a few minutes to spare. I did try to
-- make it easier to understand. But still, it is difficult. If you
-- have ideas for improvement, please contact the author (see
-- http://autoforms.sourceforge.net/Author.html).
-- The splitter type contains the splitting of a type into a
-- Constructor and Parts. It is only used temporarely by the gmapCom
-- function.
-- The structure constructed by gmapCom is reverse, in the sense that a
-- type C a b c, where C is a constructor and a,b,c is values to the
-- constructor, will be represented as (Splitter type in brackets):
-- (Part (IO(EC c)) { C a b c }
-- (Part (IO(EC b)) { c -> C a b c }
-- (Part (IO(EC a)) { b -> c -> C a b c }
-- (Constructor C)))) { a -> b -> c -> C a b c }
data Spliter a = Constructor a
| forall b. (Typeable b) => Part (EC b) (Spliter (b -> a))
data Spliter' a m = Constructor' a -- m = master type = the type, this type is part of
| forall b s. Part' (ComIO b) (m -> b) (m -> b -> m) (Spliter' (b -> a) m)
depth :: Spliter a -> Int
depth (Constructor _) = 0
depth (Part _ spliter) = 1 + depth spliter
mkSpliter' :: (Data ctx b) => Proxy ctx -> Spliter a -> WxM (Spliter' a b, [(Widget, GUI)])
mkSpliter' ctx (Part ec spliter)
= do (s, widAndGuis) <- mkSpliter' ctx spliter
(comIO, maybeWidAndGui) <- runEC ec
return $ ( Part' comIO (getFieldFun ctx (depth spliter))
(setFieldFun ctx (depth spliter)) s
, widAndGuis ++ maybeToList maybeWidAndGui
)
mkSpliter' _ (Constructor c) = return (Constructor' c, [])
{-
mkSpliter' :: (Data ctx b) => Proxy ctx -> Window w -> Spliter a -> Spliter' a b
mkSpliter' ctx w (Part x spliter)
= Part' (innerCom x w) (getFieldFun ctx (depth spliter))
(setFieldFun ctx (depth spliter)) (mkSpliter' ctx w spliter)
mkSpliter' _ _ (Constructor c) = Constructor' c
The Label problem:
data Salary = Salary Sal deriving (Show, Eq, Read)
data Sal = Sal Double deriving (Show, Eq, Read)
if we now set "mkCom p = AF.label "Foo" someSalary"
then the Foo-label will be ignored. It is so because EditorComponent.updateLabel
do not descend into the EC's children. And it cannot without changing the EC type.
The singleCom function cannot help here, as "toInnerCom spliter w label" do not
know the labels priority, just it's name.
We might need to change the EC type anyway, if we want to assign shortcuts to
labels. Atleast if we want global knowledge to optimally assign the shortcuts.
If we give up on the shortcuts we could just let:
type ToInnerCom a = forall w. Window w -> PriLabel -> InnerCom a
that is, using PriLabel in stead of String.
-}
singleCom :: forall (ctx :: * -> *) a. (Data ctx a) =>
Proxy ctx
-> (forall a1. (Data ctx a1) => MakeEC a1)
-> MakeEC a
singleCom ctx childCom y = joinEditorComponents mkSpliter
where
mkSpliter = relabel fieldLabels $ gfoldl ctx k z y where
k c x = Part (childCom x) c
z c = Constructor c
relabel :: [String] -> Spliter b -> Spliter b
relabel (x:xs) (Part com sub)
= Part (updateLabel (bestLabel (PriLabel FieldName x)) com) (relabel xs sub)
relabel _ spliter = spliter
fieldLabels = reverse (constrFields $ toConstr ctx y)
joinEditorComponents :: Spliter a -> EC a
joinEditorComponents spliter
= toInnerCom spliter -- FIXME: updateLabel (\_ -> constructorLabel) $
toInnerCom :: Spliter a -> EC a -- WxM (ComIO a, Widget, GUI)
toInnerCom spliter = mkEC $
do (spliter', widgetsAndGuis) <- mkSpliter' ctx spliter
case joinGuis widgetsAndGuis of
Nothing -> guilessInnerEC "" y
Just (widget, gui) ->
do comIO <- makeCom spliter'
innerECWithGui comIO widget (setLabel constructorLabel gui)
mapSpliter :: (forall b. EC b -> EC b) -> Spliter c -> Spliter c
mapSpliter _ (Constructor c) = Constructor c
mapSpliter f (Part ec sub) = Part (f ec) (mapSpliter f sub)
constructorLabel = PriLabel GoodConstr $ showConstr $ toConstr ctx y
-- If toInnerCom's label argument, were PriLabel and just String, we
-- could use the foo function to set correct label. See "label problem"
-- above.
-- foo label s | length (guiLabels s) == 1 = setLabel label s
-- | otherwise = s
joinGuis :: [(a, GUI)] -> Maybe (a, GUI)
joinGuis widgetsAndGuis =
case widgetsAndGuis of
[] -> Nothing
[(w, y)] -> Just (w, y)
ys -> Just (fst $ head $ ys, containerGUI (map snd ys) $ labelless)
-- FIXME: do we need containerGui here?
makeCom :: Spliter' a a -> WxM (ComIO a)
makeCom (Constructor' _)
= error "GenericEC: Internal error: makeCom with Constructor'."
makeCom spliter = -- (Part' x funGet funSet towardsConstr) =
do getMaxDepth >>= \x -> io $ putStrLn $ "GenericEC.makeCom current max-depth: " ++ (show x)
enabledVar <- liftIO $ varCreate True
onChangeVar <- liftIO $ makeOnChangeVar
(getVal, setVal, setEnableAllComIOs, addLimit') <- joinComIO onChangeVar spliter
let getEnabled = varGet enabledVar
setEnabled enabled' = do setEnableAllComIOs enabled'
varSet enabledVar enabled'
addLimit = addLimit' getVal
mkComIO getVal setVal onChangeVar getEnabled setEnabled addLimit
where
-- The Label ([PriLabel]) should be in reverse order.
--
-- The Splitter type contains a list of Com types (one for each Part
-- constructor). These Com's are joined into the output of the
-- joinComIO function.
joinComIO :: OnChangeVars
-> Spliter' a b
-> WxM ( IO a, b -> IO()
, Bool -> IO(), IO b -> Limit b -> IO())
joinComIO _ (Constructor' x)
= return ( return x, \_ -> return(), \_ -> return(), \_ _ -> return())
joinComIO ocVar (Part' comIO getFun setFun towardsConstr) =
-- Note that it is important to call guiPartsAndValue before x (the input parameter).
-- Otherwise the tab order is disturbed.
do (valTC, setTC, setEnableTC, addLimitTC) -- TC = Towards Constructor
<- joinComIO ocVar towardsConstr
io $ setParentListener comIO (signalChange ocVar)
return ( do getX <- pickGetVal comIO
valTC' <- valTC
return (valTC' getX)
, \parent -> do setTC parent
pickSetVal comIO (getFun parent)
, \enable -> do (pickSetEnabled comIO) enable
setEnableTC enable
, \parent limit
-> do (pickAddLimit comIO) (\y -> do parent' <- parent
limit (setFun parent' y)
)
addLimitTC parent limit
)
--------------------------------------------------------------------------------
{- Design rationale joinN-functions:
Could we use a custom constructor? like (2nd argument):
join2 :: (Typeable a, Typeable b, Data ctx c)
=> Proxy ctx -> (a -> b -> c) -> EC a -> EC b -> (ComIO a -> ComIO b -> IO()) -> EC c
join2 ctx constructorFunction eca ecb comIOFun
no, as it would bring trouble if a, b, and c :: Int and constructor-function is (+).
There would be no way to automatically construct the function:
setVal :: EC c -> c -> IO()
-}
{-
instance Mergeable InnerEC where
merge innerECA innerECB =
let spliter' = Part' (getComIO innerECB) snd (\(x, _) c -> (x, c)) $
Part' (getComIO innerECA) fst (\(_, x) c -> (c, x)) $ mkCon' (,)
in liftM guilessInnerEC' $ makeCom spliter'
-}
instance Mergeable EC where
merge ecA ecB = mkEC toInnerCom where
toInnerCom =
do (comIOA, guiA) <- runEC ecA
(comIOB, guiB) <- runEC ecB
let spliter' = Part' comIOB snd (\(x, _) c -> (x, c)) $
Part' comIOA fst (\(_, x) c -> (c, x)) $ mkCon' (,)
case joinGuis (maybeToList guiA ++ maybeToList guiB) of
Nothing -> do a <- io $ pickGetVal comIOA
b <- io $ pickGetVal comIOB
guilessInnerEC "" (a, b)
Just (widget, gui) ->
do comIO <- makeCom spliter'
innerECWithGui comIO widget gui
-- |Joins two 'EC' to one.
join2 :: EC a -> EC b
-> (ComIO a -> ComIO b -> WxM())
-> EC (a, b)
join2 ecA ecB comIOFun = mkEC toInnerCom where
toInnerCom =
do (comIOA, guiA) <- runEC ecA
(comIOB, guiB) <- runEC ecB
comIOFun comIOA comIOB
let spliter' = Part' comIOB snd (\(x, _) c -> (x, c)) $
Part' comIOA fst (\(_, x) c -> (c, x)) $ mkCon' (,)
case joinGuis (maybeToList guiA ++ maybeToList guiB) of
Nothing -> do a <- io $ pickGetVal comIOA
b <- io $ pickGetVal comIOB
guilessInnerEC "" (a, b)
Just (widget, gui) ->
do comIO <- makeCom spliter'
innerECWithGui comIO widget gui
class Merge before after
| before -> after
where
merge :: before -> after
instance Merge (ComIO a, ComIO b) (WxM (ComIO (a, b))) where
merge (comIOA, comIOB) =
let spliter' = Part' comIOB snd (\(x, _) c -> (x, c)) $
Part' comIOA fst (\(_, x) c -> (c, x)) $ mkCon' (,)
in makeCom spliter'
instance Merge (InnerEC a, InnerEC b) (WxM (InnerEC (a, b))) where
merge (innerECA, innerECB) =
let spliter' = Part' (getComIO innerECB) snd (\(x, _) c -> (x, c)) $
Part' (getComIO innerECA) fst (\(_, x) c -> (c, x)) $ mkCon' (,)
in liftM guilessInnerEC' $ makeCom spliter'
instance Merge (EC a, EC b) (EC (a, b)) where
merge (ecA, ecB) = mkEC toInnerCom where
toInnerCom =
do (comIOA, guiA) <- runEC ecA
(comIOB, guiB) <- runEC ecB
let spliter' = Part' comIOB snd (\(x, _) c -> (x, c)) $
Part' comIOA fst (\(_, x) c -> (c, x)) $ mkCon' (,)
case joinGuis (maybeToList guiA ++ maybeToList guiB) of
Nothing -> do a <- io $ pickGetVal comIOA
b <- io $ pickGetVal comIOB
guilessInnerEC "" (a, b)
Just (widget, gui) ->
do comIO <- makeCom spliter'
innerECWithGui comIO widget gui
join3 :: (Typeable a, Typeable b, Typeable c, Data ctx (a, b, c))
=> Proxy ctx -> EC a -> EC b -> EC c -> (ComIO a -> ComIO b -> ComIO c -> IO())
-> EC (a, b, c)
join3 ctx ecA ecB ecC comIOFun = mkEC toInnerCom where
toInnerCom =
do (comIOA, widgetAndGuiA) <- runEC ecA
(comIOB, widgetAndGuiB) <- runEC ecB
(comIOC, widgetAndGuiC) <- runEC ecC
liftIO $ comIOFun comIOA comIOB comIOC
let spliter' = addPart' ctx comIOC $
addPart' ctx comIOB $
addPart' ctx comIOA $ mkCon' (,,)
case joinGuis (maybeToList widgetAndGuiA ++
maybeToList widgetAndGuiB ++
maybeToList widgetAndGuiC) of
Nothing -> do a <- io $ pickGetVal comIOA
b <- io $ pickGetVal comIOB
c <- io $ pickGetVal comIOC
guilessInnerEC "" (a, b, c)
Just (widget, gui) ->
do comIO <- makeCom spliter'
innerECWithGui comIO widget gui
mkCon' :: a -> Spliter' a m
mkCon' c = Constructor' c
addPart' :: (Data ctx b1, Typeable b) =>
Proxy ctx
-> ComIO b
-> Spliter' (b -> a) b1
-> Spliter' a b1
addPart' ctx comIO tc = -- tc = towardsConstructor
Part' comIO (getFieldFun ctx (depth' tc)) (setFieldFun ctx (depth' tc)) tc
depth' :: Spliter' a b -> Int
depth' (Constructor' _) = 0
depth' (Part' _ _ _ spliter) = 1 + depth' spliter