sifflet 2.2.1 → 2.3.0
raw patch · 69 files changed
+15873/−462 lines, 69 filesdep +Cabaldep +HUnitdep +siffletdep −sifflet-libdep ~basedep ~cairodep ~fgl
Dependencies added: Cabal, HUnit, sifflet, text
Dependencies removed: sifflet-lib
Dependency ranges changed: base, cairo, fgl, filepath, glib, gtk, mtl, process, unix
Files
- ChangeLog.md +159/−0
- Options.hs +0/−91
- README +0/−36
- README.md +61/−0
- RELEASE-NOTES +0/−159
- app/Options.hs +91/−0
- app/sifflet.hs +137/−0
- datafiles/sifflet.py +107/−0
- datafiles/sifflet.scm +29/−0
- datafiles/siffml-1.0.dtd +63/−0
- datafiles/siffml-1.0.rnc +60/−0
- datafiles/siffml-2.0.rnc +71/−0
- lib/Data/Number/Sifflet.hs +271/−0
- lib/Data/Sifflet/Functoid.hs +104/−0
- lib/Data/Sifflet/Geometry.hs +162/−0
- lib/Data/Sifflet/Tree.hs +67/−0
- lib/Data/Sifflet/TreeGraph.hs +252/−0
- lib/Data/Sifflet/TreeLayout.hs +667/−0
- lib/Data/Sifflet/WGraph.hs +508/−0
- lib/Graphics/Rendering/Sifflet/Draw.hs +223/−0
- lib/Graphics/Rendering/Sifflet/DrawTreeGraph.hs +165/−0
- lib/Graphics/UI/Sifflet.hs +30/−0
- lib/Graphics/UI/Sifflet/Callback.hs +152/−0
- lib/Graphics/UI/Sifflet/Canvas.hs +1014/−0
- lib/Graphics/UI/Sifflet/EditArgsPanel.hs +332/−0
- lib/Graphics/UI/Sifflet/Frame.hs +307/−0
- lib/Graphics/UI/Sifflet/GtkForeign.hs +123/−0
- lib/Graphics/UI/Sifflet/GtkUtil.hs +225/−0
- lib/Graphics/UI/Sifflet/LittleGtk.hs +186/−0
- lib/Graphics/UI/Sifflet/RPanel.hs +154/−0
- lib/Graphics/UI/Sifflet/Tool.hs +588/−0
- lib/Graphics/UI/Sifflet/Types.hs +303/−0
- lib/Graphics/UI/Sifflet/Window.hs +1281/−0
- lib/Graphics/UI/Sifflet/Workspace.hs +606/−0
- lib/Language/Sifflet/Examples.hs +277/−0
- lib/Language/Sifflet/Export/Exporter.hs +191/−0
- lib/Language/Sifflet/Export/Haskell.hs +159/−0
- lib/Language/Sifflet/Export/Python.hs +198/−0
- lib/Language/Sifflet/Export/ToHaskell.hs +136/−0
- lib/Language/Sifflet/Export/ToPython.hs +162/−0
- lib/Language/Sifflet/Export/ToScheme.hs +327/−0
- lib/Language/Sifflet/Expr.hs +1041/−0
- lib/Language/Sifflet/ExprTree.hs +227/−0
- lib/Language/Sifflet/Parser.hs +319/−0
- lib/Language/Sifflet/SiffML.hs +476/−0
- lib/Language/Sifflet/TypeCheck.hs +592/−0
- lib/Language/Sifflet/Util.hs +145/−0
- lib/System/Sifflet/Paths.hs +77/−0
- lib/Text/Sifflet/Pretty.hs +56/−0
- lib/Text/Sifflet/Repr.hs +65/−0
- sifflet.cabal +155/−39
- sifflet.hs +0/−137
- tests/Testing/Common/ExprTreeTests.hs +50/−0
- tests/Testing/Common/TestStyles.hs +66/−0
- tests/Testing/TestUtil.hs +90/−0
- tests/Testing/Unit/ExprTests.hs +333/−0
- tests/Testing/Unit/ExprTreeTests.hs +119/−0
- tests/Testing/Unit/FunctionExamples.hs +123/−0
- tests/Testing/Unit/GraphTests.hs +299/−0
- tests/Testing/Unit/LayoutTests.hs +321/−0
- tests/Testing/Unit/ParserTests.hs +245/−0
- tests/Testing/Unit/ToHaskellTests.hs +98/−0
- tests/Testing/Unit/ToPythonTests.hs +87/−0
- tests/Testing/Unit/ToSchemeTests.hs +365/−0
- tests/Testing/Unit/TreeTests.hs +75/−0
- tests/Testing/Unit/TypeCheckTests.hs +339/−0
- tests/Testing/Unit/UtilTests.hs +90/−0
- tests/system-tests.sh +36/−0
- tests/unit-tests.hs +36/−0
+ ChangeLog.md view
@@ -0,0 +1,159 @@+% RELEASE NOTES++Release notes for sifflet and sifflet-lib++This is the RELEASE-NOTES file for both sifflet and sifflet-lib.+If you are editing it, be sure you are editing the original+and not the copies in the app and lib subdirectories.++Release 2.0.0.0, 2012 July 5+----------------------------++- Reorganized hierarchical modules to conform to+ http://www.haskell.org/haskellwiki/Hierarchical_module_names+ - Sifflet.Data.X is now Data.Sifflet.X+ for X in [Functoid, Geometry, Tree, TreeGraph,+ TreeLayout, WGraph]+ - Sifflet.Foreign.X is now Language.Sifflet.Export.X+ for X in [Exporter, Haskell, Python, ToHaskell, ToPython, ToScheme]+ - Sifflet.Language.X is now Language.Sifflet.X+ for X in [Expr, Parser, SiffML]+ - Sifflet.Rendering.X is now Graphics.Rendering.Sifflet.X+ for X in [Draw, DrawTreeGraph]+ - Sifflet.Text.X is now Text.Sifflet.X+ for X in [Pretty, Repr]+ - Sifflet.UI.X is now Graphics.UI.Sifflet.X+ for X in [Callback, Canvas, Frame, GtkForeign, GtkUtil, LittleGtk,+ RPanel, Tool, Types, Window, Workspace]+ - Sifflet.UI is now Graphics.UI.Sifflet+ - Sifflet.Util is now Language.Sifflet.Util, and+ Sifflet.Examples is now Language.Sifflet.Examples.+ (not clear that this is really the best place for it;+ maybe it hsould be split into pieces, such as + Control.Monad.SuccFail, ...)+ - Sifflet.Examples is now Language.Sifflet.Examples.++- File menu command to save the image of the Workspace or any+ open editor window, in SVG, PS, or PDF format.++- Implemented type checking with type inference.+ Type inference can be used for export to languages+ that require type declarations.+ Type checking error messages are *not* friendly+ for novice programmers; this needs improvement.++- Editing a function can now change its type.+ - It is now possible to change the arguments of a function+ (add, rename, or remove arguments, or for functional+ arguments, change the kind or arity).++- Bug fixes:+ - Fixed bug where the program crashed from incomplete 'if' trees+ - Various small bug fixes.++- Added RELAX NG schema for siffml version 2.0 (in datafiles).+ This is an upwards-compatible extension of siffml 1.0,+ which adds FunctionType to the alternatives for SiffletType.++- Added RELAX NG schema for siffml version 1.0 (in datafiles)++Release 1.2.5.1, 2012 Jun 14 (or later)+---------------------------------------++- Compatibility with mtl 2.1.1++Release 1.2.5, 2012 Jun 1+-------------------------++- Compatibility with GHC 7.4.1++Release 1.2.4, 2011 Mar 18+--------------------------++- Compatibility with HXT > 9.0++Release 1.2.3, 2011 Feb 18+--------------------------++- Compatibility with GHC 7 and Haskell Platform 2011.2++Release 1.2.2, 2010 Dec 3+-------------------------++- Offers to save changes before quitting++Release 1.2.1, 2010 Nov 19+--------------------------++- Compatibility with Haskell GTK packages 0.12++Release 1.2, 2010 Oct 30+------------------------++- Requires HXT 9.0+- Avoids indirect dependency on curl++Release 1.1, 2010 Aug 24+------------------------++- Improved Haskell exporter now removes most unnecessary+ parentheses.+- Exported Haskell code now uses the module Data.Number.Sifflet,+ formerly Sifflet.Data.Number.+- Sifflet now builds with slightly newer versions of the+ Haskell "Gtk2hs" libraries (cairo, gtk, glib),+ should work for versions >= 0.11.0 and < 0.12.++Release 1.0, 2010 Aug 11+------------------------++- Sifflet now has exporters to Scheme, Python, and Haskell and a small+ supporting "library" for each of those languages.+ This is intended for beginning students who are learning these+ languages, not for "industrial-strength" code production.++- Although the exporters apparently generate correct code,+ there are at present too many parentheses -- a few extra in Python,+ many extra in Haskell; no extra parentheses in Scheme, of course.++- Sifflet has a new number type, Sifflet.Data.Number.Number, which allows+ numbers to be exact or inexact, almost as in Scheme.+ Originally intended for the Scheme exporter, it is now+ also used internally by Sifflet's interpreter.++- The code is reorganized. There is now a separate library package,+ sifflet-lib, in addition to the sifflet package which provides+ only the executable. At present, the library's API is highly+ unstable.++- Sifflet has a new parser for user inputs, made with Parsec, + allowing more intuitive input+ of numbers (liberation from Haskell number syntax:+ for example, 0.0 can now be entered as 0.0, 0., or .0)+ and providing more intelligible error messages+ for some kinds of invalid input.++- Sifflet requires Gtk2hs packages (gtk, glib, cairo) version 0.11;+ support for the 0.10 Gtk2hs packages is dropped.++Release 0.1.7, 2010 June 10+---------------------------++- Tightened upper bounds on package dependency versions, in anticipation of + incompatible changes in the fgl API.+- No bug fixes or new features.+- Users who are staying with fgl == 5.4.2.2 will not benefit from upgrading + to Sifflet 0.1.7.++Release 0.1.6, 2010 May 27+--------------------------++- Sifflet offers to save your work if you give the quit or + open file command and have unsaved changes.+- Sifflet now builds with Gtk2hs 0.11.+- Some bug fixes and improved error checking.++Release 0.1.5, 2010 May 13+--------------------------++First public release.
− Options.hs
@@ -1,91 +0,0 @@-module Options (Options(..), processArgs, showHelp) where---- ?? import Control.Monad (mapM_)---- | Options are the interpretation of sifflet command-line arguments.--- If a function call is requested, the remaining arguments are unparsed,--- and just saved as strings to be fed into the parser when the--- function's argument types are known.--data Options = Options { optionsShowFunPad :: Bool- , optionsHelp :: Bool- , optionsSourceFile :: Maybe FilePath- , optionsShowFunction :: Maybe String- , optionsCallFunction :: Maybe String- , optionsAdditionalArgs :: [String]- , optionsErrorMsg :: Maybe String- , optionsDebug :: Bool- }- deriving (Eq, Show)--defaultOptions :: Options-defaultOptions = Options { optionsShowFunPad = True- , optionsHelp = False- , optionsSourceFile = Nothing- , optionsShowFunction = Nothing- , optionsCallFunction = Nothing- , optionsAdditionalArgs = []- , optionsErrorMsg = Nothing- , optionsDebug = False- }--processArgs :: [String] -> Options-processArgs = processArgsLoop defaultOptions --processArgsLoop :: Options -> [String] -> Options-processArgsLoop options args =- case args of- [] -> options- arg:args' ->- case arg of- "--help" -> options {optionsHelp = True,- optionsShowFunPad = False}- "--file" ->- case args' of- [] -> options {optionsErrorMsg = - Just "--file: missing file name"}- file:args'' ->- processArgsLoop (options {optionsSourceFile = Just file})- args''- "--show" ->- case args' of- [] -> options {optionsErrorMsg =- Just "--show: missing function name"}- fname:args'' ->- processArgsLoop (options {optionsShowFunction = - Just fname,- optionsShowFunPad = False})- args''- "--call" ->- case args' of- [] -> options {optionsErrorMsg =- Just "--call: missing function name"}- fname:args'' ->- options {optionsCallFunction = Just fname,- optionsAdditionalArgs = args'',- optionsShowFunPad = False}- "--debug" ->- processArgsLoop (options {optionsDebug = True}) args'- _ ->- options {optionsErrorMsg = Just ("unexpected argument: " ++- arg)}--helpText :: [String]-helpText =- ["Usage:",- "sifflet [OPTIONS]",- "",- "OPTIONS:",- " --file SIFFLET-FILE : loads SIFFLET-FILE at start.",- " --show FUNCTION-NAME : displays function FUNCTION-NAME.",- " --call FUNCTION-NAME [ARG ...] : calls function FUNCTION-NAME " ++- "with given arguments ARG ...",- " --debug : include context menu items for debugging.",- " --help : show this message.",- "The --help, --show, and --call options suppress the initial appearance of",- "the Function Pad, though (except with --help) it can still be",- "activated by the user."]--showHelp :: IO ()-showHelp = mapM_ putStrLn helpText-
− README
@@ -1,36 +0,0 @@-Sifflet -- README -- Sifflet--Rights---------Copyright (C) 2010 Gregory D. Weber--BSD3 license -- see the file "LICENSE" for details--Installation---------------1. Configure, either for system-wide installation:-- $ runghc Setup configure-- or for installation in a user directory:- - $ runghc Setup configure --user --prefix=~/where/to/install/--2. Build and install:-- $ runghc Setup build- $ runghc Setup install--Documentation----------------Please see the Sifflet home page for documentation:-- http://mypage.iu.edu/~gdweber/software/sifflet/--and especially the tutorial:-- http://mypage.iu.edu/~gdweber/software/sifflet/doc/tutorial.html-
+ README.md view
@@ -0,0 +1,61 @@+Sifflet -- README -- Sifflet++Rights+------++Copyright (C) 2010 Gregory D. Weber++BSD3 license -- see the file "LICENSE" for details++Installation+------------++A. In a Cabal sandbox (bracketed parts are optional)+ (with the source distribution unpacked)+++ $ cabal sandbox init+ $ cabal update++You will need this to build the Haskell gtk library if it is not already+installed:++ $ cabal install gtk2hs-buildtools++Continue:++ $ cabal install --only-dependencies [--enable-tests]+ $ cabal configure [--enable-tests]+ $ cabal build [-j4]+ $ cabal install++B. In a Cabal sandbox, directly installing from Hackage:++ $ cabal sandbox init+ $ cabal update+ $ cabal install sifflet+ +1. Configure, either for system-wide installation:++ $ runghc Setup configure++ or for installation in a user directory:+ + $ runghc Setup configure --user --prefix=~/where/to/install/++2. Build and install:++ $ runghc Setup build+ $ runghc Setup install++Documentation+-------------++Please see the Sifflet home page for documentation:++ http://mypage.iu.edu/~gdweber/software/sifflet/++and especially the tutorial:++ http://mypage.iu.edu/~gdweber/software/sifflet/doc/tutorial.html+
− RELEASE-NOTES
@@ -1,159 +0,0 @@-% RELEASE NOTES--Release notes for sifflet and sifflet-lib--This is the RELEASE-NOTES file for both sifflet and sifflet-lib.-If you are editing it, be sure you are editing the original-and not the copies in the app and lib subdirectories.--Release 2.0.0.0, 2012 July 5-------------------------------- Reorganized hierarchical modules to conform to- http://www.haskell.org/haskellwiki/Hierarchical_module_names- - Sifflet.Data.X is now Data.Sifflet.X- for X in [Functoid, Geometry, Tree, TreeGraph,- TreeLayout, WGraph]- - Sifflet.Foreign.X is now Language.Sifflet.Export.X- for X in [Exporter, Haskell, Python, ToHaskell, ToPython, ToScheme]- - Sifflet.Language.X is now Language.Sifflet.X- for X in [Expr, Parser, SiffML]- - Sifflet.Rendering.X is now Graphics.Rendering.Sifflet.X- for X in [Draw, DrawTreeGraph]- - Sifflet.Text.X is now Text.Sifflet.X- for X in [Pretty, Repr]- - Sifflet.UI.X is now Graphics.UI.Sifflet.X- for X in [Callback, Canvas, Frame, GtkForeign, GtkUtil, LittleGtk,- RPanel, Tool, Types, Window, Workspace]- - Sifflet.UI is now Graphics.UI.Sifflet- - Sifflet.Util is now Language.Sifflet.Util, and- Sifflet.Examples is now Language.Sifflet.Examples.- (not clear that this is really the best place for it;- maybe it hsould be split into pieces, such as - Control.Monad.SuccFail, ...)- - Sifflet.Examples is now Language.Sifflet.Examples.--- File menu command to save the image of the Workspace or any- open editor window, in SVG, PS, or PDF format.--- Implemented type checking with type inference.- Type inference can be used for export to languages- that require type declarations.- Type checking error messages are *not* friendly- for novice programmers; this needs improvement.--- Editing a function can now change its type.- - It is now possible to change the arguments of a function- (add, rename, or remove arguments, or for functional- arguments, change the kind or arity).--- Bug fixes:- - Fixed bug where the program crashed from incomplete 'if' trees- - Various small bug fixes.--- Added RELAX NG schema for siffml version 2.0 (in datafiles).- This is an upwards-compatible extension of siffml 1.0,- which adds FunctionType to the alternatives for SiffletType.--- Added RELAX NG schema for siffml version 1.0 (in datafiles)--Release 1.2.5.1, 2012 Jun 14 (or later)------------------------------------------- Compatibility with mtl 2.1.1--Release 1.2.5, 2012 Jun 1----------------------------- Compatibility with GHC 7.4.1--Release 1.2.4, 2011 Mar 18------------------------------ Compatibility with HXT > 9.0--Release 1.2.3, 2011 Feb 18------------------------------ Compatibility with GHC 7 and Haskell Platform 2011.2--Release 1.2.2, 2010 Dec 3----------------------------- Offers to save changes before quitting--Release 1.2.1, 2010 Nov 19------------------------------ Compatibility with Haskell GTK packages 0.12--Release 1.2, 2010 Oct 30---------------------------- Requires HXT 9.0-- Avoids indirect dependency on curl--Release 1.1, 2010 Aug 24---------------------------- Improved Haskell exporter now removes most unnecessary- parentheses.-- Exported Haskell code now uses the module Data.Number.Sifflet,- formerly Sifflet.Data.Number.-- Sifflet now builds with slightly newer versions of the- Haskell "Gtk2hs" libraries (cairo, gtk, glib),- should work for versions >= 0.11.0 and < 0.12.--Release 1.0, 2010 Aug 11---------------------------- Sifflet now has exporters to Scheme, Python, and Haskell and a small- supporting "library" for each of those languages.- This is intended for beginning students who are learning these- languages, not for "industrial-strength" code production.--- Although the exporters apparently generate correct code,- there are at present too many parentheses -- a few extra in Python,- many extra in Haskell; no extra parentheses in Scheme, of course.--- Sifflet has a new number type, Sifflet.Data.Number.Number, which allows- numbers to be exact or inexact, almost as in Scheme.- Originally intended for the Scheme exporter, it is now- also used internally by Sifflet's interpreter.--- The code is reorganized. There is now a separate library package,- sifflet-lib, in addition to the sifflet package which provides- only the executable. At present, the library's API is highly- unstable.--- Sifflet has a new parser for user inputs, made with Parsec, - allowing more intuitive input- of numbers (liberation from Haskell number syntax:- for example, 0.0 can now be entered as 0.0, 0., or .0)- and providing more intelligible error messages- for some kinds of invalid input.--- Sifflet requires Gtk2hs packages (gtk, glib, cairo) version 0.11;- support for the 0.10 Gtk2hs packages is dropped.--Release 0.1.7, 2010 June 10------------------------------- Tightened upper bounds on package dependency versions, in anticipation of - incompatible changes in the fgl API.-- No bug fixes or new features.-- Users who are staying with fgl == 5.4.2.2 will not benefit from upgrading - to Sifflet 0.1.7.--Release 0.1.6, 2010 May 27------------------------------ Sifflet offers to save your work if you give the quit or - open file command and have unsaved changes.-- Sifflet now builds with Gtk2hs 0.11.-- Some bug fixes and improved error checking.--Release 0.1.5, 2010 May 13-----------------------------First public release.
+ app/Options.hs view
@@ -0,0 +1,91 @@+module Options (Options(..), processArgs, showHelp) where++-- ?? import Control.Monad (mapM_)++-- | Options are the interpretation of sifflet command-line arguments.+-- If a function call is requested, the remaining arguments are unparsed,+-- and just saved as strings to be fed into the parser when the+-- function's argument types are known.++data Options = Options { optionsShowFunPad :: Bool+ , optionsHelp :: Bool+ , optionsSourceFile :: Maybe FilePath+ , optionsShowFunction :: Maybe String+ , optionsCallFunction :: Maybe String+ , optionsAdditionalArgs :: [String]+ , optionsErrorMsg :: Maybe String+ , optionsDebug :: Bool+ }+ deriving (Eq, Show)++defaultOptions :: Options+defaultOptions = Options { optionsShowFunPad = True+ , optionsHelp = False+ , optionsSourceFile = Nothing+ , optionsShowFunction = Nothing+ , optionsCallFunction = Nothing+ , optionsAdditionalArgs = []+ , optionsErrorMsg = Nothing+ , optionsDebug = False+ }++processArgs :: [String] -> Options+processArgs = processArgsLoop defaultOptions ++processArgsLoop :: Options -> [String] -> Options+processArgsLoop options args =+ case args of+ [] -> options+ arg:args' ->+ case arg of+ "--help" -> options {optionsHelp = True,+ optionsShowFunPad = False}+ "--file" ->+ case args' of+ [] -> options {optionsErrorMsg = + Just "--file: missing file name"}+ file:args'' ->+ processArgsLoop (options {optionsSourceFile = Just file})+ args''+ "--show" ->+ case args' of+ [] -> options {optionsErrorMsg =+ Just "--show: missing function name"}+ fname:args'' ->+ processArgsLoop (options {optionsShowFunction = + Just fname,+ optionsShowFunPad = False})+ args''+ "--call" ->+ case args' of+ [] -> options {optionsErrorMsg =+ Just "--call: missing function name"}+ fname:args'' ->+ options {optionsCallFunction = Just fname,+ optionsAdditionalArgs = args'',+ optionsShowFunPad = False}+ "--debug" ->+ processArgsLoop (options {optionsDebug = True}) args'+ _ ->+ options {optionsErrorMsg = Just ("unexpected argument: " +++ arg)}++helpText :: [String]+helpText =+ ["Usage:",+ "sifflet [OPTIONS]",+ "",+ "OPTIONS:",+ " --file SIFFLET-FILE : loads SIFFLET-FILE at start.",+ " --show FUNCTION-NAME : displays function FUNCTION-NAME.",+ " --call FUNCTION-NAME [ARG ...] : calls function FUNCTION-NAME " +++ "with given arguments ARG ...",+ " --debug : include context menu items for debugging.",+ " --help : show this message.",+ "The --help, --show, and --call options suppress the initial appearance of",+ "the Function Pad, though (except with --help) it can still be",+ "activated by the user."]++showHelp :: IO ()+showHelp = mapM_ putStrLn helpText+
+ app/sifflet.hs view
@@ -0,0 +1,137 @@+module Main (main) where++import Control.Monad (when)+import Data.IORef+import System.Exit++import Data.Sifflet.Functoid+import Data.Sifflet.TreeLayout+import Language.Sifflet.Examples+import Language.Sifflet.Expr+import Language.Sifflet.Parser+import Graphics.UI.Sifflet+import Language.Sifflet.Util++import Options+++-- | Main function++main :: IO ()+main = do+ {+ -- scim-bridge causes many errors, so don't use it+ suppressScimBridge++ -- Initialize GTK, returning args unused by Gtk itself+ ; args <- initGUI+ -- Process remaining command-line arguments+ ; let commands = processArgs args++ -- create the user interface+ ; vpui <- vpuiNew wstyle initialEnv (optionsDebug commands)+ ; let vpui' = vpui {vpuiToolkits = defaultVPUIToolkitsWithExamples}+ ; uiref <- newIORef vpui'+ -- Create some windows+ ; let cbmgr = mkCBMgr uiref+ ; vpui'' <- showWorkWin vpui' workspaceId cbmgr+ ; writeIORef uiref vpui''++ -- Obey command-line arguments, then let Gtk take over+ ; mExitCode <- performCommands commands cbmgr uiref+ ; case mExitCode of+ Nothing -> mainGUI >> return ()+ Just code -> exitWith code+ }++-- | Environment++initialEnv :: Env+initialEnv = exampleEnv++-- | Default toolkit++defaultVPUIToolkitsWithExamples :: [(String, VPToolkit)]+defaultVPUIToolkitsWithExamples =+ let toolkits =+ -- each item has name, width, list of rows tools+ [VPToolkit "Base" 500 (functionToolsFromLists baseFunctionsRows),+ VPToolkit "Examples" 500 + (functionToolsFromLists [exampleFunctionNames]),+ VPToolkit "My Functions" 500 (functionToolsFromLists [[]])]+ in zip (map toolkitName toolkits) toolkits++-- | Perform the things requested in command-line arguments.+-- Return an exit code if processing should continue.++performCommands :: Options -> CBMgr -> IORef VPUI -> IO (Maybe ExitCode)+performCommands options cbmgr uiref = + -- Error?+ case optionsErrorMsg options of+ Just msg ->+ putStrLn ("sifflet: " ++ msg) >> return (Just (ExitFailure 1))+ Nothing ->+ -- Help requested?+ if optionsHelp options+ then showHelp >> return (Just ExitSuccess)+ else do+ {+ -- show function pad?+ when (optionsShowFunPad options)+ (modifyIORefIO (showFunctionPadWindow cbmgr) uiref)++ -- source a file?+ -- What if no such file???+ ; case optionsSourceFile options of+ Nothing -> return ()+ Just file ->+ modifyIORefIO (openFilePath cbmgr file) uiref++ -- show or call a function?+ ; case (optionsShowFunction options, + optionsCallFunction options) of+ -- neither+ (Nothing, Nothing) -> return Nothing+ -- just show+ (Just fname, Nothing) -> + showFunctionFrame fname Nothing uiref >>+ return Nothing+ -- call, overrides show if both are given+ (_, Just fname) ->+ showFunctionFrame fname + (Just (optionsAdditionalArgs options))+ uiref+ }++showFunctionFrame :: String -- ^ function name+ -> Maybe [String] -- ^ Just args, to call with args+ -> IORef VPUI+ -> IO (Maybe ExitCode)+showFunctionFrame fname mArgStrs uiref = do+ {+ vpui <- readIORef uiref+ ; let x = styleFramePad (vpuiStyle vpui)+ y = 150+ env = vpuiGlobalEnv vpui++ showFun :: Function -> Maybe [Value] -> IO ()+ showFun f mArgValues = + vpuiAddFrame vpui workspaceId (FunctoidFunc f)+ mArgValues CallFrame env x y 0 Nothing >>=+ writeIORef uiref++ ; case envLookup env fname of+ Just (VFun f@(Function _fname argTypes _retType (Compound _ _))) ->+ case mArgStrs of+ Nothing -> showFun f Nothing >> return Nothing+ Just argStrs ->+ case parseTypedInputs2 argStrs argTypes of+ Fail msg ->+ putStrLn ("sifflet: " ++ msg) >>+ return (Just (ExitFailure 1))+ Succ argValues ->+ showFun f (Just argValues) >> return Nothing++ _ -> putStrLn ("sifflet: function not found or not compound") >>+ return (Just (ExitFailure 2))+ }
+ datafiles/sifflet.py view
@@ -0,0 +1,107 @@+# File: sifflet.py+# Python definitions for built-in Sifflet functions++# The variable "undefined" (sifflet.undefined) is reserved for Sifflet,+# representing an undefined variable.+# Identifiers containing any of the substrings _QUESTION_, _CHR0_,+# _CHR1_, ... _CHR255_ are reserved for Sifflet.+# For example: "zero_QUESTION_", "zero_CHR33_".++def add1 (n):+ return n + 1++def sub1 (n):+ return n - 1++def eqZero (n):+ return (n == 0)++def gtZero (n):+ return (n > 0)++def ltZero (n):+ return (n < 0)++def null (xs):+ return xs.null()++def head (xs):+ return xs.head()++def tail (xs):+ return xs.tail()++def cons (x, xs):+ return Cons(x, xs)++# The List data type+# These could use some methods to implement operations,+# like __eq__ and __repr__+ +# List delimiters++ListBegin = "li("+ListEnd = ")"++class List:++ pass++class Null (List):++ def __repr__ (self): return ListBegin + ListEnd++ def __repr2__ (self, _): return ListEnd++ def null(self): return True++ def head(self): error("head: empty list")++ def tail(self): error("tail: empty list")++class Cons (List):++ def __init__ (self, h, t):+ self.__head = h+ self.__tail = t++ def __repr__ (self):+ return self.__repr2__(ListBegin)++ def __repr2__ (self, prefix):+ return prefix + repr(self.__head) + self.__tail.__repr2__(", ")++ def null (self): return False++ def head (self): return self.__head++ def tail (self): return self.__tail++## Create a List (linked list) from any number of arguments,+## using the same notation as when Lists are converted to string reprs:+def li (*args): return al_to_ll(args)++# Convert between our List type and Python's built-in list type.+# Axioms:+# I. If alist is a Python list, then ll_to_al(al_to_ll(alist)) == alist+# II. If llist is a List, then al_to_ll(ll_to_al(llist)) == llist++## al_to_ll: convert Python list to our List type (linked list)+def al_to_ll (alist):+ node = Null()+ n = len(alist)+ for i in range(n - 1, -1, -1):+ node = cons(alist[i], node)+ return node+++## ll_to_al: convert our List type to Python list (array list)+def ll_to_al (llist):+ alist = []+ while not null(llist):+ alist.append(head(llist))+ llist = tail(llist)+ return alist++# Handy+empty = Null()
+ datafiles/sifflet.scm view
@@ -0,0 +1,29 @@+;;; File: sifflet.scm+;;; Scheme definitions for built-in Sifflet functions+;;;+;;; All symbols beginning with "sifflet-" or "*sifflet-" are+;;; reserved by Sifflet.+;;;+;;; The symbol *sifflet-undefined* is expected NOT to be defined!++;;; Adding and subtracting 1++(define (sifflet-add1 n) (+ n 1))++(define (sifflet-sub1 n) (- n 1))++;;; Scheme's quotient function is incompatible with Haskell div.+(define (sifflet-div x y) (floor (/ x y)))++;;; Scheme's / operation typically gives exact results:+;;; should this make any difference?+(define sifflet-/+ (if (exact? (/ 3 2))+ (lambda (x y) (exact->inexact (/ x y)))+ /))++;;; == and /= belong to the Eq class, which implies general+;;; equality, not limited to numbers.+(define (sifflet-not-equal? x y) (not (= x y)))++
+ datafiles/siffml-1.0.dtd view
@@ -0,0 +1,63 @@+<!-- siffml-1.0 DTD.+ root element is "functions",+ but how is that made clear?+-->++<!-- "parameter entities" for use within the DTD -->++<!-- variants of VpType -->+<!ENTITY % sifflet-type + "(string-type|char-type|num-type|bool-type|list-type|type-variable)">++<!-- Variants of Expr.+ Expr also has a EList constructor, but this is not used+ in SiffML -->+<!ENTITY % sifflet-expr "(undefined|symbol|literal|if|call)">++<!-- Variants of Value -->+<!ENTITY % sifflet-value + "(True|False|char|string|int|float|list|function)">++<!-- elements -->++<!ELEMENT functions (compound-function*)>++<!ELEMENT compound-function (name, return-type, arg-types,+ arg-names, body)>++<!ELEMENT name (#PCDATA)>+<!ELEMENT return-type %sifflet-type;> +<!ELEMENT arg-types ((%sifflet-type;)*)>+<!ELEMENT arg-names (name*)>++<!ELEMENT body (%sifflet-expr;)>++<!-- type elements -->+<!ELEMENT string-type EMPTY>+<!ELEMENT char-type EMPTY>+<!ELEMENT num-type EMPTY>+<!ELEMENT bool-type EMPTY>+<!ELEMENT list-type (%sifflet-type;)>+<!ELEMENT type-variable (#PCDATA)>++<!-- expr elements -->++<!ELEMENT undefined EMPTY>+<!ELEMENT symbol (#PCDATA)>+<!ELEMENT literal (%sifflet-value;)>+<!ELEMENT if ((%sifflet-expr;), (%sifflet-expr;), (%sifflet-expr;))>+<!-- a "list" element as an expr is probably a mistake -->+<!-- <!ELEMENT list ((%sifflet-expr;)*)> -->+<!ELEMENT call (symbol, (%sifflet-expr;)*)>++<!-- value elements -->++<!ELEMENT True EMPTY>+<!ELEMENT False EMPTY>+<!ELEMENT char (#PCDATA)>+<!ELEMENT string (#PCDATA)>+<!ELEMENT int (#PCDATA)>+<!ELEMENT float (#PCDATA)>+<!-- a "list" element represents a list value, not a list expr -->+<!ELEMENT list ((%sifflet-value;)*)>+<!ELEMENT function (compound-function)> <!-- shouldn't happen though -->
+ datafiles/siffml-1.0.rnc view
@@ -0,0 +1,60 @@+# -*- mode: conf -*-+# schema for siffml-1.0.+# RELAX NG compact syntax, using a grammar++start = Functions++# Functions and children++Functions = element functions { CompoundFunction* }+CompoundFunction = + element compound-function { Name, ReturnType, ArgTypes, ArgNames, Body }+Name = element name { text }+ReturnType = element return-type { SiffletType }+ArgTypes = element arg-types { SiffletType* }+ArgNames = element arg-names { Name* }+Body = element body { SiffletExpr }++# Types (variants of VpType)++SiffletType = + StringType | CharType | NumType | BoolType | ListType | TypeVariable++StringType = element string-type { empty }+CharType = element char-type { empty }+NumType = element num-type { empty }+BoolType = element bool-type { empty }+ListType = element list-type { SiffletType }+TypeVariable = element type-variable { text }++# Expressions (variants of Expr)+# Expr also has a EList constructor, but this is not used in SiffML++SiffletExpr = Undefined | Symbol | Literal | If | Call++Undefined = element undefined { empty }+Symbol = element symbol { text }+Literal = element literal { SiffletValue }+If = element if { SiffletExpr, SiffletExpr, SiffletExpr }+Call = element call { Symbol, SiffletExpr* }++# A "list" element as an expr is probably a mistake.+# List = element list { SiffletExpr }++# Values (variants of Value)++SiffletValue = TRUE | FALSE | Char | String | Int | Float | List | Function++TRUE = element True { empty }+FALSE = element False { empty }+Char = element char { text }+String = element string { text }+Int = element int { text }+Float = element float { text }++# A "list" element represents a list value, not a list expr.+List = element list { SiffletValue* }++# Function values shouldn't happen, but just in case:+Function = element function { CompoundFunction }+
+ datafiles/siffml-2.0.rnc view
@@ -0,0 +1,71 @@+# -*- mode: conf -*-+# schema for siffml-2.0.+# RELAX NG compact syntax, using a grammar+#+# All valid siffml-1.0 documents are also valid as siffml-2.0,+# as the only change is the addition of FunctionType as+# another alternative in SiffletType++start = Functions++# Functions and children++Functions = element functions { CompoundFunction* }+CompoundFunction = + element compound-function { Name, ReturnType, ArgTypes, ArgNames, Body }+Name = element name { text }+ReturnType = element return-type { SiffletType }+ArgTypes = element arg-types { SiffletType* }+ArgNames = element arg-names { Name* }+Body = element body { SiffletExpr }++# Types (variants of VpType)++SiffletType = + StringType | CharType | NumType | BoolType | ListType | + FunctionType | TypeVariable++StringType = element string-type { empty }+CharType = element char-type { empty }+NumType = element num-type { empty }+BoolType = element bool-type { empty }+ListType = element list-type { SiffletType }++FunctionType = element function-type { + SiffletType, # argument type+ SiffletType # return type (which may be a function type)+ }++TypeVariable = element type-variable { text }++# Expressions (variants of Expr)+# Expr also has a EList constructor, but this is not used in SiffML++SiffletExpr = Undefined | Symbol | Literal | If | Call++Undefined = element undefined { empty }+Symbol = element symbol { text }+Literal = element literal { SiffletValue }+If = element if { SiffletExpr, SiffletExpr, SiffletExpr }+Call = element call { Symbol, SiffletExpr* }++# A "list" element as an expr is probably a mistake.+# List = element list { SiffletExpr }++# Values (variants of Value)++SiffletValue = TRUE | FALSE | Char | String | Int | Float | List | Function++TRUE = element True { empty }+FALSE = element False { empty }+Char = element char { text }+String = element string { text }+Int = element int { text }+Float = element float { text }++# A "list" element represents a list value, not a list expr.+List = element list { SiffletValue* }++# Function values shouldn't happen, but just in case:+Function = element function { CompoundFunction }+
+ lib/Data/Number/Sifflet.hs view
@@ -0,0 +1,271 @@+-- | This module provides the Sifflet Number type and many operations upon it.+-- Most of the operations are provided by making Number an instance+-- of the classes Num, Real, Enum, Integral, Fractional, Floating,+-- and RealFrac. These are, I think, all of the normal Haskell+-- numeric type classes *except* RealFloat.+-- There are also a few functions defined in addition to the+-- class methods.+--+-- The *primary* purpose of this module is to be the library module+-- used by Sifflet programs exported to Haskell.+-- The *secondary* purpose (maybe no less important, but+-- realized after the first) is to implement the Sifflet+-- number Values (previously done with the VInt and VFloat constructors).++module Data.Number.Sifflet+ (+ Number(..)+ , isExact, toInexact+ , add1, sub1, eqZero, gtZero, ltZero+ )++where++-- | A Number represents a real number, which can be exact (Integer)+-- or inexact (Double).++data Number = Exact Integer | Inexact Double+ deriving (Eq, Read)++-- | Tell whether a Number is exact+isExact :: Number -> Bool+isExact (Exact _) = True+isExact _ = False++-- | Take a number, which may be exact or inexact, and+-- produce the inexact number which equals it.+-- Note that there is no inverse function toExact, +-- because some inexact numbers like 3.5 are not equal to any exact number.+-- The class RealFrac provides methods round, ceiling, floor, truncate+-- for converting to exact numbers.++toInexact :: Number -> Number+toInexact (Exact x) = Inexact (fromIntegral x)+toInexact xx = xx++toDouble :: Number -> Double+toDouble (Exact ix) = fromIntegral ix+toDouble (Inexact rx) = rx++-- | Unary operations fall into two groups:+-- exactOp1 works only for an exact operand;+-- it is an error if the operand is inexact.+-- The result is always exact.+-- (Unused)+-- inexactOp1 works directly for an inexact operand;+-- otherwise by conversion of its exact operand to inexact;+-- the result is always inexact.+-- eitherOp1 works for either exact or inexact operand,+-- and the result is exact if and only if the operand is exact.++exactOp1 :: String -> (Integer -> Integer) -> (Number -> Number)+exactOp1 name f x =+ case x of+ Exact i -> Exact (f i)+ _ -> error ("Number:" ++ name ++ ": inexact operand: " ++ show x)++inexactOp1 :: (Double -> Double) -> (Number -> Number)+-- inexactOp1 f x = Inexact (f (toDouble x))+inexactOp1 f = Inexact . f . toDouble++eitherOp1 :: (Integer -> Integer) -> (Double -> Double)+ -> (Number -> Number)+eitherOp1 fi fr arg =+ case arg of+ Exact i -> Exact (fi i)+ Inexact r -> Inexact (fr r)++-- | Binary operations fall in 3 groups:+-- exactOp2 is implemented only for exact, exact operands;+-- if there's any inexact operand, it's an error.+-- Integer division operations (quot, rem, div, mod)+-- are like this. The result is always exact.+-- eitherOp2 is implemented directly for exact, exact operands+-- and inexact, inexact operands; if one operand is+-- exact and the other inexact, the exact operand+-- is converted to inexact. Most arithmetic operations+-- (+, -, *) are like this. The result may be exact or inexact.+-- inexactop2 is directly implemented for inexact, inexact operands,+-- but handles exact operands by converting them to inexact+-- (even if both are exact). Math functions such as+-- exp, log, sqrt, and sin are like this. The result+-- is always inexact.++exactOp2 :: String -> (Integer -> Integer -> Integer)+ -> (Number -> Number -> Number)++exactOp2 _ f (Exact i) (Exact j) = Exact (f i j)+exactOp2 name _ x y = + error ("Number:" ++ name ++ ": inexact operand(s): " ++ + show x ++ ", " ++ show y)++inexactOp2 :: (Double -> Double -> Double)+ -> (Number -> Number -> Number)++inexactOp2 f x y = Inexact (f (toDouble x) (toDouble y))+++eitherOp2 :: (Integer -> Integer -> Integer)+ -> (Double -> Double -> Double)+ -> (Number -> Number -> Number)++eitherOp2 fi _ (Exact i) (Exact j) = Exact (fi i j)+eitherOp2 _ fx x y = Inexact (fx (toDouble x) (toDouble y))+++-- | This Show instance will not be compatible with the+-- derived Read instance above -- so fix it.+-- (And yet, mysteriously, ghci accepts 1 and 1.0 as Number literals.)++instance Show Number where+ show (Exact i) = show i+ show (Inexact x) = show x++-- | Number as an ordered type+instance Ord Number where+ compare (Exact x) (Exact y) = compare x y+ compare (Inexact x) (Inexact y) = compare x y+ compare (Exact x) (Inexact y) = compare (fromIntegral x) y+ compare (Inexact x) (Exact y) = compare x (fromIntegral y)+ -- This could take the place of the previous two:+ -- compare mx my = compare (toInexact mx) (toInexact my)++-- | Number as an instance of Num+instance Num Number where+ (+) = eitherOp2 (+) (+)+ (-) = eitherOp2 (-) (-)+ (*) = eitherOp2 (*) (*)++ negate = eitherOp1 negate negate+ abs = eitherOp1 abs abs+ signum = eitherOp1 signum signum++ fromInteger = Exact++-- | Numbers are Real, i.e., can be converted to Rational+instance Real Number where+ toRational (Exact i) = toRational i+ toRational (Inexact x) = toRational x++-- | In Haskell both Intgeger and Double are instances of Enum,+-- so Number should be an instance too. Also, this is a prerequisite+-- of being an instance of Integral.++instance Enum Number where++ succ = eitherOp1 succ succ+ pred = eitherOp1 pred pred++ toEnum i = Exact (toEnum i)+ fromEnum x = case x of+ Exact i -> fromEnum i+ Inexact r -> fromEnum r++ -- Use default definitions for these methods:+ -- enumFrom :: a -> [a] -- [n..]+ -- enumFromThen :: a -> a -> [a] -- [n,n'..]+ -- enumFromTo :: a -> a -> [a] -- [n..m]+ -- enumFromThenTo :: a -> a -> a -> [a] -- [n,n'..m]+++-- | Numbers are Integral, i.e., can do integer division and convert to+-- Integer. However, there is a restriction: this only works for Exact+-- numbers; for Inexact, there will be an error.+-- Some may see this as regrettable, but how is it different in principle+-- from division, which doesn't work for zero divisors, and+-- square root, which doesn't work for negative numbers?++instance Integral Number where++ quot = exactOp2 "quot" quot+ rem = exactOp2 "rem" rem+ div = exactOp2 "div" div+ mod = exactOp2 "mod" mod++ Exact i `quotRem` Exact j = + let (q, r) = i `quotRem` j in (Exact q, Exact r)+ _ `quotRem` _ = error "Number:quotRem: inexact operand(s)"++ Exact i `divMod` Exact j = + let (d, m) = i `divMod` j in (Exact d, Exact m)+ _ `divMod` _ = error "Number:divMod: inexact operand(s)"++ toInteger (Exact i) = i+ toInteger _ = error "Number:toInteger: inexact operand"++ ++-- | Numbers are Fractional, i.e., support division and conversion +-- from Rational.+-- This works directly for inexact Numbers, and otherwise by+-- conversion from Exact to Inexact.+instance Fractional Number where+ + (/) = inexactOp2 (/)+ recip = inexactOp1 recip+ fromRational r = Inexact (fromRational r)++-- | Numbers are Floating, i.e., support exponential, log, and trig functions.+-- This works directly for inexact Numbers, and otherwise by+-- conversion from Exact to Inexact.+instance Floating Number where++ pi = Inexact pi++ exp = inexactOp1 exp+ log = inexactOp1 log++ sqrt = inexactOp1 sqrt++ sin = inexactOp1 sin+ cos = inexactOp1 cos+ tan = inexactOp1 tan++ asin = inexactOp1 asin+ acos = inexactOp1 acos+ atan = inexactOp1 atan++ sinh = inexactOp1 sinh+ cosh = inexactOp1 cosh+ tanh = inexactOp1 tanh+ asinh = inexactOp1 asinh+ acosh = inexactOp1 acosh+ atanh = inexactOp1 atanh++ -- These methods have defaults:+ -- (**), logBase :: a -> a -> a++instance RealFrac Number where++ properFraction x =+ case x of + Exact i -> (fromIntegral i, Inexact 0.0)+ Inexact r -> let (w, p) = properFraction r+ in (w, Inexact p)++ -- Default methods:+ -- truncate :: (Integral b) => a -> b+ -- round :: (Integral b) => a -> b+ -- ceiling :: (Integral b) => a -> b+ -- floor :: (Integral b) => a -> b+++-- Haskell functions that implement certain Sifflet functions.++add1 :: Number -> Number+add1 = (+ 1)++sub1 :: Number -> Number+sub1 = (+ (-1))++eqZero :: Number -> Bool+eqZero = (== 0)++gtZero :: Number -> Bool+gtZero = (> 0)++ltZero :: Number -> Bool+ltZero = (< 0)++-- Omitting instance RealFloat, this is for data+-- that are *really* floating-point!
+ lib/Data/Sifflet/Functoid.hs view
@@ -0,0 +1,104 @@+module Data.Sifflet.Functoid+ (Functoid(..)+ , functoidName, functoidArgNames, functoidHeader+ , FunctoidLayout(..), flayout+ , flayoutBBox, flayoutSize, flayoutWidth, flayoutBottom+ , flayoutWiden)++where++import Data.Graph.Inductive as G++import Data.Sifflet.Geometry+import Data.Sifflet.TreeLayout++import Language.Sifflet.Expr+import Language.Sifflet.ExprTree+++-- | A Functoid is either a FunctoidParts, representing a partially+-- defined function, or a (completely defined) Function.+-- A FunctoidParts represents an incompletely defined function,+-- which has a function name, argument names, and a list of graph nodes +-- representing the function body which might not yet form+-- a complete expression tree, e.g., nodes might+-- be unconnected.++data Functoid = FunctoidParts {fpName :: String,+ fpArgs :: [String],+ fpNodes :: [G.Node]}+ | FunctoidFunc {fpFunc :: Function}+ deriving (Show)++functoidName :: Functoid -> String+functoidName (FunctoidParts {fpName = name}) = name+functoidName (FunctoidFunc function) = functionName function++functoidArgNames :: Functoid -> [String]+functoidArgNames (FunctoidParts {fpArgs = args}) = args+functoidArgNames (FunctoidFunc function) = functionArgNames function++functoidHeader :: Functoid -> String+functoidHeader f = unwords (functoidName f : functoidArgNames f)++-- | What is a FunctoidLayout? You can think of it as a +-- tree layout for a Frame,+-- or for a Functoid, or as a Forest of Tree Layouts!+-- For an Edit frame, it must be a forest, since the nodes are not+-- yet necessarily connected into a tree.+-- For a call frame, it will be a single TreeLayout (singleton list).++data FunctoidLayout = FLayoutTree (TreeLayout ExprNode)+ | FLayoutForest [TreeLayout ExprNode] BBox++-- | Graphically lay out the Functoid.+-- mvalues: Nothing implies an uncalled frame,+-- Just values implies a called frame, even with 0 arguments.++flayout :: Style -> Functoid -> Env -> Maybe [Value] -> FunctoidLayout+flayout style functoid env mvalues =+ case functoid of+ FunctoidParts {} ->+ -- STUB: [] and bbox ***+ -- WELL: is this supposed to CREATE the tlo or RETRIEVE the tlo?+ -- Either way, it won't work without access to the WGraph!+ FLayoutForest [] (BBox (hpad style) (vpad style) 300 300)+ FunctoidFunc function ->+ let expr = functionBody function+ aspecs = functionArgSpecs function+ exprTree = case mvalues of+ Nothing -> exprToTree expr+ Just _values -> evalTree (exprToTree expr) env+ tlo = treeLayout style + (exprNodeIoletCounter env aspecs)+ exprTree+ in FLayoutTree tlo++flayoutBBox :: FunctoidLayout -> BBox+flayoutBBox aflayout =+ case aflayout of+ FLayoutTree t -> layoutTreeBB t+ FLayoutForest _ bbox -> bbox++flayoutSize :: FunctoidLayout -> Size+flayoutSize = bbSize . flayoutBBox++flayoutWidth :: FunctoidLayout -> Double+flayoutWidth = bbWidth . flayoutBBox++flayoutBottom :: FunctoidLayout -> Double+flayoutBottom = bbBottom . flayoutBBox++flayoutWiden :: FunctoidLayout -> Double -> FunctoidLayout +flayoutWiden aflayout minWidth =+ case aflayout of+ FLayoutTree t -> FLayoutTree (treeLayoutWiden t minWidth)+ FLayoutForest f bbox -> FLayoutForest f bbox -- STUB ***++instance Translate FunctoidLayout where+ translate dx dy fl =+ case fl of+ FLayoutTree t -> + FLayoutTree (translate dx dy t)+ FLayoutForest f b ->+ FLayoutForest (translate dx dy f) (translate dx dy b)
+ lib/Data/Sifflet/Geometry.hs view
@@ -0,0 +1,162 @@+module Data.Sifflet.Geometry+ (Position(..), + positionDelta, positionDistance,+ positionDistanceSquared, positionCloseEnough,+ Circle(..), pointInCircle,+ Size(..),+ BBox(..), + bbX, bbY, bbWidth, bbSetWidth, bbHeight, bbPosition, bbSize,+ bbToRect, bbFromRect, bbCenter, bbLeft, bbXCenter, bbRight,+ bbTop, bbYCenter, bbBottom,+ bbMerge, bbMergeList, pointInBB,+ Widen(widen),+ Translate(..)+ )++where++import Data.Tree as T+import Graphics.UI.Gtk(Rectangle(Rectangle))++-- A Position may be interpreted either absolutely, as a point (x, y);+-- or relatively, as an offset (dx, dy)++data Position = Position {posX :: Double, posY :: Double} -- x, y+ deriving (Eq, Read, Show)++positionDelta :: Position -> Position -> (Double, Double)+positionDelta (Position x1 y1) (Position x2 y2) = (x2 - x1, y2 - y1)++positionDistance :: Position -> Position -> Double+positionDistance p1 p2 = sqrt (positionDistanceSquared p1 p2)++positionDistanceSquared :: Position -> Position -> Double+positionDistanceSquared (Position x1 y1) (Position x2 y2) =+ (x1 - x2) ** 2 + (y1 - y2) ** 2++positionCloseEnough :: Position -> Position -> Double -> Bool+positionCloseEnough p1 p2 radius =+ -- Essentially asks if p1 and p2 are nearly intersecting,+ -- i.e., if p1 is within a circle with center p2 and the given radius+ positionDistanceSquared p1 p2 <= radius ** 2++++data Circle = Circle {circleCenter :: Position,+ circleRadius :: Double}+ deriving (Eq, Read, Show)++pointInCircle :: Position -> Circle -> Bool+pointInCircle point (Circle center radius) =+ positionCloseEnough point center radius++data Size = Size {sizeW :: Double, sizeH :: Double} -- width, height+ deriving (Eq, Read, Show)++-- | BBox x y width height; (x, y) is the top left corner++data BBox = BBox Double Double Double Double+ deriving (Eq, Read, Show)++-- | BBox accessors and utilities++bbX, bbY, bbWidth, bbHeight :: BBox -> Double+bbX (BBox x _y _w _h) = x++bbY (BBox _x y _w _h) = y+bbWidth (BBox _x _y w _h) = w+bbHeight (BBox _x _y _w h) = h++bbPosition :: BBox -> Position+bbPosition (BBox x y _w _h) = Position x y++bbSize :: BBox -> Size+bbSize (BBox _x _y w h) = Size w h++bbCenter :: BBox -> Position+bbCenter (BBox x y w h) = Position (x + w / 2) (y + h / 2)++bbSetWidth :: BBox -> Double -> BBox+bbSetWidth (BBox x y _w h) nwidth = BBox x y nwidth h++bbLeft, bbXCenter, bbRight :: BBox -> Double+bbLeft = bbX+bbXCenter (BBox x _y w _h) = x + w / 2+bbRight (BBox x _y w _h) = x + w++bbTop, bbYCenter, bbBottom :: BBox -> Double+bbTop = bbY+bbYCenter (BBox _x y _w h) = y + h / 2+bbBottom (BBox _x y _w h) = y + h++bbToRect :: BBox -> Rectangle+bbToRect (BBox x y w h) = + Rectangle (round x) (round y) (round w) (round h)++bbFromRect :: Rectangle -> BBox+bbFromRect (Rectangle x y w h) =+ BBox (fromIntegral x) (fromIntegral y)+ (fromIntegral w) (fromIntegral h)++-- | Form a new BBox which encloses two bboxes+bbMerge :: BBox -> BBox -> BBox+bbMerge bb1 bb2 =+ let f1 ! f2 = f1 (f2 bb1) (f2 bb2)+ bottom = max ! bbBottom -- i.e., max (bbBottom bb1) (bbBottom bb2)+ top = min ! bbTop+ left = min ! bbLeft+ right = max ! bbRight+ in BBox left top (right - left) (bottom - top)++bbMergeList :: [BBox] -> BBox+bbMergeList [] = error "bbMergeList: empty list"+bbMergeList (b:bs) = foldl bbMerge b bs+ +-- Test whether a point (e.g., from mouse click) is within a+-- bounding box+pointInBB :: Position -> BBox -> Bool+pointInBB (Position x y) (BBox x1 y1 w h) =+ x >= x1 &&+ x <= x1 + w &&+ y >= y1 &&+ y <= y1 + h++class Widen a where+ -- | Make an object have at least a specified minimum width;+ -- does nothing if it's already at least that wide+ widen :: a -> Double -> a++instance Widen BBox where+ widen bb@(BBox x y w h) minWidth =+ if w >= minWidth+ then bb+ else BBox x y minWidth h++-- | A Translate is a thing that can be repositioned by+-- delta x and delta y++class Translate a where+ translate :: Double -- ^ delta X+ -> Double -- ^ delta Y+ -> a -- ^ thing in old position+ -> a -- ^ thing in new position++instance (Translate e) => Translate [e] where+ translate dx dy = map (translate dx dy)++instance (Translate e) => Translate (Tree e) where+ translate dx dy t = + T.Node (translate dx dy (rootLabel t))+ (translate dx dy (subForest t))+++instance Translate BBox where+ translate dx dy (BBox x y w h) = BBox (x + dx) (y + dy) w h++instance Translate Position where+ translate dx dy (Position x y) = Position (x + dx) (y + dy)++instance Translate Circle where+ translate dx dy (Circle center radius) =+ Circle (translate dx dy center) radius+
+ lib/Data/Sifflet/Tree.hs view
@@ -0,0 +1,67 @@+-- Tree.hs+-- General (not binary) trees++module Data.Sifflet.Tree + (T.Tree(..), tree, leaf, isLeaf, treeSize, treeDepth+ , Repr(..)+ -- Since String is not an instance of Repr,+ -- we need to convert (Tree String) to (Tree Name)+ , Name(..), nameTree+ , putTree, putTreeR, putTreeRs, putTreeS+ , drawTreeShow+ )++where++import Data.Tree as T+import Text.Sifflet.Repr++-- Makers++tree :: e -> Forest e -> T.Tree e+tree root subtrees = T.Node {rootLabel = root, subForest = subtrees}++leaf :: e -> T.Tree e+leaf x = tree x []++isLeaf :: T.Tree e -> Bool+isLeaf (T.Node _root []) = True+isLeaf _ = False++treeSize :: T.Tree e -> Int+treeSize (T.Node _root subtrees) = 1 + sum (map treeSize subtrees)++treeDepth :: T.Tree e -> Int+treeDepth (T.Node _root []) = 1+treeDepth (T.Node _root subtrees) = 1 + maximum (map treeDepth subtrees)++{- tree_map or treeMap:+ removed; use (Functor) fmap instead+-}++{- tree_mapM:+ removed, use Data.Traversable.mapM instead.+-}++nameTree :: T.Tree String -> T.Tree Name+nameTree = fmap Name++putTree :: (Show e) => T.Tree e -> IO ()+putTree = putTreeS++-- putTreeR -- using repr (first part)+putTreeR :: (Repr e) => T.Tree e -> IO()+putTreeR = putStrLn . drawTree . fmap repr++-- putTreeRs -- using reprs (all parts)+putTreeRs :: (Repr e) => T.Tree e -> IO()+putTreeRs = putStrLn . drawTree . fmap reprs+++-- putTreeS -- using show+putTreeS :: (Show e) => T.Tree e -> IO ()+putTreeS = putStrLn . drawTreeShow++drawTreeShow :: (Show e) => T.Tree e -> String+drawTreeShow = drawTree . fmap show+
+ lib/Data/Sifflet/TreeGraph.hs view
@@ -0,0 +1,252 @@+module Data.Sifflet.TreeGraph + (LayoutGraph, + flayoutToGraph, treeLayoutToGraph,+ -- treeToGraph, + orderedTreeToGraph, + treeGraphNodesTree, graphToTreeOriginal,+ graphToTreeStructure, + flayoutToGraphRoots,+ graphToOrderedTree, graphToOrderedTreeFrom,+ orderedChildren, adjCompareEdge,+ nextNodes, -- exported for testing; any other reason?+ grTranslateNode, grTranslateSubtree, grTranslateGraph,++ -- moved from Workspace.hs:+ functoidToFunction, graphToExprTree,++ )++where++import Data.List (sort, sortBy)++import Data.Graph.Inductive as G++import Data.Sifflet.Functoid+import Data.Sifflet.Geometry+import Data.Sifflet.Tree as T+import Data.Sifflet.TreeLayout+import Data.Sifflet.WGraph++import Language.Sifflet.Expr+import Language.Sifflet.ExprTree+import Language.Sifflet.TypeCheck++import Language.Sifflet.Util++type LayoutGraph n e = Gr (LayoutNode n) e++flayoutToGraph :: FunctoidLayout -> WGraph+flayoutToGraph tlo = + case tlo of + FLayoutTree t -> treeLayoutToGraph t+ FLayoutForest ts _bbox -> + foldl grAddGraph wgraphNew (map treeLayoutToGraph ts)++treeLayoutToGraph :: TreeLayout ExprNode -> WGraph+treeLayoutToGraph = orderedTreeToGraph . fmap WSimple+++-- flayoutToGraphRoots returns a list of graph nodes (Ints)+-- corresponding to the root of the tree, or the roots of+-- the trees in the forest.+-- The list is ordered in the same sense as the graph nodes.++flayoutToGraphRoots :: FunctoidLayout -> [G.Node]+flayoutToGraphRoots (FLayoutTree _t) = [1]+flayoutToGraphRoots (FLayoutForest trees _bbox) =+ let loop _ [] res = reverse res+ loop next (t:ts) res =+ loop (next + treeSize t) ts (next:res)+ in loop 1 trees []+++-- {-# DEPRECATED treeToGraph "use ??? instead" #-}++-- treeToGraph :: Tree e -> Gr e ()+-- treeToGraph (T.Node root subtrees) = +-- -- Convert an ordered tree to a graph.+-- -- The graph edge labels from parent to child +-- -- are integers corresponding to the order of the children.+-- -- So, to recover the ordered list of children, +-- -- sort by the edge label.+-- let g0 = empty :: Gr e ()+-- g1 = insNode (1, root) g0++-- grow :: Gr e () -> [(Tree e, G.Node)] -> G.Node -> Gr e ()+-- -- grow graph [(tree, parent)] node+-- grow g [] _ = g+-- grow g ((t, p):tps) n =+-- -- insert t forming g', insert ts into g'+-- let edge = ((), p) -- predecessors, or both?+-- g' = ([edge], n, (rootLabel t), []) & g -- assume pred only+-- in grow g' (tps ++ [(s, n) | s <- subForest t])+-- (succ n)++-- in grow g1 [(s, 1) | s <- subtrees] 2++sprout :: G.Node -> Tree e -> [(G.Node, WEdge, Tree e)]+sprout parent (T.Node _ subtrees) =+ -- create triples (parent graph node, edge, subtree)+ let m = length subtrees - 1+ in [(parent, WEdge e, s) | (e, s) <- zip [0..m] subtrees]+++orderedTreeToGraph :: Tree e -> Gr e WEdge+orderedTreeToGraph otree = + -- Convert an ordered tree to a graph.+ -- The graph edge labels from parent to child + -- are integers corresponding to the order of the children.+ -- So, to recover the ordered list of children, + -- sort by the edge label.+ let g0 = empty :: Gr e WEdge+ g1 = insNode (1, rootLabel otree) g0++ grow :: Gr e WEdge -> [(G.Node, WEdge, Tree e)] -> G.Node -> Gr e WEdge+ -- grow graph [(parent, edgeLabel, subtree), ...] node+ grow g [] _ = g+ grow g ((p, e, t):pets) n =+ -- insert pet forming g', insert pets into g';+ -- n is the node id for the root of this subtree+ let adj = (e, p) -- to parent (priority, node)+ g' = ([adj], n, (rootLabel t), []) & g + n' = succ n+ in grow g' (pets ++ + sprout n t+ -- [(s, n) | s <- subForest t])+ )+ n'++ in grow g1 (sprout 1 otree) 2++-- And what about this (e, Node) type? Is it some sort of monad?++treeGraphNodesTree :: Tree e -> Tree Node+treeGraphNodesTree atree =+ -- returns a tree of Nodes of the Graph (treeToGraph atree)+ let gnTree :: Tree e -> Node -> Node -> (Tree Node, Node)+ gnTree (T.Node _root subtrees) rootNode next =+ -- rootNode = Node (number) for the root,+ -- next = next unused Node+ let (nNodes, next') = nextNodes subtrees next+ (subtrees', next'') = gnSubtrees subtrees nNodes next'+ in (T.Node rootNode subtrees', next'')++ gnSubtrees :: [Tree e] -> [Node] -> Node -> ([Tree Node], Node)+ gnSubtrees [] [] next = ([], next)+ gnSubtrees (t:ts) (n:ns) next = + let (t', next') = gnTree t n next+ (ts', next'') = gnSubtrees ts ns next'+ in ((t' : ts'), next'')+ gnSubtrees _ _ _ = error "gnSubtrees: list lengths do not match"++ in fst (gnTree atree 1 2)++nextNodes :: [e] -> Node -> ([Node], Node)+nextNodes items next = + -- next is the next unused Node (number).+ -- Returns list of new nodes, and a new "next" node+ -- E.g., nextNodes [a, b] 3 = ([3, 4], 5)+ -- nextNodes [c, d, e] 5 = ([5, 6, 7], 8)+ -- nextNodes [] 8 = ([], 8)+ let n = length items+ next' = next + n+ in ([next .. (next' - 1)], next')++-- When a tree is converted to a graph,+-- each tree node's ordered children get graph node numbers+-- in ascending order. Therefore, when reconstructing the tree,+-- sorting the graph nodes restores the order of the children+-- as in the tree.++graphToOrderedTree :: Gr e WEdge -> Tree e+-- inverse of orderedTreeToGraph+graphToOrderedTree g = graphToOrderedTreeFrom g 1++graphToOrderedTreeFrom :: Gr e WEdge -> G.Node -> Tree e+graphToOrderedTreeFrom g n =+ case lab g n of+ Just label -> + T.Node label (map (graphToOrderedTreeFrom g) (orderedChildren g n))+ Nothing -> + errcats ["missing label for node", show n]++-- | List of the nodes children, ordered by edge number+orderedChildren :: Gr e WEdge -> G.Node -> [G.Node]+orderedChildren g = map fst . sortBy adjCompareEdge . lsuc g++adjCompareEdge :: (Node, WEdge) -> (Node, WEdge) -> Ordering+adjCompareEdge (_n1, e1) (_n2, e2) = compare e1 e2++{-# DEPRECATED graphToTreeOriginal "use ??? instead" #-}++graphToTreeOriginal :: Gr e () -> G.Node -> Tree e+-- (\g -> graphToTreeOriginal g 1) is the inverse of treeToGraph+graphToTreeOriginal g n =+ case lab g n of+ Just label -> T.Node label (map (graphToTreeOriginal g) + (sort (suc g n)))+ _ -> errcats ["missing label for node", show n]++{-# DEPRECATED graphToTreeStructure "use ??? instead" #-}++graphToTreeStructure :: Gr n e -> G.Node -> Tree G.Node+-- This is *not* an inverse of treeToGraph.+-- Rather, graphToTreeStructure (treeToGraph t 1) is a tree t' of Nodes+-- (i.e., integer identifiers of nodes in the graph)+-- which parallels the structure of t.++graphToTreeStructure g n = T.Node n (map (graphToTreeStructure g)+ (sort (suc g n)))++grTranslateNode :: + Node -> Double -> Double -> LayoutGraph n e -> LayoutGraph n e+grTranslateNode node dx dy graph = + grUpdateNodeLabel graph node (translate dx dy)++grTranslateSubtree :: + Node -> Double -> Double -> LayoutGraph n e -> LayoutGraph n e+grTranslateSubtree root dx dy graph = + let trSubtrees :: [Node] -> LayoutGraph n e -> LayoutGraph n e+ trSubtrees [] g = g+ trSubtrees (r:rs) g = trSubtrees (rs ++ suc g r)+ (grTranslateNode r dx dy g)+ in trSubtrees [root] graph++grTranslateGraph :: Double -> Double -> LayoutGraph n e -> LayoutGraph n e+grTranslateGraph dx dy graph = nmap (translate dx dy) graph++grUpdateNodeLabel :: (DynGraph g) => g a b -> Node -> (a -> a) -> g a b+grUpdateNodeLabel graph node updater =+ case match node graph of+ (Nothing, _) -> error "no such node"+ (Just (preds, jnode, label, succs), graph') ->+ -- jnode == node+ (preds, jnode, updater label, succs) & graph'++functoidToFunction :: + Functoid -> WGraph -> G.Node -> Env -> SuccFail Function+functoidToFunction functoid graph frameNode env =+ case functoid of+ FunctoidFunc f -> Succ f+ FunctoidParts {fpName = name, fpArgs = args} ->+ case suc graph frameNode of+ [root] ->+ do+ {+ expr <- treeToExpr $ graphToExprTree graph root+ ; let impl = Compound args expr+ ; (atypes, rtype) <- decideTypes name expr args env+ ; Succ (Function (Just name) atypes rtype impl)+ }+ _ -> Fail "The graph structure is not a tree!"++graphToExprTree :: WGraph -> G.Node -> Tree ExprNode+graphToExprTree g root =+ let extractExprNode wnode =+ case wnode of+ WSimple layoutNode -> gnodeValue (nodeGNode layoutNode)+ WFrame _ -> error "graphToExprTreeFrom: unexpected WFrame node"+ in fmap extractExprNode (graphToOrderedTreeFrom g root)++
+ lib/Data/Sifflet/TreeLayout.hs view
@@ -0,0 +1,667 @@+module Data.Sifflet.TreeLayout + (VColor(..), white, cream, black, lightBlue, lightBlueGreen+ , lightGray, mediumGray, darkGray+ , yellow, darkBlueGreen, blueGreen+ , Style(..), VFont(..), defaultStyle, style0, style1, style2, style3+ , wstyle+ , styleIncreasePadding+ , FontTextExtents(..), setFont, measureText, styleTextExtents, ftExtents+ , TextBox(..), makeTextBox, tbWidth, tbHeight, tbBottom+ , tbCenter, tbTextCenter, tbBoxCenter, offsetTextBoxCenters+ , tbSetWidth+ , treeSizes+ , GNode(..), treeGNodes, gnodeText, gnodeTextBB+ , Iolet(..), ioletCenter, makeIolets, makeIoletsRow+ , pointInIolet+ , IoletCounter, zeroIoletCounter+ , makeGNode+ , TreeLayout, LayoutNode(..)+ , layoutNodeSource, layoutRootBB, layoutTreeBB+ , treeLayout+ , treeLayoutPaddedSize, treeLayoutSize, treeLayoutWidth+ , layoutTreeMoveCenterTo+ , pointInLayoutNode, pointInGNode, findRect+ , treeLayoutWiden+ )++where++import System.IO.Unsafe++-- All this VVV is needed just to measure a piece of text;+-- maybe font and text should be split out to a new module?++import Graphics.Rendering.Cairo (FontExtents(..),+ FontSlant(..), FontWeight(..),+ Format(..), Render,+ TextExtents(..),+ fontExtents,+ renderWith,+ textExtents,+ selectFontFace, setFontSize,+ withImageSurface)++import Graphics.UI.Gtk (Rectangle)+import Data.Traversable () -- imports only instance declarations++import Data.Sifflet.Geometry+import Data.Sifflet.Tree as T hiding (tree)+import Text.Sifflet.Repr ()+import Language.Sifflet.Util++-- Do colors really belong here???++data VColor = ColorRGB Double Double Double |+ ColorRGBA Double Double Double Double++black, white, cream, lightBlue, lightBlueGreen :: VColor++black = ColorRGB 0 0 0+white = ColorRGB 1 1 1+cream = ColorRGB 0.94902 0.94902 0.82745+lightBlue = ColorRGB 0.43529 0.43922 0.95686+lightBlueGreen = ColorRGB 0 1 1++lightGray, mediumGray, darkGray :: VColor+lightGray = ColorRGBA 0.75 0.75 0.75 0.5+mediumGray = ColorRGB 0.5 0.5 0.5+darkGray = ColorRGB 0.25 0.25 0.25++yellow, darkBlueGreen, blueGreen :: VColor++yellow = ColorRGB 0.9 0.9 0+darkBlueGreen = ColorRGB 0 0.3 0.3+blueGreen = ColorRGB 0 0.4 0.4++-- darkRed = ColorRGB 0.5 0 0, -- dark red++data VFont = VFont {vfontFace :: String, vfontSlant :: FontSlant,+ vfontWeight :: FontWeight,+ vfontSize :: Double}++data Style = + Style {styleFont :: VFont,+ lineWidth :: Double,+ textMargin :: Double, -- in box on all four sides+ hpad, vpad :: Double, -- internode (interbox) spacing+ exomargin :: Double, -- margin of the tree within the window+ vtinypad :: (Double, Double), -- node-edge spacing (above, below)+ styleFramePad :: Double, -- pad between frames+ styleNormalTextColor, styleNormalFillColor, + styleNormalEdgeColor,+ styleActiveTextColor, styleActiveFillColor,+ styleActiveEdgeColor,+ styleSelectedTextColor, styleSelectedFillColor, + styleSelectedEdgeColor,+ styleTetherColor :: VColor,+ -- auxiliary text style, e.g., the value of an ExprNode+ styleAuxOffset :: Position, -- center-to-center offset dx dy+ styleAuxColor :: VColor,+ styleAuxFont :: VFont,+ styleIoletRadius :: Double, -- could extend to other shapes ***+ styleShowNodeBoxes :: Bool, -- draw a box around expr nodes+ styleShowNodePorts :: Bool -- draw the I/O ports of expr nodes+ }++styleIncreasePadding :: Style -> Double -> Style+-- increase hpad, vpad of style by multiplication+styleIncreasePadding style factor =+ style {hpad = factor * hpad style,+ vpad = factor * vpad style}++style0, style1, style2, style3, defaultStyle :: Style++style0 = + let green = ColorRGB 0.1 0.9 0.1+ veryDarkGray = ColorRGB 0.1 0.1 0.1+ brighterGreen = ColorRGB 0.5 0.95 0.5+ in Style {styleFont = VFont "serif" FontSlantNormal FontWeightNormal 18, + lineWidth = 2, + textMargin = 18.0, -- text within its box+ hpad = 27, vpad = 36, -- inter-node separation+ exomargin = 0,+ vtinypad = (4.5, 4.5), -- node-edge separation+ styleFramePad = 35, -- padding between frames+ -- Foreground and background colors+ styleNormalTextColor = green,+ styleNormalEdgeColor = green,+ styleNormalFillColor = veryDarkGray,+ styleActiveTextColor = brighterGreen,+ styleActiveEdgeColor = brighterGreen,+ styleActiveFillColor = mediumGray,+ styleSelectedTextColor = blueGreen,+ styleSelectedEdgeColor = blueGreen,+ styleSelectedFillColor = darkGray,+ styleTetherColor = white,+ styleAuxOffset = Position 0.0 (-20.0),+ styleAuxColor = lightGray,+ styleAuxFont = + VFont "serif" FontSlantItalic FontWeightNormal 12,+ styleIoletRadius = 5,+ styleShowNodeBoxes = True, -- draw a box around expr nodes+ styleShowNodePorts = True -- draw the I/O ports of expr nodes+ }++style1 = + let veryDarkBlue = ColorRGB 0 0 0.1+ pinkIHope = ColorRGB 1 0.9 0.9+ in style0 {styleNormalTextColor = veryDarkBlue,+ styleNormalEdgeColor = veryDarkBlue,+ styleNormalFillColor = lightGray,+ styleActiveTextColor = pinkIHope,+ styleActiveEdgeColor = pinkIHope+ }++style2 = + let darkPink = ColorRGB 1 0.5 0.5+ in style1 {styleNormalFillColor = white,+ styleActiveTextColor = darkPink,+ styleActiveEdgeColor = darkPink}++style3 = + let semiTranspBlue = ColorRGBA 0 0.2 0.9 0.5+ in style0 {exomargin = 10,+ styleNormalTextColor = yellow,+ styleNormalEdgeColor = yellow,+ styleNormalFillColor = darkBlueGreen,+ styleActiveTextColor = yellow,+ styleActiveEdgeColor = yellow,+ styleActiveFillColor = blueGreen,+ styleAuxColor = semiTranspBlue+ } ++defaultStyle = style3++wstyle :: Style+wstyle = + style3 { + -- smaller to allow multiple frames on one canvas+ styleFont = VFont "serif" FontSlantNormal FontWeightNormal 14,+ textMargin = 8.0,+ hpad = 10.0, vpad = 24.0, + vtinypad = (0.0, 0.0),+ exomargin = 10.0, -- between tree and window edges+ styleFramePad = 15,++ -- colors+ styleNormalTextColor = yellow,+ styleNormalEdgeColor = mediumGray,+ styleNormalFillColor = darkBlueGreen,++ styleActiveTextColor = yellow,+ styleActiveEdgeColor = mediumGray,+ styleActiveFillColor = blueGreen,++ styleSelectedTextColor = black,+ styleSelectedEdgeColor = lightBlueGreen,+ styleSelectedFillColor = lightBlueGreen,++ styleTetherColor =+ ColorRGBA 0.7 0.7 0.7 0.3, -- light gray+ + -- node values+ styleAuxOffset = Position 0 (-16),+ styleAuxFont = VFont "serif" FontSlantItalic FontWeightNormal 12,+ styleAuxColor = ColorRGBA 0.9 0.5 0.5 1.0,+ -- ColorRGBA 1 0.9 0.9 0.75 + styleIoletRadius = 5+ }+ ++pointInLayoutNode :: Position -> LayoutNode e -> Bool+pointInLayoutNode point = pointInGNode point . nodeGNode++pointInGNode :: Position -> GNode e -> Bool+pointInGNode point = pointInBB point . gnodeNodeBB++-- UNUSED: findNode (except in findRect)+-- find the node, if any, containing a point +-- might need to adjust this to take iolets into account ******+findNode :: Position -> TreeLayout e -> Maybe (LayoutNode e)+findNode point (T.Node node@(LayoutNode _rootGNode treeBB) sublayouts) =+ if pointInBB point treeBB+ then if pointInLayoutNode point node+ then Just node+ else findInSubs point sublayouts+ else Nothing++ where findInSubs :: Position -> [TreeLayout e] -> Maybe (LayoutNode e)+ findInSubs _p [] = Nothing+ findInSubs p (l:ls) = + let found = findNode p l in+ case found of+ (Just _) -> found+ Nothing -> findInSubs p ls++-- UNUSED: findRect+findRect :: Position -> TreeLayout e -> Maybe Rectangle+findRect point tlo = + case findNode point tlo of+ Nothing -> Nothing+ Just node -> Just (bbToRect (gnodeNodeBB (nodeGNode node)))++setFont :: VFont -> Render ()+setFont (VFont face slant weight size) = do+ selectFontFace face slant weight+ setFontSize size++data FontTextExtents = FontTextExtents {+ fontAscent::Double, fontDescent::Double, fontHeight::Double,+ fontMaxXadvance::Double, fontMaxYadvance::Double,+ textXbearing::Double, textYbearing::Double,+ extTextWidth::Double, extTextHeight::Double,+ textXadvance::Double, textYadvance::Double}+ deriving (Eq, Read, Show)++measureText :: Style -> String -> Size+measureText style str =+ let extents = styleTextExtents style str+ in Size (textXadvance extents)+ (fontHeight extents + fontDescent extents)++-- Rationale for unsafePerformIO:+-- font extents of a string will not change unless the font itself+-- changes, which is extremely unlikely++styleTextExtents :: Style -> String -> FontTextExtents+styleTextExtents style str = + unsafePerformIO $ + withImageSurface FormatARGB32 0 0 $ \ surface ->+ renderWith surface $ + setFont (styleFont style) >>+ ftExtents str++-- | ftExtents: used for what?+ftExtents :: String -> Render FontTextExtents+ftExtents text = do+ FontExtents asc desc fheight maxxadv maxyadv <- fontExtents+ TextExtents xbear ybear twidth theight xadv yadv <- textExtents text+ return (FontTextExtents asc desc fheight maxxadv maxyadv+ xbear ybear twidth theight xadv yadv)++data TextBox = TextBox {tbText :: String,+ tbTextBB :: BBox, -- BBox of text without margins+ tbBoxBB :: BBox -- of text with margins+ }+ deriving (Eq, Read, Show)++makeTextBox :: Style -> String -> TextBox+makeTextBox style text =+ let extents = styleTextExtents style text+ Size textW textH = measureText style text+ -- textW = textXadvance extents+ -- textH = fontHeight extents + fontDescent extents+ margin = textMargin style++ boxW = textW + 2.0 * margin -- max (textW + 2.0 * margin) minWidth+ boxH = textH + 2.0 * margin++ boxX = 0+ boxY = 0++ textX = (boxW - textW) / 2.0+ -- raise text slightly, by a fraction of its font descent+ -- (why? because it just looks better!)+ -- Maybe this should be made an aspect of style?+ raise = 0.5 * fontDescent extents+ textY = fontHeight extents + (boxH - textH) / 2.0 - raise++ textBB = BBox textX textY textW textH+ boxBB = BBox boxX boxY boxW boxH++ in TextBox text textBB boxBB++instance Widen TextBox where+ widen tb@(TextBox _text textBB boxBB) minWidth =+ let w = bbWidth boxBB+ in if w >= minWidth+ then tb+ else let dw = minWidth - w + in tb {tbTextBB = translate (dw / 2) 0 textBB,+ tbBoxBB = widen boxBB minWidth}++instance Translate TextBox where+ translate dx dy (TextBox text textBB boxBB) = + TextBox text (translate dx dy textBB) (translate dx dy boxBB)+++tbWidth :: TextBox -> Double+tbWidth = bbWidth .tbBoxBB++tbSetWidth :: TextBox -> Double -> TextBox+tbSetWidth tbox w = + let TextBox text textBB boxBB = tbox+ boxBB' = bbSetWidth boxBB w+ (dx, dy) = positionDelta (bbCenter boxBB) (bbCenter boxBB')+ in TextBox text (translate dx dy textBB) boxBB'++tbHeight :: TextBox -> Double+tbHeight = bbHeight . tbBoxBB++tbBottom :: TextBox -> Double+tbBottom = bbBottom . tbBoxBB++-- The geometric "center" of a TextBox is the center of its "BoxBB"+tbCenter :: TextBox -> Position+tbCenter = tbBoxCenter+ +tbBoxCenter :: TextBox -> Position+tbBoxCenter = bbCenter . tbBoxBB++-- and the center of its text should have the same x coordinate,+-- but due to the way text is positioned, maybe not the same y.+-- But do we ever need this?+tbTextCenter :: TextBox -> Position+tbTextCenter = bbCenter . tbTextBB++offsetTextBoxCenters :: Position -> TextBox -> TextBox -> TextBox+offsetTextBoxCenters offset anchor floater =+ -- Position the floater text box so that its center differs+ -- from the anchor text box by the given offset.+ -- (The offset argument comes first, like dx dy in translate.)+ let Position ax ay = tbBoxCenter anchor+ Position fx fy = tbBoxCenter floater+ Position ox oy = offset+ -- translate floater by (dx, dy), where fx + dx = ax + ox, + -- so dx = ax + ox - fx; and dy similarly+ dx = ax + ox - fx+ dy = ay + oy - fy+ in translate dx dy floater+++-- GNode = graphical node, suitable for drawing+data GNode e = GNode {gnodeValue :: e, + gnodeTextBoxes :: [TextBox], -- one or two only+ gnodeNodeBB :: BBox, -- encloses all textboxes+ gnodeInlets :: [Iolet], -- input connectors+ gnodeOutlets :: [Iolet] -- output connectors+ }+ deriving (Eq)++gnodeText :: GNode e -> String+gnodeText = tbText . head . gnodeTextBoxes++gnodeTextBB :: GNode e -> BBox+gnodeTextBB = tbTextBB . head . gnodeTextBoxes++instance (Show e) => Show (GNode e) where+ show (GNode v tbs nodeBB inlets outlets) = + par "GNode" [show v, show tbs, show nodeBB, show inlets, show outlets]++instance (Repr e) => Repr (GNode e) where+ repr (GNode v tbs nodeBB inlets outlets) = + par "GNode" [repr v, show tbs, show nodeBB, show inlets, show outlets]+ +instance Translate (GNode e) where+ translate dx dy (GNode value textboxes nodeBB inlets outlets) = + GNode value + (map (translate dx dy) textboxes)+ (translate dx dy nodeBB)+ (translate dx dy inlets)+ (translate dx dy outlets)+++-- An IoletCounter returns (no. of inlets, no. of outlets)+type IoletCounter e = e -> (Int, Int)++-- A sort of "default" IoletCounter returning zeroes+zeroIoletCounter :: IoletCounter e+zeroIoletCounter _node = (0, 0)++-- An IoletsMaker ???+-- type IoletsMaker e = Style -> e -> ([Position], [Position])++makeGNode :: (Repr e) => Style -> IoletCounter e -> e -> GNode e+makeGNode style countIolets value =+ -- The function countIolets creates a tuple (# of inlets, # of outlets)+ -- for the node, of course being (0, 0) if we don't want any.+ let textboxes1 = map (makeTextBox style) (reprl value)+ textboxes2 = case textboxes1 of+ [_tb] -> textboxes1+ [tb1, tb2] -> + [tb1, + offsetTextBoxCenters (styleAuxOffset style) tb1 tb2]+ _ -> wrong textboxes1+ nodeBB = case textboxes2 of+ [tb] -> tbBoxBB tb+ [tb1, tb2] -> bbMerge (tbBoxBB tb1) (tbBoxBB tb2)+ _ -> wrong textboxes2+ wrong tbs = + errcats ["makeGNode: wrong no. of text boxes;",+ "expected 1 or 2, but got", show (length tbs)]+ (inlets, outlets) = makeIolets style nodeBB (countIolets value)+ in GNode value textboxes2 nodeBB inlets outlets++makeIolets :: Style -> BBox -> (Int, Int) -> ([Iolet], [Iolet])+makeIolets style bbox (nin, nout) =+ -- make the (inlets, outlets)+ (makeIoletsRow style (bbXCenter bbox) (bbBottom bbox) nin,+ makeIoletsRow style (bbXCenter bbox) (bbTop bbox) nout)++makeIoletsRow :: Style -> Double -> Double -> Int -> [Iolet]+makeIoletsRow style cx cy n =+ -- make a row of n Iolets, centered at (cx, cy)+ let radius = styleIoletRadius style+ diam = 2 * radius -- diameter+ w = fromIntegral n * diam+ x1 = cx - w / 2 + radius -- the center of the first iolet+ x i = x1 + fromIntegral (i - 1) * diam+ make i = Iolet (Circle (Position (x i) cy) radius)+ in map make [1..n]++-- | An Iolet is a circular port.+-- Other shapes could be added.+newtype Iolet = Iolet Circle+ deriving (Eq, Read, Show)++instance Translate Iolet where+ translate dx dy (Iolet circle) = Iolet (translate dx dy circle)++ioletCenter :: Iolet -> Position+ioletCenter (Iolet circle) = circleCenter circle++pointInIolet :: Position -> Iolet -> Bool+pointInIolet point (Iolet circle) = pointInCircle point circle++-- Build a Tree of node Sizes parallel to the Repr tree,+-- each node in the Size tree is the size of +-- the corresponding node in the repr tree.++-- treeSizes: given a tree of *node* sizes, for the root nodes of the tree+-- and its subtrees, returns a tree of *tree* sizes++treeSizes :: Style -> Tree (GNode e) -> Tree Size+treeSizes style gTree = + let subtreeSizes = map (treeSizes style) (subForest gTree)+ (BBox _ _ rootWidth rootHeight) = gnodeNodeBB (rootLabel gTree)+ treeWidth = max rootWidth (paddedWidth style subtreeSizes)+ treeHeight = rootHeight + paddedHeight style subtreeSizes+ in T.Node (Size treeWidth treeHeight) subtreeSizes++-- (paddedWidth style subtrees) and (paddedHeight style subtrees)+-- compute the total size of all subtrees+-- of of a Size tree, including padding.+paddedWidth :: Style -> [Tree Size] -> Double+paddedWidth _style [] = 0+paddedWidth style subtrees =+ sum [w | (T.Node (Size w _h) _) <- subtrees] ++ hpad style * fromIntegral (length subtrees - 1)++-- UNUSED:+-- -- | pairSum is unused; should it be?+-- pairSum :: (Double, Double) -> Double+-- pairSum (a, b) = a + b++paddedHeight :: Style -> [Tree Size] -> Double+paddedHeight _style [] = 0+paddedHeight style subtrees = + vpad style + maximum [h | (T.Node (Size _w h) _) <- subtrees]++-- A TreeLayout is a Tree of LayoutNodes.+-- The root node in a TreeLayout identifies the root of the source Tree +-- (nodeSource) and the node's bounding box (nodeNodeBB).+-- It also tells the bounding box of the whole tree (nodeTreeBB).+-- The subtrees of the TreeLayout are the TreeLayouts +-- of the subtrees of the source Tree.++type TreeLayout e = Tree (LayoutNode e)++data LayoutNode e = LayoutNode {nodeGNode :: GNode e,+ nodeTreeBB :: BBox}+ deriving (Eq)++layoutNodeSource :: LayoutNode e -> e+layoutNodeSource = gnodeValue . nodeGNode++instance (Show e) => Show (LayoutNode e) where+ show (LayoutNode gnode treebb) = par "LayoutNode" [show gnode, show treebb]++instance (Repr e) => Repr (LayoutNode e) where+ repr (LayoutNode gnode treebb) = par "LayoutNode" [repr gnode, show treebb]+ +instance Translate (LayoutNode e) where+ translate dx dy (LayoutNode gnode treeBB) = + LayoutNode (translate dx dy gnode)+ (translate dx dy treeBB)++instance Widen (LayoutNode e) where+ widen node@(LayoutNode gNode treeBB) minWidth =+ let dw = bbWidth treeBB - minWidth+ in if dw <= 0+ then node+ else LayoutNode (translate (dw / 2) 0 gNode)+ (widen treeBB minWidth)++-- Try this, it's tough!+-- instance (Draw n, Widen n) = Widen (Tree n) where ...+-- But why not just+-- instance (Widen n) = Widen (Tree n) where ...+++-- UNUSED+-- -- | layoutRootSource: unused+-- layoutRootSource :: TreeLayout e -> e+-- layoutRootSource tree = layoutNodeSource (rootLabel tree)++layoutRootBB :: TreeLayout e -> BBox+layoutRootBB = gnodeNodeBB . nodeGNode . rootLabel++layoutTreeBB :: TreeLayout e -> BBox+layoutTreeBB = nodeTreeBB . rootLabel++treeLayout :: (Repr e) => Style -> IoletCounter e -> Tree e -> TreeLayout e+treeLayout style counter tree = + let t1 = treeGNodes style counter tree+ t2 = treeSizes style t1+ start = Position (hpad style) (vpad style)+ t3 = treeLayout2 style start tree t1 t2+ in treeLayoutAddMargin t3 (exomargin style)+++-- treeGNodes produces a tree of (GNode e),+-- based on a top left corner at (0, 0) which, of course, will need+-- to be translated in the final tlo.++treeGNodes :: Repr e => + Style -> IoletCounter e -> Tree e -> Tree (GNode e)+treeGNodes style counter tree = fmap (makeGNode style counter) tree++treeLayout2 :: (Repr e) =>+ Style -- ^ tree style+ -> Position -- ^ top left after padding+ -> Tree e -- ^ the tree being laid out + -- (actually we don't need the tree as an argument;+ -- it's implied by the GNode tree)+ -> Tree (GNode e) -- ^ "node sizes"+ -> Tree Size -- ^ tree Sizes+ -> TreeLayout e++treeLayout2 style+ (Position startX startY)+ (T.Node _root subtrees)+ (T.Node gnode subGNodes) + (T.Node (Size treeWidth treeHeight) subTreeSizes) + = + let + nodeHeight = bbHeight (gnodeNodeBB gnode)+ -- center the root in its level+ -- UNUSED:+ -- nodeCenterX = startX + treeWidth / 2+ -- nodeCenterY = startY + nodeHeight++ -- center the subtrees (may be wider or narrower than the root)+ subtreesTotalWidth = paddedWidth style subTreeSizes+ subX = startX + (treeWidth - subtreesTotalWidth) / 2 -- first subtree+ subY = startY + nodeHeight + vpad style++ sublayouts :: (Repr e) =>+ Double -> [Tree e] -> [Tree (GNode e)] -> [Tree Size] -> + [TreeLayout e]+ sublayouts _ [] [] [] = []+ sublayouts x (t:ts) (g:gs) (s:ss) = + treeLayout2 style (Position x subY) t g s :+ sublayouts (x + sizeW (rootLabel s) + hpad style) ts gs ss+ sublayouts _ _ _ _ = error "treeLayout2: mismatched list lengths"++ in T.Node (LayoutNode -- root node+ (centerGNode gnode startX startY treeWidth nodeHeight) -- node+ (BBox startX startY treeWidth treeHeight)) -- whole tree+ (sublayouts subX subtrees subGNodes subTreeSizes)++-- | Center a GNode in a rectangular area+centerGNode :: GNode e -> Double -> Double -> Double -> Double -> GNode e+centerGNode gnode startx starty awidth aheight =+ let cx = startx + awidth / 2 -- desired center+ cy = starty + aheight / 2+ Position cgx cgy = bbCenter (gnodeNodeBB gnode)+ in translate (cx - cgx) (cy - cgy) gnode+ +treeLayoutPaddedSize :: Style -> TreeLayout e -> Size+treeLayoutPaddedSize style tlo =+ let Size w h = treeLayoutSize tlo+ in Size (w + 2.0 * hpad style) (h + 2.0 * vpad style)++treeLayoutSize :: TreeLayout e -> Size+treeLayoutSize tlo = + let BBox _x _y w h = layoutTreeBB tlo in Size w h++layoutTreeMoveCenterTo :: + Double -> Double -> TreeLayout e -> TreeLayout e+layoutTreeMoveCenterTo newX newY layoutTree =+ let Position oldX oldY = bbCenter (nodeTreeBB (rootLabel layoutTree))+ in translate (newX - oldX) (newY - oldY) layoutTree++treeLayoutAddMargin :: TreeLayout e -> Double -> TreeLayout e+treeLayoutAddMargin tree margin =+ let LayoutNode {nodeGNode = rootGNode, nodeTreeBB = treeBB} =+ rootLabel tree+ subtrees = subForest tree+ BBox x y w h = treeBB+ treeBB' = BBox (x - margin) (y - margin) + (w + 2 * margin) (h + 2 * margin)+ root' = translate margin margin (LayoutNode rootGNode treeBB')+ subtrees' = translate margin margin subtrees+ in T.Node root' subtrees'++ ++treeLayoutWidth :: TreeLayout e -> Double+treeLayoutWidth = bbWidth . layoutTreeBB++treeLayoutWiden :: TreeLayout e -> Double -> TreeLayout e+treeLayoutWiden tlo minWidth =+ let w = treeLayoutWidth tlo+ in+ if w >= minWidth+ then tlo+ else let dw = minWidth - w+ T.Node root subs = translate (dw / 2) 0 tlo+ LayoutNode rootGNode treeBB = root+ root' = LayoutNode rootGNode + (translate (-dw / 2) + 0 + (widen treeBB minWidth))+ in T.Node root' subs+++
+ lib/Data/Sifflet/WGraph.hs view
@@ -0,0 +1,508 @@+module Data.Sifflet.WGraph + (WNode(..), WEdge(..), WGraph, WContext+ , wgraphNew, isWSimple, isWFrame, grInsertNode, grRemoveNode+ , connectToFrame+ , grConnect, grInletIsConnected, grDisconnect+ , grAddGraph+ , grExtractExprTree, grExtractLayoutNode, grExtractLayoutTree+ + , wlab, llab, nodeExprNode, nodeText, nodeValue+ , nodeBBox, nodePosition, nodeInputValues+ , graphOrphans, adoptChildren+ , nextNode+ , nodeAllChildren, nodeSimpleChildren, allDescendants, nodeFrameChildren+ , nodeAllSimpleDescendants, nodeProperSimpleDescendants+ , nodeIsSimple, nodeIsOpen, nodeContainerFrameNode+ , nodeParent++ , grUpdateFLayout, grUpdateTreeLayout+ , printWGraph+ , translateNodes+ , translateNode, grRelabelNode+ , translateTree+ , functoidParts, functionToParts+ -- Additional operations on graphs+ , nfilter+ )++where ++import Data.List (sort)+import Data.Maybe (fromJust)++import Data.Graph.Inductive as G hiding (nfilter)++import Data.Sifflet.Functoid+import Data.Sifflet.Geometry+import Data.Sifflet.Tree as T -- exports Data.Tree.Tree(Node), etc.+import Data.Sifflet.TreeLayout++import Language.Sifflet.Expr+import Language.Sifflet.ExprTree++import Text.Sifflet.Repr ()++import Language.Sifflet.Util++-- | A WGraph consists of WNodes with (sort of) Int-labled edges;+-- the edge labels serve to order the children of a node.++type WGraph = Gr WNode WEdge++type WContext = Context WNode WEdge++newtype WEdge = WEdge Int+ deriving (Eq, Read, Show)++instance Ord WEdge where+ compare (WEdge i) (WEdge j) = compare i j++-- | Two kinds of WNodes:+-- A WSimple node represents a node in an expression tree, e.g., "if", "+"+-- A WFrame node represents a panel or frame that displays an expression tree,+-- function call, or something similar.++data WNode = WSimple (LayoutNode ExprNode) + | WFrame G.Node+ deriving (Eq, Show)++instance Repr WNode where+ repr (WSimple lnode) = repr (gnodeValue (nodeGNode lnode))+ repr (WFrame _) = "<frame>"++wgraphNew :: WGraph+wgraphNew = empty++isWSimple :: WNode -> Bool+isWSimple (WSimple _) = True+isWSimple _ = False++isWFrame :: WNode -> Bool+isWFrame (WFrame _) = True+isWFrame _ = False++-- | Print a description of the WGraph+printWGraph :: WGraph -> IO ()+printWGraph g = + let vs = nodes g+ wnodeLabel v =+ case lab g v of + Just (WFrame v') ->+ "(WFrame with reference to vertex " ++ show v' ++ ")"+ Just (WSimple (LayoutNode {nodeGNode = gnode})) ->+ repr (gnodeValue gnode)+ Nothing ->+ "(unlabeled!)"+ printVertex v = do+ putStrLn $ "Vertex " ++ show v ++ + " with label " ++ wnodeLabel v+ putStrLn $ " " ++ show (indeg g v) ++ " predecessors: " +++ show [(v', wnodeLabel v') | v' <- pre g v]+ putStrLn $ " " ++ show (outdeg g v) ++ " successors: " +++ show [(v', wnodeLabel v') | v' <- suc g v]+ in do+ putStrLn $ "A WGraph with " ++ show (length vs) ++ " vertices"+ mapM_ printVertex vs++-- | Next node number which may be used in a graph.+-- For an empty graph, this is 0.+-- Otherwise it is 1 + the maximum node in the graph.+nextNode :: (DynGraph g) => g n e -> G.Node+nextNode g =+ if isEmpty g+ then 0+ else let (_, hi) = nodeRange g+ in hi + 1++-- | Insert new node with given label into graph,+-- without any new edges;+-- return the new graph and the new node (number)+grInsertNode :: (DynGraph g) => g n e -> n -> (g n e, G.Node)+grInsertNode graph label =+ let newNode = nextNode graph+ nodeContext = ([], newNode, label, [])+ graph' = nodeContext & graph+ in (graph', newNode)++-- | Remove a node from the graph; return the updated graph.+grRemoveNode :: (DynGraph g) => g n e -> G.Node -> (g n e)+grRemoveNode graph node = + let (mctx, g') = match node graph+ in case mctx of+ Nothing -> errcats ["grRemoveNode: node not found:", show node]+ Just _ -> g'++-- | Connect parent to child, using inlet as the order of the child+-- (0, 1, ...). outlet is ignored, since there is only outlet 0.+-- As rendered, the parent's inlet-th inlet will have a line+-- to the child's outlet-th outlet.+-- This is achieved by inserting a labeled edge (parent, child, inlet)+-- and clearing any incompatible edge. The incompatibles are:+-- a. from same parent on same inlet to a different child.+-- b. from the same parent on a different inlet to the same child.+-- c. from same child (on same outlet) to a different parent.+--+-- NOTE: This is confusing, because, from the data flow perspective,+-- data flows OUT of the child INTO the parent, but from the+-- "tree in graph" perspective, links are directed OUT of the parent+-- INTO the child. So beware!++grConnect :: WGraph -> G.Node -> WEdge -> G.Node -> WEdge -> WGraph+grConnect g parent inlet child _outlet =+ let (mPcontext, g') = match parent g+ in case mPcontext of+ Nothing -> error "grConnect: parent not found"+ -- should parent below be same as parent above?+ Just (pins, jparent, plabel, pouts) ->+ -- jparent == parent+ let pouts' = filter (edgeNotTo child)+ (filter (edgeNotEqual inlet) pouts)+ (mCcontext, g'') = match child g'+ in case mCcontext of+ Nothing -> error "grConnect: child not found"+ Just (_cins, jchild, clabel, couts) ->+ -- jchild == child+ -- remove ANY links into the jchild (c)+ let cins' = []+ in + (pins, jparent, plabel, (inlet, jchild) : pouts') & + ((cins', jchild, clabel, couts) & g'')++-- | Tell whether a parent node already has a child connected on+-- the given inlet.++grInletIsConnected :: WGraph -> G.Node -> WEdge -> Bool+grInletIsConnected graph parent inlet =+ let (mContext, _g) = match parent graph+ in case mContext of+ Nothing -> + error "grConnect: parent not found"+ Just (_ins, _parent, _label, outs) ->+ -- _parent == parent+ any (edgeEqual inlet) outs+ +++edgeEqual :: WEdge -> (WEdge, G.Node) -> Bool+edgeEqual edge pair = edge == fst pair++edgeNotEqual :: WEdge -> (WEdge, G.Node) -> Bool+edgeNotEqual edge = not . edgeEqual edge++edgeNotTo :: G.Node -> (WEdge, G.Node) -> Bool+edgeNotTo node pair = node /= snd pair++-- | Removes a link between parent and child+-- where the edge was labeled inlet (order of child).+-- Ignores outlet, which should always be 0.+-- If child is not the inlet-th child of parent,+-- well, this is an error, but grDisconnect ignores it.+-- If toFrameP is true, the child node is+-- reconnected as a child to its frame+grDisconnect :: WGraph -> G.Node -> WEdge -> G.Node -> WEdge -> Bool -> WGraph+grDisconnect g parent inlet child _outlet toFrameP =+ let (mcontext, g') = match parent g+ g'' = case mcontext of+ Nothing -> error "grDisconnect: parent not found"+ Just (ins, jparent, label, outs) ->+ -- jparent == parent+ let outs' = filter (/= (inlet, child)) outs+ in (ins, jparent, label, outs') & g'+ in if toFrameP+ then connectToFrame child (nodeContainerFrameNode g parent) g''+ else g''++connectToFrame :: G.Node -> G.Node -> WGraph -> WGraph+connectToFrame child frameNode g =+ insEdge (frameNode, child, WEdge (outdeg g frameNode)) g++grAddGraph :: (DynGraph g) => g n e -> g n e -> g n e+grAddGraph g1 g2 =+ if isEmpty g1 then g2+ else if isEmpty g2 then g1+ else let (_, hi1) = nodeRange g1+ (lo2, _) = nodeRange g2+ diff = hi1 - lo2 + 1++ adjIncr :: Adj e -> Adj e+ adjIncr adj = [(x, node + diff) | (x, node) <- adj]++ ctxIncr :: Context n e -> Context n e+ ctxIncr (adjFrom, node, label, adjTo) = + (adjIncr adjFrom, node + diff, label, adjIncr adjTo)++ loop :: (DynGraph g) => g n e -> g n e -> g n e+ loop ga gb =+ if isEmpty gb+ then ga+ else let (acontext, gb') = matchAny gb in+ ctxIncr acontext & loop ga gb'+ in loop g1 g2++-- | Extract from a graph the expression with root node n, +-- returning a Tree of ExprNode.+-- Use only the WSimple nodes of the graph (and n had better be one).+grExtractExprTree :: WGraph -> G.Node -> Tree ExprNode+grExtractExprTree g = fmap layoutNodeSource . grExtractLayoutTree g++-- ------------------------------------------------------------+-- | Finding characteristics of the WNodes in a graph+-- It is an implicit error if there is no label for the node++-- | wlab is like lab with no Maybe: the node *must* have a label+wlab :: WGraph -> Node -> WNode+wlab g n = fromJust (lab g n)++-- | llab is the tree layout node of a WSimple node+llab :: WGraph -> Node -> LayoutNode ExprNode+llab g n = + case wlab g n of+ WSimple lnode -> lnode+ WFrame _fnode ->+ errcat ["llab: node is not simple",+ "\nnode ", (show n),+ "\n in graph\n",+ (show g)]++-- | The ExprNode represented by the graph node+nodeExprNode :: WGraph -> Node -> ExprNode+nodeExprNode g n = gnodeValue (nodeGNode (llab g n))++-- | The repr of the node's value+nodeText :: WGraph -> Node -> String+nodeText g n = tbText (head (gnodeTextBoxes (nodeGNode (llab g n))))++-- | The result of an evaluated node in an expression tree+nodeValue :: WGraph -> Node -> EvalResult+nodeValue g n = mvalue+ where ENode _ mvalue = nodeExprNode g n++-- | The node's BBox+nodeBBox :: WGraph -> Node -> BBox+nodeBBox g n = gnodeNodeBB (nodeGNode (llab g n))++nodePosition :: WGraph -> Node -> Position+nodePosition g = bbPosition . nodeBBox g++nodeInputValues :: WGraph -> Node -> EvalResult+nodeInputValues graph node = + mapM (nodeValue graph) (nodeSimpleChildren graph node) >>= + EvalOk . VList++-- | Find all parentless nodes in a graph+graphOrphans :: (Graph graph) => graph a b -> [Node]+graphOrphans g = filter (\ v -> pre g v == []) (nodes g)+ +-- | Connect the given children to a new parent+adoptChildren :: WGraph -> G.Node -> [G.Node] -> WGraph+adoptChildren g0 parent children =+ let adopt g child = insEdge (parent, child, WEdge (outdeg g parent)) g+ in foldl adopt g0 children++-- | Finding the children (nodes, numbers) of a node in a graph :+-- all children, only WSimple-labeled children, only WFrame-labeled children+-- When constructing the graph, ordered children of a tree node +-- get graph node numbers in ascending order; therefore,+-- sorting the graph nodes gives back the original order of+-- children in the tree (plus WFrames that are added later,+-- and those should always be after the simple children)++nodeAllChildren :: WGraph -> Node -> [Node]+nodeAllChildren g n = sort (suc g n) ++nodeSimpleChildren :: WGraph -> Node -> [Node]+nodeSimpleChildren g n = filter (nodeIsSimple g) (nodeAllChildren g n)++-- | All (proper and improper) descendants of a node in a graph+allDescendants :: (Graph graph) => graph a b -> Node -> [Node]+allDescendants g n = reachable n g++nodeAllSimpleDescendants :: WGraph -> Node -> [Node]+nodeAllSimpleDescendants g n = + n : concatMap (nodeAllSimpleDescendants g) (nodeSimpleChildren g n)++nodeProperSimpleDescendants :: WGraph -> Node -> [Node]+nodeProperSimpleDescendants g n = tail (nodeAllSimpleDescendants g n)++nodeFrameChildren :: WGraph -> Node -> [Node]+nodeFrameChildren g n = filter (not . nodeIsSimple g) (nodeAllChildren g n)+ +nodeIsSimple :: WGraph -> Node -> Bool+nodeIsSimple g n = + -- is node n of graph g a WSimple node?+ case lab g n of+ Just (WSimple _) -> True+ _ -> False++-- | An open node has a WFrame-labeled child+nodeIsOpen :: WGraph -> Node -> Bool+nodeIsOpen graph node = nodeFrameChildren graph node /= []++-- The root node of the tree in which node occurs.+-- This is a WSimple node, it may not back up to a WFrame node.+--+-- THIS CODE IS UNTESTED, AND CURRENTLY UNUSED (2009/2/4)++-- -- nodeTreeRoot: unused+-- nodeTreeRoot :: WGraph -> Node -> Node+-- nodeTreeRoot g n = findRoot n+-- where findRoot node = +-- case pre g node of+-- [] -> (error "nodeTreeRoot: no simple root found")+-- [parent] -> +-- if not (nodeIsSimple g parent)+-- then node+-- else findRoot parent+-- _ -> error "nodeTreeRoot: node has multiple parents"++-- -- The root (a WSimple node) of the tree in which a node occurs+-- -- Huh, don't need this!++-- -- nodeSimpleRoot: unused+-- nodeSimpleRoot :: WGraph -> Node -> Node+-- nodeSimpleRoot = undefined++-- | The graph node of the frame that contains the given node+nodeContainerFrameNode :: WGraph -> Node -> Node+nodeContainerFrameNode g n = + let findFrame node =+ if not (nodeIsSimple g node)+ then node+ else case pre g node of+ [parent] -> findFrame parent+ [] -> err "has no parent but is not a frame node" node+ _:_ -> err "has multiple parents" node+ err msg node =+ errcat["nodeContainerFrameNode: node ",+ show node, " ", msg, "\n",+ "in graph\n", show g]+ + in findFrame n++-- | The parent (if any) of a node+nodeParent :: WGraph -> Node -> Maybe Node+nodeParent g n = + case pre g n of+ [] -> Nothing+ [parent] -> Just parent+ _ -> error "nodeParent: multiple parents"+++grUpdateFLayout :: WGraph -> [G.Node] -> FunctoidLayout -> WGraph+grUpdateFLayout gr ns tlo =+ case tlo of+ FLayoutTree t -> + case ns of+ [rootNode] -> grUpdateTreeLayout gr rootNode t+ _ -> error "grUpdateFLayout: tree tlo, but not a single root"+ FLayoutForest f _b ->+ let accum g (n, t) = grUpdateTreeLayout g n t+ in foldl accum gr (zip ns f)++-- | Replace the tree embedded in graph g with root n, with a new tree.+grUpdateTreeLayout :: WGraph -> G.Node -> TreeLayout ExprNode -> WGraph+grUpdateTreeLayout gr n0 t0 = updateTree gr n0 t0+ where updateTree g n (T.Node root subtrees) =+ case match n g of+ (Just (adjFrom, jn, WSimple _, adjTo), g1) ->+ -- jn == n+ let g2 = (adjFrom, jn, WSimple root, adjTo) & g1+ in updateForest g2 (nodeSimpleChildren g jn) subtrees+ (Just (_adjFrom, _n, _, _adjTo), _) ->+ error "grUpdateTreeLayout: root node is not a WSimple"+ (Nothing, _) -> + errcats ["grUpdateTreeLayout: no such node:", show n]++ updateForest g [] [] = g+ updateForest g (n:ns) (t:ts) = + case lab g n of+ Just (WSimple _) -> updateForest (updateTree g n t) ns ts+ Just (WFrame _) -> updateForest g ns (t:ts) -- shouldn't happen!+ Nothing -> error "grUpdateTreeLayout: no label for node"++ updateForest _g _ [] = error "too many ns"+ updateForest _g [] _ = error "too many ts"++-- | Extract just the single tree layout node of the given graph node+grExtractLayoutNode :: WGraph -> G.Node -> LayoutNode ExprNode+grExtractLayoutNode g n =+ case lab g n of+ Just (WSimple lnode) -> lnode+ _ -> errcats ["grExtractLayoutNode:",+ "no label for node, or node is not WSimple:",+ "node", show n]++-- | Extract the tree layout (tree) descended from the given root node+grExtractLayoutTree :: WGraph -> G.Node -> TreeLayout ExprNode+grExtractLayoutTree g n =+ T.Node (grExtractLayoutNode g n)+ (map (grExtractLayoutTree g) (nodeSimpleChildren g n))+++-- | Translate the nodes forming a tree with the given root+translateTree :: Double -> Double -> WGraph -> G.Node -> WGraph+translateTree dx dy wgraph root = + grUpdateTreeLayout wgraph root + (translate dx dy (grExtractLayoutTree wgraph root))+++translateNodes :: Double -> Double -> WGraph -> [G.Node] -> WGraph+translateNodes dx dy = foldl (translateNode dx dy)++translateNode :: Double -> Double -> WGraph -> G.Node -> WGraph+translateNode dx dy wg node =+ case match node wg of+ (Nothing, _) ->+ errcats ["translateNode: no such node:", show node]+ (Just (adjFrom, jnode, WSimple layoutNode, adjTo), g') ->+ -- jnode == node+ (adjFrom, jnode, WSimple (translate dx dy layoutNode), adjTo) & g'+ (Just _, _) ->+ errcats ["translateNode: node is not a WSimple:", show node]+++-- | Replace the label of a node in a graph+grRelabelNode :: (DynGraph g) => g a b -> G.Node -> a -> g a b+grRelabelNode g n newLabel =+ case match n g of+ (Just (adjFrom, jn, _oldLabel, adjTo), g') ->+ -- jn == n+ (adjFrom, jn, newLabel, adjTo) & g'+ (Nothing, _) -> errcats ["grRelabelNode: no such node:", show n]++-- | Get the parts of a Functoid.+-- See note on functionToParts (just below).+-- Seems to be unused ***++functoidParts :: Functoid -> WGraph -> G.Node -> Functoid+functoidParts functoid graph frameNode =+ case functoid of+ fp@FunctoidParts {} -> fp+ FunctoidFunc function -> functionToParts function graph frameNode++-- | Convert a function to its parts.+-- COULDN'T THIS BE DONE USING the function's implementation,+-- and not need to use the graph? Then this could go in Functoid.hs+-- without circular import between it and WGraph+functionToParts :: Function -> WGraph -> G.Node -> Functoid+functionToParts (Function mname _atypes _rtype impl) graph frameNode =+ case impl of + Primitive _ -> error "functionToParts: function is primitive"+ Compound argnames _body ->+ FunctoidParts {fpName = case mname of+ Nothing -> "unnamed function"+ Just jname -> jname,+ fpArgs = argnames, + fpNodes = nodeProperSimpleDescendants graph frameNode}++++-- | Filter the nodes of a graph++nfilter :: (Node -> Bool) -> Gr v e -> Gr v e+nfilter f g =+ nfilter' f g (nodes g)++nfilter' :: (Node -> Bool) -> Gr v e -> [Node] -> Gr v e+nfilter' _f g [] = g+nfilter' f g (n:ns) = nfilter' f (if f n then g else delNode n g) ns
+ lib/Graphics/Rendering/Sifflet/Draw.hs view
@@ -0,0 +1,223 @@+module Graphics.Rendering.Sifflet.Draw+ ( + Draw(..), DrawMode(..)+ , drawBox+ , drawTextBox+ , modeTextCol, modeEdgeCol, modeFillCol+ , setColor++ )++where++import Control.Monad+import Graphics.Rendering.Cairo hiding (translate)++import Data.Sifflet.Functoid+import Data.Sifflet.Geometry+import Data.Sifflet.Tree+import Data.Sifflet.TreeLayout++setColor :: VColor -> Render ()++setColor (ColorRGB red green blue) =+ setSourceRGB red green blue ++setColor (ColorRGBA red green blue alpha) =+ setSourceRGBA red green blue alpha++-- Drawing things+-- THINK: is this class well conceived?+-- A lot of things could be done with draw and translate+-- if it were not tied to Style and DrawMode++class Draw a where+ draw :: Style -> DrawMode -> a -> Render ()++-- VV DrawMode is now very awkward, since +-- a node needs to know not only if it is selected,+-- but which port(s) are selected++data DrawMode = DrawNormal | DrawActive + | DrawSelectedNode + | DrawSelectedInlet Int + | DrawSelectedOutlet Int+ deriving (Eq)++instance Draw FunctoidLayout where+ draw style mode (FLayoutTree t) = draw style mode t+ draw style mode (FLayoutForest f _) = draw style mode f++instance (Draw e) => Draw [e] where+ draw style mode = mapM_ (draw style mode)++instance (Draw e) => Draw (Tree e) where+ draw style mode t = do+ draw style mode (rootLabel t)+ draw style mode (subForest t)++instance Draw (LayoutNode e) where+ draw style mode (LayoutNode gnode _treeBB) = draw style mode gnode++instance Draw (GNode e) where++ draw style mode (GNode _value textboxes nodeBB inlets outlets) = + do+ -- draw node box+ let (nodeTextCol, nodeEdgeCol, nodeFillCol) = + case mode of+ DrawActive -> + (styleActiveTextColor, + styleActiveEdgeColor,+ styleActiveFillColor)+ DrawSelectedNode -> + (styleSelectedTextColor, + styleSelectedEdgeColor,+ styleSelectedFillColor)+ _ -> (styleNormalTextColor, + styleNormalEdgeColor, + styleNormalFillColor)+ + -- (overall box for the node)+ when (styleShowNodeBoxes style) $+ drawBox (Just (nodeFillCol style))+ (Just (nodeEdgeCol style)) nodeBB+ ++ -- assert textboxes has one or two elements+ -- draw the first text box+ drawTextBox (Just (styleFont style))+ (Just (nodeFillCol style)) -- background+ Nothing -- frame color+ (nodeTextCol style) -- text color+ (head textboxes)++ -- draw the second textbox, if any, using "aux" style+ case (tail textboxes) of+ [tbAux] -> + drawTextBox (Just (styleAuxFont style))+ Nothing+ Nothing+ (styleAuxColor style)+ tbAux+ _ -> return ()+++ -- Draw the iolets+ when (styleShowNodePorts style) $ do+ drawInlets style mode inlets+ drawOutlets style mode outlets+ ++instance Draw TextBox where+ draw style mode =+ drawTextBox (Just (styleFont style))+ (Just (modeFillCol mode style)) + Nothing+ (modeTextCol mode style) ++drawTextBox :: Maybe VFont -> Maybe VColor -> Maybe VColor -> VColor ->+ TextBox -> Render ()+drawTextBox mfont mbgcolor mframecolor textcolor + (TextBox text textBB boxBB) = do+ let BBox textX textY _textW _textH = textBB+ drawBox mbgcolor mframecolor boxBB+ setColor textcolor+ case mfont of + (Just font) -> setFont font+ _ -> return ()+ moveTo textX textY+ showText text++instance Draw BBox where+ draw style mode = + drawBox (Just (modeFillCol mode style)) + (Just (modeEdgeCol mode style)) ++drawBox :: Maybe VColor -> Maybe VColor -> BBox -> Render ()+drawBox mBgColor mFgColor (BBox x y w h) = + -- draw the BBox, in the specified colors, irrespective of style+ let setup color = + do+ rectangle x y w h+ setColor color+ in case (mBgColor, mFgColor) of+ (Just bgColor, Just fgColor) ->+ do+ setup bgColor+ fillPreserve+ setColor fgColor+ stroke+ (Just bgColor, Nothing) -> + do+ setup bgColor+ fill+ (Nothing, Just fgColor) -> + do+ setup fgColor+ stroke+ _ -> return ()++instance Draw Position where+ draw _style _mode _pos = return () -- bare points are invisible ??? ******++instance Draw Iolet where+ draw style mode (Iolet circle) = draw style mode circle++drawIolet :: Iolet -> VColor -> VColor -> Render ()+drawIolet (Iolet circle) = drawCircle circle++drawInlets :: Style -> DrawMode -> [Iolet] -> Render ()+drawInlets style mode inlets =+ let selected i = mode == DrawSelectedInlet i+ in drawIolets selected style inlets++drawOutlets :: Style -> DrawMode -> [Iolet] -> Render ()+drawOutlets style mode outlets =+ let selected o = mode == DrawSelectedOutlet o+ in drawIolets selected style outlets++drawIolets :: (Int -> Bool) -> Style -> [Iolet] -> Render ()+drawIolets selected style iolets =+ -- (selected n) should be true iff n is the selected iolet+ let loop _ [] = return ()+ loop n (p:ps) = + uncurry (drawIolet p)+ (if selected n + then (styleSelectedFillColor style, + styleSelectedEdgeColor style)+ else (styleNormalFillColor style, + styleNormalEdgeColor style)) >>+ loop (n + 1) ps+ in loop 0 iolets+ +instance Draw Circle where+ draw style mode circle = + drawCircle circle (modeFillCol mode style) (modeEdgeCol mode style) ++drawCircle :: Circle -> VColor -> VColor -> Render ()+drawCircle (Circle (Position x y) r) bgColor fgColor = do+ newPath -- otherwise we get a line to the arc+ arc x y r 0 (2 * pi)+ setColor bgColor+ fillPreserve+ setColor fgColor+ stroke++-- Helper functions to find the background and foreground colors for a mode++modeFillCol :: DrawMode -> (Style -> VColor)+modeFillCol DrawNormal = styleNormalFillColor+modeFillCol DrawActive = styleActiveFillColor+modeFillCol _ = styleSelectedFillColor++modeTextCol :: DrawMode -> (Style -> VColor)+modeTextCol DrawNormal = styleNormalTextColor+modeTextCol DrawActive = styleActiveTextColor+modeTextCol _ = styleSelectedTextColor++modeEdgeCol :: DrawMode -> (Style -> VColor)+modeEdgeCol DrawNormal = styleNormalEdgeColor+modeEdgeCol DrawActive = styleActiveEdgeColor+modeEdgeCol _ = styleSelectedEdgeColor+
+ lib/Graphics/Rendering/Sifflet/DrawTreeGraph.hs view
@@ -0,0 +1,165 @@+-- | Tree graph rendering+module Graphics.Rendering.Sifflet.DrawTreeGraph+ (+ graphWriteImageFile, graphRender,+ treeRender, treeWriteImageFile, gtkShowTree+ )++where++import Data.IORef+import Graphics.UI.Gtk.Gdk.EventM++import Graphics.Rendering.Cairo hiding (translate, x, y)+import Data.Graph.Inductive as G++import System.Glib.UTFString (glibToString)++import Graphics.UI.Sifflet.LittleGtk++import Data.Sifflet.Geometry+import Data.Sifflet.Tree+import Data.Sifflet.TreeGraph+import Data.Sifflet.TreeLayout+import Graphics.Rendering.Sifflet.Draw+import Text.Sifflet.Repr ()++-- ============================================================+-- GRAPH VIEWING AND RENDERING+-- ============================================================++graphWriteImageFile :: (Repr n) => + Style -> Maybe Node -> Maybe Node ->+ Double -> Double -> + LayoutGraph n e -> String -> + IO String +graphWriteImageFile style mactive mselected dwidth dheight graph file = do+ withImageSurface FormatARGB32 (round dwidth) (round dheight) $ \surf -> do+ renderWith surf $ + graphRender style mactive mselected graph+ surfaceWriteToPNG surf file+ return file++graphRender :: (Repr n) => + Style -> Maybe Node -> Maybe Node -> LayoutGraph n e -> + Render ()+graphRender style mactive mselected graph = do+ let renderNode :: Node -> Render ()+ renderNode node = do+ let Just layoutNode = lab graph node + -- ^^ is this safe? it can't be Nothing?+ nodeBB = gnodeNodeBB (nodeGNode layoutNode)+ active = (mactive == Just node)+ selected = case mselected of+ Nothing -> False+ Just sel -> sel == node+ mode = if active then DrawActive+ else if selected then DrawSelectedNode -- !!!+ else DrawNormal+ xcenter = bbXCenter nodeBB+ draw style mode layoutNode+ connectParent node xcenter (bbTop nodeBB)+ return ()++ connectParent node x y = + let parents = pre graph node in+ case parents of+ [] -> return ()+ [parent] -> do+ let Just playoutNode = lab graph parent+ parentBB = gnodeNodeBB (nodeGNode playoutNode)+ px = bbXCenter parentBB+ py = bbBottom parentBB+ setColor (styleNormalEdgeColor style)+ moveTo px (py + snd (vtinypad style)) -- bottom of parent+ lineTo x (y - fst (vtinypad style)) -- top of node+ stroke++ _ -> error "Too many parents"+ + setAntialias AntialiasDefault++ -- canvas background+ setColor (styleNormalFillColor style)+ let Just layoutNode = lab graph 1 -- root node, represents whole tree+ BBox x y bwidth bheight = nodeTreeBB layoutNode+ rectangle x y bwidth bheight+ fill++ -- draw the graph/tree+ setLineWidth (lineWidth style)+ mapM_ renderNode (nodes graph)++treeRender :: (Repr e) => Style -> TreeLayout e -> Render ()+treeRender style = graphRender style Nothing Nothing . orderedTreeToGraph++treeWriteImageFile :: (Repr e) => + Style -> IoletCounter e -> Tree e -> String -> IO String++treeWriteImageFile style counter atree filename = do+ let tlo = treeLayout style counter atree+ Size surfWidth surfHeight = treeLayoutPaddedSize style tlo+ withImageSurface FormatARGB32 (round surfWidth) (round surfHeight) $ + \ surf -> do+ renderWith surf $ treeRender style tlo+ surfaceWriteToPNG surf filename+ return filename++-- ============================================================+-- Simple tree viewing.+-- gtkShowTree displays a single tree very simply+-- Works for any kind of (Repr e, Show e) => Tree e.++gtkShowTree :: (Repr e, Show e) => + Style -> IoletCounter e -> Tree e -> IO ()+gtkShowTree style counter atree = do+ let tlo = treeLayout style counter atree+ Size dwidth dheight = treeLayoutPaddedSize style tlo++ tloRef <- newIORef tlo++ _ <- initGUI++ -- init window+ window <- windowNew+ set window [windowTitle := "Test Cairo Tree"]+ _ <- onDestroy window mainQuit++ -- init vbox+ vbox <- vBoxNew False 5 -- width not homogeneous; spacing+ set window [containerChild := vbox]++ -- init canvas+ canvas <- layoutNew Nothing Nothing+ _ <- onSizeRequest canvas + (return (Requisition (round dwidth) (round dheight)))+ widgetSetCanFocus canvas True -- to receive key events++ -- event handlers+ _ <- on canvas exposeEvent (updateCanvas style canvas tloRef)+ _ <- on canvas keyPressEvent (keyPress window)++ -- pack, show, and run+ boxPackStartDefaults vbox canvas+ widgetShowAll window+ mainGUI++updateCanvas :: (Repr e) => Style -> Layout -> IORef (TreeLayout e) + -> EventM EExpose Bool+updateCanvas style canvas tloRef = + tryEvent $ liftIO $ do+ { + tlo <- readIORef tloRef+ ; win <- layoutGetDrawWindow canvas+ ; renderWithDrawable win (treeRender style tlo)+ }++keyPress :: Window -> EventM EKey Bool+keyPress window =+ tryEvent $ do+ {+ kname <- eventKeyName+ ; case glibToString kname of+ "q" -> liftIO $ widgetDestroy window -- implies mainQuit+ _ -> stopEvent+ }
+ lib/Graphics/UI/Sifflet.hs view
@@ -0,0 +1,30 @@+{- Workspace.hs implements the graphical workspace of Sifflet -}++module Graphics.UI.Sifflet+ (+ module Graphics.UI.Sifflet.Frame+ , module Graphics.UI.Sifflet.LittleGtk+ , module Graphics.UI.Sifflet.RPanel+ , module Graphics.UI.Sifflet.Types+ , module Graphics.UI.Sifflet.Callback+ , module Graphics.UI.Sifflet.Canvas+ , module Graphics.UI.Sifflet.Tool+ , module Graphics.UI.Sifflet.Workspace+ , module Graphics.UI.Sifflet.GtkForeign+ , module Graphics.UI.Sifflet.GtkUtil+ , module Graphics.UI.Sifflet.Window+ )++where++import Graphics.UI.Sifflet.Callback+import Graphics.UI.Sifflet.Canvas+import Graphics.UI.Sifflet.Frame+import Graphics.UI.Sifflet.Tool+import Graphics.UI.Sifflet.Workspace+import Graphics.UI.Sifflet.GtkForeign+import Graphics.UI.Sifflet.GtkUtil+import Graphics.UI.Sifflet.LittleGtk+import Graphics.UI.Sifflet.RPanel+import Graphics.UI.Sifflet.Types+import Graphics.UI.Sifflet.Window
+ lib/Graphics/UI/Sifflet/Callback.hs view
@@ -0,0 +1,152 @@+module Graphics.UI.Sifflet.Callback+ (+ CBMgr, CBMgrAction, CBMgrCmd(..), mkCBMgr+ , MenuSpec(..), MenuItemSpec(..), MenuItemAction+ , createMenuBar, addMenu, createMenu, createMenuItem+ , modifyIORefIO+ ) ++where++import Data.IORef++import Graphics.UI.Gtk++import Graphics.UI.Sifflet.Types++-- | The CBMgr (Callback manager) encapsulates (in an enclosure, no less!)+-- an IORef VPUI. It is used *solely* to set up callbacks+-- and similar stuff in Gtk, where the callback needs access+-- to the IORef. By passing a CBMgr to a function, we can+-- avoid passing the IORef directly, and all the harm and+-- confusion that could result.+--+-- We only need *one* CBMgr for the application;+-- however, two CBMgrs with the same IORef are logically equivalent,+-- so there would be no harm in having two as long as they share one IORef.+type CBMgr = CBMgrCmd -> IO ()++type CBMgrAction = IORef VPUI -> IO ()++-- | Commands for the CBMgr+data CBMgrCmd+ = -- window events+ OnWindowConfigure Window (IORef VPUI -> EventM EConfigure Bool)+ | OnWindowDestroy Window CBMgrAction+ | AfterWindowKeyPress Window (IORef VPUI -> EventM EKey Bool)+ -- layout events+ | OnLayoutExpose Layout (IORef VPUI -> EventM EExpose Bool)+ | OnLayoutMouseMove Layout (IORef VPUI -> EventM EMotion Bool)+ | OnLayoutButtonPress Layout (IORef VPUI -> EventM EButton Bool)+ | OnLayoutButtonRelease Layout (IORef VPUI -> EventM EButton Bool)+ -- other events+ | OnMenuItemActivateLeaf MenuItem (VPUI -> IO VPUI)+ | OnEntryActivate Entry CBMgrAction+ | AfterButtonClicked Button CBMgrAction++ -- Surrender the UIRef to an arbitrary action+ | WithUIRef CBMgrAction ++ | UMTest++-- | Create the CBMgr+mkCBMgr :: IORef VPUI -> CBMgr+mkCBMgr uiref cmd = + case cmd of+ -- window events+ OnWindowConfigure window action ->+ on window configureEvent (action uiref) >> return ()+ OnWindowDestroy window action ->+ onDestroy window (action uiref) >> return ()+ AfterWindowKeyPress window action ->+ after window keyPressEvent (action uiref) >> return ()+ -- layout events+ OnLayoutExpose layout action ->+ on layout exposeEvent (action uiref) >> return ()+ OnLayoutMouseMove layout action ->+ on layout motionNotifyEvent (action uiref) >> return ()+ OnLayoutButtonPress layout action ->+ on layout buttonPressEvent (action uiref) >> return ()+ OnLayoutButtonRelease layout action ->+ on layout buttonReleaseEvent (action uiref) >> return ()+ -- other events+ OnMenuItemActivateLeaf menuItem action ->+ onActivateLeaf menuItem (modifyIORefIO action uiref) >> return ()+ OnEntryActivate entry action ->+ onEntryActivate entry (action uiref) >> return ()+ AfterButtonClicked button action ->+ afterClicked button (action uiref) >> return ()++ -- Not an event at all; the fact that I need this means the+ -- CBMgr concept was misguided!+ WithUIRef action -> action uiref++ UMTest -> + putStrLn "UMTest"+++-- ============================================================+-- MENUS++-- Easy creation of menus from lists.+-- Originally from ~/src/haskell-etudes/gtk2hs/gMenu.hs++data MenuSpec = MenuSpec String [MenuItemSpec]+data MenuItemSpec = MenuItem String MenuItemAction+ | SubMenu MenuSpec++type MenuItemAction = VPUI -> IO VPUI -- was just IO ()++createMenuBar :: [MenuSpec] -> CBMgr -> IO MenuBar+createMenuBar menuSpecs cbmgr = do+ bar <- menuBarNew+ mapM_ (addMenu bar cbmgr) menuSpecs+ return bar++addMenu :: MenuBar -> CBMgr -> MenuSpec -> IO ()+addMenu mbar cbmgr mspec@(MenuSpec name _itemSpecs) = do+ menuHead <- menuItemNewWithLabel name -- visible "item" at top of the menu+ menuShellAppend mbar menuHead+ -- Right-justify help menu.+ -- Deprecated (bad for right-to-left languages),+ -- but retained for compatibility with menus_hard.py.+ menuItemSetRightJustified menuHead (name == "Help") -- ??????++ -- menu = the container for menu items+ menu <- createMenu mspec cbmgr+ menuItemSetSubmenu menuHead menu++createMenu :: MenuSpec -> CBMgr -> IO Menu+createMenu (MenuSpec _name itemSpecs) cbmgr = do+ menu <- menuNew+ mapM_ (createMenuItem menu cbmgr) itemSpecs+ return menu++createMenuItem :: Menu -> CBMgr -> MenuItemSpec -> IO ()+createMenuItem menu cbmgr mispec = + case mispec of+ MenuItem label action ->+ do+ {+ item <- menuItemNewWithLabel label+ ; cbmgr (OnMenuItemActivateLeaf item action)+ -- may need to read/write IORef here ***+ ; menuShellAppend menu item+ }+ SubMenu subspec@(MenuSpec label _itemSpecs) ->+ do+ {+ item <- menuItemNewWithLabel label+ ; submenu <- createMenu subspec cbmgr + ; menuItemSetSubmenu item submenu+ ; menuShellAppend menu item+ }++-- | Read an IORef, update with IO, and write the updated value.+-- This is like (flip modifyIORef), but the type of the +-- first argument is (a -> IO a) instead of (a -> a).+-- Note that if a = VPUI, then updateIO :: VPUI -> IO VPUI+-- and consequently modifyIORefIO updateIO :: CBMgrAction.++modifyIORefIO :: (a -> IO a) -> IORef a -> IO ()+modifyIORefIO updateIO ref = readIORef ref >>= updateIO >>= writeIORef ref
+ lib/Graphics/UI/Sifflet/Canvas.hs view
@@ -0,0 +1,1014 @@+-- File: Canvas.hs+-- Canvas and CanvFrame data and operations++module Graphics.UI.Sifflet.Canvas+ (+ atLeastSize+ , cfContext+ , connect+ , defaultFileSaveClipBox+ , disconnect+ , drawCanvas+ , editFunction+ , frameChanged+ , nodeContainerFrame+ , pointSelection+ , renderCanvas+ , vcAddFrame+ , vcClearSelection+ , vcClearFrame+ , vcCloseFrame+ , vcEvalDialog+ , vcFrameAddFunctoidNode+ , vcFrameAddNode+ , vcFrameDeleteNode+ , vcFrameDeleteTree+ , vcFrameSubframes+ , vcGetFrame+ , vcInvalidateFrameWithParent+ , vcInvalidateBox+ , vcUpdateFrameAndGraph+ , vcanvasNew+ , vcanvasNodeAt+ , vcanvasNodeRect+ , whichFrame + , callFrames+ )++where++-- debug imports+-- import System.IO.Unsafe++-- standard imports++import Control.Monad+import Data.List as List++import Data.Graph.Inductive as G++import Graphics.Rendering.Cairo hiding (translate)+import qualified Graphics.Rendering.Cairo as Cairo++-- Sifflet imports++import Data.Sifflet.Functoid+import Data.Sifflet.Geometry as Geometry+import Data.Sifflet.Tree as T+import Data.Sifflet.TreeGraph+import Data.Sifflet.TreeLayout+import Data.Sifflet.WGraph++import Language.Sifflet.Expr+import Language.Sifflet.ExprTree+import Language.Sifflet.Parser++import Graphics.Rendering.Sifflet.Draw++import Graphics.UI.Sifflet.Frame+import Graphics.UI.Sifflet.GtkUtil+import Graphics.UI.Sifflet.LittleGtk+import Graphics.UI.Sifflet.Types+import Language.Sifflet.Util++-- Experimental:+enableDoubleBuffering :: Bool+enableDoubleBuffering = True++vcanvasNew :: Style -> Double -> Double -> IO VCanvas+vcanvasNew style width height = do+ -- create gtkLayout (the "drawing canvas")+ gtkLayout <- layoutNew Nothing Nothing+ -- Turn double buffering on or off. + -- Normally, double buffering eliminates flicker,+ -- but if the rendering is through the network,+ -- it might be better to disable it.+ -- See docs for Graphics.UI.Gtk.Gdk.DrawWindow+ -- (drawWindow{Begin,End}PaintRegion), and+ -- Graphics.UI.Gtk.Abstract.Widget+ -- (widgetSetDoubleBuffered).+ widgetSetDoubleBuffered gtkLayout enableDoubleBuffering++ -- create the VCanvas+ let vCanvas = VCanvas {vcLayout = gtkLayout, vcStyle = style, + vcGraph = wgraphNew,+ vcFrames = [],+ -- vcSize is the requested size of the+ -- canvas (Gtk.Layout)+ vcSize = Size width height,+ -- but this is the requested size;+ -- how can I get the actual, current size?+ -- Answer: + -- layoutGetSize :: Layout -> IO (Int, Int)+ -- removed: vcLocalEnv = env,+ vcMousePos = (0, 0), -- ???+ vcTool = Nothing,+ vcDragging = Nothing,+ vcActive = Nothing,+ vcSelected = Nothing++ }+ -- Most essential event handlers+ _ <- onSizeRequest gtkLayout+ (return (Requisition (round width) (round height)))+ + return vCanvas++nodeContainerFrame :: VCanvas -> WGraph -> G.Node -> CanvFrame+nodeContainerFrame vcanvas g = vcGetFrame vcanvas g . nodeContainerFrameNode g++-- Ask the VCanvas to find the frame whose frame node element is the+-- given Node; it is an error if not found or if there is more than one.+vcGetFrame :: VCanvas -> WGraph -> Node -> CanvFrame+vcGetFrame vcanvas graph frameNode = + let frames = [f | f <- vcFrames vcanvas, cfFrameNode f == frameNode]+ err phrase = errcats ["vcGetFrame", phrase,+ "frameNode:", show frameNode, + "\nframes:", show frames,+ "\ngraph:\n", show graph]+ in case frames of+ [frame] -> frame+ [] -> err "no frame found"+ (_:_:_) -> err "multiple frames found"++-- | Ask the vcanvas to update the frame and install a new graph.+-- Frames are identified by their frame nodes, so the new frame +-- must have the same frame node as the old.+-- It is an unreported error if there is not exactly one match.+vcUpdateFrameAndGraph :: VCanvas -> CanvFrame -> WGraph -> VCanvas+vcUpdateFrameAndGraph vcanvas newFrame newGraph =+ let frames = vcFrames vcanvas+ frameNode = cfFrameNode newFrame -- should match frameNode of old frame+ frames' = + [if cfFrameNode f == frameNode then newFrame else f | f <- frames]+ in vcanvas {vcFrames = frames', vcGraph = newGraph}++-- | Like vcUpdateFrameAndGraph, but keep the canvas's old graph.+vcUpdateFrame :: VCanvas -> CanvFrame -> VCanvas+vcUpdateFrame vcanvas newFrame =+ vcUpdateFrameAndGraph vcanvas newFrame (vcGraph vcanvas)++-- Delete a frame from the vcanvas's frames ref+-- This does not update the graph -- see vcCloseFrame for that.+vcDeleteFrame :: VCanvas -> CanvFrame -> VCanvas+vcDeleteFrame vcanvas frame =+ let frames = vcFrames vcanvas+ node = cfFrameNode frame+ frames' = [f | f <- frames, cfFrameNode f /= node]+ in vcanvas {vcFrames = frames'}++-- RENDERING+-- perhaps ought to be its own module++-- Perhaps this ought to be called graphRenderFunctoid! ***++graphRenderFunctoidParts :: + Style -> Maybe Node -> Maybe Selection -> WGraph -> CanvFrame -> Render ()+graphRenderFunctoidParts style mact msel graph frame = + case cfFunctoid frame of+ FunctoidFunc _ -> error "graphRenderFunctoidParts: not an edit frame"+ FunctoidParts {} -> + graphRenderForest style mact msel graph + (nodeProperSimpleDescendants graph + (cfFrameNode frame))++graphRenderForest :: + Style -> Maybe Node -> Maybe Selection -> WGraph -> [G.Node] -> Render ()+graphRenderForest style mact msel graph roots = + let renderNode node = graphRenderTree style mact msel graph node False+ in mapM_ renderNode roots++graphRenderTree :: Style -> Maybe Node -> Maybe Selection -> WGraph ->+ G.Node -> Bool -> Render ()+graphRenderTree style mact msel graph rootNode fillBackground =+ let loop :: Maybe Iolet -> G.Node -> Render ()+ loop mInlet currentNode = do+ -- Render the root+ (inlets, outs) <-+ graphRenderNode style mact msel graph currentNode mInlet+ -- Render the subtrees+ loopWithInlets 0 inlets (sortBy adjCompareEdge outs)+ + -- loopWithInlets n inletPositions outs:+ -- n = the current inlet number, starting from 0+ -- inletPositions = the points to connect to on the parent+ -- outs = a list of (child, edge) pairs (adjs)+ -- going to *simple* children (i.e., not frame nodes)+ -- There must be at least as many inlets as there are outs.+ -- If the edge of the first outs equals n, we use the+ -- first inletPosition. Otherwise we skip the inlet+ -- but not out.+ loopWithInlets :: Int -> [Iolet] -> [(G.Node, WEdge)] -> Render ()+ loopWithInlets _n _is [] = return ()+ loopWithInlets n (i:is) (a:as) =+ -- n: number of child, i: inlet, a: adjacency (node, edge)+ let (node, edge) = a in+ if edge == WEdge n+ then do+ loop (Just i) node -- draw node with current inlet+ loopWithInlets (n + 1) is as -- and draw the rest+ else -- skip current inlet+ loopWithInlets (n + 1) is (a:as) + + loopWithInlets n [] (a:as) = + -- This should not happen, and is deliberately rendered+ -- with a strange look!+ -- This repeats some of graphRenderNode, slightly modified+ let ctx = context graph rootNode+ lnode :: LayoutNode ExprNode+ WSimple lnode = lab' ctx+ bb = gnodeNodeBB (nodeGNode lnode)+ defaultInlet = + Iolet (Geometry.Circle+ (Position (bbXCenter bb) (bbYCenter bb)) 0)+ + in loopWithInlets n [defaultInlet] (a:as)+ in do+ graphStartRender style graph rootNode fillBackground+ loop Nothing rootNode++graphStartRender :: Style -> WGraph -> G.Node -> Bool -> Render ()+graphStartRender style graph rootNode fillBackground = do+ -- global actions: can be done once for the whole drawing+ -- instead of once per subtree+ -- Choose: Antialias{Default,None,Gray,Subpixel}+ setAntialias AntialiasDefault++ -- draw the canvas background+ setColor (styleNormalFillColor style)+ let rootCtx = context graph rootNode+ WSimple lroot = lab' rootCtx+ BBox x y w' h' = nodeTreeBB lroot+ when fillBackground $ do { rectangle x y w' h'; fill}++ -- now set up for the rest+ -- setColor (styleNormalTextColor style)+ setLineWidth (lineWidth style)+++-- | Render a node.+-- Returns a list of inlets and a list of "outs":+-- a list of (child, edge) pairs (adjs) +-- going to *simple* children only (not to frames formed+-- by expanding a node).+-- This can then be used if we wish to render the children of+-- the node, as when rendering a tree.++graphRenderNode :: + Style -> Maybe Node -> Maybe Selection -> WGraph ->+ G.Node -> Maybe Iolet -> Render ([Iolet], [(G.Node, WEdge)])+graphRenderNode style mact msel graph node mInlet = + -- status of this node+ let nodeActive = mact == Just node+ mode = if nodeActive+ then DrawActive+ else case msel of+ Nothing -> DrawNormal+ Just sel ->+ if selNode sel /= node then DrawNormal+ else case sel of+ SelectionNode _ -> DrawSelectedNode+ SelectionInlet {selInEdge = WEdge i} ->+ DrawSelectedInlet i+ SelectionOutlet {selOutEdge = WEdge o} ->+ DrawSelectedOutlet o+ + connectInlet :: Iolet -> Double -> Double -> Render ()+ connectInlet inlet tx ty = do+ -- draw the line from the parent inlet to this node's outlet+ let Position px py = ioletCenter inlet+ setColor (styleNormalEdgeColor style)+ moveTo px (py + snd (vtinypad style)) -- bottom of parent+ lineTo tx (ty - fst (vtinypad style)) -- top of this node+ stroke ++ ctx = context graph node+ lnode :: LayoutNode ExprNode+ WSimple lnode = lab' ctx++ -- where to connect to this node+ nodeBB = gnodeNodeBB (nodeGNode lnode)+ xcenter = bbXCenter nodeBB+ inlets = gnodeInlets (nodeGNode lnode)+ -- children (nodes and edges)+ outs = lsuc' ctx :: [(G.Node, WEdge)]+ -- omit links to frames opened from a node+ outs' = [(child, edge) |+ (child, edge) <- outs, nodeIsSimple graph child]++ -- Do we need more inlets to match the outs' ?+ deficit = length outs' - length inlets+ -- The default inlet is lifted to the center+ -- to show something is not right!+ defaultInlet = Iolet (Geometry.Circle + (Position xcenter (bbYCenter nodeBB)) 0)+ inlets' = if deficit > 0+ then inlets ++ replicate deficit defaultInlet+ else inlets++ in do+ + -- Render the node+ draw style mode lnode++ -- Connect to its parent (if any)+ case mInlet of+ Nothing -> return ()+ Just inlet -> connectInlet inlet xcenter (bbTop nodeBB) ++ return (inlets', outs')+++-- END OF RENDERING+-- ---------------------------------------------------------------------++-- | Make nothing be selected++vcClearSelection :: VCanvas -> IO VCanvas+vcClearSelection canvas =+ case vcSelected canvas of+ Nothing -> return canvas+ Just sel ->+ let node = selectionNode sel+ in do+ vcInvalidateSimpleNode canvas node+ return (canvas {vcSelected = Nothing})++-- | The Graph Node of a Selection+selectionNode :: Selection -> G.Node+selectionNode sel =+ case sel of+ SelectionNode n -> n+ SelectionInlet n _ -> n+ SelectionOutlet n _ -> n++-- | What is selected (if anything) at a point++pointSelection :: WGraph -> CanvFrame -> Position -> Maybe Selection+pointSelection graph frame point =+ -- Try to find something to select at the point,+ -- i.e., a node or an iolet on the node+ case cfFunctoid frame of+ FunctoidFunc _ -> error "graphFindFunctionPart: not an edit frame"+ FunctoidParts {fpNodes = grNodes} ->+ let layoutNodes = map (grExtractLayoutNode graph) grNodes+ tuples = zip grNodes layoutNodes++ loop :: [(G.Node, LayoutNode ExprNode)] -> Maybe Selection+ loop [] = Nothing+ loop (t:ts) = -- (n:ns) =+ let (gn, ln) = t -- graph node, tlo node+ gnode = nodeGNode ln+ inlets = gnodeInlets gnode+ outlets = gnodeOutlets gnode+ in+ -- look at the ports first,+ case pointIolet point 0 inlets of+ Just i ->+ Just (SelectionInlet gn (WEdge i))+ Nothing ->+ case pointIolet point 0 outlets of+ Just o ->+ Just (SelectionOutlet gn (WEdge o))+ Nothing ->+ -- try in the node proper+ if pointInGNode point gnode+ then+ Just (SelectionNode gn)+ else+ -- try the remaining tuples+ loop ts ++ in loop tuples++-- | Connect nodes.+-- If parent and child are different,+-- connect the i-th inlet of node parent+-- to the o-th outlet of node child+-- UNLESS doing so would create a cycle+-- parent -> child -> ... -> parent+-- AND UNLESS something is already connected+-- to the ith inlet of the parent node.++connect :: VCanvas -> G.Node -> WEdge -> G.Node -> WEdge -> IO VCanvas+connect canvas parent inlet child outlet = do+ let graph = vcGraph canvas+ if elem parent (reachable child graph)+ then do + showErrorMessage "Sorry, this connection would create a cycle."+ return canvas+ else if grInletIsConnected graph parent inlet+ then do+ showErrorMessage $ "There is already something here; " +++ "disconnect it first."+ return canvas+ else+ -- now we need to store a labeled edges (inlet -> outlet)+ -- and to clear any previous connections of the two.+ let graph' = grConnect graph parent inlet child outlet+ in return $ canvas {vcGraph = graph'}++-- | Disconnect nodes.+-- Disconnect wouldn't need to be in the IO monad,+-- except that it needs the same type signature as connect.+disconnect :: VCanvas -> G.Node -> WEdge -> G.Node -> WEdge + -> IO VCanvas+disconnect canvas parent inlet child outlet = do+ -- Opposite of connect, except we don't have to check for cycles+ -- of any kind. We also reconnect the child to the frame node+ -- as its "parent."+ let graph = vcGraph canvas+ graph' = grDisconnect graph parent inlet child outlet True+ return $ canvas {vcGraph = graph'}++vcFrameAddFunctoidNode :: + VCanvas -> CanvFrame -> Functoid -> Double -> Double -> IO VCanvas+vcFrameAddFunctoidNode canvas frame nodeFunc x y = + let exprNode = ENode (NSymbol (Symbol (functoidName nodeFunc))) EvalUntried+ args = functoidArgNames nodeFunc+ in vcFrameAddNode canvas frame exprNode args x y++vcFrameAddNode :: VCanvas -> CanvFrame -> ExprNode -> [String] + -> Double -> Double -> IO VCanvas+vcFrameAddNode canvas frame exprNode inletLabels x y =+ case cfFunctoid frame of+ FunctoidFunc _function -> + error "vcFrameAddNode: frame is not an edit frame"+ fp@FunctoidParts {fpNodes = ns} -> + do+ let -- Converting to a tree to lay it out seems overkill--+ exprTree = T.Node exprNode []+ style = styleIncreasePadding (vcStyle canvas) 10+ counter = argIoletCounter inletLabels+ layoutTree = treeLayout style counter exprTree++ let graph = vcGraph canvas+ layoutTree' = layoutTreeMoveCenterTo x y layoutTree+ layoutRoot = rootLabel layoutTree'+ newNode = WSimple layoutRoot+ -- insert into graph+ (graph', gNodeId) = grInsertNode graph newNode+ frameNode = cfFrameNode frame+ edge = (frameNode, gNodeId, WEdge (outdeg graph frameNode + 1))+ graph'' = insEdge edge graph'+ -- insert into the fpNodes+ ns' = (gNodeId:ns)+ fp' = fp {fpNodes = ns'}++ {-+ -- DON'T!+ -- Adjust header and footer for new body size++ -- BUT: IS THERE ANYTHING HERE THAT I SHOULD KEEP+ -- WHEN I MAKE FRAMES KEEP A MINIMUM SIZE TO FIT+ -- THE LAYOUT OF THEIR BODIES?++ layoutNodes = map (grExtractLayoutNode graph') ns'+ bodyBB = -- layoutTreeBB layoutTree'+ bbMergeList (map nodeTreeBB layoutNodes)+ header' = alignHeader (cfHeader frame) bodyBB+ footer' = alignFooter (cfFooter frame) bodyBB+ -- grow box to fit new node+ box' = bbMergeList [tbBoxBB header', tbBoxBB footer', bodyBB]+ -- insert into frame+ frame' = frame {cfHeader = header',+ cfFooter = footer',+ cfBox = box', + cfFunctoid = fp'}+ -}+ frame' = frame {cfFunctoid = fp'}++ -- store new frame and graph into canvas+ canvas' = vcUpdateFrameAndGraph canvas frame' graph''++ -- Ready to redraw+ frameChanged canvas graph frame graph'' frame' ++ return canvas'++vcFrameDeleteNode :: VCanvas -> CanvFrame -> G.Node -> IO VCanvas+vcFrameDeleteNode canvas frame node = + let -- Remove the graph node from the frame and canvas,+ -- giving its orphaned children the frame as their new parent+ graph = vcGraph canvas+ frameNode = cfFrameNode frame+ children = nodeAllChildren graph node+ -- Remove node from graph+ graph' = grRemoveNode graph node+ -- Frame adopts orphans+ graph'' = foldl (\ g child -> connectToFrame child frameNode g) + graph' + children+ -- Remove node from funcparts+ fp@FunctoidParts {fpNodes = ns} = cfFunctoid frame+ fp' = fp {fpNodes = List.delete node ns}+ frame' = frame {cfFunctoid = fp'}+ + -- Update references+ canvas' = vcUpdateFrameAndGraph canvas frame' graph''+ in do+ -- Ask to be redrawn+ frameChanged canvas graph frame graph'' frame'+ return canvas'++-- | Remove the (sub)tree rooted at the given node.+-- Removes it from the graph of the canvas+-- and from the FunctoidParts of the frame.+vcFrameDeleteTree :: VCanvas -> CanvFrame -> G.Node -> IO VCanvas+vcFrameDeleteTree canvas frame rootNode = ++ let removeTree :: (WGraph, [G.Node]) -> G.Node -> (WGraph, [G.Node])+ removeTree (g, ns) root =+ let g' = grRemoveNode g root+ ns' = List.delete root ns+ in foldl removeTree (g', ns') (nodeAllChildren g root)+ + graph = vcGraph canvas+ fp@FunctoidParts {fpNodes = fnodes} = cfFunctoid frame+ (graph', fnodes') = removeTree (graph, fnodes) rootNode+ frame' = frame {cfFunctoid = fp {fpNodes = fnodes'}}+ + -- Update references+ canvas' = vcUpdateFrameAndGraph canvas frame' graph'+ in do+ -- Ask to be redrawn+ frameChanged canvas graph frame graph' frame'+ return canvas'+++-- | Add a frame representing a functoid to the canvas.+--+-- Use mvalues = Nothing if you do not want the frame to be evaluated+-- as a function call, otherwise mvalues = Just values.+-- +-- prevEnv is *supposed* to be the previous environment, +-- i.e., that of the+-- "parent" frame or the canvas, not of the new frame,+-- because vcAddFrame itself will extend the environment+-- with the new (vars, values).+-- But this is odd, because openNode calls vcAddFrame +-- apparently with the *new* environment as prevEnv,+-- and yet it works correctly.+--+-- Caution: I think it is necessary for the canvas to have been realized+-- before calling this function!++vcAddFrame :: VCanvas -> Functoid -> Maybe [Value] -> FrameType+ -> Env -> Double -> Double -> Double -> Maybe G.Node + -> IO VCanvas+vcAddFrame canvas functoid mvalues mode prevEnv x y z mparent = do+ let graph = vcGraph canvas+ frameNode = nextNode graph -- implicit: root = frameNode + 1+ style = vcStyle canvas+ (newFrame, tlo) = frameNewWithLayout style (Position x y) z + functoid mvalues + CallFrame -- mode may change below+ frameNode prevEnv mparent+ inAdj = case mparent of+ Nothing -> []+ Just parent -> + -- Adjacency (priority, parent)+ [(WEdge (outdeg graph parent), parent)]+ -- add the new frame node, possibly linked to its parent,+ -- and the tree of the new frame+ graph' = grAddGraph + ((inAdj, frameNode, WFrame frameNode, []) & graph)+ (flayoutToGraph tlo)+ -- connect the frame to the tree-layout roots+ layoutRoots = map (+ frameNode) (flayoutToGraphRoots tlo)+ outEdges = [(frameNode, root, WEdge priority) | + (priority, root) <- zip [0..] layoutRoots]+ graph'' = insEdges outEdges graph'+ -- update the frames and the graph in the canvas+ frames = vcFrames canvas++ canvas' = canvas {vcFrames = (newFrame:frames)+ , vcGraph = graph''}++ -- Make sure canvas is big enough to contain newFrame+ -- This is also done when the window is resized+ -- (../Callbacks.hs: configuredCallback).++ frameBB = cfBox newFrame+ canvas'' = + atLeastSize (Size (bbRight frameBB) (bbBottom frameBB)) canvas'++ -- Request redraw of the region, including tether to parent, if any+ -- error occurs here if the widget is not yet realized, I think+ vcInvalidateFrameWithParent canvas graph'' newFrame+ case mode of+ CallFrame -> return canvas''+ EditFrame -> editFunction canvas'' newFrame ++-- | Return a canvas of at least the specified size+-- and otherwise like the given canvas.+atLeastSize :: Size -> VCanvas -> VCanvas+atLeastSize minSize@(Size minW minH) canvas =+ let Size w h = vcSize canvas+ frames = vcFrames canvas+ frames' = if canvasEditing canvas+ then -- only one frame, expand it to fill desired size+ [atLeastSizeFrame minSize (head frames)]+ else frames+ in canvas {vcSize = Size (max w minW) (max h minH), vcFrames = frames'}++vcInvalidateFrameWithParent :: VCanvas -> WGraph -> CanvFrame -> IO ()+vcInvalidateFrameWithParent vcanvas graph frame =+ -- "Invalidate" the frame itself, and if it has a parent,+ -- the region between it and its parent, so that the frame+ -- and its tether will be redrawn+ let box1 = cfBox frame+ box2 = + case cfParent frame of+ Just parent -> bbMerge (nodeBBox graph parent) box1+ Nothing -> box1+ in vcInvalidateBox vcanvas box2++vcInvalidateSimpleNode :: VCanvas -> G.Node -> IO ()+vcInvalidateSimpleNode vcanvas node = + -- For WSimple nodes --+ -- Similarly, invalidate the node itself + -- (but not yet its parent (if any))+ case wlab (vcGraph vcanvas) node of+ WFrame _ -> error "vcInvalidateSimpleNodeWithParent: node is not simple"+ WSimple layoutNode ->+ vcInvalidateBox vcanvas (gnodeNodeBB (nodeGNode layoutNode))++vcInvalidateBox :: VCanvas -> BBox -> IO ()+vcInvalidateBox vcanvas (BBox x y width height) = + -- take into account the line width of the box as drawn+ -- and the radius of Iolets. We'll do this even+ -- though frames do not have Iolets on their edges!+ -- This is also a little broader than necessary even for+ -- WSimple nodes, since the Iolets are on top and bottom,+ -- not on the side.+ let style = vcStyle vcanvas+ t = lineWidth style + styleIoletRadius style+ rect = bbToRect (BBox (x - t) (y - t) + (width + 2 * t) (height + 2 * t)) + in do+ win <- layoutGetDrawWindow (vcLayout vcanvas)+ drawWindowInvalidateRect win rect False++frameChanged :: + VCanvas -> WGraph -> CanvFrame -> WGraph -> CanvFrame -> IO ()+frameChanged vcanvas g f g' f' = + -- (graph g, frame f) has been replaced by (g', f')+ do+ vcInvalidateFrameWithParent vcanvas g f -- old+ vcInvalidateFrameWithParent vcanvas g' f' -- new++-- MORE RENDERING+-- ---------------------------------------------------------------------++-- | Draw the canvas in its window, on screen+drawCanvas :: VCanvas -> Rectangle -> IO ()+drawCanvas canvas cliprect = do+ drawWin <- layoutGetDrawWindow (vcLayout canvas)+ renderWithDrawable drawWin $ renderCanvas canvas (bbFromRect cliprect) False++-- | Render the canvas in Cairo +-- (use with renderWith to provide an alternate surface, such as+-- an SVG file).++renderCanvas :: VCanvas -> BBox -> Bool -> Render ()+renderCanvas canvas clipbox translateClip =+ -- alternatively match {eventRegion = region}, from which you can get a+ -- list of rectangles++ let graph = vcGraph canvas+ mactive = vcActive canvas+ mselected = vcSelected canvas+ frames = vcFrames canvas+ Size w h = vcSize canvas+ style = vcStyle canvas++ setClip (BBox x y width height) = do+ rectangle x y width height+ clip++ drawBackground = do+ setColor (ColorRGB 0.4 0.4 0.4)+ rectangle 0 0 w h+ fill++ renderFrame frame = + case frameType frame of+ EditFrame -> renderEditFrame frame+ CallFrame -> renderCallFrame frame++ renderEditFrame frame = do+ renderFrameHeader frame+ -- renderFrameFooter frame+ -- the body:+ setAntialias AntialiasDefault+ setColor (styleNormalFillColor style)+ drawBox (Just (styleNormalFillColor style)) Nothing + (frameBodyBox frame)+ -- now draw the nodes, if any:+ graphRenderFunctoidParts style mactive mselected graph frame+ renderFrameBorder frame+ -- end renderEditFrame++ renderCallFrame frame = do+ let frameRoot = cfRoot frame+ -- Just (WSimple _) = lab graph frameRoot -- can't be WFrame!+ -- BBox x y width height = nodeTreeBB layoutNode++ -- draw tether from parent (if any)+ -- drawTether (nodeParent graph (cfFrameNode frame)) frame+ fancyTether (nodeParent graph (cfFrameNode frame)) frame++ -- render the graph -- requires the graph, which is *not*+ -- in the frame! That's why this is not a "frame method".+ graphRenderTree style mactive mselected graph frameRoot True++ -- render the header and footer+ -- MAYBE do this before the tether?+ -- Footer needs to be drawn after body+ -- in case the frame is resized too small+ renderFrameHeader frame+ renderFrameFooter frame + renderFrameBorder frame+ -- end renderCallFrame++ renderFrameHeader frame = drawtb cream black black (cfHeader frame)++ renderFrameFooter frame =+ drawtb cream black + (if cfEvalReady frame + then lightBlue + else styleAuxColor style)+ (cfFooter frame)++ renderFrameBorder frame = drawBox Nothing (Just black) (cfBox frame)+ drawtb bgcolor framecolor textcolor tbox = + drawTextBox (Just (styleFont style)) + (Just bgcolor) + (Just framecolor) + textcolor tbox+ +-- plainTether :: Maybe G.Node -> CanvFrame -> Render ()+-- plainTether Nothing _ = return ()+-- plainTether (Just parent) frame = +-- let pb = nodeBBox graph parent+-- fb = cfBox frame+-- line f1 f2 = do+-- moveTo (f1 pb) (f2 pb) +-- lineTo (f1 fb) (f2 fb)+-- in do+-- -- outline the frame's parent+-- drawBox Nothing (Just (styleTetherColor style)) pb+-- -- draw tether lines+-- setColor (styleTetherColor style)+-- line bbLeft bbTop+-- line bbLeft bbBottom+-- line bbRight bbTop+-- line bbRight bbBottom+-- stroke++ fancyTether :: Maybe G.Node -> CanvFrame -> Render ()+ fancyTether Nothing _ = return ()+ fancyTether (Just parent) frame = + let pb = nodeBBox graph parent+ fb = cfBox frame+ side f1 f2 f3 f4 =+ do+ newPath+ moveTo (f1 pb) (f2 pb)+ lineTo (f1 fb) (f2 fb)+ lineTo (f3 fb) (f4 fb)+ lineTo (f3 pb) (f4 pb)+ closePath+ fill+ in do+ -- outline the frame's parent+ drawBox Nothing (Just (styleTetherColor style)) pb+ -- draw tether lines+ setColor (styleTetherColor style)+ side bbLeft bbTop bbRight bbTop+ side bbRight bbTop bbRight bbBottom+ side bbRight bbBottom bbLeft bbBottom+ side bbLeft bbBottom bbLeft bbTop+ -- end fancyTether++ -- end of let decls in renderCanvas+ + -- main body of renderCanvas+ in do+ when translateClip+ (Cairo.translate (- (bbX clipbox)) (- (bbY clipbox)))+ setClip clipbox+ drawBackground+ -- sorting is a possible bottleneck? + mapM_ renderFrame (sortBy levelOrder frames)++defaultFileSaveClipBox :: VCanvas -> BBox+defaultFileSaveClipBox canvas =+ let bboxes = map cfBox (vcFrames canvas)+ BBox x1 y1 w1 h1 = bbMergeList bboxes -- contains all frames+ pad = exomargin (vcStyle canvas)+ in BBox (x1 - pad) (y1 - pad) (w1 + 2 * pad) (h1 + 2 * pad)++-- | Find the node, if any, at a given position on the canvas.+vcanvasNodeAt :: VCanvas -> Position -> Maybe G.Node+vcanvasNodeAt vcanvas point =+ + -- searchFrames could be done with the Maybe monad, I guess+ let searchFrames :: [CanvFrame] -> Maybe G.Node+ searchFrames [] = Nothing+ searchFrames (f:fs) =+ case frameNodeAt f (vcGraph vcanvas) point of+ Nothing -> searchFrames fs+ Just node -> Just node+ + in searchFrames (vcFrames vcanvas)+ ++vcanvasNodeRect :: VCanvas -> G.Node -> Rectangle+vcanvasNodeRect vcanvas node =+ let Just (WSimple layoutNode) = lab (vcGraph vcanvas) node+ in bbToRect (gnodeNodeBB (nodeGNode layoutNode))++whichFrame :: VCanvas -> Double -> Double -> Maybe CanvFrame+whichFrame vcanvas x y = + -- Find the frame, if any, in which (x, y) occurs.+ -- If there's more than one match, we should return the+ -- one "on top" or at the highest level -- this is not yet implemented.+ let frames = vcFrames vcanvas+ inFrame position = pointInBB position . cfBox+ matches = filter (inFrame (Position x y)) frames+ in case matches of+ [] -> Nothing+ [m1] -> Just m1+ (m1:_:_) -> + -- multiple frames match, so here needs some additional work+ Just m1++-- | editFunction: reverse of defineFunction: replace the call frame by+-- an edit frame; does not change the VPUI (global env.), just the canvas..+editFunction :: VCanvas -> CanvFrame -> IO VCanvas+editFunction canvas frame = + case frameType frame of+ EditFrame -> + return canvas+ + CallFrame ->+ let FunctoidFunc function = cfFunctoid frame+ parts = functionToParts function (vcGraph canvas) + (cfFrameNode frame)+ frame' = frame {cfFunctoid = parts, frameType = EditFrame}+ -- Make the frame fill the canvas.+ frame'' = atLeastSizeFrame (vcSize canvas) frame'+ in return $ vcUpdateFrame canvas frame''++-- | Find a frame's subframes, i.e., those that were expanded+-- to trace the execution of a function call.+-- Cannot be in an edit frame.+vcFrameSubframes :: VCanvas -> CanvFrame -> [CanvFrame]+vcFrameSubframes canvas frame =+ let graph = vcGraph canvas+ subframeNodes = + case frameType frame of+ EditFrame -> []+ CallFrame -> grTreeSubframeNodes graph (cfRoot frame)+ in map (vcGetFrame canvas graph) subframeNodes+++-- | Given a graph with a rooted tree, collect list of "subframes,"+-- i.e., frames that are children of nodes in the tree+grTreeSubframeNodes :: WGraph -> G.Node -> [G.Node]+grTreeSubframeNodes g root =+ nodeFrameChildren g root ++ + concatMap (grTreeSubframeNodes g) (nodeSimpleChildren g root)++vcEvalDialog :: VCanvas -> CanvFrame -> IO VCanvas+vcEvalDialog canvas frame =+ let FunctoidFunc function = cfFunctoid frame -- FunctoidParts shouldn't happen+ varnames = cfVarNames frame+ in if null varnames+ then evalFrame canvas frame [] -- skip dialog, no inputs+ else let argDefault env arg = + case envLookup env arg of+ Nothing -> ""+ Just v -> repr v+ defaults = map (argDefault (cfEnv frame)) varnames++ reader :: Reader [String] [Value]+ reader inputs = parseTypedInputs3 inputs varnames + (functionArgTypes function)+ in do+ dialog <- + createEntryDialog "Input Values" varnames defaults reader (-1)+ result <- runEntryDialog dialog+ case result of+ Nothing -> return canvas+ Just values -> evalFrame canvas frame values++-- | Evaluate the frame, having gotten a list of values from the dialog++evalFrame :: VCanvas -> CanvFrame -> [Value] -> IO VCanvas+evalFrame canvas frame values = do+ -- Close subframes (those that were made by+ -- expanding a node of this frame)+ canvas' <- vcCloseSubframes canvas frame++ -- Re-evaluate expression tree and update display+ let graph = vcGraph canvas'++ -- Pop the current frame's values, if any, before+ -- extending with the new values.+ -- A frame with no values has a dummy extension,+ -- so this is still okay.+ frameNode = cfFrameNode frame+ -- It's a call frame, so it has a root+ root = cfRoot frame+ style = vcStyle canvas'+ headerTB = cfHeader frame++ -- The tlo may *change*, since showing values may require+ -- extra space.++ (frame', tlo') = frameNewWithLayout style + (bbPosition (tbBoxBB headerTB))+ (cfLevel frame)+ (cfFunctoid frame) (Just values) CallFrame+ frameNode + (envPop (cfEnv frame))+ Nothing++ -- Since the frame is a call frame, we should have a tree tlo.++ case tlo' of+ FLayoutTree _t ->+ do+ -- update the tree in the graph+ let graph' = grUpdateFLayout graph [root] tlo'+ canvas'' = vcUpdateFrameAndGraph canvas' frame' graph'+ + -- request redrawing of old and new areas+ frameChanged canvas' graph frame graph' frame'+ + return canvas''++ FLayoutForest _f _b ->+ error "vcEvalDialog: finishDialog: tlo is not a tree"++-- WORK HERE ***+-- This will be a lot like vcEvalDialog, except we are *un*-evaluating.+-- :-(++-- | vcClearFrame - clear a frame in a canvas; not yet implemented+-- What does this mean?++vcClearFrame :: VCanvas -> CanvFrame -> IO VCanvas+vcClearFrame canvas _frame = + showInfoMessage "Sorry" "Stub: vcClear is not yet implemented" >>+ return canvas++-- | Close a frame and any subframes of it++vcCloseFrame :: VCanvas -> CanvFrame -> IO VCanvas+vcCloseFrame canvas frame = do+ -- close any subframes of this frame+ canvas' <- vcCloseSubframes canvas frame++ -- remove it from the frames list+ let canvas'' = vcDeleteFrame canvas' frame++ -- remove it and its edges from the graph+ graph = vcGraph canvas''+ graph' = delNodes (allDescendants graph (cfFrameNode frame)) graph+ canvas''' = canvas'' {vcGraph = graph'}++ -- graphically invalidate the region of the frame+ -- and its tether (i.e., to its parent)+ -- (yes, using the *old* vcanvas, graph, and frame)++ vcInvalidateFrameWithParent canvas (vcGraph canvas) frame+ return canvas'''++-- | Close any subframes of the frame, but not the frame itself+vcCloseSubframes :: VCanvas -> CanvFrame -> IO VCanvas+vcCloseSubframes canvas frame =+ foldM vcCloseFrame canvas (vcFrameSubframes canvas frame)+++cfContext :: CanvFrame -> ToolContext+cfContext frame =+ case frameType frame of+ EditFrame -> TCEditFrame frame+ CallFrame -> TCCallFrame frame++-- | Is our canvas editing a function?+canvasEditing :: VCanvas -> Bool+canvasEditing canvas =+ case vcFrames canvas of+ [oneFrame] -> frameType oneFrame == EditFrame+ _ -> False++-- | Find the frames that are calling the named function+callFrames :: VCanvas -> String -> [CanvFrame]+callFrames canvas funcName =+ let isCaller frame = functoidName (cfFunctoid frame) == funcName+ in filter isCaller (vcFrames canvas)
+ lib/Graphics/UI/Sifflet/EditArgsPanel.hs view
@@ -0,0 +1,332 @@+-- | A "panel" to be shown on the Function Editor, for adjusting the+-- arguments of the function being edited -- adding and deleting arguments,+-- or modifying their "kind" (number of inlets, needed for higher order+-- functions)++module Graphics.UI.Sifflet.EditArgsPanel+ (+ ArgSpecAction+ , EditArgsPanel+ , makeEditArgsPanel+ , editArgsPanelRoot+ , expandToFit+ )++where++import Data.IORef++import Graphics.UI.Gtk (EventBox, hButtonBoxNew, + containerRemove,+ ButtonBoxClass, buttonActivated,+ widgetGetParent,+ widgetQueueResize)++import Language.Sifflet.Expr+import Graphics.UI.Sifflet.Callback+import Graphics.UI.Sifflet.LittleGtk+import Language.Sifflet.Util (SuccFail(..), parseInt)++type ArgSpecAction = [ArgSpec] -> IO ()++type PanelRoot = EventBox++data EditArgsPanel = + EditArgsPanel {editArgsPanelRoot :: PanelRoot,+ editArgsPanelAction :: ArgSpecAction}++type StateRef = IORef State++data State = State Model UI++newtype Model = Model [ArgSpec]+ deriving (Show)++data UI = UI PanelRoot Table Label [ArgRow]++data ArgRow = ArgRow Entry Entry Button+++-- | Create an EditArgsPanel+-- It currently returns a EditArgsPanel object, +-- and you can put the root of it into a container, e.g.,+-- set window [containerChild := editArgsPanelRoot panel]++-- I think it needs to return some more information than this, though,+-- and maybe know about its parent or larger context, so that when+-- applied, it can have a "global" effect.+-- Maybe just in the form of IO () actions, though.+-- +-- It has this structure (for n existing arguments):++-- EventBox ( = editArgsPanelRoot panel)+-- +----------------------------------++-- | Frame |+-- | +------------------------------+ |+-- | | VBox | |+-- | | +--------------------------+ | |+-- | | | Table (n+2 rows)x(3 cols)| | |+-- | | | +----------------------+ | | |+-- | | | | | | | |+-- | | | | (arguments) | | | |+-- | | | +----------------------+ | | |+-- | | | | | |+-- | | | HButtonBox | | |+-- | | | +----------------------+ | | |+-- | | | | (buttons) | | | |+-- | | | +----------------------+ | | |+-- | | | | | |+-- | | | Label | | |+-- | | | +----------------------+ | | |+-- | | | | (status messages) | | | |+-- | | | +----------------------+ | | |+-- | | +--------------------------+ | |+-- | +------------------------------+ |+-- +----------------------------------+++makeEditArgsPanel :: CBMgr -> [ArgSpec] -> ArgSpecAction+ -> IO EditArgsPanel+makeEditArgsPanel cbMgr argSpecs okayAction = do+ root <- eventBoxNew -- needed for everything to be visible!+ frame <- frameNew+ frameSetLabel frame "Edit Arguments"++ let panel = EditArgsPanel {editArgsPanelRoot = root,+ editArgsPanelAction = okayAction}++ vbox <- vBoxNew False 5 -- non-homogeneous sizes, 5 pixels separation++ -- Create a table of n + 2 rows x 3 cols, non-homogeneous sizes+ table <- tableNew (length argSpecs + 2) 3 False + status <- labelNew (Just "")++ stateRef <- newIORef (State (Model argSpecs) (UI root table status []))+ dressTable stateRef++ btnBox <- hButtonBoxNew+ fillButtonBox cbMgr btnBox stateRef panel++ containerAdd root frame+ containerAdd frame vbox+ boxPackStartDefaults vbox table+ boxPackStartDefaults vbox btnBox+ boxPackStartDefaults vbox status++ widgetShowAll root+ return panel++-- | Fill the table with rows for each argument in the model and more++dressTable :: StateRef -> IO ()+dressTable sref = do+ -- read state+ State (Model args) ui@(UI root table status _rows) <- readIORef sref++ -- add "headings"+ argLabel <- labelNew (Just "Name")+ inputsLabel <- labelNew (Just "Inlets")+ tableAttachCell table argLabel 0 0+ tableAttachCell table inputsLabel 0 1++-- add rows for existing and new arguments+ let n = length args+ argRows <- mapM (uncurry (argRowNew sref)) + (zip (args ++ [ArgSpec "" 0]) [0 .. n])+ mapM_ (uncurry (attachRow table)) + (zip argRows [1 .. n + 1])+ setStatusOK ui+ widgetShowAll table++ -- write state+ writeIORef sref (State (Model args) (UI root table status argRows))+++-- | Resize a widget to be at least as big as a(nother) widget.+-- Normally the widget being resized is one that contains the other.++expandToFit :: (WidgetClass v, WidgetClass w) => v -> w -> IO ()+expandToFit container widget = do+ Requisition w1 h1 <- widgetSizeRequest container+ Requisition w2 h2 <- widgetSizeRequest widget+ let (w, h) = (max w1 w2, max h1 h2)+ widgetSetSizeRequest container w h+ widgetQueueResize container++-- | Remove from table and destroy all arg rows+-- (does not alter model)++stripTable :: StateRef -> IO ()+stripTable sref = do+ State model ui@(UI root table status _rows) <- readIORef sref+ let stripWidget widget = + do+ containerRemove table widget+ widgetDestroy widget++ widgets <- containerGetChildren table+ mapM_ stripWidget widgets+ -- Why is this /not/ equivalent to above two statements?+ -- liftM (mapM_ stripWidget) (containerGetChildren table)+ setStatusOK ui++ writeIORef sref (State model (UI root table status []))++attachRow :: Table -> ArgRow -> Int -> IO ()+attachRow table (ArgRow nameEntry nEntry btn) nrow = do+ tableAttachCell table nameEntry nrow 0+ tableAttachCell table nEntry nrow 1+ tableAttachCell table btn nrow 2++-- | Attach a widget to a table in a single cell, specified by its+-- row column (top lef = 0 0) coordinates++tableAttachCell :: (WidgetClass w) => Table -> w -> Int -> Int -> IO ()+tableAttachCell t w top left = + tableAttachDefaults t w left (left + 1) top (top + 1)+++fillButtonBox :: (ButtonBoxClass b) => + CBMgr -> b -> StateRef -> EditArgsPanel -> IO ()+fillButtonBox cbMgr btnBox sref panel = + let addButton (label, action) = do+ b <- buttonNewWithLabel label+ containerAdd btnBox b+ -- on b buttonActivated action+ cbMgr (AfterButtonClicked b action) + addButton' label action = do+ b <- buttonNewWithLabel label+ containerAdd btnBox b+ _ <- on b buttonActivated action+ return ()++ applyAction :: IO ()+ applyAction = applyArgRows sref (editArgsPanelAction panel)++ okayAction = + applyAction >> closePanel panel++ in do+ -- addButton' "OK" (cbMgr (WithUIRef okayAction))+ addButton' "OK" okayAction+ mapM_ addButton [+ -- ("Strip", \ _ -> stripTable sref),+ -- ("Dress", \ _ -> dressTable sref),+ ("Cancel", \ _ -> closePanel panel)]++-- | Close (destroy) the panel.+-- I hope this also removes it from its parent.++closePanel :: EditArgsPanel -> IO ()+closePanel panel = widgetDestroy (editArgsPanelRoot panel)++-- | Create a new ArgRow+argRowNew :: StateRef -> ArgSpec -> Int -> IO ArgRow+argRowNew sref (ArgSpec name inlets) n = do+ e1 <- makeEntry name+ e2 <- makeEntry (show inlets)+ -- Create and set up button+ let (label, action) = + case name of+ "" -> ("Add", addArg sref n)+ _ -> ("Remove", removeArg sref n)+ b <- buttonNewWithLabel label+ _ <- on b buttonActivated action+ return (ArgRow e1 e2 b)++-- | Add a new argument, nth in the model, from the (n+1)th row in the table++-- Still to do: make sure the name is non-blank, and doesn't duplicate+-- an existing argument (or global variable??)+-- and is a valid symbol name (not a number, etc.)?++addArg :: StateRef -> Int -> IO ()+addArg sref n = do+ State (Model argSpecs) ui@(UI root _table _status argRows) <- readIORef sref+ readResult <- readArgRow (argRows !! n)++ case readResult of++ Succ argTool -> + do+ writeIORef sref (State (Model (argSpecs ++ [argTool])) ui)+ stripTable sref+ dressTable sref+ -- Make sure the container (layout) is big enough + -- to show the enlarged panel+ mparent <- widgetGetParent root+ case mparent of+ Nothing -> return () -- shouldn't happen+ Just parent -> expandToFit parent root+ setStatusOK ui++ Fail msg -> setStatus ui $ "Add: " ++ msg++readArgRow :: ArgRow -> IO (SuccFail ArgSpec)+readArgRow (ArgRow e1 e2 _) = do+ name <- entryGetText e1+ case name of+ "" -> return $ Fail "blank name is not allowed"+ _ -> do+ inletsStr <- entryGetText e2+ return $ case parseInt ("Inlets for " ++ name) inletsStr of+ Succ inlets -> Succ (ArgSpec name inlets)+ Fail msg -> Fail msg++-- | Remove an argument, nth in the model, (n+1)th row in the table+removeArg :: StateRef -> Int -> IO ()+removeArg sref n = do+ State (Model argSpecs) ui <- readIORef sref+ writeIORef sref (State (Model (listRemove argSpecs n)) ui)+ stripTable sref+ dressTable sref+ setStatusOK ui++-- | Remove the nth element of a list (0 is the head)+listRemove :: [a] -> Int -> [a]+listRemove [] _ = error "listRemove: empty"+listRemove (_:xs) 0 = xs+listRemove (x:xs) n = x : (listRemove xs (n - 1))++makeEntry :: String -> IO Entry+makeEntry text = do+ entry <- entryNew+ entrySetText entry text+ return entry++applyArgRows :: StateRef -> ArgSpecAction -> IO ()+applyArgRows sref action = do+ State _model ui@(UI _root _table _status argRows) <- readIORef sref+ readResult <- readArgRows argRows+ case readResult of+ Succ newSpecs -> + do+ setStatusOK ui+ writeIORef sref (State (Model newSpecs) ui)+ action newSpecs+ Fail msg ->+ setStatus ui ("Apply: " ++ msg) >> + return ()+++-- Use a monad transformer or "lift" here???++readArgRows :: [ArgRow] -> IO (SuccFail [ArgSpec])+readArgRows [] = return (Succ []) -- shouldn't happen!+readArgRows (_:[]) = return (Succ []) -- last row is for the "add" button+readArgRows (row:rows) = do+ results <- readArgRows rows+ case results of+ Fail msg -> return $ Fail msg+ Succ specs -> + do+ result <- readArgRow row+ case result of+ Fail msg -> return $ Fail msg+ Succ spec -> return $ Succ (spec:specs)+ +setStatusOK :: UI -> IO ()+setStatusOK ui = setStatus ui ""+ +setStatus :: UI -> String -> IO ()+setStatus (UI _ _ status _) msg = + labelSetText status msg
+ lib/Graphics/UI/Sifflet/Frame.hs view
@@ -0,0 +1,307 @@+module Graphics.UI.Sifflet.Frame+ (+ CanvFrame(..), FrameType(..)+ , argIoletCounter+ , atLeastSizeFrame+ , cfEvalReady+ , cfPointInHeader+ , cfPointInFooter+ , cfRoot+ , frameNewWithLayout+ , frameBodyBox+ , frameNodeAt+ , frameOffset+ , levelOrder+ , nodeCompoundFunction+ , pointIolet+ , resizeFrame+ , translateFrame+ , grTranslateFrameNodes+ )++where++import Data.Function+import Data.List++import Data.Graph.Inductive as G++import Data.Sifflet.Functoid+import Data.Sifflet.Geometry+import Data.Sifflet.Tree+import Data.Sifflet.TreeLayout+import Data.Sifflet.WGraph+import Language.Sifflet.Expr+import Language.Sifflet.ExprTree+import Language.Sifflet.Util++-- ---------------------------------------------------------------------+-- CanvFrame operations+-- ---------------------------------------------------------------------+++-- | A CanvFrame represents (indirectly, through cfRoot, and we+-- access to the graph which is provided by the VCanvas)+-- a "subgraph" such as the expression tree+-- of a function which is being edited or called.++data CanvFrame = CanvFrame {+ cfHeader :: TextBox -- ^ top area of the frame+ , cfFooter :: TextBox -- ^ bottom area+ , cfVarNames :: [String] -- ^ variable (parameter) names+ , cfParent :: Maybe G.Node -- ^ the node opened to make this frame+ , cfFrameNode :: G.Node -- ^ this frame as a node in the graph;+ -- also serves as the ID of the frame.+ , cfEnv :: Env -- ^ environment for evaluation+ , cfBox :: BBox -- ^ box of the whole frame (header, tree, and footer)+ , cfLevel :: Double -- ^ 0 = bottom level, 1 = next higher, etc.+ , cfFunctoid :: Functoid -- ^ includes tlo for an edit frame+ , frameType :: FrameType -- ^ edit or call frame+ }+ deriving (Show)+ +++-- | CanvFrame needs to be Eq in order to be Ord,+-- but maybe the Eq and Ord definitions should be more+-- in the same spirit?+instance Eq CanvFrame where (==) = (==) `on` cfFrameNode++data FrameType = EditFrame | CallFrame deriving (Eq, Read, Show)++-- | Use levelOrder for sorting frames before drawing them+levelOrder :: CanvFrame -> CanvFrame -> Ordering+levelOrder f1 f2 = compare (cfLevel f1) (cfLevel f2) ++-- | The root of the tree displayed in the frame+cfRoot :: CanvFrame -> G.Node+cfRoot frame = + case frameType frame of+ EditFrame -> error "cfRoot: an edit frame has no root"+ CallFrame -> succ (cfFrameNode frame)++-- | A frame is "eval ready" -- that is, okay to run the Eval Frame dialog --+-- if it is a call frame with no parent+cfEvalReady :: CanvFrame -> Bool+cfEvalReady frame = + (frameType frame == CallFrame) && (cfParent frame == Nothing)++cfPointInHeader :: CanvFrame -> Double -> Double -> Bool+cfPointInHeader frame x y = + pointInBB (Position x y) (tbBoxBB (cfHeader frame))++cfPointInFooter :: CanvFrame -> Double -> Double -> Bool+cfPointInFooter frame x y = + pointInBB (Position x y) (tbBoxBB (cfFooter frame))++frameBodyBox :: CanvFrame -> BBox+frameBodyBox frame =+ -- the space between the header and footer+ let hbb = tbBoxBB (cfHeader frame)+ fbb = tbBoxBB (cfFooter frame)+ top = bbBottom hbb+ bottom = bbTop fbb+ -- assuming both header and footer are left aligned and same width+ in BBox (bbLeft hbb) top (bbWidth hbb) (bottom - top)++editFrameNodes :: CanvFrame -> [G.Node]+editFrameNodes frame =+ case frameType frame of+ EditFrame -> fpNodes (cfFunctoid frame)+ CallFrame -> error "editFrameNodes: not an EditFrame"++frameNodeAt :: CanvFrame -> WGraph -> Position -> Maybe G.Node+frameNodeAt frame graph point = + case frameType frame of+ CallFrame -> callFrameNodeAt frame graph point+ EditFrame -> editFrameNodeAt frame graph point++editFrameNodeAt :: CanvFrame -> WGraph -> Position -> Maybe G.Node+editFrameNodeAt _frame _graph _point = Nothing -- STUB ***+ -- this could probably make use of the function that finds ***+ -- a selection from a point ***++callFrameNodeAt :: CanvFrame -> WGraph -> Position -> Maybe G.Node+callFrameNodeAt frame graph point = + let search :: [G.Node] -> Maybe G.Node+ search [] = Nothing+ search (r:rs) =+ case lab graph r of+ Just (WFrame _) -> search rs+ Just (WSimple layoutNode) ->+ let LayoutNode rootGNode treeBB = layoutNode+ in+ if pointInBB point treeBB + -- it's in the tree rooted at r+ then if pointInBB point (gnodeNodeBB rootGNode) + -- it's in the root node+ then Just r+ else search (suc graph r) -- maybe in the subtrees+ else search rs -- maybe in the siblings+ Nothing -> + errcats ["editFrameNodeAt: search: no label for node",+ show r]+ -- since this is a call frame, it had better have a root+ in search [cfRoot frame]++atLeastSizeFrame :: Size -> CanvFrame -> CanvFrame+atLeastSizeFrame (Size minW minH) frame =+ let BBox _ _ width height = cfBox frame+ dwidth = if minW > width then minW - width else 0+ dheight = if minH > height then minH - height else 0+ in resizeFrame frame dwidth dheight++resizeFrame :: CanvFrame -> Double -> Double -> CanvFrame+resizeFrame frame dw dh = + let BBox x y bwidth height = frameBodyBox frame+ -- do not shrink body to negative size+ bwidth' = max 0 (bwidth + dw)+ height' = max 0 (height + dh)+ bodyBB' = BBox x y bwidth' height'+ header' = alignHeader (cfHeader frame) bodyBB'+ footer' = alignFooter (cfFooter frame) bodyBB'+ frameBox' = bbMergeList [tbBoxBB header', tbBoxBB footer', bodyBB']+ in frame {cfHeader = header', cfFooter = footer', cfBox = frameBox'}+++translateFrame :: CanvFrame -> Double -> Double -> CanvFrame+translateFrame frame dx dy =+ frame {cfHeader = translate dx dy (cfHeader frame),+ cfFooter = translate dx dy (cfFooter frame),+ cfBox = translate dx dy (cfBox frame)}+++-- | Where to position a new frame that is grown out of an old frame?+-- This is a very rough draft of frameOffset+frameOffset :: Style -> CanvFrame -> Position+frameOffset style oldFrame = + let bb = cfBox oldFrame+ in Position (bbRight bb + styleFramePad style) (bbTop bb - 40)++++nodeCompoundFunction :: WGraph -> CanvFrame -> Node -> Maybe Function+nodeCompoundFunction graph frame node = + case lab graph node of+ Nothing -> error "nodeCompoundFunction: no label for node"+ Just (WFrame _) -> error "nodeCompoundFunction: node has a WFrame label"+ Just (WSimple layoutNode) ->+ case gnodeValue (nodeGNode layoutNode) of+ ENode (NSymbol (Symbol "if")) _mvalue -> Nothing -- not a function+ ENode (NSymbol (Symbol symbolName)) _mvalue ->+ case envLookup (cfEnv frame) symbolName of+ Nothing -> Nothing -- unbound symbol okay, at least sometimes+ Just (VFun func@(Function _ _ _ (Compound _ _))) -> Just func+ Just _ -> Nothing -- not a compound function+ _ -> Nothing -- not a symbol++grTranslateFrameNodes :: WGraph -> CanvFrame -> Double -> Double -> WGraph+grTranslateFrameNodes wgraph frame dx dy =+ case frameType frame of+ CallFrame -> translateTree dx dy wgraph (cfRoot frame)+ EditFrame -> translateNodes dx dy wgraph (editFrameNodes frame)+ +pointIolet :: Position -> Int -> [Iolet] -> Maybe Int+pointIolet point n iolets =+ -- find the number of the iolet, if any, containing point+ case iolets of + [] -> Nothing+ (p:ps) ->+ if pointInIolet point p + then Just n+ else pointIolet point (n + 1) ps+++-- | argIoletCounter returns (no. of inlets, no. of outlets)+-- derived from the argument list of a function still being defined+argIoletCounter :: [String] -> ExprNode -> (Int, Int)+argIoletCounter labels _exprNode = (length labels, 1)++-- | Aligning a CanvFrame's header and footer with the body of the frame.+-- Aligns the header above, and the footer below, the body of the frame,+-- also matching the width if the body widened++alignHeader :: TextBox -> BBox -> TextBox+alignHeader header bodybox =+ let headerBB = tbBoxBB header+ y0 = bbBottom headerBB+ y1 = bbTop bodybox+ x0 = bbLeft headerBB+ x1 = bbLeft bodybox+ in translate (x1 - x0) (y1 - y0) (tbSetWidth header (bbWidth bodybox))++alignFooter :: TextBox -> BBox -> TextBox+alignFooter footer bodybox =+ let footerBB = tbBoxBB footer+ y0 = bbTop footerBB+ y1 = bbBottom bodybox+ x0 = bbLeft footerBB+ x1 = bbLeft bodybox+ in translate (x1 - x0) (y1 - y0) (tbSetWidth footer (bbWidth bodybox))+++-- | Figure out the frame layout for a function. Returns the layout and frame.+-- Currently, the frame is marked as a "call frame"; if you want to edit it,+-- call (editFrame? editFunction?)++frameNewWithLayout :: Style -> Position -> Double+ -> Functoid -> Maybe [Value] -> FrameType -- added arg+ -> Node -> Env -> Maybe G.Node + -> (CanvFrame, FunctoidLayout) -- reversed tuple+frameNewWithLayout style (Position x y) z + functoid mvalues mode frameNode prevEnv mparent = + -- Figure out the positions for a function call with the+ -- given function and (possibly) values as arguments+ let headerText = functoidHeader functoid+ vars = functoidArgNames functoid+ footerText = buildFooterText vars mvalues+ env = case mvalues of+ Nothing ->+ -- dummy extension to be popped off+ extendEnv [] [] prevEnv + Just values ->+ extendEnv vars values prevEnv+ -- body tlo+ layout0 = flayout style functoid env mvalues+ -- header and footer layouts+ headerTB0 = makeTextBox style headerText -- at 0 0+ footerTB0 = makeTextBox style footerText -- at 0 0++ -- make all three the same width+ Size lw lh = flayoutSize layout0+ fwidth = maximum [tbWidth headerTB0, lw, tbWidth footerTB0]+ -- The __widen functions ensure that each part + -- (header, footer, tree tlo) have the desired width.+ headerTB1 = translate x y (widen headerTB0 fwidth)+ (dx, dy) = (x - hpad style, tbBottom headerTB1 - vpad style)+ layout1 = translate dx dy (flayoutWiden layout0 fwidth)+ footerTB1 = translate x (flayoutBottom layout1) + (widen footerTB0 fwidth)+ frameBox = BBox x y fwidth + (tbHeight headerTB0 + lh + tbHeight footerTB0)+ frame = CanvFrame {cfHeader = headerTB1,+ cfFooter = footerTB1,+ cfVarNames = vars,+ cfParent = mparent,+ cfFrameNode = frameNode,+ cfEnv = env, + cfBox = frameBox,+ cfLevel = z,+ cfFunctoid = functoid,+ frameType = mode}+ in (frame, layout1)++++buildFooterText :: [String] -> Maybe [Value] -> String+buildFooterText vars mvalues = + let items =+ case mvalues of+ Nothing -> vars+ Just [] -> vars+ Just values ->+ -- in case there are fewer values than vars,+ -- pad out with "?"s+ [var ++ " = " ++ rvalue |+ (var, rvalue) <- zip vars (map repr values ++ repeat "?")]+ in concat (intersperse ", " items)
+ lib/Graphics/UI/Sifflet/GtkForeign.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE ForeignFunctionInterface, CPP #-}++-- | Provides a function to set the cursor to a specified shape.+-- Generalized from an example in email+-- Re: [Gtk2hs-users] Changing the mouse cursor shape+-- From: Chris Mears <chris@cm...> - 2007-05-22 07:48+-- found on+-- https://sourceforge.net/mailarchive/forum.php?thread_name=87ps50ie9o.fsf%40loki.cmears.id.au&forum_name=gtk2hs-users+-- and modified by removing the definition of data Cursor+-- since that is now part of gtk2hs/gtk+-- although the enum values are not :-(++-- The CursorType type itself is now exported from+-- Graphics.UI.Gtk.Gdk.Cursor, as also cursorNew+-- and cursorNewFromPixmap.++module Graphics.UI.Sifflet.GtkForeign (setCursor)+where++import System.Glib+import System.Glib.FFI+import Foreign.ForeignPtr ()++import Graphics.UI.Gtk++foreign import ccall "gdk_window_set_cursor" gdkWindowSetCursor :: + Ptr DrawWindow -> Ptr Cursor -> IO ()++foreign import ccall "gdk_cursor_new" gdkCursorNew :: Int -> IO (Ptr Cursor)++-- | Set the X Window cursor for a window to a specified type+setCursor :: Window -> CursorType -> IO ()+setCursor window cursorType = do+ c <- gdkCursorNew (cursorTypeNumber cursorType)+ d <- widgetGetDrawWindow window+ let GObject fp = toGObject d+ withForeignPtr (castForeignPtr fp) $ \ptr -> gdkWindowSetCursor ptr c++-- These numbers are from /usr/include/gtk-2.0/gdk/gdkcursor.h++cursorTypeNumber :: CursorType -> Int+cursorTypeNumber cursorType =+ case cursorType of+ XCursor -> 0+ Arrow -> 2+ BasedArrowDown -> 4+ BasedArrowUp -> 6+ Boat -> 8+ Bogosity -> 10+ BottomLeftCorner -> 12+ BottomRightCorner -> 14+ BottomSide -> 16+ BottomTee -> 18+ BoxSpiral -> 20+ CenterPtr -> 22+ Circle -> 24+ Clock -> 26+ CoffeeMug -> 28+ Cross -> 30+ CrossReverse -> 32+ Crosshair -> 34+ DiamondCross -> 36+ Dot -> 38+ Dotbox -> 40+ DoubleArrow -> 42+ DraftLarge -> 44+ DraftSmall -> 46+ DrapedBox -> 48+ Exchange -> 50+ Fleur -> 52+ Gobbler -> 54+ Gumby -> 56+ Hand1 -> 58+ Hand2 -> 60+ Heart -> 62+ Icon -> 64+ IronCross -> 66+ LeftPtr -> 68+ LeftSide -> 70+ LeftTee -> 72+ Leftbutton -> 74+ LlAngle -> 76+ LrAngle -> 78+ Man -> 80+ Middlebutton -> 82+ Mouse -> 84+ Pencil -> 86+ Pirate -> 88+ Plus -> 90+ QuestionArrow -> 92+ RightPtr -> 94+ RightSide -> 96+ RightTee -> 98+ Rightbutton -> 100+ RtlLogo -> 102+ Sailboat -> 104+ SbDownArrow -> 106+ SbHDoubleArrow -> 108+ SbLeftArrow -> 110+ SbRightArrow -> 112+ SbUpArrow -> 114+ SbVDoubleArrow -> 116+ Shuttle -> 118+ Sizing -> 120+ Spider -> 122+ Spraycan -> 124+ Star -> 126+ Target -> 128+ Tcross -> 130+ TopLeftArrow -> 132+ TopLeftCorner -> 134+ TopRightCorner -> 136+ TopSide -> 138+ TopTee -> 140+ Trek -> 142+ UlAngle -> 144+ Umbrella -> 146+ UrAngle -> 148+ Watch -> 150+ Xterm -> 152+ LastCursor -> 153+ BlankCursor -> (-2)+ CursorIsPixmap -> (-1)
+ lib/Graphics/UI/Sifflet/GtkUtil.hs view
@@ -0,0 +1,225 @@+{-# LANGUAGE CPP #-}++module Graphics.UI.Sifflet.GtkUtil + (suppressScimBridge+ , showChoicesDialog, defaultDialogPosition+ , runDialogM, runDialogS+ -- , runDialogHelper+ , showInputErrorMessage, showErrorMessage+ , showInfoMessage+ , showMessage+ , EntryDialog, Reader+ , createEntryDialog, runEntryDialog+ , addEntryWithLabel+ )++where++import Control.Monad++#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) +import System.Posix.Env+#endif++import Graphics.UI.Sifflet.LittleGtk+import Language.Sifflet.Util++-- SCIM Bridge causes problems, so shush it++suppressScimBridge :: IO ()+suppressScimBridge = +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) + return ()+#else+ putEnv "GTK_IM_MODULE=gtk-im-context-simple"+#endif++-- ============================================================+-- CUSTOMIZABLE DIALOGS++-- | Show a message and a set of choices;+-- run the action corresponding to the selected choice.+-- The last argument is an action corresponding to the "Cancel" option+-- (a Cancel button is automatically inserted) and is also used for+-- strange actions like closing the dialog window.+-- A good value for this might be return ().+showChoicesDialog :: String -> String -> [String] -> [IO a] -> IO a -> IO a+showChoicesDialog title message options actions cancelAction = do+ -- Create basic dialog+ dialog <- dialogNew+ windowSetTitle dialog title+ widgetSetName dialog ("Sifflet-" ++ title)++ -- Add message+ vbox <- dialogGetUpper dialog+ label <- labelNew (Just message)+ boxPackStartDefaults vbox label+ widgetShowAll vbox++ -- Add buttons+ -- Work around bug in gtk2hs v. 0.10.0 and 0.10.1,+ -- which is fixed in darcs gtk2hs.+ -- fromResponse (ResponseUser i) requires i > 0.+ -- so zip [1..] instead of zip [0..]+ let allActions = actions ++ [cancelAction]+ allOptions = options ++ ["Cancel"]+ indexOptions = zip [1..] allOptions+ addButton (i, option) = + dialogAddButton dialog option (ResponseUser i)+ forM_ indexOptions addButton+ dialogGetActionArea dialog >>= widgetShowAll++ -- Run dialog+ response <- dialogRun dialog+ widgetDestroy dialog -- here? or after handling response?+ case response of+ ResponseUser i -> + let j = i - 1 -- work around bug described above+ in if j >= 0 && j < length allActions+ then allActions !! j+ else errcats ["showChoicesDialog: response index",+ show j, "is out of range for actions"]+ _ -> cancelAction+ +createDialog :: String -> (VBox -> IO a) -> IO (Dialog, a)+createDialog title addContent = do+ -- Create basic dialog+ dialog <- dialogNew+ windowSetTitle dialog title+ widgetSetName dialog ("Sifflet-" ++ title)++ -- Add custom content+ vbox <- dialogGetUpper dialog+ content <- addContent vbox++ -- Add standard buttons+ _ <- dialogAddButton dialog "OK" ResponseOk+ _ <- dialogAddButton dialog "Cancel" ResponseCancel+ dialogSetDefaultResponse dialog ResponseOk -- has no effect?++ return (dialog, content)++-- | Where to put a dialog window.+-- Possible values are+-- WinPosNone WinPosCenter WinPosMouse WinPosCenterAlways +-- WinPosCenterOnParent++defaultDialogPosition :: WindowPosition+defaultDialogPosition = WinPosMouse++-- | Customizable framework for running a dialog++runDialogS :: Dialog -> a -> (a -> IO (SuccFail b)) -> IO (Maybe b)+runDialogS dialog inputs processInputs = + runDialogHelper dialog inputs processInputs True++runDialogM :: Dialog -> a -> (a -> IO (Maybe b)) -> IO (Maybe b)+runDialogM dialog inputs processInputs =+ let process' inputs' = do+ result <- processInputs inputs'+ case result of+ Nothing -> return $ Fail "_Nothing_"+ Just value -> return $ Succ value+ in runDialogHelper dialog inputs process' False++runDialogHelper :: Dialog -> a -> (a -> IO (SuccFail b)) -> Bool -> IO (Maybe b)+runDialogHelper dialog inputs processInputs retryOnError = do+ -- Position and show the dialog+ windowSetPosition dialog defaultDialogPosition+ widgetShowAll dialog+ windowPresent dialog++ let run = do+ respId <- dialogRun dialog+ case respId of+ ResponseOk ->+ do+ result <- processInputs inputs+ case result of+ Fail msg ->+ if retryOnError+ then do+ showErrorMessage msg+ run -- try again+ else finish Nothing+ Succ value -> finish (Just value)+ _ -> finish Nothing++ finish result = do+ widgetDestroy dialog+ return result++ run++showInputErrorMessage :: String -> IO ()+showInputErrorMessage message =+ showErrorMessage ("Input Error:\n" ++ message)++showErrorMessage :: String -> IO ()+showErrorMessage = showMessage (Just "Error") MessageError ButtonsClose++showInfoMessage :: String -> String -> IO ()+showInfoMessage title = showMessage (Just title) MessageInfo ButtonsClose++showMessage :: Maybe String -> MessageType -> ButtonsType -> String -> IO ()+showMessage mtitle messagetype buttonstype message = do+ {+ msgDialog <- + messageDialogNew+ Nothing -- ? or (Just somewindow) -- what does this do?+ [] -- flags+ messagetype+ buttonstype+ message+ ; case mtitle of+ Nothing -> widgetSetName msgDialog "Sifflet-dialog"+ Just title -> windowSetTitle msgDialog title >>+ widgetSetName msgDialog ("Sifflet-" ++ title)+ ; windowSetPosition msgDialog defaultDialogPosition+ ; windowPresent msgDialog+ ; _ <- dialogRun msgDialog+ ; widgetDestroy msgDialog+ }++-- ============================================================+-- INPUT DIALOGS++type Reader a b = (a -> SuccFail b)++data EntryDialog a = EntryDialog Dialog [Entry] (Reader [String] a)++createEntryDialog :: + String -> [String] -> [String] -> (Reader [String] a) -> Int -> + IO (EntryDialog a)+createEntryDialog title labels defaults reader width = do+ -- Interpret width = -1 as don't care++ (dialog, entries) <- + createDialog title (addEntries labels defaults)+ windowSetDefaultSize dialog width (-1)+ return $ EntryDialog dialog entries reader++runEntryDialog :: (Show a) => EntryDialog a -> IO (Maybe a)+runEntryDialog (EntryDialog dialog entries reader) = + let -- processInputs :: [Entry] -> IO (SuccFail a)+ -- weird error like in runComboBoxDialog ^+ processInputs entries' = do+ inputs <- mapM entryGetText entries'+ return (reader inputs)++ in runDialogS dialog entries processInputs++addEntries :: [String] -> [String] -> VBox -> IO [Entry]+addEntries labels defaults vbox = do+ entries <- mapM (const entryNew) labels+ mapM_ (addEntryWithLabel vbox) (zip3 labels entries defaults)+ return entries++-- | Add a labeled text entry to the vbox.++addEntryWithLabel :: VBox -> (String, Entry, String) -> IO ()+addEntryWithLabel vbox (name, entry, defaultValue) = do+ label <- labelNew (Just name)+ entrySetText entry defaultValue+ boxPackStartDefaults vbox label+ boxPackStartDefaults vbox entry
+ lib/Graphics/UI/Sifflet/LittleGtk.hs view
@@ -0,0 +1,186 @@+-- | The purpose of this module is simply to re-export the+-- Gtk functions and types that I use, and avoid those+-- that I don't, particularly those that conflict with+-- names in Sifflet, like Layout.+-- Just hiding these is not enough, because Graphics.UI.Gtk+-- keeps changing what it exports.+-- For example, in 0.10.5 it no longer exports Function, fill,+-- function.++module Graphics.UI.Sifflet.LittleGtk+ (+ -- These are just directly re-exported from Gtk:++ -- Attributes+ AttrOp(..) -- for (:=)+ , get+ , set++ , adjustmentNew++ , boxPackEnd+ , boxPackStart+ , boxPackStartDefaults++ , Button+ , buttonNewWithLabel+ , buttonPressEvent++ , ButtonsType(..)++ , ContainerClass+ , castToContainer+ , containerAdd+ , containerChild+ , containerForeach+ , containerGetChildren++ , CursorType(..)+ , customStoreSetColumn++ -- Dialog+ , Dialog+ , dialogNew+ , dialogAddButton+ , dialogGetActionArea+ , dialogGetUpper + , dialogRun+ , dialogSetDefaultResponse+ , toDialog++ , DrawWindow+ , drawWindowInvalidateRect++ , entryCompletionInsertPrefix+ , entryCompletionModel+ , entryCompletionNew+ , entryCompletionSetTextColumn++ , Entry+ , entryGetText+ , entryGetCompletion+ , entryNew+ , entrySetCompletion+ , entrySetText++ , EventMask(..)++ , eventBoxNew++ , Expander+ , expanderNew+ , expanderSetExpanded++ , exposeEvent++ , fileChooserDialogNew+ , fileChooserGetFilename+ , fileChooserSetCurrentFolder+ + , FileChooserAction(..)++ , frameNew+ , frameSetLabel++ , grabAdd+ , grabRemove++ , HBox+ , hBoxNew++ , keyPressEvent++ , Label+ , labelNew+ , labelSetText++ , Layout+ , layoutGetDrawWindow+ , layoutNew+ , layoutPut+ , layoutSetSize++ , listStoreNew++ , makeColumnIdString++ , menuPopup++ , MessageType(..)+ , messageDialogNew++ , on+ , onDestroy+ , onSizeRequest++ , Packing(..)++ , PolicyType(PolicyAutomatic)++ , Rectangle(..)++ , renderWithDrawable++ , Requisition(..)++ , ResponseId(..)++ , ScrolledWindow+ , scrolledWindowNew+ , scrolledWindowSetPolicy++ , Statusbar+ , statusbarGetContextId+ , statusbarNew+ , statusbarPop+ , statusbarPush++ , Table+ , tableNew+ , tableAttachDefaults++ , VBox+ , vBoxNew++ , WidgetClass++ , widgetAddEvents+ , widgetClassPath+ , widgetDestroy+ , widgetGrabFocus+ , widgetSetCanFocus+ , widgetSetDoubleBuffered+ , widgetSetName+ , widgetSetSizeRequest+ , widgetShow+ , widgetShowAll+ , widgetSizeRequest+ , widgetVisible++ , Window+ , windowDeletable+ , windowMove+ , windowNew+ , windowPresent+ , windowSetDefaultSize+ , windowSetPosition+ , windowSetTitle+ , windowTitle++ , WindowPosition(..)+ -- General GTK stuff+ , initGUI+ , mainGUI+ , mainQuit++ -- These are renamed:+ , GtkFrame+ , GtkLayout+ )++where++import Graphics.UI.Gtk++type GtkFrame = Frame+type GtkLayout = Layout
+ lib/Graphics/UI/Sifflet/RPanel.hs view
@@ -0,0 +1,154 @@+-- | "Rowed Panel." +-- Expandable framed panel with a two-dimensional layout+-- (rows of widgets, but not with aligned columns like in a table).++module Graphics.UI.Sifflet.RPanel+ (+ RPanel, newRPanel, rpanelId, rpanelRoot, rpanelContent+ , rpanelAddWidget, rpanelAddWidgets, rpanelNewRow+ , rpanelAddRows+ )++where++import Control.Monad++import Graphics.UI.Sifflet.LittleGtk+import Language.Sifflet.Util++debugTracing :: Bool+debugTracing = False++data RPanel + = RPanel {+ -- Public+ rpId :: String -- ^ text for the expander button+ , rpRoot :: GtkFrame -- ^ use the root to add rpanel to a container+ , rpContent :: [[String]] -- ^ ids of widgets added, in rows++ -- Widgets that make up the RPanel+ , rpFrame :: GtkFrame -- ^ frame, same as root+ , rpExpander :: Expander -- ^ expander+ , rpVBox :: VBox -- ^ vbox to contain the rows+ , rpCurrentRow :: HBox -- ^ next element goes here if it fits++ -- Geometry book-keeping+ , rpCurrentRowFreeWidth :: Int -- ^ free width in current row+ , rpMaxWidth :: Int -- ^ maximum row width+ , rpHPad :: Int -- ^ horizontal padding+ }++rpanelId :: RPanel -> String+rpanelId = rpId++rpanelRoot :: RPanel -> GtkFrame+rpanelRoot = rpRoot++rpanelContent :: RPanel -> [[String]]+rpanelContent = rpContent++newRPanel :: String -> Int -> Int -> Int -> IO RPanel+newRPanel cid hpad vpad maxWidth = do+ {+ frame <- frameNew -- adds a border (not labeled, since the expander is)+ + ; expander <- expanderNew cid+ ; expanderSetExpanded expander True+ ; set frame [containerChild := expander]++ ; vbox <- vBoxNew False vpad -- non-homogeneous heights+ ; widgetSetSizeRequest vbox maxWidth (-1) -- height = don't care+ ; set expander [containerChild := vbox]++ ; hbox <- hBoxNew False hpad -- non-homogeoneous widths+ ; boxPackStart vbox hbox PackNatural 0++ ; return $ RPanel {rpId = cid+ , rpRoot = frame+ , rpFrame = frame+ , rpExpander = expander+ , rpVBox = vbox+ , rpCurrentRow = hbox+ , rpContent = [[]]+ , rpCurrentRowFreeWidth = maxWidth - hpad+ , rpMaxWidth = maxWidth - hpad+ , rpHPad = hpad+ }+ }++-- | Given a list of (name, widget) pairs, add each of the widgets+-- and its name to the rpanel+rpanelAddWidgets :: (WidgetClass widget) =>+ RPanel -> [(String, widget)] -> IO RPanel+rpanelAddWidgets rp pairs = + let addPair rp' (widgetId, widget) = rpanelAddWidget rp' widgetId widget+ in foldM addPair rp pairs++-- | Add a single named widget to the RPanel+rpanelAddWidget :: (WidgetClass widget) =>+ RPanel -> String -> widget -> IO RPanel+rpanelAddWidget rp widgetId widget = do+ {+ Requisition widgetWidth _ <- widgetSizeRequest widget+ ; let freeWidth = rpCurrentRowFreeWidth rp+ freeWidth' = freeWidth - widgetWidth - rpHPad rp+ ; if freeWidth' >= 0 || freeWidth == rpMaxWidth rp+ -- Either there is room enough, OR we're at the start of a row+ -- so starting another won't help -- in fact it would lead to+ -- infinite recursion+ then do+ {+ let content' = insertLastLast (rpContent rp) widgetId+ packMode = -- PackNatural -- to left justify+ PackGrow -- to fill+ -- PackRepel -- to center++ ; boxPackStart (rpCurrentRow rp) widget packMode 0+ -- ; widgetShow widget -- do this here???+ ; when debugTracing $+ putStr (unlines ["Adding " ++ widgetId ++ + " width " ++ show widgetWidth+ , "Free width = " ++ show freeWidth +++ " -> " ++ show freeWidth'+ , "Content -> " ++ show content'])++ ; return $ rp {rpContent = content'+ , rpCurrentRowFreeWidth = freeWidth'}+ }+ else + -- We're out of room, but not at the start of the current row,+ -- so start a new row+ do+ {+ rp' <- rpanelNewRow rp+ ; rpanelAddWidget rp' widgetId widget+ }+ }++-- | Force the RPanel to begin a new row++rpanelNewRow :: RPanel -> IO RPanel+rpanelNewRow rp = do+ {+ hbox <- hBoxNew False (rpHPad rp)+ ; boxPackStart (rpVBox rp) hbox PackNatural 0+ ; return $ rp {rpCurrentRow = hbox+ , rpContent = insertLast (rpContent rp) []+ , rpCurrentRowFreeWidth = rpMaxWidth rp}+ }++-- | Given a list of lists, each sublist representing a row of widgets,+-- add the widgets to the RPanel, preserving the row structure+-- as much as possible.+-- (Row structure will be broken if any intended row is too wide.)+rpanelAddRows :: (WidgetClass widget) =>+ RPanel -> [[(String, widget)]] -> IO RPanel+rpanelAddRows rp rows = foldM rpanelAddRow rp rows++-- | Add a row of widgets to an RPanel.+-- This does not start a new row before the first widget,+-- but after the last, so at the end, the current row will be empty.+rpanelAddRow :: (WidgetClass widget) =>+ RPanel -> [(String, widget)] -> IO RPanel+rpanelAddRow rp row = + rpanelAddWidgets rp row >>= rpanelNewRow
+ lib/Graphics/UI/Sifflet/Tool.hs view
@@ -0,0 +1,588 @@+module Graphics.UI.Sifflet.Tool+ (+ ToolId(..)+ , checkMods+ , functionArgToolSpecs+ , functionTool+ , functionToolsFromLists+ , makeConnectTool+ , makeCopyTool+ , makeDeleteTool+ , makeDisconnectTool+ , makeIfTool+ , makeMoveTool+ , showFunctionEntry+ , showLiteralEntry+ , vpuiSetTool+ , vpuiWindowSetTool++ , vwAddFrame+ , vpuiAddFrame++ -- Statusbar+ , wsPopStatusbar, wsPushStatusbar++ -- frame context menu commands (do these belong elsewhere?)+ , dumpFrame+ , dumpGraph+ , dumpWorkWin+ , clearFrame+ , closeFrame+ )++where++import Control.Monad+import Control.Monad.Trans (liftIO)+import Data.IORef+import Data.List++import Data.Graph.Inductive as G++import Graphics.UI.Gtk (ColumnId)+import Graphics.UI.Gtk.Gdk.EventM+import System.Glib.UTFString (glibToString)++import Data.Sifflet.Functoid+import Data.Sifflet.Geometry+import Data.Sifflet.Tree (putTree, repr)+import Data.Sifflet.TreeGraph (graphToOrderedTreeFrom)+import Data.Sifflet.WGraph++import Language.Sifflet.Expr+import Language.Sifflet.ExprTree+import Language.Sifflet.Parser++import Graphics.UI.Sifflet.Callback+import Graphics.UI.Sifflet.Canvas+import Graphics.UI.Sifflet.Frame+import Graphics.UI.Sifflet.LittleGtk +import Graphics.UI.Sifflet.Types++import Language.Sifflet.Util++data ToolId + = ToolConnect+ | ToolDisconnect+ | ToolIf+ | ToolMove+ | ToolDelete+ | ToolFunction String -- ^ function name+ | ToolLiteral Expr+ | ToolArg String Int -- ^ argument name, no. of inputs+ deriving (Eq, Show)+++functionArgToolSpecs :: Function -> [ArgSpec]+functionArgToolSpecs (Function _mname argTypes _rtype impl) =+ let atspec :: (String, Type) -> ArgSpec+ atspec (name, t) = ArgSpec name (typeInlets t)+ typeInlets :: Type -> Int+ typeInlets (TypeCons "Function" [_t1, t2]) = 1 + typeInlets t2+ typeInlets _ = 0+ argNames =+ case impl of+ Primitive _ -> ["arg" ++ show i | i <- [1 .. length argTypes]]+ Compound anames _body -> anames+ in map atspec (zip argNames argTypes)+ +-- Tools++vpuiSetTool :: ToolId -> WinId -> VPUI -> IO VPUI+vpuiSetTool toolId winId =+ vpuiUpdateWindowIO winId (vpuiWindowSetTool (toolIdToTool toolId))++vpuiWindowSetTool :: Tool -> VPUIWindow -> IO VPUIWindow+vpuiWindowSetTool tool vw =+ case vw of+ VPUIWorkWin ws _ ->+ do+ {+ ; wsPopStatusbar ws+ ; wsPushStatusbar ws ("Tool: " ++ toolName tool)+ ; let canvas' = (wsCanvas ws) {vcTool = Just tool}+ ; canvas'' <- toolActivated tool canvas'+ ; return $ vpuiWindowSetCanvas vw canvas''+ }+ _ -> return vw++toolIdToTool :: ToolId -> Tool+toolIdToTool toolId =+ case toolId of+ ToolConnect -> makeConnectTool+ ToolDisconnect -> makeDisconnectTool+ ToolIf -> makeIfTool+ ToolMove -> makeMoveTool+ ToolDelete -> makeDeleteTool+ ToolFunction funcname -> functionTool funcname+ ToolLiteral e -> makeBoundLiteralTool e+ ToolArg argname n -> makeBoundArgTool argname n+++defaultContextDescription :: String+defaultContextDescription = "default context"++wsPushStatusbar :: Workspace -> String -> IO ()+wsPushStatusbar ws msg = do + {+ let sbar = wsStatusbar ws+ ; contextId <- statusbarGetContextId sbar defaultContextDescription+ ; _ <- statusbarPush sbar contextId msg+ ; return ()+ }++wsPopStatusbar :: Workspace -> IO ()+wsPopStatusbar ws = do+ {+ let sbar = wsStatusbar ws+ ; contextId <- statusbarGetContextId sbar defaultContextDescription+ ; statusbarPop sbar contextId+ }++makeMoveTool :: Tool+makeMoveTool = + let move canv toolContext _mods x y = + case toolContext of+ TCEditFrame frame ->+ let graph = vcGraph canv+ in case pointSelection graph frame (Position x y) of+ sel@(Just (SelectionNode node)) ->+ let dragging = + Dragging {draggingNode = node,+ draggingPosition = Position x y}+ in do+ {+ vcInvalidateFrameWithParent canv graph frame+ ; return $ canv {vcSelected = sel,+ vcDragging = Just dragging}+ }+ _ -> -- no node selected, do nothing+ return canv+ _ ->+ return canv -- not an edit frame, do nothing+ in Tool "MOVE" return (toToolOpVW move)++makeDeleteTool :: Tool+makeDeleteTool = + let del :: CanvasToolOp+ del canv toolContext mods x y =+ case toolContext of+ TCEditFrame frame -> + let graph = vcGraph canv+ in case pointSelection graph frame (Position x y) of+ Just (SelectionNode node) ->+ if checkMods [Shift] mods+ then vcFrameDeleteTree canv frame node+ else vcFrameDeleteNode canv frame node+ _ ->+ return canv -- no node selected, do nothing++ _ -> + return canv -- not an edit frame, do nothing+ + in Tool "DELETE" vcClearSelection (toToolOpVW del)++-- | Check that all required modifiers are in found+checkMods :: [Modifier] -> [Modifier] -> Bool+checkMods required found =+ all (\ r -> elem r found) required++makeConnectTool :: Tool+makeConnectTool = + Tool "CONNECT" vcClearSelection (toToolOpVW (conn connect))+ +makeDisconnectTool :: Tool+makeDisconnectTool = + Tool "DISCONNECT" vcClearSelection (toToolOpVW (conn disconnect))++conn :: (VCanvas -> G.Node -> WEdge -> G.Node -> WEdge -> IO VCanvas)+ -> CanvasToolOp+conn action canvas toolContext _mods x y =+ case toolContext of+ TCEditFrame frame ->+ let oldSel = vcSelected canvas+ graph = vcGraph canvas+ requestRedraw =+ vcInvalidateFrameWithParent canvas graph frame+ in case pointSelection graph frame (Position x y) of+ + -- Overall algorithm: If we're on a port and there's+ -- an opposite port selected, apply the action them+ -- and clear the selection. Otherwise, if we're on+ -- a port, select it. Otherwise do nothing.++ Just sel@(SelectionInlet parent inlet) ->+ -- Case 1: we're on an inlet port, + -- opposite port = outlet+ do + {+ requestRedraw+ ; case oldSel of+ Just (SelectionOutlet child outlet) ->+ do+ {+ canvas' <- action canvas parent + inlet child outlet+ ; return $ canvas' {vcSelected = Nothing}+ }+ _ -> return $ canvas {vcSelected = Just sel}+ }+ Just sel@(SelectionOutlet child outlet) ->+ -- Case 2: we're on an outlet port, + -- opposite port = inlet+ do+ {+ requestRedraw+ ; case oldSel of+ Just (SelectionInlet parent inlet) ->+ do+ {+ canvas' <- action canvas parent + inlet child outlet+ ; return $ canvas' {vcSelected = Nothing}+ }+ _ -> return $ canvas {vcSelected = Just sel}+ }++ _ -> + -- Case 3: we're not on an iolet, do nothing+ return canvas+ _ -> + -- not in an edit frame, do nothing+ return canvas++makeBoundLiteralTool :: Expr -> Tool+makeBoundLiteralTool e =+ let enode node = ENode node EvalUntried+ addLitNode node vw toolContext _mods x y =+ case toolContext of+ TCEditFrame frame ->+ vcFrameAddNode vw frame (enode node) [] x y+ _ ->+ return vw -- Nothing+ mktool node =+ Tool ("Literal: " ++ repr e) + return + (toToolOpVW (addLitNode node))+ in case e of+ EBool b -> mktool (NBool b)+ EChar c -> mktool (NChar c)+ ENumber n -> mktool (NNumber n)+ EString s -> mktool (NString s)+ EList es -> if exprIsLiteral e+ then mktool (NList es)+ else errcats ["makeBoundLiteralTool: ",+ "non-literal list expression",+ show e]+ _ ->+ errcats ["makeBoundLiteralTool: non-literal or",+ "extended expression", show e]++makeBoundArgTool :: String -> Int -> Tool+makeBoundArgTool label n = + let node = ENode (NSymbol (Symbol label)) EvalUntried+ addArgNode vc toolContext _mods x y =+ case toolContext of+ TCEditFrame frame ->+ vcFrameAddNode vc frame node (map show [1..n]) x y+ _ ->+ return vc -- no effect+ in Tool ("Argument: " ++ label ++ "/" ++ show n) + return+ (toToolOpVW addArgNode)++makeIfTool :: Tool+makeIfTool = + let if_ vpui toolContext _mods x y =+ case toolContext of+ TCEditFrame frame ->+ let node = ENode (NSymbol (Symbol "if")) EvalUntried+ labels = ["test", "left", "right"]+ in vcFrameAddNode vpui frame node labels x y+ _ ->+ return vpui -- do nothing+ in Tool "if" return (toToolOpVW if_)++makeCopyTool :: Tool+makeCopyTool = dummyTool "COPY"++dummyTool :: String -> Tool+dummyTool name = + let op vpui _winId _context _mods x y =+ info ("dummyTool", name, x, y) >>+ return vpui+ in Tool ("*" ++ name ++ "*") return op++-- functionTool needs the VPUI in its op,+-- because it needs to get an environment.++functionTool :: String -> Tool+functionTool name =+ let op :: ToolOp+ op vpui winId toolContext _mods x y = + -- Some of these are not used in some cases,+ -- but with lazy evaluation it doesn't hurt to+ -- declare them all up here:+ let env = vpuiGlobalEnv vpui+ func = envGetFunction env name+ in case toolContext of+ TCCallFrame _ -> + return vpui -- do nothing+ TCEditFrame frame ->+ let modify canvas =+ vcFrameAddFunctoidNode canvas frame+ (FunctoidFunc func)+ x y+ in vpuiModCanvasIO vpui winId modify+ TCExprNode ->+ return vpui -- do nothing+ TCWorkspace ->+ case functionImplementation func of+ Primitive _ -> + return vpui -- do nothing+ Compound _ _ -> + -- Add a call frame to the workspace+ vpuiAddFrame vpui winId (FunctoidFunc func) + Nothing CallFrame + env x y 0 Nothing+ in Tool name return op+++-- | Add a frame representing a functoid to the canvas +-- of a particular window, specified by its window id (title).++vpuiAddFrame :: VPUI -> WinId -> Functoid -> Maybe [Value] -> FrameType+ -> Env -> Double -> Double -> Double -> Maybe G.Node + -> IO VPUI+vpuiAddFrame vpui winId functoid mvalues mode prevEnv x y z mparent = + let update vw = + vwAddFrame vw functoid mvalues mode prevEnv x y z mparent+ in vpuiUpdateWindowIO winId update vpui++-- | Add a frame representing a functoid to the canvas +-- of a VPUIWindow (which ought to have a canvas, of course).+-- Otherwise like vcAddFrame.++vwAddFrame :: VPUIWindow -> Functoid -> Maybe [Value] -> FrameType + -> Env -> Double -> Double -> Double -> Maybe G.Node + -> IO VPUIWindow+vwAddFrame vw functoid mvalues mode prevEnv x y z mparent = + let modify canvas = vcAddFrame canvas functoid mvalues mode prevEnv+ x y z mparent+ in vpuiWindowModCanvasIO vw modify++functionToolsFromLists :: [[String]] -> [[Tool]]+functionToolsFromLists = map2 functionTool+ +-- | Open an entry for user input of function name to select a function tool.+-- Returns unaltered VPUI, for convenience in menus and key callbacks.++showFunctionEntry :: WinId -> CBMgr -> VPUI -> IO VPUI+showFunctionEntry winId uimgr vpui = + let env = vpuiGlobalEnv vpui+ fsymbols = (envFunctionSymbols env)+ -- Check whether the name is bound to a function+ checkFunctionName :: String -> SuccFail String+ checkFunctionName name =+ case envLookup env name of+ Nothing -> Fail $ name ++ ": unbound variable"+ Just (VFun _) -> Succ name+ _ -> Fail $ name ++ ": bound to non-function value"+ in showToolEntry winId "Function name" + (Just fsymbols) -- completions+ checkFunctionName -- parser+ -- activateTool -- action+ ToolFunction -- tool type specifier+ uimgr -- state+ vpui++-- | Show an entry for input of a literal value.+-- Returns unaltered VPUI, for convenience in menus and key callbacks.++showLiteralEntry :: WinId -> CBMgr -> VPUI -> IO VPUI+showLiteralEntry winId = + -- Needs uimgr for action when entry is activated+ showToolEntry winId "Literal value" + Nothing -- completions+ parseLiteral -- parser+ -- activateTool -- action+ ToolLiteral -- tool type specifier++-- | New, light replacement for most dialogs++-- | Prompt for input in a text entry.+-- When the user presses Return, attempt to parse the input text.+-- If parse succeeds, apply the toolType to the resulting value+-- to produce a ToolId and set the corresponding tool.+-- If user presses Escape, the input is closed with no action.+-- If mcompletions is (Just comps), comps is a list of possible+-- completions for the entry.+-- +-- Returns the vpui, with NO UPDATE, for convenience in callbacks and menus++-- *** Consider merging this with the other "light dialog"+-- in EditArgsPanel.hs++-- Note: this has been specialized; the action only sets a tool+-- on the window. It can be generalized again+-- to any sort of action if needed.+showToolEntry :: WinId -> String -> Maybe [String] + -> (String -> SuccFail a) -> (a -> ToolId)+ -> CBMgr -> VPUI+ -> IO VPUI+showToolEntry winId prompt mcompletions parser toolType uimgr vpui =+ let vw = vpuiGetWindow vpui winId+ in case vpuiWindowLookupCanvas vw of+ Nothing -> error "showToolEntry: no canvas!"+ Just canvas ->+ let layout = vcLayout canvas+ (xx, yy) = vcMousePos canvas+ in do+ {+ ; root <- eventBoxNew -- needed for Label visibility+ ; frame <- frameNew+ ; frameSetLabel frame prompt+ ; entry <- entryNew+ ; case mcompletions of+ Nothing -> return ()+ Just comps -> addEntryCompletions entry comps++ -- Organize as (eventbox (frame (entry)))+ ; containerAdd frame entry+ ; containerAdd root frame+ ; layoutPut layout root (round xx) (round yy)+ ; widgetShowAll root++ -- grab and handle events+ ; grabAdd entry -- all keyboard and mouse events of the app+ ; widgetGrabFocus entry -- grabs keyboard events, still necessary+ -- Set actions for TAB (entry completion) and ESC (cancel)+ ; _ <- on entry keyPressEvent (entryKeyPress root entry)+ ; uimgr (OnEntryActivate entry+ (entryActivated root winId entry parser toolType))+ ; return vpui+ }++-- | When activated, send a message to set the current tool +entryActivated :: (ContainerClass c) => + c -> WinId -> Entry + -> (String -> SuccFail a) -- parser+ -> (a -> ToolId) -- tool type+ -> IORef VPUI -- state+ -> IO ()+entryActivated container winId entry parser toolType uiref = do+-- This could be rewritten in the form of :: ... -> VPUI -> IO VPUI+-- and transformed in the CBMgr, "lifting" the readIORef/writeIORef,+-- in fact streamlining it to "mutateIORef"+ {+ text <- entryGetText entry+ ; case parser text of+ Fail msg -> info msg+ Succ v -> + grabRemove entry >>+ widgetDestroy container >>+ readIORef uiref >>= + vpuiSetTool (toolType v) winId >>=+ writeIORef uiref+ }++addEntryCompletions :: Entry -> [String] -> IO ()+addEntryCompletions entry comps = do+ {+ -- prepare the model+ model <- listStoreNew comps++ -- make EntryCompletion and set model and column+ ; ec <- entryCompletionNew+ ; set ec [entryCompletionModel := Just model]+ ; customStoreSetColumn model (makeColumnIdString 0) id+ ; entryCompletionSetTextColumn ec+ (makeColumnIdString 0 :: ColumnId a String)++ -- attach EntryCompletion to Entry+ ; entrySetCompletion entry ec+ ; return ()+ }++-- | Set actions for Tab and Escape+entryKeyPress :: (ContainerClass c) => c -> Entry -> EventM EKey Bool+entryKeyPress container entry =+ tryEvent $ do+ {+ kname <- eventKeyName+ ; case glibToString kname of+ "Escape" ->+ liftIO $ + grabRemove entry >>+ widgetDestroy container+ "Tab" ->+ -- complete the entry as far as possible+ liftIO $+ entryGetCompletion entry >>=+ entryCompletionInsertPrefix+ _ -> stopEvent+ } ++-- | For debugging (frame context menu command)+dumpFrame :: VPUI -> WinId -> CanvFrame -> IO ()+dumpFrame vpui winId frame = + let vw = vpuiGetWindow vpui winId+ canv = vpuiWindowGetCanvas vw+ graph = vcGraph canv+ frameNode = cfFrameNode frame+ frame' = vcGetFrame canv graph frameNode -- ?? possibly different+ tree = graphToOrderedTreeFrom graph frameNode+ in + info ("frame functoid:", cfFunctoid frame) >>+ info ("frame' functoid:", cfFunctoid frame') >>+ info ("frame' all descendants:", + nodeAllSimpleDescendants graph frameNode) >>+ info "Tree rooted at frame:" >>+ putTree tree++-- | For debugging (frame context menu command)+dumpGraph :: VPUI -> WinId -> IO ()+dumpGraph vpui = + printWGraph . vcGraph . vpuiWindowGetCanvas . vpuiGetWindow vpui++-- | For debugging the window's widget children+dumpWorkWin :: VPUI -> WinId -> IO ()+dumpWorkWin vpui winId =+ case vpuiTryGetWindow vpui winId of+ Nothing -> putStrLn ("dumpWorkWin: no window found with id " ++ winId)+ Just vpuiWindow ->+ let window = vpuiWindowWindow vpuiWindow+ in dumpWidget window >>+ containerForeach window dumpWidget++dumpWidget :: (WidgetClass w) => w -> IO ()+dumpWidget w = do+ {+ (_, path, _) <- widgetClassPath w :: IO (Int, String, String)+ ; cname <- widgetClassName w+ ; vis <- get w widgetVisible+ ; print (path, cname, vis)+ ; when (elem cname ["GtkVBox", "GtkHBox", "GtkLayout"]) $+ containerForeach (castToContainer w) dumpWidget+ }++widgetClassName :: (WidgetClass w) => w -> IO String+widgetClassName w = do+ {+ (_len, _path, rpath) <- widgetClassPath w+ ; return (case elemIndex '.' rpath of+ Nothing -> "Nil"+ Just n -> reverse (take n rpath))+ }++-- | Clear frame indicated by mouse location+clearFrame :: WinId -> CanvFrame -> VPUI -> IO VPUI+clearFrame winId frame vpui =+ let clear canvas = vcClearFrame canvas frame+ in vpuiModCanvasIO vpui winId clear++-- | Close frame (context menu command)+closeFrame :: VPUI -> WinId -> CanvFrame -> IO VPUI+closeFrame vpui winId frame =+ let close canvas = vcCloseFrame canvas frame+ in vpuiModCanvasIO vpui winId close
+ lib/Graphics/UI/Sifflet/Types.hs view
@@ -0,0 +1,303 @@+module Graphics.UI.Sifflet.Types + ( VPUI(..)+ , WinId, VPUIWindow(..)+ , vpuiFileChanged+ , vpuiUserEnvAList++ -- | Operations on a VPUI involving its window+ , vpuiInsertWindow+ , vpuiTryGetWindow+ , vpuiGetWindow+ , vpuiUpdateWindow+ , vpuiReplaceWindow+ , vpuiUpdateWindowIO+ , vpuiRemoveVPUIWindow++ -- | Operations on a window involving its canvas+ , vpuiWindowLookupCanvas, vpuiWindowGetCanvas+ , vpuiWindowSetCanvas, vpuiWindowModCanvas + , vpuiWindowModCanvasIO++ -- | Operation on a VPUI involving the canvas of its window+ , vpuiModCanvas, vpuiModCanvasIO+ + -- | Other operations on a window+ , vpuiWindowWindow++ , VPToolkit(..)++ , Toolbox(..)+ , Tool(..)+ , ToolContext(..)++ , CanvasToolOp+ , ToolOp+ , toToolOpVW ++ , Workspace(..)+ , VCanvas(..)+ , Selection(..)+ , Dragging(..)+ )++where++import Data.Map as Map +import Data.Graph.Inductive as G++import Graphics.UI.Gtk.Gdk.EventM (Modifier(..))++import Data.Sifflet.Geometry+import Data.Sifflet.TreeLayout+import Data.Sifflet.WGraph+import Language.Sifflet.Expr++import Graphics.UI.Sifflet.Frame+import Graphics.UI.Sifflet.LittleGtk+import Graphics.UI.Sifflet.RPanel+import Language.Sifflet.Util+++-- | VPUI: Sifflet (formerly VisiProg) User Interface+-- The initialEnv is apt to contain "builtin" functions;+-- it's preserved here so that when writing to a file,+-- we can skip the functions that were in the initial env.+data VPUI = VPUI {+ vpuiWindows :: Map WinId VPUIWindow, -- ^ all the windows of the program+ vpuiToolkits :: [(String, VPToolkit)], -- ^ ordered association list,+ -- collections of tools+ vpuiInitialDir :: FilePath, -- where Sifflet started+ vpuiCurrentDir :: FilePath, -- current working directory+ vpuiCurrentFile :: Maybe FilePath, -- ^ the file opened or to save+ vpuiStyle :: Style, -- ^ for windows, canvases, editors+ vpuiInitialEnv :: Env, -- ^ initial value of global environment+ vpuiGlobalEnv :: Env, -- ^ the global environment+ vpuiFileEnv :: Env, -- ^ global env as of last file open or save,+ -- used to detect unsaved changes+ vpuiDebugging :: Bool -- ^ include debug commands in context menu?+ }++-- | Tell whether the global environmkent has changed since the+-- last file open or save+vpuiFileChanged :: VPUI -> Bool+vpuiFileChanged vpui = vpuiGlobalEnv vpui /= vpuiFileEnv vpui++-- | Extract from the environment the part defined by the user+-- But you probably want to use Graphics.UI.Sifflet.Window.UserFunctions+-- instead of this.+vpuiUserEnvAList :: VPUI -> [(String, Value)]+vpuiUserEnvAList vpui =+ let env' = vpuiGlobalEnv vpui -- I hope+ env = vpuiInitialEnv vpui+ in if length env == 1 && length env' == 1+ then assocs (Map.difference (head env') (head env))+ else errcats ["vpuiUserEnv: env lengths are not one",+ "|env'|:", show (length env'),+ "|env|:", show (length env)]++-- | Insert a window in the window map+vpuiInsertWindow :: VPUI -> WinId -> VPUIWindow -> VPUI+vpuiInsertWindow vpui winId vw =+ vpui {vpuiWindows = Map.insert winId vw (vpuiWindows vpui)}++-- | Try to get the VPUIWindow with the given window ID,+-- return Just result or Nothing+vpuiTryGetWindow :: VPUI -> WinId -> Maybe VPUIWindow+vpuiTryGetWindow vpui winId = Map.lookup winId (vpuiWindows vpui)++-- | Get the VPUIWindow with the given window ID;+-- it is an error if this fails.+vpuiGetWindow :: VPUI -> WinId -> VPUIWindow+vpuiGetWindow vpui winId = vpuiWindows vpui ! winId++-- | Replace a VPUIWindow with given window ID;+-- it is an error if this fails.+vpuiReplaceWindow :: VPUI -> WinId -> VPUIWindow -> VPUI+vpuiReplaceWindow vpui winId vpuiWin =+ let winMap = vpuiWindows vpui+ winMap' = insert winId vpuiWin winMap+ in vpui {vpuiWindows = winMap'}++-- | Apply an update function to a VPUIWindow with given window ID;+-- it is an error if this fails.+vpuiUpdateWindow :: VPUI -> WinId -> (VPUIWindow -> VPUIWindow) -> VPUI+vpuiUpdateWindow vpui winId updater =+ let winMap = vpuiWindows vpui+ winMap' = adjust updater winId winMap+ in vpui {vpuiWindows = winMap'}++-- | Apply an update IO action to a VPUIWindow with given window ID;+-- it is an error if this fails.+vpuiUpdateWindowIO :: WinId -> (VPUIWindow -> IO VPUIWindow) -> VPUI -> IO VPUI+vpuiUpdateWindowIO winId updater vpui = do+ {+ let winMap = vpuiWindows vpui+ vw = winMap ! winId+ ; vw' <- updater vw+ ; let winMap' = insert winId vw' winMap+ ; return $ vpui {vpuiWindows = winMap'}+ }++-- | Remove a window from the windows map; it has already been destroyed+-- in the GUI+vpuiRemoveVPUIWindow :: WinId -> VPUI -> VPUI+vpuiRemoveVPUIWindow winId vpui =+ let winMap = vpuiWindows vpui+ winMap' = delete winId winMap+ in vpui {vpuiWindows = winMap'}++data VPUIWindow = -- VPUIJustWindow Window + VPUIWorkWin Workspace Window+ | FunctionPadWindow Window [(String, RPanel)]+++vpuiWindowWindow :: VPUIWindow -> Window+vpuiWindowWindow vw =+ case vw of+ VPUIWorkWin _ w -> w+ FunctionPadWindow w _ -> w++-- | Try to find canvas; fail gracefully+vpuiWindowLookupCanvas :: VPUIWindow -> Maybe VCanvas+vpuiWindowLookupCanvas vw =+ case vw of+ VPUIWorkWin ws _ -> Just (wsCanvas ws)+ _ -> Nothing++-- | Find canvas or fail dramatically+vpuiWindowGetCanvas :: VPUIWindow -> VCanvas+vpuiWindowGetCanvas vw =+ case vpuiWindowLookupCanvas vw of+ Nothing -> error "vpuiWindowGetCanvas: no canvas found"+ Just canvas -> canvas++vpuiWindowSetCanvas :: VPUIWindow -> VCanvas -> VPUIWindow+vpuiWindowSetCanvas vw canvas =+ case vw of+ VPUIWorkWin ws w -> VPUIWorkWin (ws {wsCanvas = canvas}) w+ _ -> error "vpuiWindowSetCanvas: not a workspace window"++vpuiWindowModCanvas :: VPUIWindow -> (VCanvas -> VCanvas) -> VPUIWindow+vpuiWindowModCanvas vw f =+ case vpuiWindowLookupCanvas vw of+ Nothing -> error "vpuiWindowModCanvas: plain VPUIWindow"+ Just canvas -> vpuiWindowSetCanvas vw (f canvas)++vpuiWindowModCanvasIO :: VPUIWindow -> (VCanvas -> IO VCanvas) -> IO VPUIWindow+vpuiWindowModCanvasIO vw f =+ case vpuiWindowLookupCanvas vw of+ Nothing -> error "vpuiWindowModCanvas: plain VPUIWindow"+ Just canvas -> + do+ { + canvas' <- f canvas+ ; return $ vpuiWindowSetCanvas vw canvas'+ }++-- | Update the canvas of the specified window, without IO+vpuiModCanvas :: VPUI -> WinId -> (VCanvas -> VCanvas) -> VPUI+vpuiModCanvas vpui winId modCanvas = + let modWindow vw = vpuiWindowModCanvas vw modCanvas+ in vpuiUpdateWindow vpui winId modWindow++-- | Update the canvas of the specified window, with IO+vpuiModCanvasIO :: VPUI -> WinId -> (VCanvas -> IO VCanvas) -> IO VPUI+vpuiModCanvasIO vpui winId modCanvas = + let modWindow vw = vpuiWindowModCanvasIO vw modCanvas+ in vpuiUpdateWindowIO winId modWindow vpui++type WinId = String++data Workspace = + Workspace {wsRootWidget :: VBox, -- ^ container of the rest+ wsCanvas :: VCanvas, -- ^ the canvas+ wsButtonBar :: HBox,+ wsStatusbar :: Statusbar,+ wsArgToolSpecs :: [ArgSpec] -- ^ none if not editing+ }+++-- | Toolkit functions are organized in groups (rows) for presentation+-- in a toolbox+data VPToolkit = VPToolkit {toolkitName :: String,+ toolkitWidth :: Int, -- (-1) = don't care+ toolkitRows :: [[Tool]]}++-- | A Toolbox is a framed VBox with a set of Toolbars attached+data Toolbox = Toolbox {toolboxFrame :: GtkFrame+ , toolboxVBox :: VBox}++-- | ToolOp a is intended for a = VPUIWindow or VCanvas+-- type ToolOp a +-- = VPUI -> a -> ToolContext -> [Modifier] -> Double -> Double -> IO a++type ToolOp + = VPUI -> WinId -> ToolContext -> [Modifier] -> Double -> Double -> IO VPUI++type CanvasToolOp+ = VCanvas -> ToolContext -> [Modifier] -> Double -> Double -> IO VCanvas++data Tool = Tool {toolName :: String, -- the tool's name++ -- what to do when the tool is selected from the toolbox+ toolActivated :: VCanvas -> IO VCanvas,++ -- what to do to apply the tool to a point on the canvas+ toolOp :: ToolOp+ }++-- | A helper for making toolOps from actions on VCanvas++toToolOpVW :: CanvasToolOp -> ToolOp+toToolOpVW vcOp vpui winId toolContext mods x y = do+ {+ let vw = vpuiGetWindow vpui winId+ canv = vpuiWindowGetCanvas vw+ ; canv' <- vcOp canv toolContext mods x y+ ; let vw' = vpuiWindowSetCanvas vw canv'+ ; return $ vpuiReplaceWindow vpui winId vw'+ }+ +-- | ToolContext: The way a tool should be applied depends on +-- where it is being used ++data ToolContext = TCWorkspace + | TCCallFrame CanvFrame + | TCEditFrame CanvFrame+ | TCExprNode -- ???++++-- | A canvas that can display multiple boxes representing +-- expressions or function definitions or calls++data VCanvas = VCanvas {+ vcLayout :: GtkLayout,+ vcStyle :: Style,+ vcGraph :: WGraph,+ vcFrames :: [CanvFrame],+ vcSize :: Size,+ -- vcLocalEnv :: Env, -- only good for function editor, I think? + vcMousePos :: (Double, Double),+ vcTool :: Maybe Tool, -- current tool on this canvas+ vcActive :: Maybe Node, -- active node, if any+ vcSelected :: Maybe Selection, -- selected node(s), if any+ vcDragging :: Maybe Dragging -- what we're dragging, if anything+ }+++data Selection = SelectionNode {selNode :: G.Node}+ | SelectionInlet {selNode :: G.Node,+ selInEdge :: WEdge} -- numbered from 0+ | SelectionOutlet {selNode :: G.Node,+ selOutEdge :: WEdge} -- normally just 0+ deriving (Eq, Read, Show)++-- | A Dragging keeps track of the object (node) being dragged+-- and the current mouse position.++data Dragging = Dragging { draggingNode :: G.Node,+ draggingPosition :: Position+ }+ deriving (Eq, Read, Show)+
+ lib/Graphics/UI/Sifflet/Window.hs view
@@ -0,0 +1,1281 @@+module Graphics.UI.Sifflet.Window+ (+ -- Window utilities+ getOrCreateWindow+ , showWindow+ , newWindowTitled++ , showWorkWin+ , showWorkspaceWindow++ , showFedWin+ , fedWindowTitle++ , getOrCreateFunctionPadWindow+ , showFunctionPadWindow+ , newFunctionDialog++ , openFilePath+ , setWSCanvasCallbacks+ , keyBindingsHelpText+ )++where++-- debug imports+-- import Debug.Trace++-- standard imports++import Control.Monad+import Data.IORef+import Data.List as List+import Data.Map as Map (fromList, keys, lookup)+import Data.Map (Map)+import Data.Maybe+import Data.Text (Text, pack)++import Data.Graph.Inductive as G+import Data.Version++import Graphics.Rendering.Cairo+import Graphics.UI.Gtk.Gdk.EventM++import System.FilePath++-- sifflet imports++import Data.Sifflet.Functoid+import Data.Sifflet.Geometry+import Data.Sifflet.WGraph++import Language.Sifflet.Export.Exporter+import Language.Sifflet.Export.ToHaskell (defaultHaskellOptions, exportHaskell)+import Language.Sifflet.Export.ToPython (defaultPythonOptions, exportPython)+import Language.Sifflet.Export.ToScheme (SchemeOptions(..), exportScheme)++import Language.Sifflet.Expr+import Language.Sifflet.SiffML++import Graphics.UI.Sifflet.Frame+import Graphics.UI.Sifflet.Canvas+import Graphics.UI.Sifflet.Types+import Graphics.UI.Sifflet.Callback+import Graphics.UI.Sifflet.Tool+import Graphics.UI.Sifflet.Workspace+import Graphics.UI.Sifflet.GtkForeign+import Graphics.UI.Sifflet.GtkUtil+import Graphics.UI.Sifflet.LittleGtk+import Graphics.UI.Sifflet.RPanel++import Language.Sifflet.Util+++import Paths_sifflet as Paths++-- ---------------------------------------------------------------------+-- | Finding, creating, and initializing windows (VPUIWindow)++-- | Find and show a window, if it exists.+-- If not, create the window, put it in the vpui's window map,+-- and initialize it and any auxiliary objects using the initWin function.+-- The 3rd argument of initWin will be the window's title.+-- Always presents the window (shows and raises).+-- Returns a 3-tuple: the VPUIWindow contains the Window,+-- and the Bool value is True if the Window is new+-- (and therefore might need some further initialization).+-- The third tuple element is an IORef to the VPUIWindow;+-- it may be useful for setting up signal and event handling.++showWindow :: WinId -> CBMgr+ -> (VPUI -> Window -> IO VPUIWindow) -- initializes Gtk Window+ -> (VPUI -> WinId -> CBMgr -> IO ()) -- initializes callbacks+ -> VPUI -> IO (VPUI, VPUIWindow, Bool)+showWindow winId uimgr initWin initCB vpui =+ getOrCreateWindow winId uimgr initWin initCB True vpui++-- | Like showWindow, except that making the window visible is optional+getOrCreateWindow :: WinId -> CBMgr+ -> (VPUI -> Window -> IO VPUIWindow) + -- ^ initialize Gtk Window+ -> (VPUI -> WinId -> CBMgr -> IO ())+ -- ^ initialize callbacks+ -> Bool -- ^ make window visible+ -> VPUI -> IO (VPUI, VPUIWindow, Bool)+getOrCreateWindow winId uimgr initWin initCB visible vpui = do+ (vpui', vw, isNew) <- + case vpuiTryGetWindow vpui winId of+ Nothing -> do+ window <- newWindowTitled winId+ widgetSetName window ("Sifflet-" ++ winId)+ vwin <- initWin vpui window+ let vpui' = vpuiInsertWindow vpui winId vwin+ uimgr (OnWindowDestroy window (onWindowDestroy winId))+ return (vpui', vwin, True)+ Just vw ->+ return (vpui, vw, False)+ when isNew (initCB vpui' winId uimgr) -- add callbacks on new window+ when visible $+ -- show it+ let window = vpuiWindowWindow vw+ in do+ widgetShowAll window+ windowPresent window+ return (vpui', vw, isNew)++onWindowDestroy :: WinId -> IORef VPUI -> IO ()+onWindowDestroy winId uiref =+ if (winId == workspaceId) + then + readIORef uiref >>=+ checkForChanges "quit (by closing the workspace window)" True False+ (\ vpui -> do { mainQuit; return vpui }) >>+ return ()+ else modifyIORef uiref (vpuiRemoveVPUIWindow winId)++-- | Default "do-nothing" add-callbacks function+initCBDefault :: VPUI -> WinId -> CBMgr -> IO ()+initCBDefault _vpui _winId _uimgr = return ()++newWindowTitled :: String -> IO Window+newWindowTitled winId = do+ window <- windowNew+ set window [windowTitle := winId]+ widgetSetName window ("Sifflet-" ++ winId)+ return window++-- | Show a workspace window, with a given title, _not_ editing a function++showWorkWin :: VPUI -> WinId -> CBMgr -> IO VPUI+showWorkWin vpui winId uimgr = do+ {+ (vpui', _, _) <- showWorkspaceWindow winId uimgr Nothing vpui+ ; return vpui'+ }++-- | Show a workspace window with a given title and maybe function to edit++showWorkspaceWindow :: WinId -> CBMgr -> Maybe Function -> VPUI+ -> IO (VPUI, VPUIWindow, Bool)+showWorkspaceWindow winId cbmgr mfunc =+ showWindow winId cbmgr (workspaceWindowInit cbmgr winId mfunc) + setWSCanvasCallbacks+++-- | Initialize a Workspace window.+-- Called in sifflet.hs:Main from showWindow called from showWorkspaceWindow.++workspaceWindowInit :: CBMgr -> WinId -> Maybe Function -> VPUI -> Window+ -> IO VPUIWindow+workspaceWindowInit cbmgr winId mfunc vpui window = do+ {+ let style = vpuiStyle vpui+ env = vpuiGlobalEnv vpui+ ; ws <- case mfunc of + Nothing -> workspaceNewDefault style (buildMainMenu cbmgr)+ Just func -> workspaceNewEditing style env func+ ; set window [windowTitle := winId, containerChild := wsRootWidget ws]+ -- this should suppress the window close button,+ -- but doesn't, at least in Fluxbox+ -- windowDeletable := False] -- no close button+ ; widgetShowAll window+ ; windowPresent window++ ; return $ VPUIWorkWin ws window+ }++-- Menu specs here need to coordinate accelerators (shortcuts)+-- with keyBindingsList in WindowManagement.hs++buildMainMenu :: CBMgr -> VBox -> IO ()+buildMainMenu cbmgr vbox = do+ {+ -- menu bar + let mspecs = + [MenuSpec "File"+ [ -- "new" isn't implemented yet+ -- MenuItem "New ..." menuFileNew+ -- , + -- Temporarily disabling file I/O operations+ MenuItem "Open ... (C-o)" (menuFileOpen cbmgr)+ , MenuItem "Save (C-s)" menuFileSave+ , MenuItem "Save as ..." menuFileSaveAs+ , MenuItem "Export to Haskell ..." + menuFileExportHaskell+ , MenuItem "Export to Python3 ..." menuFileExportPython+ , MenuItem "Export to Scheme ..." menuFileExportScheme+ , MenuItem "Save image ..." menuFileSaveImage+ , MenuItem "Quit (C-q)" menuFileQuit]+ , MenuSpec "Functions"+ [MenuItem "New ... (n)"+ (newFunctionDialog "ignore" cbmgr)+ , MenuItem "Function Pad"+ (showFunctionPadWindow cbmgr)]+ , MenuSpec "Help"+ [MenuItem "Help ..." showHelpDialog+ , MenuItem "Complaints and praise ..." showBugs+ , MenuItem "About ..." showAboutDialog]+ ]+ ; menubar <- createMenuBar mspecs cbmgr+ ; boxPackStart vbox menubar PackNatural 0+}++-- | Show a function editor window = a workspace window editing a given function.+-- Use argNames for a new function; ignore them if funcName is bound.++showFedWin :: CBMgr -> String -> [String] -> VPUI -> IO VPUI+showFedWin cbmgr funcName argNames vpui = do+ {+ let initEnv = vpuiGlobalEnv vpui+ function = case envLookupFunction initEnv funcName of+ Nothing -> newUndefinedFunction funcName argNames+ Just func -> func+ winId = fedWindowTitle funcName++ ; (vpui', vw, isNew) <- showWorkspaceWindow winId cbmgr (Just function) vpui++ ; if isNew+ then do+ {+ let canvas = vpuiWindowGetCanvas vw+ ; canvas' <- vcAddFrame canvas (FunctoidFunc function) + Nothing EditFrame+ initEnv 0 0 0 Nothing+ ; canvas'' <- + case vcFrames canvas' of+ [] -> info "showFedWin: ERROR: no frame on canvas" >> + return canvas'+ _:_:_ -> + info "showFedWin: ERROR: too many frames on canvas" >> + return canvas'+ [frame] -> editFunction canvas' frame + ; addFedWinButtons cbmgr winId vpui'+ ; return (vpuiReplaceWindow vpui' winId + (vpuiWindowSetCanvas vw canvas''))+ }+ else return vpui'+ }++fedWindowTitle :: String -> WinId+fedWindowTitle funcName = "Edit " ++ funcName++updateFunctionPadIO :: String -> (RPanel -> IO RPanel) -> VPUI -> IO VPUI+updateFunctionPadIO padName update =+ let updateWindow vw =+ case vw of+ FunctionPadWindow window rpAList ->+ do+ {+ rpAList' <- adjustAListM padName update rpAList+ ; return (FunctionPadWindow window rpAList')+ }+ _ -> return vw+ in vpuiUpdateWindowIO "Function Pad" updateWindow++-- | Show the function pad window; create it if needed+showFunctionPadWindow :: CBMgr -> VPUI -> IO VPUI+showFunctionPadWindow cbmgr vpui = getOrCreateFunctionPadWindow cbmgr True vpui++-- | Create the function pad window if it doesn't exist+getOrCreateFunctionPadWindow :: CBMgr -> Bool -> VPUI -> IO VPUI+getOrCreateFunctionPadWindow cbmgr visible vpui = + let initWindow _vpui window = do+ vbox <- vBoxNew False 0 -- non-homogenous, 0 padding+ set window [containerChild := vbox]+ let rpnames = ["Base", "Examples", "My Functions"]+ rps <- mapM (makeFunctionPadPanel cbmgr vpui) rpnames+ mapM_ (\ rp -> boxPackStart vbox (rpanelRoot rp) PackNatural 0)+ rps+ windowMove window 5 5+ return $ FunctionPadWindow window (zip rpnames rps) + -- maybe need reference only the "My Functions" panel though **+ in do+ (vpui', _, windowIsNew) <- getOrCreateWindow functionPadWinId + cbmgr initWindow initCBDefault visible vpui+ -- "My Functions" default is empty; add any user-defined+ -- functions in the environment to it+ if windowIsNew+ then addUserFunctions cbmgr vpui'+ else return vpui'+++functionPadWinId :: String+functionPadWinId = "Function Pad"++addUserFunctions :: CBMgr -> VPUI -> IO VPUI+addUserFunctions cbmgr vpui =+ let names = map fst (vpuiUserEnvAList vpui)+ update rp = do+ {+ buttons <- mapM (makeToolButton cbmgr . functionTool) names+ ; rp' <- rpanelAddWidgets rp (zip names buttons)+ ; widgetShowAll (rpanelRoot rp')+ ; return rp'+ } + in updateFunctionPadIO "My Functions" update vpui++makeFunctionPadPanel :: CBMgr -> VPUI -> String -> IO RPanel+makeFunctionPadPanel cbmgr vpui name =+ let VPToolkit _ width toolrows = + case List.lookup name (vpuiToolkits vpui) of+ Nothing ->+ errcats ["makeFunctionPadPanel:",+ "can't find toolkit definition:", name]+ Just atoolkit -> atoolkit+ in do+ {+ buttonRows <- makeToolButtonRows cbmgr toolrows+ :: IO [[(String, Button)]]+ ; rp <- newRPanel name 3 3 width+ ; rpanelAddRows rp buttonRows+ }++makeToolButtonRows :: CBMgr -> [[Tool]] -> IO [[(String, Button)]]+makeToolButtonRows cbmgr toolRows = + mapM2 (makeNamedToolButton cbmgr) toolRows++makeNamedToolButton :: CBMgr -> Tool -> IO (String, Button)+makeNamedToolButton cbmgr tool = do+ {+ button <- makeToolButton cbmgr tool+ ; return (toolName tool, button)+ }++makeToolButton :: CBMgr -> Tool -> IO Button+makeToolButton cbmgr tool = do+ {+ button <- buttonNewWithLabel (toolName tool)+ ; cbmgr (AfterButtonClicked button+ (modifyIORefIO (forallWindowsIO (vpuiWindowSetTool tool))))+ ; return button+ }++-- | Add a tool button to the function pad window in a specified panel+addFunctionPadToolButton :: CBMgr -> String -> Tool -> VPUIWindow + -> IO VPUIWindow+addFunctionPadToolButton cbmgr panelId tool vw = + case vw of+ FunctionPadWindow window panelAList ->+ let adjustPanel :: RPanel -> IO RPanel+ adjustPanel rp = do+ {+ -- make the tool button from the tool+ button <- makeToolButton cbmgr tool+ -- add it to the panel+ ; rp' <- rpanelAddWidget rp (toolName tool) button+ ; widgetShowAll (rpanelRoot rp')+ ; return rp'+ }+ in do+ {+ panelAList' <- adjustAListM panelId adjustPanel panelAList+ ; return $ FunctionPadWindow window panelAList'+ }+ _ -> return vw+++-- | Ask user for new function name and arguments,+-- then begin editing the function.++newFunctionDialog :: WinId -> CBMgr -> VPUI -> IO VPUI+newFunctionDialog _winId cbmgr vpui =+ -- _winId is ignored, but needed for use in KeyBindingsList+ let reader :: Reader [String] (String, [String])+ reader inputLines =+ case inputLines of+ [fname, fargs] ->+ return (fname, words fargs)+ _ -> fail "wrong number of lines"+ in do+ {+ inputDialog <- + createEntryDialog "New Function"+ ["Function name", "Argument names (space between)"]+ ["", ""]+ reader+ (-1)+ ; values <- runEntryDialog inputDialog+ ; case values of+ Nothing -> return vpui+ Just (name, args) -> editNewFunction cbmgr name args vpui+ }++-- ------------------------------------------------------------+-- Implementation of menu commands++-- -- | Create a new file, but what does this mean?++-- menuFileNew :: VPUI -> IO VPUI+-- menuFileNew vpui = putStrLn "Not implemented: \"New\"" >> return vpui+-- -- Notes for future implementation:+-- -- checkChangesAndContinue vpui ...+++-- | Quit from Sifflet++menuFileQuit :: VPUI -> IO VPUI+menuFileQuit = checkForChanges "quit" False True vpuiQuit++-- | Open a file (load its function definitions)++menuFileOpen :: CBMgr -> VPUI -> IO VPUI+menuFileOpen cbmgr =+ checkForChanges "open file" True True (continueFileOpen cbmgr)++-- | Offer to save changes, if any, and continue with the continuation.+-- The continuation gets the current vpui if there are no changes+-- or if the offer to save is rejected; otherwise, it gets a+-- vpui which knows it has saved its last changes.+-- If offerCancel is true, there is an option to cancel the operation;+-- this won't work if the user is closing the main (workspace) window.+-- The message, if any, is a confirmation that the file was+-- saved and that we are going on to the next operation --+-- useful for open file, but not for quit.++checkForChanges :: String -> Bool -> Bool -> (VPUI -> IO VPUI) + -> VPUI -> IO VPUI+checkForChanges beforeOperation acknowledge offerCancel continue vpui =+ let mAckIfSaved vpui' = + when (not (vpuiFileChanged vpui') && acknowledge)+ (+ showInfoMessage "Changes saved" + ("Your changes are now saved; " +++ "proceeding to " +++ beforeOperation ++ ".")+ ) + >>+ return vpui'+ choices = [("Save them", + menuFileSave vpui >>= mAckIfSaved >>= continue),+ ("Throw them away", + return vpui >>= continue)] ++ + if offerCancel+ then [("Cancel " ++ beforeOperation, return vpui)]+ else []+ labels = map fst choices+ actions = map snd choices+ offerSaveAndContinue = showChoicesDialog "Save changes?"+ ("There are unsaved changes. " +++ "Before you " ++ beforeOperation +++ ", would you ...")+ labels+ actions+ (return vpui)+ in if vpuiFileChanged vpui+ then offerSaveAndContinue+ else continue vpui++-- | Continue with opening the file, after having possibly saved changes+continueFileOpen :: CBMgr -> VPUI -> IO VPUI+continueFileOpen cbmgr vpui = do+ mpath <- showDialogFileOpen vpui+ case mpath of+ Nothing -> return vpui+ Just filePath -> openFilePath cbmgr filePath vpui++-- | Now that we have a file path, go ahead and open it,+-- loading the function definitions into Sifflet+-- and adding buttons to the function pad "My Functions" area.++openFilePath :: CBMgr -> FilePath -> VPUI -> IO VPUI+openFilePath cbmgr filePath vpui = do+ loadResult <- loadFile vpui filePath+ case loadResult of+ Fail msg ->+ showErrorMessage msg >> return vpui+ Succ (vpui', functions) -> + let title = "My Functions"+ updatePad rp =+ -- Figure out which functions are new,+ -- i.e., not already on the pad+ let oldNames = concat (rpanelContent rp)+ loadedNames = map functionName functions+ -- use set difference to avoid duplicates+ newNames = loadedNames \\ oldNames+ newTools = map functionTool newNames+ in do + newPairs <- mapM (makeNamedToolButton cbmgr) newTools+ rp' <- rpanelAddWidgets rp newPairs+ widgetShowAll (rpanelRoot rp)+ return rp'++ in do+ vpui'' <- + getOrCreateFunctionPadWindow cbmgr False vpui' >>=+ updateFunctionPadIO title updatePad + setWorkspaceTitleForFile vpui'' filePath+ return $ vpui'' {vpuiCurrentFile = Just filePath, + vpuiCurrentDir = takeDirectory filePath,+ vpuiFileEnv = vpuiGlobalEnv vpui'}++setWorkspaceTitleForFile :: VPUI -> FilePath -> IO ()+setWorkspaceTitleForFile vpui filePath =+ case vpuiTryGetWindow vpui workspaceId of+ Just (VPUIWorkWin _ window) ->+ -- show file name in workspace window title+ set window [windowTitle := + workspaceId ++ ": " ++ takeFileName filePath]+ _ -> return ()++showDialogFileOpen :: VPUI -> IO (Maybe FilePath)+showDialogFileOpen vpui = do+ chooser <- fileChooserDialogNew+ (Just "Open file ...") -- default title+ Nothing -- transient parent of the dialog+ FileChooserActionOpen+ [("Open", ResponseOk), ("Cancel", ResponseCancel)] -- buttons+ _ <- fileChooserSetCurrentFolder chooser (vpuiCurrentDir vpui)+ result <- runDialogM (toDialog chooser) chooser fileChooserGetFilename+ return result++loadFile :: VPUI -> FilePath -> IO (SuccFail (VPUI, [Function]))+loadFile vpui filePath = do+ {+ functions <- consumeSiffMLFile xmlToFunctions filePath+ ; case functions of+ [Functions fs] ->+ let vpui' = foldl bindFunction vpui fs+ in return (Succ (vpui', fs))+ _ ->+ return (Fail "file format error")++ }++bindFunction :: VPUI -> Function -> VPUI+bindFunction vpui function =+ let env = vpuiGlobalEnv vpui+ Function (Just name) _argTypes _resType _impl = function+ env' = envIns env name (VFun function)+ in vpui {vpuiGlobalEnv = env'}++-- | Implements File menu "Save" command.++menuFileSave :: VPUI -> IO VPUI+menuFileSave vpui = + case vpuiCurrentFile vpui of+ Nothing -> menuFileSaveAs vpui+ Just filePath -> saveFile vpui filePath++-- | Implements File menu "Save as" command.+menuFileSaveAs :: VPUI -> IO VPUI+menuFileSaveAs vpui = do+ {+ mFilePath <- chooseOutputFile "Save" vpui+ ; case mFilePath of+ Nothing -> return vpui+ Just filePath -> saveFile vpui filePath+ }++-- | Unconditionally save user functions in SiffML file.+-- Called from menuFileSave and menuFileSaveAs.+-- Updates vpuiCurrentFile and vpuiFileEnv.+saveFile :: VPUI -> FilePath -> IO VPUI+saveFile vpui filePath =+ produceSiffMLFile (userFunctions vpui) filePath >>+ setWorkspaceTitleForFile vpui filePath >>+ return vpui {vpuiCurrentFile = Just filePath, + vpuiCurrentDir = takeDirectory filePath, + vpuiFileEnv = vpuiGlobalEnv vpui}++-- | The user-defined functions of the environment+userFunctions :: VPUI -> Functions+userFunctions vpui = + Functions (map (valueFunction . snd) + (vpuiUserEnvAList vpui))++-- | Export user functions to a file,+-- given an exporter and a path,+-- returning the vpui unchanged.+maybeExportUserFunctions :: VPUI -> (opts -> Exporter) + -> Maybe (FilePath, opts) -> IO VPUI+maybeExportUserFunctions vpui export mpathOptions =+ case mpathOptions of+ Nothing -> return vpui + Just (path, options) -> + export options (userFunctions vpui) path >> + return (vpui {vpuiCurrentDir = takeDirectory path})++-- | Export user functions to Haskell file+menuFileExportHaskell :: VPUI -> IO VPUI+menuFileExportHaskell vpui =+ chooseOutputFile "Export Haskell" vpui >>=+ maybeDefaultOptions defaultHaskellOptions >>=+ maybeExportUserFunctions vpui exportHaskell++-- | Export user functions to Python file+menuFileExportPython :: VPUI -> IO VPUI+menuFileExportPython vpui =+ chooseOutputFile "Export Python" vpui >>=+ maybeDefaultOptions defaultPythonOptions >>=+ maybeExportUserFunctions vpui (exportPython vpui)++-- | Export user functions to Scheme file+menuFileExportScheme :: VPUI -> IO VPUI+menuFileExportScheme vpui =+ chooseOutputFile "Export Scheme" vpui >>= + maybeRunSchemeOptionsDialog >>=+ -- maybeExportUserFunctions vpui (exportScheme defaultSchemeOptions) + maybeExportUserFunctions vpui (exportScheme vpui)++-- | Choose an output file, for file save, save as, and export commands+chooseOutputFile :: String -> VPUI -> IO (Maybe FilePath)+chooseOutputFile verb vpui = do+ chooser <- fileChooserDialogNew+ (Just (verb ++ " to file ...")) -- title+ Nothing -- transient parent of the dialog+ FileChooserActionSave+ [(verb, ResponseOk), ("Cancel", ResponseCancel)] -- buttons+ _ <- fileChooserSetCurrentFolder chooser (vpuiCurrentDir vpui)+ result <- runDialogM (toDialog chooser) chooser fileChooserGetFilename+ return result++maybeDefaultOptions :: a -> Maybe FilePath -> IO (Maybe (FilePath, a))+maybeDefaultOptions defaultOptions mpath =+ case mpath of+ Nothing -> return Nothing+ Just path -> return $ Just (path, defaultOptions)++maybeRunSchemeOptionsDialog :: Maybe FilePath + -> IO (Maybe (FilePath, SchemeOptions))+maybeRunSchemeOptionsDialog mpath =+ case mpath of+ Nothing -> return Nothing+ Just path ->+ let result :: Bool -> IO (Maybe (FilePath, SchemeOptions))+ result useLambda =+ return (Just (path, + SchemeOptions {defineWithLambda = useLambda}))+ in showChoicesDialog "Scheme Export Options"+ "Use lambda in function definitions?"+ ["Yes", "No"]+ [result True, result False]+ (result False)+++-- | Save an image of a window in a file++menuFileSaveImage :: VPUI -> IO VPUI+menuFileSaveImage vpui = do+ mImageOptions <- chooseImageOptions vpui+ case mImageOptions of+ Nothing -> return vpui+ Just (windowId, fileExt) -> do+ mfile <- chooseOutputFile ("Save image of " ++ windowId) vpui+ case mfile of+ Nothing -> return vpui+ Just filePath ->+ saveImageFile vpui windowId filePath fileExt++-- | Returns (WinId, fileExtension),+-- e.g., ("Sifflet Workspace", ".svg"),+-- where fileExtension is ".svg", ".ps", or ".pdf"+chooseImageOptions :: VPUI -> IO (Maybe (WinId, String))+chooseImageOptions vpui =+ let hasCanvas winId = + isJust (vpuiWindowLookupCanvas (vpuiGetWindow vpui winId))+ -- We can only use Cairo to render a window that has a canvas+ windowChoices = filter hasCanvas (keys (vpuiWindows vpui))+ windowActions = map (return . Just) windowChoices+ formatChoices = ["SVG", "PS", "PDF"]+ formatActions = map (return . Just) [".svg", ".ps", ".pdf"]+ in do+ mExt <- showChoicesDialog "Save Image" "Select image format"+ formatChoices formatActions (return Nothing)+ case mExt of+ Nothing -> return Nothing+ Just ext -> do+ mWinId <- + if length windowChoices == 1+ then return $ Just $ head windowChoices+ else showChoicesDialog "Save Image"+ "Select window to save as image"+ windowChoices windowActions (return Nothing)+ case mWinId of+ Nothing -> return Nothing+ Just winId -> return $ Just (winId, ext)++-- | Save the window image in the file format specified,+-- adding the right file extension to the file path if it is+-- not already present.+saveImageFile :: VPUI -> WinId -> FilePath -> String -> IO VPUI+saveImageFile vpui winId path ext =+ let vpuiWindow = vpuiGetWindow vpui winId+ canvas = vpuiWindowGetCanvas vpuiWindow + -- Size width height = vcSize canvas -- pixels (Double)+ clipbox@(BBox _ _ width height) = defaultFileSaveClipBox canvas+ -- cliprect = bbToRect clipbox++ render :: Surface -> IO ()+ render surface = + renderWith surface (renderCanvas canvas clipbox True)+ -- (BBox 0 0 width height)+ path' = if takeExtension path == ext+ then path+ else addExtension path ext+ vpui' = vpui {vpuiCurrentDir = takeDirectory path}+ in case ext of+ ".pdf" -> withPDFSurface path' width height render >> return vpui'+ ".ps" -> withPSSurface path' width height render >> return vpui'+ ".svg" -> withSVGSurface path' width height render >> return vpui'+ + -- Cairo can do PNG too, but it is harder:+ -- surfaceWriteToPNG surface path'+ -- (have to get a surface and render to it first?)++ -- Anything else really should not happen, because+ -- chooseImageOptions returns one of the three extensions above.+ -- But just in case:+ _ -> do+ showErrorMessage $+ "Unable to save in this file format " +++ "(" ++ ext ++ ").\n" +++ "Please try a file extension of " +++ ".svg, .ps, or .pdf."+ menuFileSaveImage vpui'++++-- | Text shown by the help dialog+helpText :: String+helpText =+ unlines ["Functions menu:",+ " \"New\" enters a dialog to create a new function.",+ " \"Function pad\" raises the function pad window.",+ "Keystroke shortcuts for the menu commands are shown " +++ "using \"C-\" for Control. For example, Quit " +++ "is C-q, meaning Control+Q.",+ "",+ "In a function editor, right-click for the context menu.",+ "",+ "For more help, please visit the Sifflet web site,",+ "http://mypage.iu.edu/~gdweber/software/sifflet/",+ "especially the Sifflet Tutorial:",+ "http://mypage.iu.edu/~gdweber/software/sifflet/doc/tutorial.html"+ ]++-- | Show the help dialog+showHelpDialog :: MenuItemAction+showHelpDialog vpui = showInfoMessage "Sifflet Help" helpText >> return vpui++-- | How to report bugs+bugsText :: String+bugsText =+ unlines ["To report bugs, please send mail to " ++ bugReportAddress,+ "and mention \"Sifflet\" in the Subject header.",+ "To send praise, follow the same procedure.",+ "Seriously, whether you like Sifflet or dislike it,",+ "I'd like to hear from you."+ ]++bugReportAddress :: String+bugReportAddress = concat ["gdweber", at, "iue", punctum, "edu"]+ where at = "@"+ punctum = "."++showBugs :: MenuItemAction+showBugs vpui = showInfoMessage "Reporting bugs" bugsText >> return vpui++-- | Text for the About dialog+aboutText :: String+aboutText =+ unlines ["Sifflet version " ++ showVersion Paths.version,+ "Copyright (C) 2010-2012 Gregory D. Weber",+ "",+ "BSD3 License",+ "",+ "Sifflet home page:",+ "http://mypage.iu.edu/~gdweber/software/sifflet/"+ ]++showAboutDialog :: MenuItemAction+showAboutDialog vpui = showInfoMessage "About Sifflet" aboutText >> return vpui++-- ----------------------------------------------------------------------++-- Moved here (WHY???) from Callbacks.hs:++setWSCanvasCallbacks :: VPUI -> WinId -> CBMgr -> IO ()+setWSCanvasCallbacks vpui winId cbmgr = do+ {+ let vw = vpuiGetWindow vpui winId+ window = vpuiWindowWindow vw+ ; case vpuiWindowLookupCanvas vw of+ Nothing ->+ errcats ["setWSCanvasCallbacks: VPUIWindow is not a VPUIWorkWin",+ "and has no canvas"]+ Just canvas ->+ do+ {+ -- Notice when the window size is changed+ ; cbmgr (OnWindowConfigure window (configuredCallback winId))++ -- Keypress events -- send to canvas window because the Gtk.Layout+ -- cannot receive them (why ever not?)+ ; cbmgr (AfterWindowKeyPress window (keyPressCallback winId cbmgr))++ -- Send remaining events to the Gtk.Layout (why?)+ ; let layout = vcLayout canvas+ ; widgetSetCanFocus layout True+ ; cbmgr (OnLayoutExpose layout (exposedCallback winId))++ -- Mouse events + ; widgetAddEvents layout [PointerMotionMask]+ ; cbmgr (OnLayoutMouseMove layout (mouseMoveCallback winId))+ ; cbmgr (OnLayoutButtonPress layout + (buttonPressCallback winId cbmgr))+ ; cbmgr (OnLayoutButtonRelease layout (buttonReleaseCallback winId))+ }+ }++-- | Context menu command to edit the function displayed in +-- a CallFrame++editFrameFunction :: CBMgr -> CanvFrame -> VPUI -> IO VPUI+editFrameFunction cbmgr frame vpui =+ let func = cfFunctoid frame+ in showFedWin cbmgr (functoidName func) (functoidArgNames func) vpui++-- | Create a new function, add it to the global environment +-- with body undefined, and start editing it in a new window. +-- Also update and show "My Functions" toolbox and+-- update its toolkit.++editNewFunction :: CBMgr -> String -> [String] -> VPUI -> IO VPUI+editNewFunction cbmgr name args vpui = + let updateEnv :: VPUI -> IO VPUI+ updateEnv vpui' =+ let env = vpuiGlobalEnv vpui'+ env' = envIns env name (VFun (newUndefinedFunction name args))+ in return $ vpui' {vpuiGlobalEnv = env'} + in + -- Show window first, with the *old* functions+ showFunctionPadWindow cbmgr vpui >>=+ updateEnv >>=+ vpuiUpdateWindowIO functionPadWinId+ (addFunctionPadToolButton cbmgr "My Functions" + (functionTool name)) >>=+ showFedWin cbmgr name args++configuredCallback :: WinId -> IORef VPUI -> EventM EConfigure Bool+configuredCallback winId uiref =+ tryEvent $ do+ {+ (w, h) <- eventSize+ ; liftIO $ modifyIORef uiref (handleConfigured winId w h)+ -- We *must* "stop the event", forcing the event handler + -- to return False, or else the canvas remains "squeezed in"+ -- -- Weird!!+ ; stopEvent+ }++-- | Handle the Configured event.+handleConfigured :: WinId -> Int -> Int -> VPUI -> VPUI+handleConfigured winId width height vpui = + let vw = vpuiGetWindow vpui winId+ vw' = vpuiWindowModCanvas vw + (atLeastSize (Size (fromIntegral width) (fromIntegral height)))+ in vpuiReplaceWindow vpui winId vw'++exposedCallback :: WinId -> IORef VPUI -> EventM EExpose Bool+exposedCallback winId uiref =+ tryEvent $ do+ {+ cliprect <- eventArea+ ; liftIO (readIORef uiref >>= handleExposed winId cliprect)+ }++-- | Handle the Exposed event, should be called only for a window+-- with a canvas+handleExposed :: WinId -> Rectangle -> VPUI -> IO ()+handleExposed winId cliprect vpui = + let vw = vpuiGetWindow vpui winId -- error if not found+ in case vpuiWindowLookupCanvas vw of+ Nothing -> info "handleExposed: no canvas found!"+ Just canvas -> drawCanvas canvas cliprect ++data KeyBinding = KeyBinding {kbGtkKeyName :: String,+ kbAltKeyName :: Maybe String, -- for humans+ kbRequiredModifiers :: [Modifier],+ kbDescription :: String,+ kbAction :: KeyAction}++data KeyAction + = KeyActionST (WinId -> VPUI -> IO VPUI) -- ^ set a tool+ | KeyActionDG (WinId -> CBMgr -> VPUI -> IO VPUI) -- ^ start a dialog+ | KeyActionModIO (CBMgr -> VPUI -> IO VPUI) -- ^ modify VPUI with IO+ | KeyActionHQ (VPUI -> IO ()) -- ^ help or quit++-- | Key bindings map. This is derived from keyBindingsList.+keyBindingsMap :: Map Text KeyBinding+keyBindingsMap =+ Map.fromList [(pack (kbGtkKeyName kb), kb) | kb <- keyBindingsList]++-- | KeyBinding list for workspace and function editor windows.++keyBindingsList :: [KeyBinding]+keyBindingsList = + [+ -- Bindings to set tools+ KeyBinding "c" Nothing [] "connect" + (KeyActionST (vpuiSetTool ToolConnect))+ , KeyBinding "d" Nothing [] "disconnect" + (KeyActionST (vpuiSetTool ToolDisconnect))+ , KeyBinding "i" Nothing [] "if" (KeyActionST (vpuiSetTool ToolIf))+ , KeyBinding "m" Nothing [] "move" (KeyActionST (vpuiSetTool ToolMove))+ , KeyBinding "KP_Delete" (Just "Keypad-Del") [] "delete" + (KeyActionST (vpuiSetTool ToolDelete))++ -- Bindings to start dialogs+ , KeyBinding "n" Nothing [] "new function" (KeyActionDG newFunctionDialog)+ , KeyBinding "f" Nothing [] "function" (KeyActionDG showFunctionEntry)+ , KeyBinding "l" Nothing [] "literal" (KeyActionDG showLiteralEntry)++ -- Help and quit++ , KeyBinding "question" (Just "?") [] "help" (KeyActionHQ vpuiKeyHelp)++ -- Shortcuts for menu commands (GTK "accelerators", but not done+ -- in the standard GTK way).+ -- These need to be coordinated with buildMainMenu,+ -- in WindowManagement.hs++-- Oops! Binding Ctrl+F here interferes with binding just plain f above.+-- , KeyBinding "f" (Just "Control-f") [Control] "function-pad"+-- (KeyActionModIO showFunctionPadWindow)++ , KeyBinding "o" (Just "Control-o") [Control] "open"+ (KeyActionModIO menuFileOpen)+ , KeyBinding "s" (Just "Control-s") [Control] "save"+ (KeyActionModIO (\ _cbmgr -> menuFileSave))+ , KeyBinding "q" (Just "Control-q") [Control] "quit" + (KeyActionHQ (\ vpui -> menuFileQuit vpui >> return ()))+ ]++-- | Unused argument needed for key bindings+vpuiKeyHelp :: VPUI -> IO ()+vpuiKeyHelp _vpui = putStrLn keyBindingsHelpText++-- | Help text built from key bindings+keyBindingsHelpText :: String+keyBindingsHelpText = + let add :: String -> KeyBinding -> String+ add result (kb@KeyBinding {kbAltKeyName = mkey}) =+ concat [result, " ", + case mkey of + Nothing -> kbGtkKeyName kb+ Just akey -> akey, + " = ", kbDescription kb, "\n"]+ in foldl add "" keyBindingsList++-- | What to do when a key is pressed+keyPressCallback :: WinId -> CBMgr -> IORef VPUI -> EventM EKey Bool+keyPressCallback winId cbmgr uiref =+ tryEvent $ do+ {+ kname <- eventKeyName+ ; mods <- eventModifier+ -- ; liftIO $ print mods++ ; let giveUp = + -- liftIO (info ("Unrecognized key: " ++ kname)) >> + stopEvent++ ; case Map.lookup kname keyBindingsMap of+ Nothing -> + giveUp+ Just keyBinding -> + if checkMods (kbRequiredModifiers keyBinding) mods+ then liftIO $ + case kbAction keyBinding of+ KeyActionModIO f0 ->+ -- update with IO+ modifyIORefIO (f0 cbmgr) uiref+ KeyActionST f1 ->+ -- update with IO and window ID+ modifyIORefIO (f1 winId) uiref+ KeyActionDG f2 ->+ -- update with IO and cbmgr to set further callbacks+ modifyIORefIO (f2 winId cbmgr) uiref+ KeyActionHQ f3 ->+ -- no update, no cbmgr, no further callbacks+ readIORef uiref >>= f3+ else giveUp+ }++buttonPressCallback :: WinId -> CBMgr -> IORef VPUI -> EventM EButton Bool+buttonPressCallback winId cbmgr uiref =+ tryEvent $ do+ {+ ; (x, y) <- eventCoordinates+ ; mouseButton <- eventButton+ ; mods <- eventModifier+ ; timestamp <- eventTime+ ; let updateAction = + handleButtonPress winId cbmgr mouseButton x y mods timestamp+ ; liftIO (modifyIORefIO updateAction uiref)+ }++mouseMoveCallback :: WinId -> IORef VPUI -> EventM EMotion Bool+mouseMoveCallback winId uiref =+ tryEvent $ do+ {+ (x, y) <- eventCoordinates+ ; mods <- eventModifier+ ; liftIO (modifyIORefIO (handleMouseMove winId x y mods) uiref)+ }++buttonReleaseCallback :: WinId -> IORef VPUI -> EventM EButton Bool+buttonReleaseCallback winId uiref =+ tryEvent $ do+ {+ mouseButton <- eventButton+ ; liftIO (modifyIORefIO (handleButtonRelease winId mouseButton) uiref)+ }++-- | Handle the ButtonPress event. Should be called only for a window+-- with a canvas.+handleButtonPress :: WinId -> CBMgr -> MouseButton + -> Double -> Double -- x, y+ -> [Modifier] -> TimeStamp -- timestamp not needed?+ -> VPUI ->IO VPUI+handleButtonPress winId cbmgr mouseButton x y mods timestamp vpui =+ let vw = vpuiGetWindow vpui winId+ in case vpuiWindowLookupCanvas vw of+ Nothing -> info "handleButtonPress: no canvas found!" >>+ return vpui+ Just canvas ->+ case whichFrame canvas x y of+ Nothing ->+ case vcTool canvas of+ Nothing -> return vpui+ Just tool -> toolOp tool vpui winId TCWorkspace mods x y + Just frame -> + frameButtonPressed winId cbmgr vw+ frame mods (x, y)+ mouseButton timestamp vpui++-- | Handles button pressed in a frame+frameButtonPressed :: WinId -> CBMgr -> VPUIWindow -> CanvFrame + -> [Modifier] -> (Double, Double) -> MouseButton + -> TimeStamp + -> VPUI+ -> IO VPUI+frameButtonPressed winId cbmgr vw frame mods (x, y) mouseButton timestamp vpui =+ let retWrap :: VPUIWindow -> IO VPUI+ retWrap = return . vpuiReplaceWindow vpui winId+ in case mouseButton of+ LeftButton ->+ if cfPointInHeader frame x y + then beginFrameDrag vw frame x y >>= retWrap+ else if cfPointInFooter frame x y+ then leftButtonPressedInFrameFooter vw frame >>= retWrap+ else frameBodyButtonPressed vpui winId frame + mouseButton mods x y+ MiddleButton -> return vpui+ RightButton -> do+ offerContextMenu winId cbmgr frame RightButton timestamp + (vpuiDebugging vpui)+ return vpui+ OtherButton _ -> return vpui++-- | Handles button pressed in the body of a frame+-- frameBodyButtonPressed needs VPUIWindow because it calls a toolOp.+-- mb (mouse button) is unused, but might be used later.+frameBodyButtonPressed :: VPUI -> WinId -> CanvFrame + -> MouseButton -> [Modifier] -> Double -> Double + -> IO VPUI+frameBodyButtonPressed vpui winId frame _mb mods x y = do+ {+ let vw = vpuiGetWindow vpui winId+ canvas = vpuiWindowGetCanvas vw+ mnode = vcanvasNodeAt canvas (Position x y)+ ; case mnode of+ Nothing -> + case vcTool canvas of+ Nothing -> return vpui+ Just tool -> toolOp tool vpui winId (cfContext frame) mods x y+ Just node -> + do+ {+ vw' <- openNode vw node+ ; return $ vpuiReplaceWindow vpui winId vw'+ }+ }++-- | Handles left button pressed in the footer of a frame+leftButtonPressedInFrameFooter ::+ VPUIWindow -> CanvFrame -> IO VPUIWindow+leftButtonPressedInFrameFooter vw frame = + let canvas = vpuiWindowGetCanvas vw+ in case frameType frame of+ CallFrame -> + -- request argument values and evaluate call+ if cfEvalReady frame+ then do+ canvas' <- vcEvalDialog canvas frame+ return $ vpuiWindowSetCanvas vw canvas'+ else return vw+ EditFrame ->+ -- ignore+ return vw++-- | Handles beginning of mouse-drag+beginFrameDrag :: VPUIWindow -> CanvFrame -> Double -> Double + -> IO VPUIWindow+beginFrameDrag vw frame x y = + let canvas = vpuiWindowGetCanvas vw+ window = vpuiWindowWindow vw+ dragging = Dragging {draggingNode = cfFrameNode frame,+ draggingPosition = Position x y}+ canvas' = canvas {vcDragging = Just dragging}+ in setCursor window Fleur >> + (return $ vpuiWindowSetCanvas vw canvas')++-- | Handle mouse move event+handleMouseMove :: WinId -> Double -> Double -> [Modifier] -> VPUI -> IO VPUI+handleMouseMove winId x y mods vpui =+-- Needs to be in IO because of drawWindowInvalidateRect+ let vw = vpuiGetWindow vpui winId+ in case vpuiWindowLookupCanvas vw of+ Nothing -> + info "SQUAWK! No canvas! Shouldn't happen!" >>+ return vpui -- shouldn't happen+ Just canvas -> + do+ {+ -- Highlight the active node, if any+ let active = vcActive canvas+ active' = vcanvasNodeAt canvas (Position x y)++ invalidate :: DrawWindow -> Maybe G.Node -> IO ()+ invalidate win mnode =+ case mnode of+ Nothing -> return ()+ Just node -> + drawWindowInvalidateRect win + (vcanvasNodeRect canvas node) False++ ; when (active /= active') $+ do+ {+ win <- layoutGetDrawWindow (vcLayout canvas)+ ; invalidate win active+ ; invalidate win active'+ }+ -- if dragging, continue drag+ ; canvas' <- continueDrag (canvas {vcActive = active', + vcMousePos = (x, y)}) + mods x y+ ; let vw' = vpuiWindowSetCanvas vw canvas'+ ; return $ vpuiReplaceWindow vpui winId vw'+ }++continueDrag :: VCanvas -> [Modifier] -> Double -> Double -> IO VCanvas+continueDrag canvas mods x y =+ case vcDragging canvas of+ Nothing -> return canvas+ Just dragging -> + let graph = vcGraph canvas+ dnode = draggingNode dragging+ wnode = wlab graph dnode+ Position oldX oldY = draggingPosition dragging+ (dx, dy) = (x - oldX, y - oldY)+ in+ case wnode of+ WSimple _ -> + continueDragSimple canvas dragging dnode mods x y dx dy + WFrame frameNode -> + continueDragFrame canvas dragging frameNode x y dx dy ++continueDragSimple :: VCanvas -> Dragging -> G.Node -> [Modifier] + -> Double -> Double -> Double -> Double -> IO VCanvas+continueDragSimple canvas dragging simpleNode mods x y dx dy =+ let graph = vcGraph canvas+ frame = nodeContainerFrame canvas graph simpleNode+ dragging' = dragging {draggingPosition = Position x y}+ translateSelection = if checkMods [Shift] mods+ then translateTree+ else translateNode+ graph' = translateSelection dx dy graph simpleNode+ canvas' = canvas {vcGraph = graph'}+ in vcInvalidateFrameWithParent canvas graph frame >>+ return (canvas' {vcDragging = Just dragging'})++continueDragFrame :: + VCanvas -> Dragging -> G.Node -> + Double -> Double -> Double -> Double -> IO VCanvas+continueDragFrame canvas dragging frameNode x y dx dy =+ let graph = vcGraph canvas+ frame = vcGetFrame canvas graph frameNode+ frame' = translateFrame frame dx dy+ graph' = grTranslateFrameNodes graph frame dx dy+ canvas' = vcUpdateFrameAndGraph canvas frame' graph'+ dragging' = Just dragging {draggingPosition = Position x y}+ in + -- Tell the GUI about the changes so they will be redrawn+ -- Mark the frame changed so it will be redrawn+ frameChanged canvas graph frame graph' frame' >>+ -- Also, any frames opened from nodes of this frame+ mapM_ (\f -> frameChanged canvas graph f graph' f)+ (vcFrameSubframes canvas frame) >>+ -- Return the modified canvas+ return (canvas' {vcDragging = dragging'})++handleButtonRelease :: WinId -> MouseButton -> VPUI -> IO VPUI+handleButtonRelease winId mouseButton vpui =+ case mouseButton of+ LeftButton -> + -- End drag+ let vw = vpuiGetWindow vpui winId+ canvas = vpuiWindowGetCanvas vw+ window = vpuiWindowWindow vw+ vw' = vpuiWindowSetCanvas vw (canvas {vcDragging = Nothing})+ vpui' = vpuiReplaceWindow vpui winId vw'+ in setCursor window LeftPtr >>+ return vpui'+ _ -> return vpui++-- | Show a context menu for mouse click in a frame.+offerContextMenu :: WinId -> CBMgr -> CanvFrame + -> MouseButton -> TimeStamp -> Bool -> IO ()+offerContextMenu winId cbmgr frame button timestamp debugging = do+ -- Needs CBMgr to specify menu actions.+ {+ let menuSpec = + MenuSpec "Context Menu" + (contextMenuOptions winId cbmgr frame debugging)+ ; menu <- createMenu menuSpec cbmgr+ ; widgetShowAll menu+ ; menuPopup menu (Just (button, timestamp))+ }++-- | Options for context menu that depend on the frame type.++contextMenuOptions :: WinId -> CBMgr -> CanvFrame -> Bool -> [MenuItemSpec]+contextMenuOptions winId cbmgr frame debugging =+ let typeDependentOptions :: [MenuItemSpec]+ typeDependentOptions =+ case frameType frame of+ CallFrame -> + [MenuItem "Edit" (editFrameFunction cbmgr frame)+ , MenuItem "Close" (\ vpui -> closeFrame vpui winId frame)]+ EditFrame -> + [+ -- The next items duplicate parts of keyBindingsList+ MenuItem "CONNECT (c)" (vpuiSetTool ToolConnect winId)+ , MenuItem "DISCONNECT (d)" (vpuiSetTool ToolDisconnect winId)+ , MenuItem "IF (i)" (vpuiSetTool ToolIf winId)+ , MenuItem "FUNCTION (f)" (showFunctionEntry winId cbmgr)+ , MenuItem "LITERAL (l)" (showLiteralEntry winId cbmgr)+ -- , ("CLEAR (not implemented)", clearFrame winId frame)+ , MenuItem "MOVE (m)" (vpuiSetTool ToolMove winId)+ , MenuItem "DELETE (KP-Del)" (vpuiSetTool ToolDelete winId)+ ]+ in typeDependentOptions +++ if debugging+ then [MenuItem "Dump frame (debug)"+ (\ vpui -> dumpFrame vpui winId frame >> return vpui)+ , MenuItem "Dump graph (debug)"+ (\ vpui -> dumpGraph vpui winId >> return vpui)+ ]+ else []
+ lib/Graphics/UI/Sifflet/Workspace.hs view
@@ -0,0 +1,606 @@+{- Currently, this module contains functions for VPUI, VPUIWindow,+Workspace, VCanvas, and more. A reorganization seems called for,+but for now I will just keep adding functions here. -}++module Graphics.UI.Sifflet.Workspace+ (+ -- VPUI and Workspace+ vpuiNew+ , workspaceNewDefault+ , workspaceNewEditing+ , addFedWinButtons+ , defineFunction+ , workspaceId+ , openNode++ -- Quitting:+ , removeWindow+ , vpuiQuit++ -- Windows:+ , forallWindowsIO++ , baseFunctionsRows+ )++where++-- for debugging+-- import System.IO.Unsafe++import Control.Monad+import System.Directory (getCurrentDirectory)++import Data.IORef+import Data.List+import Data.Map ((!), keys)+import qualified Data.Map as Map (empty)+import Data.Maybe++import Data.Graph.Inductive as G hiding (nfilter)++import Data.Sifflet.Functoid+import Data.Sifflet.Geometry+import Data.Sifflet.TreeGraph+import Data.Sifflet.TreeLayout+import Data.Sifflet.WGraph++import Language.Sifflet.Expr+import Language.Sifflet.ExprTree++import Graphics.UI.Sifflet.Callback+import Graphics.UI.Sifflet.Canvas+import Graphics.UI.Sifflet.EditArgsPanel+import Graphics.UI.Sifflet.Frame+import Graphics.UI.Sifflet.GtkUtil++import Graphics.UI.Sifflet.LittleGtk+-- FIX!!+-- import Graphics.UI.Gtk (widgetSizeRequest, windowResize)++import Graphics.UI.Sifflet.Tool+import Graphics.UI.Sifflet.Types++import Language.Sifflet.Util++-- | Create a new VPUI.+-- This used to set up the basic "q to quit" and "on exposed" callbacks,+-- but now does not even do that. +-- The 'init' function argument+-- may perform additional initialization;+-- if there is none, simply use 'return'.++-- The following comment is out of date,+-- but may explain some bizarre features historically:++-- Note that if you want to set up callbacks,+-- there is some trickiness: the vpui contains the workspace,+-- and the layout (which is on the workspace) needs to have callbacks+-- which know the uiref. So, create the workspace, vpui, and uiref,+-- in that order, and then set up the callbacks.+++vpuiNew :: Style -> Env -> Bool -> IO VPUI+vpuiNew style env debugging = do+ dir <- getCurrentDirectory+ return VPUI {vpuiWindows = Map.empty,+ vpuiToolkits = [],+ vpuiCurrentFile = Nothing,+ vpuiInitialDir = dir,+ vpuiCurrentDir = dir,+ vpuiStyle = style,+ vpuiInitialEnv = env,+ vpuiGlobalEnv = env,+ vpuiFileEnv = env,+ vpuiDebugging = debugging+ }++++-- | Create a new "main" workspace window, with a given style.+-- The second argument should set up a menu bar and place it on the vbox, +-- or do nothing if no menu is wanted.+workspaceNewDefault :: Style -> (VBox -> IO ()) -> IO Workspace+workspaceNewDefault style = + workspaceNew style (Size 3600.0 2400.0) (Just (Size 900.0 600.0)) []++workspaceNewEditing :: Style -> Env -> Function -> IO Workspace+workspaceNewEditing style initEnv func = do+ {+ ; let funcFrame = fedFuncFrame style func initEnv -- throw-away+ Size fwidth fheight = bbSize (cfBox funcFrame)+ canvSize = Size (max fwidth 300) (max fheight 300)+ mViewSize = Nothing+ specs = functionArgToolSpecs func+ addNoMenu _ = return () + ; workspaceNew style canvSize mViewSize specs addNoMenu+ }++-- Add the buttons for argument tools, apply, close, etc.,+-- to a function editor window++addFedWinButtons :: CBMgr -> WinId -> VPUI -> IO ()+addFedWinButtons cbmgr winId vpui =+ case vpuiGetWindow vpui winId of+ VPUIWorkWin ws window -> + let bbar = wsButtonBar ws+ argSpecs = wsArgToolSpecs ws+ applyFrame :: VPUI -> IO VPUI+ applyFrame vpui' = + let frames = vcFrames + (vpuiWindowGetCanvas + (vpuiGetWindow vpui' winId))+ in case frames of+ [] -> info "applyFrame: no frame found on canvas" >>+ return vpui'+ _:_:_ -> info ("applyFrame: more than one frame " +++ "found on canvas " +++ show frames) >>+ return vpui'+ [frame] -> defineFunction winId frame vpui'++ editParametersOK :: ArgSpecAction+ editParametersOK newSpecs = + cbmgr (WithUIRef (editParametersOK' newSpecs))+ editParametersOK' newSpecs uiref =+ do+ stripButtonBar+ dressButtonBar newSpecs+ vpui' <- readIORef uiref+ -- Maybe it should update more than just one window+ -- here, in view of issues 36 and 31+ -- VVV+ let vpui'' = vpuiUpdateWindow vpui' + winId + (updateEditWindowArgSpecs newSpecs)+ -- Should it also resize (smaller)+ -- since the panel is being removed?+ writeIORef uiref vpui''+ -- redrawing must be done AFTER writing the IORef above.+ redrawCanvas uiref winId++ editParameters :: VPUI -> IO VPUI+ editParameters vpui' =+ do+ {+ let argSpecs' = vpuiWindowArgSpecs vpui' winId+ ; argPanel <- + makeEditArgsPanel cbmgr argSpecs' editParametersOK+ -- attach it to the Gtk Layout at top left+ ; let canv = wsCanvas ws+ layout = vcLayout canv+ panelRoot = editArgsPanelRoot argPanel+ ; layoutPut layout panelRoot 1 1++ -- Make the layout big enough to see the whole panel+ ; expandToFit layout panelRoot++ ; return vpui'+ }+ addButton :: String -> CBMgrAction -> IO ()+ addButton label action = do+ {+ button <- buttonNewWithLabel label+ ; boxPackEnd bbar button PackNatural 3+ ; widgetShow button+ ; cbmgr (AfterButtonClicked button action)+ }++ dressButtonBar :: [ArgSpec] -> IO ()+ dressButtonBar argSpecs' = do+ {+ mapM_ (addArgToolButton cbmgr winId bbar) argSpecs'+ ; addButton "Close" (\ _uiref -> widgetDestroy window)+ ; addButton "Parameters" (modifyIORefIO editParameters)+ ; addButton "Apply" (modifyIORefIO applyFrame)+ } ++ stripButtonBar :: IO ()+ stripButtonBar = do+ {+ -- the buttons should be the only children+ children <- containerGetChildren bbar+ ; mapM_ widgetDestroy children+ }++ in dressButtonBar argSpecs++ FunctionPadWindow _ _ -> return () -- should not happen++vpuiWindowArgSpecs :: VPUI -> WinId -> [ArgSpec]+vpuiWindowArgSpecs vpui winId =+ case vpuiGetWindow vpui winId of+ VPUIWorkWin ws _ -> wsArgToolSpecs ws+ FunctionPadWindow _ _ -> [] -- should not happen++-- | Update an Edit Function window after the "Inputs" dialog,+-- which might have given it some new ArgSpec's.+-- In the resulting VPUIWindow, no node inlets or inputs than +-- its new arity.++updateEditWindowArgSpecs :: [ArgSpec] -> VPUIWindow -> VPUIWindow+updateEditWindowArgSpecs newSpecs vwin =+ case vwin of + VPUIWorkWin ws0 window ->+ let canv0 = wsCanvas ws0+ graph0 = vcGraph canv0+ argNames = map argName newSpecs+ in case vcFrames canv0 of+ [frame0] ->+ let foid0 = cfFunctoid frame0+ fnodes0 = fpNodes foid0 :: [G.Node]++ -- Filter out symbol nodes of any removed arguments+ validNames = + "if" : (argNames ++ envSymbols (cfEnv frame0))+ validNode' :: G.Node -> Bool+ validNode' = validNode graph0 validNames++ fnodes1 = filter validNode' fnodes0+ foid1 = foid0 {fpNodes = fnodes1,+ fpArgs = argNames} -- redundant args here+ frame1 = frame0 {cfVarNames = argNames, -- and here+ cfFunctoid = foid1}+ graph1 = nfilter validNode' graph0++ -- Eliminate excess inlets and edges + -- due to reduced arity of functional arguments+ style = vcStyle canv0+ graph2 = wLimitOuts style newSpecs graph1+ -- Frame node adopts orphaned nodes so they are+ -- not invisible+ orphans = filter (isWSimple . fromJust . lab graph2)+ (graphOrphans graph2)+ graph3 = + adoptChildren graph2 (cfFrameNode frame1) orphans++ -- plug back into larger structures+ canv1 = canv0 {vcGraph = graph3, vcFrames = [frame1]}+ ws1 = ws0 {wsArgToolSpecs = newSpecs, wsCanvas = canv1}+ in VPUIWorkWin ws1 window+ _ -> vwin -- shouldn't happen+ FunctionPadWindow _ _ -> vwin -- shouldn't happen+++-- | Given a WGraph and a list of valid symbols, a node is valid+-- if it is an ExprNode ... labeled with one of the valid symbols+--+-- (This function is only used above, in updateEditWindowArgSpecs)+validNode :: WGraph -> [String] -> G.Node -> Bool+validNode g validNames n =+ case G.lab g n of+ Nothing -> False+ Just (WFrame _) -> True+ Just (WSimple loNode) ->+ let ENode nodeLabel _ = gnodeValue (nodeGNode loNode)+ in case nodeLabel of+ NSymbol (Symbol name) -> name `elem` validNames+ _ -> True+++-- | Require a node to have <= n inlets in the node+-- and <= n successors in the graph, where+-- n is specified in a list of ArgSpec++wLimitOut :: Style -> [ArgSpec] -> WGraph -> Node -> WGraph+wLimitOut style specs g v =+ let ordered :: Adj WEdge -> Adj WEdge+ ordered = sortBy compareAdj+ compareAdj (WEdge i, _nodei) (WEdge j, _nodej) = compare i j+ in case match v g of+ (Nothing, _) -> g+ (Just (ins, _v, wnode, outs), g') -> + -- wnode is the graph-node's "label"+ case wnode of+ WFrame _ -> g+ WSimple lonode@(LayoutNode {nodeGNode = gnode}) ->+ let ENode eLabel _ = gnodeValue gnode -- :: ExprNode+ in case eLabel of+ NSymbol (Symbol name) ->+ case aspecsLookup name specs of+ Nothing -> g+ Just n -> + let (inlets, _) = + makeIolets style + (gnodeNodeBB gnode)+ (n, 1)+ gnode' = gnode {gnodeInlets = inlets}+ wnode' = + WSimple (lonode {nodeGNode = gnode'})+ in (ins, v, wnode', take n (ordered outs)) & + g'+ _ -> g++-- | Like wLimitOut, but applies to a whole graph+wLimitOuts :: Style -> [ArgSpec] -> WGraph -> WGraph+wLimitOuts style specs g = foldl (wLimitOut style specs) g (nodes g)++-- | Redraw the entire canvas of a given window+redrawCanvas :: IORef VPUI -> WinId -> IO ()+redrawCanvas uiref winId = do+ {+ vpui <- readIORef uiref+ ; let mcanvas = vpuiTryGetWindow vpui winId >>= vpuiWindowLookupCanvas + ; case mcanvas of+ Nothing -> return ()+ Just canvas ->+ case vcFrames canvas of+ [] -> return ()+ frame:_ -> vcInvalidateBox canvas (cfBox frame)+ }++addArgToolButton :: CBMgr -> WinId -> HBox -> ArgSpec -> IO ()+addArgToolButton cbmgr winId buttonBox (ArgSpec label n) = do+ {+ button <- buttonNewWithLabel label+ ; boxPackStart buttonBox button PackNatural 3 -- spacing between buttons+ ; widgetShow button+ ; cbmgr (AfterButtonClicked button + (modifyIORefIO (vpuiSetTool (ToolArg label n) winId)))+ ; return ()+ }+++-- | fedFuncFrame generates a throw-away frame for the sole purplse+-- of obtaining its measurements before initializing the canvas++fedFuncFrame :: Style -> Function -> Env -> CanvFrame+fedFuncFrame style func prevEnv = + fst (frameNewWithLayout style (Position 0 0) 0 + (FunctoidFunc func) Nothing+ CallFrame -- mode may change below+ 0 prevEnv Nothing)++-- | If mViewSize is Nothing, no scrollbars are put on the canvas,+-- and its display size request is its natural size.+-- If mViewSize = Just viewSize, then scrollbars are wrapped around+-- the canvas, and its displayed size request is viewSize.+-- addMenuBar is an action which, if desired, adds a menu bar;+-- if you don't want one, just pass (\ _ -> return ()).++workspaceNew :: Style -> Size -> Maybe Size -> [ArgSpec]+ -> (VBox -> IO ()) + -> IO Workspace+workspaceNew style canvSize mViewSize argSpecs addMenuBar = do+ {+ ; let Size dcWidth dcHeight = canvSize -- Double, Double+ (icWidth, icHeight) = (round dcWidth, round dcHeight)++ scrolled :: GtkLayout -> Size -> IO ScrolledWindow+ scrolled layout viewSize = do+ {+ let Size dvWidth dvHeight = viewSize -- Double, Double+ (iViewWidth, iViewHeight) = (round dvWidth, round dvHeight)+ -- Wrap layout directly in a ScrolledWindow .+ -- Adjustments: value lower upper stepIncr pageIncr pageSize+ ; xAdj <- adjustmentNew 0.0 0.0 dcWidth 10.0 dvWidth dvWidth+ ; yAdj <- adjustmentNew 0.0 0.0 dcHeight 10.0 dvHeight dvHeight+ ; scrollWin <- scrolledWindowNew (Just xAdj) (Just yAdj)+ -- show scrollbars? (never, always, or if needed)+ ; scrolledWindowSetPolicy scrollWin PolicyAutomatic PolicyAutomatic+ -- request view size for _layout_+ ; widgetSetSizeRequest layout iViewWidth iViewHeight+ ; set scrollWin [containerChild := layout]+ ; return scrollWin+ }++ bare :: GtkLayout -> IO GtkLayout+ bare layout = do+ {+ -- request canvas size for _layout_+ ; widgetSetSizeRequest layout icWidth icHeight -- new+ ; return layout+ }++ -- The canvas itself+ ; vcanvas <- vcanvasNew style dcWidth dcHeight+ ; let layout = vcLayout vcanvas+ -- Set the actual size of the canvas layout, which may be more+ -- than is displayed if scrollbars are used+ ; layoutSetSize layout icWidth icHeight++ -- An empty HBox for buttons (or it may remain empty)+ ; buttonBar <- hBoxNew False 3++ -- The Statusbar+ ; statusBar <- statusbarNew+ + -- All together in a VBox+ ; vbox <- vBoxNew False 0 -- not equal space allotments, 0 spacing++ ; addMenuBar vbox++ ; let packGrow :: WidgetClass w => w -> IO ()+ packGrow w = boxPackStart vbox w PackGrow 0+ ; case mViewSize of+ Nothing -> bare layout >>= packGrow+ Just viewSize -> scrolled layout viewSize >>= packGrow++ ; boxPackStart vbox buttonBar PackNatural 0+ ; boxPackStart vbox statusBar PackNatural 0+ ; return (Workspace vbox vcanvas buttonBar statusBar argSpecs)+}+++vpuiQuit :: VPUI -> IO VPUI+vpuiQuit vpui = do+ {+ -- This should also check for unsaved changes? ***+ vpui' <- foldM (\ vp winId -> removeWindow vp True winId)+ vpui+ (vpuiAllWindowKeys vpui)+ ; mainQuit+ ; return vpui'+ }++-- | List of all window ids of the vpui, ++vpuiAllWindowKeys :: VPUI -> [WinId]+vpuiAllWindowKeys = keys . vpuiWindows++-- | Perform action on all windows+-- (actually (WinId, VPUIWindow) pairs.+-- Returns updated VPUI (in case any windows are changed).++forallWindowsIO :: (VPUIWindow -> IO VPUIWindow) -> VPUI -> IO VPUI+forallWindowsIO action vpui = + let loop ks vpui' =+ case ks of+ [] -> return vpui'+ k : ks' -> + let w = vpuiGetWindow vpui' k+ in do + {+ w' <- action w+ ; loop ks' (vpuiReplaceWindow vpui' k w')+ }+ in loop (vpuiAllWindowKeys vpui) vpui+++-- | This function is called either when a window *has been* destroyed,+-- with destroy = False,+-- or when you *want to* destroy a window, with destroy = True.++-- WOULD BE BETTER to have two functions, windowRemoved and removeWindow???++-- | removeWindow actually *closes* the window if destroy = True,+-- as well as removing it from the vpui's windows map.+removeWindow :: VPUI -> Bool -> WinId -> IO VPUI+removeWindow vpui destroy winId = do+ {+ -- Remove the window from vpui;+ -- if destroy is true, also destroy it.+ -- It is an error if the window id does not exist.+ let vwMap = vpuiWindows vpui+ ; when destroy $ widgetDestroy (vpuiWindowWindow (vwMap ! winId))+ ; return $ vpuiRemoveVPUIWindow winId vpui+ }++-- | Context menu command to apply the function definition+-- of an EditFrame.++-- | "Execute" the definition currently represented in the frame,+-- i.e., bind the function name in the global environment+-- to the function definition found in the frame.++defineFunction :: WinId -> CanvFrame -> VPUI -> IO VPUI+defineFunction winId frame vpui = + case frameType frame of+ CallFrame ->+ showErrorMessage "Software error\nNot in an edit frame!"+ >> return vpui+ EditFrame ->+ case cfFunctoid frame of+ FunctoidFunc _function ->+ return vpui+ fparts@FunctoidParts {} ->+ let env = vpuiGlobalEnv vpui+ vw = vpuiGetWindow vpui winId+ canv = vpuiWindowGetCanvas vw+ graph = vcGraph canv+ frameNode = cfFrameNode frame+ friendlyTypeError msg =+ "Sifflet cannot find any set of " +++ "data types that will make this function work.\n" +++ "Details from the type checker (may be obscure):\n" +++ msg+ in case functoidToFunction fparts graph frameNode env of+ Fail errmsg -> + showErrorMessage (friendlyTypeError errmsg) >>+ return vpui+ Succ function ->+ let BBox x y _ _ = cfBox frame+ z = cfLevel frame+ fname = functionName function+ env' = envSet env fname (VFun function)+ vpui' = vpui {vpuiGlobalEnv = env'}+ in do + {+ ; canv' <- vcCloseFrame canv frame+ -- can this use vpuiAddFrame? ***+ ; canv'' <- + vcAddFrame canv' (FunctoidFunc function) + Nothing + EditFrame+ env' x y z Nothing+ ; let vw' = vpuiWindowSetCanvas vw canv''+ vpui'' = vpuiReplaceWindow vpui' winId vw'+ ; vpuiUpdateCallFrames vpui'' fname+ }++workspaceId :: String+workspaceId = "Sifflet Workspace"++-- | In the workspace window, update each frame calling the named function +-- to reflect the current function definition+vpuiUpdateCallFrames :: VPUI -> String -> IO VPUI+vpuiUpdateCallFrames vpui fname = + case vpuiTryGetWindow vpui workspaceId of+ Nothing -> return vpui+ Just w -> do+ {+ ; let canvas = vpuiWindowGetCanvas w+ env = vpuiGlobalEnv vpui+ frames = callFrames canvas fname+ update canv frame = canvasUpdateCallFrame canv frame fname env+ ; canvas' <- foldM update canvas frames + ; let w' = vpuiWindowSetCanvas w canvas'+ ; return $ vpuiReplaceWindow vpui workspaceId w'+ }++-- | In the canvas, update a call frame with the current function+-- definition from the environment, returning a new canvas.+-- Root call frames are torn down and rebuilt with the new function definition.+-- Call frames that are called by other call frames are simply torn down.+canvasUpdateCallFrame :: VCanvas -> CanvFrame -> String -> Env -> IO VCanvas+canvasUpdateCallFrame canvas frame fname env = do+ {+ -- Tear down old frame+ canvas' <- vcCloseFrame canvas frame+ ; case cfParent frame of+ Nothing -> + -- root frame; build up new frame+ let Position x y = bbPosition (cfBox frame)+ z = cfLevel frame+ functoid = FunctoidFunc {fpFunc = envGetFunction env fname}+ in vcAddFrame canvas' functoid Nothing CallFrame env x y z Nothing+ Just _ -> + -- frame with a parent; finished+ return canvas'+ }++openNode :: VPUIWindow -> G.Node -> IO VPUIWindow+openNode vw node = do+ let canvas = vpuiWindowGetCanvas vw+ graph = vcGraph canvas+ if not (nodeIsSimple graph node)+ then return vw -- WFrame node -- is this possible?+ else if nodeIsOpen graph node+ then info "Already open" >> return vw+ else let frame = nodeContainerFrame canvas graph node+ in case nodeCompoundFunction graph frame node of+ Nothing -> + info "Cannot be opened" >> return vw+ Just function ->+ case nodeInputValues graph node of+ EvalOk (VList values) ->+ let env = extendEnv (functionArgNames function)+ values (cfEnv frame)+ Position x y = + frameOffset (vcStyle canvas) frame+ z = succ (cfLevel frame)+ in vwAddFrame vw + (FunctoidFunc function) + (Just values) CallFrame+ env x y z (Just node)+ EvalOk x ->+ errcats ["openNode: non-VList result:", show x]+ _ -> + info "Cannot be opened: lacking input values" >>+ return vw++baseFunctionsRows :: [[String]]+baseFunctionsRows = [["+", "-", "*", "div", "mod", "add1", "sub1", "/"],+ ["==", "/=", "<", ">", "<=", ">="],+ ["zero?", "positive?", "negative?"],+ ["null", "head", "tail", ":"]]
+ lib/Language/Sifflet/Examples.hs view
@@ -0,0 +1,277 @@+module Language.Sifflet.Examples + (exampleFunctions+ , exampleFunctionNames+ , exampleEnv + , foo, eFoo -- used in Testing.Unit.ExprTests+ , eMax -- ditto+ , eFact -- ditto+ , getExampleFunction+ )++where++import Language.Sifflet.Expr++-- TEST COMPOUND FUNCTIONS++-- | grossProfit salesA salesB = 0.12 salesA + 0.25 salesB++grossProfit :: Function+grossProfit = + Function (Just "grossProfit") [typeNum, typeNum] typeNum+ (Compound ["salesA", "salesB"]+ (eCall "+" [eCall "*" [eFloat 0.12, eSymbol "salesA"],+ eCall "*" [eFloat 0.25, eSymbol "salesB"]]))++-- | bonus1 profit = if profit > 100000 +-- then 1000 + 0.0012 * profit+-- else 0+bonus1 :: Function+bonus1 =+ Function (Just "bonus1") [typeNum] typeNum+ (Compound ["profit"]+ (eIf (eCall ">" [eSymbol "profit", eInt 100000])+ (eCall "+" [eInt 1000,+ eCall "*" [eFloat 0.0012, eSymbol "profit"]])+ (eInt 0)))++-- | bonus2 salesA salesB = bonus1 (grossProfit salesA salesB)+bonus2 :: Function+bonus2 =+ Function (Just "bonus2") [typeNum, typeNum] typeNum+ (Compound ["salesA", "salesB"]+ (eCall "bonus1" [eCall "grossProfit" [eSymbol "salesA",+ eSymbol "salesB"]]))++-- | foo a b = 2 * a + b+foo :: Function+foo = Function (Just "foo") [typeNum, typeNum] typeNum+ (Compound ["a", "b"]+ (eCall "+" [eCall "*" [eInt 2, eSymbol "a"],+ eSymbol "b"])+ )++-- | An expression representing a call to foo+eFoo :: Expr -> Expr -> Expr+eFoo e1 e2 = eCall "foo" [e1, e2]++-- | max x y = if x > y then x else y+max :: Function+max = let ex = eSymbol "x"+ ey = eSymbol "y"+ in Function (Just "max") [typeNum, typeNum] typeNum+ (Compound ["x", "y"] (eIf (eGt ex ey) ex ey))++-- | An expression representing a call to max+eMax :: Expr -> Expr -> Expr+eMax e1 e2 = eCall "max" [e1, e2]++-- | fact n = if n == 0 then 1 else n * (fact (n - 1))+fact :: Function+fact = let en = eSymbol "n" in+ Function (Just "fact") [typeNum] typeNum+ (Compound ["n"] + (eIf (eZerop en) + (eInt 1)+ (eTimes en (eFact (eSub1 en)))))++-- | An expression representing a call to fact+eFact :: Expr -> Expr+eFact e1 = eCall "fact" [e1]++-- | sum of the integers 0..n+-- Lewis and Loftus, Jave Software Solutions, 6th. ed. (they call it "sum")+sumFromZero :: Function+sumFromZero = let en = eSymbol "n" in+ Function (Just "sumFromZero") [typeNum] typeNum+ (Compound ["n"]+ (eIf (eZerop en)+ (eInt 0)+ (ePlus en (eSumFromZero (eSub1 en)))))++buggySumFromZero :: Function+buggySumFromZero = + let body = ePlus (eSym "n")+ (eCall "buggySumFromZero"+ [eMinus (eSym "n") (eInt 1)])+ in Function (Just "buggySumFromZero") [typeNum] typeNum + (Compound ["n"] body)++eFib1 :: Expr -> Expr+eFib1 en = eCall "fib1" [en]++fib1 :: Function+fib1 = let en = eSymbol "n"+ one = eInt 1+ two = eInt 2+ in Function (Just "fib1") [typeNum] typeNum+ (Compound ["n"]+ (eIf (eEq en one)+ one+ (eIf (eEq en two)+ one+ (ePlus (eFib1 (eMinus en two))+ (eFib1 (eMinus en one))))))++-- implying that there should be fib2 ...++eSumFromZero :: Expr -> Expr+eSumFromZero en = eCall "sumFromZero" [en]++-- | rmul: multiplication by repeated addition.+-- The "multiply" function in Hanly and Koffman,+-- "Problem Solving and Program Design in C", 5th ed.++rmul :: Function+rmul = let em = eSymbol "m"+ en = eSymbol "n"+ in Function (Just "rmul") [typeNum, typeNum] typeNum+ (Compound ["m", "n"]+ (eIf (eZerop en)+ (eInt 0)+ (ePlus em (eRmul em (eSub1 en)))))++-- | An expression representing a call to rmul+eRmul :: Expr -> Expr -> Expr+eRmul em en = eCall "rmul" [em, en]++eGcd :: Expr -> Expr -> Expr+eGcd em en = eCall "gcd" [em, en]++gcd :: Function+gcd = let em = eSymbol "m"+ en = eSymbol "n"+ in Function (Just "gcd") [typeNum, typeNum] typeNum+ (Compound ["m", "n"]+ (eIf (eZerop (eMod em en))+ en+ (eGcd en (eMod em en))))+++-- | Even and odd, the slow way.+-- Springer and Friedman, Scheme and the Art of Programming (??).+-- Rubio-Sanchez, Urquiza-Fuentes, and Pareja-Flores,+-- "A Gentle Introduction to Mutual Recursion",+-- in ITiCSE 2008: The 13th SIGCSE Conference on Innovation and+-- Technology in Computer Science Education, 2008.++eEvenp, eOddp :: Expr -> Expr+eEvenp en = eCall "even?" [en]+eOddp en = eCall "odd?" [en]++evenp, oddp :: Function++evenp = let en = eSymbol "n"+ in Function (Just "even?") [typeNum] typeBool+ (Compound ["n"]+ (eIf (eZerop en)+ eTrue+ (eOddp (eSub1 en))))++oddp = let en = eSymbol "n"+ in Function (Just "odd?") [typeNum] typeBool+ (Compound ["n"]+ (eIf (eZerop en)+ eFalse+ (eEvenp (eSub1 en))))++-- | Fibonacci series through mutual recursion.+-- Rubio-Sanchez, Urquiza-Fuentes, and Pareja-Flores, "Gentle Introduction"++eRabbitBabies, eRabbitAdults :: Expr -> Expr+eRabbitBabies en = eCall "rabbitBabies" [en]+eRabbitAdults en = eCall "rabbitAdults" [en]++rabbitTotal, rabbitAdults, rabbitBabies :: Function++rabbitTotal = let m = eSymbol "month"+ in Function (Just "rabbitTotal") [typeNum] typeNum+ (Compound ["month"]+ (ePlus (eRabbitBabies m) (eRabbitAdults m)))++rabbitAdults = let m = eSymbol "month"+ zero = eInt 0+ one = eInt 1+ in Function (Just "rabbitAdults") [typeNum] typeNum + (Compound ["month"]+ (eIf (eEq m one)+ zero+ (ePlus+ (eRabbitAdults (eSub1 m)) -- all adults survive+ (eRabbitBabies (eSub1 m))))) -- all babies grow up++rabbitBabies = let m = eSymbol "month" + one = eInt 1+ in Function (Just "rabbitBabies") [typeNum] typeNum + (Compound ["month"]+ (eIf (eEq m one)+ one+ (eRabbitAdults (eSub1 m)))) -- all adults reproduce+ +buggyLength :: Function+buggyLength = let xs = eSymbol "xs"+ one = eInt 1+ in Function (Just "buggyLength") + [typeList (TypeVar "e1")] typeNum+ (Compound ["xs"]+ (eIf (eCall "null" [xs])+ one -- base case off by one, should be zero+ (ePlus one + (eCall "buggyLength"+ [eCall "tail" [xs]]))))++listLength :: Function+listLength = let xs = eSymbol "xs"+ one = eInt 1+ zero = eInt 0+ in Function (Just "length") + [typeList (TypeVar "e1")] typeNum+ (Compound ["xs"]+ (eIf (eCall "null" [xs])+ zero+ (ePlus one + (eCall "length"+ [eCall "tail" [xs]]))))++listSum :: Function+listSum = + Function (Just "sum") [typeList typeNum] typeNum + (Compound ["xs"] sumbody)++sumbody :: Expr+sumbody = + eIf (eCall "null" [eSym "xs"])+ (eInt 0)+ (ePlus (eCall "head" [eSym "xs"])+ (eCall "sum" [eCall "tail" [eSym "xs"]]))++buggySum :: Function+buggySum = let xs = eSymbol "xs"+ in Function (Just "buggySum")+ [typeList typeNum] typeNum+ (Compound ["xs"]+ -- missing "if" and base case+ (ePlus (eCall "head" [xs])+ (eCall "buggySum" [eCall "tail" [xs]])))++exampleFunctions :: [Function]+exampleFunctions = [grossProfit, bonus1, bonus2+ , foo, Language.Sifflet.Examples.max+ , fact, sumFromZero, rmul, fib1+ , Language.Sifflet.Examples.gcd, evenp, oddp+ , rabbitBabies, rabbitAdults, rabbitTotal+ , buggyLength, listLength, listSum, buggySum+ , buggySumFromZero]++exampleFunctionNames :: [String]+exampleFunctionNames = map functionName exampleFunctions++exampleEnv :: Env+exampleEnv = + envInsertL baseEnv exampleFunctionNames (map VFun exampleFunctions)++-- | This function will be in error if the function name is not+-- found in exampleEnv.+getExampleFunction :: String -> Function+getExampleFunction = envGetFunction exampleEnv+
+ lib/Language/Sifflet/Export/Exporter.hs view
@@ -0,0 +1,191 @@+module Language.Sifflet.Export.Exporter + (Exporter+ , simplifyExpr+ , commonRuleHigherPrec+ , commonRuleAtomic+ , commonRuleLeftToRight+ , commonRuleAssocRight+ , commonRuleFuncOp+ , commonRulesForSimplifyingExprs+ , ruleIfRight+ , ruleRightToLeft+ , applyFirstMatch+ , findFixed+ ) ++where++import Language.Sifflet.Expr++-- | The type of a function to export (user) functions to a file.+type Exporter = Functions -> FilePath -> IO ()++-- | Simplify an expression by applying rules +-- top-down throughout the expression+-- tree and repeatedly until there is no change.+-- This is intended for removing extra parentheses,+-- but could be used for other forms of simplification.+-- +-- Should each rule also know the level in the original expr tree,+-- with 0 = top level (root)?+-- That would require additional arguments.++simplifyExpr :: [Expr -> Expr] -> Expr -> Expr+simplifyExpr rules expr = + findFixed (topDown (applyFirstMatch rules)) expr++-- | Repeatedly apply a function to an object until there is no change,+-- that is, until reaching a fixed point of the function, a point +-- where f x == x.++findFixed :: (Eq a) => (a -> a) -> a -> a+findFixed f x =+ let x' = f x+ in if x' == x then x else findFixed f x'+++-- | Common rules for simplifying parentheses.++-- | Remove ()'s around a higher precedence operator: e.g., +-- (a * b) + c ==> a * b + c+-- a + (b * c) ==> a + b * c++commonRuleHigherPrec :: Expr -> Expr+commonRuleHigherPrec e =+ case e of+ EOp op1 (EGroup (EOp op2 subleft subright)) right ->+ -- left side+ if opPrec op2 > opPrec op1+ then EOp op1 (EOp op2 subleft subright) right+ else e+ EOp op1 left (EGroup (EOp op2 subleft subright)) ->+ -- right side+ if opPrec op2 > opPrec op1+ then EOp op1 left (EOp op2 subleft subright)+ else e+ _ -> e++-- | Remove ()'s around an atomic expression -- a variable,+-- literal, or list++commonRuleAtomic :: Expr -> Expr+commonRuleAtomic e =+ case e of+ EGroup e' ->+ if exprIsAtomic e' + then e'+ else e+ _ -> e++-- | Remove ()'s in the case of (a op1 b) op2 c,+-- if op1 and op2 have the same precedence, and+-- both group left to right, since+-- left to right evaluation makes them unnecessary.++commonRuleLeftToRight :: Expr -> Expr+commonRuleLeftToRight e =+ case e of+ EOp op2 (EGroup (EOp op1 a b)) c ->+ if opPrec op1 == opPrec op2 && + opGrouping op1 == GroupLtoR &&+ opGrouping op2 == GroupLtoR+ then EOp op2 (EOp op1 a b) c+ else e+ _ -> e++-- | Remove ()'s in the case of a op (b op c)+-- if op groups right to left, and note that+-- it is the same operator op in both places+-- (though I don't know if that restriction is necessary).+-- This applies to (:) in Haskell, for example:+-- x : y : zs == x : (y : zs)++ruleRightToLeft :: Expr -> Expr+ruleRightToLeft e =+ case e of+ EOp op1 a (EGroup (EOp op2 b c)) ->+ if op1 == op2 && opGrouping op1 == GroupRtoL+ then EOp op1 a (EOp op2 b c)+ else e+ _ -> e++-- Associativity on the right+-- x + (y + z) --> x + y + z+-- for + and all other associative operators.+-- We could add, the left-hand rule+-- (x + y) + z --> x + y + z+-- but do not need it,+-- because it is already covered by the left to right rule+-- for operators of equal precedence.+-- It must be the SAME operator on both sides, of course!++commonRuleAssocRight :: Expr -> Expr+commonRuleAssocRight e =+ case e of+ EOp op1 a (EGroup (EOp op2 b c)) -> + if op1 == op2 && opAssoc op1+ then EOp op1 a (EOp op2 b c)+ else e+ _ -> e++-- An if expression as the right operand can be unparenthesized.+-- but not so on the left (at least in Haskell):+-- x + (if ...) --> x + if ...+-- but NOT+-- (if ...) + x --> if ... + x (NOT!)++ruleIfRight :: Expr -> Expr+ruleIfRight e =+ case e of+ EOp op a (EGroup i@(EIf _ _ _)) -> EOp op a i+ _ -> e++-- In Haskell, a function application has precedence over all+-- operators. This applies in both the left and right operands.++commonRuleFuncOp :: Expr -> Expr+commonRuleFuncOp e =+ case e of+ EOp op a (EGroup c@(ECall _ _)) -> EOp op a c+ EOp op (EGroup c@(ECall _ _)) b -> EOp op c b+ _ -> e++-- | A list of common rules for simplifying expressions.+-- Does *not* include ruleIfRight, since that works+-- for Haskell but not Python.++commonRulesForSimplifyingExprs :: [Expr -> Expr]+commonRulesForSimplifyingExprs =+ [commonRuleHigherPrec+ , commonRuleAtomic+ , commonRuleLeftToRight+ , commonRuleAssocRight+ , commonRuleFuncOp]++-- | Try the first rule in a list to see if it changes an expression,+-- returning the new expression if it does; otherwise, try the next rule,+-- and so on; if no rule changes the expression, then return the expression.+-- (Note that (applyFirstMatch rules) is itself a rule.)++applyFirstMatch :: [Expr -> Expr] -> Expr -> Expr+applyFirstMatch [] e = e+applyFirstMatch (r:rs) e = + let e' = r e+ in if e' /= e+ then e'+ else applyFirstMatch rs e++-- | Apply a rule top-down to all levels of an expression.+-- Normally, the "rule" would be a value of (applyFirstMatch rules).+topDown :: (Expr -> Expr) -> Expr -> Expr+topDown f e =+ let tdf = topDown f+ e' = f e+ in case e' of+ EIf c a b -> EIf (tdf c) (tdf a) (tdf b)+ EList xs -> EList (map tdf xs)+ ELambda x body -> ELambda x (tdf body)+ ECall fsym args -> ECall fsym (map tdf args)+ EOp op left right -> EOp op (tdf left) (tdf right)+ EGroup e'' -> EGroup (tdf e'')+ _ -> e'
+ lib/Language/Sifflet/Export/Haskell.hs view
@@ -0,0 +1,159 @@+-- | Abstract syntax tree and pretty-printing for Haskell 98.+-- This is only a small subset of the Haskell 98 syntax,+-- so we do not need to pull in haskell-src and all its complexity.+-- Moreover, haskell-src gives too little control over the format+-- of pretty-printed text output.++module Language.Sifflet.Export.Haskell+ (HsPretty(..)+ , Module(..)+ , ExportSpec(..)+ , ImportDecl(..)+ , Decl(..)+ , operatorTable+ )++where++import Data.List (intercalate)+import qualified Data.Map as M++import Language.Sifflet.Expr+import Text.Sifflet.Pretty++class HsPretty a where++ hsPretty :: a -> String++ hsPrettyList :: String -> String -> String -> [a] -> String+ hsPrettyList pre tween post xs =+ pre ++ intercalate tween (map hsPretty xs) ++ post++instance HsPretty Symbol where+ hsPretty = pretty++instance HsPretty Operator where+ hsPretty = pretty++-- | A Haskell module; moduleDecls are functions and variables.++data Module = Module {moduleName :: String+ , moduleExports :: Maybe ExportSpec+ , moduleImports :: ImportDecl+ , moduleDecls :: [Decl]+ }+ deriving (Eq, Show)++instance HsPretty Module where+ hsPretty m = + let pmod = "module " ++ moduleName m+ pexports = case moduleExports m of+ Nothing -> ""+ Just exports -> hsPretty exports+ pimports = hsPretty (moduleImports m)+ pdecls = sepLines2 (map hsPretty (moduleDecls m))+ in unlines [pmod ++ " where",+ pexports,+ pimports,+ pdecls]++-- | A Haskell module's export spec: a list of function and +-- variable identifiers+newtype ExportSpec = ExportSpec [String]+ deriving (Eq, Show)++instance HsPretty ExportSpec where+ hsPretty (ExportSpec exports) = + "(" ++ sepCommaSp exports ++ ")"++-- | A Haskell modules import decls: a list of module identifiers.+-- No support for "qualified" or "as" or for selecting only some+-- identifiers from the imported modules.++newtype ImportDecl = ImportDecl [String]+ deriving (Eq, Show)++instance HsPretty ImportDecl where+ hsPretty (ImportDecl modnames) = + let idecl modname = "import " ++ modname+ in unlines (map idecl modnames)++-- | Wrap a string in parentheses+par :: String -> String+par s = "(" ++ s ++ ")"++-- | A Haskell function or variable declaration.+-- An explicit type declaration is optional.+-- Thus we have just enough for +-- name :: type+-- name [args] = expr.+-- Of course [args] would be empty if it's just a variable.+data Decl = Decl {declIdent :: String+ , declType :: Maybe [String]+ , declParams :: [String]+ , declExpr :: Expr+ }+ deriving (Eq, Show)++instance HsPretty Decl where+ hsPretty decl =+ let ptypeDecl = "" -- to be improved **+ pparams = case declParams decl of+ [] -> ""+ params -> " " ++ sepSpace params+ pbody = hsPretty (declExpr decl)+ in ptypeDecl ++ + declIdent decl ++ pparams ++ " =\n" +++ " " ++ pbody++-- | HsPretty expressions. This is going to be like in Python.hs.+instance HsPretty Expr where+ hsPretty pexpr =+ case pexpr of+ EUndefined -> "undefined"+ EChar c -> show c+ ENumber n -> show n+ EBool b -> show b+ EString s -> show s+ ESymbol sym -> hsPretty sym+ EList xs -> hsPrettyList "[" ", " "]" xs+ EIf c a b -> + unwords ["if", hsPretty c, "then", hsPretty a, "else", hsPretty b]+ EGroup e -> par (hsPretty e)+ ELambda (Symbol x) body ->+ unwords ["\\", x, "->", hsPretty body]+ EApp fexpr argexpr ->+ hsPretty fexpr ++ " " ++ hsPretty argexpr+ ECall fexpr argExprs -> + hsPretty fexpr ++ " " ++ hsPrettyList "" " " "" argExprs+ EOp op left right -> + unwords [hsPretty left, hsPretty op, hsPretty right]++-- | The Haskell operators.+-- Now what about the associativity of (:)?+-- It really doesn't even make sense to ask if (:) is+-- associative in the usual sense, +-- since (x1 : x2) : xs == x1 : (x2 : xs)+-- is not only untrue, but the left-hand side is+-- a type error, except maybe in some very special cases+-- (and then the right-hand side would probably be a type error).+-- Is (:) what is called a "right-associative" operator?+-- And do I need to expand my Operator type to+-- include this? And then what about (-) and (/)???+-- Does this affect their relationship with (+) and (-)?++operatorTable :: M.Map String Operator+operatorTable = + M.fromList (map (\ op -> (opName op, op)) + [ Operator "*" 7 True GroupLtoR -- times+ , Operator "+" 6 True GroupLtoR -- plus+ , Operator "-" 6 False GroupLtoR -- minus+ , Operator ":" 5 False GroupRtoL -- cons+ , Operator "==" 4 False GroupNone -- eq+ , Operator "/=" 4 False GroupNone -- ne+ , Operator ">" 4 False GroupNone -- gt+ , Operator ">=" 4 False GroupNone -- ge+ , Operator "<" 4 False GroupNone -- lt+ , Operator "<=" 4 False GroupNone -- le+ ])+
+ lib/Language/Sifflet/Export/Python.hs view
@@ -0,0 +1,198 @@+-- | Abstract syntax tree and pretty-printing for Python.+-- Works for Python 2 and 3.+-- A lot of the data structures are inspired by the language-python package;+-- I have chosen not to have language-python as a dependency of sifflet-lib,+-- however, because it would be overkill and still allows to little control+-- over pretty-printing of Python expressionsw.++module Language.Sifflet.Export.Python+ (PyPretty(..)+ , PModule(..)+ , PStatement(..)+ , alterParens+ , ret+ , condS+ , var+ , ident+ , char+ , fun+ , operatorTable+ )++where++import Data.List (intercalate)+import qualified Data.Map as M++import Language.Sifflet.Expr+import Text.Sifflet.Pretty++class PyPretty a where++ pyPretty :: a -> String++ pyPrettyList :: String -> String -> String -> [a] -> String+ pyPrettyList pre tween post xs =+ pre ++ intercalate tween (map pyPretty xs) ++ post++pyPrettyParens :: (PyPretty a) => [a] -> String+pyPrettyParens = pyPrettyList "(" ", " ")"++instance PyPretty Symbol where+ pyPretty = pretty++instance PyPretty Operator where+ pyPretty = pretty++-- | Python module -- essentially a list of statements;+-- should it also have a name?+newtype PModule = PModule [PStatement]+ deriving (Eq, Show)++instance PyPretty PModule where+ pyPretty (PModule ss) = sepLines2 (map pyPretty ss)++-- | Python statement+data PStatement = PReturn Expr+ | PImport String -- ^ import statement+ | PCondS Expr + PStatement + PStatement -- ^ if condition action alt-action+ | PFun Symbol + [Symbol]+ PStatement -- ^ function name, formal parameters, body+ deriving (Eq, Show)++instance PyPretty PStatement where+ pyPretty s =+ case s of+ PReturn e -> "return " ++ pyPretty e+ PImport modName -> "import " ++ modName+ PCondS c a b ->+ sepLines ["if " ++ pyPretty c ++ ":",+ indentLine 4 (pyPretty a),+ "else:",+ indentLine 4 (pyPretty b)]+ PFun fid params body ->+ sepLines ["def " ++ pyPretty fid ++ + pyPrettyParens params ++ ":",+ indentLine 4 (pyPretty body)]++-- | Expr as an instance of PyPretty.+-- This instance is only for Exprs as Python exprs,+-- for export to Python! It will conflict with the+-- one in ToHaskell.hs (or Haskell.hs).+--+-- The EOp case needs work to deal with precedences+-- and avoid unnecessary parens.+-- Note that this instance declaration is for *Python* Exprs.+-- Haskell Exprs of course should not be pretty-printed+-- the same way!+instance PyPretty Expr where+ pyPretty pexpr =+ case pexpr of+ EUndefined -> "undefined"+ EChar _ -> error ("Python pyPretty of Expr: " +++ "EChar should have been converted to " +++ "EString")+ EList _ -> error ("Python pyPretty of Expr: " +++ "EList should have been converted to " +++ "ECall li ...")+ EIf c a b -> + unwords [pyPretty a, "if", pyPretty c, "else", pyPretty b]+ EGroup e -> pyPrettyParens [e]+ ESymbol vid -> pyPretty vid+ ENumber n -> show n+ EBool b -> show b+ EString s -> show s+ ELambda (Symbol x) body -> + unwords ["lambda", show x, ":", pyPretty body]+ EApp fexpr argExpr ->+ concat [pyPretty fexpr, pyPrettyParens [argExpr]]+ ECall fexpr argExprs -> + concat [pyPretty fexpr, pyPrettyParens argExprs]+ EOp op left right -> + unwords [pyPretty left, pyPretty op, pyPretty right]++alterParens :: (Expr -> Expr) -> PStatement -> PStatement+alterParens t s =+ case s of+ PReturn e -> PReturn (t e)+ PCondS c a b -> PCondS (t c) (alterParens t a) (alterParens t b)+ PFun fid params b -> PFun fid params (alterParens t b)+ _ -> s+++-- | Python return statement+ret :: Expr -> PStatement+ret pexpr = PReturn pexpr++-- | Python if STATEMENT++-- This is the if STATEMENT:+-- if c:+-- a+-- else:+-- b+--+-- But do I need this at all?++condS :: Expr -> Expr -> Expr -> PStatement+condS c a b = PCondS c (ret a) (ret b)++-- PExpr smart constructors++-- | Python variable+var :: String -> Expr+var name = ESymbol (Symbol name)++-- | Python identifier+ident :: String -> Symbol+ident s = Symbol s++-- | Python character expression = string expression with one character+char :: Char -> Expr+char c = EString [c]++-- | Python function formal parameter+param :: String -> Symbol+param name = Symbol name++-- | Defines function definition+fun :: String -> [String] -> Expr -> PStatement+fun fname paramNames bodyExpr = + PFun (ident fname) (map param paramNames) (ret bodyExpr)++-- | Binary operators+-- Precedence levels are rather *informally* described in+-- The Python Language Reference,+-- http://docs.python.org/reference/.+-- I am adopting the infixr levels from Haskell,+-- which seem to be consistent with Python,+-- at least for the operators that Sifflet uses.+--+-- | Operator information+-- Arithmetic operators: +-- + and - have lower precedence than *, /, //, %+-- | Comparison operators have precedence lower than any arithmetic+-- operator. Here, I've specified associative = False,+-- because association doesn't even make sense (well, it does in Python+-- but not in other languages);+-- (a == b) == c is in general not well typed.++operatorTable :: M.Map String Operator+operatorTable = + M.fromList (map (\ op -> (opName op, op)) + [ (Operator "*" 7 True GroupLtoR) -- times+ , (Operator "//" 7 False GroupLtoR) -- int div+ , (Operator "/" 7 False GroupLtoR) -- float div+ , (Operator "%" 7 False GroupLtoR) -- mod+ , (Operator "+" 6 True GroupLtoR) -- plus+ , (Operator "-" 6 False GroupLtoR) -- minus+ , (Operator "==" 4 False GroupNone) -- eq+ , (Operator "!=" 4 False GroupNone) -- ne+ , (Operator ">" 4 False GroupNone) -- gt+ , (Operator ">=" 4 False GroupNone) -- ge+ , (Operator "<" 4 False GroupNone) -- lt+ , (Operator "<=" 4 False GroupNone) -- le+ ])
+ lib/Language/Sifflet/Export/ToHaskell.hs view
@@ -0,0 +1,136 @@+-- | Exports Sifflet to Haskell+-- Requires haskell-src package.++module Language.Sifflet.Export.ToHaskell+ (+ HaskellOptions(..)+ , defaultHaskellOptions+ , exportHaskell+ , functionsToHsModule+ , functionToHsDecl+ , exprToHsExpr+ )+where++import Data.Char (toUpper)+import qualified Data.Map as M+import System.FilePath (dropExtension, takeFileName)++import Language.Sifflet.Export.Exporter+import Language.Sifflet.Export.Haskell+import Language.Sifflet.Expr+import Language.Sifflet.Util+++-- Main types and functions++-- | User configurable options for export to Haskell.+-- Currently these options are unused.+-- The line width options should probably go somewhere else,+-- maybe as PrettyOptions.+data HaskellOptions = + HaskellOptions {optionsSoftMaxLineWidth :: Int+ , optionsHardMaxLineWidth :: Int+ }+ deriving (Eq, Show)++-- | The default options for export to Haskell.+defaultHaskellOptions :: HaskellOptions+defaultHaskellOptions = HaskellOptions {optionsSoftMaxLineWidth = 72,+ optionsHardMaxLineWidth = 80}++-- | Export functions with specified options to a file+exportHaskell :: HaskellOptions -> Exporter+exportHaskell _options functions path =+ let header = "-- File: " ++ path +++ "\n-- Generated by the Sifflet->Haskell exporter.\n\n"+ in writeFile path (header ++ + hsPretty (functionsToHsModule + (pathToModuleName path)+ functions))+++pathToModuleName :: FilePath -> String+pathToModuleName path =+ case dropExtension (takeFileName path) of+ [] -> "Test"+ c : cs -> toUpper c : cs++-- ------------------------------------------------------------------------++-- | Converting Sifflet to Haskell syntax tree++-- | Create a module from a module name and Functions.+functionsToHsModule :: String -> Functions -> Module+functionsToHsModule modname (Functions fs) =+ Module {moduleName = modname+ , moduleExports = Nothing+ , moduleImports = ImportDecl ["Data.Number.Sifflet"]+ , moduleDecls = map functionToHsDecl fs+ }++-- | Create a declaration from a Function.+-- Needs work: infer and declare the type of the function.+-- Minimally parenthesized.+functionToHsDecl :: Function -> Decl+functionToHsDecl (Function mname _atypes _rtype impl) =+ case (mname, impl) of+ (Nothing, _) -> error "functionToHsDecl: function has no name"+ (_, Primitive _) -> error "functionToHsDecl: function is primitive"+ (Just fname, Compound args body) ->+ Decl {declIdent = fname+ , declType = Nothing -- to be improved later+ , declParams = args+ , declExpr = (simplifyExpr haskellRules)+ (exprToHsExpr body)}++haskellRules :: [Expr -> Expr]+haskellRules = commonRulesForSimplifyingExprs ++ + [ruleIfRight, ruleRightToLeft]++-- | Converts a Sifflet Expr to a fully parenthesized Haskell Expr+exprToHsExpr :: Expr -> Expr+exprToHsExpr expr =+ case expr of+ EUndefined -> ESymbol (Symbol "undefined")+ ESymbol _ -> expr+ EBool _ -> expr+ EChar _ -> expr+ ENumber _ -> expr+ EString _ -> expr++ EIf c a b -> EIf (exprToHsExpr c) (exprToHsExpr a) (exprToHsExpr b)+ EList es -> EList (map exprToHsExpr es)+ ELambda x body -> ELambda x (EGroup body)+ ECall (Symbol fname) args -> + case nameToHaskell fname of+ Left op -> -- operator+ case args of+ [left, right] -> + EOp op (EGroup (exprToHsExpr left))+ (EGroup (exprToHsExpr right))+ _ -> error + "exprToHsExpr: operation does not have 2 operands"+ Right funcName -> -- function+ ECall (Symbol funcName) (map (EGroup . exprToHsExpr) args)+ _ -> errcats ["exprToHsExpr: extended expr:", show expr]++-- | Map Sifflet names to Haskell names.+-- Returns a Left Operator for Haskell operators,+-- which always have the same name as their corresponding Sifflet +-- functions, or a Right String for Haskell function and variable names.+nameToHaskell :: String -> Either Operator String+nameToHaskell name =+ case M.lookup name operatorTable of+ Just op -> Left op+ Nothing ->+ -- Most names would have the same names in Haskell,+ -- but there are a few special cases.+ Right (case name of+ "zero?" -> "eqZero"+ "positive?" -> "gtZero"+ "negative?" -> "ltZero"+ "add1" -> "succ"+ "sub1" -> "pred"+ _ -> name)+
+ lib/Language/Sifflet/Export/ToPython.hs view
@@ -0,0 +1,162 @@+-- | Sifflet to abstract syntax tree for Python.+-- Use Python module's pyPretty to pretty-print the result.++module Language.Sifflet.Export.ToPython+ (+ PythonOptions(..)+ , defaultPythonOptions+ , exprToPExpr+ , nameToPython+ , fixIdentifierChars+ , functionToPyDef+ , defToPy+ , functionsToPyModule+ , functionsToPrettyPy+ , exportPython+ )++where++import Data.Char (isAlpha, isDigit, ord)+import Data.Map ((!))+import System.FilePath (replaceFileName)++import Graphics.UI.Sifflet.Types (VPUI(..))++import Language.Sifflet.Export.Exporter+import Language.Sifflet.Export.Python+import Language.Sifflet.Expr+-- import Text.Sifflet.Pretty+import Language.Sifflet.Util++import System.Sifflet.Paths++-- | Options for Python export.+-- Should probably include choices like Python2 or Python3;+-- if statement or if expression. Right now, just a placeholder.++data PythonOptions = PythonOptions+ deriving (Eq, Show)+++defaultPythonOptions :: PythonOptions+defaultPythonOptions = PythonOptions++-- A lot of these are "pass-through" -- simplify: ***+exprToPExpr :: Expr -> Expr+exprToPExpr expr =+ case expr of+ EUndefined -> EUndefined -- was var "undefined"+ ESymbol _ -> expr++ EBool _ -> expr+ EChar c -> EString [c] -- Python does not distinguish char from str+ ENumber _ -> expr+ EString _ -> expr++ EIf cond action altAction ->+ -- EIf here represents a Python if *expression*:+ -- value if test else altvalue+ -- not the familiar if *statement*!+ EIf (exprToPExpr cond) + (exprToPExpr action)+ (exprToPExpr altAction)+ EList exprs -> + ECall (Symbol "li") (map exprToPExpr exprs)+ ELambda x body -> ELambda x (EGroup body)+ ECall (Symbol fname) args -> + -- Python distinguishes between functions and operators+ case nameToPython fname of+ Left op ->+ case args of+ [left, right] -> + EOp op (EGroup (exprToPExpr left))+ (EGroup (exprToPExpr right))+ _ -> error "exprToPExpr: operation does not have 2 operands"+ Right pname ->+ -- I don't think we need (a) for each arg a+ -- since they are separated by commas+ ECall (Symbol pname) (map exprToPExpr args)+ _ -> errcats ["exprToPExpr: extended expr:", show expr]++-- | Convert Sifflet name (of a function) to Python operator (Left)+-- or function name (Right)+nameToPython :: String -> Either Operator String+nameToPython name =+ let oper oname = Left $ operatorTable ! oname+ in case name of + "+" -> oper "+"+ "-" -> oper "-"+ "*" -> oper "*"+ "div" -> oper "//"+ "mod" -> oper "%"+ "/" -> oper "/" -- invalid for integers in Python 2!+ "==" -> oper "=="+ "/=" -> oper "!="+ ">" -> oper ">"+ ">=" -> oper ">="+ "<" -> oper "<"+ "<=" -> oper "<="+ "add1" -> Right "add1"+ "sub1" -> Right "sub1"+ "zero?" -> Right "eqZero"+ "positive?" -> Right "gtZero"+ "negative?" -> Right "ltZero"+ "null" -> Right "null"+ "head" -> Right "head"+ "tail" -> Right "tail"+ ":" -> Right "cons"+ _ -> Right (fixIdentifierChars name)++-- | Remove characters that are not valid in a Python identifier,+-- and in some cases, insert other characters to show what's missing++fixIdentifierChars :: String -> String+fixIdentifierChars =+ let fix s =+ case s of+ [] -> []+ c:cs ->+ if isAlpha c || isDigit c || c == '_'+ then c : fix cs+ else case c of+ '?' -> "_QUESTION_" ++ fix cs+ -- other cases can be inserted here+ _ -> "_CHR" ++ show (ord c) ++ "_" ++ fix cs+++ in fix++-- | Create a Python def statement from a Sifflet function.+-- Minimally parenthesized.+functionToPyDef :: Function -> PStatement+functionToPyDef = defToPy . functionToDef++defToPy :: FunctionDefTuple -> PStatement+defToPy (fname, paramNames, _, _, body) =+ fun (fixIdentifierChars fname) + paramNames + ((simplifyExpr pyRules) (exprToPExpr body))++pyRules :: [Expr -> Expr]+pyRules = commonRulesForSimplifyingExprs++functionsToPyModule :: Functions -> PModule+functionsToPyModule (Functions fs) = PModule (map functionToPyDef fs)++functionsToPrettyPy :: Functions -> String+functionsToPrettyPy = pyPretty . functionsToPyModule++exportPython :: VPUI -> PythonOptions -> Exporter+exportPython vpui _options funcs path =+ let header = "# File: " ++ path ++ "\n" +++ "# Generated by the Sifflet->Python exporter.\n" +++ "\n" +++ "# You may need to copy the file sifflet.py into " +++ "this directory\n" +++ "# from the directory where Sifflet is installed.\n" +++ "\n" +++ "from sifflet import *\n\n"+ libDest = replaceFileName path "sifflet.py"+ in do copyLibFile vpui "sifflet.py" libDest+ writeFile path (header ++ functionsToPrettyPy funcs)
+ lib/Language/Sifflet/Export/ToScheme.hs view
@@ -0,0 +1,327 @@+module Language.Sifflet.Export.ToScheme+ (SExpr(..)+ , Atom(..)+ , Indent+ , Exporter+ , SchemeOptions(..)+ , defaultSchemeOptions+ , exprToSExpr+ , functionNameToSchemeName+ , valueToSExpr+ , exprToSchemeRepr+ , exprToSchemePretty+ , exprToScheme+ , inl+ , sepLines2+ , functionsToSExprs+ , functionsToPrettyScheme+ , defToSExpr+ , exportScheme+ )++where++import System.Sifflet.Paths++import Data.Number.Sifflet+import Graphics.UI.Sifflet.Types (VPUI(..))++import Language.Sifflet.Expr+import Language.Sifflet.Export.Exporter+import Language.Sifflet.Util++import Text.Sifflet.Pretty+import Text.Sifflet.Repr++-- Scheme S-exprs+-- --------------++-- Names beginning with S are generally Scheme things,+-- and of course, SExpr also stands for Symbolic Expression.++data SExpr = SAtom Atom | SList [SExpr]+ deriving (Eq, Show)++data Atom = SFloat Double+ | SInt Integer+ | SSymbol String+ | SString String+ | SChar Char+ | SBool Bool+ | SFunction Function+ deriving (Eq, Show)++type Indent = Int++data SchemeOptions = + SchemeOptions { defineWithLambda :: Bool + -- ^ use explicit lambda in function definitions,+ -- (define f (lambda (a b) ...)+ }+ deriving (Eq, Show)++defaultSchemeOptions :: SchemeOptions+defaultSchemeOptions = SchemeOptions {defineWithLambda = False}++-- | An SExpr is "flattish" if it is an atom+-- or is a list containing only atoms, +-- where the empty list () is an atom.++flattish :: [SExpr] -> Bool+flattish sexprs =+ case sexprs of+ [] -> True+ x:xs -> atom x && flattish xs++atom :: SExpr -> Bool+atom sexpr =+ case sexpr of+ SAtom _ -> True+ SList [] -> True+ _ -> False++-- Converting Sifflet Exprs to SExprs++exprToSExpr :: Expr -> SExpr+exprToSExpr expr =+ case expr of+ EUndefined -> + SAtom (SSymbol "*sifflet-undefined*")+ ESymbol (Symbol str) -> + SAtom (SSymbol (functionNameToSchemeName str))++ EBool b -> valueToSExpr (VBool b)+ EChar c -> valueToSExpr (VChar c)+ ENumber n -> valueToSExpr (VNumber n)+ EString s -> valueToSExpr (VString s)++ EIf cond action altAction ->+ SList [SAtom (SSymbol "if"), exprToSExpr cond,+ exprToSExpr action, exprToSExpr altAction]+ EList exprs -> + -- This case is not likely to be used,+ -- but if it is, the exprs might need to be evaluated,+ -- so we have to use list instead of quote+ SList (SAtom (SSymbol "list") : (map exprToSExpr exprs))+ ELambda (Symbol x) body ->+ SList [SAtom (SSymbol "lambda"), SList [SAtom (SSymbol x)], + exprToSExpr body] + ECall fsym args -> + SList (exprToSExpr (ESymbol fsym) : map exprToSExpr args) + _ -> errcats ["exprToSExpr: extended expr:", show expr]++-- Convert Sifflet function names to corresponding Scheme function names.+-- There are a few special cases; otherwise, the names are the same.+-- In particular, all of these have the same names in Sifflet+-- as in standard (R5RS) Scheme:+-- +, -, *, +-- All of these are defined in the library sifflet.scm, +-- with the prefix "sifflet-" (e.g., sifflet-div):+-- div, add1, sub1, /, not-equal?+-- Notes: 1+ and 1- are commonly found in Scheme implementations,+-- but not standard.++functionNameToSchemeName :: String -> String+functionNameToSchemeName name =+ case name of+ "mod" -> "modulo"+ "add1" -> "sifflet-add1"+ "sub1" -> "sifflet-sub1"+ "==" -> "equal?"+ "/=" -> "sifflet-not-equal?"+ "null" -> "null?"+ "head" -> "car"+ "tail" -> "cdr"+ ":" -> "cons"+ _ -> name++-- Converting Sifflet Values to SExprs++valueToSExpr :: Value -> SExpr+valueToSExpr value =+ case value of+ VList vs -> + SList [SAtom (SSymbol "quote"), SList (map valueToSExpr vs)]+ _ ->+ SAtom (case value of+ VBool b -> SBool b+ VChar c -> SChar c+ VNumber (Exact i) -> SInt i+ VNumber (Inexact x) -> SFloat x+ VString s -> SString s+ VFun f -> SFunction f+ VList _ -> + error ("valueToSExpr: Impossible! " +++ "We can't have VList here!")+ )++-- Converting Exprs to Strings of Scheme code++exprToSchemeRepr :: Expr -> String+exprToSchemeRepr = repr . exprToSExpr++exprToSchemePretty :: Expr -> String+exprToSchemePretty = pretty . exprToSExpr++exprToScheme :: Expr -> String+exprToScheme = exprToSchemePretty++-- Converting SExprs to Strings of Scheme code++instance Repr SExpr where+ repr sexpr =+ case sexpr of+ SAtom satom ->+ case satom of+ SFloat x -> show x+ SInt i -> show i+ SSymbol name -> name -- without ""+ SString str -> show str -- with ""+ SChar char -> show char+ SBool False -> "#f"+ SBool True -> "#t"+ -- SFunction: is this case really needed?+ -- Isn't the conversion to Scheme function names+ -- done in exprToSExpr? + SFunction (Function mname _ _ _) ->+ case mname of+ Nothing -> + error "SExpr/repr: cannot repr unnamed function"+ Just name -> + functionNameToSchemeName name+ SList exprs ->+ "(" ++ unwords (map repr exprs) ++ ")"++instance Pretty SExpr where+ pretty = prettyLoop 0++prettyLoop :: Indent -> SExpr -> String+prettyLoop ind sexpr =+ case sexpr of+ SAtom _ -> repr sexpr+ SList xs ->+ if flattish xs+ then repr sexpr+ else+ case xs of+ [] -> error "prettyLoop: non-flattish xs cannot be []."+ [SAtom (SSymbol "if"), _, _, _] ->+ displayList2 ind (ind + 4) xs+ [SAtom (SSymbol "define"), _, _] ->+ displayList2 ind (ind + 4) xs+ [SAtom (SSymbol "lambda"), _, _] ->+ displayList2 ind (ind + 4) xs+ SAtom (SSymbol name) : args ->+ -- If it starts as a symbol, it's probably a function call,+ -- so put function name and first argument on one line,+ -- and indent everything following to first argument.+ case args of+ [] ->+ -- no argument+ displayList1 ind (ind + length name + 2) xs+ _ ->+ -- at least one argument, so at least two elements+ -- in the list+ displayList2 ind (ind + length name + 2) xs+ _ -> displayList1 ind (ind + 1) xs+++-- | Newline and indent+inl :: Int -> String+inl ind = "\n" ++ replicate ind ' '++-- displayList1 "shows" the first list element on the first line+-- and then the rest on succeeding lines, so it must have at+-- least one element+displayList1 :: Indent -> Indent -> [SExpr] -> String+displayList1 ind ind' xs =+ case xs of+ [] -> error "displayList1: empty list"+ x:xs' -> "(" ++ + prettyLoop ind x ++ + displayTail ind' xs'++-- Like displayList1 but "shows" the first *two* list elements+-- on the first line.+displayList2 :: Indent -> Indent -> [SExpr] -> String+displayList2 ind ind' xs =+ case xs of+ x0:x1:xs' -> "(" ++ prettyLoop ind x0 +++ " " ++ prettyLoop ind' x1 +++ displayTail ind' xs'+ _ -> error "displayList2: list is too short"++-- displayTail "shows" the tail of an SExpr which is a list,+-- it assumes the initial "(" and first element have already+-- been "shown"+displayTail :: Indent -> [SExpr] -> String+displayTail ind xs =+ case xs of+ [] -> ")"+ -- to prevent final ")" from being on a line by itself+ x:[] -> inl ind ++ prettyLoop ind x ++ ")"+ x:xs' -> inl ind ++ prettyLoop ind x ++ displayTail ind xs'++++-- Converting Sifflet definitions to Scheme definitions.++-- | Convert Sifflet Functions to Scheme SExprs+functionsToSExprs :: SchemeOptions -> Functions -> [SExpr]+functionsToSExprs options (Functions fs) =+ map (defToSExpr options . functionToDef) fs++-- | Convert Sifflet Functions to pretty Scheme+functionsToPrettyScheme :: SchemeOptions -> Functions -> String+functionsToPrettyScheme options = + sepLines2 . map pretty . functionsToSExprs options++-- | Convert a FunctionDefTuple to a Scheme SExpr.+-- Use the form (define (name . args) body)+-- except when there are zero arguments, which becomes a+-- Scheme constant rather than a function,+-- use (define name expr).++defToSExpr :: SchemeOptions -> FunctionDefTuple -> SExpr+defToSExpr options (name, args, _atypes, _rtype, body) =+ let asym = SAtom . SSymbol+ sdefine = asym "define"+ sname = asym name+ sbody = exprToSExpr body+ in case args of+ [] -> SList [sdefine, sname, sbody]+ _:_ ->+ let argAtoms = map asym args+ in if defineWithLambda options+ then let slambda = asym "lambda"+ sargs = SList argAtoms+ slambdaArgsBody = SList [slambda, sargs, sbody]+ in SList [sdefine, sname, slambdaArgsBody]+ else let snameArgs = SList (sname : argAtoms)+ in SList [sdefine, snameArgs, sbody]++-- | Export functions to a Scheme file.++-- This, too, could use an extra "explicit lambda" argument,+-- like defToSExpr.++exportScheme :: VPUI -> SchemeOptions -> Exporter+exportScheme vpui options functions path =+ + let header = ";;; File: " ++ path ++ "\n" +++ ";;; Generated by the Sifflet->Scheme exporter.\n" +++ "\n" +++ ";;; You may need to insert the contents of sifflet.scm,\n" +++ ";;; from the Sifflet installation directory," ++ + " into this file\n"+ in do+ -- Get contents of sifflet.scm.+ -- It must be copied into the export file,+ -- since there is no standard way in Scheme to "include" or "import"+ -- a library.+ lib <- readLibFile vpui "sifflet.scm" path+ writeFile path + (sepLines2 [header,+ functionsToPrettyScheme options functions,+ lib])+
+ lib/Language/Sifflet/Expr.hs view
@@ -0,0 +1,1041 @@+module Language.Sifflet.Expr+ (+ ArgSpec(..)+ , aspecsLookup+ , EvalResult, EvalRes(EvalOk, EvalError, EvalUntried)+ , exprToValue, valueToLiteral, valueToLiteral'+ , Symbol(..)+ , OStr, OBool, OChar+ , Expr(..), eSymbol, eSym, eInt, eString, eChar, eFloat+ , toLambdaExpr+ , callToApp, mapply+ , appToCall, mcall+ , exprIsAtomic+ , exprIsCompound+ , eBool, eFalse, eTrue, eIf+ , eList, eCall+ , exprIsLiteral+ , exprSymbols, exprVarNames+ , Operator(..)+ , Precedence+ , OperatorGrouping(..)+ , Value(..), valueFunction+ , Functions(..)+ , Function(..), functionName, functionNArgs+ , functionArgSpecs+ , functionArgTypes, functionResultType, functionArgResultTypes+ , functionType+ , functionArgNames, functionBody, functionImplementation+ , FunctionDefTuple, functionToDef, functionFromDef+ , FunctionImpl(..)+ , TypeVarName, TypeConsName, Type(..)+ , typeBool, typeChar, typeNum, typeString+ , typeList, typeFunction+ , Env, emptyEnv, makeEnv, extendEnv, envInsertL, envPop+ , envIns, envSet, envGet+ , envGetFunction, envLookup, envLookupFunction+ , envSymbols, envFunctionSymbols, envFunctions+ , eval, evalWithLimit, stackSize, apply+ , newUndefinedFunction+ , ePlus, eTimes, eMinus, eDiv, eMod+ , eAdd1, eSub1+ , eEq, eNe, eGt, eGe, eLt, eLe+ , eZerop, ePositivep, eNegativep+ , baseEnv)++where++-- drop this after debugging:+-- import System.IO.Unsafe(unsafePerformIO)++import Data.Map as Map hiding (filter, foldl, map, null)+import Data.List as List++import Data.Number.Sifflet++import Data.Sifflet.Tree as T++import Text.Sifflet.Pretty+import Text.Sifflet.Repr ()++import Language.Sifflet.Util++-- | Transform a numerical expression into its negation,+-- e.g., 5 --> (-5).+-- Fails if the expression is not an ENumber.++eNegate :: Expr -> SuccFail Expr+eNegate expr = + case expr of+ ENumber n -> Succ $ ENumber (negate n)+ _ -> Fail $ "eNegate: cannot handle" ++ show expr++-- Symbols have names, and may or may not have values,+-- but the value is stored in an environment, not in the symbol itself.++newtype Symbol = Symbol String+ deriving (Eq, Read, Show)++instance Pretty Symbol where+ pretty (Symbol s) = s++instance Repr Symbol where repr (Symbol s) = s++-- The Haskell representations of V's primitive data types.+-- Data.Number.Sifflet.Number represents exact and inexact numbers.+type OStr = String+type OBool = Bool+type OChar = Char++-- | A more highly "parsed" type of expression+--+-- Function calls have two kinds:+-- 1. ECall:+-- restricted to the case where the function expression+-- is just a symbol, since otherwise it will be hard to visualize.+-- 2. EApp: allows any expression to be the function,+-- but is applied to only one argument.+-- For now, the type checker will convert ECall expressions to+-- EApp expressions. Ultimately, the two variants ought to be+-- unified.+--+-- The constructors EOp and EGroup are not used in Sifflet itself,+-- but they are needed for export to Python, Haskell, and similar languages;+-- they allow a distinction between operators and functions, and+-- wrapping expressions in parentheses.+-- EGroup e represents parentheses used for grouping: (e);+-- it is not used for other cases of parentheses, e.g.,+-- around the argument list in a function call.] ++data Expr = EUndefined+ | ESymbol Symbol + | EBool Bool+ | EChar Char+ | ENumber Number+ | EString String+ | EIf Expr Expr Expr -- ^ if test branch1 branch2+ | EList [Expr]+ | ELambda Symbol Expr + | EApp Expr Expr -- ^ apply function to argument+ | ECall Symbol [Expr] -- ^ function name, arglist+ | EOp Operator Expr Expr -- ^ binary operator application+ | EGroup Expr -- ^ grouping parentheses+ deriving (Eq, Show)++instance Repr Expr where+ repr e =+ case e of+ EUndefined -> "*undefined*"+ ESymbol s -> repr s+ EBool b -> repr b+ EChar c -> repr c+ ENumber n -> repr n+ EString s -> show s+ EIf t a b -> par "if" (map repr [t, a, b])+ EList xs -> if exprIsLiteral e+ then reprList "[" ", " "]" xs+ else error ("Expr.repr: EList expression is non-literal: " + ++ show e)+ -- check *** was: par "EList" (map repr items)+ ELambda x body -> par "lambda" [repr x , "->", repr body]+ EApp f arg -> par (repr f) [repr arg]+ ECall (Symbol fname) args -> par fname (map repr args)+ EOp op left right -> unwords [repr left, opName op, repr right]+ EGroup e' -> "(" ++ repr e' ++ ")"++-- | Try to convert the arguments and body of a function to a lambda expression.+-- Fails if there are no arguments, since a lambda expression requires one.+-- If there are multiple arguments, then we get a nested lambda expression.++toLambdaExpr :: [String] -> Expr -> SuccFail Expr+toLambdaExpr args body =+ case args of+ [] -> Fail "toLambdaExpr: no arguments; at least one needed"+ a:[] -> Succ $ ELambda (Symbol a) body+ a:as -> do+ {+ expr <- toLambdaExpr as body+ ; Succ $ ELambda (Symbol a) expr+ }+ +-- | Convert an ECall expression to an EApp expression++callToApp :: Expr -> Expr+callToApp expr =+ case expr of+ ECall fsym args -> mapply (ESymbol fsym) args+ _ -> error "callToApp: requires ECall expression"++-- | Helper for callToApp, but may have other uses.+-- Creates an EApp expression representing a function call+-- with possibly many arguments.+mapply :: Expr -> [Expr] -> Expr+mapply fexpr args =+ case args of+ [] -> error "mapply: no argument, cannot happen"+ arg:[] -> EApp fexpr arg+ arg:args' -> mapply (EApp fexpr arg) args'+++-- | Convert an EApp expression to an ECall expression++appToCall :: Expr -> Expr+appToCall expr =+ case expr of+ EApp f arg -> mcall f [arg]+ _ -> error "appToCall: requires an EApp expression"+++-- | Helper for appToCall, but may have other uses.+-- Creates an ECall expression.++mcall :: Expr -> [Expr] -> Expr+mcall f args =+ case f of+ ESymbol fsym -> ECall fsym args+ EApp g arg -> mcall g (arg:args)+ _ ->+ error "mcall: function must be represented as a symbol or an EApp"++-- | An Expr is "extended" if it uses the extended constructors+-- EOp or EGroup. In pure Sifflet, no extended Exprs are used.++exprIsExtended :: Expr -> Bool+exprIsExtended e =+ case e of+ EOp _ _ _ -> True+ EGroup _ -> True+ EIf t a b -> exprIsExtended t ||+ exprIsExtended a ||+ exprIsExtended b+ EList xs -> any exprIsExtended xs+ ELambda _ body -> exprIsExtended body+ ECall (Symbol _) args -> any exprIsExtended args+ _ -> False++-- | Is an Expr a literal? A literal is a boolean, character, number, string,+-- or list of literals. We (should) only allow user input expressions+-- to be literal expressions.++exprIsLiteral :: Expr -> Bool+exprIsLiteral e =+ case e of + EBool _ -> True+ EChar _ -> True+ ENumber _ -> True+ EString _ -> True+ EList es -> all exprIsLiteral es+ -- Shouldn't we say that + -- EGroup e' *not* a literal, even if e' is a literal?+ -- But consider carefully the effect on exprIsAtomic and ()'s removal.+ EGroup _e' -> True -- or False, or exprIsLiteral e' ???+ _ -> False++-- | Is an expression atomic?+-- Atomic expressions do not need parentheses in any reasonable language,+-- because there is nothing to be grouped (symbols, literals)+-- or in the case of lists, they already have brackets+-- which separate them from their neighbors.+--+-- All lists are atomic, even if they are not literals,+-- because (for example) we can remove parentheses+-- from ([a + b, 7])++exprIsAtomic :: Expr -> Bool+exprIsAtomic e =+ case e of+ ESymbol _ -> True+ EList _ -> True+ _ -> exprIsLiteral e++-- | Compound = non-atomic+exprIsCompound :: Expr -> Bool+exprIsCompound = not . exprIsAtomic++eSymbol, eSym :: String -> Expr+eSymbol = ESymbol . Symbol+eSym = eSymbol++eInt :: Integer -> Expr+eInt = ENumber . Exact++eString :: OStr -> Expr+eString = EString++eChar :: OChar -> Expr+eChar = EChar++eFloat :: Double -> Expr+eFloat = ENumber . Inexact++eBool :: Bool -> Expr+eBool = EBool++eFalse, eTrue :: Expr+eFalse = eBool False+eTrue = eBool True++eIf :: Expr -> Expr -> Expr -> Expr+eIf = EIf++eList :: [Expr] -> Expr+eList = EList++-- | Example:+-- ePlus_2_3 = eCall "+" [eInt 2, eInt 3]+eCall :: String -> [Expr] -> Expr+eCall = ECall . Symbol++-- | An operator, such as * or ++-- An operator is associative, like +, if (a + b) + c == a + (b + c).+-- Its grouping is left to right if (a op b op c) means (a op b) op c;+-- right to left if (a op b op c) means a op (b op c).+-- Most operators group left to right.+data Operator = Operator {opName :: String+ , opPrec :: Precedence+ , opAssoc :: Bool -- ^ associative?+ , opGrouping :: OperatorGrouping+ }+ deriving (Eq, Show)++instance Pretty Operator where+ pretty = opName++-- | Operator priority, normally is > 0 or >= 0, +-- but does that really matter? I think not.+type Precedence = Int++-- | Operator grouping: left to right or right to left,+-- or perhaps not at all+data OperatorGrouping = GroupLtoR | GroupRtoL | GroupNone+ deriving (Eq, Show)++-- VALUES AND EVALUATION++data Value = VBool OBool+ | VChar OChar+ | VNumber Number+ | VString OStr+ | VFun Function+ | VList [Value] + deriving (Eq, Show)+ -- no Read for Function++instance Repr Value where+ repr (VBool b) = show b+ repr (VChar c) = show c+ repr (VNumber n) = show n+ repr (VString s) = show s+ repr (VFun f) = repr f+ repr (VList vs) = reprList "[" ", " "]" vs++valueFunction :: Value -> Function+valueFunction value =+ case value of+ VFun function -> function+ _ -> error "valueFunction: non-function value"++-- Evaluation results (or non-results)++type EvalResult = EvalRes Value++data EvalRes e = EvalOk e | EvalError String | EvalUntried+ deriving (Eq, Show)++instance Functor EvalRes where+ fmap f (EvalOk v) = EvalOk (f v)+ fmap _ (EvalError s) = EvalError s+ fmap _ EvalUntried = EvalUntried++instance Applicative EvalRes where+ pure = EvalOk+ EvalOk f <*> EvalOk v = EvalOk (f v)+ EvalOk _ <*> EvalError s = EvalError s+ EvalOk _ <*> EvalUntried = EvalUntried++ -- It seems that the other cases should be consistent+ -- with evalWithLimit for ECall below,+ -- whatever that means ...+ EvalError s <*> _ = EvalError s+ EvalUntried <*> _ = EvalUntried+ +instance Monad EvalRes where+ EvalOk value >>= f = f value+ EvalError e >>= _f = EvalError e+ EvalUntried >>= _f = EvalUntried+ return = EvalOk+ fail = EvalError++-- | The value of an expression in the base environment.++exprToValue :: Expr -> SuccFail Value+exprToValue expr = + case eval expr baseEnv of + EvalOk value -> Succ value+ EvalError msg -> Fail msg+ EvalUntried -> error "exprToValue: eval resulted in EvalUntried"++valueToLiteral :: Value -> SuccFail Expr+valueToLiteral v = + case v of+ VBool b -> Succ $ EBool b+ VChar c -> Succ $ EChar c+ VNumber n -> Succ $ ENumber n+ VString s -> Succ $ EString s+ -- VList [] -> Succ $ EList []+ -- VV Should this be fixed? VV+ -- VList _ -> Fail "cannot convert non-empty list to literal expression"+ VList vs -> mapM valueToLiteral vs >>= Succ . EList+ VFun _f -> Fail "cannot convert function to literal expression"++valueToLiteral' :: Value -> Expr+valueToLiteral' v = case valueToLiteral v of+ Fail msg -> error ("valueToLiteral: " ++ msg)+ Succ e -> e++-- | Convert a literal expression to the value it represents.+-- It is an error if the expression is non-literal.+-- See exprIsLiteral. +literalToValue :: Expr -> Value+literalToValue e =+ case e of+ EBool b -> VBool b+ EChar c -> VChar c+ ENumber n -> VNumber n+ EString s -> VString s+ EList es -> if exprIsLiteral e+ then VList (map literalToValue es)+ else errcats ["literalToValue: ",+ "non-literal list expression: ",+ show e]+ _ -> errcats ["literalToValue: non-literal or extended expression: " , + show e]++-- | Type variable name +type TypeVarName = String++-- | Type constructor name+type TypeConsName = String++-- | A Type is either a type variable or a constructed type+-- with a constructor and a list of type parameters++data Type = TypeVar TypeVarName -- named type variable+ | TypeCons TypeConsName [Type] -- constructed type+ deriving (Eq)++instance Show Type where+ show (TypeVar vname) = vname+ show (TypeCons ctor ts) =+ case ts of+ [] -> ctor+ (t:ts') ->+ case ctor of+ "List" -> "[" ++ show t ++ "]"+ "Function" -> "(" ++ show t ++ " -> " +++ show (head ts') ++ ")"+ _ -> "(" ++ ctor ++ (unwords (map show ts)) ++ ")"+++typeToArity :: Type -> Int+typeToArity atype =+ case atype of + TypeCons "Function" [_, next] -> 1 + typeToArity next+ _ -> 0++-- Primitive types++primType :: TypeConsName -> Type+primType tname = TypeCons tname []++typeBool, typeChar, typeNum, typeString :: Type+typeBool = primType "Bool"+typeChar = primType "Char"+typeNum = primType "Num"+typeString = primType "String"++-- Built-in compound types++typeList :: Type -> Type+typeList t = TypeCons "List" [t]++-- | The type of a function, from its argument types and result type,+-- where (a -> b) is represented as TypeCons "Function" [a, b].+-- Note that for n-ary functions, n > 2 implies nested function types: +-- (a -> b -> c) is represented as+-- TypeCons "Function" [a, TypeCons "Function" [b, c]], etc.++typeFunction :: [Type] -> Type -> Type+typeFunction atypes rtype =+ let func a b = TypeCons "Function" [a, b]+ in case atypes of+ [] -> error "typeFunction: empty argument type list"+ atype:[] -> func atype rtype+ atype:atypes' -> func atype (typeFunction atypes' rtype)++-- | A collection of functions, typically to be saved or exported+-- or read from a file++newtype Functions = Functions [Function]+ deriving (Eq, Show)++-- | A function may have a name and always has an implementation+data Function = Function (Maybe String) -- function name+ [Type] -- argument types+ Type -- result type+ FunctionImpl -- implementation+ deriving (Show)+++data ArgSpec = ArgSpec {argName :: String, -- argument name+ argInlets :: Int -- number of inputs+ }+ deriving (Eq, Show)++-- | Try to find the number of inlets for an argument+-- from a list of ArgSpec+aspecsLookup :: String -> [ArgSpec] -> Maybe Int+aspecsLookup name specs =+ case specs of + [] -> Nothing+ s:ss ->+ if argName s == name+ then Just (argInlets s)+ else aspecsLookup name ss++functionArgSpecs :: Function -> [ArgSpec]+functionArgSpecs f@(Function _ argTypes _ _) = + [ArgSpec {argName = n, argInlets = typeToArity t} |+ (n, t) <- zip (functionArgNames f) argTypes]++data FunctionImpl = Primitive ([Value] -> EvalResult) -- a Haskell function+ | Compound [String] Expr -- arguments, body++instance Show FunctionImpl where+ show (Primitive _) = "<primitive function>"+ show (Compound args body) = + concat ["Compound function, args = " ++ show args ++ + "; body = " ++ show body]++instance Read FunctionImpl where+ readsPrec _ _ = error "readsPrec not implemented for FunctionImpl"++instance Repr Function where+ repr f =+ let name = functionName f+ in case functionImplementation f of+ Primitive _ -> "<primfunc " ++ name ++ ">"+ Compound _args _body -> "<func " ++ name ++ ">"++newUndefinedFunction :: String -> [String] -> Function+newUndefinedFunction name argnames =+ let (atypes, rtype) = undefinedTypes argnames+ impl = Compound argnames EUndefined+ in Function (Just name) atypes rtype impl++undefinedTypes :: [String] -> ([Type], Type)+undefinedTypes argnames =+ let atypes = [TypeVar ('_' : name) | name <- argnames]+ rtype = TypeVar "_result"+ in (atypes, rtype)++functionName :: Function -> String+functionName (Function mname _ _ _) = + case mname of+ Just name -> name+ Nothing -> "(unnamed)"++functionNArgs :: Function -> Int+functionNArgs = length . functionArgTypes++functionArgTypes :: Function -> [Type]+functionArgTypes (Function _ argtypes _ _) = argtypes++functionResultType :: Function -> Type+functionResultType (Function _ _ rtype _) = rtype++-- | Type type of a function, a tuple of (arg types, result type)+functionArgResultTypes :: Function -> ([Type], Type) -- (args., result type)+functionArgResultTypes f = (functionArgTypes f, functionResultType f)++-- | The type of a function, +-- where (a -> b) is represented as TypeCons "Function" [a, b]+functionType :: Function -> Type+functionType (Function _ argTs resultT _) = typeFunction argTs resultT++functionImplementation :: Function -> FunctionImpl+functionImplementation (Function _ _ _ impl) = impl++functionArgNames :: Function -> [String]+functionArgNames f = case functionImplementation f of+ Primitive _ -> + ["dummy" | _t <- functionArgTypes f]+ Compound args _body -> args++type FunctionDefTuple = (String, [String], [Type], Type, Expr)++functionToDef :: Function -> FunctionDefTuple+functionToDef (Function mname argTypes resType impl) = + case impl of+ Primitive _ -> error "functionToDef: primitive function"+ Compound argNames body ->+ case mname of+ Nothing -> error "functionToDef: unnamed function"+ Just name -> (name, argNames, argTypes, resType, body)++functionFromDef :: FunctionDefTuple -> Function+functionFromDef (name, argNames, argTypes, resType, body) =+ Function (Just name) argTypes resType (Compound argNames body)++functionBody :: Function -> Expr+functionBody f = case functionImplementation f of+ Primitive _fp -> + errcats ["functionBody:",+ "no body available for primitive function"]+ Compound _args body -> body++-- | We need to be able to say functions are equal (or not) in order+-- to tell if environments are equal or not, in order to know whether+-- there are unsaved changes. This is tricky since the primitive+-- function implementations do not instantiate Eq, so if it's+-- primitive == primitive? we go by the names alone (there's nothing+-- else to go by). Otherwise all the parts must be equal.+instance Eq Function where+ f1 == f2 =+ let Function mname1 atypes1 anames1 impl1 = f1+ Function mname2 atypes2 anames2 impl2 = f2+ in case (impl1, impl2) of+ (Primitive _, Primitive _) -> mname1 == mname2+ (Compound args1 body1, Compound args2 body2 ) -> + mname1 == mname2 &&+ atypes1 == atypes2 &&+ anames1 == anames2 &&+ args1 == args2 &&+ body1 == body2+ _ -> False++-- | An Environment contains variable bindings and may be linked to +-- a next environment+--+-- Perhaps it may also be used to generate Vp type variables (with int id's)++type EnvFrame = Map String Value+type Env = [EnvFrame] -- should be NON-empty+type Binding = (String, Value)++emptyEnv :: Env+emptyEnv = makeEnv [] []++makeEnv :: [String] -> [Value] -> Env +makeEnv names values = extendEnv names values []++extendEnv :: [String] -> [Value] -> Env -> Env+extendEnv names values env = fromList (zip names values) : env++-- | Insert names and values from lists into an environment+envInsertL :: Env -> [String] -> [Value] -> Env+envInsertL env names values =+ case env of+ [] -> error "envInsertL: empty list"+ f : fs ->+ let ins :: EnvFrame -> Binding -> EnvFrame+ ins frame (name, value) = Map.insert name value frame+ in foldl ins f (zip names values) : fs++envIns :: Env -> String -> Value -> Env+envIns env name value =+ case env of+ [] -> error "envIns: empty list"+ f : fs -> Map.insert name value f : fs++envSet :: Env -> String -> Value -> Env+envSet env name value = + -- If name is bound in some map in the environment, update the binding+ -- in that map; otherwise insert it into the "front" map+ let loop :: Env -> Maybe Env+ loop env1 =+ case env1 of+ [] -> Nothing+ f:fs ->+ case Map.lookup name f of+ Just _ -> Just (envIns env1 name value)+ Nothing ->+ do -- in the Maybe monad:+ fs' <- loop fs+ return (f:fs')++ in case loop env of+ Just result -> result+ Nothing -> envIns env name value++-- | Get the value of a variable from an environment+envGet :: Env -> String -> Value+envGet env name = case envLookup env name of+ Just value -> value+ Nothing -> errcats ["envGet: unbound variable:", name]++envGetFunction :: Env -> String -> Function+envGetFunction env name = func + where VFun func = envGet env name++envLookup :: Env -> String -> Maybe Value+envLookup env name =+ case env of+ [] -> Nothing+ f:fs ->+ case Map.lookup name f of+ Just value -> Just value+ Nothing -> envLookup fs name++envLookupFunction :: Env -> String -> Maybe Function+envLookupFunction env name = + case envLookup env name of+ Nothing -> Nothing+ Just value ->+ case value of+ VFun function -> Just function+ _ -> Nothing++-- | List of all symbols bound in the environment+envSymbols :: Env -> [String]+envSymbols env =+ case env of+ [] -> []+ f : fs -> keys f ++ envSymbols fs++-- | List of all symbols bound to functions in the environment+envFunctionSymbols :: Env -> [String]+envFunctionSymbols env =+ let isFunction s = case envGet env s of+ VFun _ -> True+ _ -> False+ in [s | s <- envSymbols env, isFunction s]++-- | All the functions in the environment+envFunctions :: Env -> Functions+envFunctions env = + Functions (map (envGetFunction env) + (envFunctionSymbols env))++-- | Return to the environment prior to an extendEnv+envPop :: Env -> Env+envPop env =+ case env of+ [] -> error "envPop: empty list"+ _f:fs -> fs+ +unbound :: String -> Env -> Bool+unbound name env = envLookup env name == Nothing++-- EVALUATING EXPRESSIONS++-- Limit the stack size for recursion, since we are helping+-- novice programmers to learn++stackSize :: Int+stackSize = 1000++eval :: Expr -> Env -> EvalResult+eval expr env = evalWithLimit expr env stackSize++evalWithLimit :: Expr -> Env -> Int -> EvalResult++-- Evaluate an expression in an environment with a limited stack++evalWithLimit expr env stacksize =+ if stacksize <= 0+ then EvalError "stack overflow"+ else+ let stacksize' = pred stacksize in+ case expr of+ EUndefined -> EvalError "undefined"+ ESymbol (Symbol name) ->+ case envLookup env name of+ Nothing -> EvalError $ "unbound variable: " ++ name+ Just value -> EvalOk value++ EBool b -> EvalOk (VBool b)+ EChar c -> EvalOk (VChar c)+ ENumber n -> EvalOk (VNumber n)+ EString n -> EvalOk (VString n)++ EIf t a b ->+ case evalWithLimit t env stacksize' of+ EvalOk (VBool True) -> evalWithLimit a env stacksize'+ EvalOk (VBool False) -> evalWithLimit b env stacksize'+ -- Should there be another case here, where we get+ -- EvalOk(something not boolean) and this should be+ -- an error?+ result -> result++ ELambda _ _ -> error "evalWithLimit: not implemented for lambda expr"+ ECall fsym args ->+ -- evaluating a function call+ -- I assume that call expressions have *symbols* for the + -- functions.+ -- To relax this assumption: change the definition of ECall,+ -- but how will you visualize it?++ case evalWithLimit (ESymbol fsym) env stacksize' of+ EvalOk f -> + case mapM (\ a -> evalWithLimit a env stacksize') args of+ EvalOk argvalues -> apply f argvalues env stacksize'+ -- why doesn't this work? err -> err+ EvalError e -> EvalError e+ EvalUntried -> EvalUntried+ err -> err++ EList elist ->+ case mapM (\ elt -> evalWithLimit elt env stacksize') elist of+ EvalOk values -> EvalOk (VList values)+ EvalError e -> EvalError e+ EvalUntried -> EvalUntried+ _ -> errcats ["evalWithLimit: extended expression not supported",+ show expr]+ +-- | Apply a function fvalue to a list of actual arguments args+-- in an environment env and with a limited stack size stacksize+apply :: Value -> [Value] -> Env -> Int -> EvalResult+apply fvalue args env stacksize =+ case fvalue of+ VFun f ->+ case functionImplementation f of+ Primitive pf -> pf args+ Compound formalArgs body ->+ evalWithLimit body (extendEnv formalArgs args env) stacksize+ not_a_function ->+ EvalError ("apply: first arg is not a function: " ++ + show not_a_function)++-- Shortcuts for making expressions that call the primitive functions+ePlus :: Expr -> Expr -> Expr+ePlus e1 e2 = eCall "+" [e1, e2]++eTimes :: Expr -> Expr -> Expr+eTimes e1 e2 = eCall "*" [e1, e2]++eMinus, eDiv, eMod :: Expr -> Expr -> Expr+eMinus e1 e2 = eCall "-" [e1, e2]+eDiv e1 e2 = eCall "div" [e1, e2]+eMod e1 e2 = eCall "mod" [e1, e2]++eAdd1, eSub1 :: Expr -> Expr+eAdd1 e1 = eCall "add1" [e1]+eSub1 e1 = eCall "sub1" [e1]++eEq, eNe, eGt, eGe, eLt, eLe :: Expr -> Expr -> Expr+eEq e1 e2 = eCall "==" [e1, e2]+eNe e1 e2 = eCall "/=" [e1, e2]+eGt e1 e2 = eCall ">" [e1, e2]+eGe e1 e2 = eCall ">=" [e1, e2]+eLt e1 e2 = eCall "<" [e1, e2]+eLe e1 e2 = eCall "<=" [e1, e2]+++eZerop, ePositivep, eNegativep :: Expr -> Expr+eZerop e1 = eCall "zero?" [e1]+ePositivep e1 = eCall "positive?" [e1]+eNegativep e1 = eCall "negative?" [e1]++-- A good base environment to get started with ++primitiveFunctions :: [Function]+primitiveFunctions = [+ -- Arithmetic+ primN2N "+" (+), -- Number (+)+ primN2N "-" (-),+ primN2N "*" (*),+ primIntDiv,+ primIntMod,+ primFloatDiv,++ primN1N "add1" succ,+ primN1N "sub1" pred,++ -- Comparison+ primN2B "==" (==),+ primN2B "/=" (/=),+ primN2B ">" (>),+ primN2B ">=" (>=),+ primN2B "<" (<),+ primN2B "<=" (<=),++ primN1B "zero?" eqZero,+ primN1B "positive?" gtZero,+ primN1B "negative?" ltZero,++ -- List operations++ -- null xs tells if xs is an empty list+ prim "null" [typeList (TypeVar "a")] + typeBool primNull,++ prim "head" [typeList (TypeVar "b")] + (TypeVar "b")+ primHead,+ prim "tail" [typeList (TypeVar "c")] + (typeList (TypeVar "c"))+ primTail,+ prim ":" [TypeVar "d", typeList (TypeVar "d")]+ (typeList (TypeVar "d"))+ primCons+ ]++type PFun = [Value] -> EvalResult++-- Primitive functions of arbitrary type+prim :: String -> [Type] -> Type -> PFun -> Function+prim name atypes rtype = Function (Just name) atypes rtype . Primitive++-- Primitive arithmetic functions++-- | Integer div and mod operations, for exact integers only.+-- Using an inexact (floating point) argument is an error,+-- even if the argument is "equal" to an integer (e.g., 5.0).+-- Division (div or mod) by zero is an error.+primIntDivMod :: String -> (Number -> Number -> Number) -> Function+primIntDivMod name oper =+ let func args =+ let err msg = EvalError $ concat [name, ": ", msg, + " (", show args, ")"]+ in case args of+ [VNumber a, VNumber b] ->+ if b == 0+ then err "zero divisor"+ else if isExact a && isExact b+ then EvalOk $ VNumber (oper a b)+ else err "arguments must be exact numbers"+ _ -> err "wrong type or number of arguments"+ in prim name [typeNum, typeNum] typeNum func++primIntDiv, primIntMod :: Function+primIntDiv = primIntDivMod "div" div+primIntMod = primIntDivMod "mod" mod++-- | Floating point division.+-- Integer arguments are coerced to floating point,+-- and the result is always floating point.+-- operands are ints. +-- x / 0 is NaN if x == 0, Infinity if x > 0, -Infinity if x < 0.+primFloatDiv :: Function+primFloatDiv =+ let divide args =+ case args of+ [VNumber x, VNumber y] -> EvalOk $ VNumber (x / y)+ _ -> EvalError $ "/: invalid args: " ++ show args+ in prim "/" [typeNum, typeNum] typeNum divide++-- Primitive functions for lists++primArgCountError :: String -> EvalResult+primArgCountError name = + errcat [name, ": wrong number of arguments in primitive function"]++-- Some of the type-checking in these primitive functions+-- shouldn't be necessary, if Sifflet knew the types of the+-- functions and could do type inference and check input values.++primNull :: PFun+primNull args =+ case args of+ [VList list] -> EvalOk $ VBool (List.null list)+ [_] -> EvalError "null: not a list"+ _ -> primArgCountError "primNull"++primHead :: PFun+primHead args =+ case args of+ [VList (x : _xs)] -> EvalOk x+ [VList []] -> EvalError "head: empty list"+ [_] -> EvalError "head: not a list"+ _ -> primArgCountError "primHead"++primTail :: PFun+primTail args =+ case args of+ [VList (_x : xs)] -> EvalOk $ VList xs+ [VList []] -> EvalError "tail: empty list"+ [_] -> EvalError "tail: not a list"+ _ -> primArgCountError "primTail"++primCons :: PFun+primCons args =+ case args of+ [x, VList xs] -> EvalOk $ VList (x:xs)+ [_, _] -> EvalError "cons: second argument not a list"+ _ -> primArgCountError "primCons"++-- Functions for constructing Functions of common types++-- | Primitive function with 2 number arguments yield an number value+-- fn = Number function to implement for Number operands.+primN2N :: String -> (Number -> Number -> Number) -> Function+primN2N name fn =+ let impl args =+ case args of+ [VNumber x, VNumber y] -> EvalOk $ VNumber (fn x y)+ _ -> EvalError $ name ++ ": invalid args: " ++ show args+ in prim name [typeNum, typeNum] typeNum impl++-- | Primitive unary functions number to number+primN1N :: String -> (Number -> Number) -> Function+primN1N name fn = + let impl args =+ case args of+ [VNumber x] -> EvalOk $ VNumber (fn x)+ _ -> EvalError $ name ++ ": invalid args: " ++ show args+ in prim name [typeNum] typeNum impl++-- Primitive frunctions with 2 number args and a boolean result+primN2B :: String -> (Number -> Number -> OBool) -> Function+primN2B name fn =+ let impl args =+ case args of+ [VNumber x, VNumber y] -> EvalOk $ VBool (fn x y)+ _ -> EvalError $ name ++ ": invalid args: " ++ show args+ in prim name [typeNum, typeNum] typeBool impl+++-- Primitive unary functions number to boolean+primN1B :: String -> (Number -> Bool) -> Function+primN1B name fn = + let impl args =+ case args of+ [VNumber x] -> EvalOk $ VBool (fn x)+ _ -> EvalError $ name ++ ": invalid args: " ++ show args+ in prim name [typeNum] typeBool impl++baseEnv :: Env+baseEnv = + makeEnv (map functionName primitiveFunctions)+ (map VFun primitiveFunctions)++-- | Given an expression, return the list of names of variables+-- occurring in the expression+exprSymbols :: Expr -> [Symbol]+exprSymbols expr = + nub $ case expr of+ EUndefined -> [] -- is *not* a variable+ ESymbol s -> [s]+ EIf t a b -> nub $ concat [exprSymbols t,+ exprSymbols a,+ exprSymbols b]+ ELambda x body -> nub (x : exprSymbols body)+ ECall f args -> + case args of+ [] -> [f]+ a:as -> nub $ concat [exprSymbols a,+ exprSymbols (ECall f as)]+ EList items -> nub $ concatMap exprSymbols items+ _ -> if exprIsExtended expr+ then errcats ["exprSymbols: extended expr not supported:",+ show expr]+ else [] -- literal types bool, char, number, string++-- | exprVarNames expr returns the names of variables in expr+-- that are UNBOUND in the base environment. This may not be ideal,+-- but it's a start.++exprVarNames :: Expr -> [String]+exprVarNames expr = [name | (Symbol name) <- exprSymbols expr,+ unbound name baseEnv]
+ lib/Language/Sifflet/ExprTree.hs view
@@ -0,0 +1,227 @@+module Language.Sifflet.ExprTree+ (+ ExprTree, ExprNode(..), ExprNodeLabel(..)+ , exprNodeIoletCounter -- needs work ****** get rid of it???+ , exprToTree, treeToExpr, exprToReprTree+ , evalTree, unevalTree+ )++where++import Data.Number.Sifflet++import Data.Sifflet.Tree as T+import Data.Sifflet.TreeLayout (IoletCounter)++import Language.Sifflet.Expr++import Text.Sifflet.Repr ()++import Language.Sifflet.Util+++-- | +-- EXPRESSION TREES+-- For pure Sifflet, so not defined for extended expressions.++type ExprTree = Tree ExprNode+data ExprNode = ENode ExprNodeLabel EvalResult+ deriving (Eq, Show)++data ExprNodeLabel = NUndefined + | NSymbol Symbol + |+ -- formerly NLit Value+ NBool Bool | NChar Char | NNumber Number + | NString String+ | NList [Expr] -- ???+ deriving (Eq, Show)++instance Repr ExprNode where+ reprl (ENode label evalRes) =+ case label of+ NUndefined ->+ case evalRes of+ EvalUntried -> ["undefined"]+ EvalError e -> ["undefined", "error: " ++ e]+ EvalOk _ -> + errcats ["reprl of ExprNode: NUndefined with EvalOk",+ "should not happen!"]+ NSymbol s ->+ case evalRes of+ EvalOk v -> [repr s, repr v]+ EvalError e -> [repr s, "error: " ++ e]+ EvalUntried -> reprl s++ -- NLit l -> reprl l+ NBool b -> reprl b+ NChar c -> reprl c+ NNumber n -> reprl n+ NString s -> [show s]+ NList es -> reprl (EList es) -- check ***++-- | Counts the number of inlets and outlets for an ExprNode+exprNodeIoletCounter :: Env -> [ArgSpec] -> IoletCounter ExprNode+exprNodeIoletCounter env aspecs (ENode nodeLabel _nodeResult) =+ case nodeLabel of+ NUndefined -> (0, 1)+ NSymbol (Symbol "if") -> (3, 1) + NSymbol (Symbol s) -> + case envLookup env s of+ Nothing -> -- probably a parameter of the function+ case aspecsLookup s aspecs of+ Nothing -> (0, 1)+ Just i -> (i, 1)+ Just value ->+ case value of+ VFun function -> (functionNArgs function, 1)+ _ -> (0, 1) -- symbol bound to non-function value+ _ -> (0, 1)++exprToTree :: Expr -> ExprTree+exprToTree expr =+ let leafnode :: ExprNodeLabel -> T.Tree ExprNode+ leafnode e = node e []+ node :: ExprNodeLabel -> [T.Tree ExprNode] -> T.Tree ExprNode+ node e ts = T.Node (ENode e EvalUntried) ts+ errext = error ("exprToTree: extended expr: " ++ show expr)+ in case expr of+ -- EUndefined, ESymbol, and literals map directly + -- to NUndefined, NSymbol, E(literal-type) + EUndefined -> leafnode NUndefined+ ESymbol s -> leafnode (NSymbol s)++ -- Literals+ EBool b -> leafnode (NBool b)+ EChar c -> leafnode (NChar c)+ ENumber n -> leafnode (NNumber n)+ EString s -> leafnode (NString s)++ -- EIf maps to symbol "if" at the root, 3 subtrees+ EIf t a b -> node (NSymbol (Symbol "if")) (map exprToTree [t, a, b])++ ELambda _x _body -> error "exprToTree: not implemented for lambda expr"+ EApp f arg -> node (NSymbol (Symbol "@")) (map exprToTree [f, arg])+ -- ECall maps to symbol f (function name) at the root,+ -- each argument forms a subtree+ ECall f args -> node (NSymbol f) (map exprToTree args)+ EList xs -> leafnode (NList xs)+ -- Extended Exprs not supported!+ EGroup _ -> errext+ EOp _ _ _ -> errext++-- | Convert an expression tree (back) to an expression+-- It will not give back the *same* expression in the case of an EList.+treeToExpr :: ExprTree -> SuccFail Expr+treeToExpr (T.Node (ENode label _) trees) =+ let lit e = if null trees then Succ e+ else Fail "literal node with non-empty subtrees"+ in case label of+ NUndefined -> Succ EUndefined+ NBool b -> lit (EBool b)+ NChar c -> lit (EChar c)+ NNumber n -> lit (ENumber n)+ NString s -> lit (EString s)+ NList xs -> lit (EList xs)+ NSymbol (Symbol "@") ->+ case trees of+ [f, arg] -> + do+ {+ f' <- treeToExpr f+ ; arg' <- treeToExpr arg+ ; Succ $ EApp f' arg'+ }+ _ -> Fail "'@' node with /= 2 subtrees"+ NSymbol (Symbol "if") ->+ case trees of+ [q, a, b] -> + do+ {+ q' <- treeToExpr q+ ; a' <- treeToExpr a+ ; b' <- treeToExpr b+ ; Succ $ EIf q' a' b'+ }+ _ -> Fail ("An 'if' node has the wrong number of subtrees" +++ " (should be 3)")+ NSymbol s ->+ -- VVV Do I really need to distinguish these two cases?+ if null trees + then + -- s = terminal symbol+ Succ $ ESymbol s + else -- s = function symbol in function call+ do+ {+ trees' <- mapM treeToExpr trees+ ; Succ $ ECall s trees'+ }++-- Convert an expression to a repr tree (of string elements)+-- (Why?)++exprToReprTree :: Expr -> Tree String+exprToReprTree = fmap repr . exprToTree+++-- Evaluate an expression tree showing the evaluation at each node.+-- There's a lot of redundancy in this computation, but does it matter?++evalTree :: ExprTree -> Env -> ExprTree+evalTree atree env = evalTreeWithLimit atree env stackSize++evalTreeWithLimit :: ExprTree -> Env -> Int -> ExprTree+evalTreeWithLimit atree env stacksize =++ let T.Node root subtrees = atree+ ss' = pred stacksize+ in case root of+ ENode (NSymbol (Symbol "if")) _ ->+ case subtrees of+ [tt, ta, tb] ->+ let tt' = evalTreeWithLimit tt env ss'+ ENode _ testResult = rootLabel tt'+ subEval subtree =+ let subtree' = evalTreeWithLimit subtree env ss'+ ENode _ subresult = rootLabel subtree'+ in (subresult, subtree')+ ifNode result = ENode (NSymbol (Symbol "if")) result+ in case testResult of+ EvalOk (VBool True) -> + let (taValue, ta') = subEval ta in+ T.Node (ifNode taValue) [tt', ta', tb]++ EvalOk (VBool False) -> + let (tbValue, tb') = subEval tb in+ T.Node (ifNode tbValue) [tt', ta, tb']++ EvalOk weirdValue ->+ -- This shouldn't happen with proper type+ -- checking!+ let msg = "if: non-boolean condition value: " +++ repr weirdValue+ in T.Node (ifNode (EvalError msg)) [tt', ta, tb]++ EvalError msg ->+ T.Node (ifNode (EvalError msg)) [tt', ta, tb]++ _ -> errcats ["evalTreeWithLimit (if):",+ "unexpected test result"]++ _ -> error "evalTreeWithLimit: if: wrong number of subtrees"++ ENode rootOper _ ->+ let evalResult =+ case treeToExpr atree of+ Succ expr -> evalWithLimit expr env ss'+ Fail msg -> EvalError msg+ in T.Node (ENode rootOper evalResult)+ [evalTreeWithLimit s env ss' | s <- subtrees]++-- remove the values from the ExprNodes+-- "inverse" of evalTree +unevalTree :: ExprTree -> ExprTree+unevalTree atree = + let unevalNode (ENode oper _) = ENode oper EvalUntried+ in fmap unevalNode atree
+ lib/Language/Sifflet/Parser.hs view
@@ -0,0 +1,319 @@+-- | A parser for Sifflet input values.+-- This is not a parser for all Sifflet expressions,+-- but just those that might be input in textual form+-- through the function call dialog that asks for the argument values.+-- So, it is limited (deliberately) to "data" types of expressions:+-- that is, Exprs using the constructors:+-- ELit+-- EList+-- That means excluding Exprs constructed with EUndefined,+-- ESymbol, EIf, ELambda, and ECall.++module Language.Sifflet.Parser+ (parseExpr+ , parseValue+ , parseLiteral+ , parseTest+ , parseSuccFail+ , parseTypedInput2, parseTypedInputs2+ , parseTypedInput3, parseTypedInputs3+ , nothingBut+ , expr, list+ , value, typedValue+ , bool, qchar, qstring, integer, double+ , number+ )++where++import Text.ParserCombinators.Parsec++import Data.Number.Sifflet+import Language.Sifflet.Expr+import Language.Sifflet.Util++-- | Parse a Sifflet data literal (number, string, char, bool, or list),+-- returning an Expr+parseExpr :: String -> SuccFail Expr+parseExpr = parseSuccFail expr++-- | Parse a Sifflet literal expression and return its Value+parseValue :: String -> SuccFail Value+parseValue s =+ -- take a shortcut here?+ -- case parseExpr s of -- stringToExpr s of+ -- Succ expr -> exprToValue expr+ -- Fail errmsg -> Fail errmsg+ parseLiteral s >>= exprToValue++parseLiteral :: String -> SuccFail Expr+parseLiteral s = + -- parseValue s >>= valueToLiteral+ case parseExpr s of+ Succ e -> if exprIsLiteral e+ then Succ e+ else Fail $ + "parseLiteral: expr is non-literal" ++ show e+ Fail errmsg -> Fail errmsg++parseSuccFail :: Parser a -> String -> SuccFail a+parseSuccFail p s =+ case parse p "user input" s of+ Left perr -> Fail (show perr)+ Right v -> Succ v++-- | Try to parse an input value of a specific type+parseTypedInput2 :: (String, Type) -> SuccFail Value+parseTypedInput2 (str, vartype) =+ parseSuccFail (nothingBut (typedValue vartype)) str++-- | Try to parse input values of specific types+parseTypedInputs2 :: [String] -- ^ input strings+ -> [Type] -- ^ expected types+ -> SuccFail [Value]+parseTypedInputs2 strs vartypes = + mapM parseTypedInput2 (zip strs vartypes)++-- | Try to parse an input value for a named variable of a specific type+parseTypedInput3 :: (String, String, Type) -> SuccFail Value+parseTypedInput3 (s, varname, vartype) =+ case parseSuccFail (nothingBut (typedValue vartype)) s of+ Fail msg -> Fail ("For variable " ++ varname ++ ":\n" ++ msg)+ Succ v -> Succ v++-- | Try to parse input values for named variables of specific types+parseTypedInputs3 :: [String] -- ^ inputs+ -> [String] -- ^ variable names+ -> [Type] -- ^ variable types+ -> SuccFail [Value]+parseTypedInputs3 strs varnames vartypes =+ mapM parseTypedInput3 (zip3 strs varnames vartypes)++-- | Like expr, but consumes the entire input,+-- so there must not be any extraneous characters after the Expr.+input :: Parser Expr+input = nothingBut expr++-- | 'nothingBut p is like 'p', but consumes the entire input,+-- so there must be no extraneous characters (except space)+-- after whatever 'p' parses.+nothingBut :: Parser a -> Parser a+nothingBut p = (many space >> p) `prog1` (many space >> eof)++prog1 :: (Monad m) => m a -> m b -> m a+prog1 m1 m2 = m1 >>= (\ r -> m2 >> return r)++-- | Parse a Sifflet data expression -- actually only a literal+-- or a list of literals.+expr :: Parser Expr+expr = -- (try (list expr >>= return . EList)) <|>+ (bool >>= return . EBool) <|>+ (qchar >>= return . EChar) <|>+ (qstring >>= return . EString) <|>+ try (double >>= return . ENumber . Inexact) <|>+ (integer >>= return . ENumber . Exact) <|>+ (list expr >>= return . EList)+ +list :: Parser a -> Parser [a]+list element = + let sep = try (skipMany space >> char ',' >> skipMany space)+ in (char '[' >> many space >> sepBy element sep)+ `prog1`+ (many space >> char ']')+ -- do I need (...) above?+ <?> "list" -- ???++++ +-- | Parser for a Value of any primitive or (concrete) list type++value :: Parser Value+value = (bool >>= return . VBool) <|>+ (qchar >>= return .VChar) <|>+ (qstring >>= return . VString) <|>+ try (double >>= return . VNumber . Inexact) <|>+ (integer >>= return . VNumber . Exact) <|>+ (list value >>= return . VList)++-- | Parser for a value with a specific primitive or concrete list type +-- expected.++typedValue :: Type -> Parser Value+typedValue t = + (case t of+ TypeCons "Bool" [] -> bool >>= return . VBool+ TypeCons "Char" [] -> qchar >>= return . VChar+ TypeCons "String" [] -> qstring >>= return . VString+ TypeCons "Num" [] -> number >>= return . VNumber+ TypeCons "List" [e] -> list (typedValue e) >>= return . VList+ TypeCons "Function" _argTypes -> + fail $ "Sorry, but you cannot input a function here.\n\n" +++ "Note to developer: typedValue needs access to the " +++ "global environment in order to look up function names."+ TypeCons _ _ -> + fail $ "Sorry, but you cannot input that type of value here.\n\n" +++ "Note to developer: typedValue needs to implement " +++ "the type " ++ show t+ TypeVar _ -> value -- can't check, so just accept anything+ )+ <?> typeName t++-- | A name for the type, for use in parser error reporting+typeName :: Type -> String+typeName t =+ let cerr cname = + error ("typeName: improper " ++ cname ++ " type construction")+ primitive tname args =+ case args of+ [] -> tname+ _ -> cerr tname+ in case t of + TypeVar tvn -> tvn -- could be more specific!+ TypeCons "Bool" ts -> primitive "boolean" ts+ TypeCons "Char" ts -> + primitive "character" ts -- "character (in single quotes)"+ TypeCons "Num" ts -> primitive "number" ts+ TypeCons "String" ts -> + primitive "string" ts -- "string (in double quotes)"+ TypeCons "List" [e] -> "list of " ++ typeName e+ TypeCons "List" _ -> cerr "List"+ TypeCons "Function" [_, _] -> "function" -- ???+ TypeCons "Function" _ -> cerr "Function"+ TypeCons tname texprs -> tname ++ " " ++ show (map typeName texprs)++bool :: Parser Bool+bool = (try (string "True" >> return True) <|>+ (string "False" >> return False))+ <?> typeName typeBool+++-- quoted character 'c'+qchar :: Parser Char+qchar = + let sq = '\'' -- single quote character+ in (((char sq <?> "opening single quote") >> + (try escapedChar <|> noneOf [sq])) + `prog1`+ (char sq <?> "closing single quote")+ )+ <?> typeName typeChar+ +-- quoted string "c..."++qstring :: Parser String+qstring = + let dq = '\"' -- double quote character+ in (char dq >> + many (escapedChar <|> noneOf [dq] <?> "")) + `prog1` + (char dq <?> "close of quotation")+ -- Do I need (...) above?+ <?> typeName typeString++-- escapedChar recognizes the following escape sequences:+-- \t = tab+-- \n = newline+-- \r = carriage return+-- \\ = backslash+-- Anything else that begins with \ is an error.++escapedChar :: Parser Char+escapedChar = + let bs = '\\' -- backslash character+ in char bs >> + (oneOf "ntr\\" <?> "n, t, r, or \\ to follow \\") >>=+ (\ c ->+ return (case c of+ 'n' -> '\n'+ 't' -> '\t'+ 'r' -> '\r'+ '\\' -> '\\'+ _ -> error "escapedChar: c MUST be n, t, r, or \\"+ )+ )++data Sign = Minus | Plus++-- Integer ::= (+|-)? digit+++integer :: Parser Integer -- sign, digits+integer = do { s <- optSign;+ u <- unsignedInteger;+ return (applySign s u)+ }+ <?> "integer"++unsignedInteger :: Parser Integer+unsignedInteger = many1 digit >>= return . read++-- An optional + or - defaulting to +++optSign :: Parser Sign -- 1: negative; 0: non-negative+optSign = try ( char '-' >> return Minus ) <|>+ try ( char '+' >> return Plus ) <|>+ return Plus++applySign :: (Num n) => Sign -> n -> n+applySign s x =+ case s of + Minus -> (- x)+ Plus -> x++-- A double (float) may begin with a sign (+ or -) and must contain+-- a decimal point along with at least one digit before and/or after+-- the decimal point.+-- So there are three cases:+-- [sign] digits '.' digits+-- [sign] digits '.'+-- [sign] '.' digits++double :: Parser Double++-- Double FAILS if there is a decimal point.+-- It succeeds in the following cases:++double = + let digits1 = many1 digit+ point = char '.'+ -- wpf: whole-part point fraction-part+ wpf = do { dd <- digits1;+ dd' <- point >> digits1;+ return (dd, dd')+ }+ -- wp: whole-part point+ wp = do { dd <- digits1 `prog1` point;+ return (dd, "0")+ }+ -- pf: point fraction-part+ pf = do { dd' <- point >> digits1;+ return ("0", dd')+ }+ -- optional trailing exponent notation e.g. e-4+ scale = do { i <- oneOf "eE" >> integer;+ return (10 ** fromIntegral i)+ }+ <|> return 1++ in do { sign <- optSign+ ; (whole, frac) <- (try wpf <|>+ try wp <|>+ try pf)+ ; m <- scale;+ ; let w = read (whole ++ ".0") -- whole part as number+ f = read ("0." ++ frac) -- frac part as number+ ; return (m * applySign sign (w + f))+ }+ <?> "real number"++-- A number is a Sifflet Number, which is exact unless it contains+-- a decimal point.+-- To avoid consuming "123" from "123." and interpreting it as an exact+-- number, we MUST try to parse double before integer.+number :: Parser Number+number = (try (double >>= return . Inexact) <|> + (integer >>= return . Exact))+ <?> typeName typeNum+++
+ lib/Language/Sifflet/SiffML.hs view
@@ -0,0 +1,476 @@+-- | SiffML : Sifflet Markup Language.+-- An XML application for storing and retrieving Sifflet programs+-- and libraries.++module Language.Sifflet.SiffML+ (+ ToXml(..)+ , produceSiffMLFile+ , consumeSiffMLFile+ , xmlToFunctions+ -- for testing+ , testFromXml+-- , consumeString+ )++where++import Text.XML.HXT.Core++import Data.Number.Sifflet+import Language.Sifflet.Expr+import Language.Sifflet.Util++class ToXml a where+ toXml :: a -> XMLProducer++-- | An XMLProducer produces XML+type XMLProducer = IOSLA (XIOState ()) XmlTree XmlTree++-- | An XMLConsumer consumes XML+type XMLConsumer a b = IOSLA (XIOState ()) a b++defaultOptions :: SysConfigList+defaultOptions = [withIndent yes, withValidate no ]++produceSiffMLFile :: (ToXml a) => a -> FilePath -> IO ()+produceSiffMLFile src path = + let arrow :: XMLProducer+ arrow = toXml src+ options = defaultOptions+ in do+ {+ putStrLn ""+ ; [rc] <- runX (root [] [arrow] >>>+ writeDocument options path >>>+ getErrStatus)+ ; putStrLn (case rc of+ 0 -> "Okay"+ _ -> "Failed")++ }+consumeSiffMLFile :: XMLConsumer XmlTree a -> FilePath -> IO [a]+consumeSiffMLFile fromXml filePath =+ let options = defaultOptions+ in do+ doc <- readFile filePath+ runX (readString options doc >>> fromXml)++-- | Symbols++instance ToXml Symbol where+ toXml = symbolToXml++symbolToXml :: Symbol -> XMLProducer+symbolToXml (Symbol name) =+ selem "symbol" [txt name]+++-- | Expr++instance ToXml Expr where+ toXml = exprToXml++exprToXml :: Expr -> XMLProducer+exprToXml expr =+ let literal label text = + -- future: (omit label arg.): selem label [txt text]+ selem "literal" [selem label [txt text]]+ in case expr of+ EUndefined -> + eelem "undefined"+ ESymbol (Symbol name) -> + selem "symbol" [txt name]++ -- "Literals"+ -- New way: duplicates parts of valueToXml (bad) ***+ EBool b -> + -- future: selem "bool" [eelem (show b)]+ selem "literal" [selem "bool" [eelem (show b)]]+ EChar c ->+ -- future: selem "char" [txt [c]]+ literal "char" [c]+ ENumber (Exact i) ->+ -- future: selem "int" [txt (show i)]+ literal "int" (show i)+ ENumber (Inexact x) ->+ -- future: selem "float" [txt (show x)]+ literal "float" (show x)+ EString s ->+ -- future: selem "string" [txt s]+ literal "string" s++ EIf e1 e2 e3 -> + selem "if" [toXml e1, toXml e2, toXml e3]+ EList xs -> + -- I predict that this is going to be troublesome! ***+ -- No checking for whether the list elements are literals!+ selem "literal" [selem "list" + (map (toXml . literalToValue) xs)]+ -- future: selem "list" (map toXml xs)+ ELambda _ _ -> error "exprToXml: not implemented for lambda expr"+ ECall (Symbol name) xs -> + selem "call" + (selem "symbol" [txt name] :+ map toXml xs)+ _ -> errcats ["exprToXml: extended expr:", show expr]++-- | Convert a literal expression to a value.+-- It is an error if the expr is not a literal.+-- Compare exprToValue in Expr.hs+literalToValue :: Expr -> Value+literalToValue e =+ if exprIsLiteral e+ then case e of+ EBool b -> VBool b+ EChar c -> VChar c+ ENumber n -> VNumber n+ EString s -> VString s+ EList es -> VList (map literalToValue es)+ EGroup e' -> literalToValue e'+ _ -> error "literalToValue: expr is literal, but not literal?"+ else error ("literalToValue: expr is not a literal: " ++ show e)++xmlToExpr :: XMLConsumer XmlTree Expr+xmlToExpr = + isElem >>>+ (+ (hasName "undefined" >>> constA EUndefined) <+>+ (hasName "symbol" >>> getChildren >>> isText >>> getText >>>+ arr (ESymbol . Symbol)) <+>++ -- future: remove extra level "literal"+ (hasName "literal" >>> getChildren >>> xmlToExpr) <+>++ -- boolean values+ (hasName "True" >>> constA (EBool True)) <+>+ (hasName "False" >>> constA (EBool False)) <+>++ -- chars+ (hasName "char" >>> getChildren >>> isText >>> getText >>>+ -- VVV head dangerous ???+ arr (EChar . head)) <+>++ -- numbers -- why not use parser instead of read???+ (hasName "int" >>> getChildren >>> isText >>> getText >>>+ arr (ENumber . Exact . read)) <+> -- read dangerous?+ (hasName "float" >>> getChildren >>> isText >>> getText >>>+ arr (ENumber . Inexact . read)) <+> -- read dangerous?+ + -- strings+ (hasName "string" >>> getChildren >>> isText >>> getText >>> + arr EString) <+>+++ (hasName "if" >>> listA (getChildren >>> xmlToExpr) >>> + -- sometimes I get bogus run-time errors here about+ -- this pattern [a, b, c] being non-exhaustive.+ -- Of course, it *is* non-exhaustive; but it is+ -- never violated in practice+ arr (\ [a, b, c] -> EIf a b c)) <+>+ -- This is very awkward, but needed for compatibility with the+ -- present SiffML doctype:+ (hasName "list" >>> + -- future?: listA (getChildren >>> xmlToExpr) >>> + -- Anyway, *why* does this not work???+ listA (getChildren >>> xmlToExpr) >>> + -- past?:+ -- listA (getChildren >>> xmlToValue >>> arr valueToLiteral') >>> + arr EList) <+>+ -- VVV Would be less awkward if ECall :: Symbol -> [Expr] -> Expr+ -- were changed to ECall :: Expr -> [Expr] -> Expr+ (hasName "call" >>> listA (getChildren >>> xmlToExpr) >>>+ arr (\ (ESymbol symf : args) -> ECall symf args))+ )++-- | Values+-- Still used in exprToXml in the EList case :-(++instance ToXml Value where+ toXml = valueToXml++-- Is this still needed? ***+valueToXml :: Value -> XMLProducer+valueToXml value =+ case value of+ VBool b ->+ -- <True/> or <False/> + -- complicate? selem "bool" [txt (show b)]+ eelem (show b)+ VChar c ->+ selem "char" [txt [c]]+ VString s ->+ selem "string" [txt s]+ VNumber (Exact i) ->+ selem "int" [txt (show i)]+ VNumber (Inexact x) ->+ selem "float" [txt (show x)]+ -- Are VFun and VList needed???+ VFun f ->+ selem "function" [toXml f]+ VList vs ->+ selem "list" (map toXml vs)++-- xmlToValue: still needed? ***+xmlToValue :: XMLConsumer XmlTree Value+xmlToValue = + isElem >>>+ ((hasName "True" >>> constA (VBool True)) <+>+ (hasName "False" >>> constA (VBool False)) <+>+ (hasName "char" >>> getChildren >>> isText >>> getText >>>+ arr (VChar . head)) <+>+ (hasName "string" >>> getChildren >>> isText >>> getText >>> + arr VString) <+>+ (hasName "int" >>> getChildren >>> isText >>> getText >>>+ arr (VNumber . Exact . read)) -- dangerous?+ <+>+ (hasName "float" >>> getChildren >>> isText >>> getText >>>+ arr (VNumber . Inexact . read)) -- dangerous?++ <+>+ (hasName "function" >>> getChildren >>> xmlToFunction >>> arr VFun) ++ <+>+ -- listA arr collects the results of arr into a list, so to speak;+ -- note that listA (arr1 >>> arr2) + -- does not equal listA arr1 >>> listA arr2+ -- and probably will not even have a well-defined type.+ -- In particular:+ -- getChildren --> [child1]+ -- listA getChildren --> [childi for i = 1 to n]+ -- listA getChildren >>> xmlToValue+ -- --> [child1] if child1 passes xmlToValue (it does not)+ -- listA (getChildren >>> xmlToValue)+ -- --> [childi for i = 1 to n if childi passes xmlToValue]+ (hasName "list" >>> listA (getChildren >>> xmlToValue) >>>+ arr VList)+ )++-- | Types++instance ToXml Type where+ toXml = typeToXml++typeToXml :: Type -> XMLProducer+typeToXml vtype =+ case vtype of+ TypeVar typeVarName -> selem "type-variable" [txt typeVarName]+ TypeCons "String" [] -> eelem "string-type"+ TypeCons "Char" [] -> eelem "char-type"+ TypeCons "Num" [] -> eelem "num-type"+ TypeCons "Bool" [] -> eelem "bool-type"+ TypeCons "List" [eltType] -> selem "list-type" [typeToXml eltType]+ TypeCons "Function" [argT, resultT] -> + selem "function-type" [typeToXml argT, typeToXml resultT]+ -- error "typeToXml: TypeCons Function cannot be converted to XML"+ TypeCons _ _ ->+ errcats ["typeToXml:", show vtype, "cannot be converted to XML"]++xmlToType :: XMLConsumer XmlTree Type+xmlToType =+ isElem >>> + ((hasName "string-type" >>> constA typeString) <+>+ (hasName "char-type" >>> constA typeChar) <+>+ (hasName "num-type" >>> constA typeNum) <+>+ (hasName "bool-type" >>> constA typeBool) <+>+ (hasName "list-type" >>> getChildren >>> xmlToType >>> arr typeList) <+>+ (hasName "function-type" >>> + listA (getChildren >>> xmlToType) >>>+ -- there must be exactly two children, but I'm not checking+ arr (\ ts -> TypeCons "Function" ts)) <+>+ (hasName "type-variable" >>> getChildren >>>+ isText >>> getText >>> arr TypeVar)+ )++-- | Functions++instance ToXml Function where+ toXml = functionToXml++functionToXml :: Function -> XMLProducer+functionToXml (Function mName argTypes retType impl) =+ case impl of+ Primitive _ ->+ -- shouldn't happen+ errcats ["functionToXml:",+ "primitive functions cannot be exported to XML",+ show (mName, argTypes, retType)]+ Compound argNames body ->+ selem "compound-function"+ (let name s = selem "name" [txt s]+ rest = + [selem "return-type" [typeToXml retType],+ selem "arg-types" (map typeToXml argTypes),+ selem "arg-names" (map name argNames),+ selem "body" [toXml body]]+ in case mName of+ Nothing -> rest+ Just fName -> name fName : rest+ )++xmlToFunction :: XMLConsumer XmlTree Function+xmlToFunction = + let getChildElem :: XMLConsumer XmlTree XmlTree+ getChildElem = getChildren >>> isElem++ getFuncName :: XMLConsumer XmlTree String+ getFuncName = hasName "name" >>> getChildren >>> isText >>> getText++ getReturnType :: XMLConsumer XmlTree Type+ getReturnType = hasName "return-type" >>> getChildren >>> xmlToType++ getArgTypes :: XMLConsumer XmlTree [Type]+ getArgTypes = hasName "arg-types" >>> + listA (getChildren >>> xmlToType)++ getArgNames :: XMLConsumer XmlTree [String]+ getArgNames = hasName "arg-names" >>> + listA (getChildElem >>> getFuncName)++ getBody :: XMLConsumer XmlTree Expr+ getBody = hasName "body" >>> getChildren >>> xmlToExpr ++ in + isElem >>> hasName "compound-function" >>> + -- NOTE:+ -- If arr1 "produces" a, and arr2 "produces" b,+ -- then (arr1 &&& arr2) "produces" (a, b).+ (+ ( -- function name is optional, though it *should* be in the XML file+ listA (getChildElem >>> getFuncName)) &&& + (getChildElem >>> getReturnType) &&&+ (getChildElem >>> getArgTypes) &&&+ (getChildElem >>> getArgNames) &&&+ (getChildElem >>> getBody)+ )+ >>>+ (arr (\ (names, (returnType, (argTypes, (argNames, body)))) -> + Function (case names of + [] -> Nothing+ (fname : _) -> (Just fname)+ )+ argTypes+ returnType (Compound argNames body)))++functionsToXml :: Functions -> XMLProducer+functionsToXml (Functions fs) =+ selem "functions" (map toXml fs)++xmlToFunctions :: XMLConsumer XmlTree Functions+xmlToFunctions =+ isElem >>> -- document root+ getChildren >>>+ hasName "functions" >>>+ listA (getChildren >>> xmlToFunction) >>>+ arr Functions++instance ToXml Functions where+ toXml = functionsToXml++-- -- | Examples and tests++-- exampleFunction :: Function+-- exampleFunction = +-- let esym = ESymbol . Symbol+-- in Function (Just "cincr") +-- [typeBool, typeNum, typeNum]+-- typeNum+-- (Compound ["incr", "a", "b"]+-- (EIf (esym "incr")+-- (ECall (Symbol "+") [esym "a", esym "b"])+-- (esym "a")))++-- -- | This is for testing, when I don't know the type +-- -- of the result I'm getting+-- xmlToX :: XMLConsumer XmlTree Functions -- [Function] -- XmlTree+-- xmlToX = +-- isElem -- document root+-- >>>+-- getChildren+-- >>>+-- hasName "functions" +-- >>>+-- listA (getChildren >>> xmlToFunction) +-- >>>+-- arr Functions++-- -- | Tests++-- testOut :: IO ()+-- testOut = +-- produceStdout (Functions [exampleFunctions !! 0, exampleFunctions !! 1])+++-- testFromFile :: (Show a) => XMLConsumer XmlTree a -> FilePath -> IO ()+-- testFromFile fromXml filePath = do+-- {+-- results <- consumeSiffMLFile fromXml filePath+-- ; putStrLn ""+-- ; print (length results)+-- ; print results+-- ; putStrLn ""+-- }++-- testIn :: (Show a) => XMLConsumer XmlTree a -> IO ()+-- testIn fromXml = testFromFile fromXml "-"++-- UNUSED:++-- | testFromXml :: (ToXml a, Show a) => a -> XMLConsumer XmlTree a -> IO ()+-- VVV This type generalization (a, a to a, b) is for debugging, undo it later:+testFromXml :: (ToXml a, Show b) => Int -> a -> XMLConsumer XmlTree b -> IO ()+testFromXml traceLevel src consumer = do+ {+ produceSiffMLFile src "test.xml"+ ; results <- runX (readDocument + (defaultOptions ++ [withTrace traceLevel])+ "test.xml" >>>+ isElem >>> -- document root+ getChildren >>>+ consumer)+ ; case results of+ [] -> putStrLn "Failed"+ result : _ -> print result+ }++-- testToXmlAndBack :: (ToXml a, Show a) => a -> XMLConsumer XmlTree a -> IO ()+-- testToXmlAndBack = testFromXml+++-- xmlToSymbol :: XMLConsumer XmlTree Symbol+-- xmlToSymbol = +-- isElem >>> hasName "symbol" >>> -- symbol element+-- getChildren >>> isText >>> -- text element+-- getText >>> -- String+-- arr Symbol -- quasi (return . Symbol)++-- testXmlToSymbol :: Symbol -> IO ()+-- testXmlToSymbol sym = testFromXml sym xmlToSymbol++++-- produceStdout :: (ToXml a) => a -> IO ()+-- produceStdout src = produceSiffMLFile src "-"+++-- produceXmlTrees :: (ToXml a) => a -> IO [XmlTree]+-- produceXmlTrees src = +-- let arrow :: XMLProducer+-- arrow = toXml src+-- options = defaultOptions+-- in do+-- {+-- putStrLn ""+-- ; docs <- runX (root [] [arrow] >>> writeDocument options "-")+-- ; case docs of+-- [] -> putStrLn "Failed"+-- doc : _ ->+-- print doc+-- ; return docs++-- }++++-- consumeStdin :: XMLConsumer XmlTree a -> IO [a]+-- consumeStdin fromXml = consumeSiffMLFile fromXml "-"
+ lib/Language/Sifflet/TypeCheck.hs view
@@ -0,0 +1,592 @@+module Language.Sifflet.TypeCheck+ (valueType, typeCheckValues+ , typeVarsIn+ , Subst+ , subst, substComp, idSubst, deltaSubst+ , extend, unify+ , TypeScheme(..), schematicsTS, unknownsTS, substTS+ , TypeEnv, emptyTypeEnv, install, unknownsTE, substTE+ , NameSupply(..), newNameSupply, nameSupplyNext, nameSupplyTake+ , tcExpr, tcExprs+ , tcVar, newInstance+ , arrow+ , envToTypeEnv, baseTypeEnv+ , fromLambdaType, decideTypes+ )++where++-- drop after debugging:+import Debug.Trace++import Control.Monad (foldM)++import qualified Data.List as AList (lookup)++import Data.Map as Map hiding (filter, foldr, lookup, map, null)+import qualified Data.Map as Map (map, lookup)++import Text.Printf++import Language.Sifflet.Expr+import Text.Sifflet.Repr+import Language.Sifflet.Util+++-- | Determine the type of a value.+-- May result in a type variable.++valueType :: Value -> SuccFail Type+valueType v =+ case v of+ VBool _ -> Succ typeBool+ VChar _ -> Succ typeChar+ VNumber _ -> Succ typeNum+ VString _ -> Succ typeString+ VFun (Function _ atypes rtype _) -> Succ $ typeFunction atypes rtype++ VList [] -> Succ $ typeList $ TypeVar "list_element"+ VList (x:xs) -> + do+ xtype <- valueType x+ xstypes <- mapM valueType xs+ if filter (/= xtype) xstypes == []+ then Succ $ typeList xtype+ else Fail "list with diverse element types"++-- | Check whether the values agree with the types (which may be abstract)+--+-- This is *probably* too lenient in the case of type variables:+-- it can pass a mixed-type list.++typeCheckValues :: [String] -> [Type] -> [Value] -> SuccFail [Value]+typeCheckValues names types values =+ let check :: (Map String Type) -> [String] -> [Type] -> [Value] + -> SuccFail [Value]+ check _ [] [] [] = Succ []+ check env (n:ns) (t:ts) (v:vs) = + case typeMatch t v env of+ Succ env' -> check env' ns ts vs >>= Succ . (v:)+ Fail msg -> Fail $ "For variable " ++ n ++ ":\n" ++ msg+ check _ _ _ _ = error "typeCheckValues: mismatched list lengths"+ in check empty names types values+ +++-- | Try to match a single type and value,+-- may result in binding a type variable in a new environment+-- or just the old environment+-- (Note that this tries to produce a map of type variable names to Types,+-- instead of TypeSchemes as with TypeEnv below)+typeMatch :: Type -> Value -> (Map String Type) -> SuccFail (Map String Type)+typeMatch atype value env = + let sorry x etype =+ Fail $ repr x ++ ": " ++ etype ++ " expected"+ in case (atype, value) of+ -- easy cases+ (TypeCons "Bool" [], VBool _) -> Succ env+ (TypeCons "Bool" [], x) -> sorry x "True or False"+ (TypeCons "Char" [], VChar _) -> Succ env+ (TypeCons "Char" [], x) -> sorry x "character"+ (TypeCons "Num" [], VNumber _) -> Succ env+ (TypeCons "Num" [], x) -> sorry x "number"+ (TypeCons "String" [], VString _) -> Succ env+ (TypeCons "String" [], x) -> sorry x "string"+ -- VV Harder+ -- VV Are the avalues below supposed to be equal to the value above?+ (TypeVar name, avalue) -> + case Map.lookup name env of+ Nothing -> + -- bind type variable+ valueType avalue >>= \ vtype -> + Succ $ Map.insert name vtype env+ Just concreteType -> typeMatch concreteType avalue env+ (TypeCons "List" [etype], VList lvalues) ->+ case lvalues of+ [] -> Succ env+ v:vs -> + typeMatch etype v env >>= + typeMatch (typeList etype) (VList vs)+ (TypeCons "Function" [_, _], _) ->+ -- this will require matching type variables with type variables!+ error "typeMatch: unimplemented case for TypeCons Function"+ _ -> Fail $ "type mismatch: " ++ show (atype, value)+++-- The rest of this is based (loosely and conceptually) on the type checker+-- chapters 8-9 of Simon L. Peyton Jones, The Implementation of Functional+-- Programming Languages, Prentice Hall, 1987.+-- Out of print but available on the web at+-- http://research.microsoft.com/en-us/um/people/simonpj/papers/slpj-book-1987/+--+-- Chapter 8: Polymorphic Type Checking, by Peter Hancock.+-- Chapter 9: A Type-Checker, by Peter Hancock.++-- 9.2 Representation of Type Expressions+-- ('a -> b' means the textbook notation 'a' corresponds (at least roughly)+-- to the Sifflet code 'b'.)+-- tvname -> Language.Sifflet.Expr.TypeVarName+-- type_exp -> Language.Sifflet.Expr.Type+-- tvars_in -> typeVarsIn++typeVarsIn :: Type -> [TypeVarName]+typeVarsIn atype =+ let tvarsIn atype' result =+ case atype' of+ TypeVar vname -> vname : result+ TypeCons _ctor ts -> foldr tvarsIn result ts+ -- TypeList t -> foldr tvarsIn result [t]+ -- TypeFunction ats rt -> foldr tvarsIn result (rt:ats)+ -- _ -> []+ in tvarsIn atype []++-- 9.3 Success and Failure+-- reply -> Language.Sifflet.Util.SuccFail++-- 9.4 Solving Equations+-- 9.4.1 Substitutions+-- subst -> Subst+-- sub_type -> subst+-- scomp -> substComp+-- id_subst -> idSubst+-- delta -> deltaSubst++-- | The type of a substitution function, which maps type variables to types++type Subst = TypeVarName -> Type++-- | Apply a substitution function to a type (possibly a type with variables)++subst :: Subst -> Type -> Type+subst phi typeExpr =+ case typeExpr of+ TypeVar tvn -> phi tvn+ -- TypeList etype -> TypeList (subst phi etype)+ -- TypeFunction atypes rtype -> + -- TypeFunction (map (subst phi) atypes) (subst phi rtype)+ TypeCons ctor atypes ->+ TypeCons ctor (map (subst phi) atypes)++-- | Composing two substitutions++substComp :: Subst -> Subst -> Subst+substComp sub2 sub1 tvn = subst sub2 (sub1 tvn)++-- | Identity substitution++idSubst :: Subst+idSubst tvn = TypeVar tvn++-- | A delta substitution is one that affects just a single variable.++deltaSubst :: TypeVarName -> Type -> Subst+deltaSubst tvn typeExpr tvn' =+ if tvn == tvn'+ then typeExpr+ else TypeVar tvn'++-- 9.4.2. Unification+-- extend -> extend+-- unify -> unify+-- unifyl -> unifyList++-- | Try to extend a substitution by adding a single variable-value pair++extend :: Subst -> TypeVarName -> Type -> SuccFail Subst+extend phi tvn t =+ if t == TypeVar tvn+ then Succ phi+ else if tvn `elem` typeVarsIn t+ then Fail ("occurs check: " ++ tvn ++ " is in " ++ (show t))+ else Succ (deltaSubst tvn t `substComp` phi)++-- extend is untested; we can wait until unify to test++unify :: Subst -> (Type, Type) -> SuccFail Subst+unify phi (TypeVar tvn, t) =+ if phi tvn == TypeVar tvn+ then extend phi tvn (subst phi t)+ else unify phi (phi tvn, subst phi t)+unify phi (TypeCons tcn ts, TypeVar tvn) =+ unify phi (TypeVar tvn, TypeCons tcn ts)+unify phi types@(TypeCons tcn ts, TypeCons tcn' ts') =+ if tcn == tcn'+ then unifyList phi (zip ts ts')+ else Fail ("cannot unify " ++ show (fst types) ++ + " with " ++ show (snd types))++unifyList :: Subst -> [(Type, Type)] -> SuccFail Subst+unifyList = foldM unify++-- 9.5 Keeping track of types+-- 9.5.2 Look to the variables+-- type_scheme -> TypeScheme+-- SCHEME -> TypeScheme+-- unknowns_scheme -> unknownsTS+-- sub_scheme -> substTS++-- | A TypeScheme (TypeScheme schematicVariables typeExpression)+-- is a sort of type template, in which+-- schematic variables (i.e., type parameters or "generics")+-- are made explicit; any other type variables+-- in the type expression are unknowns++data TypeScheme = TypeScheme [TypeVarName] Type+ deriving (Eq, Show)++schematicsTS :: TypeScheme -> [TypeVarName]+schematicsTS (TypeScheme schVars _) = schVars++unknownsTS :: TypeScheme -> [TypeVarName]+unknownsTS (TypeScheme schVars t) =+ [tv | tv <- typeVarsIn t, not (tv `elem` schVars)]++-- | Apply a substitution to a type scheme, taking care to affect+-- only the unknowns, not the schematic variables++substTS :: Subst -> TypeScheme -> TypeScheme+substTS phi (TypeScheme schVars t) =+ let phi' :: Subst+ phi' tvn =+ -- phi' is like phi but excludes the schematic variables+ if tvn `elem` schVars+ then TypeVar tvn+ else phi tvn+ in TypeScheme schVars (subst phi' t)++-- 9.5.3 Type environments+-- I'll use maps instead of association lists+-- type_env -> TypeEnv+-- unknowns_te -> unknownsTE+-- sub_te -> substTE++-- | A type environment maps type variable names to type schemes.+-- Oh, is it really type variable names, or just names?+-- It seems to me that in envToTypeEnv, it's function names,+-- instead of type variable names.++type TypeEnv = Map TypeVarName TypeScheme++emptyTypeEnv :: TypeEnv+emptyTypeEnv = Map.empty++-- -- | The domain of a type environment++-- dom :: TypeEnv -> [TypeVarName]+-- dom = keys++-- | The range of a type environment++rng :: TypeEnv -> [TypeScheme]+rng = elems++-- -- | The type scheme value of a type variable name+-- -- This will fail, of course, if the variable name is not+-- -- bound in the type environment.+-- val :: TypeEnv -> TypeVarName -> TypeScheme+-- val = (!)++-- | Insert a new type variable and its type scheme value+install :: TypeEnv -> TypeVarName -> TypeScheme -> TypeEnv+install te tvn ts = insert tvn ts te++-- | The unknowns of a type environment++unknownsTE :: TypeEnv -> [TypeVarName]+unknownsTE gamma = concatMap unknownsTS (rng gamma)++substTE :: Subst -> TypeEnv -> TypeEnv+substTE phi gamma = Map.map (substTS phi) gamma++-- 9.6 New variables+-- I diverge from the "easy" way given in the book++-- | A source of variable names++data NameSupply = NameSupply TypeVarName Int -- prefix, count+ deriving (Eq, Show)++-- | Creates a name supply++newNameSupply :: TypeVarName -> NameSupply+newNameSupply prefix = NameSupply prefix 1++-- | Produces next variable from a name supply++nameSupplyNext :: NameSupply -> (TypeVarName, NameSupply)+nameSupplyNext (NameSupply prefix count) =+ (prefix ++ show count, NameSupply prefix (count + 1))++-- | Produces next several variables from a name supply++nameSupplyTake :: NameSupply -> Int -> ([TypeVarName], NameSupply)+nameSupplyTake (NameSupply prefix count) n =+ ([prefix ++ show i | i <- [count .. count+n-1]],+ NameSupply prefix (count + n))++-- 9.7 The type checker+-- tc -> tcExpr+-- tcl -> tcExprs (type checks a list of Expr)+-- +-- Additional functions (?) tcExprTree ??++-- | Type check an expression++tcExpr :: TypeEnv -> NameSupply -> Expr -> SuccFail (Subst, Type, NameSupply)+tcExpr te ns expr =+ let prim ptype = Succ (idSubst, ptype, ns)+ in case expr of+ EUndefined -> + let (tvn, ns') = nameSupplyNext ns+ in Succ (idSubst, TypeVar tvn, ns')++ EBool _ -> prim typeBool+ EChar _ -> prim typeChar+ ENumber _ -> prim typeNum+ EString _ -> prim typeString++ ESymbol (Symbol name) -> tcVar te ns name+ EIf c a b -> tcIf te ns c a b+ EList exprs -> tcList te ns exprs+ ELambda (Symbol x) body -> tcLambda te ns x body+ EApp f arg -> tcApp te ns f arg+ ECall _ _ -> tcExpr te ns (callToApp expr)++ -- EOp and EGroup are not needed in Sifflet itself,+ -- only for export+ EOp _op _ _ -> Fail "tcExpr: not implemented for EOp"+ EGroup e -> tcExpr te ns e++-- 9.7.1 Type checking lists of expressions+-- tcl -> tcExprs+-- tcl1 -> tcExprs1+-- tcl2 -> tcExprs2+-- This occurs in "two stages":+-- 1. Type check each expression in the list, building up the +-- type environment as we scan through it.+-- 2. Cumulatively compose all the substitutions found,+-- and make sure each type found is a fixed point of the+-- final substitution.+-- NOTE: This is to check a list of Exprs, not an Expr of the type EList.+-- See tcList.++tcExprs :: TypeEnv -> NameSupply -> [Expr] + -> SuccFail (Subst, [Type], NameSupply)+tcExprs _te ns [] = Succ (idSubst, [], ns)+tcExprs te ns (e:es) = do+ {+ (phi, t, ns') <- tcExpr te ns e+ ; tcExprs1 te ns' es phi t+ }++tcExprs1 :: TypeEnv -> NameSupply -> [Expr] -> Subst -> Type+ -> SuccFail (Subst, [Type], NameSupply)+tcExprs1 te ns es phi t = do+ {+ (psi, ts, ns') <- tcExprs (substTE phi te) ns es+ ; tcExprs2 phi t psi ts ns'+ }++tcExprs2 :: Subst -> Type -> Subst -> [Type] -> NameSupply+ -> SuccFail (Subst, [Type], NameSupply)+tcExprs2 phi t psi ts ns =+ Succ (substComp psi phi, subst psi t : ts, ns)++-- 9.7.2 Type checking variables+-- tcvar -> tcVar+-- newinstance -> newInstance+-- al_to_subst -> alistToSubst++-- | Type check a variable (actually the variable name).+-- Find the type scheme associated with the variable in the type environment.+-- Return a "new instance" of the type scheme, in which its schematic variables+-- are replaced by new variables, and the unknowns are left as they are.++tcVar :: TypeEnv -> NameSupply -> String -> SuccFail (Subst, Type, NameSupply)+tcVar te ns name =+ case Map.lookup name te of+ Nothing -> + Fail ("BUG in type checker: tcVar: unable to find " ++ name ++ + " in type environment")+ Just ntype ->+ let (t, ns') = newInstance ns ntype+ in Succ (idSubst, t, ns')++newInstance :: NameSupply -> TypeScheme -> (Type, NameSupply)+newInstance ns (TypeScheme schVars t) =+ let (names, ns') = nameSupplyTake ns (length schVars)+ alist = zip schVars names+ phi = alistToSubst alist+ in (subst phi t, ns')++-- | Convert an association list of type variable names into a substitution++alistToSubst :: [(TypeVarName, TypeVarName)] -> Subst+alistToSubst alist tvn =+ case AList.lookup tvn alist of+ Just tvn' -> TypeVar tvn'+ Nothing -> TypeVar tvn++-- 9.7.3 Type checking application+-- tcap -> tcApp+-- a $arrow b -> a `arrow` b = TypeCons "Function" [a, b]++tcApp :: TypeEnv -> NameSupply -> Expr -> Expr+ -> SuccFail (Subst, Type, NameSupply)+tcApp te ns e1 e2 = + let (tvn, ns') = nameSupplyNext ns+ in do+ (phi, [t1, t2], ns'') <- tcExprs te ns' [e1, e2]+ phi' <- unify phi (t1, t2 `arrow` (TypeVar tvn))+ Succ (phi', phi' tvn, ns'')++arrow :: Type -> Type -> Type+arrow a b = TypeCons "Function" [a, b]+ ++-- 9.7.4 Type checking lambda abstractions+-- +-- LAMBDA -> ELambda++tcLambda :: TypeEnv -> NameSupply -> String -> Expr+ -> SuccFail (Subst, Type, NameSupply)+tcLambda te ns x e =+ let (tvn, ns') = nameSupplyNext ns+ te' = install te x (TypeScheme [] (TypeVar tvn))+ in do+ {+ (phi, t, ns'') <- tcExpr te' ns' e+ ; Succ (phi, phi tvn `arrow` t, ns'')+ } ++-- 9.7.5 Type checking let expressions+-- Not needed, at least for the present ++-- 9.7.6 Type checking letrec expressions+-- Not needed, at least for the present ++++-- Extras (not in the textbook)++-- | Decide the type of a function -- called by the function editor+-- when the Apply button is clicked.+-- decideTypes tries to find the argument types and return type+-- of an expression considered as the body of a function,+-- at the same time checking for consistency of inputs and+-- outputs between the parts of the expression.+-- It returns Succ (argtypes, returntype) if successful;+-- Fail errormessage otherwise.++decideTypes :: String -> Expr -> [String] -> Env -> SuccFail([Type], Type)+decideTypes name body args env =+ let te = envToTypeEnv env+ -- extend te to bind name to a type variable that will not be used+ te' = install te name (TypeScheme [] (TypeVar "u"))+ result :: SuccFail (Type, ([Type], Type))+ result = do+ expr <- traceValue "decideTypes.expr" $ toLambdaExpr args body+ (_, t, _) <- tcExpr te' (newNameSupply "t") expr+ _ <- traceValue "decideTypes.t" $ return t+ res <- traceValue "decideTypes.res" $ fromLambdaType t+ Succ (t, res)+ finalResult = + case result of+ Succ (t, res@(argTypes, _retType)) ->+ if length args == length argTypes+ then Succ res+ else Fail ("Inferred function type " ++ show t +++ " does not agree with number of arguments")+ Fail msg -> Fail msg+ in traceValue (printf "decideTypes: %s ::\n" (show (args, body))) + finalResult+++traceValue :: (Show a) => String -> a -> a+traceValue label value =+ trace (printf "\n%s: %s\n" label (show value)) value++-- | Convert a function type, such as a -> (b -> c), to+-- a pair consisting of the list of argument types and the+-- result type, such as ([a, b], c).++fromLambdaType :: Type -> SuccFail ([Type], Type)+fromLambdaType t = + case t of+ TypeCons "Function" [t1, t2] -> + case t2 of+ TypeCons "Function" _ -> do+ (atypes, rtype) <- fromLambdaType t2+ return (t1:atypes, rtype)+ _ -> Succ ([t1], t2)+ TypeCons "Function" _ -> + error ("fromLambdaType: invalid function type " ++ show t)+ _ -> error ("fromLambdaType: non-function type " ++ show t)++-- | Type check an IF expression+-- *** Failure messages need improvement ***++tcIf :: TypeEnv -> NameSupply -> Expr -> Expr -> Expr + -> SuccFail (Subst, Type, NameSupply)+tcIf te ns expr1 expr2 expr3 = do+ {+ (phi, ts, ns') <- tcExprs te ns [expr1, expr2, expr3]+ ; -- assert ts has length 3+ phi' <- unifyList phi [(head ts, typeBool), (ts !! 1, ts !! 2)]+ ; return (phi', subst phi' (ts !! 1), ns')+ }++-- | Type check a list expression.+-- NOTE: This is to check a single Expr with the EList type, +-- in which all elements must be of the same type,+-- not a general list of Exprs of possibly mixed type. +-- See tcExprs.+--+-- *** Failure messages need improvement ***+--+-- IDEA: can this be reduced to [] and application of (:)?++tcList :: TypeEnv -> NameSupply -> [Expr]+ -> SuccFail (Subst, Type, NameSupply)+tcList te ns exprs =+ case exprs of+ [] -> + let (tvn, ns') = nameSupplyNext ns+ in Succ (idSubst, typeList (TypeVar tvn), ns')+ e:es ->+ do+ {+ (phi, ts, ns') <- tcExprs te ns [e, EList es]+ ; -- assert ts has length 2+ phi' <- unify phi (typeList (head ts), ts !! 1)+ ; return (phi', subst phi' (ts !! 1), ns')+ }++++-- | Create a TypeEnv from an Env+-- Bindings on the left replace bindings of the same name on the right,+-- if any.++envToTypeEnv :: Env -> TypeEnv+envToTypeEnv env =+ let frameTE frame = Map.map vftype frame+ in Map.unions (Prelude.map frameTE env)++-- | The base type environment, derived from the base environment+-- of the Sifflet language (built-in functions)+++baseTypeEnv :: TypeEnv+baseTypeEnv = Map.map vftype (head baseEnv)++vftype :: Value -> TypeScheme+vftype (VFun f) = ftype f+vftype _ = error "vftype: non-function value type"++ftype :: Function -> TypeScheme+ftype f = + let ft = uncurry typeFunction (functionArgResultTypes f)+ -- treat /all/ type variables in ft as schematic+ scvars = typeVarsIn ft+ in TypeScheme scvars ft
+ lib/Language/Sifflet/Util.hs view
@@ -0,0 +1,145 @@+module Language.Sifflet.Util (+ -- | Parser Utilities+ SuccFail(Succ, Fail)+ , parsef, parseInt, parseDouble, parseVerbatim+ -- | String Utilities+ , par+ -- Output Utilities+ , putCatsLn+ , putCatLn+ , info+ , fake+ , stub++ -- | Error Reporting+ , errcat+ , errcats++ -- | List Utilities+ , map2, mapM2+ , adjustAList, adjustAListM+ , insertLastLast, insertLast+ )++where++import Control.Monad()++-- SuccFail: the result of an attempt, succeeds or fails+data SuccFail a = Succ a -- value+ | Fail String -- error message+ deriving (Eq, Read, Show)++instance Functor SuccFail where+ fmap f (Succ v) = Succ (f v)+ fmap _f (Fail s) = Fail s++instance Applicative SuccFail where+ pure = Succ+ Succ f <*> Succ v = Succ (f v)+ Fail s <*> _ = Fail s+ Succ _ <*> Fail s = Fail s++instance Monad SuccFail where+ Succ val >>= f = f val+ Fail err >>= _f = Fail err+ return = Succ+ fail = Fail++-- PARSER UTILITIES++parsef :: (Read a) => String -> String -> String -> SuccFail a+parsef typeName inputLabel input =+ case reads input of+ [(value, "")] -> Succ value+ [(_, more)] -> + Fail $ inputLabel ++ ": extra characters after " ++ + typeName ++ ": " ++ more+ _ -> Fail $ inputLabel ++ ": cannot parse as " ++ + typeName ++ ": " ++ input++parseInt :: String -> String -> SuccFail Int+parseInt = parsef "integer"++parseDouble :: String -> String -> SuccFail Double+parseDouble = parsef "real number"++parseVerbatim :: String -> String -> SuccFail String+parseVerbatim _label = Succ++-- | Enclose in parentheses, like a Lisp function call.+-- Example: par "foo" ["x", "y"] = "(foo x y)"++par :: String -> [String] -> String+par f xs = "(" ++ unwords (f:xs) ++ ")"++-- | Write a list of words, separated by spaces+putCatsLn :: [String] -> IO ()+putCatsLn = putStrLn . unwords++-- | Write a list of words, not separated by spaces+putCatLn :: [String] -> IO ()+putCatLn = putStrLn . concat++info :: (Show t) => t -> IO ()+info = print++fake :: String -> IO ()+fake what = putStrLn $ "Faking " ++ what ++ "..."++stub :: String -> IO ()+stub name = putStrLn $ "Stub for " ++ name++-- ERROR REPORTING++-- | Signal an error using a list of strings to be concatenated+errcat :: [String] -> a+errcat = error . concat++-- | Signal an error using a list of strings to be concatenated+-- with spaces between (unwords).+errcats :: [String] -> a+errcats = error . unwords++-- LIST UTILITIES++-- | Generalization of map to lists of lists+map2 :: (a -> b) -> [[a]] -> [[b]]+map2 f rows = -- map (\ row -> map f row) rows+ map (map f) rows++-- | Generalization of mapM to lists of lists+mapM2 :: (Monad m) => (a -> m b) -> [[a]] -> m [[b]]+mapM2 f rows = -- mapM (\ row -> mapM f row) rows+ mapM (mapM f) rows++-- | Insert an item into a list of lists of items,+-- making it the last element in the last sublist+insertLastLast :: [[a]] -> a -> [[a]]+insertLastLast xss x = init xss ++ [insertLast (last xss) x]++-- | Insert an item in a list of items, making it the last element+insertLast :: [a] -> a -> [a]+insertLast xs x = xs ++ [x]++-- | Update a value at a given key by applying a function.+-- Similar to Data.Map.adjust.++-- This implementation, using map, could be inefficient+-- if the key to be updated is near the front of a long list.+adjustAList :: (Eq k) => k -> (v -> v) -> [(k, v)] -> [(k, v)]+adjustAList key f alist =+ map (\ (k, v) -> if k == key then (k, f v) else (k, v)) + alist++-- | Monadic generalization of adjustAList ++-- Same caution re. inefficiency+adjustAListM :: (Eq k, Monad m) => + k -> (v -> m v) -> [(k, v)] -> m [(k, v)]+adjustAListM key f alist =+ mapM (\ (k, v) -> + if k == key + then do { v' <- f v; return (k, v') }+ else return (k, v))+ alist
+ lib/System/Sifflet/Paths.hs view
@@ -0,0 +1,77 @@+module System.Sifflet.Paths+ (findDataFile, copyLibFile, readLibFile)+ where++import Control.Monad (unless)+import System.Directory (doesFileExist, copyFile)+import System.FilePath (replaceDirectory)++-- Cabal-generated paths module tells where a datafile+-- _should_ be, but not necessarily where it is,+-- if the installed files have been relocated.++import Paths_sifflet (getDataFileName)++import Graphics.UI.Sifflet.Types (VPUI(..))+import Graphics.UI.Sifflet.GtkUtil (showErrorMessage)++-- | Try to find the original of a datafile that is part of the+-- sifflet library. +-- These are usually files like sifflet.scm or sifflet.py that provide +-- Sifflet support for the target language when exporting.+-- First try the directory where Cabal would have installed data files.+-- This may fail if Sifflet has been installed (or portably installed)+-- on Windows into a non-standard location; in that case, also try+-- the directory from which sifflet.exe was launched.++findDataFile :: VPUI -> FilePath -> IO (Maybe FilePath)+findDataFile vpui fileBaseName = do+ -- path1 is where it should be;+ -- path2 is where it might be on Windows.+ path1 <- getDataFileName fileBaseName+ let path2 = replaceDirectory fileBaseName (vpuiInitialDir vpui)+ -- There's surely a name for this type of search,+ -- which simply returns the first item in the list+ -- for which a predicate `returns` True (m True):+ search [] = return Nothing+ search (path:paths) = do+ fileExists <- doesFileExist path+ if fileExists+ then return $ Just path+ else search paths+ search [path1, path2]+ +-- | Try to copy a library file (such as sifflet.py or Sifflet.java)+-- to the same directory where an export file is being written,+-- if it doesn't already exist there.+-- Show a warning message if the library file cannot be found.+copyLibFile :: VPUI -> FilePath -> FilePath -> IO ()+copyLibFile vpui libFileName dest = do+ mLibFilePath <- findDataFile vpui libFileName+ destExists <- doesFileExist dest+ unless destExists $ do+ case mLibFilePath of+ Nothing ->+ showErrorMessage $ "Sifflet could not locate the file " ++ + libFileName ++ "\n" +++ "Please copy it from the Sifflet installation directory to " +++ "the same directory into which you are saving the export file.\n"+ Just libFileSource ->+ copyFile libFileSource dest+ +-- | Get the contents of a library file (such as sifflet.scm) +-- so you can insert it into the file being exported.+-- If the file cannot be found, display an error message and+-- return the empty string.+readLibFile :: VPUI -> FilePath -> FilePath -> IO String+readLibFile vpui libFileName exportFile = do+ mLibFilePath <- findDataFile vpui libFileName+ case mLibFilePath of+ Nothing -> do+ showErrorMessage $ "Sifflet could not locate the file " ++ + libFileName ++ "\n" +++ "Please find it in the Sifflet installation directory " +++ "and insert its contents into " ++ exportFile ++ "\n"+ return ""+ Just libFilePath ->+ readFile libFilePath
+ lib/Text/Sifflet/Pretty.hs view
@@ -0,0 +1,56 @@+module Text.Sifflet.Pretty + (Pretty(..)+ , indentLine, sepLines, sepLines2+ , sepComma, sepCommaSp, sepSpace)++where++import Data.List (intercalate)+++-- | The class of types that can be pretty-printed.+-- (Unfortunately this is not very useful, because+-- and Expr can be pretty Haskell or pretty Python or pretty Scheme,+-- leading to overlapping instance declarations.)+--+-- pretty x is a pretty String representation of x.+-- prettyList prefix infix postfix xs is a pretty String representation+-- of the list xs, with prefix, infix, and postfix specifying the+-- punctuation. For example, if (pretty x) => "x",+-- then prettyList "[" ", " "]" [x, x, x] => "[x, x, x]".+--+-- Minimal complete implementation: define pretty.++class Pretty a where++ pretty :: a -> String++ prettyList :: String -> String -> String -> [a] -> String+ prettyList pre tween post xs =+ pre ++ intercalate tween (map pretty xs) ++ post++-- | Indent a single line n spaces.+indentLine :: Int -> String -> String+indentLine n line = replicate n ' ' ++ line++-- | sepLines is like unlines, but omits the \n at the end of the+-- last line.+sepLines :: [String] -> String+sepLines = intercalate "\n"++-- | sepLines2 is like sepLines, but adds an extra \n between each+-- pair of lines so they are "double spaced."+sepLines2 :: [String] -> String+sepLines2 = intercalate "\n\n"++-- | Separate strings by commas and nothing else (",")+sepComma :: [String] -> String+sepComma = intercalate ","++-- | Separate strings by commas and spaces (", ")+sepCommaSp :: [String] -> String+sepCommaSp = intercalate ", "++-- | Separate strings by just spaces (" ")+sepSpace :: [String] -> String+sepSpace = unwords
+ lib/Text/Sifflet/Repr.hs view
@@ -0,0 +1,65 @@+module Text.Sifflet.Repr+ (Repr(..)+ , Name(..)+ )++where++import Data.Number.Sifflet+import Data.List (intercalate)++-- | class Repr: representable by a String or a list of Strings+--+-- repr x is a String representation of x.+-- reprl x is a [String] representation of x,+-- where the first element should be the same as repr x,+-- and the rest provide auxiliary information+-- that you want to be shown with x.+-- reprs x is a reduction of reprl x to a single String.+-- reprList prefix infix postfix xs is the representation of a list of xs+--+-- Minimal complete implementation: define repr, or define reprl.+-- The normal way is to define repr. Define reprl instead,+-- if for some reason you want to include additional information+-- such as the value of an expression in an expression node.+--+-- Examples:+-- - (3 :: Int) has repr => "3", reprl => ["3"], reprs => "3"+-- - In Language.Sifflet.Expr, (ENode (NSymbol "x") (EvalOk (3 :: Int)+-- has reprl => ["x", "3"], reprs => "x 3", and repr => "x".+-- - reprList "(" " " ")" [3 :: Int, 4, 5] => "(3 4 5)"++class Repr a where++ repr :: a -> String+ repr = head . reprl++ reprl :: a -> [String]+ reprl x = [repr x]++ reprs :: a -> String+ reprs = unwords . reprl++ reprList :: String -> String -> String -> [a] -> String+ reprList pre tween post xs =+ pre ++ intercalate tween (map repr xs) ++ post++instance Repr Bool where repr = show+instance Repr Char where repr = show+instance Repr Int where repr = show+instance Repr Integer where repr = show+instance Repr Number where repr = show+instance Repr Float where repr = show+instance Repr Double where repr = show++-- instance Repr String won't work because String is a type synonym,+-- unless you ask ghc nicely, which I'd prefer not to do.+-- Use Name data type in Testing/Tree.hs instead, or Symbol in Expr.hs+-- I don't know if I can use Expr.Symbol here, since Expr.hs also+-- imports Tree.hs (this file) -- is mutual import allowed?++newtype Name = Name String+ deriving (Eq, Read, Show)++instance Repr Name where+ repr (Name s) = s
sifflet.cabal view
@@ -1,63 +1,179 @@ name: sifflet-version: 2.2.1-cabal-version: >= 1.8+version: 2.3.0+cabal-version: >= 1.22 build-type: Simple license: BSD3 license-file: LICENSE-copyright: (C) 2009-2014 Gregory D. Weber+copyright: (C) 2009-2016 Gregory D. Weber author: Gregory D. Weber maintainer: "gdweber" ++ drop 3 "abc@" ++ "iue.edu"-bug-reports: mailto:"gdweber" ++ drop 3 "abc@" ++ "iue.edu"-homepage: http://mypage.iu.edu/~gdweber/software/sifflet/ stability: Experimental.-synopsis: A simple, visual, functional programming language.+homepage: http://pages.iu.edu/~gdweber/software/sifflet/+bug-reports: mailto:"gdweber" ++ drop 3 "abc@" ++ "iue.edu"+synopsis: Simple, visual, functional language for learning about recursion. description: Sifflet is a visual, functional programming language.+ It is intended as an aid for learning about recursion. Sifflet users can make programs by drawing diagrams to connect functions and other units.- Sifflet show the intermediate steps of the computation+ Sifflet shows the intermediate steps of the computation on the diagram, and can expand function calls to show further details.- It is intended as an aid for learning about recursion.-category: - Language - , Visual Programming-tested-with: GHC == 7.4.2, GHC == 7.6.3--- data-files: filename list--- data-dir: directory--- extra-tmp-files: filename list--extra-source-files: README RELEASE-NOTES+category: Language, Visual Programming+tested-with: GHC == 7.10.3+data-files: sifflet.scm sifflet.py siffml-1.0.dtd siffml-1.0.rnc siffml-2.0.rnc +data-dir: datafiles+extra-source-files: README.md ChangeLog.md tests/system-tests.sh+-- extra-tmp-files: -flag no-link- description: Inhibit linking; just compile.- default: False+source-repository head+ type: darcs+ location: http://hub.darcs.net/gdweber/sifflet-devel +source-repository this+ type: darcs+ location: http://hub.darcs.net/gdweber/sifflet-stable+ tag: 2.3.0+ +-- Executable ----------------------------------------------------------+ executable sifflet main-is: sifflet.hs+ hs-source-dirs: app other-modules: Options build-depends: - base >= 4.0 && < 4.8,- -- begin GTK stuff, these no longer need to have the same version- -- numbers- cairo >= 0.11 && < 0.13,- glib >= 0.11 && < 0.13,- gtk >= 0.11 && < 0.13,- -- end+ base >= 4.0 && < 4.9,+ sifflet == 2.3.0 ++ if !os(windows)+ build-depends: unix >= 2.3 && < 2.8+ -- extra-libraries: gdk-x11-2.0 gtk-x11-2.0+ -- includes: gtk-2.0/gtk/gtk.h, gtk-2.0/gdk/gdk.h+ buildable: True+ default-language: Haskell2010+ -- default-extensions: + -- other-extensions: ForeignFunctionInterface CPP+ ghc-options: -Wall++-- Library -------------------------------------------------------------+ +library++ build-depends:+ base >= 4.0 && < 4.9,+ -- Begin GTK stuff, these no longer need to have the same version numbers+ cairo >= 0.11 && < 0.14,+ glib >= 0.11 && < 0.14,+ gtk >= 0.11 && < 0.15,+ -- End GTK stuff containers >= 0.2 && < 0.7, directory >= 1.0 && < 1.4,- filepath >= 1.1 && < 1.4,- fgl >= 5.4 && < 5.5,+ filepath >= 1.1 && < 1.5,+ fgl >= 5.4 && < 5.6, hxt >= 9.0 && < 10.0,- mtl >= 1.1 && < 2.2,+ mtl >= 1.1 && < 2.3, parsec >= 2.1.0.1 && < 3.2, - process >= 1.0 && < 1.2,- sifflet-lib >= 2.2 && < 2.3-+ process >= 1.0 && < 1.3,+ text >= 1.2 && < 1.3 if !os(windows)- build-depends: unix >= 2.3 && < 2.7+ build-depends: unix >= 2.3 && < 2.8 buildable: True- extensions: ForeignFunctionInterface CPP- ghc-options: -Wall- if flag(no-link)- ghc-options: -c+ default-language: Haskell2010+ default-extensions: + other-extensions: ForeignFunctionInterface CPP+ ghc-options: -Wall -fwarn-incomplete-uni-patterns + -- if os(windows)+ -- extra-libraries: gdk-2.0 gtk+-2.0+ -- includes: gtk/gtk.h, gdk/gdk.h+ -- ghc-options: -Wall --extra-include-dirs=c:/MinGW/msys/1.0/opt/gtk/include --extra-lib-dirs=c:/MinGW/msys/1.0/opt/gtk/lib+ -- ghc-options: -Wall --extra-include-dirs=/c/MinGW/msys/1.0/opt/gtk/include --extra-lib-dirs=/c/MinGW/msys/1.0/opt/gtk/lib+ -- include-dirs: c:/MinGW/msys/1.0/opt/gtk/include+ -- extra-lib-dirs: c:/MinGW/msys/1.0/opt/gtk/lib+ if !os(windows)+ -- extra-libraries: gdk-x11-2.0 gtk-x11-2.0 includes: gtk-2.0/gtk/gtk.h, gtk-2.0/gdk/gdk.h- extra-libraries: gdk-x11-2.0 gtk-x11-2.0+ exposed-modules: + Data.Number.Sifflet++ , Data.Sifflet.Functoid+ , Data.Sifflet.Geometry+ , Data.Sifflet.Tree+ , Data.Sifflet.TreeGraph+ , Data.Sifflet.TreeLayout+ , Data.Sifflet.WGraph++ , Graphics.Rendering.Sifflet.Draw+ , Graphics.Rendering.Sifflet.DrawTreeGraph+ + , Graphics.UI.Sifflet+ , Graphics.UI.Sifflet.Callback+ , Graphics.UI.Sifflet.Canvas+ , Graphics.UI.Sifflet.EditArgsPanel+ , Graphics.UI.Sifflet.Frame+ , Graphics.UI.Sifflet.GtkForeign+ , Graphics.UI.Sifflet.GtkUtil+ , Graphics.UI.Sifflet.LittleGtk+ , Graphics.UI.Sifflet.Tool+ , Graphics.UI.Sifflet.RPanel+ , Graphics.UI.Sifflet.Types+ , Graphics.UI.Sifflet.Window+ , Graphics.UI.Sifflet.Workspace++ , Language.Sifflet.Examples++ , Language.Sifflet.Export.Exporter+ , Language.Sifflet.Export.Haskell+ , Language.Sifflet.Export.Python+ , Language.Sifflet.Export.ToHaskell+ , Language.Sifflet.Export.ToPython+ , Language.Sifflet.Export.ToScheme++ , Language.Sifflet.Expr+ , Language.Sifflet.ExprTree+ , Language.Sifflet.Parser + , Language.Sifflet.TypeCheck+ , Language.Sifflet.SiffML+ , Language.Sifflet.Util++ , System.Sifflet.Paths++ , Text.Sifflet.Pretty+ , Text.Sifflet.Repr++-- Paths to data files, generated by Cabal+ other-modules: Paths_sifflet+ hs-source-dirs: lib+ build-tools:++-- Test Suite ----------------------------------------------------------++test-suite unit-tests+ type: exitcode-stdio-1.0+ build-depends:+ base >= 4.0 && < 4.9,+ cairo >= 0.11 && < 0.14,+ Cabal >= 1.22,+ containers >= 0.2 && < 0.7,+ fgl >= 5.4 && < 5.6,+ HUnit >= 1.2 && < 1.4,+ parsec >= 2.1.0.1 && < 3.2, + process >= 1.0 && < 1.3,+ sifflet == 2.3.0+ default-language: Haskell2010+ main-is: unit-tests.hs+ hs-source-dirs: tests+ other-modules:+ Testing.Common.ExprTreeTests,+ Testing.Common.TestStyles,+ Testing.TestUtil,+ Testing.Unit.ExprTests,+ Testing.Unit.ExprTreeTests,+ Testing.Unit.FunctionExamples,+ Testing.Unit.GraphTests,+ Testing.Unit.LayoutTests,+ Testing.Unit.ParserTests,+ Testing.Unit.ToHaskellTests,+ Testing.Unit.ToPythonTests,+ Testing.Unit.ToSchemeTests,+ Testing.Unit.TreeTests,+ Testing.Unit.TypeCheckTests,+ Testing.Unit.UtilTests+
− sifflet.hs
@@ -1,137 +0,0 @@-module Main (main) where--import Control.Monad (when)-import Data.IORef-import System.Exit--import Data.Sifflet.Functoid-import Data.Sifflet.TreeLayout-import Language.Sifflet.Examples-import Language.Sifflet.Expr-import Language.Sifflet.Parser-import Graphics.UI.Sifflet-import Language.Sifflet.Util--import Options----- | Main function--main :: IO ()-main = do- {- -- scim-bridge causes many errors, so don't use it- suppressScimBridge-- -- Initialize GTK, returning args unused by Gtk itself- ; args <- initGUI- -- Process remaining command-line arguments- ; let commands = processArgs args-- -- create the user interface- ; vpui <- vpuiNew wstyle initialEnv (optionsDebug commands)- ; let vpui' = vpui {vpuiToolkits = defaultVPUIToolkitsWithExamples}- ; uiref <- newIORef vpui'- -- Create some windows- ; let cbmgr = mkCBMgr uiref- ; vpui'' <- showWorkWin vpui' workspaceId cbmgr- ; writeIORef uiref vpui''-- -- Obey command-line arguments, then let Gtk take over- ; mExitCode <- performCommands commands cbmgr uiref- ; case mExitCode of- Nothing -> mainGUI >> return ()- Just code -> exitWith code- }---- | Environment--initialEnv :: Env-initialEnv = exampleEnv---- | Default toolkit--defaultVPUIToolkitsWithExamples :: [(String, VPToolkit)]-defaultVPUIToolkitsWithExamples =- let toolkits =- -- each item has name, width, list of rows tools- [VPToolkit "Base" 500 (functionToolsFromLists baseFunctionsRows),- VPToolkit "Examples" 500 - (functionToolsFromLists [exampleFunctionNames]),- VPToolkit "My Functions" 500 (functionToolsFromLists [[]])]- in zip (map toolkitName toolkits) toolkits---- | Perform the things requested in command-line arguments.--- Return an exit code if processing should continue.--performCommands :: Options -> CBMgr -> IORef VPUI -> IO (Maybe ExitCode)-performCommands options cbmgr uiref = - -- Error?- case optionsErrorMsg options of- Just msg ->- putStrLn ("sifflet: " ++ msg) >> return (Just (ExitFailure 1))- Nothing ->- -- Help requested?- if optionsHelp options- then showHelp >> return (Just ExitSuccess)- else do- {- -- show function pad?- when (optionsShowFunPad options)- (modifyIORefIO (showFunctionPadWindow cbmgr) uiref)-- -- source a file?- -- What if no such file???- ; case optionsSourceFile options of- Nothing -> return ()- Just file ->- modifyIORefIO (openFilePath cbmgr file) uiref-- -- show or call a function?- ; case (optionsShowFunction options, - optionsCallFunction options) of- -- neither- (Nothing, Nothing) -> return Nothing- -- just show- (Just fname, Nothing) -> - showFunctionFrame fname Nothing uiref >>- return Nothing- -- call, overrides show if both are given- (_, Just fname) ->- showFunctionFrame fname - (Just (optionsAdditionalArgs options))- uiref- }--showFunctionFrame :: String -- ^ function name- -> Maybe [String] -- ^ Just args, to call with args- -> IORef VPUI- -> IO (Maybe ExitCode)-showFunctionFrame fname mArgStrs uiref = do- {- vpui <- readIORef uiref- ; let x = styleFramePad (vpuiStyle vpui)- y = 150- env = vpuiGlobalEnv vpui-- showFun :: Function -> Maybe [Value] -> IO ()- showFun f mArgValues = - vpuiAddFrame vpui workspaceId (FunctoidFunc f)- mArgValues CallFrame env x y 0 Nothing >>=- writeIORef uiref-- ; case envLookup env fname of- Just (VFun f@(Function _fname argTypes _retType (Compound _ _))) ->- case mArgStrs of- Nothing -> showFun f Nothing >> return Nothing- Just argStrs ->- case parseTypedInputs2 argStrs argTypes of- Fail msg ->- putStrLn ("sifflet: " ++ msg) >>- return (Just (ExitFailure 1))- Succ argValues ->- showFun f (Just argValues) >> return Nothing-- _ -> putStrLn ("sifflet: function not found or not compound") >>- return (Just (ExitFailure 2))- }
+ tests/Testing/Common/ExprTreeTests.hs view
@@ -0,0 +1,50 @@+module Testing.Common.ExprTreeTests + (testStyle, aDemoExpr, demoEnv)++where+++import Graphics.Rendering.Cairo hiding (translate, x, y)++import Data.Number.Sifflet+import Data.Sifflet.Geometry+import Data.Sifflet.TreeLayout+import Language.Sifflet.Expr++import Testing.Common.TestStyles+++testStyle :: Style+testStyle = + let normal = ColorRGB 0.3 0.6 0.5+ active = ColorRGB 0.15 0.3 0.25+ auxColor = ColorRGBA 1.0 1.0 0.5 0.75+ in styleTest4 {textMargin = 18,+ hpad = 27, vpad = 36,+ vtinypad = (0, 0),+ styleAuxOffset = Position 4 (-12),+ styleNormalTextColor = normal,+ styleNormalEdgeColor = normal,+ styleActiveTextColor = active,+ styleActiveEdgeColor = active,+ styleAuxColor = auxColor,+ styleAuxFont = + VFont "serif" FontSlantItalic FontWeightNormal 14,+ styleShowNodeBoxes = False,+ styleShowNodePorts = False+ }+++aDemoExpr :: Expr+aDemoExpr = let a = eSymbol "ant"+ b = eSymbol "butterfly"+ c = eSymbol "cheetah"+ in eIf (eGt a (ePlus b (eInt 5)))+ (ePlus a (ePlus b c))+ (eTimes (ePlus a (eInt 7))+ (eMinus b (eInt 12)))++demoEnv :: Env+demoEnv = extendEnv ["ant", "butterfly", "cheetah"]+ [VNumber (Exact x) | x <- [5, 10, 18]] + baseEnv
+ tests/Testing/Common/TestStyles.hs view
@@ -0,0 +1,66 @@+module Testing.Common.TestStyles+ (styleTest0, styleTest1, styleTest2, styleTest3,+ styleTest4, allStyles, treeStyles)++where++import Graphics.Rendering.Cairo (FontSlant(..), FontWeight(..))++import Data.Sifflet.Geometry (Position(..))+import Data.Sifflet.TreeLayout -- for style++-- Some styles for testing++styleTest0 :: Style+styleTest0 = + let green = ColorRGB 0.1 0.9 0.1+ veryDarkGray = ColorRGB 0.1 0.1 0.1+ brighterGreen = ColorRGB 0.5 0.95 0.5+ blueGreen' = ColorRGB 0 1 1+ in Style {styleFont = + VFont "serif" FontSlantNormal FontWeightNormal 18, + lineWidth = 2, + textMargin = 0.0, -- text within its box+ hpad = 0, vpad = 0, -- inter-node separation+ exomargin = 0.0, -- between tree and window edge+ vtinypad = (0, 0), -- node-edge separation+ styleFramePad = 35,+ + -- Foreground and background colors+ styleNormalTextColor = green,+ styleNormalEdgeColor = green,+ styleNormalFillColor = veryDarkGray,+ styleActiveTextColor = brighterGreen,+ styleActiveEdgeColor = brighterGreen,+ styleActiveFillColor = mediumGray,+ styleSelectedTextColor = blueGreen',+ styleSelectedEdgeColor = blueGreen',+ styleSelectedFillColor = darkGray,+ styleTetherColor = white,+ styleAuxOffset = Position 9 9,+ styleAuxColor = lightGray,+ styleAuxFont = + VFont "serif" FontSlantItalic FontWeightNormal 14,+ styleIoletRadius = 10,+ styleShowNodeBoxes = True,+ styleShowNodePorts = True+ }++styleTest1 :: Style+styleTest1 = styleTest0 {textMargin = 10}++styleTest2 :: Style+styleTest2 = styleTest0 {hpad = 10, vpad = 15}++styleTest3 :: Style+styleTest3 = styleTest0 {hpad = 20, vpad = 30, textMargin = 10}++styleTest4 :: Style+styleTest4 = styleTest0 {textMargin = 4.0, hpad = 27, vpad = 36, + vtinypad = (4.5, 4.5)}++allStyles :: [Style]+allStyles = [styleTest0, styleTest1, styleTest2, styleTest3, styleTest4]++treeStyles :: [Style]+treeStyles = [styleTest2, styleTest3, styleTest4]
+ tests/Testing/TestUtil.hs view
@@ -0,0 +1,90 @@+module Testing.TestUtil (assertAll, utestloop, vtestloop,+ Diff(..), bboxDiff, gnodeDiff, sizeTreeDiff+ )+where++import Test.HUnit++import Data.Sifflet.Geometry+import Data.Sifflet.Tree+import Data.Sifflet.TreeLayout++assertAll :: [Assertion] -> Test+assertAll assertions = TestList (map TestCase assertions)++ +-- General test loops -- used by the other TestX.hs files++-- unit test loop++utestloop :: Test -> IO()++utestloop tests = do+ count <- runTestTT tests+ print count+ putStrLn $ "Errors: " ++ show (errors count)+ putStrLn $ "Failures: " ++ show (failures count)++-- visual test loop: run all visual tests+-- Not really test data, but well!++vtestloop :: [IO()] -> IO()+vtestloop [] = return ()+vtestloop (t:ts) = do {t; vtestloop ts}++-- | Use to express the result of comparing structures of type a +-- with some error tolerance++data Diff a = CloseEnough+ | TooFar a a+ deriving (Eq, Show)++-- Do these belong here, or in the modules where the data types+-- (BBox, GNode, etc.) are defined?++bboxDiff :: BBox -> BBox -> Diff BBox+bboxDiff b1@(BBox x1 y1 w1 h1) b2@(BBox x2 y2 w2 h2) =+ let closeEnough u v = abs (u - v) <= 2.0+ in if (closeEnough x1 x2 &&+ closeEnough y1 y2 &&+ closeEnough w1 w2 &&+ closeEnough h1 h2)+ then CloseEnough+ else TooFar b1 b2++gnodeDiff :: GNode Name -> GNode Name -> Diff (GNode Name)+gnodeDiff g1 g2 =+ let GNode (Name n1) textboxes1 bb1 inlets1 outlets1 = g1+ GNode (Name n2) textboxes2 bb2 inlets2 outlets2 = g2+ in if n1 == n2 &&+ all (uncurry textBoxCloseEnough) (zip textboxes1 textboxes2) &&+ bboxDiff bb1 bb2 == CloseEnough &&+ inlets1 == inlets2 &&+ outlets1 == outlets2+ then CloseEnough+ else TooFar g1 g2++textBoxCloseEnough :: TextBox -> TextBox -> Bool+textBoxCloseEnough tb1 tb2 =+ tbText tb1 == tbText tb2 &&+ bboxDiff (tbTextBB tb1) (tbTextBB tb2) == CloseEnough &&+ bboxDiff (tbBoxBB tb1) (tbBoxBB tb2) == CloseEnough+++sizeTreeDiff :: Tree Size -> Tree Size -> Diff (Tree Size)+sizeTreeDiff t1 t2 =+ let Node size1 subtrees1 = t1+ Node size2 subtrees2 = t2+ sizeTreeCloseEnough t3 t4 = sizeTreeDiff t3 t4 == CloseEnough+ in if sizeDiff size1 size2 == CloseEnough &&+ all (uncurry sizeTreeCloseEnough) (zip subtrees1 subtrees2)+ then CloseEnough+ else TooFar t1 t2++sizeDiff :: Size -> Size -> Diff Size+sizeDiff s1 s2 =+ let close x1 x2 = abs(x1 - x2) < 3.0+ in if close (sizeW s1) (sizeW s2) &&+ close (sizeH s1) (sizeH s2)+ then CloseEnough+ else TooFar s1 s2
+ tests/Testing/Unit/ExprTests.hs view
@@ -0,0 +1,333 @@+-- New tests for Expr++module Testing.Unit.ExprTests (tests, runU) where++import Test.HUnit++import Data.Number.Sifflet++import Data.Sifflet.Tree as T++import Language.Sifflet.Examples++import Language.Sifflet.Expr+import Language.Sifflet.ExprTree++import Text.Sifflet.Repr ()++import Language.Sifflet.Util++import Testing.TestUtil++env0 :: Env+env0 = makeEnv [] []++envTest :: Env+envTest = extendEnv ["x", "y"] -- , "foo"] + [VNumber (Exact 3), VNumber (Exact 7)] -- , VFun foo]+ exampleEnv++fPlus :: Function+fPlus = envGetFunction baseEnv "+"++-- (ifExpr t a b represents "if t a else b")+ifExpr :: Bool -> Integer -> Integer -> Expr+ifExpr bool0 int1 int2 = eIf (eBool bool0) (eInt int1) (eInt int2)++plusExpr :: Integer -> Integer -> Expr+plusExpr int1 int2 = ePlus (eInt int1) (eInt int2)++testRepr :: Test+testRepr = assertAll+ [+ -- Functions+ assertEqual "repr of Function (primitive)" "<primfunc +>" + (repr fPlus),+ -- Values+ assertEqual "repr of VString" "\"hi monde\"" (repr $ VString "hi monde"),+ assertEqual "repr of VNumber" "23" (repr $ VNumber (Exact 23)),+ assertEqual "repr of VBool" "False" (repr $ VBool False),+ -- add VList ...+ -- ExprNode+ assertEqual "reprl of ExprNode/symbol with no value" + ["casey"]+ (reprl $ ENode (NSymbol (Symbol "casey")) EvalUntried),+ assertEqual "reprl of ExprNode/symbol with value"+ ["casey", "23"]+ (reprl $ ENode (NSymbol (Symbol "casey"))+ (EvalOk (VNumber (Exact 23)))),+ assertEqual "reprl of ExprNode/symbol with an error"+ ["casey", "error: unbound"]+ (reprl $ ENode (NSymbol (Symbol "casey")) (EvalError "unbound")),+ assertEqual "reprs of ExprNode/symbol with value"+ "casey 23"+ (reprs $ ENode (NSymbol (Symbol "casey")) + (EvalOk (VNumber (Exact 23)))),+ + assertEqual "reprl of ExprNode/string literal"+ ["\"adam\""]+ (reprl $ ENode (NString "adam") EvalUntried),+ assertEqual "reprl of ExprNode/int literal"+ ["23"]+ (reprl $ ENode (NNumber (Exact 23)) EvalUntried),+ assertEqual "reprl of ExprNode/boolean literal"+ ["False"]+ (reprl $ ENode (NBool False) (EvalOk (VBool False))),+ assertEqual "reprl of ExprNode/if"+ ["if"]+ (reprl $ ENode (NSymbol (Symbol "if")) EvalUntried),+ assertEqual "reprl of ExprNode/if/value"+ ["if", "5"]+ (reprl $ ENode (NSymbol (Symbol "if")) + (EvalOk (VNumber (Exact 5)))),+ assertEqual "reprs of ExprNode/if/value"+ "if 5"+ (reprs $ ENode (NSymbol (Symbol "if")) + (EvalOk (VNumber (Exact 5)))),+ -- Expr+ assertEqual "repr of Expr/variable"+ "betty"+ (repr $ eSymbol "betty"),+ assertEqual "repr of Expr/function call with args"+ "(top sam \"johnny\")"+ (repr (eCall "top" [eSymbol "sam", eString "johnny"]))+ ]++testEnv :: Test+testEnv = + let ints = map int+ e0 = makeEnv [] []+ e1 = extendEnv ["a", "b"] (ints [1, 3]) e0+ e2 = extendEnv ["b", "c", "d"] (ints [5, 7, 9]) e1+ in assertAll+ [+ -- testing Env+ assertEqual "makeEnv + envGet"+ (int 21)+ (envGet (makeEnv ["a", "b"] [int 21, VString "hoot"])+ "a"),+ assertEqual "envIns + envGet"+ (int 12)+ (envGet (envIns e0 "x" (int 12)) "x"),+ assertEqual "extendEnv e1 a" (int 1) (envGet e1 "a"),+ assertEqual "extendEnv e1 b" (int 3) (envGet e1 "b"),+ assertEqual "extendEnv e2 b" (int 5) (envGet e2 "b"),+ assertEqual "extendEnv e2 c" (int 7) (envGet e2 "c"),+ assertEqual "extendEnv e2 d" (int 9) (envGet e2 "d"),+ assertEqual "envSet e0 a 1" + (makeEnv ["a"] [int 1])+ (envSet e0 "a" (int 1)),+ assertEqual "envSet e1 a 7"+ (extendEnv ["a", "b"] (ints [7, 3]) e0)+ (envSet e1 "a" (int 7)),+ assertEqual "envSet e2 a 7"+ (extendEnv ["b", "c", "d"] (ints [5, 7, 9])+ (extendEnv ["a", "b"] (ints [7, 3]) e0))+ (envSet e2 "a" (int 7)),+ assertEqual "envSet e2 b 18"+ (extendEnv ["b", "c", "d"] (ints [18, 7, 9]) e1)+ (envSet e2 "b" (int 18)),+ assertEqual "envSet e2 z 23"+ (extendEnv ["b", "c", "d", "z"] + (ints [5, 7, 9, 23])+ e1)+ (envSet e2 "z" (int 23))+ ]+++testExprTree :: Test+testExprTree = TestCase $ + let call1 = eCall "top" [eSymbol "sam", eString "johnny"]+ in assertEqual "testing reciprocals exprTree, treeExpr"+ (Succ call1)+ (treeToExpr (exprToTree call1))++int :: Integer -> Value+int = VNumber . Exact++testEval :: Test+testEval = + assertAll+ [assertEqual "eval 2 + 3"+ (EvalOk (VNumber (Exact 5)))+ (eval (ePlus (eInt 2) (eInt 3))+ exampleEnv)+ ,+ assertEqual "eval x + y"+ (EvalOk (int 10))+ (eval (ePlus (eSymbol "x") (eSymbol "y"))+ envTest)+ ,+ assertEqual "eval foo 2 4"+ (EvalOk (int 8))+ (eval (eFoo (eInt 2) (eInt 4)) envTest)+ ,+ assertEqual "eval foo x y"+ (EvalOk (int 13))+ (eval (eFoo (eSymbol "x") (eSymbol "y"))+ envTest)+ ,+ assertEqual "eval (1 + x) + foo y 2"+ (EvalOk (int 20))+ (eval (ePlus (ePlus (eInt 1) (eSymbol "x"))+ (eFoo (eSymbol "y") (eInt 2)))+ envTest)+ ,+ assertEqual "eval max x y"+ (EvalOk (int 7))+ (eval (eMax (eSymbol "x") (eSymbol "y"))+ envTest)+ ,+ assertEqual "eval max 42 12"+ (EvalOk (int 42))+ (eval (eMax (eInt 42) (eInt 12)) envTest)+ ,+ assertEqual "eval fact 0"+ (EvalOk (int 1))+ (eval (eFact (eInt 0)) envTest)+ ,+ assertEqual "eval fact 5"+ (EvalOk (int 120))+ (eval (eFact (eInt 5)) envTest)+ ,+ assertEqual "eval literal"+ (EvalOk (int 345))+ (eval (eInt 345) env0)+ ,+ assertEqual "eval variable"+ (EvalOk (int 331))+ (eval (eSymbol "w3c") + (makeEnv ["w3c"] [int 331]))+ ,+ assertEqual "eval if false"+ (EvalOk (int 281))+ (eval (ifExpr False 279 281) env0)+ ,+ assertEqual "eval if true"+ (EvalOk (int 279))+ (eval (ifExpr True 279 281) env0)+ ,+ assertEqual "eval function call"+ (EvalOk (int 5))+ (eval (plusExpr 2 3) envTest)+ ,+ assertEqual "eval function call with unbound variable"+ (EvalError "unbound variable: j")+ (eval (ePlus (eSymbol "j") (eInt 1)) envTest)+ ,+ assertEqual "eval head okay"+ (EvalOk (int 5)) + (eval (eCall "head" [EList [eInt 5, eInt 7]])+ envTest)+ ,+ assertEqual "eval head with error"+ (EvalError "head: empty list")+ (eval (eCall "head" [EList []]) envTest)+ ,+ assertEqual "eval div by zero"+ (EvalError + "div: zero divisor ([VNumber 3,VNumber 0])")+ (eval (eCall "div" [eSymbol "x", eInt 0])+ envTest)+ ]++testEvalTree :: Test+testEvalTree = assertAll+ [let t = evalTree (exprToTree (plusExpr 5 7)) envTest+ ENode _ mvalue = rootLabel t + in assertEqual "evalTree: plus" (EvalOk (int 12)) mvalue,+ + let t = evalTree (exprToTree (ifExpr True 8 21)) env0+ ENode _ mvalue = rootLabel t + in assertEqual "evalTree: if true" (EvalOk (int 8)) mvalue,+ + let t = evalTree (exprToTree (ifExpr False 17 35)) env0+ ENode _ mvalue = rootLabel t + in assertEqual "evalTree: if false" (EvalOk (int 35)) mvalue,++ let t = evalTree (exprToTree (ePlus (eSymbol "j") (eInt 1))) envTest+ ENode _ mvalue = rootLabel t+ in assertEqual "evalTree: function call with unbound variable"+ (EvalError "unbound variable: j")+ mvalue+ ]++testUnevalTree :: Test+testUnevalTree = TestCase $ + let t1 = exprToTree (ePlus (eSymbol "a") (eTimes (eSymbol "b") (eInt 3)))+ t2 = evalTree t1 (makeEnv ["a", "b"] (map int [7, 5]))+ in assertEqual "unevalTree" t1 (unevalTree t2)++testExprSymbols :: Test+testExprSymbols = + let e1 = ePlus (eSymbol "x") (eSymbol "y")+ e2 = eTimes (ePlus (eSymbol "horse") (eInt 5))+ (eMinus (eInt 6) + (eTimes (eSymbol "neck") (eSymbol "tail")))+ in assertAll+ [+ assertEqual "exprSymbols: 0" + (map Symbol ["x", "y", "+"]) (exprSymbols e1),+ assertEqual "exprSymbols: 1" + ["x", "y"] (exprVarNames e1),+ assertEqual "exprSymbols: 2"+ (map Symbol ["horse", "+", "neck", "tail", "*", "-"])+ (exprSymbols e2),+ assertEqual "exprSymbols: 3"+ ["horse", "neck"]+ (exprVarNames e2)+ ]++testLambda :: Test+testLambda =+ let vx = ESymbol (Symbol "x")+ vy = ESymbol (Symbol "y")+ body = ePlus vx vy+ in assertAll+ [assertEqual "lambda ()"+ (Fail "toLambdaExpr: no arguments; at least one needed")+ (toLambdaExpr [] body)+ , assertEqual "lambda (x)"+ (Succ (ELambda (Symbol "x") body))+ (toLambdaExpr ["x"] body)+ , assertEqual "lambda (x y)"+ (Succ (ELambda (Symbol "x")+ (ELambda (Symbol "y") body)))+ (toLambdaExpr ["x", "y"] body)+ ]++testAppCall :: Test+testAppCall =+ let callFoo ns = ECall (Symbol "foo") (map eInt ns)+ call1 = callFoo [1]+ call2 = callFoo [1, 2]+ call3 = callFoo [1, 2, 3]+ appFoo n = EApp (ESymbol (Symbol "foo")) (eInt n)+ app1 = appFoo 1+ app2 = EApp app1 (eInt 2)+ app3 = EApp app2 (eInt 3)+ in assertAll+ [assertEqual "call to app 1" app1 (callToApp call1)+ , assertEqual "call to app 2" app2 (callToApp call2)+ , assertEqual "call to app 3" app3 (callToApp call3)+ , assertEqual "app to call 1" call1 (appToCall app1)+ , assertEqual "app to call 2" call2 (appToCall app2)+ , assertEqual "app to call 3" call3 (appToCall app3)+ ]+++tests :: Test+tests = TestList [TestLabel "repr" testRepr, + TestLabel "env" testEnv, + TestLabel "expr tree" testExprTree,+ TestLabel "eval" testEval, + TestLabel "eval tree" testEvalTree, + TestLabel "uneval tree" testUnevalTree, + TestLabel "expr symbols" testExprSymbols,+ TestLabel "expr lambda" testLambda,+ TestLabel "ECall <-> EApp exprs" testAppCall+ ]+++runU :: IO ()+runU = utestloop tests
+ tests/Testing/Unit/ExprTreeTests.hs view
@@ -0,0 +1,119 @@+module Testing.Unit.ExprTreeTests (tests, runU)+where++import Test.HUnit++import Data.Number.Sifflet++import Data.Sifflet.Geometry+import Data.Sifflet.Tree as T+import Data.Sifflet.TreeGraph+import Data.Sifflet.TreeLayout+import Data.Sifflet.WGraph++import Language.Sifflet.Examples++import Language.Sifflet.Expr+import Language.Sifflet.ExprTree++import Text.Sifflet.Repr ()++import Testing.Common.ExprTreeTests+import Testing.TestUtil++-- ============================================================+-- UNIT TESTS ++utestGNode :: Test+utestGNode = + let tpp = "The Purple Platypus"+ gnode = makeGNode testStyle zeroIoletCounter (Name tpp)+ Size w h = measureText testStyle tpp+ m = 18.0 -- style textMargin+ mm = 2.0 * m+ x = m+ y = 36.5 -- where does this come from????+ w' = w + mm+ h' = h + mm+ in assertAll+ [assertEqual "GNode of The Purple Platypus"+ CloseEnough+ (gnodeDiff + (GNode (Name tpp) + [TextBox tpp+ (BBox x y w h)+ (BBox 0 0 w' h')]+ (BBox 0 0 w' h')+ [] + [])+ gnode)+ ,+ assertEqual "Translation of GNode by 10, 20"+ CloseEnough+ (gnodeDiff+ (GNode (Name tpp)+ [TextBox tpp+ (BBox (x + 10.0) (y + 20.0) w h)+ (BBox 10.0 20.0 w' h')]+ (BBox 10.0 20.0 w' h') [] [])+ (translate 10 20 gnode))+ ]++utestRepr :: Test+utestRepr = TestCase $+ assertEqual "repr of aDemoExpr"+ ("(if (> ant (+ butterfly 5)) " +++ "(+ ant (+ butterfly cheetah)) (* (+ ant 7) (- butterfly 12)))")+ (repr aDemoExpr)++utestEval :: Test+utestEval = TestCase $+ assertEqual "value of aDemoExpr"+ (EvalOk (VNumber (Exact (-24))))+ (eval aDemoExpr demoEnv)+++utestGraphToExprTree :: Test+utestGraphToExprTree = TestCase $ + do + let expr = ePlus (eTimes (eSymbol "x") (eInt 5))+ (eMinus (eInt 7) (eSymbol "y"))+ exprTree = exprToTree expr+ layoutTree = treeLayout testStyle zeroIoletCounter exprTree+ graph = treeLayoutToGraph layoutTree+ assertEqual "recover expr from tlo tree" exprTree + (graphToExprTree graph 1)++utest1 :: Test+utest1 = TestCase $+ do+ let factFunction = envGetFunction exampleEnv "fact"+ factTree = exprToTree (functionBody factFunction)+ tlo = treeLayout defaultStyle zeroIoletCounter factTree+ let g = orderedTreeToGraph (fmap WSimple tlo)+ assertEqual "graph extract expr tree" factTree+ (grExtractExprTree g 1)++utest2 :: Test+utest2 = TestCase $ + do+ let nSymbol s = ENode (NSymbol (Symbol s)) EvalUntried+ t1 = fmap nSymbol (T.Node "horse" [leaf "saddle", leaf "rider"])+ t2 = fmap nSymbol (T.Node "mule" [leaf "plough", leaf "farmer"])+ y1 :: TreeLayout ExprNode+ y1 = treeLayout wstyle zeroIoletCounter t1+ y2 :: TreeLayout ExprNode+ y2 = treeLayout wstyle zeroIoletCounter t2+ g1 = treeLayoutToGraph y1 :: WGraph+ g2 = grUpdateTreeLayout g1 1 y2 :: WGraph+ assertEqual "grUpdateLayout" y2 (grExtractLayoutTree g2 1)++tests :: Test+tests = TestList [TestLabel "GNode test" utestGNode,+ TestLabel "repr of Expr" utestRepr,+ TestLabel "eval of Expr" utestEval,+ TestLabel "tlo to expr" utestGraphToExprTree,+ utest1, utest2]++runU :: IO Counts+runU = runTestTT tests
+ tests/Testing/Unit/FunctionExamples.hs view
@@ -0,0 +1,123 @@+-- | Example functions for testing simplification of expressions+-- (removing parentheses).++module Testing.Unit.FunctionExamples+ (f1, f2, f3, f4, f5, f6, f7, f8, f9, f10, f11, f12, f13, f14+ , f15, f16)++where++import Data.Number.Sifflet+import Language.Sifflet.Expr++fun :: String -> [String] -> Expr -> Function+fun fname fargs body =+ Function (Just fname) undefined undefined -- undef arg and ret types + (Compound fargs body)++sym :: String -> Expr+sym name = ESymbol (Symbol name)++int :: Integer -> Expr+int n = ENumber (Exact n)++-- | The type of a function with two arguments+type F2 = Expr -> Expr -> Expr++-- | Builds a function call with two arguments,+-- which will be converted to EOp expressions for +-- Haskell or Python+call2 :: String -> F2+call2 name left right = ECall (Symbol name) [left, right]+++plus, minus, times, eq, lt :: F2++plus = call2 "+"+minus = call2 "-"+times = call2 "*"+eq = call2 "=="+lt = call2 "<"++f1, f2, f3, f4, f5, f6, f7, f8, f9, f10, f11, f12, f13, f14 :: Function++f1 = fun "foo" [] (int 1)++f2 = fun "bar" ["a", "b", "c"]+ (plus (times (sym "a") (sym "b"))+ (times (sym "c") (int 2)))++f3 = fun "cup" ["a", "b", "c"]+ (times (plus (sym "a") (sym "b"))+ (plus (sym "c") (int 2)))++f4 = fun "dook" ["a", "b", "c"]+ (plus (sym "a")+ (times (sym "b") (sym "c")))++f5 = fun "egg" ["x", "y", "z"]+ (plus (plus (sym "x") (sym "y"))+ (EIf (lt (sym "x") (sym "y"))+ (plus (sym "z") (int 7))+ (plus (int 1)+ (times (sym "z") (sym "z")))))++f6 = fun "hen" ["x", "y", "z"]+ (plus (plus (sym "x") (sym "y"))+ (plus (sym "z")+ (EIf (lt (sym "x") (sym "y"))+ (int 7)+ (int 16))))++f7 = fun "fact" ["n"]+ (EIf (eq (sym "n") (int 0))+ (int 1)+ (times (sym "n") + (ECall (Symbol "fact") [minus (sym "n") (int 1)])))++f8 = fun "glob" ["x", "y", "z"]+ (plus (sym "x")+ (plus (sym "y") (sym "z")))++f9 = fun "hack" ["x", "y", "z"]+ (minus (sym "x")+ (minus (sym "y") (sym "z")))++f10 = fun "icarus" ["x", "y", "z"]+ (minus (minus (sym "x") (sym "y"))+ (sym "z"))++f11 = fun "jessie" ["x", "y", "z"]+ (plus (minus (sym "x") (sym "y"))+ (sym "z"))++f12 = fun "kicks" ["x", "y", "z"]+ (plus (sym "x")+ (minus (sym "y") (sym "z")))++f13 = fun "lazy" ["x", "y", "z"]+ (minus (plus (sym "x") (sym "y"))+ (sym "z"))++f14 = fun "mental" ["x", "y", "z"]+ (minus (sym "x")+ (plus (sym "y") (sym "z")))+++-- A couple more for consing++cons :: F2+cons = call2 ":"++f15, f16 :: Function++f15 = fun "cons3" ["x", "y", "z"]+ (cons (sym "x")+ (cons (sym "y")+ (cons (sym "z")+ (EList []))))++f16 = fun "add_cons" ["x", "y", "z"]+ (cons (plus (sym "x") (sym "y"))+ (cons (sym "z") + (EList [])))
+ tests/Testing/Unit/GraphTests.hs view
@@ -0,0 +1,299 @@+module Testing.Unit.GraphTests (tests)+where++import System.Cmd+import Test.HUnit++import Data.Graph.Inductive as G++import Data.Sifflet.Functoid+import Data.Sifflet.Geometry+import Data.Sifflet.Tree as T+import Data.Sifflet.TreeGraph+import Data.Sifflet.TreeLayout+import Data.Sifflet.WGraph++import Language.Sifflet.Expr+import Language.Sifflet.ExprTree++import Graphics.Rendering.Sifflet.DrawTreeGraph++import Text.Sifflet.Repr ()++import Testing.Unit.TreeTests hiding (tests)+import Testing.TestUtil++-- (Sym s) is a symbol, similar to (Name s), but its show method+-- is just the string s instead of (Sym s).+-- This is just here for testing with graphviz.++newtype Sym = Sym String+ deriving (Eq)++instance Show Sym where+ show (Sym s) = s++instance Repr Sym where+ repr (Sym s) = s++{- SOME TEST TREES++> putTreeS t5+root+|++- left+|+`- right++-}++t5 :: Tree Sym+t5 = fmap Sym (T.Node "root" [leaf "left", leaf "right"])++{- +++> putTreeS t6+1+|+`- 2+ |+ `- 3+ |+ +- 4+ | |+ | +- 7+ | |+ | `- 8+ |+ +- 5+ |+ `- 6+ |+ +- 9+ |+ `- 10++-}++t6 :: Tree Int+t6 = T.Node 1 [T.Node 2 [T.Node 3 [T.Node 4 [leaf 7, leaf 8],+ leaf 5,+ T.Node 6 [leaf 9, leaf 10]]]]+++{-++> putTreeS t7+'A'+|++- 'B'+| |+| +- 'E'+| |+| `- 'F'+|++- 'C'+|+`- 'D'+ |+ `- 'G'++-}++t7 :: Tree Char+t7 = T.Node 'A' [T.Node 'B' [leaf 'E', leaf 'F'],+ leaf 'C',+ T.Node 'D' [leaf 'G']]++-- UNIT TESTS++utestsNextNodes :: Test+utestsNextNodes = + assertAll [assertEqual "nextNodes 3-5" ([3, 4], 5) + (nextNodes "ab" 3),+ assertEqual "nextNodes 5-8" ([5, 6, 7], 8)+ (nextNodes "cde" 5),+ assertEqual "nextNodes 8-8" ([], 8) (nextNodes [] 8)]++utestsTreeGraph :: Test+utestsTreeGraph =+ let tn1 = (T.Node 1 [leaf 2, leaf 3])+ tn3 = (T.Node 1 [T.Node 2 [leaf 5, leaf 6],+ leaf 3,+ T.Node 4 [leaf 7]])+ tgStruct :: Tree e -> Tree G.Node+ -- is this needed at all?+ tgStruct t = graphToTreeStructure (orderedTreeToGraph t) 1+ in assertAll + [assertEqual "tree graph nodes t5" tn1+ (treeGraphNodesTree t5),+ assertEqual "tree graph nodes t7" tn3+ (treeGraphNodesTree t7),+ assertEqual "tree graph struct t5" tn1+ (tgStruct t5),+ assertEqual "tree graph struct t7" tn3+ (tgStruct t7)]++utestsTreeGraphReconstruct :: Test+utestsTreeGraphReconstruct = + let reconstruct :: Tree e -> Tree e+ reconstruct = graphToOrderedTree . orderedTreeToGraph+ in assertAll [assertEqual "tree graph inverse" t5 (reconstruct t5),+ assertEqual "tree graph inverse" t6 (reconstruct t6),+ assertEqual "tree graph inverse" t7 (reconstruct t7)]++utestsOrderedTreeGraph :: Test+utestsOrderedTreeGraph =+ let t = T.Node "ham" + [T.Node "pineapple" [], + T.Node "juice" + [T.Node "can" [], + T.Node "cup" [], + T.Node "balls" []]]+ g = mkGraph [(1, "ham"),+ (2, "pineapple"),+ (3, "juice"),+ (4, "can"),+ (5, "cup"),+ (6, "balls")]+ [(1, 2, WEdge 0), -- from node 1 to node 2 as 0th child+ (1, 3, WEdge 1),+ (3, 4, WEdge 0),+ (3, 5, WEdge 1),+ (3, 6, WEdge 2)]++ in assertAll [-- assertEqual "ordered tree to graph" g + -- (orderedTreeToGraph t),+ assert $ equal g (orderedTreeToGraph t),+ assertEqual "graph to ordered tree" t (graphToOrderedTree g)]++utestsInsertRemove :: Test+utestsInsertRemove = + let g1 :: Gr String Int+ g1 = mkGraph [(1, "ding"), (2, "aling"), (3, "along")]+ [(1, 3, 0), (2, 3, 0), (3, 1, 0)]+ g0 = mkGraph [(2, "aling"), (3, "along")]+ [(2, 3, 0)]+ g2 = mkGraph [(1, "ding"), (2, "aling"), (3, "along"), (4, "song")]+ [(1, 3, 0), (2, 3, 0), (3, 1, 0)]+ in assertAll+ [assert $ equal g2 (fst (grInsertNode g1 "song")),+ assert $ equal g0 (grRemoveNode g1 1)+ ]+++testGrAddGraph :: Test+testGrAddGraph = + TestCase $ + let g1 :: Gr () ()+ g1 = mkUGraph [1 .. 3] [(1, 2), (1, 3), (2, 3)]+ g2 :: Gr () ()+ g2 = mkUGraph [1 .. 3] [(1, 2), (2, 3), (3, 1)]+ g3 :: Gr () ()+ g3 = mkUGraph [1..6] [(1, 2), (1, 3), (2, 3), (4, 5), (5, 6), (6, 4)]+ in assert $ equal g3 (grAddGraph g1 g2)++testLayoutRoots :: Test+testLayoutRoots = + let m = eSymbol "m"+ n = eSymbol "n"+ t = exprToTree (eIf (eZerop n) + (eInt 0)+ (ePlus m (eMinus m (eSub1 n))))+ lt = treeLayout style0 zeroIoletCounter t+ lf = map (treeLayout style0 zeroIoletCounter) (subForest t)+ f1 = FLayoutTree lt+ f2 = FLayoutForest lf (BBox 0 0 0 0)+ in assertAll+ [assertEqual "tlo to graph roots, function tree" + [1]+ (flayoutToGraphRoots f1)+ ,+ assertEqual "tlo to graph roots, function parts forest" + [1, 3, 4]+ (flayoutToGraphRoots f2)+ ]++testGraphOrphans :: Test+testGraphOrphans =+ let g0 :: Gr String ()+ g0 = mkGraph [(0, "A"), (1, "B"), (2, "C"), (3, "D"), (4, "E")]+ [(0, 1, ()), (0, 2, ()), (0, 3, ()), + (3, 2, ()),+ (4, 1, ()), (4, 2, ())]+ g1 :: Gr String ()+ g1 = mkGraph [(0, "WFrame"), (1, "f"), (2, "g"), (3, "x"), (4, "y"),+ (5, "add1"), (6, "y"), (7, "x")]+ [(1, 2, ()), (1, 3, ()), (1, 4, ()),+ (2, 5, ()), (2, 6, ()),+ (5, 7, ())]+ in assertAll+ [assertEqual "graphOrphans g0" [0, 4] (graphOrphans g0),+ assertEqual "graphOrphans g1" [0, 1] (graphOrphans g1)]++tests :: Test+tests = TestList [utestsInsertRemove,+ testGrAddGraph,+ utestsNextNodes, + utestsTreeGraph,+ utestsTreeGraphReconstruct,+ utestsOrderedTreeGraph,+ testLayoutRoots,+ testGraphOrphans+ ]++runU :: IO Counts+runU = runTestTT tests++testm :: (Show e, Repr e) => [Style] -> Tree e -> IO ()+testm styles t = + mapM_ (\s -> gtkShowTree s zeroIoletCounter t) styles++-- test render a graph, simple form+testRenderGraph1 :: (Repr e) => Tree e -> IO ()+testRenderGraph1 t =+ let style = defaultStyle+ tlo = treeLayout style zeroIoletCounter t+ Size surfWidth surfHeight = treeLayoutPaddedSize style tlo+ g = orderedTreeToGraph tlo+ file = "tmp.png"+ in graphWriteImageFile style (Just 1) (Just 2) + surfWidth surfHeight g file >> + system ("feh " ++ file) >> + return ()+++testRenderGraph2a :: IO ()+testRenderGraph2a = testRenderGraph2Aux t3 (grTranslateNode 2 (-100) (-50))++testRenderGraph2b :: IO ()+testRenderGraph2b = testRenderGraph2Aux t3 (grTranslateNode 2 100 50)++testRenderGraph2c :: IO ()+testRenderGraph2c = testRenderGraph2Aux t3 (grTranslateNode 3 (-100) 20)++testRenderGraph3a :: IO ()+testRenderGraph3a = testRenderGraph2Aux t3 (grTranslateSubtree 2 100 50)++testRenderGraph3b :: IO ()+testRenderGraph3b = testRenderGraph2Aux t3 (grTranslateSubtree 4 (-50) (-50))+++-- test render a graph, with a transformation+-- the second argument updates the graph, for example by+-- translating a node or a subtree++testRenderGraph2Aux :: + (Repr n) => Tree n -> (LayoutGraph n WEdge -> LayoutGraph n WEdge) -> IO ()+testRenderGraph2Aux t transform =+ let style = defaultStyle+ tlo = treeLayout style zeroIoletCounter t+ Size surfWidth surfHeight = treeLayoutPaddedSize style tlo+ g = transform (orderedTreeToGraph tlo)+ file = "tmp.png"+ in graphWriteImageFile style (Just 1) Nothing+ surfWidth surfHeight g file >>+ system ("feh " ++ file) >>+ return ()+
+ tests/Testing/Unit/LayoutTests.hs view
@@ -0,0 +1,321 @@+module Testing.Unit.LayoutTests + (tests, runU)++where++import Graphics.Rendering.Cairo hiding (translate)++import Data.Tree as DT+import System.Process+import Test.HUnit++import Data.Sifflet.Geometry+import Data.Sifflet.Tree+import Data.Sifflet.TreeLayout+import Graphics.Rendering.Sifflet.DrawTreeGraph+import Text.Sifflet.Repr ()++import Testing.TestUtil++import Testing.Common.TestStyles+import Testing.Unit.TreeTests hiding (tests, runU)++testStyle :: Style+testStyle = styleTest4++-- Is there a way to unify and generalize these, testF and testFIo?++testF :: (Repr a, Repr b) => Tree a -> (Tree a -> Tree b) -> IO ()+testF t f = + putTreeR t >>+ putStrLn "=>" >>+ putTreeR (f t)++testFIo :: (Repr a, Repr b) => Tree a -> (Tree a -> IO (Tree b)) -> IO ()+testFIo t f = + putTreeR t >>+ putStrLn "=>" >>+ f t >>= putTreeR++treeLayoutAsTree :: TreeLayout e -> Tree (e, BBox, BBox)+treeLayoutAsTree (DT.Node (LayoutNode gnode treeBB) sublayouts) =+ DT.Node (gnodeValue gnode, gnodeNodeBB gnode, treeBB)+ (map treeLayoutAsTree sublayouts)++-- Illegal symbol '.' in type ***+-- but this is the type that ghc infers!+-- testLo :: forall a. (Repr a, Repr (LayoutNode a)) =>+-- Tree a -> IO ()+testLo t = testF t (treeLayout testStyle zeroIoletCounter)++-- Illegal symbol '.' in type, ***+-- testVi :: forall e. (Show e, Repr e) =>+-- Tree e -> IO ()+testVi t = + putTree t >>+ putStrLn "=> tmp.png (type q or Esc to finish)" >>+ treeWriteImageFile testStyle zeroIoletCounter t "tmp.png" >>+ system "feh tmp.png" >>+ return ()++testNodeSize :: Test+testNodeSize = TestCase $ do+ let gtree = treeGNodes testStyle zeroIoletCounter t2c+ -- Expected dimensions+ size = measureText testStyle+ Size w1' h1' = size "floor"+ Size w3' h3' = size "mat"+ Size w5' h5' = size "textile"+ m = 4.0 -- text margin+ mm = 2 * m+ -- Actual tree of GNodes+ DT.Node (GNode (Name "floor") + [TextBox "floor" (BBox _ _ w1 h1) (BBox _ _ w2 h2)]+ _ _ _)+ [DT.Node (GNode (Name "mat") + [TextBox "mat" (BBox _ _ w3 h3) (BBox _ _ w4 h4)]+ _ _ _)+ [],+ DT.Node (GNode (Name "textile")+ [TextBox "textile" (BBox _ _ w5 h5) (BBox _ _ w6 h6)]+ _ _ _)+ []] = gtree++ assertEqual "tree GNodes"+ -- [43, 26, 51, 34, 35, 26, 43, 34, 60, 26, 68, 34]+ [w1', h1', w1' + mm, h1' + mm,+ w3', h3', w3' + mm, h3' + mm,+ w5', h5', w5' + mm, h5' + mm]+ [w1, h1, w2, h2, w3, h3, w4, h4, w5, h5, w6, h6]+-- 44 52++testTextCenter :: Test+testTextCenter = + let gtree = treeGNodes testStyle zeroIoletCounter t2c+ (DT.Node (GNode _ [tb1] _ _ _) + [DT.Node (GNode _ [tb2] _ _ _) [],+ DT.Node (GNode _ [tb3] _ _ _) []]) = gtree+ tb2' = offsetTextBoxCenters (Position 15 20) tb1 tb2+ Position cbx cby = tbBoxCenter tb1+ Position cbx' cby' = tbBoxCenter tb2'+ Position ctx cty = tbTextCenter tb1+ Position ctx' cty' = tbTextCenter tb2'+ -- tbCenter is tbBoxCenter; we should get the same xs using tbTextCenter, + -- since the text should be horizontally centered in its box, + -- but not the same ys, since the y's of text are strange!+ in assertAll+ [assertEqual "text box centers 1" + (posX (tbCenter tb1)) (posX (tbTextCenter tb1))+ ,+ assertEqual "text box centers 2" + (posX (tbCenter tb2)) (posX (tbTextCenter tb2))+ ,+ assertEqual "text box centers 3"+ (posX (tbCenter tb3)) (posX (tbTextCenter tb3))+ ,+ assertEqual "text box center box offset"+ (15, 20) (cbx' - cbx, cby' - cby)+ ,+ assertEqual "text box center text offset"+ (15, 20) (ctx' - ctx, cty' - cty)+ ]++testTreeSize :: Test+testTreeSize = TestCase $ do+ let t = treeGNodes testStyle zeroIoletCounter t2c+ assertEqual "tree sizes t2c"+ CloseEnough+ (sizeTreeDiff+ (DT.Node Size {sizeW = 138.0, sizeH = 104.0}+ [leaf Size {sizeW = 43.0, sizeH = 34.0},+ leaf Size {sizeW = 68.0, sizeH = 34.0}+ ])+ (treeSizes testStyle t))+++-- | This has to go into the IO monad to call treeLayout.+-- How, if at all, can I get it out? Probably not.+testLayout :: Test+testLayout = + let tlo = treeLayout testStyle zeroIoletCounter t2c+ DT.Node (LayoutNode (GNode _ [TextBox _ bb1 bb2] _ _ _) bb3)+ [DT.Node (LayoutNode (GNode _ [TextBox _ bb4 bb5] _ _ _) bb6)+ [],+ DT.Node (LayoutNode (GNode _ [TextBox _ bb7 bb8] _ _ _) bb9)+ []] = tlo+-- *** Figuring this out from first principles is murderous!!+-- -- now calculate some expected values+-- mm = 2 * textMargin testStyle+-- mx = hpad testStyle+-- my = vpad testStyle++-- mt = measureText testStyle+-- Size w1 h1 = mt "floor"++-- (x3, y3) = (mx, my)++-- Size w4 h4 = mt "mat"+-- (w2, h2) = (w1 + mm, h1 + mm)+-- (w5, h5) = (w4 + mm, h4 + mm)+-- Size w7 h7 = mt "textile"+-- (w8, h8) = (w7 + mm, h7 + mm)++-- fullWidth = (w4 + mm) + mx + (w7 + mm)+-- fullHeight = (h1 + mm) + my + (h4 + mm)++-- bb1' = BBox ? ? w1 h1+-- bb2' = BBox ? ? w2 h2+-- bb3' = BBox mx my fullWidth fullHeight++-- bb4' = BBox (mx + mm) ? w4 h4+-- bb5' = BBox mx ? (w4 + mm) (h4 + mm)+-- bb6' = bb5'++-- bb7' = BBox (mx + w4 + mm + mx) ? w7 h7+-- bb8' = BBox (mx + w4 + mm + mx + mm) ? w8 h8+-- bb9' = bb8'+--+ in assertAll+ [assertEqual "tree tlo t2c floor text" + CloseEnough (bboxDiff (BBox 74.0 58.5 44.0 26.0) bb1)+ ,+ assertEqual "tree tlo t2c floor box"+ CloseEnough (bboxDiff (BBox 70.0 36.0 52.0 34.0) bb2)+ ,+ assertEqual "tree tlo t2c floor tree"+ CloseEnough (bboxDiff (BBox 27.0 36.0 138.0 104.0) bb3)+ ,+ assertEqual "tree tlo t2c mat text"+ CloseEnough (bboxDiff (BBox 31.0 128.5 35.0 26.0) bb4)+ ,+ assertEqual "tree tlo t2c mat box"+ CloseEnough (bboxDiff (BBox 27.0 106.0 43.0 34.0) bb5)+ ,+ assertEqual "tree tlo t2c mat tree"+ CloseEnough (bboxDiff (BBox 27.0 106.0 43.0 34.0) bb6)+ ,+ assertEqual "tree tlo t2c textile text"+ CloseEnough (bboxDiff (BBox 101.0 128.5 58.0 26.0) bb7) + ,+ assertEqual "tree tlo t2c textile box"+ CloseEnough (bboxDiff (BBox 97.0 106.0 68.0 34.0) bb8)+ ,+ assertEqual "tree tlo t2c textile tree"+ CloseEnough (bboxDiff (BBox 97.0 106.0 68.0 34.0) bb9)+ ]++testBBMerge :: Test+testBBMerge = assertAll+ [assertEqual "bbMerge, intersecting"+ (BBox 0 0 50 120)+ (bbMerge (BBox 0 0 50 100) (BBox 10 20 30 100)),+ assertEqual "bbMerge, non-intersecting"+ (BBox 0 0 130 140)+ (bbMerge (BBox 0 0 100 100) + (BBox 110 110 20 30)),+ assertEqual "bbMerge, enclosed"+ (BBox 0 0 200 200)+ (bbMerge (BBox 0 0 200 200) (BBox 50 50 50 50)),+ assertEqual "bbMerge, reversed"+ (BBox 0.0 0.0 200.0 200.0)+ (bbMerge (BBox 50 50 50 50) (BBox 0 0 200 200))+ ]++testTranslate :: Test+testTranslate = assertAll+ [assertEqual "translate Position"+ (Position 110 220)+ (translate 10 20 (Position 100 200)),+ assertEqual "translate BBox"+ (BBox 110 220 50 80)+ (translate 10 20 (BBox 100 200 50 80))]+ +testCircleIolets :: Test +testCircleIolets = + let style = style0 {styleIoletRadius = 10} + row n = makeIoletsRow style 100 200 n -- row of n iolets+ in assertAll [assertEqual "iolets, n = 1"+ [Iolet (Circle (Position 100 200) 10)]+ (row 1),+ assertEqual "iolets, n = 3"+ [Iolet (Circle (Position 80 200) 10),+ Iolet (Circle (Position 100 200) 10),+ Iolet (Circle (Position 120 200) 10)]+ (row 3),+ assertEqual "iolets, n = 2"+ [Iolet (Circle (Position 90 200) 10),+ Iolet (Circle (Position 110 200) 10)]+ (row 2),+ assertEqual "circle translate"+ (Circle (Position 120 280) 50)+ (translate 20 80 + (Circle (Position 100 200) 50)),+ assertEqual "iolet translate"+ (Iolet (Circle (Position 30 50) 2))+ (translate (-70) 25+ (Iolet (Circle (Position 100 25) 2)))]++testTreeWindowMargin :: Test+testTreeWindowMargin =+ let styleA = + styleTest0 {styleFont = + VFont "serif" FontSlantNormal FontWeightNormal 18, + lineWidth = 2, textMargin = 18.0, + hpad = 27, vpad = 36,+ exomargin = 0, vtinypad = (4.5, 4.5),+ styleFramePad = 35}+ styleB = styleA {exomargin = 10}+ testTree = Node 1 [Node 2 [], Node 3 []] :: Tree Int+ nodeTextBB :: LayoutNode Int -> BBox+ nodeTextBB = tbTextBB . head . gnodeTextBoxes . nodeGNode+ node1 :: Tree (LayoutNode Int) -> LayoutNode Int+ node1 = rootLabel + node3 :: Tree (LayoutNode Int) -> LayoutNode Int+ node3 = rootLabel . head . tail . subForest++ layoutA = treeLayout styleA zeroIoletCounter testTree+ layoutB = treeLayout styleB zeroIoletCounter testTree+ in assertAll+ [+ -- Assertions re. root node (node 1)+ assertEqual "node 1 text bbox A" CloseEnough+ (bboxDiff (BBox 82 72.5 11 26) (nodeTextBB (node1 layoutA)))+ ,+ assertEqual "node 1 text bbox B" CloseEnough+ (bboxDiff (BBox 92 82.5 11 26) (nodeTextBB (node1 layoutB)))+ ,+ assertEqual "node 1 tree bbox A" CloseEnough+ (bboxDiff (BBox 27 36 121 160) (nodeTreeBB (node1 layoutA)))+ ,+ assertEqual "node 1 tree bbox B" CloseEnough+ (bboxDiff (BBox 27 36 141 180) (nodeTreeBB (node1 layoutB)))+ ,+ -- Assertions re. root's 2nd child (node 3)+ assertEqual "node 3 text bbox A" CloseEnough+ (bboxDiff (BBox 119 170.5 11 26) (nodeTextBB (node3 layoutA)))+ ,+ assertEqual "node 3 text bbox B" CloseEnough+ (bboxDiff (BBox 129 180.5 11 26) (nodeTextBB (node3 layoutB)))+ ,+ assertEqual "node 3 tree bbox A" CloseEnough+ (bboxDiff (BBox 101 134 47 62) (nodeTreeBB (node3 layoutA)))+ ,+ assertEqual "node 3 tree bbox B" CloseEnough+ (bboxDiff (BBox 111 144 47 62) (nodeTreeBB (node3 layoutB)))+ ]++tests :: Test+tests = TestList [TestLabel "node size" testNodeSize,+ TestLabel "text center" testTextCenter,+ TestLabel "tree sizes" testTreeSize,+ TestLabel "tlo" testLayout,+ -- , TestLabel "tree tlo" testLayout'+ TestLabel "bbmerge" testBBMerge,+ TestLabel "translate" testTranslate,+ TestLabel "circles and iolets" testCircleIolets,+ TestLabel "tree window margin" testTreeWindowMargin+ ]+++runU :: IO Counts+runU = runTestTT tests
+ tests/Testing/Unit/ParserTests.hs view
@@ -0,0 +1,245 @@+module Testing.Unit.ParserTests (int, float, runU, tests)+where++import Text.ParserCombinators.Parsec++import Test.HUnit++import Data.Number.Sifflet+import Language.Sifflet.Expr+import Language.Sifflet.Parser+import Language.Sifflet.Util (SuccFail(..))++import Testing.TestUtil (assertAll, utestloop)++int :: Integer -> Value+int = VNumber . Exact++float :: Double -> Value+float = VNumber . Inexact++-- Tests for the parser++testParseExpr :: Test+testParseExpr =+ assertAll+ [assertEqual "parseExpr: int" (Succ (eInt 1)) (parseExpr "1"),+ assertEqual "parseExpr: float" + (Succ (eFloat 12.5)) (parseExpr "12.5"),+ assertEqual "parseExpr: char" (Succ (eChar 'c'))+ (parseExpr "'c'"),+ assertEqual "parseExpr: string" (Succ (eString "five ducks")) + (parseExpr "\"five ducks\""),+ -- parser does not recognize symbols; should it?+ -- assertEqual "parseExpr: symbol" (Succ (eSymbol "henry_viii"))+ -- (parseExpr "henry_viii"),+ assertEqual "parseExpr: list of int" + (Succ (EList [eInt 1, eInt 6, eInt 33]))+ (parseExpr "[1, 6, 33]"),+ assertEqual "parseExpr: list of mixed type" + (Succ (EList [eInt 15, eString "horses", eChar 'y',+ eFloat 6.2]))+ (parseExpr "[15, \"horses\", 'y', 6.2]"),+ assertEqual "parseExpr: bool" + (Succ eFalse) (parseExpr "False"),+ assertEqual "parseExpr: input error 1" -- an unterminated list+ (Fail "\"user input\" (line 1, column 22):\nunexpected end of input\nexpecting space, \",\" or \"]\"")+ (parseExpr "[1, \"horse\", 'y', 12."),+ assertEqual "parseExpr: input error 2" + (Fail "\"user input\" (line 1, column 2):\nunexpected 'f'\nexpecting digit, space or end of input")+ (parseTypedInput2 ("7figs", typeNum))]++testExprToValue :: Test+testExprToValue =+ assertAll+ [assertEqual "exprToValue: int" (Succ (int 1)) (exprToValue (eInt 1)),+ assertEqual "exprToValue: float" (Succ (float 12.5)) + (exprToValue (eFloat 12.5)),+ assertEqual "exprToValue: string" (Succ (VString "cow"))+ (exprToValue (eString "cow")),+ assertEqual "exprToValue: if" + (Succ (int 7))+ (exprToValue (eIf eTrue (eInt 7) (eInt 11))),+ assertEqual "exprToValue: call" + (Succ (int 18))+ (exprToValue (ePlus (eInt 7) (eInt 11)))]+++testStringToValue :: Test+testStringToValue = + assertAll+ [assertEqual "parseValue: int" (Succ (int 8)) (parseValue "8"),+ assertEqual "parseValue: float" (Succ (float (-1.5)))+ (parseValue "-1.5"),+ assertEqual "parseValue: string" (Succ (VString "patty cake"))+ (parseValue "\"patty cake\""),+ assertEqual "parseValue: list of mixed type" + (Succ (VList [int 12, float 1.7, + VString "harry", VList []]))+ (parseValue "[12, 1.7, \"harry\", []]"),+ assertEqual "parseValue: bool" (Succ (VBool True)) + (parseValue "True"),+ assertEqual "parseValue: incomplete list" + (Fail ("\"user input\" (line 1, column 8):\n" +++ "unexpected end of input\n" +++ "expecting space, boolean, character, " +++ "string, real number, integer or list"))+ (parseValue "[1, 2, ")+ ]+++-- BEGIN NEW TESTS++data ParseResult = PE {peColumn :: Column,+ peUnexpected :: String,+ peExpecting :: String}+ | PV Value+ deriving (Eq, Show)++dquote :: String -> String+dquote s = "\"" ++ s ++ "\""++squote :: Char -> String+squote c = ['\'', c, '\'']++parseResult :: Parser Value -> String -> ParseResult+parseResult p s =+ case parse p "test input" s of+ Left err ->+ let pos = errorPos err+ col = sourceColumn pos+ msgLines = tail (lines (show err))+ theUnexpected = unwords (tail (words (msgLines !! 0)))+ expecting = unwords (tail (words (msgLines !! 1)))+ in PE {peColumn = col, peUnexpected = theUnexpected,+ peExpecting = expecting}+ Right v -> PV v++parseAssert :: Type -> String -> ParseResult -> Assertion+parseAssert t s expectedResult =+ let description = "parse " ++ s ++ " as " ++ show t +++ (case expectedResult of+ PV _ -> "succeeds"+ _ -> "fails")+ in assertEqual description expectedResult+ (parseResult (nothingBut (typedValue t)) s)++testBool :: Test+testBool = + assertAll+ [parseAssert typeBool "True" (PV (VBool True)) + , parseAssert typeBool "False" (PV (VBool False))+ , parseAssert typeBool "123" (PE 1 (dquote "1") "space or boolean")+ , parseAssert typeBool "Truex" (PE 5 (squote 'x') + "space or end of input")+ , parseAssert typeBool "Truck" (PE 1 (dquote "T") "space or boolean")+ ]++testChar :: Test+testChar = + let close = "closing single quote"+ in assertAll+ [parseAssert typeChar "'c'" (PV (VChar 'c'))+ , parseAssert typeChar "'\\\\'" (PV (VChar '\\'))+ , parseAssert typeChar "'\\n'" (PV (VChar '\n'))+ , parseAssert typeChar "'\\r'" (PV (VChar '\r'))+ , parseAssert typeChar "'\\t'" (PV (VChar '\t'))+ , parseAssert typeChar "'cd'" + (PE 3 (dquote "d") close)+ , parseAssert typeChar "'\\x'" + (PE 3 (dquote "x") close)+ , parseAssert typeChar "\"\"\""+ (PE 1 "\"\\\"\"" "space or character") -- ??+ ]++testString :: Test+testString = + assertAll+ [parseAssert typeString (dquote "abc") (PV (VString "abc"))+ , parseAssert typeString (dquote "1 2 3 4") (PV (VString "1 2 3 4"))+ , parseAssert typeString "\"1 2 3"+ (PE 7 "end of input" "close of quotation")+ , parseAssert typeString "1 2 3\""+ (PE 1 (dquote "1") "space or string")+ ]++testNum :: Test+testNum = assertAll [parseAssert typeNum "12" (PV (int 12))+ , parseAssert typeNum "+155" (PV (int 155))+ , parseAssert typeNum "-279" (PV (int (-279)))+ , parseAssert typeNum "-000279" (PV (int (-279)))+ , parseAssert typeNum "000279" (PV (int 279))+ , parseAssert typeNum "+000279" (PV (int 279))+ , parseAssert typeNum "0" (PV (int 0))+ , parseAssert typeNum "-0" (PV (int 0))++ , parseAssert typeNum "0.0" (PV (float 0.0))+ , parseAssert typeNum "0." (PV (float 0.0))+ , parseAssert typeNum ".0" (PV (float 0.0))+ , parseAssert typeNum "-.0" (PV (float 0.0))+ , parseAssert typeNum "+.0" (PV (float 0.0))+ , parseAssert typeNum "12.5" (PV (float 12.5))+ , parseAssert typeNum "+12.5" (PV (float 12.5))+ , parseAssert typeNum "-12.5" (PV (float (-12.5)))+ , parseAssert typeNum "1.25e2" (PV (float 125.0))+ , parseAssert typeNum "1.25e+2" (PV (float 125.0))+ , parseAssert typeNum "1.25e-3" (PV (float 0.00125))+ , parseAssert typeNum "-7.25e-3" (PV (float (-0.00725)))+ , parseAssert typeNum "00.0625" (PV (float 0.0625))+ + , parseAssert typeNum "++987" + (PE 2 (dquote "+") "digit")+ , parseAssert typeNum "'987'" + (PE 1 (dquote "'") "space or number")+ , parseAssert typeNum "x987" + (PE 1 (dquote "x") "space or number")+ , parseAssert typeNum "987x" + (PE 4 (squote 'x')+ "digit, space or end of input")+ + , parseAssert typeNum "9.87.9"+ (PE 5 (squote '.') + "digit, space or end of input")+ , parseAssert typeNum "9 87.9"+ (PE 3 (squote '8') "space or end of input")+ ]++testList :: Test+testList = assertAll [parseAssert (typeList typeNum)+ "[1,3,5]"+ (PV (VList [int 1, int 3, int 5]))+ , parseAssert (typeList typeNum)+ "[]"+ (PV (VList []))+ , parseAssert (typeList typeBool)+ "[]"+ (PV (VList []))+ , parseAssert (typeList typeChar)+ " [ 'c', 'a', 't' ] "+ (PV (VList [VChar 'c', VChar 'a', VChar 't']))+ , parseAssert (typeList typeBool)+ "[1, 2, 3]"+ (PE 2 (dquote "1") + "space, boolean or \"]\"")+ , parseAssert (typeList typeNum)+ "[12 , 34 56]"+ (PE 10 (dquote "5")+ "space or \"]\"")+ ]++tests :: Test+tests = TestList [TestLabel "parse expr" testParseExpr,+ TestLabel "expr to value" testExprToValue,+ TestLabel "string to value" testStringToValue,+ TestLabel "parse bool" testBool,+ TestLabel "parse char" testChar,++ TestLabel "parse string" testString,+ TestLabel "parse num" testNum,+ TestLabel "parse list" testList]++runU :: IO ()+runU = utestloop tests+++
+ tests/Testing/Unit/ToHaskellTests.hs view
@@ -0,0 +1,98 @@+module Testing.Unit.ToHaskellTests+ (tests, runU)+where++import Test.HUnit++import Data.Number.Sifflet+import Language.Sifflet.Expr (Expr(..), Function)+import Language.Sifflet.Export.Haskell+import Language.Sifflet.Export.ToHaskell++import Testing.Unit.FunctionExamples+import Testing.TestUtil (assertAll, utestloop)++-- These tests functions should be replaced by those in Test.hs+-- converted to Python++hsdef :: Function -> Decl+hsdef = functionToHsDecl+++hf1, hf2, hf3, hf4, hf5, hf6, hf7, hf8, hf9 :: Decl++hf1 = hsdef f1+hf2 = hsdef f2+hf3 = hsdef f3+hf4 = hsdef f4+hf5 = hsdef f5+hf6 = hsdef f6+hf7 = hsdef f7+hf8 = hsdef f8+hf9 = hsdef f9++hf10, hf11, hf12, hf13, hf14 :: Decl++hf10 = hsdef f10+hf11 = hsdef f11+hf12 = hsdef f12+hf13 = hsdef f13+hf14 = hsdef f14+++hf15, hf16 :: Decl++hf15 = hsdef f15+hf16 = hsdef f16++tests :: Test+tests = + let -- toHs = hsPretty -- was: pretty . alterParens bestParens+ tfunc label func result =+ assertEqual label result (hsPretty func)+ texpr label expr result =+ assertEqual label result (hsPretty (exprToHsExpr expr))+ sixSeven = map (ENumber . Exact) [6, 7]+ in assertAll+ [+ tfunc "hf1" hf1 ("foo =\n" +++ " 1")+ , tfunc "hf2" hf2 ("bar a b c =\n" +++ " a * b + c * 2")+ , tfunc "hf3" hf3 ("cup a b c =\n" +++ " (a + b) * (c + 2)")+ , tfunc "hf4" hf4 ("dook a b c =\n" +++ " a + b * c")++ , tfunc "hf5" hf5 + ("egg x y z =\n" +++ " x + y + if x < y then z + 7 else 1 + z * z")+ , tfunc "hf6" hf6+ ("hen x y z =\n" +++ " x + y + z + if x < y then 7 else 16")+ , tfunc "hf7" hf7+ ("fact n =\n" +++ " if n == 0 then 1 else n * fact (n - 1)")+ , tfunc "hf8" hf8 ("glob x y z =\n" +++ " x + y + z")+ , tfunc "hf9" hf9 ("hack x y z =\n" +++ " x - (y - z)")+ , tfunc "hf10" hf10 ("icarus x y z =\n" +++ " x - y - z")+ , tfunc "hf11" hf11 ("jessie x y z =\n" +++ " x - y + z")+ , tfunc "hf12" hf12 ("kicks x y z =\n" +++ " x + (y - z)")+ , tfunc "hf13" hf13 ("lazy x y z =\n" +++ " x + y - z")+ , tfunc "hf14" hf14 ("mental x y z =\n" +++ " x - (y + z)")+ , tfunc "hf15" hf15 ("cons3 x y z =\n" +++ " x : y : z : []")+ , tfunc "hf16" hf16 ("add_cons x y z =\n" +++ " x + y : z : []")+ , texpr "e1" (EList sixSeven) "[6, 7]"+ ]++runU :: IO ()+runU = utestloop tests
+ tests/Testing/Unit/ToPythonTests.hs view
@@ -0,0 +1,87 @@+module Testing.Unit.ToPythonTests+ (tests, runU)+where++import Test.HUnit++import Data.Number.Sifflet+import Language.Sifflet.Expr (Expr(..), Function)+import Language.Sifflet.Export.Python+import Language.Sifflet.Export.ToPython++import Testing.Unit.FunctionExamples+import Testing.TestUtil (assertAll, utestloop)++-- These tests functions should be replaced by those in Test.hs+-- converted to Python++pydef :: Function -> PStatement+pydef = functionToPyDef+++pf1, pf2, pf3, pf4, pf5, pf6, pf7, pf8, pf9 :: PStatement++pf1 = pydef f1+pf2 = pydef f2+pf3 = pydef f3+pf4 = pydef f4+pf5 = pydef f5+pf6 = pydef f6+pf7 = pydef f7+pf8 = pydef f8+pf9 = pydef f9++pf10, pf11, pf12, pf13, pf14 :: PStatement++pf10 = pydef f10+pf11 = pydef f11+pf12 = pydef f12+pf13 = pydef f13+pf14 = pydef f14++tests :: Test+tests = + let toPy = pyPretty -- was: pretty . alterParens bestParens+ tfunc label func result =+ assertEqual label result (toPy func)+ texpr label expr result =+ assertEqual label result (pyPretty (exprToPExpr expr))+ sixSeven = map (ENumber . Exact) [6, 7]+ in assertAll+ [+ tfunc "pf1" pf1 ("def foo():\n" +++ " return 1")+ , tfunc "pf2" pf2 ("def bar(a, b, c):\n" +++ " return a * b + c * 2")+ , tfunc "pf3" pf3 ("def cup(a, b, c):\n" +++ " return (a + b) * (c + 2)")+ , tfunc "pf4" pf4 ("def dook(a, b, c):\n" +++ " return a + b * c")+ , tfunc "pf5" pf5 + ("def egg(x, y, z):\n" +++ " return x + y + (z + 7 if x < y else 1 + z * z)")+ , tfunc "pf6" pf6+ ("def hen(x, y, z):\n" +++ " return x + y + z + (7 if x < y else 16)")+ , tfunc "pf7" pf7+ ("def fact(n):\n" +++ " return 1 if n == 0 else n * fact(n - 1)")+ , tfunc "pf8" pf8 ("def glob(x, y, z):\n" +++ " return x + y + z")+ , tfunc "pf9" pf9 ("def hack(x, y, z):\n" +++ " return x - (y - z)")+ , tfunc "pf10" pf10 ("def icarus(x, y, z):\n" +++ " return x - y - z")+ , tfunc "pf11" pf11 ("def jessie(x, y, z):\n" +++ " return x - y + z")+ , tfunc "pf12" pf12 ("def kicks(x, y, z):\n" +++ " return x + (y - z)")+ , tfunc "pf13" pf13 ("def lazy(x, y, z):\n" +++ " return x + y - z")+ , tfunc "pf14" pf14 ("def mental(x, y, z):\n" +++ " return x - (y + z)")+ , texpr "pe1" (EList sixSeven) "li(6, 7)"+ ]++runU :: IO ()+runU = utestloop tests
+ tests/Testing/Unit/ToSchemeTests.hs view
@@ -0,0 +1,365 @@+-- | Testing for Language.Sifflet.Export.ToScheme++module Testing.Unit.ToSchemeTests + (tests, runU, testExpr, testExampleDef, ted+ , t6, mt0, mt1, mt2, t7, t8+ , test', testf')++where++import Test.HUnit++import Data.Number.Sifflet+import Language.Sifflet.Export.ToScheme+import Language.Sifflet.Expr+import Language.Sifflet.Examples+import Text.Sifflet.Repr+import Text.Sifflet.Pretty++import Testing.TestUtil (utestloop)++-- | Test expr labels+labels :: [String]+labels = ["undefined", "symbol foo", "False", "True", + "char c", "if True then 7 else 88",+ "nested list"]++-- | Test expressions++exprs :: [Expr]+exprs = [EUndefined+ , ESymbol (Symbol "foo")+ , EBool False+ , EBool True+ , EChar 'c'++ , EIf (EBool True) + (ENumber (Exact 7))+ (ENumber (Exact 88))++ , EList [EBool True,+ EChar 'x',+ ENumber (Exact 35), + ENumber (Inexact 4.6),+ EString "cozy",+ EList [],+ EList [EBool False,+ EChar 'y',+ EString "",+ EList []]]+ ]++-- | Corresponding S-expressions++sexprs :: [SExpr]+sexprs = [SAtom (SSymbol "*sifflet-undefined*")+ , SAtom (SSymbol "foo")+ , SAtom (SBool False)+ , SAtom (SBool True)+ , SAtom (SChar 'c')++ , SList [SAtom (SSymbol "if"),+ SAtom (SBool True),+ SAtom (SInt 7),+ SAtom (SInt 88)]++ , SList [SAtom (SSymbol "list"),+ SAtom (SBool True),+ SAtom (SChar 'x'),+ SAtom (SInt 35),+ SAtom (SFloat 4.6),+ SAtom (SString "cozy"),+ SList [SAtom (SSymbol "list")],+ SList [SAtom (SSymbol "list"),+ SAtom (SBool False),+ SAtom (SChar 'y'),+ SAtom (SString ""),+ SList [SAtom (SSymbol "list")]]]+ ]++-- | Corresponding repr strings++reprStrings :: [String]+reprStrings = + ["*sifflet-undefined*"+ , "foo"+ , "#f"+ , "#t"+ , "'c'"++ , "(if #t 7 88)"++ , "(list #t 'x' 35 4.6 \"cozy\" (list) (list #f 'y' \"\" (list)))"++ ]++-- | Corresponding pretty strings++pretties :: [String]+pretties = ["*sifflet-undefined*"+ , "foo"+ , "#f"+ , "#t"+ , "'c'"++ , "(if #t 7 88)"++ , concat [ "(list #t"+ , "\n 'x'"+ , "\n 35"+ , "\n 4.6"+ , "\n \"cozy\""+ , "\n (list)"+ , "\n (list #f"+ , "\n 'y'"+ , "\n \"\""+ , "\n (list)))"+ ]++ ]++moreLabels :: [String]+moreLabels = ["empty list"+ , "flat list"+ , "nested list"+ , "if expr"+ , "list expression with evaluation"+ , "list expression without evaluation"+ ]+++eint :: Integer -> Expr+eint n = ENumber (Exact n)++moreExprs :: [Expr]+moreExprs = [EList []+ , EList [eint 1+ , EBool False+ , EString "thunder"]+ , EList [EList [eint 1, eint 2]+ , EList [eint 3, eint 4, eint 5]+ , EList []+ , EList [eint 6, eint 7]]+ , let sa = ESymbol (Symbol "a")+ sb = ESymbol (Symbol "b")+ in EIf (ECall (Symbol ">") [sa, sb])+ (ECall (Symbol "+") [sa, eint 5])+ (ECall (Symbol "-") [sb, eint 20])+ , EList [ENumber (Exact 6), ENumber (Exact 7)]+ ]++morePretties :: [String]+morePretties = ["(list)"+ , "(list 1 #f \"thunder\")"+ , concat [ "(list (list 1 2)"+ , "\n (list 3 4 5)"+ , "\n (list)"+ , "\n (list 6 7))"+ ]+ , concat [ "(if (> a b)"+ , "\n (+ a 5)"+ , "\n (- b 20))"+ ]+ , "(list 6 7)"+ ]+++sexprTests :: [Test]+sexprTests = map (makeTestCase "exprToSExpr" exprToSExpr) + (zip3 exprs sexprs labels)++reprTests :: [Test]+reprTests = map (makeTestCase "exprToSchemeRepr" exprToSchemeRepr)+ (zip3 exprs reprStrings labels)++prettyTests :: [Test]+prettyTests = map (makeTestCase "exprToSchemePretty" exprToSchemePretty)+ (zip3 exprs pretties labels)++morePrettyTests :: [Test]+morePrettyTests = map (makeTestCase "exprToSchemePretty" exprToSchemePretty)+ (zip3 moreExprs morePretties moreLabels)++makeTestCase :: (Eq a, Show a) => + String -> (Expr -> a) -> (Expr, a, String) -> Test+makeTestCase fname f (expr, result, label) =+ TestCase (assertEqual (fname ++ " " ++ label) result (f expr))++-- | Test for function definition+makeDefTest :: SchemeOptions -> (String, String) -> Test+makeDefTest options (name, result) =+ let f = envGetFunction exampleEnv name+ sdef = defToSExpr options (functionToDef f)+ in TestCase (assertEqual ("define " ++ name)+ result+ (pretty sdef))++-- Tests of function definition using lambda expressions+defTests1 :: [Test]+defTests1 = map (makeDefTest (SchemeOptions {defineWithLambda = True}))+ (zip defTestNames1 defTestResults1)+++defTestNames1 :: [String]+defTestNames1 = ["bonus2"]++defTestResults1 :: [String]+defTestResults1 = [concat [ "(define bonus2"+ , "\n (lambda (salesA salesB)"+ , "\n (bonus1 (grossProfit salesA salesB))))"]]++-- | Tests of function definition with default Scheme options (no lambda)+defTests2 :: [Test]+defTests2 = map (makeDefTest (SchemeOptions {defineWithLambda = False}))+ (zip defTestNames2 defTestResults2)++defTestNames2 :: [String]+defTestNames2 = ["grossProfit"+ , "fact"+ , "rmul"+ , "fib1"+ , "length"+ ]++defTestResults2 :: [String]+defTestResults2 = [concat ["(define (grossProfit salesA salesB)"+ , "\n (+ (* 0.12 salesA)"+ , "\n (* 0.25 salesB)))"+ ]+ , concat ["(define (fact n)"+ , "\n (if (zero? n)"+ , "\n 1"+ , "\n (* n"+ , "\n (fact (sifflet-sub1 n)))))"+ ]+ , concat ["(define (rmul m n)"+ , "\n (if (zero? n)"+ , "\n 0"+ , "\n (+ m"+ , "\n (rmul m"+ , "\n (sifflet-sub1 n)))))"+ ]++ , concat ["(define (fib1 n)"+ , "\n (if (equal? n 1)"+ , "\n 1"+ , "\n (if (equal? n 2)"+ , "\n 1"+ , "\n (+ (fib1 (- n 2))"+ , "\n (fib1 (- n 1))))))"+ ]+ , concat ["(define (length xs)"+ , "\n (if (null? xs)"+ , "\n 0"+ , "\n (+ 1"+ , "\n (length (cdr xs)))))"+ ]+ ]++tests :: Test+tests = TestList $ concat [sexprTests+ , reprTests+ , prettyTests+ , morePrettyTests+ , defTests1+ , defTests2+ ]++runU :: IO ()+runU = utestloop tests++putLabeledString :: String -> String -> IO ()+putLabeledString label string = putStrLn (label ++ ": " ++ string)++testExpr :: Expr -> IO ()+testExpr expr =+ let pls = putLabeledString+ in pls "Expr" (show expr) >>+ pls "SExpr" (show (exprToSExpr expr)) >> + pls "Repr" (exprToSchemeRepr expr) >>+ pls "Pretty" ("\n" ++ exprToSchemePretty expr)++testExampleDef :: String -> IO ()+testExampleDef name =+ let f = envGetFunction exampleEnv name+ def = functionToDef f+ sdef = defToSExpr defaultSchemeOptions def+ pls = putLabeledString+ plss label thing = pls label (show thing)+ in pls "Name" name >>+ plss "Value" f >> -- ???+ plss "SExpr" sdef >>+ pls "Repr" (repr sdef) >>+ pls "Pretty" ("\n" ++ pretty sdef)++ted :: String -> IO ()+ted = testExampleDef++t6, mt0, mt1, mt2 :: IO ()++t6 = testExpr (exprs !! 6)++mt0 = testExpr (moreExprs !! 0)+++mt1 = testExpr (moreExprs !! 1)++mt2 = testExpr (moreExprs !! 2)++e7 :: Expr+e7 = EList [EList [eint 1, eint 2]+ , EList [EList [eint 3+ , EList [eint 4, eint 5]+ , EList []+ , EList [eint 6+ , EList [eint 7, eint 8]+ , eint 9+ ]+ , eint 10+ ]+ , EList [eint 11, eint 12, eint 13+ , EList [eint 14, eint 15]+ ]+ ]+ ]++t7 :: IO ()+t7 = testExpr e7++e8 :: Expr+e8 = let sym name = ESymbol (Symbol name)+ in EList [sym "cat"+ , EList [sym "dog", sym "mouse"]++ , EList [sym "broccoli"+ , EList [sym "potatoes"+ , sym "catsup"+ , sym "mustard"+ ]+ ]+ ]++t8 :: IO ()+t8 = testExpr e8++test' :: Expr -> IO ()+test' expr =+ let pls = putLabeledString+ sexpr = exprToSExpr expr+ in pls "Expr" (show expr) >>+ pls "SExpr" (show sexpr) >> + pls "Repr" (repr sexpr) >>+ pls "Pretty" ("\n" ++ pretty sexpr)++testf' :: String -> IO ()+testf' name =+ let f = envGetFunction exampleEnv name+ def = functionToDef f+ sdef = defToSExpr defaultSchemeOptions def+ pls = putLabeledString+ plss label thing = pls label (show thing)+ in pls "Name" name >>+ plss "Value" f >> -- ???+ plss "SExpr" sdef >>+ pls "Repr" (repr sdef) >>+ pls "Pretty" ("\n" ++ pretty sdef)
+ tests/Testing/Unit/TreeTests.hs view
@@ -0,0 +1,75 @@+-- Testing/Tree.hs++module Testing.Unit.TreeTests + (tests, + t1, t1a, t2a, t2b, t2c, t2d, t2e,+ t3, t4,+ runU)++where++import Test.HUnit++import Data.Sifflet.Tree as T++import Testing.TestUtil++-- Test data+t1 :: Tree Name+t1 = leaf (Name "cat")++-- Equiv:+t1a :: Tree Name+t1a = nameTree (leaf "cat")++t2a :: Tree Name+t2a = nameTree (T.Node "cat" [leaf "doormat"])++t2b :: Tree Name+t2b = nameTree (T.Node "doormat" [leaf "cat"])++t2c :: Tree Name+t2c = nameTree (T.Node "floor" [leaf "mat", leaf "textile"])++t2d :: Tree Name+t2d = nameTree (T.Node "X" [leaf "seven", leaf "twelve"])++t2e :: Tree Name+t2e = nameTree (T.Node "Seven" [leaf "7", leaf "77"])++t3 :: Tree Int+t3 = tree 12 [tree 6 [tree 3 [leaf 0, leaf 2, leaf 4],+ leaf 5],+ leaf 9,+ tree 24 [tree 18 [leaf 19,+ leaf 21]]]++t4 :: Tree Name+t4 = nameTree (tree "batty" [tree "fa" [leaf "zen", leaf "bud", leaf "rose"],+ tree "solfeggio" [leaf "apricot", leaf "pear"],+ leaf "humble",+ leaf "apple-pie"])++-- Specific tests for the Tree module++tests :: Test+tests = + assertAll+ [-- testing isLeaf+ assertEqual "cat is leaf" True+ (isLeaf t1),+ assertEqual "cat is not leaf" False+ (isLeaf t2a),+ -- testing treeDepth+ assertEqual "depth of t1" 1 (treeDepth t1),+ assertEqual "depth of t2d" 2 (treeDepth t2d),+ assertEqual "depth of t3" 4 (treeDepth t3),+ assertEqual "depth of t4" 3 (treeDepth t4),+ -- testing treeSize+ assertEqual "size of t1" 1 (treeSize t1),+ assertEqual "size of t1" 3 (treeSize t2c),+ assertEqual "size of t1" 12 (treeSize t3),+ assertEqual "size of t1" 10 (treeSize t4)]++runU :: IO ()+runU = utestloop tests
+ tests/Testing/Unit/TypeCheckTests.hs view
@@ -0,0 +1,339 @@+-- Unit tests for type checker++module Testing.Unit.TypeCheckTests (tests, runU) where++import Data.Map (fromList)++import Test.HUnit++import Language.Sifflet.Expr+import Language.Sifflet.TypeCheck+import Language.Sifflet.Util++import Testing.TestUtil+import Testing.Unit.ParserTests (int, float)++testTypeCheckValues :: Test+testTypeCheckValues =+ let checkSucc :: String -> [Value] -> [Type] -> Assertion+ checkSucc alabel values types =+ check alabel values types (Succ values)++ checkFail :: String -> [Value] -> [Type] -> String -> Assertion+ checkFail alabel values types = check alabel values types . Fail++ check :: String -> [Value] -> [Type] -> SuccFail [Value] -> Assertion+ check alabel values types result =+ let names = + ['x' : show i | i <- take (length values) [1..] :: [Int]]+ in assertEqual ("typeCheckValues: " ++ alabel)+ result+ (typeCheckValues names types values)+ in assertAll+ [checkSucc "int" [int 32] [typeNum],+ checkSucc "float" [float (-1.7)] [typeNum],+ checkSucc "list of int" [VList (map int [-7, 16, 24])] + [typeList typeNum],+ checkSucc "list of number"+ [VList [float 3.5, int 7]]+ [typeList typeNum],+ checkFail "list of mixed types" + [VList [float 3.5, VString "pony"]] + [typeList typeNum]+ ("For variable x1:\n\"pony\": " +++ "number expected"),+ checkSucc "int bool float"+ [int 7, VBool False, float 3.5]+ [typeNum, typeBool, typeNum],+ checkSucc "typevars a b c"+ [int 7, VBool False, float 3.5]+ [TypeVar "a", TypeVar "b", TypeVar "c"],+ checkSucc "typevars a a a"+ [int 18, int 21, int 9]+ [TypeVar "a", TypeVar "a", TypeVar "a"],+ checkFail "typevars a not-a"+ [int (-21), VString "roads"]+ [TypeVar "a", TypeVar "a"]+ "For variable x2:\n\"roads\": number expected"+ + ]++testTypeVarsIn :: Test+testTypeVarsIn = + assertAll+ [assertEqual "typeVarsIn t1" ["t1"] (typeVarsIn (TypeVar "t1"))+ , assertEqual "typeVarsIn typeNum" [] (typeVarsIn typeNum)+ , assertEqual "typeVarsIn [t2]" ["t2"] + (typeVarsIn (typeList (TypeVar "t2")))+ , assertEqual "typeVarsIn t3 -> t4 -> t5" ["t3", "t4", "t5"]+ (typeVarsIn (typeFunction [TypeVar "t3", TypeVar "t4"] + (TypeVar "t5")))+ ]++d1, d2, d3 :: Subst++d1 = deltaSubst "t1" typeNum+d2 = deltaSubst "t2" typeBool+d3 = deltaSubst "t3" (TypeVar "t1")++s1, s2 :: Subst+s1 = idSubst+s2 = substComp d1 d2++mapType, foldrType :: Type -> Type -> Type+mapType t1 t2 = + typeFunction [typeFunction [t1] t2, typeList t1] (typeList t2)+foldrType t1 t2 =+ typeFunction [typeFunction [t1] t2, t2, typeList t1] t2+ +testSubst :: Test+testSubst = + assertAll+ [assertEqual "testSubst t3 to t1 in t3" (TypeVar "t1") + (subst d3 (TypeVar "t3")),+ assertEqual "testSubst t3 to t1 in [t3]" (typeList (TypeVar "t1"))+ (subst d3 (typeList (TypeVar "t3"))),+ assertEqual "testSubst idSubst in t4" (TypeVar "t4")+ (subst s1 (TypeVar "t4")),+ -- the type of the map function+ assertEqual "testSubst s2 in mapType"+ (mapType typeNum typeBool)+ (subst s2 (mapType (TypeVar "t1") (TypeVar "t2"))),+ -- the type of the foldr function+ assertEqual "testSubst s2 in foldrType"+ (foldrType typeNum typeBool)+ (subst s2 (foldrType (TypeVar "t1") (TypeVar "t2")))+ ]+++testUnify :: Test+testUnify = + let uni t1 t2 =+ case unify idSubst (t1, t2) of+ Succ _ -> True+ Fail _ -> False+ yes name t1 t2 = assertBool name (uni t1 t2)+ no name t1 t2 = assertBool name (not (uni t1 t2))+ in assertAll+ [yes "t1 with Bool" (TypeVar "t1") typeBool+ , yes "t2 with Char" (TypeVar "t2") typeChar+ , yes "t3 with t4" (TypeVar "t3") (TypeVar "t4")+ , no "Bool with Char" typeBool typeChar+ , yes "[t1] with [t6]" (typeList (TypeVar "t1"))+ (typeList (TypeVar "t6"))+ , yes "[t1] with [[Num]]" (typeList (TypeVar "t1"))+ (typeList (typeList typeNum))+ , no "[String] with [Num]" (typeList typeString)+ (typeList typeNum)+ , yes "t1 -> t2 with Num -> Bool"+ (typeFunction [TypeVar "t1"] (TypeVar "t2"))+ (typeFunction [typeNum] typeBool)+ , no "t1 -> t2 -> t3 with Num -> Bool"+ (typeFunction [TypeVar "t1", TypeVar "t2"] (TypeVar "t3"))+ (typeFunction [typeNum] typeBool)+ ]++ts1, ts2 :: TypeScheme++ts1 = TypeScheme ["t1", "t2"] + (typeFunction [TypeVar "t1", TypeVar "t2", TypeVar "t3"] + (TypeVar "t4"))++ts2 = TypeScheme ["t1", "t2"]+ (typeFunction [TypeVar "t1", TypeVar "t2", typeNum] + typeBool)++phi34 :: Subst++phi34 = case extend (deltaSubst "t3" typeNum) "t4" typeBool of+ Succ s -> s+ Fail _ -> undefined++testTypeScheme :: Test+testTypeScheme = + assertAll+ [assertEqual "substTS t3 t4 in a function type" ts2+ (substTS phi34 ts1)+ , assertEqual "schematics of ts1" ["t1", "t2"] (schematicsTS ts1)+ , assertEqual "unknowns of ts1" ["t3", "t4"] (unknownsTS ts1)]++te1, te2 :: TypeEnv+te1 = fromList [("t16", ts1)]+te2 = fromList [("t16", ts2)]++testTypeEnv :: Test+testTypeEnv = assertAll [assertEqual "unknowns of te1" ["t3", "t4"]+ (unknownsTE te1)+ , assertEqual "unknowns of te2" []+ (unknownsTE te2)+ , assertEqual "substTE t3 t4 in te1 is te2" te2+ (substTE phi34 te1)]++testNS :: NameSupply+testNS = newNameSupply "t"++tc0 :: Expr -> SuccFail Type+tc0 expr =+ case tcExpr emptyTypeEnv testNS expr of+ Succ (_, etype, _) -> Succ etype+ Fail msg -> Fail msg+tc1 :: Expr -> SuccFail Type+tc1 expr =+ case tcExpr baseTypeEnv testNS expr of+ Succ (_, etype, _) -> Succ etype+ Fail msg -> Fail msg++testTypeCheckExpr1 :: Test+testTypeCheckExpr1 =+ assertAll+ [ -- primitive type expressions+ assertEqual "tc bool" (Succ typeBool) (tc0 (EBool False))+ , assertEqual "tc char" (Succ typeChar) (tc0 (EChar 'c'))+ , assertEqual "tc num (int)" (Succ typeNum) (tc0 (eInt 21))+ , assertEqual "tc num (float)" (Succ typeNum) (tc0 (eFloat 2.1))+ -- variables globally bound to functions+ , assertEqual "tc var (+)" + (Succ (typeFunction [typeNum, typeNum] typeNum))+ (tc1 (ESymbol (Symbol "+")))+ , assertEqual "tc var (:)"+ (Succ (typeFunction + [TypeVar "t1", typeList (TypeVar "t1")]+ (typeList (TypeVar "t1"))))+ (tc1 (ESymbol (Symbol ":")))+ , assertEqual "tc var (null)"+ (Succ (typeFunction [typeList (TypeVar "t1")] typeBool))+ (tc1 (ESymbol (Symbol "null")))+ -- if expressions+ , assertEqual "tc if bool num num"+ (Succ (typeNum))+ (tc1 (EIf (EBool True) (eInt 35) (eFloat 3.5)))+ , assertEqual "tc if bool char char"+ (Succ (typeChar))+ (tc1 (EIf (EBool False) (EChar 'c') (EChar 'd')))+ , assertEqual "tc if bool char num"+ (Fail "cannot unify Char with Num")+ (tc1 (EIf (EBool False) (EChar 'c') (eFloat 4.1)))+ , assertEqual "tc if string num num"+ (Fail "cannot unify String with Bool")+ (tc1 (EIf (EString "horses") (eInt 35) (eFloat 3.5)))+ -- list expressions+ , assertEqual "tc list []"+ (Succ (typeList (TypeVar "t1")))+ (tc1 (EList []))+ , assertEqual "tc list [35]"+ (Succ (typeList typeNum))+ (tc1 (EList [eInt 35]))+ , assertEqual "tc list [35, 3.5]"+ (Succ (typeList typeNum))+ (tc1 (EList [eInt 35, eFloat 3.5]))+ , assertEqual "tc list [35, 'c']"+ (Fail "cannot unify Num with Char")+ (tc1 (EList [eInt 35, eChar 'c']))+ , assertEqual "tc list [1..10]"+ (Succ (TypeCons "List" [TypeCons "Num" []]))+ (tc1 (EList (map eInt [1..10])))+ -- lambda expressions+ , assertEqual "tc lambda0"+ (Succ (TypeVar "t1" `arrow` typeNum))+ (tc1 (ELambda (Symbol "y") (ENumber 0)))+ , assertEqual "tc lambda1"+ (Succ (TypeVar "t1" `arrow` typeList (TypeVar "t2")))+ (tc1 (ELambda (Symbol "z") (EList [])))+ , assertEqual "tc lambda2"+ (Succ (TypeVar "t2" `arrow` typeList (TypeVar "t2")))+ (tc1 (ELambda (Symbol "z") (EList [ESymbol (Symbol "z")])))+ , assertEqual "tc lambda3"+ (Succ (TypeVar "t1" `arrow` (TypeVar "t2" `arrow` TypeVar "t1")))+ (tc1 (ELambda (Symbol "c") + (ELambda (Symbol "x") (ESymbol (Symbol "c")))))+ ]++testTypeCheckExpr2 :: Test+testTypeCheckExpr2 =+ let -- 1 * 2+ call4 = ECall (Symbol "*") [eInt 1, eInt 2]+ -- (1 + 2) * (7 - 3)+ call5 = ECall (Symbol "*") [ECall (Symbol "+") [eInt 1, eInt 2],+ ECall (Symbol "-") [eInt 7, eInt 3]]+ -- invalid cons expression:+ -- 7 : ["beeswax"]+ call6 = ECall (Symbol ":") [eInt 7, EList [EString "beeswax"]]++ -- add1+ lambda4 = ELambda (Symbol "x") + (ePlus (ESymbol (Symbol "x")) (eInt 1))+ + -- function with function argument+ lambda5 = ELambda (Symbol "f")+ (EList [EApp (ESymbol (Symbol "f")) (eInt 3),+ EApp (ESymbol (Symbol "f")) (eFloat 4.5)])++ -- function with function value+ lambda6 = ELambda (Symbol "n")+ (ELambda (Symbol "k")+ (ECall (Symbol "+") + [ESymbol (Symbol "n"), ESymbol (Symbol "k")]))++ -- invalid lambda expression:+ -- \x -> (x + 1) : x+ lambda7 = ELambda (Symbol "x")+ (ECall (Symbol ":")+ [ECall (Symbol "+") [ESymbol (Symbol "x"), eInt 1],+ ESymbol (Symbol "x")])++ in assertAll+ [+ assertEqual "tc call4"+ (Succ (TypeCons "Num" []))+ (tc1 call4)+ , assertEqual "tc call5"+ (Succ (TypeCons "Num" []))+ (tc1 call5)+ , assertEqual "tc call6"+ (Fail "cannot unify Num with String")+ (tc1 call6)++ , assertEqual "tc lambda4"+ (Succ (typeNum `arrow` typeNum))+ (tc1 lambda4)+ , assertEqual "tc lambda5"+ (Succ ((typeNum `arrow` TypeVar "t4") `arrow` + (typeList (TypeVar "t4"))))+ (tc1 lambda5)+ , assertEqual "tc lambda6"+ (Succ (typeNum `arrow` (typeNum `arrow` typeNum)))+ (tc1 lambda6)+ , assertEqual "tc lambda7"+ (Fail ("cannot unify [Num] with Num"))+ (tc1 lambda7)+ ]+++testFromLambdaType :: Test+testFromLambdaType =+ let t1 = TypeVar "t1"+ t2 = TypeVar "t2"+ t3 = TypeVar "t3"+ in assertAll+ [assertEqual "fromLambdaType t1 -> t2"+ (Succ ([t1], t2))+ (fromLambdaType (t1 `arrow` t2))+ , assertEqual "fromLambdaType t1 -> (t2 -> t3)"+ (Succ ([t1, t2], t3))+ (fromLambdaType (t1 `arrow` (t2 `arrow` t3)))+ ]++tests :: Test+tests = TestList [TestLabel "typeVarsIn" testTypeVarsIn,+ TestLabel "typeCheckValues" testTypeCheckValues,+ TestLabel "subst" testSubst,+ TestLabel "unify" testUnify,+ TestLabel "TypeScheme" testTypeScheme,+ TestLabel "TypeEnv" testTypeEnv,+ TestLabel "tcExpr1" testTypeCheckExpr1,+ TestLabel "tcExpr2" testTypeCheckExpr2,+ TestLabel "fromLambdaType" testFromLambdaType+ ]++runU :: IO ()+runU = utestloop tests
+ tests/Testing/Unit/UtilTests.hs view
@@ -0,0 +1,90 @@+-- For testing the Util module+module Testing.Unit.UtilTests (tests, runU) where++import Test.HUnit++import Language.Sifflet.Util++import Testing.TestUtil++testPar :: Test+testPar = + assertAll+ [assertEqual "par (a b c)" "(a b c)" (par "a" ["b", "c"]),+ assertEqual "par (a)" "(a)" (par "a" [])]++f1 :: Int -> Int+f1 x = x + 3++f2 :: Int -> IO Int+f2 x = return $ x + 3++list2 :: [[Int]]+list2 = [[1, 5, 7], [9, 6], [1..5]]++list2plus3 :: [[Int]]+list2plus3 = [[4, 8, 10], [12, 9], [4..8]]++tlist :: [(String, Int)]+tlist = [("a", 21), ("b", 77), ("c", 90)]++testMap2 :: Test+testMap2 = TestCase $ assertEqual "map2" list2plus3 (map2 f1 list2)++testMapM2 :: Test+testMapM2 = TestCase $ assertEqualIO "mapM2" list2plus3 (mapM2 f2 list2)++assertEqualIO :: (Eq b, Show b) => String -> b -> IO b -> IO ()+assertEqualIO label expected expr = do+ {+ result <- expr+ ; assertEqual label expected result+ }++testAdjustAList :: Test+testAdjustAList = + assertAll+ [assertEqual "adjustAList a"+ [("a",24),("b",77),("c",90)]+ (adjustAList "a" f1 tlist)+ , assertEqual "adjustAList b"+ [("a",21),("b",80),("c",90)]+ (adjustAList "b" f1 tlist)+ , assertEqual "adjustAList c"+ [("a",21),("b",77),("c",93)]+ (adjustAList "c" f1 tlist)+ , assertEqual "adjustAList d"+ [("a",21),("b",77),("c",90)]+ (adjustAList "d" f1 tlist)+ ]++testAdjustAListM :: Test+testAdjustAListM =+ assertAll+ [assertEqualIO "adjustAListM a"+ [("a",24),("b",77),("c",90)]+ (adjustAListM "a" f2 tlist)+ , assertEqualIO "adjustAListM b"+ [("a",21),("b",80),("c",90)]+ (adjustAListM "b" f2 tlist)+ , assertEqualIO "adjustAListM c"+ [("a",21),("b",77),("c",93)]+ (adjustAListM "c" f2 tlist)++ , assertEqualIO "adjustAListM d"+ [("a",21),("b",77),("c",90)]+ (adjustAListM "d" f2 tlist)+ ]++tests :: Test+tests = TestList+ [TestLabel "par" testPar+ , TestLabel "map2" testMap2+ , TestLabel "mapM2" testMapM2+ , TestLabel "adjustAList" testAdjustAList+ , TestLabel "adjustAListM" testAdjustAListM+ ]++runU :: IO ()+runU = utestloop tests+
+ tests/system-tests.sh view
@@ -0,0 +1,36 @@+#!/bin/bash+#+# Run system tests on a sifflet executable, which may be optionally+# specified as the command line argument:+#+# ./system-tests.sh PATH-TO-SIFFLET-EXECUTABLE+#+# The default PATH-TO-SIFFLET-EXECUTABLE is in the ../bin directory+# from where this script is located.++TEST_DIR=`dirname $0`+# Figure out which sifflet program is to be tested+if [ $# -eq 1 ]; then+ Prog=$1+else+ Prog=$TEST_DIR/../.cabal-sandbox/bin/sifflet+fi++echo "Using $Prog"++# Check if file exists, is regular file and executable+if [ -f $Prog ] && [ -x $Prog ]; then++ $Prog --call fact 4+ $Prog --show fact+ $Prog --file $TEST_DIR/data/systest1.siff --show demoFunction+ $Prog --show length+ $Prog --show sum+ $Prog --show buggySum+ $Prog --show buggySumFromZero++else++ echo "$Prog is does not exist, or is not an executable program file."+ exit 1+fi
+ tests/unit-tests.hs view
@@ -0,0 +1,36 @@+module Main+where++import Test.HUnit++import Testing.TestUtil++import Testing.Unit.ExprTests as ET (tests)+import Testing.Unit.TypeCheckTests as TCT (tests)+import Testing.Unit.ExprTreeTests as ETT (tests)+import Testing.Unit.GraphTests as GT (tests)+import Testing.Unit.LayoutTests as LT (tests)+import Testing.Unit.ParserTests as PaT (tests)+import Testing.Unit.ToHaskellTests as ToHsT (tests)+import Testing.Unit.ToPythonTests as ToPyT (tests)+import Testing.Unit.ToSchemeTests as ToScmT (tests)+import Testing.Unit.TreeTests as TT (tests)+import Testing.Unit.UtilTests as UT (tests)++-- run unit tests++main :: IO ()+main = + utestloop (TestList [TestLabel "ExprTests" ET.tests,+ TestLabel "TypeCheckTests" TCT.tests,+ TestLabel "ExprTreeTests" ETT.tests,+ TestLabel "GraphTests" GT.tests,+ TestLabel "LayoutTests" LT.tests,+ TestLabel "ParserTests" PaT.tests,+ TestLabel "ToHaskellTests" ToHsT.tests,+ TestLabel "ToPythonTests" ToPyT.tests,+ TestLabel "ToSchemeTests" ToScmT.tests,+ TestLabel "TreeTests" TT.tests,+ TestLabel "UtilTests" UT.tests+ ])+