diff --git a/Data/Sifflet/WGraph.hs b/Data/Sifflet/WGraph.hs --- a/Data/Sifflet/WGraph.hs +++ b/Data/Sifflet/WGraph.hs @@ -2,7 +2,7 @@ (WNode(..), WEdge(..), WGraph, WContext , wgraphNew, isWSimple, isWFrame, grInsertNode, grRemoveNode , connectToFrame - , grConnect, grDisconnect + , grConnect, grInletIsConnected, grDisconnect , grAddGraph , grExtractExprTree, grExtractLayoutNode, grExtractLayoutTree @@ -158,8 +158,26 @@ (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 pair = edge /= fst pair +edgeNotEqual edge = not . edgeEqual edge edgeNotTo :: G.Node -> (WEdge, G.Node) -> Bool edgeNotTo node pair = node /= snd pair diff --git a/Graphics/UI/Sifflet/Canvas.hs b/Graphics/UI/Sifflet/Canvas.hs --- a/Graphics/UI/Sifflet/Canvas.hs +++ b/Graphics/UI/Sifflet/Canvas.hs @@ -381,32 +381,36 @@ in loop tuples --- | Connect nodes +-- | 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 - -- if parent and child are different, - -- connect the ith inlet of node parent - -- to the oth outlet of node child - -- provided that doing so would not create a cycle - -- parent -> child -> ... -> parent - let graph = vcGraph canvas if elem parent (reachable child graph) - then - do - showErrorMessage "Sorry, this connection would create a cycle." - 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 + 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 wouldn't need to be in the IO monad, --- except that it needs the same type signature as connect +-- | 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 diff --git a/Graphics/UI/Sifflet/Frame.hs b/Graphics/UI/Sifflet/Frame.hs --- a/Graphics/UI/Sifflet/Frame.hs +++ b/Graphics/UI/Sifflet/Frame.hs @@ -300,8 +300,8 @@ Nothing -> vars Just [] -> vars Just values -> - if length vars /= length values - then error "buildFooterText: mismatched lists" - else [var ++ " = " ++ repr value | - (var, value) <- zip vars 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/Graphics/UI/Sifflet/GtkUtil.hs b/Graphics/UI/Sifflet/GtkUtil.hs --- a/Graphics/UI/Sifflet/GtkUtil.hs +++ b/Graphics/UI/Sifflet/GtkUtil.hs @@ -38,47 +38,48 @@ -- CUSTOMIZABLE DIALOGS -- | Show a message and a set of choices; --- run the action corresponding to the selected choice; --- you might want to include a "Cancel" option with the action return (). --- There *should* be as many actions as there are options. -showChoicesDialog :: String -> String -> [String] -> [IO a] -> IO a -showChoicesDialog title message options actions = do - { - -- Create basic dialog - dialog <- dialogNew - ; windowSetTitle dialog title - ; widgetSetName dialog ("Sifflet-" ++ title) +-- 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 + 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 indexOptions = zip [1..] options - addButton (i, option) = - dialogAddButton dialog option (ResponseUser i) - ; forM_ indexOptions addButton - ; dialogGetActionArea dialog >>= widgetShowAll + 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 actions - then actions !! j - else errcats ["showChoicesDialog: response index", - show j, "is out of range for actions"] - _ -> errcats ["showChoicesDialog: expected a ResponseUser _ but got", - show response] - } + 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 diff --git a/Graphics/UI/Sifflet/Window.hs b/Graphics/UI/Sifflet/Window.hs --- a/Graphics/UI/Sifflet/Window.hs +++ b/Graphics/UI/Sifflet/Window.hs @@ -453,19 +453,13 @@ else [] labels = map fst choices actions = map snd choices - -- labels = ["Save them", - -- "Throw them away", - -- ] - -- actions = [menuFileSave vpui >>= mAckIfSaved >>= continue, -- save - -- return vpui >>= continue, -- throw away - -- return vpui] -- cancel offerSaveAndContinue = showChoicesDialog "Save changes?" - ("There are unsaved changes. " ++ - "Before you " ++ beforeOperation ++ - ", would you ...") - labels - actions - + ("There are unsaved changes. " ++ + "Before you " ++ beforeOperation ++ + ", would you ...") + labels + actions + (return vpui) in if vpuiFileChanged vpui then offerSaveAndContinue else continue vpui @@ -638,40 +632,50 @@ "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 - (windowId, fileExt) <- chooseImageOptions vpui - mfile <- chooseOutputFile ("Save image of " ++ windowId) vpui - case mfile of + mImageOptions <- chooseImageOptions vpui + case mImageOptions of Nothing -> return vpui - Just filePath -> - saveImageFile vpui windowId filePath fileExt + 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 (WinId, String) +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 windowChoices + windowActions = map (return . Just) windowChoices formatChoices = ["SVG", "PS", "PDF"] - formatActions = map return [".svg", ".ps", ".pdf"] + formatActions = map (return . Just) [".svg", ".ps", ".pdf"] in do - ext <- showChoicesDialog "Save Image" "Select image format" - formatChoices formatActions - winId <- if length windowChoices == 1 - then return $ head windowChoices - else showChoicesDialog "Save Image" - "Select window to save as image" - windowChoices windowActions - return (winId, ext) + 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 diff --git a/ISSUES b/ISSUES deleted file mode 100644 --- a/ISSUES +++ /dev/null @@ -1,403 +0,0 @@ -ISSUES -====== - -Issues for sifflet and sifflet-lib - -This is the ISSUES 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. - -O = date opened -R = reporter -P = priority -C = closed - -OPEN ISSUES ------------ - -41 next issue bug number - -40 Duplicate arguments in "Edit Arguments" - - Adding a duplicate argument in the "Edit Arguments" dialog - is possible (for example, two arguments named "f"). - It should not be. - O: 2012 July 2 - R: gdw - P: medium - -39 No lambda tool - - There is no lambda tool, and since partial application doesn't work - (issue 32), this means there is no way to have a function return a function. - O: 2012 jul 2 - R: gdw - P: medium - -38 Working directory - - Sifflet should have some sense of its working directory, - for convenience of opening and saving files - O: 2012 july 2 - R: gdw - P: medium - -37 Changing helper function definition does not affect displayed function call - - See f2 and testF2 in ../examples/map.sfl - When testF2 is called on the workspace, and you edit and chagne f2, - apply the new definition, the displayed call is not re-evaluated - using the new definition. In fact if you use the displayed - testF2 frame to call again, it still uses the old definition -- - it seems permanently bound to it. To use the new definition - of f2, you have to place a new copy of testF2 on the workspace. - - O: 2012 Jun 27 - R: gdw - P: low - -36 Cascade effect of changing kind of arguments to a function. - - When we change the number of type (kind) of the arguments of - a function, we also change the function's type (or kind); and if - it's used in the definitions of other functions, then they may - become invalid in turn -- what should be done in this case? - O: 2012 Jun 27 - R: gdw - P: medium - -33 testMapSumFromZero (see ../examples/map.sfl) - In testMapSumFromZero n, with n = [1,2], - opening the sumFromZero node displays bogus error messages - as though it is a call to sumFromZero with n = [1,2]. - In fact, the node has no input, so there is no call - to sumFromZero until we get into map. - The problem doesn't occur with recursive functions. - It must be because the node has an inlet that expects n, - and finds n in the enclosing environment although it is not called. - O: 2012 June 22 - R: gdw - P: low - -32 Partial application does not work - (e.g., calling the + function with one argument) - Comment: See also #39. - O: 2012 Jun 21 - R: gdw - P: medium - -31 Edit function inputs: when an argument tool is selected, - and you change the arity of that argument, the next click - of the tool puts the argument down on the canvas with its - *old* arity; should be the new arity. - Comment: A work-around is to reselect the tool to get the right arity. - O: 2012 Jun 21 - R: gdw - P: medium - -26 EditArgsPanel: TAB fails to move the cursor to the next field. - O: 2011 Jun 23 - R: gdw - P: medium-high - -25 Nodes lose unused inlets when applying a function definition. - - Suppose the f node has two inlets, but none of them are - used by any f nodes in the definition. Then when you apply the - definition, all the f nodes lose both of their inlets. - On the other hand, if one f node uses none of its two inlets - and another uses both, then when you apply the definition, - both of them keep both of their inlets. - O: 2011 Jun 23 - R: gdw - P: lowest. - Comment: - This seems not really to be a problem. If NONE of the f nodes - use their inlets, then why do they have inlets, anyway? - Besides, it should become irrelevant when a new UI is - developed without the circular inlets, as in issue 24. - Comment: The inlets will reappear if you reopen the "inputs" - dialog and then click "OK". - -24 Arguments are shifted when applying a function definition. - - If a node has 3 inlets and connections on inlets 1 and 2, - but not on 0, then when "apply" is clicked the connections are - shifted to inlets 0 and 1, leaving 2 open. - O: 2011 Jun 23 - R: gdw - P: lowest. - This should become irrelevant when and if I develop a new - UI that does away with the circular inlets. Why not just - let the user make as many connections as they please? And - that would get rid of the need for a dialog that lets you - change the number of inlets too. - -23 typeToXml fails for (TypeCons Function) - O: 2011 Jun 23 - R: gdw - P: medium - -22 When you connect an input to the second (or generally not first) - input port of a node, and leave the first "open", then click on - apply, the input is reconnected to the first port instead of the - second. - -- Is this actually a bug? - O: 2011 Jun 2 - R: gdw - P: ??? - -14 If two frames overlap, then clicks on the top frame - sometimes are interpreted as clicks on the lower (hidden) frame. - O: 2010 aug 16 - P: low - -13 If you change any of the *example* functions and quit or open, - Sifflet prompts you to save changes, but it does not save - these particular changes, since they are not in "My Functions". - Probably need to re-design the whole organization of examples - and my functions, introduce modules associated with files, - and show each in its own panel. - Opened 2010 May 27. - Priority: low - -11 When function f, which calls function g, is on the workspace, - and you edit g, the changes do not propagate back to f, so that - calling f results in calling the *old* g. - Example: open test-champ.siff, place two-lovely on the workspace, - call it with any argument, edit lovely, apply, call two-lovely - again. - Opened 2010 May 20. - Priority: medium - -* * * - -CLOSED ISSUES -------------- - - -1 After using the literal tool, etc., the program stops responding - to key presses in the workspace. - Opened ?? - Closed 2009 Oct 5. - -2 Fix resize frame - Opened ?? - Closed 2009 Oct 13. - -3 Quitting (q and File/quit) should actually quit! - Opened ?? - Closed 2009 Oct 13. - -4 vpTypeOf fails for []. - Opened ?? - Closed 2009 Oct 30. - -5 Deleting a node leaves its children orphans. - Opened ?? - Closed 2009 Nov 4. - -6 After closing "My functions" window and re-opening it, - it should "remembers" the function tools that it had when closed, - instead of showing up as a blank window. - Opened ?? - Closed 2009 Nov 11 - -7 If function pad window is closed, then creating a - new function results in a "key not found" error. - Opened ?? - Closed 2010 March 1 - -8 Opening a file twice put duplicate tools in - "My Functions" window (and toolkit, presumably). - Opened ?? - Closed 2010 May 13 - -9 After the dialog suggesting save changes before quitting or - opening a new file, the program crashes due to a bug in - Gtk2hs 0.10.0 and 0.10.1 (but fixed in gtk2hs darcs). - Opened ?? - Closed 2010 May 20. - -10 Evaluating a call frame with zero arguments - opens an unnecessary dialog (there are not arguments, - so no values needed); moreover, it does not evaluate - the function call. - -15 In the test function list_of_2, evaluating [] results in - "error: unbound variable: []". Ditto repeat_a_b. - O: 2010 aug 16 - P: high - C: 2010 aug 16 -- fixed. - -16 Editing a function, if you enter the literal ["a", "b"], - the program crashes with this message: - sifflet-new-expr: makeFixedLiteralTool: - non-empty list expression EList [EString "a",EString "b"] - O: 2010 aug 16 - P: high - C: 2010 aug 16 -- fixed. - - -17 There is an error in reading a non-empty list element from - a SiffML file, e.g., - - - a - b - - - due to the fact that the children of the element - directly represent values, not expressions, so they are - not read correctly (not read at all?) by xmlToExpr. - I think I need to use xmlToValue here, but how to connect - the two is not easy. - In the long run, it is desirable to change the XML doctype, - dropping the element so that strings would be - e.g. just a - and lists would be just e.g. - - a - b - - O: 2010 aug 17 - P: highest - C: 2010 aug 17 -- fixed. - -19 Closing all program windows leaves executable still running - but no way to kill it (Ctrl+C is a no-op).* - O: 2010 nov 3 - R: Andrew Coppin andrewcoppin@btinternet.com - P: HIGH - C: 2010 dec 9 (actually fixed dec 3): closing the workspace window - now "safely" quits from the application. - -20 Amend documentation/home page to note that installation on - Windows without curl is now definitely feasible - O: 2010 nov 3 - R: Andrew Coppin andrewcoppin@btinternet.com - P: medium - C: 2010 dec 9 (actually fixed dec 3) - -21 Define adds list = - if null list - then 0 - else if head list - then + list 1 - else tail (head list) - Call the function with list = [1] - Sifflet crashes with this error message: - evalTreeWithLimit (if): unexpected test result - O: 2010 dec 9 - R: Charles Turner III (turnchan@iue.edu) - P: high - C: 2010 dec 9 - -29 typedValue (in Parser.hs) has two conditions that result in - run-time errors. For testing higher-order functions, it would - be good to be able to type in the name of a function in the global - environment, but we don't have access to the environment here, - do we? Also in case of failure, it should fail with an error - message but not crash sifflet. - O: 2012 Jun 15 - R: gdw - P: high - Crashes program. - C: 2012 June 21 -- fixed. - -30 typeToXml: program crashes when saving the map function definition, - with message: - sifflet-devel: typeToXml: TypeCons Function cannot be converted to XML. - Notes: - 1. typeToXml is fixed, but now I also need to fix the corresponding - part of xmlToType so the file can be read back in. - 2. Maybe better still: - Why do we need the types in the XML file anyway, now that - we have type inference? - 3. Also revise schema/DTD for SiffML files. - O: 2012 Jun 21 - R: gdw - P: highest - program crash - C: 2012 June 22, fixed. - -28 EditArgsPanel should change inlets for existing nodes when the arg's - kind is changed. - - Suppose you change the number of parameters for argument f. - Then any existing f nodes on the drawing should have their - number of inlets changed correspondingly. - Currently this works if the number is increased, but - fails if it is decreased and there are now too many - connected children in the graph --> error in graphRenderTree. - Unfortunately, this is not the place where that can be fixed: - even if I reduce nto or nfrom in this context, - there are still the contexts in the connected children to - consider. - - Also, when extra inputs are disconnected (as they should be) - they are sometimes also deleted from the canvas (shouldn't be). - O: 2011 Jun 23 - R: gdw - P: highest. Crashes program. - C: 2012 Jun 27, fixed. - - -18 Sifflet crashes when applying a function if some connections - are missing. - - "PS. I presume you know that you can crash the whole of Sifflet by - something as trivial as hitting the "apply" button when some - connections are missing, and that closing all of the program windows - leaves the executable still running but with no way to kill it. (I'm - not sure why Ctrl+C is no-op...)" - -- email from Andrew Coppin, 2010 Nov 01. - - O: 2010 nov 3 - R: Andrew Coppin andrewcoppin@btinternet.com - P: HIGH - C: 2012 Jun 27 -- unable to duplicate either part of this at this time; - must have been fixed earlier. Though it might be that the - "no way to kill it" issue persists on MS Windows. - -35 vcCloseFrame does not remove the frame's subgraph from the canvas graph. - - vcCloseFrame removes only the WFrame node, not the WSimple nodes - displayed in the frame. It should remove all of them, otherwise - clutter builds up every time a function definition is applied, - since the apply command calls vcCloseFrame and then vcAddFrame. - O: 2012 Jun 27 - R: gdw - P: high - C: 2012 Jun 27 fixed. - -12 Four tests fail in testall -u. - These seem to all involve issues of text node size - and are pretty minor, so maybe the tests need to be - fine-tuned to allow for variations in what Cairo says - is the text's dimensions. - Opened 2010 May 24 - Priority: medium - C: 2012 Jul 2, previously fixed but not closed; all unit tests now pass. - -34 In edit function / edit arguments: the edit window sometimes - does not sufficiently increase in size, - so the edit arguments buttons (OK, cancel) - are hidden by the edit function buttons (args, apply, inputs, close). - Comment: see darcs change: - Tue Jun 7 12:40:24 EDT 2011 gdweber@iue.edu - * Crude window resizing to fit as the EditArgsPanel grows - - crude because it does not take into account the button bar - below the panel - Comment: duplicate of #27 - O: 2012 June 26 - R: gdw - P: top - C: 2012 jul 2, fixed - -27 EditArgsPanel: window resizing is bad. - - Sometimes the window does not expand enough to show the - panel's buttons. - - Sometimes it shrinks back too much after the panel is closed. - - Comment: lib/Graphics/UI/Sifflet/EditArgsPanel.hs - Workspace.hs : 138 - - O: 2011 Jun 23 - R: gdw - P: top - C: 2012 jul 2, fixed diff --git a/Language/Sifflet/Export/Exporter.hs b/Language/Sifflet/Export/Exporter.hs --- a/Language/Sifflet/Export/Exporter.hs +++ b/Language/Sifflet/Export/Exporter.hs @@ -11,10 +11,16 @@ , ruleRightToLeft , applyFirstMatch , findFixed + , copyLibFile + , readLibFile ) where +import Control.Monad (unless) +import System.Directory (doesFileExist, copyFile) + +import Graphics.UI.Sifflet.GtkUtil (showErrorMessage) import Language.Sifflet.Expr -- | The type of a function to export (user) functions to a file. @@ -190,3 +196,32 @@ EGroup e'' -> EGroup (tdf e'') _ -> e' +-- | Copy a library file (such as sifflet.py or Sifflet.java) to the same directory +-- where an export file is being written, showing a warning message if +-- the library file cannot be found. But don't copy it if it already +-- exists in the destination location. +copyLibFile :: FilePath -> FilePath -> IO () +copyLibFile orig dest = do + origExists <- doesFileExist orig + destExists <- doesFileExist dest + unless destExists $ + if origExists + then copyFile orig dest + else showErrorMessage $ "Sifflet could not locate the file " ++ orig ++ "\n" ++ + "Please copy it from the Sifflet installation directory to " ++ + "the same directory in which you are saving the export file.\n" + +-- | 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 :: FilePath -> FilePath -> IO String +readLibFile libFile exportFile = do + libExists <- doesFileExist libFile + if libExists + then readFile libFile + else do + showErrorMessage $ "Sifflet could not locate the file " ++ libFile ++ "\n" ++ + "Please find it in the Sifflet installation directory " ++ + "and insert its contents into " ++ exportFile ++ "\n" + return "" diff --git a/Language/Sifflet/Export/ToPython.hs b/Language/Sifflet/Export/ToPython.hs --- a/Language/Sifflet/Export/ToPython.hs +++ b/Language/Sifflet/Export/ToPython.hs @@ -18,9 +18,7 @@ where import Data.Char (isAlpha, isDigit, ord) -import Control.Monad (unless) import Data.Map ((!)) -import System.Directory (copyFile, doesFileExist) import System.FilePath (replaceFileName) import Language.Sifflet.Export.Exporter @@ -149,23 +147,17 @@ exportPython :: PythonOptions -> Exporter exportPython _options funcs path = - let header = "# File: " ++ path ++ - "\n# Generated by the Sifflet->Python exporter.\n\n" ++ + let header = "# File: " ++ path ++ "\n" ++ + "# Generated by the Sifflet->Python exporter.\n" ++ + "# You may need to copy the file sifflet.py to this directory\n" ++ + "# from the directory where Sifflet is installed.\n" ++ + "\n" ++ "from sifflet import *\n\n" libDest = replaceFileName path "sifflet.py" in do - { - libDestExists <- doesFileExist libDest - ; unless libDestExists - (do - -- copy sifflet.py to the same directory as path - { - libSrc <- pythonLibSiffletPath - ; copyFile libSrc libDest - } - ) - ; writeFile path (header ++ (functionsToPrettyPy funcs)) - } + libSrc <- pythonLibSiffletPath + copyLibFile libSrc libDest + writeFile path (header ++ (functionsToPrettyPy funcs)) pythonLibSiffletPath :: IO FilePath pythonLibSiffletPath = getDataFileName "sifflet.py" diff --git a/Language/Sifflet/Export/ToScheme.hs b/Language/Sifflet/Export/ToScheme.hs --- a/Language/Sifflet/Export/ToScheme.hs +++ b/Language/Sifflet/Export/ToScheme.hs @@ -303,16 +303,21 @@ -- like defToSExpr. exportScheme :: SchemeOptions -> Exporter -exportScheme options functions path = do - { - let header = ";;; File: " ++ path ++ - "\n;;; Generated by the Sifflet->Scheme exporter." - ; lib <- schemeLibSiffletPath >>= readFile - ; writeFile path - (sepLines2 [header, - functionsToPrettyScheme options functions, - lib]) - } +exportScheme options functions path = + let header = ";;; File: " ++ path ++ "\n" ++ + ";;; Generated by the Sifflet->Scheme exporter.\n" ++ + "\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. + libFile <- schemeLibSiffletPath + lib <- readLibFile libFile path + writeFile path + (sepLines2 [header, + functionsToPrettyScheme options functions, + lib]) -- | The path to the "sifflet.scm" file. schemeLibSiffletPath :: IO FilePath diff --git a/Language/Sifflet/Expr.hs b/Language/Sifflet/Expr.hs --- a/Language/Sifflet/Expr.hs +++ b/Language/Sifflet/Expr.hs @@ -885,7 +885,7 @@ else if isExact a && isExact b then EvalOk $ VNumber (oper a b) else err "arguments must be exact numbers" - _ -> error "wrong type or number of arguments" + _ -> err "wrong type or number of arguments" in prim name [typeNum, typeNum] typeNum func primIntDiv, primIntMod :: Function diff --git a/Language/Sifflet/SiffML.hs b/Language/Sifflet/SiffML.hs --- a/Language/Sifflet/SiffML.hs +++ b/Language/Sifflet/SiffML.hs @@ -52,7 +52,9 @@ consumeSiffMLFile :: XMLConsumer XmlTree a -> FilePath -> IO [a] consumeSiffMLFile fromXml filePath = let options = defaultOptions - in runX (readDocument options filePath >>> fromXml) + in do + doc <- readFile filePath + runX (readString options doc >>> fromXml) -- | Symbols diff --git a/Language/Sifflet/TypeCheck.hs b/Language/Sifflet/TypeCheck.hs --- a/Language/Sifflet/TypeCheck.hs +++ b/Language/Sifflet/TypeCheck.hs @@ -16,8 +16,8 @@ where --- drop this after debugging: -import System.IO.Unsafe(unsafePerformIO) +-- drop after debugging: +import Debug.Trace import Control.Monad (foldM) @@ -26,6 +26,8 @@ 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 @@ -434,11 +436,9 @@ 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'') - } + (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] @@ -485,38 +485,40 @@ te' = install te name (TypeScheme [] (TypeVar "u")) result :: SuccFail (Type, ([Type], Type)) result = do - { - expr <- toLambdaExpr args body - ; (_, t, _) <- tcExpr te' (newNameSupply "t") expr - -- ; fromLambdaType t - ; res <- fromLambdaType t - ; Succ (t, res) - } - in unsafePerformIO $ do - { - putStrLn "decideTypes:" - ; print (args, body) - ; putStrLn "::" - -- ; print result - -- ; return result - ; case result of - Succ (t, res) -> do { print t ; return (Succ res) } - Fail msg -> do { putStrLn msg; return (Fail msg) } - } + 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" _ -> 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) diff --git a/sifflet-lib.cabal b/sifflet-lib.cabal --- a/sifflet-lib.cabal +++ b/sifflet-lib.cabal @@ -1,10 +1,10 @@ name: sifflet-lib -version: 2.0.0.0 +version: 2.1.0 cabal-version: >= 1.8 build-type: Simple license: BSD3 license-file: LICENSE -copyright: (C) 2009-2012 Gregory D. Weber +copyright: (C) 2009-2013 Gregory D. Weber author: Gregory D. Weber maintainer: "gdweber" ++ drop 3 "abc@" ++ "iue.edu" bug-reports: mailto:"gdweber" ++ drop 3 "abc@" ++ "iue.edu" @@ -24,22 +24,22 @@ siffml-2.0.rnc data-dir: datafiles extra-tmp-files: -extra-source-files: README ISSUES RELEASE-NOTES +extra-source-files: README RELEASE-NOTES -- Library section library build-depends: - base >= 4.0 && < 4.6, + 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 - containers >= 0.2 && < 0.5, - directory >= 1.0 && < 1.2, + containers >= 0.2 && < 0.7, + directory >= 1.0 && < 1.4, filepath >= 1.1 && < 1.4, fgl >= 5.4 && < 5.5, hxt >= 9.0 && < 10.0, @@ -51,8 +51,16 @@ buildable: True extensions: ForeignFunctionInterface CPP ghc-options: -Wall - includes: gtk-2.0/gtk/gtk.h, gtk-2.0/gdk/gdk.h - extra-libraries: gdk-x11-2.0 gtk-x11-2.0 + -- 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 exposed-modules: Data.Number.Sifflet