diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -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. diff --git a/Options.hs b/Options.hs deleted file mode 100644 --- a/Options.hs +++ /dev/null @@ -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 - diff --git a/README b/README deleted file mode 100644 --- a/README +++ /dev/null @@ -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 - diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 + diff --git a/RELEASE-NOTES b/RELEASE-NOTES deleted file mode 100644 --- a/RELEASE-NOTES +++ /dev/null @@ -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. diff --git a/app/Options.hs b/app/Options.hs new file mode 100644 --- /dev/null +++ b/app/Options.hs @@ -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 + diff --git a/app/sifflet.hs b/app/sifflet.hs new file mode 100644 --- /dev/null +++ b/app/sifflet.hs @@ -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)) + } diff --git a/datafiles/sifflet.py b/datafiles/sifflet.py new file mode 100644 --- /dev/null +++ b/datafiles/sifflet.py @@ -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() diff --git a/datafiles/sifflet.scm b/datafiles/sifflet.scm new file mode 100644 --- /dev/null +++ b/datafiles/sifflet.scm @@ -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))) + + diff --git a/datafiles/siffml-1.0.dtd b/datafiles/siffml-1.0.dtd new file mode 100644 --- /dev/null +++ b/datafiles/siffml-1.0.dtd @@ -0,0 +1,63 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/datafiles/siffml-1.0.rnc b/datafiles/siffml-1.0.rnc new file mode 100644 --- /dev/null +++ b/datafiles/siffml-1.0.rnc @@ -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 } + diff --git a/datafiles/siffml-2.0.rnc b/datafiles/siffml-2.0.rnc new file mode 100644 --- /dev/null +++ b/datafiles/siffml-2.0.rnc @@ -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 } + diff --git a/lib/Data/Number/Sifflet.hs b/lib/Data/Number/Sifflet.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Number/Sifflet.hs @@ -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! diff --git a/lib/Data/Sifflet/Functoid.hs b/lib/Data/Sifflet/Functoid.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Sifflet/Functoid.hs @@ -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) diff --git a/lib/Data/Sifflet/Geometry.hs b/lib/Data/Sifflet/Geometry.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Sifflet/Geometry.hs @@ -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 + diff --git a/lib/Data/Sifflet/Tree.hs b/lib/Data/Sifflet/Tree.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Sifflet/Tree.hs @@ -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 + diff --git a/lib/Data/Sifflet/TreeGraph.hs b/lib/Data/Sifflet/TreeGraph.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Sifflet/TreeGraph.hs @@ -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) + + diff --git a/lib/Data/Sifflet/TreeLayout.hs b/lib/Data/Sifflet/TreeLayout.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Sifflet/TreeLayout.hs @@ -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 + + + diff --git a/lib/Data/Sifflet/WGraph.hs b/lib/Data/Sifflet/WGraph.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Sifflet/WGraph.hs @@ -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 _) = "" + +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 diff --git a/lib/Graphics/Rendering/Sifflet/Draw.hs b/lib/Graphics/Rendering/Sifflet/Draw.hs new file mode 100644 --- /dev/null +++ b/lib/Graphics/Rendering/Sifflet/Draw.hs @@ -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 + diff --git a/lib/Graphics/Rendering/Sifflet/DrawTreeGraph.hs b/lib/Graphics/Rendering/Sifflet/DrawTreeGraph.hs new file mode 100644 --- /dev/null +++ b/lib/Graphics/Rendering/Sifflet/DrawTreeGraph.hs @@ -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 + } diff --git a/lib/Graphics/UI/Sifflet.hs b/lib/Graphics/UI/Sifflet.hs new file mode 100644 --- /dev/null +++ b/lib/Graphics/UI/Sifflet.hs @@ -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 diff --git a/lib/Graphics/UI/Sifflet/Callback.hs b/lib/Graphics/UI/Sifflet/Callback.hs new file mode 100644 --- /dev/null +++ b/lib/Graphics/UI/Sifflet/Callback.hs @@ -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 diff --git a/lib/Graphics/UI/Sifflet/Canvas.hs b/lib/Graphics/UI/Sifflet/Canvas.hs new file mode 100644 --- /dev/null +++ b/lib/Graphics/UI/Sifflet/Canvas.hs @@ -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) diff --git a/lib/Graphics/UI/Sifflet/EditArgsPanel.hs b/lib/Graphics/UI/Sifflet/EditArgsPanel.hs new file mode 100644 --- /dev/null +++ b/lib/Graphics/UI/Sifflet/EditArgsPanel.hs @@ -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 diff --git a/lib/Graphics/UI/Sifflet/Frame.hs b/lib/Graphics/UI/Sifflet/Frame.hs new file mode 100644 --- /dev/null +++ b/lib/Graphics/UI/Sifflet/Frame.hs @@ -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) diff --git a/lib/Graphics/UI/Sifflet/GtkForeign.hs b/lib/Graphics/UI/Sifflet/GtkForeign.hs new file mode 100644 --- /dev/null +++ b/lib/Graphics/UI/Sifflet/GtkForeign.hs @@ -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 - 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) diff --git a/lib/Graphics/UI/Sifflet/GtkUtil.hs b/lib/Graphics/UI/Sifflet/GtkUtil.hs new file mode 100644 --- /dev/null +++ b/lib/Graphics/UI/Sifflet/GtkUtil.hs @@ -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 diff --git a/lib/Graphics/UI/Sifflet/LittleGtk.hs b/lib/Graphics/UI/Sifflet/LittleGtk.hs new file mode 100644 --- /dev/null +++ b/lib/Graphics/UI/Sifflet/LittleGtk.hs @@ -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 diff --git a/lib/Graphics/UI/Sifflet/RPanel.hs b/lib/Graphics/UI/Sifflet/RPanel.hs new file mode 100644 --- /dev/null +++ b/lib/Graphics/UI/Sifflet/RPanel.hs @@ -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 diff --git a/lib/Graphics/UI/Sifflet/Tool.hs b/lib/Graphics/UI/Sifflet/Tool.hs new file mode 100644 --- /dev/null +++ b/lib/Graphics/UI/Sifflet/Tool.hs @@ -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 diff --git a/lib/Graphics/UI/Sifflet/Types.hs b/lib/Graphics/UI/Sifflet/Types.hs new file mode 100644 --- /dev/null +++ b/lib/Graphics/UI/Sifflet/Types.hs @@ -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) + diff --git a/lib/Graphics/UI/Sifflet/Window.hs b/lib/Graphics/UI/Sifflet/Window.hs new file mode 100644 --- /dev/null +++ b/lib/Graphics/UI/Sifflet/Window.hs @@ -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 [] diff --git a/lib/Graphics/UI/Sifflet/Workspace.hs b/lib/Graphics/UI/Sifflet/Workspace.hs new file mode 100644 --- /dev/null +++ b/lib/Graphics/UI/Sifflet/Workspace.hs @@ -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", ":"]] diff --git a/lib/Language/Sifflet/Examples.hs b/lib/Language/Sifflet/Examples.hs new file mode 100644 --- /dev/null +++ b/lib/Language/Sifflet/Examples.hs @@ -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 + diff --git a/lib/Language/Sifflet/Export/Exporter.hs b/lib/Language/Sifflet/Export/Exporter.hs new file mode 100644 --- /dev/null +++ b/lib/Language/Sifflet/Export/Exporter.hs @@ -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' diff --git a/lib/Language/Sifflet/Export/Haskell.hs b/lib/Language/Sifflet/Export/Haskell.hs new file mode 100644 --- /dev/null +++ b/lib/Language/Sifflet/Export/Haskell.hs @@ -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 + ]) + diff --git a/lib/Language/Sifflet/Export/Python.hs b/lib/Language/Sifflet/Export/Python.hs new file mode 100644 --- /dev/null +++ b/lib/Language/Sifflet/Export/Python.hs @@ -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 + ]) diff --git a/lib/Language/Sifflet/Export/ToHaskell.hs b/lib/Language/Sifflet/Export/ToHaskell.hs new file mode 100644 --- /dev/null +++ b/lib/Language/Sifflet/Export/ToHaskell.hs @@ -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) + diff --git a/lib/Language/Sifflet/Export/ToPython.hs b/lib/Language/Sifflet/Export/ToPython.hs new file mode 100644 --- /dev/null +++ b/lib/Language/Sifflet/Export/ToPython.hs @@ -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) diff --git a/lib/Language/Sifflet/Export/ToScheme.hs b/lib/Language/Sifflet/Export/ToScheme.hs new file mode 100644 --- /dev/null +++ b/lib/Language/Sifflet/Export/ToScheme.hs @@ -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]) + diff --git a/lib/Language/Sifflet/Expr.hs b/lib/Language/Sifflet/Expr.hs new file mode 100644 --- /dev/null +++ b/lib/Language/Sifflet/Expr.hs @@ -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 _) = "" + 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 _ -> "" + Compound _args _body -> "" + +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] diff --git a/lib/Language/Sifflet/ExprTree.hs b/lib/Language/Sifflet/ExprTree.hs new file mode 100644 --- /dev/null +++ b/lib/Language/Sifflet/ExprTree.hs @@ -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 diff --git a/lib/Language/Sifflet/Parser.hs b/lib/Language/Sifflet/Parser.hs new file mode 100644 --- /dev/null +++ b/lib/Language/Sifflet/Parser.hs @@ -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 + + + diff --git a/lib/Language/Sifflet/SiffML.hs b/lib/Language/Sifflet/SiffML.hs new file mode 100644 --- /dev/null +++ b/lib/Language/Sifflet/SiffML.hs @@ -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 -> + -- or + -- 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 "-" diff --git a/lib/Language/Sifflet/TypeCheck.hs b/lib/Language/Sifflet/TypeCheck.hs new file mode 100644 --- /dev/null +++ b/lib/Language/Sifflet/TypeCheck.hs @@ -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 diff --git a/lib/Language/Sifflet/Util.hs b/lib/Language/Sifflet/Util.hs new file mode 100644 --- /dev/null +++ b/lib/Language/Sifflet/Util.hs @@ -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 diff --git a/lib/System/Sifflet/Paths.hs b/lib/System/Sifflet/Paths.hs new file mode 100644 --- /dev/null +++ b/lib/System/Sifflet/Paths.hs @@ -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 diff --git a/lib/Text/Sifflet/Pretty.hs b/lib/Text/Sifflet/Pretty.hs new file mode 100644 --- /dev/null +++ b/lib/Text/Sifflet/Pretty.hs @@ -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 diff --git a/lib/Text/Sifflet/Repr.hs b/lib/Text/Sifflet/Repr.hs new file mode 100644 --- /dev/null +++ b/lib/Text/Sifflet/Repr.hs @@ -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 diff --git a/sifflet.cabal b/sifflet.cabal --- a/sifflet.cabal +++ b/sifflet.cabal @@ -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 + diff --git a/sifflet.hs b/sifflet.hs deleted file mode 100644 --- a/sifflet.hs +++ /dev/null @@ -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)) - } diff --git a/tests/Testing/Common/ExprTreeTests.hs b/tests/Testing/Common/ExprTreeTests.hs new file mode 100644 --- /dev/null +++ b/tests/Testing/Common/ExprTreeTests.hs @@ -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 diff --git a/tests/Testing/Common/TestStyles.hs b/tests/Testing/Common/TestStyles.hs new file mode 100644 --- /dev/null +++ b/tests/Testing/Common/TestStyles.hs @@ -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] diff --git a/tests/Testing/TestUtil.hs b/tests/Testing/TestUtil.hs new file mode 100644 --- /dev/null +++ b/tests/Testing/TestUtil.hs @@ -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 diff --git a/tests/Testing/Unit/ExprTests.hs b/tests/Testing/Unit/ExprTests.hs new file mode 100644 --- /dev/null +++ b/tests/Testing/Unit/ExprTests.hs @@ -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)" "" + (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 diff --git a/tests/Testing/Unit/ExprTreeTests.hs b/tests/Testing/Unit/ExprTreeTests.hs new file mode 100644 --- /dev/null +++ b/tests/Testing/Unit/ExprTreeTests.hs @@ -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 diff --git a/tests/Testing/Unit/FunctionExamples.hs b/tests/Testing/Unit/FunctionExamples.hs new file mode 100644 --- /dev/null +++ b/tests/Testing/Unit/FunctionExamples.hs @@ -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 []))) diff --git a/tests/Testing/Unit/GraphTests.hs b/tests/Testing/Unit/GraphTests.hs new file mode 100644 --- /dev/null +++ b/tests/Testing/Unit/GraphTests.hs @@ -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 () + diff --git a/tests/Testing/Unit/LayoutTests.hs b/tests/Testing/Unit/LayoutTests.hs new file mode 100644 --- /dev/null +++ b/tests/Testing/Unit/LayoutTests.hs @@ -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 diff --git a/tests/Testing/Unit/ParserTests.hs b/tests/Testing/Unit/ParserTests.hs new file mode 100644 --- /dev/null +++ b/tests/Testing/Unit/ParserTests.hs @@ -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 + + + diff --git a/tests/Testing/Unit/ToHaskellTests.hs b/tests/Testing/Unit/ToHaskellTests.hs new file mode 100644 --- /dev/null +++ b/tests/Testing/Unit/ToHaskellTests.hs @@ -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 diff --git a/tests/Testing/Unit/ToPythonTests.hs b/tests/Testing/Unit/ToPythonTests.hs new file mode 100644 --- /dev/null +++ b/tests/Testing/Unit/ToPythonTests.hs @@ -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 diff --git a/tests/Testing/Unit/ToSchemeTests.hs b/tests/Testing/Unit/ToSchemeTests.hs new file mode 100644 --- /dev/null +++ b/tests/Testing/Unit/ToSchemeTests.hs @@ -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) diff --git a/tests/Testing/Unit/TreeTests.hs b/tests/Testing/Unit/TreeTests.hs new file mode 100644 --- /dev/null +++ b/tests/Testing/Unit/TreeTests.hs @@ -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 diff --git a/tests/Testing/Unit/TypeCheckTests.hs b/tests/Testing/Unit/TypeCheckTests.hs new file mode 100644 --- /dev/null +++ b/tests/Testing/Unit/TypeCheckTests.hs @@ -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 diff --git a/tests/Testing/Unit/UtilTests.hs b/tests/Testing/Unit/UtilTests.hs new file mode 100644 --- /dev/null +++ b/tests/Testing/Unit/UtilTests.hs @@ -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 + diff --git a/tests/system-tests.sh b/tests/system-tests.sh new file mode 100644 --- /dev/null +++ b/tests/system-tests.sh @@ -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 diff --git a/tests/unit-tests.hs b/tests/unit-tests.hs new file mode 100644 --- /dev/null +++ b/tests/unit-tests.hs @@ -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 + ]) +