{-# 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