AutoForms-0.4.0: src/Graphics/UI/AF/WxForm/WxFormImplementation.hs
{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses
, OverlappingInstances, PatternSignatures, ScopedTypeVariables, RankNTypes
, TypeOperators, TypeSynonymInstances, UndecidableInstances #-}
-- |An implementation of the AutoForm class for WxHaskell
module Graphics.UI.AF.WxForm.WxFormImplementation
( module Graphics.UI.AF.WxForm.WxConstants
, module EC -- module Graphics.UI.AF.WxForm.EditorComponent
, ComH
, mkComProxy, makeEC, mkComI', ECCreator, ECCreatorD, ecCreatorCtx
, wxParentProxy
, SatCxt
, enumeration
)
where
{- mkfifo
http://wxhaskell.sourceforge.net/doc/Graphics.UI.WXCore.Process.html#v%3AprocessExecAsyncTimed
-}
import Graphics.UI.AF.WxForm.WxConstants
import Graphics.UI.AF.WxForm.EditorComponent as EC
import Graphics.UI.AF.WxForm.ComIO as EC
import Graphics.UI.AF.WxForm.GenericEC
import Graphics.UI.AF.WxForm.WxEnumeration
import qualified Graphics.UI.AF.General as AF
import Graphics.UI.AF.General.MySYB
import Graphics.UI.WX hiding ( command, label, value, entry, parent, Parent, items, enabled, close
, dialog, errorDialog, menu, stop)
import qualified Graphics.UI.WX as WX
import Graphics.UI.WXCore.Process(processExecAsyncTimed)
import Maybe
import qualified Control.Monad.State as St
import Control.Monad(liftM)
import qualified Graphics.UI.AF.WxForm.WxM as WxM
-- |Parameter for the Wx instance of AutoForm
type SatCxt = ECCreatorD
-- |A Parent type proxy
wxParentProxy :: WxM ()
wxParentProxy = error "Cannot be instantiated."
-- instance Closeable (Dialog a) where
-- close dialog = set dialog [ visible := False ]
type ComH = InnerEC
instance AF.AutoForm WxAct ComH WxM SatCxt EC where
defaultCom x = (makeECD dict) x
builderToCom = builderToCom'
addCom = mkComI'
state s = guilessInnerEC "" s
postponeAction = postponeAction'
button = buttonI'
addTimer = addTimer'
executeProcess = executeProcess'
limit test message ec = updateComIO ec helper where
helper comIO = do pickAddLimit comIO doTest
return comIO
doTest x = do accept <- test x
if accept
then return Accepted
else return $ Rejected message
label heading ec = updateLabel (bestLabel (PriLabel UserDefined heading)) ec
addListener wxAct innerEC
= do wxActToListenerM wxAct >>= io . addListener (getComIO innerEC)
return innerEC
command _ ec execute = startI "" $ AF.commandImpl ec execute
window com = subWindow com
-- blockingWindow :: ((Maybe b -> action ()) -> com a ())
-- -> action (Maybe b)
instance AF.Dialog WxAct ComH WxM SatCxt EC where
blockingWindow closeToEC =
do (Parent parent) <- getParentI
d <- liftIO $ WX.dialog parent [ resizeable := True ]
liftIO $ showModal d (\stop -> do let ec = closeToEC (\x -> do liftIO $ stop x)
(_, widAndGui) <- runWxM (runEC ec) parent (stop Nothing) parent
(lay, title) <- maybe nonEditableLayout (unboxedLayout . rootGui) (liftM snd widAndGui)
p <- panel d []
set p [ layout := lay ]
set d [ text := title ]
set d [ layout := dynamic $ fill $ widget p ]
return ()
)
----------------------------------------------------------------------------
------------------------------------------------------------------------------
-- |The dictionary type for the ECCreator class
data ECCreatorD a = ECCreatorD { makeECD :: MakeEC a
, mkComProxyD :: MakeEC a
, gToStringD :: a -> String
}
-- |Instantiation of the Sat class
instance ECCreator a => Sat (ECCreatorD a)
where dict = ECCreatorD { makeECD = makeEC
, mkComProxyD = mkComProxy
, gToStringD = gToString
}
-- |The context for generic autoform
ecCreatorCtx :: Proxy ECCreatorD
ecCreatorCtx = error "ecCreatorCtx"
-- |A more constrained generic function -- not needed anymore. But in the future?
-- makeEC' :: Data ECCreatorD a => GuiForm -> a -> IO (ComIO a)
-- makeEC' = makeECD dict
toString :: Sat (ECCreatorD a) => a -> String
toString x = (gToStringD dict) x
------------------------------------------------------------------------------
-- A problem with a default implementation is that it becomes hard to spilt
-- declaration from definition. For example, it would require circular dependencies
-- to put enumeration into its own module.
-- |Main class for generic construction of 'EC' - see also
-- 'genericEC'. Instantiate this class to make custom construction of
-- ECs.
class ( Data ECCreatorD a, AF.GInstanceCreator a, Show a
, AF.TypePresentation a WxAct ComH WxM ECCreatorD EC)
=> ECCreator a
where
mkComProxy :: MakeEC a
mkComProxy x = updateWxM (withMaxDepth (\d -> d-1)) (AF.mkCom x)
makeEC :: MakeEC a
makeEC x =
case enumerationFromType x of
Just ec -> ec
Nothing ->
case constrRep (toConstr ecCreatorCtx x) of
AlgConstr _ -> genericEC ecCreatorCtx (mkComProxyD dict) x
IntConstr _ -> entryForm ('-':['0'..'9']) "Int" x
FloatConstr _ -> entryForm ('-':'.':['0'..'9']) "Float" x
StringConstr [_] -> error "WxFormImplementation: Char not implemented yet" -- FIXME
StringConstr _ -> error "WxFormImplementation: No StringConstr constructors for other than Char."
where
-- widthFirstTraversal :: (ECCreator b) => b -> EC b ()
-- widthFirstTraversal = (mkComProxyD dict)
entryForm :: [Char] -> String -> MakeEC a
entryForm allowedChars label val = AF.builderToCom $
do Parent w <- getPanel
lastTextVal <- io $ varCreate ""
entry <- io $ textEntry w [ processEnter := True
, on anyKey := handleInput allowedChars
]
let gui = singleGui (badConstrLabel label) entry hfill
setGuiValue z = do set entry [ text := show z ]
varSet lastTextVal (show z)
-- We check whether the textEntry has changed outselves, as
-- we do not want Eq to be a superclass of ECCreator.
-- Thus we use `addCustomGuiNoEquals`.
(comH, parms) <- addCustomGuiNoEquals val setGuiValue entry gui
let getGuiVal = do textVal <- get entry text
let maybeConstr = readConstr (dataTypeOf ecCreatorCtx val) textVal
maybeX = maybeConstr >>= (Just . fromConstr ecCreatorCtx)
return maybeX
restore = pickGetVal (getComIO comH) >>= setGuiValue
let onFocus _ = do lastVal <- varGet lastTextVal
currentVal <- get entry text
when (lastVal /= currentVal) $
do varSet lastTextVal currentVal
getGuiVal >>= maybe restore (testInputParm' parms SetOnReject)
propagateEvent
io $ set entry [ on focus := onFocus ]
return comH
handleInput chars (KeyChar c)
= if c `elem` chars
then do propagateEvent
else return()
handleInput _ _ = propagateEvent
--------------------------------------------------------------------------------
enumerationFromType :: (ECCreator a) => a -> Maybe (EC a)
enumerationFromType x =
case constrRep (toConstr ecCreatorCtx x) of
AlgConstr _ -> do namesAndValues <- mapM enumConstr (constructors ecCreatorCtx x)
if length namesAndValues > 1
then return (enumeration typeName namesAndValues x)
else Nothing
IntConstr _ -> Nothing
FloatConstr _ -> Nothing
StringConstr _ -> Nothing
where
typeName = dataTypeName $ dataTypeOf ecCreatorCtx x
enumConstr constr = if numChildren' x constr > 0
then Nothing
else Just ( showConstr constr
, fromConstr ecCreatorCtx constr
, \y -> constr == toConstr ecCreatorCtx y
)
-- typeType is solely to satisfy the type checker.
numChildren' :: (ECCreator a) => a -> Constr -> Int
numChildren' typeType constr = ((numChildren typeType) . fromConstr ecCreatorCtx) constr
-- the first parameter is solely to satisfy the type checker.
numChildren :: (ECCreator a) => a -> a -> Int
numChildren _ y = sum $ gmapQ ecCreatorCtx (\_ -> 1) y
------------------------------------------------------------------------------
instance ECCreator Bool
instance ECCreator Int
instance ECCreator Char
instance ECCreator Float
instance ECCreator Double
{- trash:
removeQualifiers xs = reverse (takeWhile (/= '.') (reverse xs))
-}
---------------------------------------------------------------------------------
mkComI' :: EC a -> WxM (ComH a)
mkComI' x = do (comIO, maybeGui) <- runEC x
case maybeGui of
Just ((Widget wid), gui) -> addGui wid gui comIO
_ -> return $ guilessInnerEC' comIO
buttonI' :: String -> WxAct() -> WxM (ComH ())
buttonI' title act = helper >>= AF.addListener act
where helper =
do Parent p <- getPanel
comIO <- liftIO $ staticComIO ()
wid <- liftIO $ button p
[ text := title
, on WX.command := unsafeSignalChange comIO
]
let comIO' = comIO { pickSetEnabled = \enable -> do set wid [ WX.enabled := enable ]
pickSetEnabled comIO enable
}
addGui wid (Buttons $ widget wid) comIO'
-- FIXME: set parentwindow, ...
subWindow :: EC a -> WxAct ()
subWindow ec =
do (Parent parentWindow) <- getParentI
d <- io $ WX.dialog parentWindow [ resizeable := True ]
liftIO $ set d [ visible := True ]
let closeDialog = set d [ visible := False ]
io $ do
p <- panel d []
(_, widAndGui) <- runWxM (runEC ec) d closeDialog p
(lay, title) <- maybe nonEditableLayout (unboxedLayout . rootGui) (liftM snd widAndGui)
set p [ layout := lay ]
set d [ text := title ]
set d [ layout := dynamic $ fill $ widget p ]
addTimer' :: Int -> WxAct () -> WxM ()
addTimer' mili action =
do Parent parentWindow <- getFrame
actionIO <- wxActToListenerM action
io $ WX.timer parentWindow [ interval := mili
, on WX.command := unsafeRunListenerM actionIO
]
return ()
{-
Reading these two:
http://www.wxwidgets.org/manuals/stable/wx_wxinputstream.html#wxinputstreamcanread
http://www.wxwidgets.org/manuals/stable/wx_wxinputstream.html#wxinputstreameof
it seems that wxInputStream::Eof is the correct choice.
-- See http://sourceforge.net/mailarchive/message.php?msg_id=54647.129.16.31.149.1111686341.squirrel%40webmail.chalmers.se-- for problem about on-end-process (check also Process.hs example with "ls -l" and "tail -f Process.hs" -examples.
-}
executeProcess' :: String
-> (Int -> WxAct ())
-> (String -> WxAct ())
-> (String -> WxAct ())
-> WxM ()
executeProcess' command onEnd onStdOut onStdErr
= do Parent parentWindow <- getFrame
let setAction (local::(forall a. WxAct a -> ListenerM a))
= do processExecAsyncTimed parentWindow command True
(\exitCode -> local' $ onEnd exitCode)
(\msg _ -> local' $ onStdOut msg)
(\msg _ -> local' $ onStdErr msg)
return ()
where local' = unsafeRunListenerM . local
liftWxActToListenerM setAction
{- Menus
we need (Frame ()) in WxM to make it work, now we got just Window ().
Maybe this could just be part of the WxM-monad.
Pro: no need to tread variables though the monads
no need for yet another monad
Con: if the programmer forgets to call addMenu, the menu will be titleless
type MenuMonad a = St.StateT (Menu ()) IO a
addMenu :: String -> MenuMonad a -> WxM a
addMenu title menuMonad =
do pane <- io $ menuPane [text := title]
handles <- io $ St.evalStateT menuMonad pane
Parent parentWindow <- getFrame
io $ set parentWindow [ menuBar := [pane] ]
return handles
menuItem :: String -> WxAct() -> MenuMonad (ComIO ())
menuItem title action =
do pane <- St.get
item <- io $ WX.menuItem pane [ text := title ]
comIO <- liftIO $ staticComIO ()
return $ comIO { pickSetEnabled = \enable -> do set item [ WX.enabled := enable ]
pickSetEnabled comIO enable
}
subMenu :: String -> MenuMonad (ComIO ())
seperator :: MenuMonad ()
-}
{-
addMenu :: Menu (WxAct ())
-> WxM (WxAct ())
addMenu Menu name items =
do (comIO, Widget widget, gui) <- f
(panes, actions) <- liftM (concatSnd . unzip) $ mapM addSubMenu menu
io $ set window [ menuBar := panes ]
let setAction action (local::(forall b. WxM b -> IO b))
= WX.set window [ on (WX.menu $ AF.identity action) := applyAction comIO (AF.actionFun action) local
]
mapM_ liftIO' $ map setAction actions
io $ addListener comIO (updateEnabled comIO actions)
io $ updateEnabled comIO actions
return (comIO, Widget widget, gui)
where
concatSnd (x, ys) = (x, concat ys)
addSubMenu :: AF.SubMenu a state WxM.WxM String -> WxM (Menu(), [AF.Action a state WxM.WxM (MenuItem())])
addSubMenu (name, items) =
do pane <- io $ menuPane [text := name]
items' <- mapM (addItem pane) items
return (pane, concat items')
where
addItem :: Menu() -> AF.MenuItem a state WxM.WxM String -> WxM [AF.Action a state WxM.WxM (MenuItem())]
addItem pane (AF.Sub subMenu) =
do (subPane, actions) <- addSubMenu subMenu
io $ WX.menuSub pane subPane []
return actions
addItem pane (AF.MenuItem action) =
do item <- io $ WX.menuItem pane [ text := AF.identity action ]
return [action { AF.identity = item }]
addItem pane (AF.Seperator) =
do io $ WX.menuLine pane
return []
-}
{-
(comIO, Widget widget, gui) <- f
let setActions (local::(forall b. WxM b -> IO b))
= do -- (send,process,pid) <-
processExecAsyncTimed widget command True
(\exitCode -> applyAction comIO (onEnd exitCode) local)
(applyAction' local onStdOut) (applyAction' local onStdErr)
return ()
applyAction' local action str _ = applyAction comIO (action str) local
liftIO' setActions
return (comIO, Widget widget, gui)
-}