diff --git a/AutoForms.cabal b/AutoForms.cabal new file mode 100644 --- /dev/null +++ b/AutoForms.cabal @@ -0,0 +1,101 @@ +Name: AutoForms +Version: 0.4.0 +Copyright: Mads Lindstrøm +License: LGPL +License-file: COPYRIGHT.txt +Author: Mads Lindstrøm +Maintainer: Mads Lindstrøm +Homepage: http://autoforms.sourceforge.net/ +Category: GUI +Build-Depends: base,haskell98,mtl,template-haskell,wx,wxcore,syb-with-class>=0.4,array +Synopsis: GUI library based upon generic programming (SYB3) +Tested-with: GHC==6.8.1,GHC==6.8.2 +Stability: experimental +Description: + AutoForms is a library to ease the creation of Graphical User + Interfaces (GUI). It does this by using generic programming to + construct GUI components. + . + The AutoForms user creates an ordinary algebraic data type (ADT), + which should reflect the data model of an application. From this ADT + AutoForms automatically constructs a GUI component, by using the + structure and identifiers of the ADT. To facilitate this construction, + AutoForms uses the 'Scrap your boilerplate' approach to generic + programming. + . + This component can be displayed using WxHaskell or by an AutoForms + custom monad called WxM.. The first facilitates that people who + already knows WxHaskell quickly will be able to make GUIs. The second + is our attempt at a more type-safe and easier to use GUI toolkit. +Ghc-options: -O -Wall +Exposed-modules: + Graphics.UI.AF.PolyCommand + ,Graphics.UI.AF.General + ,Graphics.UI.AF.General.MySYB + ,Graphics.UI.AF.WxFormAll + ,Graphics.UI.AF.AFWx + ,Graphics.UI.AF.WxForm + ,Graphics.UI.AF.WxForm.WxList + ,Graphics.UI.AF.WxForm.ComIO + ,Graphics.UI.AF.CForm.CFormAll + ,Graphics.UI.AF.CForm.CForm + ,Graphics.UI.AF.CForm.CFormImplementation + +other-modules: + Control.Monad.RecursiveObserver + ,Control.Monad.Unlift + ,Graphics.UI.AF.General.AutoForm + ,Graphics.UI.AF.General.CustomTypes + ,Graphics.UI.AF.General.Dialog + ,Graphics.UI.AF.General.EditFile + ,Graphics.UI.AF.General.InstanceCreator + ,Graphics.UI.AF.General.Misc + ,Graphics.UI.AF.General.PriLabel + ,Graphics.UI.AF.WxForm.GenericEC + ,Graphics.UI.AF.WxForm.EditorComponent + ,Graphics.UI.AF.WxForm.GUI + ,Graphics.UI.AF.WxForm.WxConstants + ,Graphics.UI.AF.WxForm.WxEnumeration + ,Graphics.UI.AF.WxForm.WxFilePath + ,Graphics.UI.AF.WxForm.WxFormImplementation + ,Graphics.UI.AF.WxForm.WxM + ,Graphics.UI.AF.WxForm.WxMaybe +Extra-Source-Files: + src/Examples/Makefile + ,src/Examples/GhciGui/Makefile + ,src/Examples/HCron/Makefile + ,src/Examples/Misc/Makefile + + ,src/Examples/GhciGui/Options.hs + ,src/Examples/GhciGui/GhciGui.hs + ,src/Examples/GhciGui/GhcProcess.hs + ,src/Examples/GhciGui/Protocol.hs + ,src/Examples/GhciGui/ECOptions.hs + ,src/Examples/GhciGui/WxMultilinePerformanceTest.hs + ,src/Examples/HCron/Entry2ndRecurring.hs + ,src/Examples/HCron/Editor4thRecurring.hs + ,src/Examples/HCron/Daemon2ndRecurring.hs + ,src/Examples/HCron/Entry1st.hs + ,src/Examples/HCron/Editor2nd.hs + ,src/Examples/HCron/Daemon1st.hs + ,src/Examples/HCron/Editor1st.hs + ,src/Examples/HCron/Editor3rdLimit.hs + ,src/Examples/HCron/Editor5thOutputWindow.hs + ,src/Examples/HCron/Editor6thCrontab.hs + ,src/Examples/HCron/Entry3rdCrontab.hs + ,src/Examples/HCron/Run.hs + ,src/Examples/Misc/Person.hs + ,src/Examples/Misc/PersonTest.hs + ,src/Examples/Misc/AlbumEditor.hs + ,src/Examples/Misc/NonModalDialogTest.hs + ,src/Examples/Misc/WxEmbedded.hs + ,src/Examples/Misc/EmbeddedTree.hs + ,src/Examples/Misc/AlbumDTD.hs + ,src/Examples/Misc/Grep.hs + ,src/Examples/Misc/RecursiveUpdates.hs + ,src/Examples/Misc/AFWxExample.hs + ,src/Examples/Misc/MVCExample.hs + ,src/Examples/Misc/SettingsForm.hs +Extensions: +hs-source-dirs: src + diff --git a/COPYRIGHT.txt b/COPYRIGHT.txt new file mode 100644 --- /dev/null +++ b/COPYRIGHT.txt @@ -0,0 +1,20 @@ +AutoForms - A library to ease the constructions of user interfaces. + +Copyright (C) 2006 Mads Lindstrøm + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Lesser General Public +License as published by the Free Software Foundation; either +version 2.1 of the License, or (at your option) any later version. + +This library is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Lesser General Public License for more details. + +You should have received a copy of the GNU Lesser General Public +License along with this library; if not, write to the Free Software +Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA + + +The author can be contacted at mads_lindstroem@yahoo.dk diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,4 @@ +#! /usr/bin/runhaskell + +> import Distribution.Simple +> main = defaultMain diff --git a/src/Control/Monad/RecursiveObserver.hs b/src/Control/Monad/RecursiveObserver.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/RecursiveObserver.hs @@ -0,0 +1,208 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} + +{- | + +The RecursiveObserver transformer (RecursiveObserverT) monad and the +Observable type class, can be used to connect a network of observable +objects and listeners (observers). The network may be recursive. When +desired events can be transmitted though the network. + +By using an Event-ID it is ensured that objects call their listeners +at most once per invocation of the network. The functions +runRecursiveObserverT and runRecursiveObserverTWithNewEID are used to +execute a new invocation of the network. + +Each listener should be using the RecursiveObserverT monad transformer. + +Each observable object should be instance of the Observable type class. + +It is the responsibility of the user of +Control.Monad.RecursiveObserver that runRecursiveObserverT and +runRecursiveObserverTWithNewEID is only called when approiate. If he +is not carefull with this, he can accidently create eternal recursion. + +_Usage of RecursiveObserver_ + +To use this library you should create an EventID like: + +> newtype EventID = EventID Int +> deriving (Random.Random, Show, Eq) + +and Listener which contains RecursiveObserverT like: + +> newtype Listener a = Listener { listener' :: RecursiveObserverT EventID IO a } +> deriving (Monad, MonadIO, MonadEvent, Observable (ComIO b), Observable OnChangeVar) + +Make sure you do not export the Listener constructor. By doing this +you control when new invocations of the network is started. + +Next you should make the observable objects, in the network, instances +of Observable. Use the whenNotVisitedHelper, visitHelper, and +signalChangeHelper -functions to do this. You should also implement +some way of attaching listeners to the objects. + +Finally, implement some way of doing controlled invocations of the +network. + +_Alternative way to handling recursive observer/observable networks_ + +In some uses of observer/observable networks each observable object +contains some value. And we want to call all listeners when an +observable object changes its value. Also imagine that each observable +object has a setVal (:: a -> IO()) action, which when called changes +the value of the object. + +Under these circumstances we could, each time setVal was called, check +if the new value differed from the last value and if it did signal all +its listeners. In this way we could avoid threading an EventID around. + +However, we choose not to use this approch as: + +* It requires that each observable object has some value. + +* That the value implements Eq. This may work fine for most data + types, but particularly data types containing functions cannot + implement Eq. + +* The comparison operation will scale linear with respect to the data + types size, whereas the EventID approch has constant time + complexity. + +* The user could accidently make eternal recursion, if the network + never diverges to some value. + +* We may get into trouble with rounding errors. Imagine an exchange + rate calculator from Dollars to Euros. Both values are represented + as doubles. When we change the Dollar widget the Euros widget gets + update, and vice versa. Let say the rate = 0.69056. And we type 127 + into the Euro-widget. Now the dollar widget is update to 127 * + rate. The changing Dollar widget will update the Euro widget with + 127 * rate / rate = 126.99999999999! Why? because of an rounding + error. + +** The same problem can exist with RecursiveObserver. However, by + using: whenNotVisited updateOtherWidget, we can avoid the problem. + +-} + +module Control.Monad.RecursiveObserver + ( -- * Listener transformer + ListenerT + , MonadListener(..) + -- ** Invocating the network + , runListenerT, runListenerTWithNewEID + -- * Observable class + , Observable(..) + -- ** Functions used to help construct Observable instances + , whenNotVisitedHelper, visitHelper, signalChangeHelper + ) +where + +import Random(randomIO, Random) + +import Control.Monad.Reader +import Control.Monad.Writer +import Control.Monad.Unlift + +-- We cannot newtype derive as the definition of ListenerT contains +-- other ListenerT-s. +newtype ListenerT eid m a = + ListenerT { listenerT' :: ReaderT eid (WriterT [ListenerT eid m ()] m) a } + +-- | Invokes the oberver/observable network, using a user supplied event-id. +runListenerT :: (Monad m) => eid -> ListenerT eid m a -> m a +runListenerT eid m = + do (a, w) <- runWriterT $ runReaderT (listenerT' m) eid + mapM_ (\eventT -> runListenerT eid eventT) w + return a + +-- | Invokes the oberver/observable network, using a random event-id. +-- This is a bit of a copout, as we can then get the same event-id +-- twice. On the other hand, chances are small if we choose an +-- event-id type with a large set of possible values. +-- +-- If this behavior is unacceptable use `runListenerT` and together +-- with a counter (like counterFun :: IO Int). +runListenerTWithNewEID :: (Monad m, MonadIO m, Random eid) => + ListenerT eid m a + -> m a +runListenerTWithNewEID oc = + do eid <- liftIO randomIO + runListenerT eid oc + +getEID :: (Monad m) => ListenerT eid m eid +getEID = ListenerT ask + +{- --------- MonadListener class --------- -} + +class (Monad m) => MonadListener m where + postponeEvent :: m () -> m () + +instance Monad m => MonadListener (ListenerT eid m) where + postponeEvent event = ListenerT $ tell [event] + +instance MonadListener m => MonadListener (ReaderT r m) where + postponeEvent e = unlift e >>= lift . postponeEvent + +instance (Monoid w, MonadListener m) => MonadListener (WriterT w m) where + postponeEvent e = unlift e >>= lift . postponeEvent + +{- --------- Observable class --------- -} + +class (MonadListener m) => Observable o m where + -- | Executes a monad if the observable object has not already been visited + whenNotVisited :: o -- ^Object to ask + -> m () -- ^Monad to execute if the object has not been visited + -> m () + -- | Mark an observable object as visited + visit :: o -> m () + -- | Tell an object to executes its listeners (observers) + signalChange :: o -> m () + +instance (Monad m, Observable o m) => Observable o (ReaderT r m) where + whenNotVisited o action = unlift action >>= lift . whenNotVisited o + visit o = lift $ visit o + signalChange = lift . signalChange + +instance (Monoid w, Monad m, Observable o m) => Observable o (WriterT w m) where + whenNotVisited o action = unlift action >>= lift . whenNotVisited o + visit o = lift $ visit o + signalChange = lift . signalChange + +whenNotVisitedHelper :: (Eq eid, Monad m) => + (o -> ListenerT eid m eid) + -> o + -> ListenerT eid m () + -> ListenerT eid m () +whenNotVisitedHelper getEventID o action = + do currentEID <- getEventID o + calleeEID <- getEID + when (calleeEID /= currentEID) action + +visitHelper :: (Monad m) => + (t -> eid -> m a) + -> t + -> ListenerT eid m a +visitHelper setEventID o = + do calleeEID <- getEID + lift $ setEventID o calleeEID + +signalChangeHelper :: (Observable o t) => + (o -> t ()) + -> o + -> t () +signalChangeHelper signalAllListeners o = postponeEvent (whenNotVisited o signal) + where signal = do visit o + signalAllListeners o + +-- Common monad instances + +instance (Monad m) => Monad (ListenerT eid m) where + return x = ListenerT $ return x + m >>= k = ListenerT (listenerT' m >>= listenerT' . k) + +instance MonadIO m => MonadIO (ListenerT eid m) where + liftIO = ListenerT . liftIO + +instance MonadTrans (ListenerT eid) where + lift = ListenerT . lift . lift diff --git a/src/Control/Monad/Unlift.hs b/src/Control/Monad/Unlift.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Unlift.hs @@ -0,0 +1,21 @@ +-- | Dual to Control.Monad.Trans +module Control.Monad.Unlift + ( Unlift(..) + ) +where + +import Control.Monad.Reader +import Control.Monad.Writer + +class Unlift t where + unlift :: (Monad m) => t m a -> t m (m a) + +instance Unlift (ReaderT r) where + unlift e = do r <- ask + return (runReaderT e r) + +instance (Monoid w) => Unlift (WriterT w) where + unlift e = do return $ (runWriterT e >>= return . fst) + + + diff --git a/src/Examples/GhciGui/ECOptions.hs b/src/Examples/GhciGui/ECOptions.hs new file mode 100644 --- /dev/null +++ b/src/Examples/GhciGui/ECOptions.hs @@ -0,0 +1,25 @@ +{-# OPTIONS -fallow-undecidable-instances #-} +{-# OPTIONS -fglasgow-exts #-} +{-# OPTIONS -fth #-} + +-- FIXME: Change OPTIONS pragmas to LANGUAGE pragmas + +module ECOptions where + +import Options +import Graphics.UI.AF.WxFormAll + +$(derive [''Options]) + +-- Below is to satisfy GHC 6.6. It is not neccesary in GHC 6.8. +instance ECCreator Options + + +{- Old trash + +{-# OPTIONS -fno-warn-missing-signatures #-} +{-# OPTIONS -fno-warn-unused-matches #-} +{-# OPTIONS -fno-warn-incomplete-patterns #-} + +-- The last three -fno-warn-... are because of the $(derive) below. +-} diff --git a/src/Examples/GhciGui/GhcProcess.hs b/src/Examples/GhciGui/GhcProcess.hs new file mode 100644 --- /dev/null +++ b/src/Examples/GhciGui/GhcProcess.hs @@ -0,0 +1,181 @@ +{- This module was inspired by: + +http://haskell.org/sitewiki/images/5/51/Interactive.hs and +http://haskell.org/haskellwiki/GHC/As_a_library + +-} + +module GhcProcess where + +import qualified Protocol as P +import qualified Options as Opt + +import qualified GHC as GHC +import qualified Outputable as GHC +import qualified PackageConfig as GHC +import qualified DynFlags as GHC +import qualified Panic as GHC +import qualified Distribution.InstalledPackageInfo as GHC +import qualified UniqFM as GHC + +import Control.Concurrent +import Control.Concurrent.Chan +import Network +import System.IO +import System +import Monad (when) +import System.Time + +-- import qualified Packages as GHC +-- import qualified ErrUtils as GHC + +-- Should'n we do: main = defaultErrorHandler defaultDynFlags $ do + +main :: IO() +main = do clearLog + withSocketsDo startSession + `catch` (\e -> do myLog (show e) + return () + ) + +startSession :: IO () +startSession = + do request <- getArgs + (ghcPath, outPort, inPort) <- readIO $ head request + -- + session <- initializeSession ghcPath + logPkgDB session + -- + myLog ("Read port numbers: " ++ show (outPort, inPort)) + inHandle <- connectTo "localhost" (PortNumber $ fromInteger inPort) + myLog ("Connected to inPort") + outHandle <- connectTo "localhost" (PortNumber $ fromInteger outPort) + myLog ("Connected to outPort") + P.setIsExecuting outHandle False + f <- hGetContents inHandle + let reply :: (Show s) => s -> IO() + reply s = do hPutStrLn inHandle $ show s + hFlush inHandle + insertIO <- channeledIO outHandle + myLog ("Ready to recieve commands") + mapM_ (execCommand session insertIO reply) $ lines f + return () + + +myLog :: String -> IO () +myLog msg = appendFile "log" (msg ++ "\n") + +clearLog :: IO () +clearLog = do t <- getClockTime + writeFile "log" ("Initiating log at " ++ (show t) ++ "\n") + +putError :: String -> IO () +putError msg = hPutStr stderr msg + +putMsg :: String -> IO () +putMsg msg = putStr msg + +execCommand :: GHC.Session + -> (IO () -> IO t) + -> (Opt.Options -> IO ()) + -> String + -> IO () +execCommand session insertIO reply cmd = + do cmd' <- readIO cmd + case cmd' of + P.Exec stmt -> do myLog $ show stmt ++ " ... " + insertIO $ evalStmt session stmt + myLog $ "finished.\n" + P.Kill -> do threads <- readMVar GHC.interruptTargetThread + hPutStrLn stderr ("Debug output. Threads: " ++ show threads) + killThread $ head threads + P.GetOptions -> do dynFlags <- GHC.getSessionDynFlags session + reply $ Opt.ghcflagsToOptions dynFlags + P.SetOptions userFlags -> + do dynFlags <- GHC.getSessionDynFlags session + userFlags' <- readIO userFlags + GHC.setSessionDynFlags session $ Opt.setOptions userFlags' dynFlags + return () + +evalStmt :: GHC.Session -> String -> IO () +evalStmt session stmt | take 4 stmt == ":set" + = do dynFlags <- GHC.getSessionDynFlags session + (newFlags, unknownArgs) <- GHC.parseDynamicFlags dynFlags (words $ drop 4 stmt) + GHC.setSessionDynFlags session newFlags + hPutStrLn stderr $ "Unrecognized flags: " ++ unlines unknownArgs + hFlush stderr + | otherwise = execStmt session stmt + +execStmt :: GHC.Session -> String -> IO () +execStmt session stmt = + do result <- GHC.runStmt session stmt GHC.RunToCompletion + GHC.runStmt session "hFlush stdout >> hFlush stderr" GHC.RunToCompletion + case result of + GHC.RunOk names -> putMsg ("*** Ok: " ++ showNames names ++ "\n") + GHC.RunFailed -> putError "*** Failed\n" + GHC.RunException e -> putError ("*** Exception: " ++ (show e) ++ "\n") + hFlush stdout >> hFlush stderr + + +channeledIO :: Handle -> IO (IO t -> IO ()) +channeledIO outHandle = + do ioChan <- newChan + let readAndExec = do isEmpty <- isEmptyChan ioChan + when isEmpty (P.setIsExecuting outHandle False) + ioAction <- readChan ioChan + P.setIsExecuting outHandle True + ioAction + readAndExec + insertIO io' = do writeChan ioChan io' + forkIO $ readAndExec + return insertIO + +-- If GHC.runStmt returns GHC.RunOk names then names is a list +-- of the names of all variables that were bound during evaluation. +-- This function somehow manages to pretty-print such a list. +showNames :: [GHC.Name] -> String +showNames = GHC.showSDoc . GHC.ppr + +logPkgDB :: GHC.Session -> IO () +logPkgDB session = + do flags <- GHC.getSessionDynFlags session + let pkgName pkg = "Package: " ++ (GHC.pkgName $ GHC.package pkg) ++ "\n" ++ + "Copyright: " ++ GHC.copyright pkg ++ "\n" ++ + "Haddock HTML: " ++ (show $ GHC.haddockHTMLs pkg) + handleUniqFM uniqFM = do myLog $ "Number of elements" ++ show (length $ GHC.ufmToList uniqFM) + mapM_ (myLog . pkgName) $ GHC.eltsUFM uniqFM + maybe (myLog "Pkg DB: Nothing") handleUniqFM (GHC.pkgDatabase flags) + +initializeSession :: String -> IO GHC.Session +initializeSession ghcPath = + do session <- GHC.newSession (Just ghcPath) + + dynFlags <- GHC.getSessionDynFlags session + GHC.setSessionDynFlags session dynFlags{GHC.hscTarget=GHC.HscInterpreted} + + prelude <- GHC.findModule session (GHC.mkModuleName "Prelude") Nothing + systemIO <- GHC.findModule session (GHC.mkModuleName "System.IO") Nothing + GHC.setContext session [] [ prelude, systemIO ] + + return session + +{- GHC.log_action logs error messages from compilation failure: + let myLogAction _ locSpec style errMsg = hPutStrLn stderr ("Checkpoint charlie: " ++ showMsg) where + showMsg = GHC.showSDoc $ GHC.withPprStyle style $ GHC.mkLocMessage locSpec errMsg + dflags1 = dflags0 { GHC.log_action = myLogAction } +-} +{- + -- Loading modules: + -- 1) For example loading MyPrelude.hs + target <- GHC.guessTarget "MyPrelude.hs" Nothing + GHC.addTarget session target + -- this would unload the standard prelude if it had already been loaded + GHC.load session GHC.LoadAllTargets + + -- 2) We need to load the standard prelude (I think), because of + -- "GHC.load seesion..." unloaded the prelude. + let preludeModule = GHC.mkModule (GHC.stringToPackageId "base") (GHC.mkModuleName "Prelude") + systemIOModule <- GHC.findModule session (GHC.mkModuleName "System.IO") Nothing + GHC.setContext session [] [preludeModule, systemIOModule] +-} + diff --git a/src/Examples/GhciGui/GhciGui.hs b/src/Examples/GhciGui/GhciGui.hs new file mode 100644 --- /dev/null +++ b/src/Examples/GhciGui/GhciGui.hs @@ -0,0 +1,116 @@ +{-# OPTIONS -fglasgow-exts #-} +{-# OPTIONS -Wall #-} + +-- FIXME: Change OPTIONS pragmas to LANGUAGE pragmas + +module GhciGui where + +import Graphics.UI.AF.WxFormAll +import qualified Protocol as P +import ECOptions() + +import System(getArgs) +import System.IO (Handle, hPutStrLn, stderr) +import Network (Socket, accept, withSocketsDo) + +main :: IO() +main = do args <- getArgs + case args of + [ghcPath] -> startGui ghcPath `catch` (\e -> hPutStrLn stderr $ "Exception raised: " ++ show e) + _ -> do putStrLn "ghcGui " + putStrLn "And your PATH=" + where startGui ghcPath = withSocketsDo $ + do (inSocket, inPortNumber) <- P.listenOnRandomPort 10 + (outSocket, outPortNumber) <- P.listenOnRandomPort 10 + (runAF $ mainWindow ghcPath inSocket inPortNumber outSocket outPortNumber) + + +data GuiState = + GuiState { inHandle :: Handle + , outHandle :: Handle + , isExecuting :: Bool + } + +mainWindow :: String -> Socket -> Int -> Socket -> Int -> WxM() +mainWindow ghcPath inSocket inPortNumber outSocket outPortNumber + = do window menus + $ addTimer 200 updateState + $ addButtons buttons + $ comStateM state component + + where + -- It is important to "hide" away the outputArea (the sndCom bit), so that we not risk + -- calling pickGetVal on it, as it will ruin performance. + -- Maybe we just need to make pickGetVal lazy in the AutoForms library :) + component = sndCom $ join outputArea inputArea + inputArea = giveFocus $ multiLineEC "" + outputArea = noValue $ label "Output" $ startGhcProcess $ multiLineEC "" + + state = do (inHandle', _, _) <- io $ accept inSocket + (outHandle', _, _) <- io $ accept outSocket + return $ constState $ GuiState inHandle' outHandle' False + startGhcProcess = executeProcess ("./GhcProcess " ++ show (ghcPath, inPortNumber, outPortNumber)) + onEnd doOutput doError where + doOutput str = do appendVal (str ++ "\n") -- have to make a newline, otherwise WxHaskell gets really slow + -- on large data series. + doError str = do appendVal ("Error: " ++ str ++ "\n") + onEnd exitCode = do errorDialog "Error" ("The GhcProcess failed with exit code: " ++ show exitCode) + closeWindow + updateState + = do s <- getState + executing <- io $ P.isExecuting $ inHandle s + maybe (return ()) (\x -> setState s { isExecuting = x }) executing + + menus = [ ("&File", [ MenuItem optionsAction + , MenuItem quitAction + ] + ) + , ("&Help", [ MenuItem $ alwaysEnabled "&About" $ infoDialog "GHCi GUI" aboutText + ] + ) + ] + where + aboutText = unlines [ "GHCi GUI made with AutoForms." + , "" + , "The program was made by Mads Lindstrom." -- FIXME: should use real ø + , "" + , "See http://autoforms.sourceforge.net" + ] + optionsAction = alwaysEnabled "&Options..." $ + do options <- doInGhc P.getOptions + maybeNewOptions <- lift $ blockingSettingsDialog (mkCom options) + maybe (return()) (doInGhc . P.setOptions) maybeNewOptions + + buttons = [killButton, exec, quitAction] where + killButton + = Action "&Cancel" (\_ s -> isExecuting s) $ doInGhc P.kill + exec = alwaysEnabled "&Exec" $ + do stmt <- getVal + doInGhc (P.executeStmt stmt) + doInGhc cmd = do s <- getState + io $ cmd $ outHandle s + + + +{- Design rationale: Why the seperate GhcProcess? + +* It seems to be the only cross-platform way. "GHC as a library" + writes directly to stdout. Thus we need to capture this output. It + could be done using System.Posix, but that is Unix-only. Also see + http://www.mail-archive.com/glasgow-haskell-users@haskell.org/msg12000.html + +* We can then, in the future, have multiply GhcProcesses. We can not + do that without a seperate process, as "GHC as a library" is a one + session-per-process design - as far as I know. + +* Good seperation between GUI and "GHC as a library". + +* I had major problems with deadlocks, and stronger seperation between + GUI and "GHC as a library" helped me pinpoint where the problem was + located. + +* WxHaskell is not multi-threaded. Thus if we want a responsive GUI + (and we do), then we need to use processExecAsyncTimed, which starts + another process. See http://wxhaskell.sourceforge.net/faq.html + +-} diff --git a/src/Examples/GhciGui/Makefile b/src/Examples/GhciGui/Makefile new file mode 100644 --- /dev/null +++ b/src/Examples/GhciGui/Makefile @@ -0,0 +1,39 @@ +HC = ghc +HC_MAKE = $(HC) --make $< -o $@ -main-is $(notdir $@) $(HC_OPTIONS) -package ghc +SCREENSHOT_DIR = $(CURDIR)/../../../website/ + +EXAMPLES = GhciGui GhcProcess + +%: %.hs + $(HC_MAKE) + +GhciGui:GhciGui.hs Options.hs Protocol.hs ECOptions.hs +GhcProcess:GhcProcess.hs Options.hs Protocol.hs + +.PHONY: clean all no_screenshots + +all:$(EXAMPLES) + +clean: + - rm *.hi *.o *~ $(EXAMPLES) + +define makeScreenshot + echo "Doing $(1) screenshot" + ./$(1) & + sleep 2 && import -frame -window $(2) $(SCREENSHOT_DIR)$(1)Screenshot.png + killall $(1) +endef + +no_screenshots: all + $(call makeScreenshot,Grep,"Grep") + $(call makeScreenshot,GrepText,"AutoForms") + killall Grep + $(call makeScreenshot,SettingsForm,"Settings") + $(call makeScreenshot,WxEmbedded,"Counter") + $(call makeScreenshot,ExtendedCounter,"My Extended Counter") + $(call makeScreenshot,MVCExample,"Alarm") + $(call makeScreenshot,EmbeddedTree,"Embedded Tree") + $(call makeScreenshot,AlbumEditor,"Album") + + +# -iExamples/GhciGui -fglasgow-exts -fth diff --git a/src/Examples/GhciGui/Options.hs b/src/Examples/GhciGui/Options.hs new file mode 100644 --- /dev/null +++ b/src/Examples/GhciGui/Options.hs @@ -0,0 +1,49 @@ +module Options where + +import qualified GHC as GHC +import qualified DynFlags as GHC +import List( (\\) ) + +data Options = Options + { allowOverlappingInstances :: Bool + , allowIncoherentInstances :: Bool -- FIXME: implies overlapping instances + , allowUndecidableInstances :: Bool + , contextStackDepth :: Int + , arrows :: Bool + , generics :: Bool + , monomorphismRestriction :: Bool + } deriving (Eq, Show, Read) + +ghcflagsToOptions :: GHC.DynFlags -> Options +ghcflagsToOptions ghcFlags = + Options { allowOverlappingInstances = isSet GHC.Opt_OverlappingInstances + , allowIncoherentInstances = isSet GHC.Opt_IncoherentInstances + , allowUndecidableInstances = isSet GHC.Opt_UndecidableInstances + , contextStackDepth = GHC.ctxtStkDepth ghcFlags + , arrows = isSet GHC.Opt_Arrows + , generics = isSet GHC.Opt_Generics + , monomorphismRestriction = isSet GHC.Opt_MonomorphismRestriction + } + where + isSet flag = elem flag (GHC.flags ghcFlags) + +setOptions :: Options -> GHC.DynFlags -> GHC.DynFlags +setOptions options dynFlags = + let mapping = + [ (allowOverlappingInstances, GHC.Opt_OverlappingInstances) + , (allowIncoherentInstances, GHC.Opt_IncoherentInstances) + , (allowUndecidableInstances, GHC.Opt_UndecidableInstances) + , (arrows, GHC.Opt_Arrows) + , (generics, GHC.Opt_Generics) + , (monomorphismRestriction, GHC.Opt_MonomorphismRestriction) + ] + include opt (optionF, ghcOption) = + if optionF opt + then [ghcOption] + else [] + compileOptions = map (include options) mapping + removeFlags = GHC.flags dynFlags \\ map snd mapping + in dynFlags { GHC.flags = concat (removeFlags:compileOptions) + , GHC.ctxtStkDepth = contextStackDepth options + } + diff --git a/src/Examples/GhciGui/Protocol.hs b/src/Examples/GhciGui/Protocol.hs new file mode 100644 --- /dev/null +++ b/src/Examples/GhciGui/Protocol.hs @@ -0,0 +1,63 @@ +module Protocol where + +import System.IO +import Options +import Network (PortID(..), Socket, listenOn) +import System.Random (randomRIO) + +data Protocol + = Exec String + | Kill + | GetOptions + | SetOptions String + deriving (Show, Read) + +put :: Handle -> Protocol -> IO() +put handle msg + = do hPutStrLn handle $ show msg + hFlush handle + +get :: (Read a) => Handle -> IO a +get handle = hGetLine handle >>= readIO + +{- From GUI-API -} + +isExecuting :: Handle -> IO (Maybe Bool) +isExecuting handle + = do x <- hReady handle + case x of + False -> return Nothing + True -> do msg <- hGetLine handle + readIO msg >>= return . Just + +kill :: Handle -> IO () +kill handle + = do put handle Kill + +getOptions :: Handle -> IO Options +getOptions handle + = do put handle GetOptions + get handle + +setOptions :: Options -> Handle -> IO () +setOptions options handle + = do put handle $ SetOptions $ show options + +executeStmt :: String -> Handle -> IO () +executeStmt stmt handle + = do put handle $ Exec stmt + +{- From GHCProcess to GUI -} +setIsExecuting :: Handle -> Bool -> IO() +setIsExecuting handle is = do hPutStrLn handle $ show is + hFlush handle + +listenOnRandomPort :: Int -- ^ Number of tries + -> IO(Socket, Int) +listenOnRandomPort 0 = error "Could not establish socket connection" +listenOnRandomPort tries = tryGetSocket `catch` tryAgain where + tryGetSocket = do port <- randomRIO (16384, 65535) + socket <- listenOn (PortNumber $ fromIntegral port) + return (socket, port) + tryAgain _ = listenOnRandomPort (tries-1) + diff --git a/src/Examples/GhciGui/WxMultilinePerformanceTest.hs b/src/Examples/GhciGui/WxMultilinePerformanceTest.hs new file mode 100644 --- /dev/null +++ b/src/Examples/GhciGui/WxMultilinePerformanceTest.hs @@ -0,0 +1,17 @@ + +module WxMultilinePerformanceTest where + +-- ghc --make WxMultilinePerformanceTest.hs -main-is WxMultilinePerformanceTest + +import Graphics.UI.WX + +main = start $ + do f <- frame [ text := "MyWindow" ] + tc <- textCtrl f [ processEnter := True + , wrap := WrapNone + ] + timer f [ interval := 150 + , on command := appendText tc $ show [1..10] + ] + set f [ layout := fill $ widget tc ] + diff --git a/src/Examples/HCron/Daemon1st.hs b/src/Examples/HCron/Daemon1st.hs new file mode 100644 --- /dev/null +++ b/src/Examples/HCron/Daemon1st.hs @@ -0,0 +1,50 @@ +module Daemon1st where + +import List(sort) +import System(system) +import Control.Concurrent(threadDelay) + +import Entry1st + +main = do putStrLn "The HCron daemon" + spec <- readFile specLocation + calTime <- getCalendarTime + (TOD currentSecondsSinceEpoch _) <- getClockTime + let entries = (read spec)::[Entry Time] + entries' = filter isNew $ map toSeconds (sort entries) + isNew (Entry t _) = t > currentSecondsSinceEpoch + toSeconds x = x { when = timeToSeconds calTime (when x) } + putStrLn "Successfully read entries. Starting daemon." + putStrLn $ unlines $ map show entries + putStrLn "After pruning:" + putStrLn $ unlines $ map show entries' + daemon entries' + +daemon :: [Entry Integer] -> IO() +daemon [] = return () +daemon ((Entry time command'):xs) = + do (TOD clockTime _) <- getClockTime + delaySeconds $ max 0 (time - clockTime) + system command' + daemon xs + +getCalendarTime :: IO CalendarTime +getCalendarTime = + do clockTime <- getClockTime + toCalendarTime clockTime + +timeToSeconds :: CalendarTime -> Time -> Integer +timeToSeconds calTime t = + let t' = calTime { ctYear = year t, ctMonth = month t, ctDay = day t + , ctHour = hour t, ctMin = minute t, ctSec = 0, ctPicosec = 0 } + (TOD time _) = (toClockTime t') + in time + +delaySeconds :: Integer -> IO () +delaySeconds seconds = delayMicro (seconds * 1) -- FIXME: multiple by 10^6 + where + delayMicro ms | ms <= 0 = return () + | otherwise = do let d = min (toInteger (maxBound::Int)) ms + print (d `div` 10^6) + threadDelay (fromInteger d) + delayMicro (ms - d) diff --git a/src/Examples/HCron/Daemon2ndRecurring.hs b/src/Examples/HCron/Daemon2ndRecurring.hs new file mode 100644 --- /dev/null +++ b/src/Examples/HCron/Daemon2ndRecurring.hs @@ -0,0 +1,64 @@ +module Daemon2ndRecurring where + +import List(sort, insert) +import System(system) +import Control.Concurrent(threadDelay) +import Maybe(mapMaybe) + +import Entry2ndRecurring + +main = do putStrLn "The HCron daemon" + spec <- readFile specLocation + calTime <- getCalendarTime + (TOD currentSecondsSinceEpoch _) <- getClockTime + let entries = (read spec)::[Entry Time] + entries' = sort $ mapMaybe renewAndPrune $ map toSeconds entries + renewAndPrune e@(Entry t recur _) = + case (t > currentSecondsSinceEpoch, recur) of + (True, _) -> Just e + (False, Nothing) -> Nothing + (False, Just (TimeDiff 0 0 0 0 0 0 0)) -> Nothing + (False, Just recur') -> renewAndPrune $ addTimeDiff recur' e + toSeconds x = x { when = timeToSeconds calTime (when x) } + putStrLn "Successfully read entries. Starting daemon." + putStrLn $ unlines $ map show entries + putStrLn "After pruning:" + putStrLn $ unlines $ map show entries' + daemon entries' + +daemon :: [Entry Integer] -> IO() +daemon [] = return () +daemon (x@(Entry time recur command'):xs) = + do (TOD clockTime _) <- getClockTime + delaySeconds $ max 0 (time - clockTime) + system command' + let xs' = case recur of + Nothing -> xs + Just recur' -> insert (addTimeDiff recur' x) xs + daemon xs' + +addTimeDiff :: TimeDiff -> Entry Integer -> Entry Integer +addTimeDiff diff e = e { when = let (TOD t _ ) = addToClockTime diff (TOD (when e) 0) + in t + } + +getCalendarTime :: IO CalendarTime +getCalendarTime = + do clockTime <- getClockTime + toCalendarTime clockTime + +timeToSeconds :: CalendarTime -> Time -> Integer +timeToSeconds calTime t = + let t' = calTime { ctYear = year t, ctMonth = month t, ctDay = day t + , ctHour = hour t, ctMin = minute t, ctSec = 0, ctPicosec = 0 } + (TOD time _) = (toClockTime t') + in time + +delaySeconds :: Integer -> IO () +delaySeconds seconds = delayMicro (seconds * 1) -- FIXME: multiple by 10^6 + where + delayMicro ms | ms <= 0 = return () + | otherwise = do let d = min (toInteger (maxBound::Int)) ms + print (d `div` 10^6) + threadDelay (fromInteger d) + delayMicro (ms - d) diff --git a/src/Examples/HCron/Editor1st.hs b/src/Examples/HCron/Editor1st.hs new file mode 100644 --- /dev/null +++ b/src/Examples/HCron/Editor1st.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances + , MultiParamTypeClasses, PatternSignatures + , TemplateHaskell, UndecidableInstances #-} + +module Editor1st where + +import Entry1st +import Graphics.UI.AF.WxFormAll +import Control.Monad.Trans(liftIO) + +$(derive [''Entry,''Time,''Month]) + +instance ECCreator (Entry HCron) + +main = startWx "Editor1st" $ + do entryValue :: HCron <- liftIO $ (readFile specLocation >>= readIO) `catch` (\_ -> return []) + entry <- builderCom entryValue + chState <- makeChangedState entry + + let saveFile = do x <- getValue entry + liftIO $ writeFile specLocation $ show x + setValue chState $ Unchanged x + button "Save" saveFile >>= enabledWhen chState (== Changed) + button "Quit" closeWindow diff --git a/src/Examples/HCron/Editor2nd.hs b/src/Examples/HCron/Editor2nd.hs new file mode 100644 --- /dev/null +++ b/src/Examples/HCron/Editor2nd.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances + , MultiParamTypeClasses, TemplateHaskell + , TypeSynonymInstances, UndecidableInstances #-} + +module Editor2nd where + +import Entry1st +import Graphics.UI.AF.WxFormAll + + +$(derive [''Entry,''Time,''Month]) + +-- Should not be neccesary, but GHC 6.6 requires it. Remove when we stop support for GHC 6.6. +instance ECCreator (Entry Time) + +main = startWx "Editor2nd" $ editFile specLocation ([]::HCron) diff --git a/src/Examples/HCron/Editor3rdLimit.hs b/src/Examples/HCron/Editor3rdLimit.hs new file mode 100644 --- /dev/null +++ b/src/Examples/HCron/Editor3rdLimit.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances + , MultiParamTypeClasses, TemplateHaskell + , TypeSynonymInstances, UndecidableInstances #-} + +module Editor3rdLimit where + +import Entry1st + +import Graphics.UI.AF.WxFormAll + +$(derive [''Entry,''Time,''Month]) + +main = startWx "Editor3rd" $ editFile specLocation ([]::HCron) + +instance TypePresentation (Entry Time) tp1 tp2 tp3 tp4 tp5 where + mkCom x = limit timeLimit ("Incorrect time") + (defaultCom x) + where + timeLimit :: Entry Time -> IO Bool + timeLimit Entry { when = Time y month d h m } = return $ + y > 1970 && y < 2100 && + d >= 1 && + ((month == February && d <= 28) || + (month == February && d == 29 && y `mod` 4 == 0) || + (month `elem` [ January, March, May, July, August + , October, December] && d <= 30) || + (month `elem` [April, June, September, November] && d <= 30) + ) && + h >= 0 && h <= 23 && + m >= 0 && m <= 59 + +instance GInstanceCreator Time where + gGenUpTo _ = [Time 2000 January 1 10 00] diff --git a/src/Examples/HCron/Editor4thRecurring.hs b/src/Examples/HCron/Editor4thRecurring.hs new file mode 100644 --- /dev/null +++ b/src/Examples/HCron/Editor4thRecurring.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances + , MultiParamTypeClasses, TemplateHaskell + , TypeSynonymInstances, UndecidableInstances #-} + +module Editor4thRecurring where + +import Entry2ndRecurring + +import Graphics.UI.AF.WxFormAll + +$(derive [''Entry,''Time,''Month,''TimeDiff]) + +main = startWx "Editor4th" $ editFile specLocation ([]::HCron) + +instance TypePresentation (Entry Time) tp1 tp2 tp3 tp4 tp5 where + mkCom x = limit timeLimit ("Incorrect time") + (defaultCom x) + where + timeLimit :: Entry Time -> IO Bool + timeLimit Entry { when = Time y month d h m } = return $ + y > 1970 && y < 2100 && + d >= 1 && + ((month == February && d <= 28) || + (month == February && d == 29 && y `mod` 4 == 0) || + (month `elem` [ January, March, May, July, August + , October, December] && d <= 30) || + (month `elem` [April, June, September, November] && d <= 30) + ) && + h >= 0 && h <= 23 && + m >= 0 && m <= 59 + +instance GInstanceCreator Time where + gGenUpTo _ = [Time 2000 January 1 10 00] diff --git a/src/Examples/HCron/Editor5thOutputWindow.hs b/src/Examples/HCron/Editor5thOutputWindow.hs new file mode 100644 --- /dev/null +++ b/src/Examples/HCron/Editor5thOutputWindow.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances + , MultiParamTypeClasses, TemplateHaskell + , TypeSynonymInstances, UndecidableInstances #-} + +module Editor5thOutputWindow where + +import Entry2ndRecurring as Entry + +import Graphics.UI.AF.WxFormAll + +import Control.Monad.Trans(MonadIO) +import Run + +$(derive [''Entry,''Time,''Month,''TimeDiff]) + +main = startWx "Editor5th" $ editFile specLocation ([]::HCron) + +instance ( AutoForm WxAct ComH WxM SatCxt EC + , Sat (SatCxt (Entry Time)), Sat (SatCxt [String])) + => TypePresentation (Entry Time) WxAct ComH WxM SatCxt EC where + mkCom x = limit timeLimit ("Incorrect time") $ + label "Entry" $ builderToCom $ + do entryHandle <- addCom $ defaultCom x -- don't use mkCom here, as this + -- results in eternal recursion + outputHandle <- addCom $ label "Command output" $ mkCom [""] + button "Exec..." (do cmd <- getValue entryHandle + (_, out) <- liftIO $ readCommand (Entry.command cmd) "" + setValue outputHandle (lines out) + ) + return entryHandle + where + timeLimit :: Entry Time -> IO Bool + timeLimit Entry { when = Time y month d h m } = return $ + y > 1970 && y < 2100 && + d >= 1 && + ((month == February && d <= 28) || + (month == February && d == 29 && y `mod` 4 == 0) || + (month `elem` [ January, March, May, July, August + , October, December] && d <= 30) || + (month `elem` [April, June, September, November] && d <= 30) + ) && + h >= 0 && h <= 23 && + m >= 0 && m <= 59 + +instance GInstanceCreator Time where + gGenUpTo _ = [Time 2000 January 1 10 00] diff --git a/src/Examples/HCron/Editor6thCrontab.hs b/src/Examples/HCron/Editor6thCrontab.hs new file mode 100644 --- /dev/null +++ b/src/Examples/HCron/Editor6thCrontab.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances + , MultiParamTypeClasses, TemplateHaskell + , TypeSynonymInstances, UndecidableInstances #-} + +module Editor6thCrontab where + +import Entry3rdCrontab +import Run + +import Graphics.UI.AF.WxFormAll + +$(derive [''Crontab,''Entry,''Comment,''Field]) + +main = do (exitCode, crontabText) <- readCommand "crontab -l" "" + startWx "Editor6th" $ + case exitCode of + ExitFailure e -> errorDialog' ("Error - could not read crontab:\n") e + ExitSuccess -> do crontab <- liftIO $ (readIO crontabText >>= return . Right) + `catch` (return . Left) + either (errorDialog' "Error - could not parse crontab:\n") + -- (\x -> window [] $ crontabComponent x) + cronGui + crontab + return () + where + errorDialog' msg e = errorDialog "Error loading crontab" (msg ++ show e) + cronGui x + = do cronHandle <- builderCom x + chState <- makeChangedState cronHandle + button "Save" (saveFile cronHandle chState) >>= enabledWhen chState (== Changed) + button "Show" (showFile cronHandle) + button "Quit" closeWindow + return () + + saveFile cronHandle chState = + do x <- getValue cronHandle + (exitCode, crontabText) <- liftIO $ readCommand "crontab -" (show x) + case exitCode of + ExitFailure _ -> errorDialog "Error saving crontab" "Could not save crontab" + _ -> setValue chState $ Unchanged x + showFile :: ComH Crontab -> WxAct() + showFile cronHandle = + do x <- getValue cronHandle + infoDialog "Crontab file" (show x) + +instance TypePresentation Entry WxAct ComH WxM SatCxt EC where + mkCom x = finalDepth $ layoutAs dualColumn $ defaultCom x diff --git a/src/Examples/HCron/Entry1st.hs b/src/Examples/HCron/Entry1st.hs new file mode 100644 --- /dev/null +++ b/src/Examples/HCron/Entry1st.hs @@ -0,0 +1,23 @@ +module Entry1st + ( HCron, Entry(Entry, when, command) + , Time(Time, year, month, day, hour, minute) + , specLocation + , module System.Time + ) +where + +import System.Time + +type HCron = [Entry Time] + +data Entry t = Entry { when :: t + , command :: String } deriving (Show, Read, Eq, Ord) + +data Time = Time { year :: Int + , month :: System.Time.Month + , day :: Int + , hour :: Int + , minute :: Int } deriving (Show, Read, Eq, Ord) + +specLocation :: String +specLocation = "hcron.spec" diff --git a/src/Examples/HCron/Entry2ndRecurring.hs b/src/Examples/HCron/Entry2ndRecurring.hs new file mode 100644 --- /dev/null +++ b/src/Examples/HCron/Entry2ndRecurring.hs @@ -0,0 +1,24 @@ +module Entry2ndRecurring + ( HCron, Entry(Entry, when, command) + , Time(Time, year, month, day, hour, minute) + , specLocation + , module System.Time + ) +where + +import System.Time + +type HCron = [Entry Time] + +data Entry t = Entry { when :: t + , recurring :: Maybe TimeDiff + , command :: String } deriving (Show, Read, Eq, Ord) + +data Time = Time { year :: Int + , month :: System.Time.Month + , day :: Int + , hour :: Int + , minute :: Int } deriving (Show, Read, Eq, Ord) + +specLocation :: String +specLocation = "hcronRecurring.spec" diff --git a/src/Examples/HCron/Entry3rdCrontab.hs b/src/Examples/HCron/Entry3rdCrontab.hs new file mode 100644 --- /dev/null +++ b/src/Examples/HCron/Entry3rdCrontab.hs @@ -0,0 +1,112 @@ + +-- http://en.wikipedia.org/wiki/Cron + +module Entry3rdCrontab + ( Crontab(Crontab), Entry(Entry), Comment(CommentLine, BlankLine) + , Field(List, Range, All, EveryNth) + ) +where + +import Text.ParserCombinators.Parsec +import List(intersperse) + +data Crontab = Crontab { entries :: [Entry], endOfCrontabComments :: [Comment] } deriving Eq +data Entry = Entry { comment :: [Comment] + , minutes :: Field + , hours :: Field + , dayOfMonth :: Field + , month :: Field + , dayOfWeek :: Field + , command :: String + } deriving Eq +data Comment = CommentLine String + | BlankLine + deriving Eq + +data Field = List [Int] -- 1,2,6 + | Range Int Int -- 3-6 + | All -- * + | EveryNth Int -- */3 + deriving Eq + +-------------- Show instances -------------------------------- +instance Show Crontab where + show (Crontab es cs) = unlines $ map show es ++ map show cs + +instance Show Entry where + show e = (concat $ map (++ "\n") $ map show (comment e)) + ++ (concat $ intersperse "\t" $ map show [minutes e, hours e, dayOfMonth e, month e, dayOfWeek e]) + ++ "\t" ++ command e + +instance Show Comment where + show (CommentLine s) = '#':s + show BlankLine = "" + +instance Show Field where + show (List xs) = concat $ intersperse "," (map show xs) + show (Range l r) = show l ++ "-" ++ show r + show All = "*" + show (EveryNth x) = "*/" ++ show x + + +------------- Parser and Read instance ------------------------ +instance Read Crontab where + readsPrec _ serialzedText = [crontabParser serialzedText] + +crontabParser xs = let (Right (crontab, unconsumed)) = parse parsecParser "" xs + in (crontab, unconsumed) + where + parsecParser = do xs <- many (try crontabEntry) + endComment <- many parseComment + unconsumed <- many anyChar + return (Crontab xs endComment, unconsumed) + +crontabEntry = do comment' <- many parseComment + minute <- parseField + hour <- parseField + dayOfMonth <- parseField + month <- parseField + dayOfWeek <- parseField + command <- untilEOL + return $ Entry comment' minute hour dayOfMonth month dayOfWeek command + + +-- Field functions +parseField = let tryAll [] = pzero + tryAll (x:xs) = try (do x' <- x + whitespace + return x') + <|> tryAll xs + in tryAll [range, star, everyNth, list] + +list = do x <- digits + xs <- many (do char ',' + digits) + return $ List $ map read (x:xs) + +range = do low <- digits + char '-' + high <- digits + return $ Range (read low) (read high) + +star = do char '*' + return All + +everyNth = do char '*' + char '/' + digits >>= return . EveryNth . read + +digits = many1 digit + +whitespace = many1 $ oneOf " \t" + +-- + +parseComment = do char '#' + untilEOL >>= return . CommentLine + <|> + do blanks <- whitespace + char '\n' + return BlankLine + +untilEOL = manyTill anyChar ((do char '\n' >> return ()) <|> eof) diff --git a/src/Examples/HCron/Makefile b/src/Examples/HCron/Makefile new file mode 100644 --- /dev/null +++ b/src/Examples/HCron/Makefile @@ -0,0 +1,41 @@ +HC = ghc +HC_MAKE = $(HC) --make $< -o $@ -main-is $(notdir $@) $(HC_OPTIONS) + +H_CRONS = Daemon1st Daemon2ndRecurring Editor1st Editor2nd Editor3rdLimit Editor4thRecurring \ +Editor5thOutputWindow Editor6thCrontab + +%: %.hs + $(HC_MAKE) + +all: $(H_CRONS) + +Daemon1st: Daemon1st.hs Entry1st.hs +Daemon2ndRecurring: Daemon2ndRecurring.hs Entry2ndRecurring.hs +Editor1st: Editor1st.hs Entry1st.hs +Editor2nd: Editor2nd.hs Entry1st.hs +Editor3rdLimit: Editor3rdLimit.hs Entry1st.hs +Editor4thRecurring: Editor4thRecurring.hs Entry2ndRecurring.hs +Editor5thOutputWindow: Editor5thOutputWindow.hs Entry2ndRecurring.hs +Editor6thCrontab: Editor6thCrontab.hs Entry3rdCrontab.hs + +.PHONY: clean all screenshots + +all:$(H_CRONS) + +clean: + - rm *.hi *.o *~ $(H_CRONS) *.png + +define hcronScreenshot + echo "Doing $(1) screenshot" + ./$(1) & + sleep 2 && import -frame -window $(2) $(1)Screenshot.png + killall $(1) +endef + +screenshots: all + $(call hcronScreenshot,Editor1st,"Editor1st") + $(call hcronScreenshot,Editor2nd,"Editor2nd") + $(call hcronScreenshot,Editor3rdLimit,"Editor3rd") + $(call hcronScreenshot,Editor4thRecurring,"Editor4th") + $(call hcronScreenshot,Editor5thOutputWindow,"Editor5th") + $(call hcronScreenshot,Editor6thCrontab,"Editor6th") diff --git a/src/Examples/HCron/Run.hs b/src/Examples/HCron/Run.hs new file mode 100644 --- /dev/null +++ b/src/Examples/HCron/Run.hs @@ -0,0 +1,68 @@ +-- This module is heavily inspired/copied by/from Don Stewats System.Process.Run +-- module. See http://www.haskell.org/pipermail/libraries/2006-December/006632.html +-- and http://www.cse.unsw.edu.au/~dons/code/newpopen/ +-- +-- Stewats module has a BSD-style license. + +module Run (readCommand, ExitCode(ExitSuccess, ExitFailure)) where + +import System.Process +import System.Exit +import System.IO + +import Control.Monad +import Control.Concurrent +import qualified Control.Exception as C + +data Output = Standard { contents :: String } + | Error { contents :: String } deriving Show + +-- +-- |readCommand forks an external thread, reads its standard output +-- and standard error, waits for the process to terminate, and +-- returns the output (both standard output and standard error) and +-- an exitcode. +-- +readCommand :: String -- ^ command to run + -> String -- ^ standard input + -> IO (ExitCode, String) -- ^ exitcode and output +readCommand cmd input = C.handle (return . handler) $ do + + (inh,outh,errh,pid) <- runInteractiveCommand cmd + + -- fork off a thread to start consuming the output + commonOutputMVar <- newMVar [] + stdOutIsFinished <- newEmptyMVar + stdErrIsFinished <- newEmptyMVar + + let consume handle isFinished outputMVar = + do outIsEOF <- hIsEOF handle + if outIsEOF + then putMVar isFinished () + else do x <- hGetLine handle + modifyMVar_ outputMVar (\y -> return $ y ++ [Standard x]) + consume handle isFinished outputMVar + forkIO $ consume outh stdOutIsFinished commonOutputMVar + forkIO $ consume errh stdErrIsFinished commonOutputMVar + + -- now write and flush any input + when (not (null input)) $ hPutStr inh input + hClose inh -- done with stdin + + -- wait on the output + takeMVar stdOutIsFinished + takeMVar stdErrIsFinished + hClose outh + hClose errh + output <- takeMVar commonOutputMVar + -- We could drop the *IsFinished MVars and just use waitForProcess. However, according to + -- http://haskell.org/ghc/docs/latest/html/libraries/base/System-Process.html#v%3AwaitForProcess + -- this would require the program to be compiled with -threaded. + ex <- C.catch (waitForProcess pid) (\_ -> return ExitSuccess) + + return (ex, unlines $ map contents output) + + where + handler (C.ExitException e) = (e, []) + handler e = (ExitFailure 1, []) + diff --git a/src/Examples/Makefile b/src/Examples/Makefile new file mode 100644 --- /dev/null +++ b/src/Examples/Makefile @@ -0,0 +1,21 @@ +export HC_OPTIONS=$(OPT) + +all: + $(MAKE) -C Misc all + $(MAKE) -C HCron all + +.PHONY: clean all screenshots nolink nolinkWall + +clean: + $(MAKE) -C Misc clean + $(MAKE) -C HCron clean + +screenshots: + $(MAKE) -C Misc screenshots + $(MAKE) -C HCron screenshots + +nolink: clean + make all "HC_OPTIONS=-no-link" + +nolinkWall: clean + make all "HC_OPTIONS=-no-link -Wall" diff --git a/src/Examples/Misc/AFWxExample.hs b/src/Examples/Misc/AFWxExample.hs new file mode 100644 --- /dev/null +++ b/src/Examples/Misc/AFWxExample.hs @@ -0,0 +1,18 @@ +module AFWxExample where + +import Graphics.UI.WX +import Graphics.UI.AF.AFWx + +main :: IO () +main = start $ + do w <- frame [text := "AFWx example"] + p <- panel w [] + + wid <- makeWidget (0.96::Double, 123::Int, "asdf") p [] + setWidButton <- button p [ text := "Set widget" + , on command := set wid [ value := (0.32, 456, "New Value") ] + ] + + set w [ layout := container p $ fill $ column 10 + [ widget wid, widget setWidButton ] + ] diff --git a/src/Examples/Misc/AlbumDTD.hs b/src/Examples/Misc/AlbumDTD.hs new file mode 100644 --- /dev/null +++ b/src/Examples/Misc/AlbumDTD.hs @@ -0,0 +1,329 @@ +module AlbumDTD where + +{- +Copyright of (c) copyright 1998-2005 Malcolm Wallace and Colin Runciman +Lessor GPL License + +This file is constructed by the program DtdToHaskell, using a DTD +which originates from the HaXmL project. + +Some of the automatically generated code, have been commented away by +Mads Lindstrøm (2006). This was done to reduce the number of +dependencies. + +-} + + +{- +import Text.XML.HaXml.Xml2Haskell +import Text.XML.HaXml.OneOfN +-} + +{-Type decls-} + +data Album = Album Title Artist (Maybe Recording) Coverart + [Catalogno] Personnel [Track] Notes + deriving (Eq,Show) +newtype Title = Title String deriving (Eq,Show) +newtype Artist = Artist String deriving (Eq,Show) +data Recording = Recording + { recordingDate :: (Maybe String) + , recordingPlace :: (Maybe String) + } deriving (Eq,Show) +data Coverart = Coverart Coverart_Attrs (Maybe Location) + deriving (Eq,Show) +data Coverart_Attrs = Coverart_Attrs + { coverartStyle :: String + } deriving (Eq,Show) +data Location = Location + { locationThumbnail :: (Maybe String) + , locationFullsize :: (Maybe String) + } deriving (Eq,Show) +data Catalogno = Catalogno + { catalognoLabel :: String + , catalognoNumber :: String + , catalognoFormat :: (Maybe Catalogno_Format) + , catalognoReleasedate :: (Maybe String) + , catalognoCountry :: (Maybe String) + } deriving (Eq,Show) +data Catalogno_Format = Catalogno_Format_CD | Catalogno_Format_LP + | Catalogno_Format_MiniDisc + deriving (Eq,Show) +newtype Personnel = Personnel [Player] deriving (Eq,Show) +data Player = Player + { playerName :: String + , playerInstrument :: String + } deriving (Eq,Show) +data Track = Track + { trackTitle :: String + , trackCredit :: (Maybe String) + , trackTiming :: (Maybe String) + } deriving (Eq,Show) +data Notes = Notes Notes_Attrs [Notes_] + deriving (Eq,Show) +data Notes_Attrs = Notes_Attrs + { notesAuthor :: (Maybe String) + } deriving (Eq,Show) +data Notes_ = Notes_Str String + | Notes_Albumref Albumref + | Notes_Trackref Trackref + deriving (Eq,Show) +data Albumref = Albumref Albumref_Attrs String + deriving (Eq,Show) +data Albumref_Attrs = Albumref_Attrs + { albumrefLink :: String + } deriving (Eq,Show) +data Trackref = Trackref Trackref_Attrs String + deriving (Eq,Show) +data Trackref_Attrs = Trackref_Attrs + { trackrefLink :: (Maybe String) + } deriving (Eq,Show) + +{- +{-Instance decls-} + +instance XmlContent Album where + fromElem (CElem (Elem "album" [] c0):rest) = + (\(a,ca)-> + (\(b,cb)-> + (\(c,cc)-> + (\(d,cd)-> + (\(e,ce)-> + (\(f,cf)-> + (\(g,cg)-> + (\(h,ch)-> + (Just (Album a b c d e f g h), rest)) + (definite fromElem "" "album" cg)) + (many fromElem cf)) + (definite fromElem "" "album" ce)) + (many fromElem cd)) + (definite fromElem "" "album" cc)) + (fromElem cb)) + (definite fromElem "" "album" ca)) + (definite fromElem "" "album" c0) + fromElem (CMisc _:rest) = fromElem rest + fromElem rest = (Nothing, rest) + toElem (Album a b c d e f g h) = + [CElem (Elem "album" [] (toElem a ++ toElem b ++ maybe [] toElem c + ++ toElem d ++ concatMap toElem e ++ toElem f ++ concatMap toElem g + ++ toElem h))] +instance XmlContent Title where + fromElem (CElem (Elem "title" [] c0):rest) = + (\(a,ca)-> + (Just (Title a), rest)) + (definite fromText "text" "title" c0) + fromElem (CMisc _:rest) = fromElem rest + fromElem rest = (Nothing, rest) + toElem (Title a) = + [CElem (Elem "title" [] (toText a))] +instance XmlContent Artist where + fromElem (CElem (Elem "artist" [] c0):rest) = + (\(a,ca)-> + (Just (Artist a), rest)) + (definite fromText "text" "artist" c0) + fromElem (CMisc _:rest) = fromElem rest + fromElem rest = (Nothing, rest) + toElem (Artist a) = + [CElem (Elem "artist" [] (toText a))] +instance XmlContent Recording where + fromElem (CElem (Elem "recording" as []):rest) = + (Just (fromAttrs as), rest) + fromElem (CMisc _:rest) = fromElem rest + fromElem rest = (Nothing, rest) + toElem as = + [CElem (Elem "recording" (toAttrs as) [])] +instance XmlAttributes Recording where + fromAttrs as = + Recording + { recordingDate = possibleA fromAttrToStr "date" as + , recordingPlace = possibleA fromAttrToStr "place" as + } + toAttrs v = catMaybes + [ maybeToAttr toAttrFrStr "date" (recordingDate v) + , maybeToAttr toAttrFrStr "place" (recordingPlace v) + ] +instance XmlContent Coverart where + fromElem (CElem (Elem "coverart" as c0):rest) = + (\(a,ca)-> + (Just (Coverart (fromAttrs as) a), rest)) + (fromElem c0) + fromElem (CMisc _:rest) = fromElem rest + fromElem rest = (Nothing, rest) + toElem (Coverart as a) = + [CElem (Elem "coverart" (toAttrs as) (maybe [] toElem a))] +instance XmlAttributes Coverart_Attrs where + fromAttrs as = + Coverart_Attrs + { coverartStyle = definiteA fromAttrToStr "coverart" "style" as + } + toAttrs v = catMaybes + [ toAttrFrStr "style" (coverartStyle v) + ] +instance XmlContent Location where + fromElem (CElem (Elem "location" as []):rest) = + (Just (fromAttrs as), rest) + fromElem (CMisc _:rest) = fromElem rest + fromElem rest = (Nothing, rest) + toElem as = + [CElem (Elem "location" (toAttrs as) [])] +instance XmlAttributes Location where + fromAttrs as = + Location + { locationThumbnail = possibleA fromAttrToStr "thumbnail" as + , locationFullsize = possibleA fromAttrToStr "fullsize" as + } + toAttrs v = catMaybes + [ maybeToAttr toAttrFrStr "thumbnail" (locationThumbnail v) + , maybeToAttr toAttrFrStr "fullsize" (locationFullsize v) + ] +instance XmlContent Catalogno where + fromElem (CElem (Elem "catalogno" as []):rest) = + (Just (fromAttrs as), rest) + fromElem (CMisc _:rest) = fromElem rest + fromElem rest = (Nothing, rest) + toElem as = + [CElem (Elem "catalogno" (toAttrs as) [])] +instance XmlAttributes Catalogno where + fromAttrs as = + Catalogno + { catalognoLabel = definiteA fromAttrToStr "catalogno" "label" as + , catalognoNumber = definiteA fromAttrToStr "catalogno" "number" as + , catalognoFormat = possibleA fromAttrToTyp "format" as + , catalognoReleasedate = possibleA fromAttrToStr "releasedate" as + , catalognoCountry = possibleA fromAttrToStr "country" as + } + toAttrs v = catMaybes + [ toAttrFrStr "label" (catalognoLabel v) + , toAttrFrStr "number" (catalognoNumber v) + , maybeToAttr toAttrFrTyp "format" (catalognoFormat v) + , maybeToAttr toAttrFrStr "releasedate" (catalognoReleasedate v) + , maybeToAttr toAttrFrStr "country" (catalognoCountry v) + ] +instance XmlAttrType Catalogno_Format where + fromAttrToTyp n (n',v) + | n==n' = translate (attr2str v) + | otherwise = Nothing + where translate "CD" = Just Catalogno_Format_CD + translate "LP" = Just Catalogno_Format_LP + translate "MiniDisc" = Just Catalogno_Format_MiniDisc + translate _ = Nothing + toAttrFrTyp n Catalogno_Format_CD = Just (n, str2attr "CD") + toAttrFrTyp n Catalogno_Format_LP = Just (n, str2attr "LP") + toAttrFrTyp n Catalogno_Format_MiniDisc = Just (n, str2attr "MiniDisc") +instance XmlContent Personnel where + fromElem (CElem (Elem "personnel" [] c0):rest) = + (\(a,ca)-> + (Just (Personnel a), rest)) + (many fromElem c0) + fromElem (CMisc _:rest) = fromElem rest + fromElem rest = (Nothing, rest) + toElem (Personnel a) = + [CElem (Elem "personnel" [] (concatMap toElem a))] +instance XmlContent Player where + fromElem (CElem (Elem "player" as []):rest) = + (Just (fromAttrs as), rest) + fromElem (CMisc _:rest) = fromElem rest + fromElem rest = (Nothing, rest) + toElem as = + [CElem (Elem "player" (toAttrs as) [])] +instance XmlAttributes Player where + fromAttrs as = + Player + { playerName = definiteA fromAttrToStr "player" "name" as + , playerInstrument = definiteA fromAttrToStr "player" "instrument" as + } + toAttrs v = catMaybes + [ toAttrFrStr "name" (playerName v) + , toAttrFrStr "instrument" (playerInstrument v) + ] +instance XmlContent Track where + fromElem (CElem (Elem "track" as []):rest) = + (Just (fromAttrs as), rest) + fromElem (CMisc _:rest) = fromElem rest + fromElem rest = (Nothing, rest) + toElem as = + [CElem (Elem "track" (toAttrs as) [])] +instance XmlAttributes Track where + fromAttrs as = + Track + { trackTitle = definiteA fromAttrToStr "track" "title" as + , trackCredit = possibleA fromAttrToStr "credit" as + , trackTiming = possibleA fromAttrToStr "timing" as + } + toAttrs v = catMaybes + [ toAttrFrStr "title" (trackTitle v) + , maybeToAttr toAttrFrStr "credit" (trackCredit v) + , maybeToAttr toAttrFrStr "timing" (trackTiming v) + ] +instance XmlContent Notes where + fromElem (CElem (Elem "notes" as c0):rest) = + (\(a,ca)-> + (Just (Notes (fromAttrs as) a), rest)) + (many fromElem c0) + fromElem (CMisc _:rest) = fromElem rest + fromElem rest = (Nothing, rest) + toElem (Notes as a) = + [CElem (Elem "notes" (toAttrs as) (concatMap toElem a))] +instance XmlAttributes Notes_Attrs where + fromAttrs as = + Notes_Attrs + { notesAuthor = possibleA fromAttrToStr "author" as + } + toAttrs v = catMaybes + [ maybeToAttr toAttrFrStr "author" (notesAuthor v) + ] +instance XmlContent Notes_ where + fromElem c0 = + case (fromText c0) of + (Just a,rest) -> (Just (Notes_Str a), rest) + (Nothing,_) -> + case (fromElem c0) of + (Just a,rest) -> (Just (Notes_Albumref a), rest) + (Nothing,_) -> + case (fromElem c0) of + (Just a,rest) -> (Just (Notes_Trackref a), rest) + (Nothing,_) -> + (Nothing, c0) + fromElem (CMisc _:rest) = fromElem rest + fromElem rest = (Nothing, rest) + toElem (Notes_Str a) = toText a + toElem (Notes_Albumref a) = toElem a + toElem (Notes_Trackref a) = toElem a +instance XmlContent Albumref where + fromElem (CElem (Elem "albumref" as c0):rest) = + (\(a,ca)-> + (Just (Albumref (fromAttrs as) a), rest)) + (definite fromText "text" "albumref" c0) + fromElem (CMisc _:rest) = fromElem rest + fromElem rest = (Nothing, rest) + toElem (Albumref as a) = + [CElem (Elem "albumref" (toAttrs as) (toText a))] +instance XmlAttributes Albumref_Attrs where + fromAttrs as = + Albumref_Attrs + { albumrefLink = definiteA fromAttrToStr "albumref" "link" as + } + toAttrs v = catMaybes + [ toAttrFrStr "link" (albumrefLink v) + ] +instance XmlContent Trackref where + fromElem (CElem (Elem "trackref" as c0):rest) = + (\(a,ca)-> + (Just (Trackref (fromAttrs as) a), rest)) + (definite fromText "text" "trackref" c0) + fromElem (CMisc _:rest) = fromElem rest + fromElem rest = (Nothing, rest) + toElem (Trackref as a) = + [CElem (Elem "trackref" (toAttrs as) (toText a))] +instance XmlAttributes Trackref_Attrs where + fromAttrs as = + Trackref_Attrs + { trackrefLink = possibleA fromAttrToStr "link" as + } + toAttrs v = catMaybes + [ maybeToAttr toAttrFrStr "link" (trackrefLink v) + ] + + +{-Done-} +-} diff --git a/src/Examples/Misc/AlbumEditor.hs b/src/Examples/Misc/AlbumEditor.hs new file mode 100644 --- /dev/null +++ b/src/Examples/Misc/AlbumEditor.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances + , MultiParamTypeClasses, TemplateHaskell, UndecidableInstances #-} + +module AlbumEditor where + +import Graphics.UI.AF.WxFormAll +import Maybe + +import AlbumDTD + +$(derive [''Trackref_Attrs,''Trackref,''Albumref_Attrs,''Albumref,''Notes_,''Notes_Attrs,''Notes,''Track,''Player,''Personnel,''Catalogno_Format,''Catalogno,''Location,''Coverart_Attrs,''Coverart,''Recording,''Artist,''Title,''Album]) + +-- Should not be neccesary, but GHC 6.6 requires it. Remove when we stop support for GHC 6.6. +instance ECCreator Album + +someAlbum :: Album +someAlbum = case createInstance of + (Just a) -> a + Nothing -> error "AlbumEditor: Could not create the data type" + +otherAlbum :: Album +otherAlbum = let i :: (GInstanceCreator a) => a + i = fromJust createInstance + in Album (Title "The Gratefull Dead") i (Just $ Recording Nothing $ Just "Birmingham") i i i i + (Notes i [Notes_Str "Foo"]) + +main :: IO () +main = startWx "" $ + do button "Dialog" albumDialog + postponeAction albumDialog -- Just for the sake of creating screenshot + +albumDialog = settingsDialog otherAlbum + -- (layoutAs dualColumn (finalDepth $ mkCom otherAlbum)) + (Just (\val -> liftIO $ putStr $ "Settings: " ++ show val ++ "\n")) -- Nothing + (liftIO . print) -- (\_ -> return ()) + (return ()) + diff --git a/src/Examples/Misc/EmbeddedTree.hs b/src/Examples/Misc/EmbeddedTree.hs new file mode 100644 --- /dev/null +++ b/src/Examples/Misc/EmbeddedTree.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances + , MultiParamTypeClasses, TemplateHaskell, UndecidableInstances #-} + +module EmbeddedTree where + +import Graphics.UI.WX as Wx +import Graphics.UI.AF.AFWx as AF -- cannot do qualified as `derive` then complains + +data Tree = Branch { left :: Tree, right :: Tree } + | Leaf Int deriving (Show, Eq) +$(AF.derive [''Tree]) + +-- Should not be neccesary, but GHC 6.6 requires it. Remove when we stop support for GHC 6.6. +instance AF.ECCreator Tree + +simpleTree = Leaf 2 +complexTree = Branch (Branch (Leaf 3) (Leaf 123)) (Leaf 2) + +main :: IO () +main = start $ + do w <- frame [text := "Embedded Tree"] + p <- panel w [] + ps <- scrolledWindow p [ scrollRate := sz 10 10 ] + + -- wid <- AF.makeWidget complexTree ps [ Wx.enabled := False ] -- Simple widget without autoform functions + let limitTree (Leaf x) = return (x < 117) + limitTree _ = return True + changeEditorComponent :: AF.EC Tree -> AF.EC Tree + changeEditorComponent = AF.limit limitTree "Rejected by limit-tree" + -- focusOn will not work until `AFWx a` becomes a `Window (AFWx a)`. + wid <- AF.makeWidget' changeEditorComponent complexTree ps [ enabled := False ] + simpleTreeButton <- button p [ text := "Simple tree", Wx.enabled := True + , on command := set wid [ value := simpleTree ] + ] + disableButton <- button p [ text := "Disable", enabled := True + , on command := set wid [ enabled := False ] + ] + enableButton <- button p [ text := "Enable", enabled := True + , on command := set wid [ enabled := True ] + ] + set wid [ on Wx.command := do val <- get wid value + putStr $ "Value changed by user input: " ++ show val ++ "\n" + ] + + set w [ layout := container p $ fill $ column 10 + [ container ps $ fill $ widget wid + , hfill $ valignBottom $ row 5 + [ widget disableButton + , widget enableButton + , widget simpleTreeButton + ] + ] + ] diff --git a/src/Examples/Misc/Grep.hs b/src/Examples/Misc/Grep.hs new file mode 100644 --- /dev/null +++ b/src/Examples/Misc/Grep.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances + , MultiParamTypeClasses, TemplateHaskell + , TypeSynonymInstances, UndecidableInstances #-} + +-- |Grep-like example to illustrate PolyCommand. +module Grep where + +import Graphics.UI.AF.PolyCommand as AF +import Graphics.UI.AF.WxForm as Wx + +import IO +import List(isPrefixOf) +import Char(toLower) + +data Grep = Grep { file :: AFFilePath + , directory :: AFDirectoryPath -- The directory is currently unused. + , pattern :: Pattern + , caseSensitive :: Case } deriving (Show, Read, Eq) +newtype Pattern = Pattern String deriving (Show, Read, Eq) +data Case = Sensitive | Unsensitive deriving (Show, Read, Eq) +$(derive [''Grep, ''Pattern, ''Case]) + +-- Should not be neccesary, but GHC 6.6 requires it. Remove when we stop support for GHC 6.6. +instance ECCreator Grep + +-- Specialization for all AutoForm instances: +instance TypePresentation Pattern tp1 tp2 tp3 tp4 tp5 where + mkCom p = AF.label "Search pattern" (defaultCom p) + +-- Specialization only for WxForm: +instance TypePresentation Case Wx.WxAct Wx.ComH Wx.WxM Wx.ECCreatorD Wx.EC where + mkCom p = AF.label "Case" (defaultCom p) + +main = polyCommand (Grep (AFFilePath "") (AFDirectoryPath ".") (Pattern "") Unsensitive) grepCommand + +grepCommand input + = do putStrLn $ "The directory part (" ++ (directoryPath $ directory input) + ++ ") is currently unused." + fileHandle <- afOpenFile (file input) ReadMode + contents <- (hGetContents fileHandle) + return (grep contents input) + +grep contents (Grep _ _ (Pattern p) sensitive) + = concat $ map (\x -> if isSubString sensitive p x + then x ++ "\n" + else [] + ) + (lines contents) + where isSubString _ [] _ = True + isSubString _ _ [] = False + isSubString Unsensitive subStr xs = isSubString Sensitive (map toLower subStr) (map toLower xs) + isSubString Sensitive subStr (x:xs) = isPrefixOf subStr (x:xs) || isSubString Sensitive subStr xs + + + + diff --git a/src/Examples/Misc/MVCExample.hs b/src/Examples/Misc/MVCExample.hs new file mode 100644 --- /dev/null +++ b/src/Examples/Misc/MVCExample.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances + , MultiParamTypeClasses, TemplateHaskell, UndecidableInstances #-} + +module MVCExample where + +import Graphics.UI.AF.WxFormAll +import Graphics.UI.WX as Wx + +data Minutes = Minutes Int deriving (Show, Eq) +data Alarm = Alarm { name :: String + , time :: Minutes + } deriving (Show, Eq) +data UserTime = UserTime { hour :: Int + , minute :: Int + } deriving (Show, Eq) + +$(derive [''Minutes,''UserTime,''Alarm]) + +-- Should not be neccesary, but GHC 6.6 requires it. Remove when we stop support for GHC 6.6. +instance ECCreator Alarm + +instance (TypePresentation UserTime action comH builder satCxt com, Sat(satCxt UserTime)) + => TypePresentation Minutes action comH builder satCxt com where + mkCom m' = + let minutes2UserTime (Minutes m) = UserTime (m `div` 60) (m `mod` 60) + userTime2Minutes (UserTime h m) = Minutes (60*h + m) + in mapValue userTime2Minutes (const minutes2UserTime) (mkCom (minutes2UserTime m')) + +main = startWx "Alarm MVC Example" $ do + {- blockingSettingsDialog (mkCom -} + builderCom (Alarm "My alarm" $ Minutes 117) + return () + diff --git a/src/Examples/Misc/Makefile b/src/Examples/Misc/Makefile new file mode 100644 --- /dev/null +++ b/src/Examples/Misc/Makefile @@ -0,0 +1,45 @@ +HC = ghc +HC_MAKE = $(HC) --make $< -o $@ -main-is $(notdir $@) $(HC_OPTIONS) +SCREENSHOT_DIR = $(CURDIR)/../../../website/ + +EXAMPLES = PersonTest Grep SettingsForm WxEmbedded MVCExample EmbeddedTree AlbumEditor AFWxExample RecursiveUpdates + +all:$(EXAMPLES) + +%: %.hs + $(HC_MAKE) + +PersonTest:PersonTest.hs +Grep:Grep.hs +SettingsForm:SettingsForm.hs +WxEmbedded:WxEmbedded.hs +MVCExample:MVCExample.hs +EmbeddedTree:EmbeddedTree.hs +AlbumEditor:AlbumEditor.hs +AFWxExample:AFWxExample.hs +RecursiveUpdates:RecursiveUpdates.hs + +.PHONY: clean all screenshots + +clean: + - rm *.hi *.o *~ $(EXAMPLES) $(SCREENSHOT_DIR){PersonTest,Grep,SettingsForm,WxEmbedded,MVCExample,EmbeddedTree,AlbumEditor,AFWxExample,RecursiveUpdates}.png + +define makeScreenshot + echo "Doing $(1) screenshot" + ./$(1) & + sleep 2 && import -frame -window $(2) $(SCREENSHOT_DIR)$(1)Screenshot.png + killall $(1) +endef + +#The screenshots which are outcommented, are because they are not working right now. +screenshots: all +# $(call makeScreenshot,Grep,"Grep") +# $(call makeScreenshot,GrepText,"AutoForms") +# killall Grep + $(call makeScreenshot,SettingsForm,"Text Editor Settings Forms") + $(call makeScreenshot,WxEmbedded,"Counter") + $(call makeScreenshot,MVCExample,"Alarm MVC Example") + $(call makeScreenshot,EmbeddedTree,"Embedded Tree") +# $(call makeScreenshot,AlbumEditor,"Album") + $(call makeScreenshot,AFWxExample,"AFWx example") + $(call makeScreenshot,RecursiveUpdates,"Recursive Updates") diff --git a/src/Examples/Misc/NonModalDialogTest.hs b/src/Examples/Misc/NonModalDialogTest.hs new file mode 100644 --- /dev/null +++ b/src/Examples/Misc/NonModalDialogTest.hs @@ -0,0 +1,24 @@ +-- This program is made to show an error in WxHaskell. It is not really a part of AutoForms. + +-- Compile with ghc -fglasgow-exts --make NonModalDialogTest.hs -o NonModalDialogTest + +module Main where + +import Graphics.UI.WX +import System + +main = start $ do + f <- frame [ text := "Some program" ] -- , on closing := exitWith ExitSuccess ] + okButton <- button f [ text := "OK", on command := putStr "Tester\n" ] + -- w <- get f parent -- if you use this the program do not terminate properly + set f [ layout := widget okButton ] + d <- dialog f [ text := "Some dialog" ] + set d [ visible := True ] + +{- + +Added "on closing := exitWith ExitSuccess" to frame creating line. This makes the program +close properly (see http://sourceforge.net/mailarchive/forum.php?thread_id=9096517&forum_id=34197). +However, this is a workaround and not good for AutoForms. + +-} diff --git a/src/Examples/Misc/Person.hs b/src/Examples/Misc/Person.hs new file mode 100644 --- /dev/null +++ b/src/Examples/Misc/Person.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances + , MultiParamTypeClasses, TemplateHaskell, UndecidableInstances #-} + +{- + +This class contains a person data type and one instantiation +(somePerson) of the datatype. The data type have been made ready for +use with the SYB3 ("Scrap Your Boilerplate" 3) library. However, it is +still not ready to be used with the AutoForm library, as all data +types needs to be instances of the GAutoForm class. These instance +declarations are in the PersonTest.hs file. + +It is good to keep the data types, needed to be used with the SYB3 +library in a seperate file, as it requires the use of +-fallow-undecidable-instances. + +-} + +module Person where + +import Graphics.UI.AF.General.MySYB + +import Time (Month (January, February, March, April, May, June + , July, August, September, October, November, December) + ) + +somePerson = (Person (Just $ Name "Walter" "Hansen") + (Address "Bernhoffstrasse 27" "Berlin" 12345) + (Birthday (Date 1970 March 3)) (Salary (Sal 47892.23)) (Red) + (SpecialYears [[1980,1982,1999]]) + ) + +data Person = Person (Maybe Name) Address Birthday Salary FavoriteColor SpecialYears deriving (Show, Eq, Read) +data Name = Name { first_Name :: String, sir_name :: String } deriving (Show, Eq, Read) +data Address = Address { road :: String, city :: String, zipCode :: Int } deriving (Show, Eq, Read) +data Birthday = Birthday Date deriving (Show, Eq, Read) +data Salary = Salary Sal deriving (Show, Eq, Read) +data Sal = Sal Double deriving (Show, Eq, Read) +data FavoriteColor = Black [Int] | Blue [(Int, String)] | White | Red deriving (Show, Eq, Read) +data SpecialYears = SpecialYears [[Int]] deriving (Show, Eq, Read) + +data Date = Date { year :: Int, month :: Month, day :: Int } deriving (Show, Eq, Read) + +$(derive [''Name,''Address,''Month,''Birthday,''Date,''Sal,''Salary,''FavoriteColor,''SpecialYears,''Person]) + + diff --git a/src/Examples/Misc/PersonTest.hs b/src/Examples/Misc/PersonTest.hs new file mode 100644 --- /dev/null +++ b/src/Examples/Misc/PersonTest.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances + , MultiParamTypeClasses, TemplateHaskell + , TypeSynonymInstances, UndecidableInstances #-} + +module PersonTest where + +import Person + +-- With respect to GAutoForm instances you have two choices. One is a +-- bit cumbersome the other requires undecidable and overlapping +-- instances, which can be unsafe. The latter choice is used +-- here, which also requires the import of GAutoFormAll. The former +-- requires an instance declation for each used data type. + +import Graphics.UI.WX as Wx hiding (close, button) +import Random +import Graphics.UI.AF.WxFormAll as AF +import Graphics.UI.AF.AFWx +import Graphics.UI.AF.General.MySYB +import Data.Word +import List(sort) + + +data Foo = Foo Int Int + deriving (Show) + +$(derive [''Foo]) + +aFoo, anotherFoo :: Foo +aFoo = Foo 3 5 +anotherFoo = Foo 127 5 + +data Bar = Bar Foo Foo + deriving (Show) + +$(derive [''Bar]) + +aBar, anotherBar :: Bar +aBar = Bar aFoo aFoo +anotherBar = Bar anotherFoo anotherFoo + +-- FIXME: here we have an error :( When The hole Foo is updated, as shown in myForm below, +-- listener (addListener ... i') is not triggerede. +instance AF.TypePresentation Foo AF.WxAct AF.ComH AF.WxM AF.ECCreatorD AF.EC where + mkCom (Foo i _) = mapValue (\x -> Foo x x) (\_ (Foo i _) -> i) $ builderToCom $ + do i' <- builderCom i + addListener (io $ putStrLn "i listener triggered") i' + return i' + +instance TypePresentation Address AF.WxAct AF.ComH AF.WxM AF.ECCreatorD AF.EC where + mkCom p = layoutAs singleRow $ defaultCom p + +main :: IO () +main = myForm + +myForm :: IO () +myForm = startWx "" $ + do builderCom () + p <- builderCom (1::Float) -- Just somePerson + builderCom $ Just (17.2::Float) + s <- builderCom (17.2::Float) + maybeVal <- AF.builderCom (Just "asdf") + s' <- AF.builderCom ["Foobar II"] + affect (+1) p s + affect (+1) s p + -- + ls <- AF.builderCom ([1::Double,52,9]) + -- affect sort ls ls + -- + aBar' <- AF.builderCom aBar + button "set aFoo" (setValue aBar' anotherBar) + button "Enable" (setEnabled maybeVal True >> giveFocus p) + button "Disable" (setEnabled maybeVal False) + button "Set Int to 123.1" (setValue s 123.1) + button "Append 1000" (sequence_ $ replicate 1000 (appendValue s' ["Krolymut\n"])) + return () diff --git a/src/Examples/Misc/RecursiveUpdates.hs b/src/Examples/Misc/RecursiveUpdates.hs new file mode 100644 --- /dev/null +++ b/src/Examples/Misc/RecursiveUpdates.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances + , MultiParamTypeClasses, TemplateHaskell, UndecidableInstances #-} + +{- + +This example is showing how to handle recursive updates. + +We do this by making two exchange rate calculators. The first is +recursive, the second is not. See RecursiveObserver monad (included +with AutoForms) for explanation of recursive udpates in this context. + +-} + +module RecursiveUpdates where + +import Graphics.UI.AF.WxFormAll + +euroToDollarRate :: Float +euroToDollarRate = 1.4414 + +main = startWx "Recursive Updates" $ + do addCom $ exchangeRateCalculater "Recursive" setValue + addCom $ exchangeRateCalculater "Non-recursive" nonRecursiveSetValue + +exchangeRateCalculater :: String -> (ComH Float -> Float -> WxAct ()) -> EC Float +exchangeRateCalculater label' updateFun = label label' $ builderToCom $ + do euros <- addCom $ label "Euros" $ mkCom 100 + dollars <- addCom $ label "Dollars" $ mkCom (100 * euroToDollarRate) + addListener (do euros' <- getValue euros + updateFun dollars (euros' * euroToDollarRate) + ) euros + addListener (do dollars' <- getValue dollars + updateFun euros (dollars' / euroToDollarRate) + ) dollars + return euros diff --git a/src/Examples/Misc/SettingsForm.hs b/src/Examples/Misc/SettingsForm.hs new file mode 100644 --- /dev/null +++ b/src/Examples/Misc/SettingsForm.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances + , MultiParamTypeClasses, TemplateHaskell, UndecidableInstances #-} + +module SettingsForm where + +import Graphics.UI.AF.AFWx +import Graphics.UI.WX + +data Settings = Settings { lineWrap :: Bool, splitWords :: Bool + , autoSave :: Bool, tabulatorStops :: [Int] + , spacesInSteadOfTabulators :: Bool } deriving (Show, Eq) +$(derive [''Settings]) + +defaultValues :: Settings +defaultValues = Settings True False False ([4,8,12] ++ [16,20..120]) False + +main = start $ + do w <- frame [ text := "Text Editor Settings Forms" ] + p <- panel w [] + + wid <- makeWidget defaultValues p [] + + set p [ layout := widget wid ] + diff --git a/src/Examples/Misc/WxEmbedded.hs b/src/Examples/Misc/WxEmbedded.hs new file mode 100644 --- /dev/null +++ b/src/Examples/Misc/WxEmbedded.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances + , MultiParamTypeClasses, TemplateHaskell, UndecidableInstances #-} + +module WxEmbedded where + +import Graphics.UI.WX +import Graphics.UI.AF.AFWx as AF -- cannot do qualified as `derive` then complains + + +data Counter = Counter Int deriving (Show, Eq) +$(derive [''Counter]) + +-- Should not be neccesary, but GHC 6.6 requires it. Remove when we stop support for GHC 6.6. +instance ECCreator Counter + +main :: IO () +main = start $ + do w <- frame [text := "Counter"] + p <- panel w [] + + wid <- AF.makeWidget (Counter 117) p [] + upButton <- button p [ text := "Up", enabled := True + , on command := set wid [ value :~ \(Counter val) -> Counter $ val + 1 ] + ] + downButton <- button p [ text := "Down", enabled := True + , on command := set wid [ value :~ \(Counter val) -> Counter $ val - 1 ] + ] + restoreButton <- button p [ text := "Restore", enabled := True + , on command := set wid [ value := Counter 117 ] + ] + disableButton <- button p [ text := "Disable", enabled := True + , on command := set wid [ enabled := False ] + ] + enableButton <- button p [ text := "Enable", enabled := True + , on command := set wid [ enabled := True ] + ] + set wid [ on command := do val <- get wid value + putStr $ "Direct input by user: " ++ show val ++ "\n" + ] + + set p [ layout := column 10 [ widget wid + , row 5 [glue, widget upButton, widget downButton] + , row 5 [glue, widget restoreButton] + , row 5 [glue, widget disableButton, widget enableButton] + ] + ] + set w [ layout := fill $ widget p ] diff --git a/src/Graphics/UI/AF/AFWx.hs b/src/Graphics/UI/AF/AFWx.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/AF/AFWx.hs @@ -0,0 +1,98 @@ +-- |AutoForm functions closely integrated with WxHaskell. +module Graphics.UI.AF.AFWx + ( -- * Example + -- $example + -- * Creating widgets + makeWidget, makeWidget', AFWx + , module Graphics.UI.AF.General.MySYB + -- * 'AF.EC' + , AF.EC, AF.ECCreator + , AF.limit, AF.giveFocus + , AF.mapValue + -- ** GUI-layout of 'AF.EC' types + , AF.layoutAs, AF.singleColumn, AF.dualColumn, AF.singleRow + , AF.finalDepth + ) +where + +import qualified Graphics.UI.AF.WxFormAll as AF +import qualified Graphics.UI.AF.WxForm.EditorComponent as AF +import qualified Graphics.UI.AF.WxForm.ComIO as ComIO + +import Graphics.UI.WX hiding (parent) +import Graphics.UI.WXCore +import Graphics.UI.AF.General.MySYB + +import Control.Monad(liftM) + +-- |Contains a widget representing an arbitrary type. +data AFWx a = AFWx { pickComIO :: ComIO.ComIO a + , pickLayout :: Layout + } + +instance Widget (AFWx a) where + widget = pickLayout + +instance Commanding (AFWx a) where + command = newEvent "Commanding" getter setter + where getter w = get (pickComIO w) (on command) + setter w action = set (pickComIO w) [ on command := action ] + +instance Able (AFWx a) where + enabled = mapToAFWx "Able" enabled + +instance Valued AFWx where + value = mapToAFWx "Value" value + +mapToAFWx :: String -> Attr (ComIO.ComIO a) a1 -> Attr (AFWx a) a1 +mapToAFWx name attribute = newAttr name getter setter + where getter w = get (pickComIO w) attribute + setter w val = set (pickComIO w) [ attribute := val ] + +-- |A more constrained version of 'makeWidget''. +makeWidget :: (AF.ECCreator a) + => a + -> Window w + -> [Prop (AFWx a)] + -> IO (AFWx a) +makeWidget x parent props = makeWidget' id x parent props + +-- |Creating a widget for any type, which is an instance of ECCreator. +makeWidget' :: (AF.ECCreator a) + => (AF.EC a -> AF.EC a) -- ^Used to transform the created widget. See 'AF.limit', 'AF.giveFocus' + -- and the functions in "AF.AutoForm". + -- Also see the EmbeddedTree example. + -> a -- ^The value to represent in a GUI. + -> Window w -- ^The window (or panel) to represent the value in. + -> [Prop (AFWx a)] -- ^Initial properties to set. + -> IO (AFWx a) +makeWidget' ecToEC x parent props = + do (comIO, widAndGui) <- AF.runWxM (AF.runEC $ ecToEC $ AF.mkCom x) parent (return ()) parent + (lay, _) <- maybe AF.nonEditableLayout AF.unboxedLayout (liftM snd widAndGui) + let afwx = AFWx comIO lay + set afwx props + return $ AFWx comIO lay + +{- $example +An example of using AutoForm and WxHaskell together: + +>import Graphics.UI.WX +>import Graphics.UI.AF.AFWx +> +>main :: IO () +>main = start $ +> do w <- frame [text := "Small example"] +> p <- panel w [] +> +> wid <- makeWidget (0.96::Double, 123::Int, "asdf") p [ ] +> setWidButton <- button p [ text := "Set widget" +> , on command := set wid [ value := (0.32, 456, "New Value") ] +> ] +> +> set w [ layout := container p $ fill $ column 10 +> [ widget wid, widget setWidButton ] +> ] + +-} + + diff --git a/src/Graphics/UI/AF/CForm/CForm.hs b/src/Graphics/UI/AF/CForm/CForm.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/AF/CForm/CForm.hs @@ -0,0 +1,31 @@ +{-| + +A proxy-like module for the implementation of the AutoForm class for +the console (text-only). + +However, the console interface is very rudimentary and were just +implemented to verify that the library, was general enough to support +other user interfaces. + +This module is located under Graphics.UI.AF.CForm, even though it has +nothing to do with Graphics. It was placed here for convenience. It +should be replaced if CForm is ever to become practically usefull. + +-} +module Graphics.UI.AF.CForm.CForm + ( module Graphics.UI.AF.General.MySYB + , module Maybe + , module Graphics.UI.AF.General.CustomTypes + , consoleParentProxy, GCForm + ) +where + +import Graphics.UI.AF.CForm.CFormImplementation +-- import Graphics.UI.AF.WX.WxList +-- import Graphics.UI.AF.WX.WxFilePath + +import Graphics.UI.AF.General.CustomTypes +import Graphics.UI.AF.General.MySYB +import Maybe + + diff --git a/src/Graphics/UI/AF/CForm/CFormAll.hs b/src/Graphics/UI/AF/CForm/CFormAll.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/AF/CForm/CFormAll.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE FlexibleInstances, OverlappingInstances, UndecidableInstances #-} + +module Graphics.UI.AF.CForm.CFormAll + ( module Graphics.UI.AF.CForm.CForm ) +where + +import Graphics.UI.AF.CForm.CForm +import Graphics.UI.AF.CForm.CFormImplementation +import Graphics.UI.AF.General.AutoForm (TypePresentation) +import Graphics.UI.AF.General.InstanceCreator + +instance ( Data GCFormD a, GInstanceCreator a, Show a, Read a, Data NoCtx a + , TypePresentation a IO Com' Identity GCFormD Com, Eq a) => GCForm a +-- instance TypePresentation a component satCxt parent diff --git a/src/Graphics/UI/AF/CForm/CFormImplementation.hs b/src/Graphics/UI/AF/CForm/CFormImplementation.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/AF/CForm/CFormImplementation.hs @@ -0,0 +1,183 @@ +{-# OPTIONS -fglasgow-exts #-} +-- Do not know precisely which extensions needs adding + +-- |An implementation of the AutoForm class for consoles (text-only) +module Graphics.UI.AF.CForm.CFormImplementation + ( GCForm, GCFormD + , consoleParentProxy + , Com(Com), Parent, Com', Identity + ) +where + +import Maybe + +import qualified Graphics.UI.AF.General as AF +import Graphics.UI.AF.General.MySYB +-- import Graphics.UI.AF.General.CustomTypes +import Graphics.UI.AF.General.InstanceCreator + +import Graphics.UI.AF.General.PriLabel + +import Control.Monad.Identity + +import Monad(zipWithM_) +import IO(hFlush, stdout) + +-- |Component parameter for the console instance of AutoForm +data Com a = Com PriLabel (Int -> PriLabel -> IO a) +data Com' a = Com' (Com a) +-- |Satisfiability context parameter for the console instance of AutoForm +type SatCxt = GCFormD +-- |Parent parameter for the console instance of AutoForm +type Parent = Identity + +-- |A Parent type proxy +consoleParentProxy :: Parent () +consoleParentProxy = error "Cannot be instantiated." + +instance AF.SimpleDialog Identity where + errorDialog = error "Not implemented yet" + infoDialog = error "Not implemented yet" +instance AF.SimpleDialog IO where + errorDialog = error "Not implemented yet" + infoDialog = error "Not implemented yet" + +-- class (Action action comH builder) + -- => AutoForm (action :: * -> *) (comH :: * -> *) (builder :: * -> *) (satCxt :: * -> *) (com :: * -> * -> *) +-- instance AF.Valued IO Com' Identity where +instance AF.Action IO Com' where +instance AF.Valued Com where +instance AF.Valued Com' where +instance AF.Mergeable Com where +instance AF.Mergeable Com' where +instance AF.ValuedAction Com' IO where +instance AF.AutoForm IO Com' Identity SatCxt Com where + defaultCom x = (gCFormD dict) x -- Com (\indentation -> (gCFormD dict) indentation x) + label newLabel (Com lbl get) + = Com (bestLabel (PriLabel UserDefined newLabel) lbl) get + limit = error "Not implemented yet" + builderToCom com = let (Com' (Com lbl f)) = runIdentity com + in Com lbl f + addCom = return . Com' + command _ (Com lbl get) execFun + = do putStrLn "In CForm command" + get 0 lbl >>= execFun >>= putStr . toString + return () + +{- +instance AF.AutoForm Com SatCxt Parent where + display = error "Not implemented yet" + hidden = error "Not implemented yet" + addTimer = error "Not implemented yet" + executeProcess = error "Not implemented yet" +-} + +------------------------------------------------------------------------------ + +type GCFormT a = a -> Com a + +-- |The dictionary type for the GCForm class +data GCFormD a = GCFormD { gCFormD :: GCFormT a + , mkComD :: GCFormT a + , gToStringD :: a -> String + , gDefaultInstanceD :: a + } + +-- |Instantiation of the Sat class +instance GCForm a => Sat (GCFormD a) + where dict = GCFormD { gCFormD = gCForm + , mkComD = AF.mkCom + , gToStringD = gToString + , gDefaultInstanceD = defaultInstance + } + +-- |The context for generic autoform +gCFormCtx :: Proxy GCFormD +gCFormCtx = error "gCFormCtx" + +toString :: Sat (GCFormD a) => a -> String +toString x = (gToStringD dict) x + +class (Data GCFormD a, GInstanceCreator a, Show a, Read a, AF.TypePresentation a IO Com' Identity GCFormD Com + , Eq a) => GCForm a + where + gCForm :: GCFormT a + gCForm x = + case constrRep (toConstr gCFormCtx x) of + AlgConstr _ -> gmapCom gCFormCtx (mkComD dict) (gDefaultInstanceD dict) x + IntConstr _ -> makeComFromSimpleType "Int" + FloatConstr _ -> makeComFromSimpleType "Float" + StringConstr _ -> error "No StringConstr constructors" + defaultInstance :: a + defaultInstance = fromJust createInstance + +makeComFromSimpleType :: (Read a) => String -> Com a +makeComFromSimpleType inputType + = Com (defaultLabel "") getter + where + getter indentation (PriLabel _ label) + = maybeRead indentation label inputType + +requestInput :: Int -> String -> String -> IO String +requestInput indentation label labelType = + do putStr $ (replicate indentation ' ') ++ label ++ " (" ++ labelType ++ "): " + hFlush stdout + getLine + +maybeRead :: (Read a) => Int -> String -> String -> IO a +maybeRead indentation label labelType = + do input <- requestInput indentation label labelType + case reads input of + (x, ""):[] -> return x + _ -> maybeRead indentation label labelType + +instance GCForm String + where + gCForm _ = + Com (defaultLabel "") + (\indentation (PriLabel _ label) -> requestInput indentation label "String" + ) + +data GMapHelper a = GMapHelper [PriLabel] (IO a) + +gmapCom :: -- forall a (m :: * -> *). + (Data ctx a) => + Proxy ctx -> (forall a1. (Data ctx a1) => GCFormT a1) + -> (forall a2. (Data ctx a2) => a2) -> GCFormT a +gmapCom ctx f defaultInstance' y = + Com (defaultLabel constructorLabel) + (\indentation (PriLabel _ label) -> + do putStrLn (indent indentation ++ "Doing: " ++ label) + c <- chooseConstructor indentation + let GMapHelper _ getter = gunfold ctx (k indentation) z c + getter + ) + where + indent indentation = replicate indentation ' ' + chooseConstructor indentation = + if length constructors' == 1 + then return $ head constructors' + else do zipWithM_ (\i name -> putStrLn $ indent indentation ++ (show i) ++ ") " ++ name) + ([1..]::[Int]) constructorNames + i <- maybeRead indentation "Choose one" "Int" + if (i < 1 || i > length constructors') + then chooseConstructor indentation + else return $ constructors' !! (i - 1) + k indentation (GMapHelper labels c) = + GMapHelper (if null labels then [] else tail labels) + (do let (Com label getFun) = f defaultInstance' + c' <- c + x' <- getFun (indentation + 2) (maybe label (\x -> bestLabel label x) (listToMaybe labels)) + return (c' x') + ) + z c = GMapHelper fieldLabels (return c) + constructorLabel = showConstr $ toConstr ctx y + fieldLabels = map (humanizeLabel . PriLabel FieldName) (constrFields $ toConstr ctx y) + constructors' = constructors ctx y + constructorNames = map showConstr constructors' + +instance GCForm Bool +instance GCForm Int +instance GCForm Char +instance GCForm Float +instance GCForm Double diff --git a/src/Graphics/UI/AF/General.hs b/src/Graphics/UI/AF/General.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/AF/General.hs @@ -0,0 +1,21 @@ +-- |General functionality for all AutoForms instances +module Graphics.UI.AF.General + ( module Graphics.UI.AF.General.AutoForm + , module Graphics.UI.AF.General.CustomTypes + , module Graphics.UI.AF.General.Dialog + , module Graphics.UI.AF.General.EditFile + , module Graphics.UI.AF.General.InstanceCreator + , module Graphics.UI.AF.General.Misc + , module Graphics.UI.AF.General.MySYB + , module Graphics.UI.AF.General.PriLabel + ) +where + +import Graphics.UI.AF.General.AutoForm +import Graphics.UI.AF.General.CustomTypes +import Graphics.UI.AF.General.Dialog +import Graphics.UI.AF.General.EditFile +import Graphics.UI.AF.General.InstanceCreator +import Graphics.UI.AF.General.Misc +import Graphics.UI.AF.General.MySYB +import Graphics.UI.AF.General.PriLabel diff --git a/src/Graphics/UI/AF/General/AutoForm.hs b/src/Graphics/UI/AF/General/AutoForm.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/AF/General/AutoForm.hs @@ -0,0 +1,494 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances, FunctionalDependencies + , KindSignatures, MultiParamTypeClasses #-} + +module Graphics.UI.AF.General.AutoForm + ( TypePresentation, SimpleDialog + -- * Creating windows + , infoDialog, errorDialog, window + + -- * Components + , addCom + -- ** Component constructors + , mkCom, defaultCom, builderToCom, builderCom + -- ** Valueless components + , button, addTimer, executeProcess -- the last two do not return a component know, + -- but they will in the future. + + -- * Mapping the component type + -- + -- |These functions do not change the GUI-user sees the components - + -- only how the programmer sees them. E.g. they change state and\/or + -- value, not presentation. + -- + -- ** State + , state, makeChangedState, Changed(..) + -- ** Value + , Valued(..), Mergeable(..) + + -- * Actions + , postponeAction + , Action(..) + -- ** Setting/getting value of component + , ValuedAction(..) + + -- * Presentation of component + , limit, label + + -- * Misc + , AutoForm + , commandImpl, command + , addListener + ) +where + +import Graphics.UI.AF.General.MySYB +import Control.Monad.Trans(liftIO, MonadIO) +import Data.Monoid + +class Valued (valued :: * -> *) where + -- |Maps the value of a compoent + mapValue :: (old -> new) -- ^old to new conversion + -> (old -> new -> old) -- ^new to old conversions. This functions also get the current + -- old value as input. + -> valued old -- ^old component + -> valued new -- ^new component + + fstValue :: valued (valFst, valSnd) + -> valued valFst + fstValue valued = mapValue fst (\old new -> (new, snd old)) valued + + sndValue :: valued (valFst, valSnd) + -> valued valSnd + sndValue valued = mapValue snd (\old new -> (fst old, new)) valued + + -- |Hides the value of a valued object. + noValue :: valued a -> valued () + noValue valued = mapValue (const ()) (\old _ -> old) valued + + +class Mergeable (valued :: * -> *) where + merge :: valued left -> valued right -> valued (left, right) + +class (Monad action) => ValuedAction (valued :: * -> *) (action :: * -> *) where + getValue :: valued a -> action a + setValue :: valued a -> a -> action () + nonRecursiveSetValue :: valued a -> a -> action () + appendValue :: (Monoid a) => valued a -> a -> action () + appendValue c xs = do value <- getValue c + setValue c (value `mappend` xs) + +class ( Monad action + ) + => Action (action :: * -> *) (comH :: * -> *) + | action -> comH, comH -> action + where + setEnabled :: comH a -> Bool -> action () + + closeWindow :: action () + -- |Will give this compoment focus + giveFocus :: comH a -> action () + +class ( Action action comH + , Valued com, Valued comH + -- , Mergeable com, Mergeable comH + , ValuedAction comH action + , SimpleDialog action, SimpleDialog builder + ) + => AutoForm (action :: * -> *) (comH :: * -> *) (builder :: * -> *) (satCxt :: * -> *) (com :: * -> *) + | action -> comH, comH -> builder, builder -> satCxt, satCxt -> com, com -> action + where + -- |Makes a default component. That is, it do not call `mkCom`. + defaultCom :: (Sat (satCxt a)) => + a + -> com a + -- | Takes all components encapsulated in (added to) a builder + -- monad and packages them in a component. + builderToCom :: builder (comH a) + -> com a + -- |Encapsulates (or adds) a component in the builder monad. + addCom :: com a -> builder (comH a) + state :: s -> builder (comH s) + + -- + postponeAction :: action a -> builder () + button :: String -> action () -> builder (comH ()) + addTimer :: Int -> action () -> builder () + executeProcess :: String + -> (Int -> action ()) -- ^OnEnd :: ExitCode + -> (String -> action ()) -- ^OnStandardInput :: String + -> (String -> action ()) -- ^OnStandardError :: String + -> builder () + + -- |Limits the values a GUI-user can set a component to. + limit :: (Show a) => + (a -> IO Bool) -- ^The limit. + -> String -- ^Error message displayed to the GUI-user, if the limit is violated. + -> com a + -> com a + -- |Labels a component. This label will usually be displayed to the GUI-user. + label :: String -- ^The label. + -> com a + -> com a + + addListener :: action () -> comH a -> builder (comH a) + + + command :: (Sat (satCxt a), Sat (satCxt [String])) + => builder () -- ^Not used in WxForm, just a proxy to identify AutoForm instance + -> com a + -> (a -> IO String) -- ^Command to execute + -> IO () + window :: com a + -> action () + +commandImpl :: ( AutoForm action comH builder satCxt com + , MonadIO action + , Sat (satCxt a), Sat (satCxt [String]) + ) => + com a + -> (a -> IO String) -- ^Command to execute + -> builder () +commandImpl ec execute = + do outputArea <- addCom $ label "Output area" $ mkCom [""] + commandInput <- addCom ec + button "&Quit" closeWindow + button "&Execute" (do output <- getValue commandInput >>= liftIO . execute + mapM_ (appendValue outputArea) (map (\x -> [x]) $ lines output) + ) + return () + + +-- |Adds any value to AutoForm interface. The following equation holds: +-- builderCom x = addCom $ mkCom x +builderCom :: ( Sat (satCxt a) + , AutoForm action comH builder satCxt com + , TypePresentation a action comH builder satCxt com + ) => + a + -> builder (comH a) +builderCom x = addCom $ mkCom x + + +data Changed a = Changed + | Unchanged a + deriving (Eq, Show) + +makeChangedState :: (Eq a, AutoForm action comH builder satCxt com) => + comH a + -> builder (comH (Changed a)) +makeChangedState comIO + = do st <- state Changed + let updateState = do cur <- getValue st + new <- getValue comIO + case (cur, new) of + (Unchanged x, x') | x /= x' -> setValue st Changed + _ -> return () + addListener updateState comIO + postponeAction (getValue comIO >>= setValue st . Unchanged) + return st + +class TypePresentation a (action :: * -> *) (comH :: * -> *) (builder :: * -> *) (satCxt :: * -> *) (com :: * -> *) + where + -- |Constructs a component. The default implementation just calls + -- 'defaultCom'. Override this if you want other behaviour. + mkCom :: (AutoForm action comH builder satCxt com, Sat (satCxt a)) => + a + -> com a + mkCom = defaultCom + +instance (AutoForm action comH builder satCxt com) => TypePresentation Bool action comH builder satCxt com +instance (AutoForm action comH builder satCxt com) => TypePresentation Int action comH builder satCxt com +instance (AutoForm action comH builder satCxt com) => TypePresentation Char action comH builder satCxt com +instance (AutoForm action comH builder satCxt com) => TypePresentation Float action comH builder satCxt com +instance (AutoForm action comH builder satCxt com) => TypePresentation Double action comH builder satCxt com +instance (TypePresentation a action comH builder satCxt com) => TypePresentation [a] action comH builder satCxt com +instance (TypePresentation a action comH builder satCxt com) => TypePresentation (Maybe a) action comH builder satCxt com +instance (TypePresentation a action comH builder satCxt com + ,TypePresentation b action comH builder satCxt com) => TypePresentation (a, b) action comH builder satCxt com +instance (TypePresentation a action comH builder satCxt com + ,TypePresentation b action comH builder satCxt com + ,TypePresentation c action comH builder satCxt com) => TypePresentation (a, b, c) action comH builder satCxt com + + + +-- |The methods of this class shows simple dialogs. E.g. dialogs which +-- do not take a component as input. +class (Monad m) => SimpleDialog (m :: * -> *) where + errorDialog :: String -- ^Title + -> String -- ^Message + -> m () + infoDialog :: String -- ^Title + -> String -- ^Message + -> m () + +{- Design challengers with the SimpleDialog class + +We would have like to bring all windows-creating functions from +AutoForms into SimpleDialog (and rename SimpleDialog to +Dialog). However, it proved very difficult. + +If a function, like window, takes a component as input we are in +trouble. 'window' function: + + window :: Menu a state m String + -> component a state + -> m () + +Note that the m in the window function is not always the same as the m +in (SimpleDialog m). It is the same if we call window from within +'WxM', but if we call within (ActionM val state m) it is different. Thus: + + window :: (AutoForm component satCxt m') + => Menu a state m' String + -> component a state + -> m () + +but then we are claiming that for any (AutoForm component satCxt m') +we can with any monad m, implementing SimpleDialog, then we can bring +up a window. For example if we are within (ActionM val state WxM) then: + + window [] <CForm component> + +should bring up a window (WxM is the WxForm monad). + + +* AutoForm superclass for SimpleDialog + +Another option would be to let AutoForm be a superclass to +SimpleDialog. But then type for SimpleDialog get a lot more +complex. Also then we get undecidable instances, as we will have: + +class (AutoForm component satCxt m, Monad m') => Foo ... + +but component we will only be on the left side of => . + +* Another option requireing undecidable instances + +-- class (AutoForm component satCxt m, Monad m') +class (Monad m, Monad m') + => Foo (component :: * -> * -> *) (satCxt :: * -> *) (m :: * -> *) (m' :: * -> *) + | m -> component, m -> satCxt + , satCxt -> component, satCxt -> m + , component -> satCxt, component -> m + , m' -> component, m' -> satCxt, m' -> m where + + window' :: Menu a state m String + -> component a state + -> m' () + +Requires {-# OPTIONS -fallow-undecidable-instances #-} +instance (Foo component satCxt m m) => Foo component satCxt m (ActionM val state m) where + window' menu com = lift $ window' menu com + +From CFormImplementation: +instance AF.Foo Com SatCxt Parent Parent where + window' = error "Not implemented yet" + +From WxFormImplementation: +instance AF.Foo EC SatCxt WxM WxM where + window' menu com = AF.window menu com + + +From AutoForm: +class (Monad m, SimpleDialog m, Foo component satCxt m m) + => AutoForm (component :: * -> * -> *) (satCxt :: * -> *) (m :: * -> *) + + -} + + +{- To make it easier to make TypePresentation instances we could: + +-- Here we just need the actual type being spelized: +instance PresentationAll Name where + mkCom'''' p = AF.label "My name for Name" $ AF.defaultCom p + +class PresentationAll a where + mkCom'''' :: (AutoForm component satCxt parent, Sat (satCxt a)) + => a -> (component a ()) +instance (PresentationAll a) => TypePresentation a component satCxt parent where + mkCom = mkCom'''' +instance PresentationAll a where + mkCom'''' = defaultCom + +-} + +-- Rest is comments and design rationale + +{- Design rationale for TypePresentation I (call order) + +We could let ???Form call TypePresentation in stead of the other way +around. Have tried it with the following signature: + +TypePresentation.customize :: component a () -> component a () + +that would make a call to mkCom unneccesary and thus make it simpler +for the user. However that gave some problems. First of all the call +to alterType were complicated. We either had to change customize's +signature to: + +:: a -> component a () -> component a () + +the first parameter is the value that the GUI should show +initially. Or we could add this value to the component. + +Another problem is that the user must call alterType first and then +apply the result of it to other function, as the functionions called +before it will be ignored. This seems untransparent to the user, and +could easily lead to mistakes. The current solution with explicit +calls to mkCom, seems more transparent to the user. + + +A solution could be to fill out some datatype, like: + +data Customize { label :: String, + limit :: [(a -> Bool, String)], + alterType :: (a -> b, b -> a) + } + +Then the ???Form instance could apply the different functions, in the +order it needed to. The fields could be set with some custom setter +function, supplied by the AutoForms library. + +This however seems to limit the flexibility (harder to add new +features - I think) of the library, and I am not ready for that yet. + +_Conclusion_ + +I think I will wait with a solution, untill I have analyzed the +situation more. More experience implementing the library will properly +also help. + +-} + + +{- Design rationale for TypePresentation II: + +There is an awful lot of parameters to TypePresentation. It is +becoming a burden and its makes it harder to change existin +code. Could we not have something like: + +class (AutoForm context component satCxt parent) => TypePresentation a context where + +as context decides all other variables of AutoForm? + +It seems to be related to this email: +http://article.gmane.org/gmane.comp.lang.haskell.cafe/7995/match=functional+dependenices+in+class+declarations +. Note however, that he seems to turn his functional dependency the +wrong way. But that is not important as we get the same problem no +matter what way we turn the dependency. + +So, I guess, it is a no. + +Another way to avoid the many type parameters, is to not have the four +last parameters at all - Just "TypePresentation a". This is not a good +solution either, as it proved difficult (maybe impossible) to use the +alterType function. See Examples/MVCExample. Another problem is that +it becomes impossible to specify that a certain TypePresentation only +applies to some instance of AutoForm and not all instances of +AutoForm. That is, we could not specialize differently for WxForm and +ConsoleForms. + +-} + +{- form & modalForm + +* requirements + * form needs to return imediately, so that the program do not stall + * The user can make an extra thread, but this is cumbersome. + And the point of using non-modal is that the user interface do not stall. + * Should form has a modal option + * can just use showModal. If he really needs to compute something he can start an extra + thread. It is cumbersome, but OK since it would seldom happen. + * Should there be a no-parent option? + * When would that be useable? + + +-} + +{- Limit function: design idea + +If limit's first parameter was not a function from a -> IO Bool, but +rather some small internal language we could translate it to +JavaScript or other languages. This could facilitate an AJAX like +experience in a WebForms instance of AutoForms. + +Another way for this to happen, would be if we could somehow look at +the compile tree. I think somebody was working on that. Who, where, or +how, I cannot remember. + +-} + +{- ---------------------------- Trash ------------------------ -} +{- +class (Monad m, SimpleDialog m) + => AutoForm (component :: * -> * -> *) (satCxt :: * -> *) (m :: * -> *) + ... + -- |Makes a display-only component. + display :: (Sat (satCxt a)) => a -> component a () + -- |Makes a component which cannot be seen. + hidden :: (Sat (satCxt a)) => a -> component a () -- FIXME: Consider if this is really useable? + ... +-} + +{- +class ( Monad action + , Monad builder + ) + => DelayedAction (action :: * -> *) (comH :: * -> *) (builder :: * -> *) + | builder -> comH + where + postponeAction :: action () -> builder () + button :: String -> action () -> builder (comH ()) + addTimer :: Int -> action () -> builder () + executeProcess :: String + -> (Int -> action ()) -- ^OnEnd :: ExitCode + -> (String -> action ()) -- ^OnStandardInput :: String + -> (String -> action ()) -- ^OnStandardError :: String + -> builder () +class Action + setEnabled :: comH a -> Bool -> action () + closeWindow :: action () +class Builder + addListener :: action () -> comH a -> builder (comH a) + + state :: s -> builder (comH s) +class StaticCom + limit :: (Show a) => + (a -> IO Bool) -- ^The limit. + -> String -- ^Error message displayed to the GUI-user, if the limit is violated. + -> com a + -> com a + -- |Labels a component. This label will usually be displayed to the GUI-user. + label :: String -- ^The label. + -> com a + -> com a + maybe giveFocus ... for know + +maybe toStaticCom :: (dynamicCom a -> dynamicCom b) -> staticCom a -> staticCom b + + => AutoForm (action :: * -> *) (comH :: * -> *) (builder :: * -> *) (satCxt :: * -> *) (com :: * -> *) + -- |Creates a static component from an arbitrary type + staticCom :: (Sat (satCxt a)) => a -> com a + -- | Takes all components encapsulated in a builder monad + -- and packages them in a static component (staticCom). + builderToStaticCom :: builder (comH a) -- ^The ... + -> com a + -- |Encapsulates a static component in a builder monad. + addStaticCom :: com a -> builder (comH a) +The two below can be implemented from staticCom and addStaticCom: + dynamicCom :: (Sat (satCxt a)) => a -> builder (comH a) + dynamicCom' :: (Sat (satCxt a)) => a -> (com a -> com b) -> builder (comH b) + +class Presentable a -- like builderCom + present :: a -> builder (ComHandle a) -- maybe encapsulate +instance Presentable (Com a) +instance (Sat (satCxt a)) => Presentable a + +-- Maybe: +class (Monad m) => Runable builder m where + runBuilder :: String -> builder a -> m () -- currently the WxM.startI function +or maybe just keep it in each instance. How else will the compiler know which instance to choose? +Therefore, properly just rename startI to runWxBuilder. + +-} + diff --git a/src/Graphics/UI/AF/General/CustomTypes.hs b/src/Graphics/UI/AF/General/CustomTypes.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/AF/General/CustomTypes.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances + , MultiParamTypeClasses, TemplateHaskell, UndecidableInstances #-} + + +{- Who made what? + +Shelarcy made the AFDirectoryPath extension. + +The rest is made by Mads Lindstrøm. + +-} + +-- |Contain types which implementations of the 'AutoForm' class should handle specially. +module Graphics.UI.AF.General.CustomTypes + ( AFFilePath(..) + , AFDirectoryPath(..) + , afOpenFile + ) +where + + +import Graphics.UI.AF.General.MySYB + +import IO +import Graphics.UI.AF.General.AutoForm + +-- |Contains a file system pointer in form of a text string, just like FilePath. +-- A new type were needed as FilePath is just a type synonym (for string). Otherwise, +-- It would be impossible to behave in one way for strings and another for file paths. +newtype AFFilePath = AFFilePath { filePath :: String } deriving (Show, Read, Eq) + +-- |afOpenFil is the counterpart of IO.openFile, just using AFFilePath +-- instead. +afOpenFile :: AFFilePath -> IOMode -> IO Handle +afOpenFile (AFFilePath path) mode = openFile path mode + +-- Note that, a list of AFFilePath should probably also behave +-- specially, like being able to select multiple files in a file +-- requester dialog. But this is not implemented yet. + +$(derive [''AFFilePath]) + +instance (AutoForm action comH builder satCxt com) => TypePresentation AFFilePath action comH builder satCxt com + +-- |AutoForms directory path -type. A new type is needed for the same +-- reason it was needed for 'AFFilePath'. +newtype AFDirectoryPath = AFDirectoryPath { directoryPath :: String } deriving (Show, Read, Eq) + +instance (AutoForm action comH builder satCxt com) => TypePresentation AFDirectoryPath action comH builder satCxt com +$(derive [''AFDirectoryPath]) diff --git a/src/Graphics/UI/AF/General/Dialog.hs b/src/Graphics/UI/AF/General/Dialog.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/AF/General/Dialog.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE FunctionalDependencies, KindSignatures, MultiParamTypeClasses #-} + +module Graphics.UI.AF.General.Dialog + ( Dialog(..) + ) +where + +import Graphics.UI.AF.General.AutoForm +import Graphics.UI.AF.General.Misc +import Graphics.UI.AF.General.MySYB + +class ( AutoForm action comH builder satCxt com ) + => Dialog (action :: * -> *) (comH :: * -> *) (builder :: * -> *) (satCxt :: * -> *) (com :: * -> *) + | action -> comH, comH -> builder, builder -> satCxt, satCxt -> com, com -> action + where + settingsDialog :: ( TypePresentation a action comH builder satCxt com + , Eq a, Sat (satCxt a)) + => a + -> Maybe (a -> action ()) + -- ^Apply. However, this parameter may be ignored by a given instance. + -- If Nohting then there will be no apply button. + -> (a -> action ()) -- ^OK + -> action () -- ^Canel + -> action () + settingsDialog = settingsDialogImpl + -- |Creates a blocking window. + blockingWindow :: TypePresentation b action comH builder satCxt com => + ((Maybe b -> action ()) -> com a) + -> action (Maybe b) + -- |Blocking version of 'settingsDialog'. + blockingSettingsDialog :: ( TypePresentation a action comH builder satCxt com + , Sat (satCxt a)) + => a + -> action (Maybe a) + blockingSettingsDialog = blockingSettingsDialogImpl + + +settingsDialogImpl :: ( AutoForm action comH builder satCxt com + , TypePresentation a action comH builder satCxt com + , Sat (satCxt a), Eq a) => + a + -> Maybe (a -> action ()) + -> (a -> action ()) + -> action () + -> action () +settingsDialogImpl com apply ok cancel = window $ builderToCom $ + do entryHandle <- builderCom com + chState <- makeChangedState entryHandle + case apply of + Nothing -> return () + Just apply' -> do button "Apply" (getValue entryHandle >>= apply') >>= enabledWhen chState (== Changed) + return () + button "OK" (getValue entryHandle >>= ok) >>= enabledWhen chState (== Changed) + button "Canel" cancel + return entryHandle + +blockingSettingsDialogImpl :: ( AutoForm action comH builder satCxt com + , Dialog action comH builder satCxt com + , TypePresentation a action comH builder satCxt com + , Sat (satCxt a)) => + a + -> action (Maybe a) +blockingSettingsDialogImpl com = blockingWindow (builderToCom . helper) where + helper stop + = do entryHandle <- builderCom com + button "OK" (getValue entryHandle >>= stop . Just) + button "Canel" (stop Nothing) + diff --git a/src/Graphics/UI/AF/General/EditFile.hs b/src/Graphics/UI/AF/General/EditFile.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/AF/General/EditFile.hs @@ -0,0 +1,47 @@ +module Graphics.UI.AF.General.EditFile + ( editFile + ) +where + +import Graphics.UI.AF.General.AutoForm +import Graphics.UI.AF.General.Misc +import Graphics.UI.AF.General.MySYB +import Graphics.UI.AF.General.CustomTypes + +import Control.Monad.Error + +editFile :: ( Read t, AutoForm wxAct comH builder satCxt com + , Sat (satCxt t), Eq t, Show t, MonadIO builder, MonadIO wxAct + , TypePresentation t wxAct comH builder satCxt com) => + FilePath + -> t + -> builder () +editFile filename defaultValue = + do entry <- fromFile filename defaultValue (errorDialog "Error loading file") + entryHandle <- builderCom entry -- FIXME: should be changed to mkCom laiter + chState <- makeChangedState entryHandle + + let saveFile = do x <- getValue entryHandle + liftIO $ writeFile filename $ show x + setValue chState $ Unchanged x + button "Save" saveFile >>= enabledWhen chState (== Changed) + -- FIXME: missing saveAs button + button "Quit" closeWindow + return () + +-- |Tries to read a file from disc. If an error occurs the 'onError' function is called. +fromFile :: (MonadIO m, Read a) + => FilePath -- ^The file to read. + -> a -- ^Default value. + -> (String -> m ()) -- ^This is called if an error occurs while trying to read the file. + -> m a +fromFile filename defaultValue onError = + do entry <- liftIO $ (do entryText <- readFile filename + e <- readIO entryText + return $ Right e + ) `catch` (return . Left . show) + case entry of + Left "" -> return defaultValue + Left s -> do onError s + return defaultValue + Right x -> return x diff --git a/src/Graphics/UI/AF/General/InstanceCreator.hs b/src/Graphics/UI/AF/General/InstanceCreator.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/AF/General/InstanceCreator.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses + , OverlappingInstances, UndecidableInstances #-} + +{-# OPTIONS -fglasgow-exts #-} + +module Graphics.UI.AF.General.InstanceCreator + ( createInstance, createInstance' + , gInstanceCreatorCtx, GInstanceCreator, gGenUpTo + ) + +where + +import Graphics.UI.AF.General.MySYB +-- import Graphics.UI.AF.General.CustomTypes + +-- The function below is heavily inspired of "Test-data generator" +-- example from SYB2 paper. +-- +-- |Creates an instance of a Haskell type. For this to work the compiler +-- must be able to deduce the type from the callee's context. +createInstance :: GInstanceCreator a => Maybe a +createInstance = helper 1 -- Zero newer returns anything + where + --helper :: Int -> a + helper 8 = Nothing -- Make sure we do not to loop eternally or for a very, very long time. + helper x = if (length generate) == 0 + then helper (x+1) + else Just $ head generate + where + generate = (gGenUpToD dict) x + +-- |Like 'createInstance' excepts it uses a phantom type to elicit the +-- correct type to return. +createInstance' :: GInstanceCreator a + => a -- ^Not evaluated. Only used to force the right type. + -> Maybe a +createInstance' _ = createInstance + + +-- |The dictionary type for the GInstanceCreator class +data GInstanceCreatorD a = GInstanceCreatorD { gGenUpToD :: Int -> [a] } + +-- |Instantiation of the Sat class +instance GInstanceCreator a => Sat (GInstanceCreatorD a) + where dict = GInstanceCreatorD { gGenUpToD = gGenUpTo } + +-- |The context for generic autoform +gInstanceCreatorCtx :: Proxy GInstanceCreatorD +gInstanceCreatorCtx = error "gInstanceCreatorCtx" + +-- |Used to creates instances of data types +class (Data GInstanceCreatorD a) => GInstanceCreator a + where + -- This code is heavily inspired of the "Test-data generator" example in the SYB2 paper. + + -- |Generates all possible instances of a, while using no more + -- than n levels of recursion. Each subtype requires another level + -- of recursion. For example: + -- + -- Branch (Branch Leaf 17) (Leaf 3) + -- + -- would require 4 levels of recursion. One for the first branch, + -- one for second branch, one for the left Leaf, and one for the + -- Int (the seventeen). The right part of the first branch (Left + -- 3) would be done in two recursions. + gGenUpTo :: Int -- ^ Max number of recursions + -> [a] + gGenUpTo 0 = [] + gGenUpTo d = result + where + -- Recurse per possible constructor + result = concat (map recurse cons) + -- Retrieve constructors of the requested type + -- cons :: (Data ctx a) => ctx() -> [Constr] + cons = case dataTypeRep ty of + AlgRep cs -> cs + IntRep -> [mkIntConstr ty 0] + FloatRep -> [mkFloatConstr ty 0] + StringRep -> [mkStringConstr ty "f"] -- Also used for char, so we changed foo to f + -- Or Maybe SYB3/Instances.hs should be changed + NoRep -> [] -- error "InstanceCreator: NoRep" + where + ty = dataTypeOf gInstanceCreatorCtx (head result) + -- Find all terms headed by a specific Constr + recurse :: Constr -> [a] + recurse = fromConstrM gInstanceCreatorCtx ((gGenUpToD dict) (d-1)) + +{- +instance GInstanceCreator Bool +instance GInstanceCreator Int +instance GInstanceCreator Char +instance GInstanceCreator Float +instance GInstanceCreator Double +instance (GInstanceCreator a) => GInstanceCreator (Maybe a) +instance (GInstanceCreator a) => GInstanceCreator [a] +instance GInstanceCreator AFFilePath +instance GInstanceCreator AFDirectoryPath +-} + +instance (Data GInstanceCreatorD a) => GInstanceCreator a + diff --git a/src/Graphics/UI/AF/General/Misc.hs b/src/Graphics/UI/AF/General/Misc.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/AF/General/Misc.hs @@ -0,0 +1,47 @@ +module Graphics.UI.AF.General.Misc + ( enabledWhen, enabledWhen2 + , affect + ) +where + +import Graphics.UI.AF.General.AutoForm + +enabledWhen + :: AutoForm action comH builder satCxt com => + comH b + -> (b -> Bool) + -> comH a + -> builder (comH a) +enabledWhen source ableFun target + = do let setEnabled' = getValue source >>= setEnabled target . ableFun + addListener setEnabled' source + postponeAction setEnabled' + return target + +enabledWhen2 + :: AutoForm action comH builder satCxt com => + comH b + -> comH c + -> (b -> c -> Bool) + -> comH a + -> builder (comH a) +enabledWhen2 source1 source2 ableFun target + = do let setEnabled' = do source1' <- getValue source1 + source2' <- getValue source2 + setEnabled target $ ableFun source1' source2' + addListener setEnabled' source1 + addListener setEnabled' source2 + postponeAction setEnabled' + return target + +affect + :: AutoForm action comH builder satCxt com => + (a -> b) + -> comH a + -> comH b + -> builder () +affect f source target + = do let affectTarget = getValue source >>= setValue target . f + addListener affectTarget source + postponeAction affectTarget + diff --git a/src/Graphics/UI/AF/General/MySYB.hs b/src/Graphics/UI/AF/General/MySYB.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/AF/General/MySYB.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE ExistentialQuantification, KindSignatures, ScopedTypeVariables #-} + +{-| + This module reexports the SYB3 library. + + It also makes some extensions to SYB3, namely getFieldFun and + setFieldFun. +-} + +module Graphics.UI.AF.General.MySYB + ( module Data.Generics.SYB.WithClass.Basics + , module Data.Generics.SYB.WithClass.Derive + , constructors + , getFieldFun, setFieldFun + , gToString + ) +where + +import Data.Generics.SYB.WithClass.Basics +import Data.Generics.SYB.WithClass.Derive +import Data.Generics.SYB.WithClass.Instances() + +import Maybe + +{- *** My SYB Helper functions *** -} +constructors :: (Data ctx a) => Proxy ctx -> a -> [Constr] +constructors ctx x = dataTypeConstrs $ dataTypeOf ctx x + + + + +-- |A get field fun: parent -> child +data GetFieldHelper = forall a. Typeable a => GetFieldHelper a +getFieldFun :: forall a m (ctx :: * -> *). + (Typeable a, Data ctx m) => + Proxy ctx -> Int -> m -> a +getFieldFun ctx i m = case gmapQ ctx (\x -> GetFieldHelper x) m !! i of + (GetFieldHelper x) -> fromJust $ cast x + +-- |A set field fun: parent -> child -> parent +setFieldFun :: forall m a (ctx :: * -> *). + (Data ctx m, Typeable a) => + Proxy ctx -> Int -> m -> a -> m +setFieldFun ctx i m a = snd $ gfoldl ctx k z m + where + k (0, c) _ = (-1, (c . fromJust . cast) a) + k (i', c) x = (i'-1, c x) + z c = (i, c) + +-- |Function is similar to show, except that strings are shown without escaped \". +gToString :: (Show a, Typeable a) => a -> String +gToString x = case (cast x) of + (Just y) -> y + (Nothing) -> show x + diff --git a/src/Graphics/UI/AF/General/PriLabel.hs b/src/Graphics/UI/AF/General/PriLabel.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/AF/General/PriLabel.hs @@ -0,0 +1,110 @@ +module Graphics.UI.AF.General.PriLabel + ( PriLabel(..) + , Priority(..) + , badConstrLabel, goodConstrLabel, fieldNameLabel, userDefinedLabel + , bestLabel, humanizeLabel + , defaultLabel, labelless + ) +where + +import Char + +-- |Prioritized label. If two 'PriLabel' can be used for some +-- component, then the one with highest priority is used. +data PriLabel = PriLabel { priority :: Priority, labelString :: String } deriving (Show) +-- |The label priority. +data Priority = BadConstr | GoodConstr | FieldName | UserDefined deriving (Show, Ord, Eq) + +badConstrLabel, goodConstrLabel, fieldNameLabel, userDefinedLabel :: String -> PriLabel +badConstrLabel label = PriLabel BadConstr label +goodConstrLabel label = PriLabel GoodConstr label +fieldNameLabel label = PriLabel FieldName label +userDefinedLabel label = PriLabel UserDefined label + +-- |Creates a default (lowest priority) PriLabel +defaultLabel :: String -> PriLabel +defaultLabel label = PriLabel BadConstr label + +labelless :: PriLabel +labelless = defaultLabel "" + +-- |Choose label with highest priority. If equal then choose the left +-- |(first parameter) label. +bestLabel :: PriLabel -> PriLabel -> PriLabel +bestLabel left@(PriLabel priL _) right@(PriLabel priR _) + | priL >= priR = left + | otherwise = right + +-- |Humanized label strings, by turning labels like "someLabelName" +-- into "Some label name". +humanizeLabel :: PriLabel -> PriLabel +humanizeLabel (PriLabel pri label) = PriLabel pri label' + where + label' | pri == UserDefined || elem ' ' label -- safegaurd against accidentally calling humanizeLabel twice + = label + | elem '_' label = (first toUpper . nonCamel) label + | otherwise = camelCase label + -- humanizing non-camel case identifiers + nonCamel [] = [] + nonCamel ('_':[]) = [] + nonCamel (x:[]) = x:[] + nonCamel ('_':x:[]) = ' ':toUpper x:[] + nonCamel (x:y:[]) = x:nonCamel [y] + nonCamel ('_':x:y:xs) + | isUpper y = ' ':toUpper x:nonCamel (y:xs) + | otherwise = ' ':toLower x:nonCamel (y:xs) + nonCamel (x:xs) = x:nonCamel xs + -- + camelCase xs = (first toUpper . drop 1 . seperateWords [] . first toUpper) xs + seperateWords cs [] = cs + seperateWords [] (x:xs) + | isUpper x = ' ':seperateWords [x] xs + | otherwise = x:seperateWords [] xs + seperateWords (c:[]) (x:xs) + | isUpper x = seperateWords (c:x:[]) xs + | otherwise = toLower c:x:seperateWords [] (xs) + seperateWords (cs) (x:xs) + | isUpper x = seperateWords (cs ++ [x]) xs + | otherwise = (init cs) ++ ' ':(toLower $ last cs):x:seperateWords [] xs + first _ [] = [] + first f (x:xs) = (f x):xs + + +{- + +testHumanizeLabel :: IO () +testHumanizeLabel = putStr $ unlines $ map testLabel tests + where + testLabel (actual, expected) + = let (PriLabel _ result) = humanizeLabel (PriLabel GoodConstr actual) + in (if result == expected then "True" else "Error (" ++ result ++ ")") ++ ": " ++ actual ++ " " ++ expected + tests = [-- Underscore upper case + ("download_Site_URI", "Download site URI") + , ("default_Contents_Author", "Default contents author") + , ("default_Contents_License", "Default contents license") + , ("foobar_ASD_Foo", "Foobar ASD foo") + -- Underscore lower case + , ("download_site", "Download site") + , ("foobar_ASD_foo", "Foobar ASD foo") + -- Camel case + , ("FooBarSky", "Foo bar sky") + , ("FooBASky", "Foo BA sky") + , ("foobarASDFoo", "Foobar ASD foo") + -- + , ("a", "A") + , ("A", "A") + , ("", "") + , ("FOO", "FOO") + ] ++ map (\x -> (x,x)) [ "Download FOO site", "Download something", "Foo" ] + +-} + +{- Rest is trash: + + replace _ _ [] = [] + replace this with (x:xs) + | this == x = with:replace this with xs + | otherwise = x:replace this with xs + + -- | elem '_' label = (first toUpper . replace '_' ' ') label +-} diff --git a/src/Graphics/UI/AF/PolyCommand.hs b/src/Graphics/UI/AF/PolyCommand.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/AF/PolyCommand.hs @@ -0,0 +1,44 @@ +-- |Used to make shell-like command, however with graphical interface. +-- In the Future it should gracefully use console mode, when no +-- graphical display is available. +module Graphics.UI.AF.PolyCommand + ( polyCommand + , module Graphics.UI.AF.WxFormAll + ) +where + +import Graphics.UI.AF.WxFormAll +import Graphics.UI.AF.CForm.CFormAll + +import System + +polyCommand :: (ECCreator a, GCForm a) => + a + -> (a -> IO String) + -> IO () +polyCommand input action + = do available <- isDisplayAvailable + let command' proxy = command proxy (mkCom input) action + if available + then command' wxParentProxy + else command' consoleParentProxy + + +-- We can also use System.Info.os, which returns the OS name, but +-- just returns linux. I would rather have a functions like isPosix and isMSWindows. +-- +-- We could also use some compile flags to destinguish OS'es. + +-- getEnv throws isDoesNotExistError +-- +-- WARNING: This function has only been tested on Linux. +isDisplayAvailable :: IO Bool +isDisplayAvailable = do isWindows <- isSet "SystemDrive" + if isWindows + then return True + else isSet "DISPLAY" -- We are geussing it's an Posix-OS. + + where + isSet environmentVariable = catch (do getEnv environmentVariable + return True + ) (\_ -> return False) diff --git a/src/Graphics/UI/AF/WxForm.hs b/src/Graphics/UI/AF/WxForm.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/AF/WxForm.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE FlexibleContexts #-} + +-- |Import this module to use the WxHaskell instance of AutoForms (called WxForm) +module Graphics.UI.AF.WxForm + ( module Graphics.UI.AF.General + , module Graphics.UI.AF.WxForm.WxList + , EC, ECCreator + , wxParentProxy + , SatCxt + -- * GUI-layout of EC types + , layoutAs, singleColumn, dualColumn, singleRow, reverseGuis + , finalDepth + , Parent(Parent) + -- * Lifting + , liftIO, WxM.io + -- * ComIO handling + , G.join2 + -- * From WxHaskell + , Wx.start + , startWx + , WxAct, ComH, WxM, ECCreatorD + ) +where + +import Graphics.UI.AF.WxForm.WxFormImplementation as AF +import Graphics.UI.AF.WxForm.WxList +import Graphics.UI.AF.WxForm.WxFilePath() +import Graphics.UI.AF.WxForm.WxMaybe() +import Graphics.UI.AF.WxForm.EditorComponent(layoutAs, singleColumn, dualColumn, singleRow) +import Graphics.UI.AF.WxForm.WxM as WxM +import qualified Graphics.UI.AF.WxForm.GenericEC as G + +import Graphics.UI.AF.General +import Control.Monad.Trans + +import qualified Graphics.UI.WX as Wx + +-- |Tells WxForm to try to keep the GUI as small as possible. It will +-- only work from this 'EC' and it's sub-components (sub-ECs). +finalDepth :: EC a -> EC a +finalDepth ec = updateWxM (AF.withMaxDepth (const 0)) ec + +startWx :: AutoForm WxAct ComH WxM SatCxt EC => String -> WxM a -> IO () +startWx = startI diff --git a/src/Graphics/UI/AF/WxForm/ComIO.hs b/src/Graphics/UI/AF/WxForm/ComIO.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/AF/WxForm/ComIO.hs @@ -0,0 +1,385 @@ +{-# LANGUAGE ExistentialQuantification, FlexibleContexts, FlexibleInstances + , GeneralizedNewtypeDeriving, MultiParamTypeClasses, RankNTypes + , ScopedTypeVariables, UndecidableInstances #-} + +-- |The ComIO type +module Graphics.UI.AF.WxForm.ComIO + ( io + -- * ComIO + , ComIO ( pickGetVal, pickSetVal, pickAppendVal + , pickGetEnabled, pickSetEnabled, pickAddLimit) + , mkComIO + -- * Component construction + , staticComIO + , SetOn (..) + , guiComM, GuiComHelper(..), AddGui + , getterSetterComIO + -- * Handle limits + , makeLimitVar, addToLimitVar, checkLimits, tellUserOfIllegalValue + , Limit, LimitResult(..) + -- * Listener monad and signaling of change + , OnChangeVars, makeOnChangeVar + , OnChange(addListener, setParentListener) + , unsafeSignalChange, unsafeRunListenerM, ListenerM + , module Control.Monad.RecursiveObserver + ) + +where + +import Graphics.UI.WX (Var, varCreate, varGet, varSet) +import qualified Graphics.UI.WX as Wx + +import qualified Graphics.UI.AF.General.AutoForm as AF + +import Graphics.UI.AF.WxForm.GUI + +import qualified Random + +import Control.Monad.Writer +import Control.Monad.RecursiveObserver +import System.IO.Unsafe(unsafeInterleaveIO) + +io :: MonadIO m => IO a -> m a +io = liftIO + +instance AF.Valued ComIO where + mapValue old2NewFun new2OldFun comIO = + comIO { pickGetVal = do val <- pickGetVal comIO + return $ old2NewFun val + , pickSetVal = \newVal -> do oldVal <- pickGetVal comIO + pickSetVal comIO (new2OldFun oldVal newVal) + , pickAppendVal = + case pickAppendVal comIO of + Nothing -> Nothing + Just f' -> Just (\newVal -> -- we use unsafeInterleaveIO as the oldVal is not always needed + -- and as it defies the purpose of the appendVal optimization. + do oldVal <- unsafeInterleaveIO $ pickGetVal comIO + f' (new2OldFun oldVal newVal) + ) + , pickAddLimit = \limitFun -> pickAddLimit comIO + (\oldVal -> limitFun (old2NewFun oldVal)) + } + noValue comIO = comIO { pickGetVal = return () + , pickSetVal = const $ return () + , pickAppendVal = Just $ const $ return () + , pickAddLimit = const $ return () + } + +instance (MonadIO m, Observable OnChangeVars m) => AF.ValuedAction ComIO m where + getValue = io . pickGetVal + setValue comIO x = do io $ pickSetVal comIO x + signalChange (pickOnChangeVar comIO) + nonRecursiveSetValue comIO x + = whenNotVisited (pickOnChangeVar comIO) (AF.setValue comIO x) + appendValue comIO xs = + maybe (do value <- AF.getValue comIO + AF.setValue comIO (value `mappend` xs) + ) (\f -> io $ f xs) (pickAppendVal comIO) + + +data LimitResult = Rejected String + | Accepted + +type Limit a = a -> IO LimitResult + +-- |Component IO-commands +data ComIO a = ComIO + { pickGetVal :: IO a + , pickSetVal :: a -> IO() + , pickAppendVal :: Maybe (a -> IO()) -- ^Appends a value to the component. This only + -- makes sense for some component. E.g. list components. + , pickOnChangeVar :: OnChangeVars + , pickGetEnabled :: IO Bool -- ^Tells the callee if the GUI for the component is enabled. + -- Even if the component is disabled, a programmer can + -- still call 'pickSetVal', 'pickAppendVal', and + -- 'pickSetState'. It is only for the GUI-user the + -- component is enabled or disabled. + , pickSetEnabled :: Bool -> IO() -- ^Sets the enabledness of a component. See also + -- 'pickGetEnabled'. + , pickAddLimit :: Limit a -> IO() -- ^Adds a limit check to the component. + } + +mkComIO :: (MonadIO m) => + IO a + -> (a -> IO ()) + -> OnChangeVars + -> IO Bool + -> (Bool -> IO ()) + -> (Limit a -> IO ()) + -> m (ComIO a) +mkComIO getVal setVal ocVar getEnabled setEnabled addLimit + = do return $ ComIO getVal setVal Nothing ocVar getEnabled setEnabled addLimit + + +-- ComIO constructor functions ----------------------------------------- + +-- | Returns a ComIO type, which just stores values when setVal is +-- called and retrieves values when getVal is called. It should be +-- used when no GUI can be created for a type. +staticComIO :: (MonadIO m) => a -> m (ComIO a) +staticComIO val = + do valVar <- io $ varCreate val + let getVal = varGet valVar + setVal x = do varSet valVar x + return () + getterSetterComIO getVal setVal + +getterSetterComIO :: (MonadIO m) => IO a -> (a -> IO()) -> m (ComIO a) +getterSetterComIO getVal setVal = + do enableVar <- io $ varCreate True + ocVar <- io $ makeOnChangeVar + let getEnabled = varGet enableVar + setEnabled x = do varSet enableVar x + return () + addLimit _ = return () + mkComIO getVal setVal ocVar getEnabled setEnabled addLimit + + +-- |IO-commands helped in the construction of components. Is used by +-- function that construct components via guiComM. +data GuiComHelper a = GuiComHelper + { testInputParm' :: (SetOn -> a -> IO ()) + , readGuiOnGetValParm' :: (Eq a) => IO a -> IO () + } + +type AddGui builder com a = forall w. Wx.Window w -> GUI -> ComIO a -> builder (com a) + +guiComM :: (Show a, MonadIO builder) => + AddGui builder com a + -> Maybe (a -> a -> Bool) + -> a + -> (a -> IO ()) + -> Wx.Window w + -> GUI + -> builder (com a, GuiComHelper a) +guiComM addGui equals value setGuiValue wid gui = + do limitVar <- io $ makeLimitVar + lastValVar <- io $ varCreate value + onChangeVar <- io $ makeOnChangeVar + enabledVar <- io $ varCreate True + onGetValVar <- io $ varCreate (varGet lastValVar) + -- + let whenChanged newValue thenDo = + case equals of + Nothing -> thenDo + Just eq -> do oldVal <- varGet lastValVar + when (not $ oldVal `eq` newValue) + thenDo + testInput setOn newValue = + do res <- checkLimits limitVar newValue + case (setOn, res) of + (SetOnAccept, Rejected msg) -> do tellUserOfIllegalValue msg + (SetOnAccept, Accepted) -> whenChanged newValue $ + do varSet lastValVar newValue + setGuiValue newValue + signalGuiChange onChangeVar + (SetOnReject, Rejected msg) -> do tellUserOfIllegalValue msg + setGuiValue =<< varGet lastValVar + (SetOnReject, Accepted) -> whenChanged newValue $ + do varSet lastValVar newValue + signalGuiChange onChangeVar + setValue x = do res <- checkLimits limitVar x + case res of + Rejected _ -> return () -- FIXME: should probably log something + Accepted -> varSet lastValVar x >> setGuiValue x + readGuiOnGetVal f = + do varSet onGetValVar $ + do x <- f + res <- checkLimits limitVar x + case res of + Rejected msg -> do tellUserOfIllegalValue msg + xOld <- varGet lastValVar + setGuiValue xOld + return xOld + Accepted -> do varSet lastValVar x + signalGuiChange onChangeVar + return x + getVal = do f <- varGet onGetValVar + f + setEnabled enabled = do varSet enabledVar enabled + Wx.set wid [ Wx.enabled Wx.:= enabled ] + + com <- mkComIO getVal setValue onChangeVar (varGet enabledVar) setEnabled (addToLimitVar limitVar) + >>= addGui wid gui + io $ setGuiValue value + return ( com, GuiComHelper testInput readGuiOnGetVal) + + +-- Calls setVal when the value is acceptet by limit function or call +-- setVal when value is rejected by limit function. +data SetOn = SetOnAccept | SetOnReject + + +-- Limit handeling ------------------------------------------------------- +type LimitVar a = Var [Limit a] + +-- |Constructs a 'LimitVar' with no limits in it. +makeLimitVar :: IO (LimitVar a) +makeLimitVar = varCreate [] + +-- |Adds a limit to a 'LimitVar' +addToLimitVar :: LimitVar a -> Limit a -> IO () +addToLimitVar limitVar limit = + do limits <- varGet limitVar + varSet limitVar (limits ++ [limit]) + +checkLimits :: (Show a) + => LimitVar a + -> a -- ^The new value + -> IO LimitResult -- ^The result of the limit check +checkLimits limitVar newValue + = do limits <- varGet limitVar + callLimitChecks limits + where + callLimitChecks [] = return Accepted + callLimitChecks (limit:limits) = + do res <- limit newValue + case res of + Rejected _ -> return res + Accepted -> callLimitChecks limits + +-- |Use this function to tell the GUI-user that he violated some limit. +tellUserOfIllegalValue :: String -> IO() +tellUserOfIllegalValue = putStrLn + +-- On Change handeling --------------------------------------------------------- +newtype EventID = EventID Int + deriving (Random.Random, Show, Eq) + +newtype ListenerM a = ListenerM { listenerM' :: ListenerT EventID IO a } + deriving (Monad, MonadIO, MonadListener, Observable OnChangeVars, Observable (ComIO b)) + +instance Observable OnChangeVars (ListenerT EventID IO) where + whenNotVisited = whenNotVisitedHelper (io . varGet . pickEventID) + visit = visitHelper (\oc eid -> do varSet (pickEventID oc) eid) + signalChange = signalChangeHelper (\oc -> listenerM' $ + do listeners' <- io $ getListeners oc + parentListeners <- io $ getParentListener oc + sequence_ (listeners' ++ [parentListeners]) + ) + +instance Observable (ComIO a) (ListenerT EventID IO) where + whenNotVisited o = whenNotVisited (pickOnChangeVar o) + visit o = visit (pickOnChangeVar o) + signalChange o = signalChange (pickOnChangeVar o) + +{- Detecting eternal recursion + +if signalGuiChange are called X number of times with Y ms, then we +properly have an eternal recursion and we could stop transmititng the +call until Z ms has passed. + +-} + +signalGuiChange :: OnChange oc => + oc + -> IO() +signalGuiChange oc = do runListenerTWithNewEID (listenerM' $ signalChange oc) + join $ getWxHaskellListener oc + +unsafeSignalChange :: OnChange oc => + oc + -> IO() +unsafeSignalChange = signalGuiChange + +unsafeRunListenerM :: ListenerM a -> IO a +unsafeRunListenerM m = runListenerTWithNewEID (listenerM' m) + + +data OnChangeVars = OnChangeVars + { pickEventID :: Var EventID + , pickListeners :: Var [ListenerM ()] + , pickParent :: Var (ListenerM ()) + , pickWxHaskellListeners :: Var (IO ()) + } + +-- |Constructs an 'OnChangeVar' with no listeners. +makeOnChangeVar :: IO OnChangeVars +makeOnChangeVar = + do eid <- varCreate (EventID 0) + listeners <- varCreate [] + parent <- varCreate (return ()) + wxHaskell <- varCreate (return ()) + return $ OnChangeVars + { pickEventID = eid + , pickListeners = listeners + , pickParent = parent + , pickWxHaskellListeners = wxHaskell + } + +class Observable oc ListenerM => OnChange oc where + addListener :: oc -> ListenerM () -> IO() + addListener oc action = do listeners' <- getListeners oc + setListeners oc (listeners' ++ [action]) + + getListeners :: oc -> IO [ListenerM ()] + setListeners :: oc -> [ListenerM ()] -> IO() + + getParentListener :: oc -> IO (ListenerM ()) + setParentListener :: oc -> ListenerM () -> IO() + + getWxHaskellListener :: oc -> IO (IO ()) + setWxHaskellListener :: oc -> IO () -> IO () + +instance OnChange OnChangeVars where + getListeners oc = varGet $ pickListeners oc + setListeners oc actions = varSet (pickListeners oc) actions + + getParentListener oc = varGet $ pickParent oc + setParentListener oc action = varSet (pickParent oc) action + + getWxHaskellListener oc = varGet $ pickWxHaskellListeners oc + setWxHaskellListener oc action = + varSet (pickWxHaskellListeners oc) action + +instance OnChange (ComIO a) where + getListeners oc = getListeners (pickOnChangeVar oc) + setListeners oc actions = setListeners (pickOnChangeVar oc) actions + + getParentListener oc = getParentListener (pickOnChangeVar oc) + setParentListener oc action = setParentListener (pickOnChangeVar oc) action + + getWxHaskellListener oc = getWxHaskellListener (pickOnChangeVar oc) + setWxHaskellListener oc actions = setWxHaskellListener (pickOnChangeVar oc) actions + +{- ------------- Making ComIO instances of some WxHaskell classes ------------ -} + +instance Wx.Commanding (ComIO a) where + command = Wx.newEvent "Commanding" getter setter + where getter = getWxHaskellListener + setter = setWxHaskellListener + +instance Wx.Able (ComIO a) where + enabled = Wx.newAttr "Able" (\w -> pickGetEnabled w) (\w -> pickSetEnabled w) + +instance Wx.Valued ComIO where + value = Wx.newAttr "Value" (\w -> pickGetVal w) (\w -> pickSetVal w) + +-------------------------------------------------------------------------------- + + +{- Some difficult to understand design rationale: + +In ComIO, instead of the GUI type we could just use (Layout, +PriLabel). When needing GUI boxes (is needed when having types with +multiply children), they could be created directly by genericCom. However, +we need the extra GUI type to ensure that only non top-level types +gets surrounded by a box. We cannot have this in the generic function, +as the generic function needs to act the same for all types. Note, +that sometimes we do want top-level types surrounded by boxes, but not +always. + +Threading a (isTopLevel :: Bool) is ugly and not even a solution, as +the top-level can be: + + data Foo = Foo Bar; data Bar = Bar Int String + +and then no box around Foo but box around Bar. But as Foo should be +ignored as it only has one child we still have box around the top +level. Not what we intended. Now, there may be a workaround for that, +but it all gets very ugly. + +Furtermore, to get tab order and shortcuts, we need to know all the +labels at once. Which, again requires the extra step. +-} + diff --git a/src/Graphics/UI/AF/WxForm/EditorComponent.hs b/src/Graphics/UI/AF/WxForm/EditorComponent.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/AF/WxForm/EditorComponent.hs @@ -0,0 +1,221 @@ +{-# LANGUAGE FlexibleInstances, FunctionalDependencies, KindSignatures + , MultiParamTypeClasses, RankNTypes + , ScopedTypeVariables, TypeOperators #-} + +module Graphics.UI.AF.WxForm.EditorComponent + ( EC + , MakeEC, runEC + , mkEC, builderToCom', makeGUIlessEC + , InnerEC, guilessInnerEC, innerECWithGui + -- + , SetOn(..) + -- + , updateGui, updateComIO, updateWxM + , layoutAs + -- + , module Graphics.UI.AF.WxForm.GUI + , module Graphics.UI.AF.WxForm.WxM + , extEC + , chooseEC + , getComIO + , addCustomGui, addCustomGuiNoEquals, ComIO.GuiComHelper(..) + , addGui, guilessInnerEC', TypeLift(..) + ) +where + +import Graphics.UI.WX hiding (close, command, enabled, entry, item, items, label, menu, panel, Parent, value, widget, Widget, window) +import qualified Graphics.UI.WX as WX + +import Graphics.UI.AF.WxForm.ComIO as ComIO +import Graphics.UI.AF.WxForm.GUI +import Graphics.UI.AF.WxForm.WxM + +import qualified Graphics.UI.AF.General.AutoForm as AF +import Graphics.UI.AF.General.PriLabel +import Graphics.UI.AF.General.MySYB + +import Control.Monad(liftM) + +type MakeEC a = a -> EC a + +-- |Component type for the Wx instance of AutoForm +newtype EC a = EC (WxM (InnerEC a)) +data InnerEC a = WithGui (ComIO a) Widget GUI + | NoGui (ComIO a) + +getComIO :: InnerEC a -> ComIO a +getComIO (WithGui cio _ _) = cio +getComIO (NoGui cio) = cio + +class TypeLift (from :: * -> *) (to :: * -> *) | to -> from where + typeLift :: (from a -> from b) -> (to a -> to b) + +instance TypeLift ComIO InnerEC where + typeLift f (WithGui cio wid gui) = WithGui (f cio) wid gui + typeLift f (NoGui cio) = NoGui (f cio) + +instance Labeled (EC a) where + updateLabel f ec = updateGui ec (updateLabel f) + +instance Labeled (WxM (ComIO a, Widget, GUI)) where + updateLabel f wxi = do (comIO, wid, gui) <- wxi + return (comIO, wid, updateLabel f gui) + +instance LabelGetter (InnerEC a) where + guiLabel (WithGui _ _ gui) = guiLabel gui + guiLabel _ = defaultLabel "" + +instance AF.Valued EC where + mapValue old2NewFun new2OldFun ec + = updateComIO ec (return . AF.mapValue old2NewFun new2OldFun) + noValue ec = updateComIO ec (return . AF.noValue) + +instance AF.Action WxAct InnerEC where + closeWindow = getCloseWindow >>= io + setEnabled innerEC enabled + = liftIO $ pickSetEnabled (getComIO innerEC) enabled + giveFocus innerEC = withWidget innerEC focusOn where + withWidget :: InnerEC a -> (forall w. Window w -> IO b) -> WxAct () + withWidget (NoGui _) _ + = return () + withWidget (WithGui _ (Widget widget) _) f + = do liftIO $ f widget + return () + +instance AF.Valued InnerEC where + mapValue old2NewFun new2OldFun = typeLift (AF.mapValue old2NewFun new2OldFun) + noValue = typeLift AF.noValue + +-- instance (AF.Valued ComIO m) => AF.Valued InnerEC m where +instance AF.ValuedAction InnerEC WxAct where + getValue innerEC = AF.getValue (getComIO innerEC) + setValue innerEC x = AF.setValue (getComIO innerEC) x + nonRecursiveSetValue innerEC x + = AF.nonRecursiveSetValue (getComIO innerEC) x + appendValue innerEC xs = AF.appendValue (getComIO innerEC) xs + +addCustomGui + :: (Eq a, Show a) => + a + -> (a -> IO ()) + -> Window w + -> GUI + -> WxM (InnerEC a, GuiComHelper a) +addCustomGui value setGuiValue wid gui = + guiComM addGui (Just (==)) value setGuiValue wid gui + +-- |Like `addCustomGui`, but do check if a value set by the user is +--differen than the last value. Thus events can be triggered even +--if no change were actually made. Thus, the callee should make sure +--that does not happen. +addCustomGuiNoEquals + :: (Show a) => + a + -> (a -> IO ()) + -> Window w + -> GUI + -> WxM (InnerEC a, GuiComHelper a) +addCustomGuiNoEquals value setGuiValue wid gui = + guiComM addGui Nothing value setGuiValue wid gui + +addGui :: AddGui WxM InnerEC a +addGui w gui comIO = + do comIO' <- comIOAddGui w gui comIO + return $ WithGui comIO' (toWidget w) gui + + +-- |Constructs an 'EC', but leaving most of the work to the callee. +mkEC :: WxM (InnerEC a) -> + EC a +mkEC = EC + +builderToCom' :: WxM (InnerEC a) -> EC a +builderToCom' wxi + = mkEC $ do (cio, wid, gui) <- extractGui (liftM getComIO wxi) + innerECWithGui cio wid gui + +-- |Constructs a EC type without a GUI. It should be used when no GUI +-- can be created for a type. +makeGUIlessEC :: String -- ^If non-empty then this string will displayed + -- on standard output. It should be an error message + -- explaining why the GUI could not be created. + -> a + -> EC a +makeGUIlessEC msg x = EC $ guilessInnerEC msg x + +guilessInnerEC :: String -- ^If non-empty then this string will displayed + -- on standard output. It should be an error message + -- explaining why the GUI could not be created. + -> a + -> WxM (InnerEC a) +guilessInnerEC msg x = do io $ when (msg /= "") (putStrLn msg) + cio <- staticComIO x + return $ NoGui cio + +innerECWithGui :: ComIO a + -> Widget + -> GUI + -> WxM (InnerEC a) +innerECWithGui cio wid gui = return $ WithGui cio wid gui + +guilessInnerEC' :: ComIO a + -> InnerEC a +guilessInnerEC' = NoGui + +runEC :: forall a. EC a -> WxM (ComIO a, Maybe (Widget, GUI)) +runEC (EC wxi) = + do wxi' <- wxi + return $ case wxi' of + NoGui comIO + -> (comIO, Nothing) + WithGui comIO widget gui + -> (comIO, Just (widget, updateLabel humanizeLabel gui)) + +-- |Used to update the ComIO functions +updateComIO :: EC a -> (ComIO a -> IO (ComIO b)) -> EC b +updateComIO (EC wxi) transformer = EC $ + do wxi' <- wxi + case wxi' of + NoGui comIO + -> do comIO' <- io $ transformer comIO + return $ NoGui comIO' + WithGui comIO widget gui + -> do comIO' <- io $ transformer comIO + return $ WithGui comIO' widget gui + +updateWxM :: (forall b. WxM b -> WxM b) -> EC a -> EC a +updateWxM f (EC wxi) = EC (f wxi) + +updateGui :: EC a -> (GUI -> GUI) -> EC a +updateGui (EC wxi) transformer = EC $ + do wxi' <- wxi + return $ case wxi' of + NoGui comIO + -> NoGui comIO + WithGui comIO widget gui + -> WithGui comIO widget (transformer gui) + +-- |Attach a new layout manager to an 'EC'. Layout manager such as +-- 'dualColumn' or 'singleRow' can be used. +layoutAs :: LayoutManager -> EC a -> EC a +layoutAs layoutManager ec = updateGui ec (layoutGuiAs layoutManager) + +-- | Chooses either the EC onTrue or the EC onFalse, based on which of +-- them that has a GUI. If both have then prefer decides which one to +-- use. If neither has a run-time error is made. +chooseEC :: EC a + -> EC a + -> EC a +chooseEC (EC firstChoice) (EC secondChoice) = + EC $ do first <- firstChoice + case first of + gui@(WithGui _ _ _) -> return gui + NoGui _ -> secondChoice + +extEC :: (Typeable b, Typeable a) => (a -> EC a) + -> (b -> EC b) -> a -> EC a +extEC fn spec_fn arg = case gcast (M spec_fn) of + Just (M spec_fn') -> spec_fn' arg + Nothing -> fn arg +newtype M a = M (a -> EC a) + diff --git a/src/Graphics/UI/AF/WxForm/GUI.hs b/src/Graphics/UI/AF/WxForm/GUI.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/AF/WxForm/GUI.hs @@ -0,0 +1,220 @@ +-- |The GUI type and helper functions +module Graphics.UI.AF.WxForm.GUI + ( -- *GUI type + GUI (Single, SelfContained, Buttons) + -- ** GUI construting function + , containerGUI, singleGui + + -- *Layout + , LayoutManager + , layoutGuiAs, dualColumn, singleColumn, singleRow, reverseGuis + , rootGui + + -- * WxHaskell's Layout type + -- + -- |Note that WxHaskell's Layout type is different from this + -- modules Layout type. + , boxedLayout, unboxedLayout, labeledLayout, nonEditableLayout + + -- * Misc + , module Graphics.UI.AF.General.PriLabel, Labeled(..), LabelGetter(..) + ) + +where + + +import qualified Graphics.UI.WX as WX +import Graphics.UI.AF.General.PriLabel + +import List (partition) +import Maybe + +-- |Contains a GUI-component. Used by 'EC'. +data GUI = Single WX.Layout PriLabel -- ^A GUI with a single GUI-component. + | SelfContained (String -> IO WX.Layout) PriLabel -- ^Here the GUI handles the header itself. + | Many LayoutManager [GUI] PriLabel -- ^A GUI with sub-GUI-components. + | Buttons WX.Layout -- ^A list of buttons. + +-- SelfContained needs the IO, as WxEnumeration needs it. We need to +-- wait with setting the label, until after creating the GUI data, but +-- enumeration needs to do `set enum [ text := ... ]`. We need to wait +-- with setting the label, as it may be changed by functions like +-- `humanizeLabel`. +-- +-- For the other constructors it is not a problem, as the GUI itself +-- do not set the label. The label is set by other means by other +-- functions. E.g. see `labeledLayout`. + +class Labeled a where + updateLabel :: (PriLabel -> PriLabel) -> a -> a + setLabel :: PriLabel -> a -> a + setLabel lbl = updateLabel (const lbl) + +class LabelGetter a where + -- |Returns the label of a 'GUI' + guiLabel :: a -> PriLabel + +instance LabelGetter GUI where + guiLabel (Single _ lbl) = lbl + guiLabel (SelfContained _ lbl) = lbl + guiLabel (Many _ _ lbl) = lbl + guiLabel _ = defaultLabel "" + +instance Labeled GUI where + updateLabel f (Single lay lbl) = (Single lay $ f lbl) + updateLabel f (SelfContained lay lbl) = (SelfContained lay $ f lbl) + updateLabel f (Many manager guis lbl) = (Many manager guis $ f lbl) + updateLabel _ gui = gui + +instance Labeled PriLabel where + updateLabel f lbl = f lbl + +buttonsLabel :: PriLabel +buttonsLabel = defaultLabel "Press buttons" + +-- |Constructs a GUI using Single-constructor. +singleGui :: (WX.Widget w) => PriLabel -> w -> (WX.Layout -> WX.Layout) -> GUI +singleGui label guiElement toWidget + = Single (toWidget $ WX.widget guiElement) label + +-- |Constructs a GUI using Many-constructor. +containerGUI :: [GUI] -> PriLabel -> GUI +containerGUI guis label = Many singleColumn guis label + + +-------------------------------------------------------------------------------- + +-- |Used to layout GUIs. If a GUI contains multiple components, the +-- layout manager arranges these components. Also see 'singleRow' or +-- 'singleColumn'. +type LayoutManager = [(WX.Layout, Maybe String)] -> WX.Layout + +{- +defaultLayout :: LayoutManager +defaultLayout [] = error "GUI.defaultLayout: Must have at least one member of the list." +defaultLayout layoutsAndLabels = + singleColumn $ mergeButtons layoutsAndLabels where + mergeButtons +-} + +-- FIXME: Consider using caption in stead of WX.label below: +-- Puts one or more Layouts in a column, without any heading (label). +singleColumn :: LayoutManager +singleColumn [] = error "GUI.singleColumn: Must have at least one member of the list." +singleColumn layoutsAndLabels = + let (withLabels, withoutLabels) = partitionWidgets layoutsAndLabels + isEmpty xs = (length xs) == 0 + in WX.column 10 $ + (if isEmpty withLabels + then [] + else [WX.grid 20 10 withLabels] + ) + ++ withoutLabels + +-- |Arranges all gui components (widgets) in a row. +singleRow :: LayoutManager +singleRow [] = error "GUI.singleRow: Must have at least one member of the list." +singleRow layoutsAndLabels = +{- + let (withLabels, withoutLabels) = partitionWidgets layoutsAndLabels + in WX.row 10 $ + (concat withLabels) + ++ withoutLabels +-} + let labelWidgets (lay, Just name) = [WX.label name, lay] + labelWidgets (lay, _) = [lay] + in WX.row 10 $ concatMap labelWidgets layoutsAndLabels + +reverseGuis :: LayoutManager -> LayoutManager +reverseGuis manager layoutsAndLabels = + manager $ reverse layoutsAndLabels + + +partitionWidgets :: [(WX.Layout, Maybe String)] -> ([[WX.Layout]], [WX.Layout]) +partitionWidgets layoutsAndLabels = + let sortedWidgets = partition (isJust . snd) layoutsAndLabels + withLabels = map (\(lay, name) -> (lay, fromJust name)) (fst sortedWidgets) + withoutLabels = map fst (snd sortedWidgets) + in (map (\(lay,name) -> [WX.label name, lay]) withLabels, withoutLabels) + +-- |Arranges all gui components (widgets) in a column. +dualColumn :: LayoutManager +dualColumn [] = error "AutoForms.GUI.dualColumn: Must have at least one member of the list." +dualColumn [x] = singleColumn [x] +dualColumn xs = + let halfLength = length xs `div` 2 + in WX.row 35 (map singleColumn [take halfLength xs, drop halfLength xs]) + +-- |Attach a new layout manager to a 'GUI'. Layout manager such as +-- 'dualColumn' or 'singleRow' can be used. +layoutGuiAs :: LayoutManager -> GUI -> GUI +layoutGuiAs newManager (Many _ guis label) = Many newManager guis label +layoutGuiAs _ gui = gui + +-- |Special handling of a GUI if it is the top-most GUI. +rootGui :: GUI -> GUI +rootGui gui@(Many manager guis label) = + case last guis of + Buttons buttons -> let newButtons = Buttons (WX.column 10 [ WX.hfill $ WX.hrule 1 + , buttons + ]) + in Many manager (init guis ++ [newButtons]) label + _ -> gui +rootGui gui = gui + +----------------------------------------------------------------------------- + +-- |Return a WxHaskell Layout with no editable values. E.g. just a label. +nonEditableLayout :: IO (WX.Layout, String) +nonEditableLayout = return (WX.label "No editable values!", "No editable values!") + +-- |Turns a GUI into a WxHaskell Layout and a string (the label). The +-- layout has no box around it. +unboxedLayout :: GUI -> IO (WX.Layout, String) +unboxedLayout (Single lay label) = return (lay, labelString label) +unboxedLayout (SelfContained lay label) + = do lay' <- lay $ labelString label + return (lay', labelString label) +unboxedLayout (Many layoutManager [Many _ guis _] label) + = unboxedLayout $ Many layoutManager guis label -- FIXME: should we push manager and label downwards? +unboxedLayout (Many _ [gui] _) + = unboxedLayout gui +unboxedLayout (Many layoutManager guis label) + = do layoutsAndLabels <- mapM boxedLayout guis + return (layoutManager layoutsAndLabels, labelString label) +unboxedLayout (Buttons lay) = return (lay, labelString buttonsLabel) + +-- |Returns a WxHaskell Layout. If possible the WxHaskell Layout will +-- be construced with a WxHaskell label to the left of the 'GUI'-s +-- Layout. +labeledLayout :: GUI -> IO WX.Layout +labeledLayout (Single lay label) = return $ WX.row 5 [ WX.label (labelString label), lay ] +labeledLayout (SelfContained lay label) + = do lay' <- lay $ labelString label + return lay' +labeledLayout (Many layoutManager [Many _ guis _] label) + = labeledLayout $ Many layoutManager guis label -- FIXME: should we push manager and label downwards? + -- or maybe just use the best one +labeledLayout (Many _ [gui] _) + = labeledLayout gui +labeledLayout (Many layoutManager guis _) + = do layoutsAndLabels <- mapM boxedLayout guis + return (layoutManager layoutsAndLabels) +labeledLayout (Buttons lay) = return lay + +-- |Turns a GUI into a, possibly boxed, Layout. +-- A label will only be returned if GUI is of type Single. +-- If GUI's not of type Single, the Layout will contain its own label. +boxedLayout :: GUI -> IO (WX.Layout, Maybe String) +boxedLayout (Single lay label) = return (lay, Just $ labelString label) +boxedLayout (SelfContained lay label) + = do lay' <- lay $ labelString label + return (lay', Nothing) +boxedLayout (Many layoutManager [Many _ guis _] label) + = boxedLayout $ Many layoutManager guis label -- FIXME: should we push manager and label downwards? +boxedLayout (Many _ [gui] _) + = boxedLayout gui +boxedLayout (Many layoutManager guis label) + = do guis' <- mapM boxedLayout guis + return (WX.boxed (labelString label) (layoutManager guis'), Nothing) +boxedLayout (Buttons lay) = return (lay, Nothing) diff --git a/src/Graphics/UI/AF/WxForm/GenericEC.hs b/src/Graphics/UI/AF/WxForm/GenericEC.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/AF/WxForm/GenericEC.hs @@ -0,0 +1,415 @@ +{-# 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 diff --git a/src/Graphics/UI/AF/WxForm/WxConstants.hs b/src/Graphics/UI/AF/WxForm/WxConstants.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/AF/WxForm/WxConstants.hs @@ -0,0 +1,16 @@ +{-| + +In this module we keep different constants. Atleast some of them +will become user-setteable in the future. + +Currently, far from all the neccessary constants are in here. Alot of +them is unfortunately still hardcoded. + +-} +module Graphics.UI.AF.WxForm.WxConstants where + +-- |Maximum widt of a list item, measured in charectors +-- Must be no less than 5. +maxListWidth :: Int +maxListWidth = 80 + diff --git a/src/Graphics/UI/AF/WxForm/WxEnumeration.hs b/src/Graphics/UI/AF/WxForm/WxEnumeration.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/AF/WxForm/WxEnumeration.hs @@ -0,0 +1,109 @@ +module Graphics.UI.AF.WxForm.WxEnumeration + ( enumeration + ) +where + +import Graphics.UI.AF.WxForm.EditorComponent +import Graphics.UI.AF.General + +import Graphics.UI.WX hiding (value, entry, Parent, items, label) +import qualified Graphics.UI.WX as WX (items) +import List (findIndex) + +enumeration :: (Show a) + => String -- ^Label for the resulting 'EC'. + -> [(String, a, a -> Bool)] -- ^ValueName, Value, isValue + -> a -- ^The initial value in 'EC' a () (see return value) + -> EC a +enumeration typeName items y = mapValue intToA (const aToInt) $ builderToCom' $ + let enumSize = sum $ map (+ bottomAndSpaceSize) $ map length itemNames + bottomAndSpaceSize = 3 + in do comH <- if enumSize < 40 + then box Horizontal + else dropdownChoice + return comH + where + + intToA sel = itemValues !! sel + aToInt x = maybe 0 id (List.findIndex (== True) $ (map (\f -> f x) isItems)) + + enumLabel = PriLabel GoodConstr typeName + box direction = + do Parent w <- getPanel + r1 <- io $ radioBox w direction itemNames [ ] + let gui = (SelfContained (\label' -> do set r1 [text := label'] + return $ hfill $ widget r1 + ) + enumLabel + ) + addGuiAndOnSelect r1 gui + + dropdownChoice = + do Parent w <- getPanel + r1 <- io $ choice w [WX.items := itemNames] + let gui = singleGui enumLabel r1 hfill + addGuiAndOnSelect r1 gui + + addGuiAndOnSelect enum gui = + do (comH, parms) <- addCustomGui (aToInt y) (setSelection enum) enum gui + io $ set enum [ on select := get enum selection >>= (testInputParm' parms) SetOnReject ] + return comH + + setSelection enum x = set enum [ selection := x] + (itemNames, itemValues, isItems) = unzip3 items + + +{- Old enumeration (20071216) + +-- |Constructs an enumerated EC. The GUI will be a radioBox or a drop-down choice. +enumeration :: (Show a) + => String -- ^Label for the resulting 'EC'. + -> [(String, a, a -> Bool)] -- ^ValueName, Value, isValue + -> a -- ^The initial value in 'EC' a () (see return value) + -> EC a +enumeration typeName items y = builderToCom' $ + let enumSize = sum $ map (+ bottomAndSpaceSize) $ map length itemNames + bottomAndSpaceSize = 3 + in do comH <- if enumSize < 40 + then box Horizontal + else dropdownChoice + return comH + where + + enumLabel = PriLabel GoodConstr typeName + box direction = + do Parent w <- getPanel + r1 <- io $ radioBox w direction itemNames [ ] + let gui = (SelfContained (\label -> do set r1 [text := label] + return $ hfill $ widget r1 + ) + enumLabel + ) + foo r1 gui + + dropdownChoice = + do Parent w <- getPanel + r1 <- io $ choice w [WX.items := itemNames] + let gui = singleGui enumLabel r1 hfill + foo r1 gui + + foo enum gui = + do lastSelection <- io $ varCreate 0 + (comH, parms) <- addCustomGuiNoEquals y (setSelection enum lastSelection) enum gui + io $ set enum [ on select := do sel <- get enum selection + last <- varGet lastSelection + when (sel /= last) + (getSelection enum >>= (testInputParm' parms) SetOnReject) + ] + return comH + + getSelection enum = do sel <- get enum selection + return (itemValues !! sel) + setSelection enum lastSelection x = + maybe (return()) + (\i -> set enum [ selection := i] >> varSet lastSelection i ) + (List.findIndex (== True) $ (map (\f -> f x) isItems)) + (itemNames, itemValues, isItems) = unzip3 items + + +-} diff --git a/src/Graphics/UI/AF/WxForm/WxFilePath.hs b/src/Graphics/UI/AF/WxForm/WxFilePath.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/AF/WxForm/WxFilePath.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE RankNTypes, ScopedTypeVariables, TypeOperators #-} +{-# OPTIONS -fno-warn-orphans #-} + +module Graphics.UI.AF.WxForm.WxFilePath () where + +import qualified Graphics.UI.AF.General as AF + +import Graphics.UI.AF.WxForm.WxFormImplementation +import Graphics.UI.WX hiding (Widget, value, dialog) +import Graphics.UI.AF.General.CustomTypes +import Graphics.UI.AF.WxForm.WxList() -- must import as AFFilePath and AFDirectoryPath both contains a string ([Char]) + +{- Who made what? + +Shelarcy made the AFDirectoryPath and merged it with AFFilePath. + +Mads Lindstrøm made AFFilePath. + +-} + +instance ECCreator AFFilePath + where + makeEC x = dialogEC "file" filePath AFFilePath dialog' x + where + dialog' w _ = fileOpenDialog w True True "Choose file ..." [("Any file", ["*"])] "" "" + +instance ECCreator AFDirectoryPath + where + makeEC x = dialogEC "directory" directoryPath AFDirectoryPath dialog' x + where + dialog' w val = dirOpenDialog w True "Choose directory ..." val + +dialogEC :: (Eq a, Show a) => + String + -> (a -> String) + -> (String -> a) + -> (forall w. Window w -> String -> IO (Maybe String)) + -> MakeEC a +dialogEC typeName fromType toType dialog' value = AF.builderToCom $ + do Parent w <- getPanel + chooseB <- io $ button w [ text := "Choose " ++ typeName ++ " ..." + , enabled := True] + te <- io $ textEntry w [processEnter := True] + let gui = singleGui (badConstrLabel typeName) + (row 5 [hfill $ widget te, widget chooseB]) hfill + setGuiValue x = set te [ text := fromType x ] + setGuiEnable enable = + do set chooseB [ enabled := enable ] + set te [ enabled := enable ] + (comH, parms) <- addCustomGui value setGuiValue te gui + + io $ set te [ on focus := \_ -> + do get te text >>= testInputParm' parms SetOnReject . toType + propagateEvent + ] + io $ set chooseB [ on command := + do val <- get te text + maybePath <- dialog' w val + maybe (return()) (testInputParm' parms SetOnAccept . toType) + maybePath + ] + return $ typeLift (\cio -> cio { pickSetEnabled = setGuiEnable }) comH diff --git a/src/Graphics/UI/AF/WxForm/WxFormImplementation.hs b/src/Graphics/UI/AF/WxForm/WxFormImplementation.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/AF/WxForm/WxFormImplementation.hs @@ -0,0 +1,383 @@ +{-# 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) +-} + diff --git a/src/Graphics/UI/AF/WxForm/WxList.hs b/src/Graphics/UI/AF/WxForm/WxList.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/AF/WxForm/WxList.hs @@ -0,0 +1,285 @@ +{-# LANGUAGE FlexibleContexts, RecursiveDo, ScopedTypeVariables #-} +{-# OPTIONS -fno-warn-orphans #-} + +module Graphics.UI.AF.WxForm.WxList + ( multiLineEC, listECChooser + -- * List with sub-window for editing elements + ) +where + +{- Old - remove when WxM-refactoring is over. + + , listEC, ListAction + -- ** Functions to aid creating custom made actions + , oneToMany, one + -- ** Standard actions + , standardActions, moveItemDown, moveItemUp, editItem, addItem, removeItem + + -- * List with embedded elements + , listWithEmbeddedElement, ListActionEmbedded + -- ** Functions to aid creating custom made actions + , oneToManyEmbedded, oneEmbedded + -- ** Standard actions + , standardEmbeddedActions + , moveItemDownEmbedded, moveItemUpEmbedded, addItemEmbedded, removeItemEmbedded +-} + +import Graphics.UI.WX hiding (value, label, identity, enabled, item, items, Parent, parent, swap, when) +import qualified Graphics.UI.WX as WX (enabled, items) + +import Maybe(fromJust) +import List ( (\\), intersperse ) +import Control.Monad(when) + +import qualified Graphics.UI.AF.General as AF + +import Graphics.UI.AF.WxForm.WxFormImplementation +import Graphics.UI.AF.WxForm.ComIO +import Graphics.UI.AF.WxForm.EditorComponent + +-- |A type-specific case for lists. +instance (ECCreator a, Show a, Eq a, AF.GInstanceCreator a) => ECCreator [a] + where + --makeEC xs = (listEC standardActions `extEC` strings `extEC` listOfStrings) xs + makeEC xs = (listECChooser `extEC` strings `extEC` listOfStrings) xs + +{- +-- |Chooses between 'listWithEmbeddedElement' and 'listEC'. The choice +-- is by using the 'goDeeper' function. +listECChooser :: forall a. (ECCreator a, Show a, AF.GInstanceCreator a) + => [a] -> EC [a] () +listECChooser xs = chooseEC elemPriority header goDeeper embeddedList nonEmbeddedList xs + where + (elemPriority, header) = maybe (BadConstr, "A list") goodHeader (elementHeader (head xs)) + goodHeader (PriLabel pri label) = (pri, ("List of " ++ label)) + embeddedList = AF.comState AF.stateless . listWithEmbeddedElement' + nonEmbeddedList = AF.comState AF.stateless . addButtons standardActions . listEC +-} + +listECChooser :: forall a. (ECCreator a, Show a, Eq a, AF.GInstanceCreator a) + => MakeEC [a] +listECChooser xs = listWithEmbeddedElement' xs + +-- setLabel $ PriLabel GoodConstr "A list" +-- FIXME: better to name like "A list of ...". But this is currently (20071221) not possible. +-- We need to be able to set the label from within WxM. +listWithEmbeddedElement' :: forall a. (ECCreator a, Show a, Eq a, AF.GInstanceCreator a, ECCreator [a]) => + MakeEC [a] +listWithEmbeddedElement' xs = AF.builderToCom $ + do (list, selectedSt) <- listEC' xs + let anElement :: a + anElement = fromJust AF.createInstance + element <- AF.builderCom anElement + elementWhichIsEdited <- AF.state (Nothing::(Maybe Int)) + let setList ys = do selected <- AF.getValue selectedSt + AF.setValue list ys + AF.setValue selectedSt selected + update = + do selected <- AF.getValue selectedSt + elementWhichIsEdited' <- AF.getValue elementWhichIsEdited + ls <- AF.getValue list + l <- AF.getValue element + case (elementWhichIsEdited', selected) of + (Nothing, [i]) -> do AF.setValue elementWhichIsEdited $ Just i + AF.setValue element $ ls !! i + (Just i, [j]) -> do setList $ replace l i ls + when (i /= j) $ + do AF.setValue element $ ls !! j + AF.setValue elementWhichIsEdited $ Just j + (Just _, _) -> do AF.setValue elementWhichIsEdited Nothing + _ -> return () + AF.addListener update selectedSt + AF.addListener update element + AF.enabledWhen selectedSt (\x -> length x == 1) element + + let listButton name f = AF.button name (listAction f) + listAction f = + do selected <- AF.getValue selectedSt + values <- AF.getValue list + (values', selected', edited') <- f values selected + AF.setValue list values' + AF.setValue elementWhichIsEdited edited' + AF.setValue selectedSt selected' + let moveItemDown values [i] = return (swap i (i+1) values, [i+1], Just $ i+1) + moveItemDown values selected = return (values, selected, Nothing) + midEnabled [selected] ys = (length xs >= 2) && (selected + 1) < length ys + midEnabled _ _ = False + -- + moveItemUp values [i] = return (swap i (i-1) values, [i-1], Just $ i-1) + moveItemUp values selected = return (values, selected, Nothing) + miuEnabled [selected] ys = (length ys >= 2) && selected >= 1 + miuEnabled _ _ = False + -- + addItem values _ = + do AF.setValue element anElement + let newList = values ++ [anElement] + lastItem = length newList - 1 + return (newList, [lastItem], Just lastItem) + -- + deleteItem values selected = return (removeIndices values selected, [], Nothing) + diEnabled (_:_) = True + diEnabled _ = False + removeIndices ys indices = map (ys !!) $ [0..(length ys) - 1] \\ indices + listButton "Down" moveItemDown >>= AF.enabledWhen2 selectedSt list midEnabled + listButton "Up" moveItemUp >>= AF.enabledWhen2 selectedSt list miuEnabled + listButton "Add..." addItem + listButton "Delete" deleteItem >>= AF.enabledWhen selectedSt diEnabled + return list + +-- |A list ComJ and selected ComH. The list do not have any buttons. +listEC' :: forall a. (ECCreator a, Eq a, Show a, AF.GInstanceCreator a) + => [a] -> WxM (ComH [a], ComH [Int]) +listEC' xs = + mdo Parent w <- getPanel + listBox <- io $ multiListBox w [] + st <- getterSetterComIO (get listBox selections) setSelected + listVar <- io $ varCreate [] + let gui = SelfContained (\_ -> return $ fill $ widget listBox) labelless + signalChange' = -- A workaround - see below. + mdo t <- timer listBox [ interval := 100 + , on command := do unsafeSignalChange st + objectDelete t + ] + return() + setSelected ys = do unsetOnSelect -- otherwise we fire selection events + set listBox [ selections := ys ] + setOnSelect -- now we can fire selection events again + setOnSelect = set listBox [ on select := do signalChange' + propagateEvent + ] + unsetOnSelect = set listBox [ on select := propagateEvent ] + --setGuiEnable _ = return () + setGuiEnable enable = set listBox [ WX.enabled := enable ] + setGuiVal ys = do currentValue <- varGet listVar + when (ys /= currentValue) $ + do unsetOnSelect -- otherwise we fire selection events + set listBox [ WX.items := map (shortenLongLines . show) ys ] + varSet listVar ys + setOnSelect + shortenLongLines ys + = if length ys > maxListWidth + then take (maxListWidth - 4) ys ++ " ..." + else ys + + io $ setOnSelect + io $ set listBox [ -- The select-events is not enough. They do not see unselect events. + on mouse := \_ -> do signalChange' + propagateEvent + ] + (comH, _) <- addCustomGui xs setGuiVal listBox gui + return (comH, guilessInnerEC' st) + +-- |Replaces an item in a list. +replace :: a -- ^ The new item. + -> Int -- ^ Index (starting at 0) to replace. Must be less than the lists length. + -> [a] -> [a] +replace x index xs = take index xs ++ [x] ++ drop (index + 1) xs + +-- |Replaces an item in a list. +swap :: Int -- ^ First index (starting at 0) to swap. Must be less than the lists length. + -> Int -- ^ Second index (starting at 0) to replace. Must be less than the lists length. + -> [a] -> [a] +swap first second xs = + replace (xs !! second) first $ replace (xs !! first) second xs + +-------------------------------------------------------------------------------- + +-- |Constructs an 'EC' for single-line text string. +strings :: String -> EC String +strings xs = AF.builderToCom $ + do Parent w <- getPanel + te <- io $ textEntry w [ processEnter := True ] + let gui = singleGui (badConstrLabel "A text-string") te hfill + setGuiValue x = set te [ text := x ] + (comH, parms) <- addCustomGui xs setGuiValue te gui + io $ set te [ on focus := \_ -> do get te text >>= (testInputParm' parms) SetOnReject + propagateEvent + ] + return comH + +-- |Constructs an 'EC' for multi-line text string. +listOfStrings :: MakeEC [String] +listOfStrings xs = AF.mapValue myLines (const myUnlines) (multiLineEC $ myUnlines xs) + where + -- we cannot use the Preludes lines & unlines -function as: lines $ unlines xs != xs + myLines "" = [] + myLines ys = lines $ if last ys == '\n' + then ys ++ "\n" + else ys + myUnlines ys = concat $ intersperse "\n" ys + +-- |Constructs an 'EC' for multi-line text string. +multiLineEC :: MakeEC String +multiLineEC xs = AF.builderToCom $ + do Parent w <- getPanel + tc <- io $ textCtrl w [ processEnter := True ] + let gui = SelfContained (\l -> return $ boxed l (fill $ widget tc)) (PriLabel BadConstr "Text") + -- We could also make into an "ordinary" gui element as: + -- gui = singleGui label' tc fill + setGuiValue ys = set tc [ text := ys ] + (comH, parms) <- addCustomGui xs setGuiValue tc gui + io$ set tc [ on focus := \_ -> do get tc text >>= (testInputParm' parms) SetOnReject + propagateEvent + ] + io $ (readGuiOnGetValParm' parms) (get tc text) + -- FIXME: This is cheating as we do not make limit checks. + -- However, limit check would currently blow away performance for large + -- texts - even if no tests were actually performed. Thus we need + -- to redesign the limit checks. + return (typeLift (\cio -> cio { pickAppendVal = Just $ \ys -> do appendText tc ys }) comH) + + +{- + += Future enhancements that require WxHaskell changed = + +Custom sensitive popup menus are not implemented, as WxHaskell +support for them is rudimentary. Likewise, for double-clicking a menu +item. However, when they are easily possible we could have: + +* User definable popups + +* Remove & edit popups (double click could edit) + +* Sort according to column (also requires tabular format) + +It is not possible to click the same button more than once, without +moving the mouse pointer away from the button and then onto it +again. This is a WxHaskell or maybe GtkWxHaskell issue. + +Also the list should probably require CTRL to select multiple. This is +how multi-select lists normally function - for example a file +explorer. + += Other future enhancements = + +* More user control of layout + +Is this needed? + +* Could add tooltips explaining why diabled buttons, are disabled. + However, this could confuse the user, as it would be unconventionel. + Though the risk seems slight, as the presented text could explain + what is going on, for example: \"The button is disabled as + ...\". Furthermore, it would be almost completely unobtrusive. + +* zero 'Action' function (like the 'one' or 'oneToMany' functions) + +* Tabular form when practical +** Use wxGrid control - see Grid example in wxHaskell distribution. +*** Or use listCtrl +* The function listCtrlHitTest might be usefull for detecting on which item a double click occured + +-} + +{- Design rationale: + + If we split up String and [a], like: + instance ECCreator String where + ... + instance ECCreator [a] where + ... + then it requires overlapping instances. Therefore, we instead do as above and + merged String and [a] case. + +-} diff --git a/src/Graphics/UI/AF/WxForm/WxM.hs b/src/Graphics/UI/AF/WxForm/WxM.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/AF/WxForm/WxM.hs @@ -0,0 +1,233 @@ +{-# LANGUAGE ExistentialQuantification, GeneralizedNewtypeDeriving, RankNTypes #-} + +module Graphics.UI.AF.WxForm.WxM + ( io, Widget(..), toWidget, Parent(Parent) + , WxAct + , startI + , getParentI + -- + , WxM, runWxM, wxActToListenerM, liftWxActToListenerM + , getFrame, getPanel, withPanel + , liftIO, liftIO' + , withMaxDepth, getMaxDepth, goDeeper + , extractGui, comIOAddGui, getPostponedIO, postponeAction', getClose, getCloseWindow + , WxMGUI(..) + ) + +where + +import qualified Graphics.UI.AF.General.AutoForm as AF + +import Control.Monad.State +import Control.Monad.Reader +import Control.Monad.Writer +import Control.Monad.Fix +import Control.Monad.Trans(MonadIO, liftIO) + +import qualified Graphics.UI.WX as Wx +import qualified Graphics.UI.WXCore as Wx + +import Graphics.UI.AF.WxForm.ComIO +import Graphics.UI.AF.WxForm.GUI + +data Widget = forall w. Widget (Wx.Window w) + +toWidget :: forall w. Wx.Window w + -> Widget +toWidget w = Widget w + +data Parent = forall w. Parent (Wx.Window w) + +instance AF.SimpleDialog WxM where + infoDialog title msg = standardDialog' (\w -> Wx.infoDialog w title msg) + errorDialog title msg = standardDialog' (\w -> Wx.errorDialog w title msg) + +standardDialog' :: (forall w. Wx.Window w -> IO a) -> WxM a +standardDialog' dialog = + do Parent parent <- getFrame + x <- liftIO $ dialog parent + return x + +instance AF.SimpleDialog WxAct where + infoDialog title msg = standardDialog'' (\w -> Wx.infoDialog w title msg) + errorDialog title msg = standardDialog'' (\w -> Wx.errorDialog w title msg) + +standardDialog'' :: (forall w. Wx.Window w -> IO a) -> WxAct a +standardDialog'' dialog = + do (Parent parent) <- getParentI + x <- liftIO $ dialog parent + return x + +-- (Parent, closeWindow) +newtype WxAct a = WxAct { wxAct' :: ReaderT (Parent, IO()) ListenerM a } + deriving ( Monad, MonadIO, MonadListener, Observable (ComIO b) + , Observable OnChangeVars + ) + +liftWxActToListenerM :: ((forall b. WxAct b -> ListenerM b) -> IO a) -> WxM a +liftWxActToListenerM f = + do p <- getFrame + close <- getClose + let local' act = runReaderT (wxAct' act) (p, close) + liftIO $ f local' + + +getParentI :: WxAct Parent +getParentI = WxAct $ asks fst + +getCloseWindow :: WxAct (IO ()) +getCloseWindow = WxAct $ liftM snd ask + +wxActToListenerM :: WxAct a -> WxM (ListenerM a) +wxActToListenerM act = + do p <- getFrame + close <- getClose + return (runReaderT (wxAct' act) (p, close)) + +---------------------------- WxM ---------------------------------- +newtype WxM a = WxM { wxm' :: StateT WxMState (ReaderT WxMReader IO) a } + deriving (Monad, MonadIO, MonadFix) + +data WxMReader = WxMReader { frame' :: Parent -- ^The parent frame or dialog. + , close' :: IO () -- ^Closing the parent frame or dialog. + , panel' :: Parent -- ^The panel or frame the widgets should + -- be attached to, like `textCtrl panel []`. + , maxDepth' :: Int + } + +data WxMGUI = WxMGUI { wxmWidget :: Widget, wxmGui :: GUI } + +data WxMState = WxMState { wxmGuis :: [WxMGUI] + , wxmAfterCreationAction :: WxAct() + , wxmUpdateEnabledness :: IO () + , wxmGlobalEnabled :: Wx.Var Bool + } +initialWxMState :: IO WxMState +initialWxMState = do globalEnable <- Wx.varCreate True + return $ WxMState [] (return()) (return ()) globalEnable + +extractGui :: WxM (ComIO a) -> WxM (ComIO a, Widget, GUI) +extractGui wxmComIO + = testLiftWxM2WxM (wxmComIO >>= getGui) + where + testLiftWxM2WxM :: WxM a -> WxM a + testLiftWxM2WxM wxm = + do iState <- io $ initialWxMState + (x, st) <- WxM $ lift $ runStateT (wxm' wxm) iState + WxM $ modify (\y -> y { wxmAfterCreationAction + = do wxmAfterCreationAction y + wxmAfterCreationAction st + } + ) + return x + -- FIXME: no label + getGui :: ComIO a -> WxM (ComIO a, Widget, GUI) + getGui comIO + = do -- We handle all the encapsulated guis here, as enabledness should apply to them all. + -- And we _don't_ do listeners, getValue, setValue as they shold only apply to + -- the input ComIO (see argument wxmComIO). + WxMState { wxmGuis = guis + , wxmUpdateEnabledness = updateEnabledness + , wxmGlobalEnabled = globalEnabled + } <- WxM $ get + let com' = comIO { pickSetEnabled = \enabled -> do Wx.varSet globalEnabled enabled + updateEnabledness + } + case guis of + [] -> error "Cannot handle yet :(" + [gui] -> return (com', wxmWidget gui, wxmGui gui) + guis' -> return ( com', (wxmWidget $ head guis') + , containerGUI (map wxmGui guis') (PriLabel BadConstr "") + ) + +comIOAddGui :: AddGui WxM ComIO a +comIOAddGui w gui comIO = + do guis <- WxM $ gets wxmGuis + case (reverse guis, gui) of + ((WxMGUI wid (Buttons lay)):xs, Buttons lay') + -> setGuis $ reverse $ (WxMGUI wid (Buttons $ Wx.row 5 [lay, lay'])):xs -- FIXME: merge comio + _ -> setGuis (guis ++ [WxMGUI (toWidget w) gui]) + -- + enabledVar <- io $ Wx.varCreate True + globalEnabled <- WxM $ gets wxmGlobalEnabled + let updateEnabledness = do enabled <- liftM2 (&&) (Wx.varGet enabledVar) (Wx.varGet globalEnabled) + pickSetEnabled comIO enabled + WxM $ modify (\x -> x { wxmUpdateEnabledness = + do wxmUpdateEnabledness x + updateEnabledness + } + ) + return $ comIO { pickSetEnabled = \enable -> do Wx.varSet enabledVar enable + updateEnabledness + } + +defaultMaxDepth :: Int +defaultMaxDepth = 5 + + +startI :: String -> WxM a -> IO () +startI title wxq + = Wx.start $ do f <- Wx.frame [ Wx.text Wx.:= title ] + p <- Wx.panel f [] + (guis, afterCreationAction, _) <- execWxM wxq (Parent f) (Wx.close f) p + (lay, _) <- unboxedLayout $ containerGUI (map wxmGui guis) labelless + unsafeRunListenerM (runReaderT (wxAct' afterCreationAction) (Parent f, Wx.close f)) + Wx.set f [ Wx.layout Wx.:= Wx.container p $ Wx.fill lay ] + +-- newtype WxM a = WxM { wxm' :: StateT WxMState (ReaderT WxMReader IO) a } +execWxM :: WxM a -> Parent -> IO() -> Wx.Window w -> IO ([WxMGUI], WxAct(), a) +execWxM wxm parentWindow c panel = + do iState <- initialWxMState + (val, st) <- runReaderT (runStateT (wxm' wxm) iState) (WxMReader parentWindow c (Parent panel) defaultMaxDepth) + return (wxmGuis st, wxmAfterCreationAction st, val) + +runWxM :: WxM a -> Wx.Window w' -> IO() -> Wx.Window w -> IO a +runWxM wxm parentWindow c panel = + do iState <- initialWxMState + runReaderT (evalStateT (wxm' wxm) iState) (WxMReader (Parent parentWindow) c (Parent panel) defaultMaxDepth) + +liftIO' :: ((forall b. WxM b -> IO b) -> IO a) -> WxM a +liftIO' f = do Parent parentWindow <- getFrame + c <- getClose + Parent panel <- getPanel + let local' wxm = runWxM wxm parentWindow c panel + liftIO $ f local' + +setGuis :: [WxMGUI] -> WxM () +setGuis guis = WxM $ modify (\state -> state {wxmGuis = guis} ) + +getPostponedIO :: WxM (WxAct ()) +getPostponedIO = WxM $ gets wxmAfterCreationAction + +postponeAction' :: WxAct a -> WxM () +postponeAction' action = WxM $ modify addAction where + addAction state = state { wxmAfterCreationAction = wxmAfterCreationAction state >> (action >> return ()) } + +-- |Returns enclosing frame or dialog. +getFrame :: WxM Parent +getFrame = WxM $ ask >>= return . frame' + +-- |Returns an action to close the enclosing frame or dialog. +getClose :: WxM (IO()) +getClose = WxM $ ask >>= return . close' + +-- |Returns the panel or frame the widgets should be attached to, like `textCtrl panel []`. +getPanel :: WxM Parent +getPanel = WxM $ ask >>= return . panel' + +-- |Sets the panel or frame the widgets should be attached to, like `textCtrl panel []`. +withPanel :: Wx.Window w -> WxM a -> WxM a +withPanel panel wxm = WxM $ local (\x -> x { panel' = Parent panel }) $ wxm' wxm + +getMaxDepth :: WxM Int +getMaxDepth = WxM $ ask >>= return . maxDepth' + +withMaxDepth :: (Int -> Int) -> WxM a -> WxM a +withMaxDepth maxDepth wxm = + do currentMaxD <- getMaxDepth + WxM $ local (\x -> x { maxDepth' = maxDepth currentMaxD }) $ wxm' wxm + +goDeeper :: WxM Bool +goDeeper = do d <- getMaxDepth + return (d > 0) + diff --git a/src/Graphics/UI/AF/WxForm/WxMaybe.hs b/src/Graphics/UI/AF/WxForm/WxMaybe.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/AF/WxForm/WxMaybe.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS -fno-warn-orphans #-} + +module Graphics.UI.AF.WxForm.WxMaybe () where + +import Graphics.UI.AF.WxForm.WxFormImplementation +import Maybe +import Char +import Control.Monad(liftM) +import qualified Graphics.UI.AF.WxForm.EditorComponent as EC +import qualified Graphics.UI.AF.General as AF +import Graphics.UI.AF.WxForm.GenericEC + +instance (ECCreator a, Show a, AF.GInstanceCreator a) => ECCreator (Maybe a) + where + makeEC maybeX = + case (maybeX, AF.createInstance) of + (Just x, _) -> makeMaybe x maybeX + (_, Just x) -> makeMaybe x maybeX + _ -> makeGUIlessEC msg maybeX + where + msg = "Maybe's GUI could not be made as the subtype did not have a GUI." + +makeMaybe :: (Show (Maybe a), ECCreator a) => + a + -> MakeEC (Maybe a) +makeMaybe subX x = layoutAs (reverseGuis singleRow) $ AF.builderToCom $ + do val <- AF.builderCom subX + let lbl = case labelString (guiLabel val) of + "" -> "Has ..." + (l:ls) -> "Has " ++ [toLower l] ++ ls + justVal <- AF.addCom $ AF.label lbl $ AF.mkCom (isJust x) + AF.enabledWhen justVal (== True) val + liftM (AF.mapValue oldToNew newToOld) $ merge (justVal, val) + where + oldToNew (True, y) = Just y + oldToNew (False, _) = Nothing + newToOld _ (Just y) = (True, y) + newToOld (_, y) Nothing = (False, y) diff --git a/src/Graphics/UI/AF/WxFormAll.hs b/src/Graphics/UI/AF/WxFormAll.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/AF/WxFormAll.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses + , OverlappingInstances, UndecidableInstances #-} + +{- | + +Easier, but less safe version of WXForm. It includes WxForm, but also +makes every type an instance of 'TypePresentation' and +'GInstanceCreator'. + +This means that the module uses both -fallow-undecidable-instances and +-fallow-overlapping-instances. + +-} +module Graphics.UI.AF.WxFormAll + ( module Graphics.UI.AF.WxForm + ) +where + +import Graphics.UI.AF.WxForm + +import Graphics.UI.AF.WxForm.WxFormImplementation +import Graphics.UI.AF.General.AutoForm (TypePresentation) +import Graphics.UI.AF.General.InstanceCreator + +instance (Data ECCreatorD a, GInstanceCreator a, Show a, TypePresentation a WxAct ComH WxM ECCreatorD EC) + => ECCreator a +instance TypePresentation a action comH builder satCxt com +-- instance TypePresentation a context + +{- Instead of this unsafe choice, we could make our own 'derive +template and let it derive ECCreator, Show, ... + +But we would need to let the user use the SYB derive, so that he could +override stuff when needed. -}