packages feed

AutoForms (empty) → 0.4.0

raw patch · 66 files changed

+6078/−0 lines, 66 filesdep +arraydep +basedep +haskell98build-type:Customsetup-changed

Dependencies added: array, base, haskell98, mtl, syb-with-class, template-haskell, wx, wxcore

Files

+ AutoForms.cabal view
@@ -0,0 +1,101 @@+Name:           AutoForms+Version:        0.4.0+Copyright:      Mads Lindstrøm <mads_lindstroem@yahoo.dk>+License:        LGPL+License-file:   COPYRIGHT.txt+Author:         Mads Lindstrøm <mads_lindstroem@yahoo.dk>+Maintainer:     Mads Lindstrøm <mads_lindstroem@yahoo.dk>+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+
+ COPYRIGHT.txt view
@@ -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
+ Setup.lhs view
@@ -0,0 +1,4 @@+#! /usr/bin/runhaskell++> import Distribution.Simple+> main = defaultMain
+ src/Control/Monad/RecursiveObserver.hs view
@@ -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
+ src/Control/Monad/Unlift.hs view
@@ -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)+++
+ src/Examples/GhciGui/ECOptions.hs view
@@ -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.+-}
+ src/Examples/GhciGui/GhcProcess.hs view
@@ -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]+-}+
+ src/Examples/GhciGui/GhciGui.hs view
@@ -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 <path to ghc lib>"
+                            putStrLn "And your PATH=<location of GhciGui and GhcProcess>"
+    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
+
+-}
+ src/Examples/GhciGui/Makefile view
@@ -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
+ src/Examples/GhciGui/Options.hs view
@@ -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+                }+
+ src/Examples/GhciGui/Protocol.hs view
@@ -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)+
+ src/Examples/GhciGui/WxMultilinePerformanceTest.hs view
@@ -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 ]+
+ src/Examples/HCron/Daemon1st.hs view
@@ -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)
+ src/Examples/HCron/Daemon2ndRecurring.hs view
@@ -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)
+ src/Examples/HCron/Editor1st.hs view
@@ -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
+ src/Examples/HCron/Editor2nd.hs view
@@ -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)
+ src/Examples/HCron/Editor3rdLimit.hs view
@@ -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]
+ src/Examples/HCron/Editor4thRecurring.hs view
@@ -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]
+ src/Examples/HCron/Editor5thOutputWindow.hs view
@@ -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]
+ src/Examples/HCron/Editor6thCrontab.hs view
@@ -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
+ src/Examples/HCron/Entry1st.hs view
@@ -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"
+ src/Examples/HCron/Entry2ndRecurring.hs view
@@ -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"
+ src/Examples/HCron/Entry3rdCrontab.hs view
@@ -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)
+ src/Examples/HCron/Makefile view
@@ -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")
+ src/Examples/HCron/Run.hs view
@@ -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, [])+
+ src/Examples/Makefile view
@@ -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"
+ src/Examples/Misc/AFWxExample.hs view
@@ -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 ]+              ]
+ src/Examples/Misc/AlbumDTD.hs view
@@ -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 "<notes>" "album" cg))+			  (many fromElem cf))+		       (definite fromElem "<personnel>" "album" ce))+		    (many fromElem cd))+		 (definite fromElem "<coverart>" "album" cc))+	      (fromElem cb))+	   (definite fromElem "<artist>" "album" ca))+	(definite fromElem "<title>" "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-}+-}
+ src/Examples/Misc/AlbumEditor.hs view
@@ -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 ())+
+ src/Examples/Misc/EmbeddedTree.hs view
@@ -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+                                      ]+                          ]+             ]
+ src/Examples/Misc/Grep.hs view
@@ -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++++
+ src/Examples/Misc/MVCExample.hs view
@@ -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 ()+
+ src/Examples/Misc/Makefile view
@@ -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")
+ src/Examples/Misc/NonModalDialogTest.hs view
@@ -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.++-}
+ src/Examples/Misc/Person.hs view
@@ -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])++
+ src/Examples/Misc/PersonTest.hs view
@@ -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 ()
+ src/Examples/Misc/RecursiveUpdates.hs view
@@ -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
+ src/Examples/Misc/SettingsForm.hs view
@@ -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 ]+
+ src/Examples/Misc/WxEmbedded.hs view
@@ -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 ]
+ src/Graphics/UI/AF/AFWx.hs view
@@ -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 ]+>              ]++-}++
+ src/Graphics/UI/AF/CForm/CForm.hs view
@@ -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++
+ src/Graphics/UI/AF/CForm/CFormAll.hs view
@@ -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
+ src/Graphics/UI/AF/CForm/CFormImplementation.hs view
@@ -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
+ src/Graphics/UI/AF/General.hs view
@@ -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
+ src/Graphics/UI/AF/General/AutoForm.hs view
@@ -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.++-}+
+ src/Graphics/UI/AF/General/CustomTypes.hs view
@@ -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])
+ src/Graphics/UI/AF/General/Dialog.hs view
@@ -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)+
+ src/Graphics/UI/AF/General/EditFile.hs view
@@ -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
+ src/Graphics/UI/AF/General/InstanceCreator.hs view
@@ -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+
+ src/Graphics/UI/AF/General/Misc.hs view
@@ -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+
+ src/Graphics/UI/AF/General/MySYB.hs view
@@ -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+
+ src/Graphics/UI/AF/General/PriLabel.hs view
@@ -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+-}
+ src/Graphics/UI/AF/PolyCommand.hs view
@@ -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)
+ src/Graphics/UI/AF/WxForm.hs view
@@ -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
+ src/Graphics/UI/AF/WxForm/ComIO.hs view
@@ -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.+-}+
+ src/Graphics/UI/AF/WxForm/EditorComponent.hs view
@@ -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)+
+ src/Graphics/UI/AF/WxForm/GUI.hs view
@@ -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)
+ src/Graphics/UI/AF/WxForm/GenericEC.hs view
@@ -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
+ src/Graphics/UI/AF/WxForm/WxConstants.hs view
@@ -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+
+ src/Graphics/UI/AF/WxForm/WxEnumeration.hs view
@@ -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+++-}
+ src/Graphics/UI/AF/WxForm/WxFilePath.hs view
@@ -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
+ src/Graphics/UI/AF/WxForm/WxFormImplementation.hs view
@@ -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)+-}+
+ src/Graphics/UI/AF/WxForm/WxList.hs view
@@ -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.++-}
+ src/Graphics/UI/AF/WxForm/WxM.hs view
@@ -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)+
+ src/Graphics/UI/AF/WxForm/WxMaybe.hs view
@@ -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)
+ src/Graphics/UI/AF/WxFormAll.hs view
@@ -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. -}