diff --git a/CBMgr.hs b/CBMgr.hs deleted file mode 100644 --- a/CBMgr.hs +++ /dev/null @@ -1,141 +0,0 @@ -module CBMgr - ( - CBMgr, CBMgrCmd(..), mkCBMgr - , MenuSpec(..), MenuItemSpec(..), MenuItemAction - , createMenuBar, addMenu, createMenu, createMenuItem - , modifyIORefIO - ) - -where - -import Data.IORef - -import Graphics.UI.Gtk -import Graphics.UI.Gtk.Gdk.EventM - -import UITypes - --- | 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 () - --- | Commands for the CBMgr -data CBMgrCmd - = -- window events - OnWindowConfigure Window (IORef VPUI -> EventM EConfigure Bool) - | OnWindowDestroy Window (IORef VPUI -> IO ()) - | OnWindowKeyPress 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 (IORef VPUI -> IO ()) - | AfterButtonClicked Button (IORef VPUI -> IO ()) - - | 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 () - OnWindowKeyPress window action -> - on 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 uiref action) >> return () - OnEntryActivate entry action -> - onEntryActivate entry (action uiref) >> return () - AfterButtonClicked button action -> - afterClicked button (action uiref) >> return () - - 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 modifyIORef, but the type of the second argument is (a -> IO a) --- instead of (a -> a). -modifyIORefIO :: IORef a -> (a -> IO a) -> IO () -modifyIORefIO ref updateIO = readIORef ref >>= updateIO >>= writeIORef ref diff --git a/Examples.hs b/Examples.hs deleted file mode 100644 --- a/Examples.hs +++ /dev/null @@ -1,278 +0,0 @@ -module Examples (exampleFunctions, exampleFunctionNames, exampleEnv - , eFoo, eMax, eFact -- must these be exported? - ) - -where - --- standard libraries - --- extra libraries - --- sifflet libraries -import Expr -import Util - --- TEST COMPOUND FUNCTIONS - --- | grossProfit salesA salesB = 0.12 salesA + 0.25 salesB - -grossProfit :: Function -grossProfit = - Function (Just "grossProfit") [VpTypeNum, VpTypeNum] VpTypeNum - (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") [VpTypeNum] VpTypeNum - (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") [VpTypeNum, VpTypeNum] VpTypeNum - (Compound ["salesA", "salesB"] - (eCall "bonus1" [eCall "grossProfit" [eSymbol "salesA", - eSymbol "salesB"]])) - --- foo a b = 2 * a + b -foo :: Function -foo = Function (Just "foo") [VpTypeNum, VpTypeNum] VpTypeNum - (Compound ["a", "b"] - (eCall "+" [eCall "*" [eInt 2, eSymbol "a"], - eSymbol "b"]) - ) - -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") [VpTypeNum, VpTypeNum] VpTypeNum - (Compound ["x", "y"] (eIf (eGt ex ey) ex ey)) - -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") [VpTypeNum] VpTypeNum - (Compound ["n"] - (eIf (eZerop en) - (eInt 1) - (eTimes en (eFact (eSub1 en))))) - -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") [VpTypeNum] VpTypeNum - (Compound ["n"] - (eIf (eZerop en) - (eInt 0) - (ePlus en (eSumFromZero (eSub1 en))))) - -buggySumFromZero :: Function -buggySumFromZero = - let Succ body = stringToExpr "n + buggySumFromZero (n - 1)" - in Function (Just "buggySumFromZero") [VpTypeNum] VpTypeNum - (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") [VpTypeNum] VpTypeNum - (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. - -eRmul :: Expr -> Expr -> Expr -eRmul em en = eCall "rmul" [em, en] - -rmul :: Function -rmul = let em = eSymbol "m" - en = eSymbol "n" - in Function (Just "rmul") [VpTypeNum, VpTypeNum] VpTypeNum - (Compound ["m", "n"] - (eIf (eZerop en) - (eInt 0) - (ePlus em (eRmul em (eSub1 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") [VpTypeNum, VpTypeNum] VpTypeNum - (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?") [VpTypeNum] VpTypeBool - (Compound ["n"] - (eIf (eZerop en) - eTrue - (eOddp (eSub1 en)))) - -oddp = let en = eSymbol "n" - in Function (Just "odd?") [VpTypeNum] VpTypeBool - (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") [VpTypeNum] VpTypeNum - (Compound ["month"] - (ePlus (eRabbitBabies m) (eRabbitAdults m))) - -rabbitAdults = let m = eSymbol "month" - zero = eInt 0 - one = eInt 1 - in Function (Just "rabbitAdults") [VpTypeNum] VpTypeNum - (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") [VpTypeNum] VpTypeNum - (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") - [VpTypeList (VpTypeVar "e1")] VpTypeNum - (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") - [VpTypeList (VpTypeVar "e1")] VpTypeNum - (Compound ["xs"] - (eIf (eCall "null" [xs]) - zero - (ePlus one - (eCall "length" - [eCall "tail" [xs]])))) - -listSum :: Function -listSum = - Function (Just "sum") [VpTypeList VpTypeNum] VpTypeNum - (Compound ["xs"] sumbody1) - -sumbody1, sumbody2 :: Expr -sumbody1 = let xs = eSymbol "xs" - zero = eInt 0 - in eIf (eCall "null" [xs]) - zero - (ePlus (eCall "head" [xs]) - (eCall "sum" [eCall "tail" [xs]])) - -sumbody2 = - let Succ body = - stringToExpr "if null xs then 0 else (head xs) + (sum' (tail xs))" - in body - -listSum' :: Function -listSum' = - Function (Just "sum'") - [VpTypeList VpTypeNum] VpTypeNum - (Compound ["xs"] sumbody2) - -buggySum :: Function -buggySum = let xs = eSymbol "xs" - in Function (Just "buggySum") - [VpTypeList VpTypeNum] VpTypeNum - (Compound ["xs"] - -- missing "if" and base case - (ePlus (eCall "head" [xs]) - (eCall "buggySum" [eCall "tail" [xs]]))) - -exampleFunctions :: [Function] -exampleFunctions = [grossProfit, bonus1, bonus2, - foo, Examples.max, fact, sumFromZero, rmul, fib1, - 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) diff --git a/Expr.hs b/Expr.hs deleted file mode 100644 --- a/Expr.hs +++ /dev/null @@ -1,1059 +0,0 @@ -module Expr (stringToExpr, exprToValue, stringToValue, - stringToLiteral, - Symbol(..), - Expr(..), eSymbol, eInt, eString, eChar, eFloat, - eBool, eFalse, eTrue, eIf, - eList, eCall, - exprSymbols, exprVarNames, - ExprTree, ExprNode(..), ExprNodeLabel(..), - exprNodeIoletCounter, -- needs work ****** get rid of it??? - exprToTree, treeToExpr, exprToReprTree, - EvalResult, EvalRes(EvalOk, EvalError, EvalUntried), - evalTree, unevalTree, - Value(..), valueFunction, - Function(..), functionName, functionNArgs, - functionArgTypes, functionResultType, - functionArgNames, functionBody, functionImplementation, - FunctionDefTuple, functionToDef, functionFromDef, - FunctionImpl(..), - VpType(..), typeCheck, vpTypeOf, - Env, makeEnv, extendEnv, envInsertL, envPop, - envIns, envSet, envGet, - envGetFunction, envLookup, envLookupFunction, - envSymbols, envFunctionSymbols, - eval, apply, - decideTypes, newUndefinedFunction, undefinedTypes, - 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 Language.Haskell.Syntax -import Language.Haskell.Parser -{- -import Language.Haskell.Pretty --} - - -import Data.Map as Map hiding (filter, map, null) -import Data.List as List - -import Tree as T -import Util - -{- -testHsParse = do - let (ParseOk (HsModule srcLoc pmod mExports imports decls)) = parseModule "foo x y = x + y" - print $ length decls - print $ decls!!0 - putStrLn "Wow, this is complex." --} - -stringToExpr :: String -> SuccFail Expr -stringToExpr string = - case parseModule ("x = " ++ string) of - ParseOk (HsModule - _srcLoc -- (SrcLoc ...) - _module -- (Module "Main") - _justMain -- (Just [HsEVar (UnQual (HsIdent "main"))]) - _ -- [] - result) - -> - case result of - [HsPatBind _ _ (HsUnGuardedRhs expr) []] -> - hsExpToVp expr - _ -> - errcat ["stringToExpr: unexpected parse result " ++ - "from string " ++ show string ++ - "; result = " ++ show result] - - ParseFailed _ str -> Fail str -- not very informative - -hsExpToVp :: HsExp -> SuccFail Expr -hsExpToVp hsExp = - case hsExp of - - HsVar (UnQual (HsSymbol name)) -> Succ $ eSymbol name -- e.g. "+" - HsVar (UnQual (HsIdent name)) -> Succ $ eSymbol name -- e.g. "head" - - HsLit (HsInt i) -> Succ $ eInt i - HsLit (HsFrac r) -> Succ $ eFloat (fromRational r) - HsLit (HsChar a) -> Succ $ eChar a - HsLit (HsString s) -> Succ $ eString s - - HsCon (UnQual (HsIdent "False")) -> Succ eFalse - HsCon (UnQual (HsIdent "True")) -> Succ eTrue - - HsList items -> - case hsListItemsToVps [] items of - Fail msg -> Fail msg - Succ items' -> Succ (eList items') - - HsNegApp hslit -> hsExpToVp hslit >>= eNegate - - HsApp (HsVar (UnQual (HsIdent name))) hsArg -> - do - arg <- hsExpToVp hsArg - Succ $ eCall name [arg] -- ??? *** - HsApp (HsApp hsApp1 hsArg1) hsArg2 -> - do - call1 <- hsExpToVp (HsApp hsApp1 hsArg1) - arg2 <- hsExpToVp hsArg2 - let ECall f args = call1 - Succ $ ECall f (args ++ [arg2]) - HsInfixApp hsArg1 (HsQVarOp (UnQual (HsSymbol op))) hsArg2 -> - do - arg1 <- hsExpToVp hsArg1 - arg2 <- hsExpToVp hsArg2 - Succ $ eCall op [arg1, arg2] - - HsIf hsExp1 hsExp2 hsExp3 -> - do - expr1 <- hsExpToVp hsExp1 - expr2 <- hsExpToVp hsExp2 - expr3 <- hsExpToVp hsExp3 - Succ $ eIf expr1 expr2 expr3 - - HsParen hsExp1 -> hsExpToVp hsExp1 - - _ -> Fail ("hsExpToVp: unknown expression type: " ++ show hsExp) - -eNegate :: Expr -> SuccFail Expr -eNegate expr = - case expr of - ELit (VInt i) -> Succ $ ELit (VInt (negate i)) - ELit (VFloat x) -> Succ $ ELit (VFloat (negate x)) - _ -> Fail $ "eNegate: cannot handle" ++ show expr - -hsListItemsToVps :: [Expr] -> [HsExp] -> SuccFail [Expr] -hsListItemsToVps result items = - case items of - [] -> Succ (reverse result) - (x:xs) -> - case hsExpToVp x of - Fail msg -> Fail msg - Succ x' -> hsListItemsToVps (x':result) xs - --- Symbols have names, and may or may not have values, --- but the value is stored in an environment, not in the symbol itself. - -data Symbol = Symbol String -- symbol name - deriving (Eq, Read, Show) - -instance Repr Symbol where repr (Symbol s) = s - --- The Haskell representations of V's primitive data types -type OInt = Integer -type OStr = String -type OBool = Bool -type OChar = Char -type OFloat = Double - -stringToLiteral :: String -> SuccFail Expr -stringToLiteral s = stringToValue s >>= valueToLiteral - --- | A more highly "parsed" type of expression --- --- ELit (literals) are "primitive" (self-evaluating) expressions, --- in the sense that if x is a literal, then eval x env = EvalOk x --- for any environment env. - -data Expr = EUndefined - | ESymbol Symbol - | ELit Value - | EIf Expr Expr Expr -- if test branch1 branch2 - | EList [Expr] -- needed for hsExpToVp case HsList - | ECall Symbol [Expr] -- function name, arglist - -- A function expression other than a symbol will - -- be hard to visualize: - -- | ECall [Expr] -- (function:args) - deriving (Eq, Read, Show) - -instance Repr Expr where - repr EUndefined = "*undefined*" - repr (ESymbol s) = repr s - repr (ELit x) = repr x - repr (EIf t a b) = par "if" (map repr [t, a, b]) - repr (EList items) = par "EList" (map repr items) - repr (ECall (Symbol fname) args) = par fname (map repr args) - -eSymbol :: String -> Expr -eSymbol = ESymbol . Symbol - -eInt :: OInt -> Expr -eInt = ELit . VInt - -eString :: OStr -> Expr -eString = ELit . VStr - -eChar :: OChar -> Expr -eChar = ELit . VChar - -eFloat :: OFloat -> Expr -eFloat = ELit . VFloat - -eBool :: Bool -> Expr -eBool = ELit . VBool - -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 - - --- EXPRESSION TREES -type ExprTree = Tree ExprNode -data ExprNode = ENode ExprNodeLabel EvalResult - deriving (Eq, Show) - -data ExprNodeLabel = NUndefined | NSymbol Symbol | NLit Value - 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 - --- This was --- exprNodeIoletCounter :: Env -> IoletCounter ExprNode --- but IoletCounter is not available here, so use equivalent type. --- Returns (no. of inlets, no. of outlets) -exprNodeIoletCounter :: Env -> ExprNode -> (Int, Int) -exprNodeIoletCounter env (ENode nodeLabel _nodeResult) = - case nodeLabel of - NUndefined -> (0, 1) - NSymbol (Symbol "if") -> (3, 1) - NSymbol (Symbol s) -> - case envLookup env s of - Nothing -> (0, 1) -- probably a parameter of the function - Just value -> - case value of - VFun function -> (functionNArgs function, 1) - _ -> (0, 1) -- symbol bound to non-function value - NLit _ -> (0, 1) - -exprToTree :: Expr -> ExprTree -exprToTree expr = - case expr of - -- EUndefined, ESymbol, ELit map direclty to NUndefined, NSymbol, NLit - EUndefined -> T.Node (ENode NUndefined EvalUntried) [] - ESymbol s -> T.Node (ENode (NSymbol s) EvalUntried) [] - ELit l -> T.Node (ENode (NLit l) EvalUntried) [] - -- EIf maps to symbol "if" at the root, 3 subtrees - EIf t a b -> T.Node (ENode (NSymbol (Symbol "if")) EvalUntried) - (map exprToTree [t, a, b]) - -- ECall maps to symbol f (function name) at the root, - -- each argument forms a subtree - ECall f args -> T.Node (ENode (NSymbol f) EvalUntried) - (map exprToTree args) - -- EList maps to the *symbol* (yes!) "[]" or to a ":" (cons) expression - EList [] -> T.Node (ENode (NSymbol (Symbol "[]")) EvalUntried) [] - EList (x:xs) -> exprToTree (ECall (Symbol ":") [x, EList xs]) - --- | Convert an expression tree (back) to an expression --- It will not give back the *same* expression in the case of an EList. -treeToExpr :: ExprTree -> Expr -treeToExpr (T.Node (ENode label _) trees) = - let wrong msg = - errcat ["treeToExpr: ", msg, ": node label = ", - show label, "; trees = ", show trees] - in case label of - NUndefined -> EUndefined - NSymbol s -> - if s == Symbol "if" - then case trees of - [q, a, b] -> - EIf (treeToExpr q) (treeToExpr a) (treeToExpr b) - _ -> wrong "'if' node with /= 3 subtrees" - else - -- VVV Do I really need to distinguish these two cases? - if null trees - then - -- s = terminal symbol - ESymbol s - else -- s = function symbol in function call - ECall s (map treeToExpr trees) - NLit lit -> if null trees then ELit lit - else wrong "literal node with non-empty subtrees" - --- Convert an expression to a repr tree (of string elements) --- (Why?) - -exprToReprTree :: Expr -> Tree String -exprToReprTree = fmap repr . exprToTree - --- Evaluation results (or non-results) - -type EvalResult = EvalRes Value - -data EvalRes e = EvalOk e | EvalError String | EvalUntried - deriving (Eq, Show) - -instance Monad EvalRes where - EvalOk value >>= f = f value - EvalError e >>= _f = EvalError e - EvalUntried >>= _f = EvalUntried - return = EvalOk - fail = EvalError - --- 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'] - - 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 _ -> - T.Node (ENode rootOper (evalWithLimit (treeToExpr atree) env ss')) - [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 - --- VALUES AND EVALUATION - -data Value = VBool OBool - | VChar OChar - | VInt OInt - | VFloat OFloat - | VStr OStr - | VFun Function - | VList [Value] - deriving (Eq, Read, Show) - -- no Read for Function - -instance Repr Value where - repr (VBool b) = show b - repr (VChar c) = show c - repr (VInt i) = show i - repr (VFloat x) = show x - repr (VStr s) = show s - repr (VFun f) = show f - repr (VList l) = - "[" ++ - concat (intersperse ", " (map repr l)) ++ - "]" - -valueFunction :: Value -> Function -valueFunction value = - case value of - VFun function -> function - _ -> error "valueFunction: non-function value" - --- | 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 - VFun _f -> Fail "cannot convert a function to a literal" - _ -> Succ (ELit v) - -stringToValue :: String -> SuccFail Value -stringToValue s = - case stringToExpr s of - Succ expr -> exprToValue expr - Fail errmsg -> Fail errmsg - -data VpType = VpTypeString - | VpTypeChar - | VpTypeNum - | VpTypeBool - | VpTypeList VpType -- list with fixed type of elements - | VpTypeFunction [VpType] VpType -- argument, result types - | VpTypeVar String -- named type variable - deriving (Eq, Read, Show) - - -type TypeEnv = Map String VpType - --- | Try to match a single type and value, --- may result in binding a type variable in a new environment --- or just the old environment -typeMatch :: VpType -> Value -> TypeEnv -> SuccFail TypeEnv -typeMatch vptype value env = - let sorry x etype = - Fail $ repr x ++ ": " ++ etype ++ " expected" - in case (vptype, value) of - -- easy cases - (VpTypeBool, VBool _) -> Succ env - (VpTypeBool, x) -> sorry x "True or False" - (VpTypeChar, VChar _) -> Succ env - (VpTypeChar, x) -> sorry x "character" - (VpTypeNum, VInt _) -> Succ env - (VpTypeNum, VFloat _) -> Succ env - (VpTypeNum, x) -> sorry x "number" - (VpTypeString, VStr _) -> Succ env - (VpTypeString, x) -> sorry x "string" - -- VV Harder - -- VV Are the avalues below supposed to be equal to the value above? - (VpTypeVar name, avalue) -> - case Map.lookup name env of - Nothing -> - -- bind type variable - vpTypeOf avalue >>= \ vtype -> Succ $ Map.insert name vtype env - Just concreteType -> typeMatch concreteType avalue env - (VpTypeList etype, VList lvalues) -> - case lvalues of - [] -> Succ env - v:vs -> - typeMatch etype v env >>= - typeMatch (VpTypeList etype) (VList vs) - (VpTypeFunction _atypes _rtype, _) -> - -- this will require matching type variables with type variables! - error "typeMatch: unimplemented case for VpTypeFunction" - _ -> Fail $ "type mismatch: " ++ show (vptype, value) - - --- | Determine the type of a value. --- May result in a type variable. - -vpTypeOf :: Value -> SuccFail VpType -vpTypeOf v = - case v of - VBool _ -> Succ VpTypeBool - VChar _ -> Succ VpTypeChar - VInt _ -> Succ VpTypeNum - VFloat _ -> Succ VpTypeNum - VStr _ -> Succ VpTypeString - VFun (Function _ atypes rtype _) -> Succ $ VpTypeFunction atypes rtype - - VList [] -> Succ $ VpTypeList $ VpTypeVar "list_element" - VList (x:xs) -> - do - xtype <- vpTypeOf x - xstypes <- mapM vpTypeOf xs - if filter (/= xtype) xstypes == [] - then Succ $ VpTypeList 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. - -typeCheck :: [String] -> [VpType] -> [Value] -> SuccFail [Value] -typeCheck names types values = - let check :: TypeEnv -> [String] -> [VpType] -> [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 "typeCheck: mismatched list lengths" - in check empty names types values - --- | A function may have a name and always has an implementation -data Function = Function (Maybe String) -- function name - [VpType] -- argument types - VpType -- result type - FunctionImpl -- implementation - deriving (Read, Show) - -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 (Function mname _ _ _) = - case mname of - Nothing -> "" - Just name -> "" - -newUndefinedFunction :: String -> [String] -> Function -newUndefinedFunction name argnames = - let (atypes, rtype) = undefinedTypes argnames - impl = Compound argnames EUndefined - in Function (Just name) atypes rtype impl - -functionName :: Function -> String -functionName (Function mname _ _ _) = - case mname of - Just name -> name - Nothing -> "anonymous function" - -functionNArgs :: Function -> Int -functionNArgs = length . functionArgTypes - -functionArgTypes :: Function -> [VpType] -functionArgTypes (Function _ argtypes _ _) = argtypes - -functionResultType :: Function -> VpType -functionResultType (Function _ _ rtype _) = rtype - --- -- | Type type of a function, a tuple of (arg types, result type) --- -- Unused --- functionType :: Function -> ([VpType], VpType) -- (args., result type) --- functionType f = (functionArgTypes f, functionResultType f) - -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], [VpType], VpType, 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) - -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] - --- | 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 - - ELit value -> EvalOk value - - EIf t a b -> - case evalWithLimit t env stacksize' of - EvalOk (VBool True) -> evalWithLimit a env stacksize' - EvalOk (VBool False) -> evalWithLimit b env stacksize' - result -> result - - 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 - --- | 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 "+" (+) (+), -- Integer (+), Double (+) - primN2N "-" (-) (-), - primN2N "*" (*) (*), - primIntDiv, - primIntMod, - primFloatDiv, - - primN1N "add1" succ succ, - primN1N "sub1" pred pred, - - -- Comparison - primN2B "==" (==) (==), - primN2B "/=" (/=) (/=), - primN2B ">" (>) (>), - primN2B ">=" (>=) (>=), - primN2B "<" (<) (<), - primN2B "<=" (<=) (<=), - - primN1B "zero?" (== 0) (== 0.0), - primN1B "positive?" (> 0) (> 0.0), - primN1B "negative?" (< 0) (< 0.0), - - -- List operations - - -- null xs tells if xs is an empty list - prim "null" [VpTypeList (VpTypeVar "a")] - VpTypeBool primNull, - - prim "head" [VpTypeList (VpTypeVar "c")] - (VpTypeVar "c") - primHead, - prim "tail" [VpTypeList (VpTypeVar "c")] - (VpTypeList (VpTypeVar "c")) - primTail, - prim ":" [VpTypeVar "d", VpTypeList (VpTypeVar "d")] - (VpTypeList (VpTypeVar "d")) - primCons - ] - -type PFun = [Value] -> EvalResult - --- Primitive functions of arbitrary type -prim :: String -> [VpType] -> VpType -> 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 -> (OInt -> OInt -> OInt) -> Function -primIntDivMod name oper = - let func args = - let err msg = EvalError $ concat [name, ": ", msg, - " (", show args, ")"] - in case args of - [VInt a, VInt b] -> - if b == 0 - then err "zero divisor" - else EvalOk $ VInt (oper a b) - [VFloat _, _] -> err "arguments must be exact numbers" - [_, VFloat _] -> err "arguments must be exact numbers" - _ -> error "wrong type or number of arguments" - in prim name [VpTypeNum, VpTypeNum] VpTypeNum 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 - [VInt ix, VInt iy] -> - EvalOk $ VFloat (fromIntegral ix / fromIntegral iy) - [VInt ix, VFloat y] -> EvalOk $ VFloat (fromIntegral ix / y) - [VFloat x, VInt iy] -> EvalOk $ VFloat (x / fromIntegral iy) - [VFloat x, VFloat y] -> EvalOk $ VFloat (x / y) - _ -> EvalError $ "/: invalid args: " ++ show args - in prim "/" [VpTypeNum, VpTypeNum] VpTypeNum 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 --- fi = integer function to implement for integer operands. --- fx = float function to implement for float operands. -primN2N :: String -> (OInt -> OInt -> OInt) -> (OFloat -> OFloat -> OFloat) - -> Function -primN2N name fi fx = - let impl args = - case args of - [VInt ix, VInt iy] -> EvalOk $ VInt (fi ix iy) - [VInt ix, VFloat y] -> EvalOk $ VFloat (fx (fromIntegral ix) y) - [VFloat x, VInt iy] -> EvalOk $ VFloat (fx x (fromIntegral iy)) - [VFloat x, VFloat y] -> EvalOk $ VFloat (fx x y) - _ -> EvalError $ name ++ ": invalid args: " ++ show args - in prim name [VpTypeNum, VpTypeNum] VpTypeNum impl - --- | Primitive unary functions number to number -primN1N :: String -> (OInt -> OInt) -> (OFloat -> OFloat) -> Function -primN1N name fi fx = - let impl args = - case args of - [VInt ix] -> EvalOk $ VInt (fi ix) - [VFloat x] -> EvalOk $ VFloat (fx x) - _ -> EvalError $ name ++ ": invalid args: " ++ show args - in prim name [VpTypeNum] VpTypeNum impl - --- Primitive frunctions with 2 number args and a boolean result -primN2B :: String -> (OInt -> OInt -> OBool) -> (OFloat -> OFloat -> OBool) - -> Function -primN2B name fi fx = - let impl args = - case args of - [VInt x, VInt y] -> EvalOk $ VBool (fi x y) - [VInt ix, VFloat y] -> EvalOk $ VBool (fx (fromIntegral ix) y) - [VFloat x, VInt iy] -> EvalOk $ VBool (fx x (fromIntegral iy)) - [VFloat x, VFloat y] -> EvalOk $ VBool (fx x y) - _ -> EvalError $ name ++ ": invalid args: " ++ show args - in prim name [VpTypeNum, VpTypeNum] VpTypeBool impl - - --- Primitive unary functions number to boolean -primN1B :: String -> (OInt -> Bool) -> (OFloat -> OBool) -> Function -primN1B name fi fx = - let impl args = - case args of - [VInt ix] -> EvalOk $ VBool (fi ix) - [VFloat x] -> EvalOk $ VBool (fx x) - _ -> EvalError $ name ++ ": invalid args: " ++ show args - in prim name [VpTypeNum] VpTypeBool impl - -baseEnv :: Env -baseEnv = - makeEnv (map functionName primitiveFunctions) - (map VFun primitiveFunctions) - --- | Given an expression, return the list of names of variables --- occurring n the expression -exprSymbols :: Expr -> [Symbol] -exprSymbols expr = - nub $ case expr of - EUndefined -> [] -- is *not* a variable - ESymbol s -> [s] - ELit _ -> [] - EIf t a b -> nub $ concat [exprSymbols t, - exprSymbols a, - exprSymbols b] - ECall f args -> - case args of - [] -> [f] - a:as -> nub $ concat [exprSymbols a, - exprSymbols (ECall f as)] - EList items -> nub $ concatMap exprSymbols items - --- | 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] - --- | 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 Right (argtypes, returntype) if successful; --- Left errormessage otherwise. - -decideTypes :: Expr -> [String] -> Env -> Either String ([VpType], VpType) -decideTypes expr args _env = - unsafePerformIO $ do - { - print "Fudged the decideTypes" - ; print expr - ; return (if True - then Right (undefinedTypes args) - else Left "decideTypes: not implemented") - } - -undefinedTypes :: [String] -> ([VpType], VpType) -undefinedTypes argnames = - let atypes = [VpTypeVar ('_' : name) | name <- argnames] - rtype = VpTypeVar "_result" - in (atypes, rtype) diff --git a/Geometry.hs b/Geometry.hs deleted file mode 100644 --- a/Geometry.hs +++ /dev/null @@ -1,131 +0,0 @@ -module 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) - ) - -where - -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 diff --git a/GtkForeign.hs b/GtkForeign.hs deleted file mode 100644 --- a/GtkForeign.hs +++ /dev/null @@ -1,269 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface, CPP #-} -{-# INCLUDE /usr/include/gtk-2.0/gtk/gtk.h #-} -{-# INCLUDE /usr/include/gtk-2.0/gdk/gdk.h #-} - --- NOTE: START GHCI AS FOLLOWS: --- ghci -lgtk-x11-2.0 -lgdk-x11-2.0 --- ================================ - --- File: GtkForeign.hs --- Foreign functions from Gtk - --- CURSOR SHAPES --- Original source: https://sourceforge.net/mailarchive/forum.php?thread_name=87ps50ie9o.fsf%40loki.cmears.id.au&forum_name=gtk2hs-users --- Copyright status ?????? - -{- -Re: [Gtk2hs-users] Changing the mouse cursor shape -From: Chris Mears - 2007-05-22 07:48 -Hi Axel, - -Axel Simon writes: - -> We haven't done that yet. -> The functions required are a few in Gdk for creating cursors and looking -> up stock cursors. Also, in Gdk.DrawWindow the function -> gdk_window_set_cursor would need to be bound. If changing cursors would -> be useful for your application, then I can add these functions into the -> next minor release which Duncan wants to do soon. - -Thanks for the information. With your pointers, I was able to hack up -the following code to suit my needs: - -data Cursor = Cursor -type CursorPtr = Ptr Cursor -foreign import ccall "gdk_window_set_cursor" gdkWindowSetCursor :: Ptr DrawWindow -> CursorPtr -> IO () -foreign import ccall "gdk_cursor_new" gdkCursorNew :: Int -> IO CursorPtr -setCursor :: Window -> IO () -setCursor window = do -c <- gdkCursorNew 34 -- the 'crosshair' cursor -d <- widgetGetDrawWindow window -withForeignPtr (unDrawWindow d) $ \ptr -> gdkWindowSetCursor ptr c - -I tried briefly to add some of the bindings to the library, but I don't -understand the build system or the library design well enough to do it -properly. I can confirm that adding the cursor bindings is not very -hard. If you could add them, that would be great, but you needn't do it -solely on my account. - -Chris --} - --- Gtk2hs has added a definition of CursorType in version 0.10.1, --- but in version 0.10.0 and lower, we have to do it ourselves. - --- Ah, but it's not really in 0.10.1 released May 10, 2009; --- it's in darcs since Sept. 27, 2009. - -#if MIN_VERSION_gtk(0,10,2) -#define GTK_HAS_CURSOR_TYPE 1 -#else -#define GTK_HAS_CURSOR_TYPE 0 -#endif - -module GtkForeign - ( -#if GTK_HAS_CURSOR_TYPE - Graphics.UI.Gtk.CursorType(..) -#else - CursorType(..) -#endif - , setCursor) -where - -import System.Glib -import System.Glib.FFI -import Foreign.ForeignPtr (castForeignPtr) - -#if GTK_HAS_CURSOR_TYPE -import Graphics.UI.Gtk -#else -import Graphics.UI.Gtk (Cursor, widgetGetDrawWindow, DrawWindow, Window) -#endif - - --- type CursorPtr = Ptr Cursor - -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 - -#if ! GTK_HAS_CURSOR_TYPE --- Cursor types are added to gtk2hs in v. 0.10.1, but we need this for --- earlier versions including 0.10.0. --- For illustrations, see --- http://www.pygtk.org/docs/pygtk/class-gdkcursor.html - -data CursorType = XCursor - | Arrow - | BasedArrowDown - | BasedArrowUp - | Boat - | Bogosity - | BottomLeftCorner - | BottomRightCorner - | BottomSide - | BottomTee - | BoxSpiral - | CenterPtr - | Circle - | Clock - | CoffeeMug - | Cross - | CrossReverse - | Crosshair - | DiamondCross - | Dot - | Dotbox - | DoubleArrow - | DraftLarge - | DraftSmall - | DrapedBox - | Exchange - | Fleur - | Gobbler - | Gumby - | Hand1 - | Hand2 - | Heart - | Icon - | IronCross - | LeftPtr - | LeftSide - | LeftTee - | Leftbutton - | LlAngle - | LrAngle - | Man - | Middlebutton - | Mouse - | Pencil - | Pirate - | Plus - | QuestionArrow - | RightPtr - | RightSide - | RightTee - | Rightbutton - | RtlLogo - | Sailboat - | SbDownArrow - | SbHDoubleArrow - | SbLeftArrow - | SbRightArrow - | SbUpArrow - | SbVDoubleArrow - | Shuttle - | Sizing - | Spider - | Spraycan - | Star - | Target - | Tcross - | TopLeftArrow - | TopLeftCorner - | TopRightCorner - | TopSide - | TopTee - | Trek - | UlAngle - | Umbrella - | UrAngle - | Watch - | Xterm - | LastCursor - | CursorIsPixmap - deriving (Eq, Read, Show) -#endif - -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 -> (-1) - CursorIsPixmap -> (-1) diff --git a/GtkUtil.hs b/GtkUtil.hs deleted file mode 100644 --- a/GtkUtil.hs +++ /dev/null @@ -1,225 +0,0 @@ -{-# LANGUAGE CPP #-} - -module 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.Gtk hiding (response) -- Gtk 0.10.1 -import Graphics.UI.Gtk -- Gtk 0.10.0 does not have response - -import 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; --- 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) - - -- 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 indexOptions = zip [1..] options - 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] - } - -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 - return Nothing - 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/LittleGtk.hs b/LittleGtk.hs deleted file mode 100644 --- a/LittleGtk.hs +++ /dev/null @@ -1,150 +0,0 @@ --- 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 LittleGtk - ( - -- These are just directly re-exported from Gtk: - - -- Attributes - AttrOp(..), -- for (:=) - get, - set, - - adjustmentNew, - - boxPackEnd, - boxPackStart, - boxPackStartDefaults, - - Button, - buttonNewWithLabel, - - ContainerClass, - castToContainer, - containerAdd, - containerChild, - containerForeach, - - customStoreSetColumn, - - -- Dialog - toDialog, - - DrawWindow, - drawWindowInvalidateRect, - - entryCompletionInsertPrefix, - entryCompletionModel, - entryCompletionNew, - entryCompletionSetTextColumn, - - Entry, - entryGetText, - entryGetCompletion, - entryNew, - entrySetCompletion, - - EventMask(..), - - eventBoxNew, - - exposeEvent, - - fileChooserDialogNew, - fileChooserGetFilename, - - FileChooserAction(..), - - grabAdd, - grabRemove, - - HBox, - hBoxNew, - - keyPressEvent, - - labelNew, - - Layout, - layoutGetDrawWindow, - layoutNew, - layoutPut, - layoutSetSize, - - listStoreNew, - - makeColumnIdString, - - menuPopup, - - on, - onDestroy, - onSizeRequest, - - Packing(..), - - PolicyType(PolicyAutomatic), - - Rectangle(..), - - renderWithDrawable, - - Requisition(..), - - ResponseId(..), - - ScrolledWindow, - scrolledWindowNew, - scrolledWindowSetPolicy, - - Statusbar, - statusbarGetContextId, - statusbarNew, - statusbarPop, - statusbarPush, - - VBox, - vBoxNew, - - WidgetClass, - - widgetAddEvents, - widgetClassPath, - widgetDestroy, - widgetGrabFocus, - widgetSetCanFocus, - widgetSetDoubleBuffered, - widgetSetName, - widgetSetSizeRequest, - widgetShow, - widgetShowAll, - widgetVisible, - - Window, - windowMove, - windowNew, - windowPresent, - windowTitle, - - -- 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/RPanel.hs b/RPanel.hs deleted file mode 100644 --- a/RPanel.hs +++ /dev/null @@ -1,154 +0,0 @@ --- | "Rowed Panel." --- Expandable framed panel with a two-dimensional layout --- (rows of widgets, but not with aligned columns like in a table). - -module RPanel - ( - RPanel, newRPanel, rpanelId, rpanelRoot, rpanelContent - , rpanelAddWidget, rpanelAddWidgets, rpanelNewRow - , rpanelAddRows - ) - -where - -import Control.Monad -import Graphics.UI.Gtk - -import Util - -debugTracing :: Bool -debugTracing = False - -data RPanel - = RPanel { - -- Public - rpId :: String -- ^ text for the expander button - , rpRoot :: Frame -- ^ use the root to add rpanel to a container - , rpContent :: [[String]] -- ^ ids of widgets added, in rows - - -- Widgets that make up the RPanel - , rpFrame :: Frame -- ^ 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 -> Frame -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/SiffML.hs b/SiffML.hs deleted file mode 100644 --- a/SiffML.hs +++ /dev/null @@ -1,396 +0,0 @@ --- | SiffML : Sifflet Markup Language. --- An XML application for storing and retrieving Sifflet programs --- and libraries. - -module SiffML - ( - ToXml(..) - , produceFile - , consumeFile - , Functions(..) - , xmlToFunctions - , testOut -- testing - , xmlToX -- testing - , testIn, testFromFile -- testing - ) - -where - -import Text.XML.HXT.Arrow -import Text.XML.HXT.DOM.FormatXmlTree - -import Expr -import Examples -import Util - -class ToXml a where - toXml :: a -> Producer - --- | A Producer produces XML -type Producer = IOSLA (XIOState ()) XmlTree XmlTree - --- | A Consumer consumes XML -type Consumer a b = IOSLA (XIOState ()) a b - -defaultOptions = [(a_indent, v_yes), (a_validate, v_no)] - -produceStdout :: (ToXml a) => a -> IO () -produceStdout src = produceFile src "-" - -produceFile :: (ToXml a) => a -> FilePath -> IO () -produceFile src path = - let arrow :: Producer - arrow = toXml src - options = defaultOptions - in do - { - putStrLn "" - ; [rc] <- runX (root [] [arrow] >>> - writeDocument options path >>> - getErrStatus) - ; putStrLn (case rc of - 0 -> "Okay" - _ -> "Failed") - - } - -produceXmlTrees :: (ToXml a) => a -> IO [XmlTree] -produceXmlTrees src = - let arrow :: Producer - arrow = toXml src - options = defaultOptions - in do - { - putStrLn "" - ; docs <- runX (root [] [arrow] >>> writeDocument options "-") - ; case docs of - [] -> putStrLn "Failed" - doc : _ -> - print doc - ; return docs - - } - - -consumeFile :: Consumer XmlTree a -> FilePath -> IO [a] -consumeFile fromXml filePath = - let options = defaultOptions - in runX (readDocument options filePath >>> fromXml) - -consumeStdin :: Consumer XmlTree a -> IO [a] -consumeStdin fromXml = consumeFile fromXml "-" - --- | testFromXml :: (ToXml a, Show a) => a -> Consumer XmlTree a -> IO () --- VVV This type generalization (a, a to a, b) is for debugging, undo it later: -testFromXml :: (ToXml a, Show b) => a -> Consumer XmlTree b -> IO () -testFromXml src consumer = do - { - produceFile src "test.xml" - ; results <- runX (readDocument defaultOptions "test.xml" >>> - isElem >>> -- document root - getChildren >>> - consumer) - ; case results of - [] -> putStrLn "Failed" - result : _ -> print result - } - -testToXmlAndBack :: (ToXml a, Show a) => a -> Consumer XmlTree a -> IO () -testToXmlAndBack = testFromXml - --- | Symbols - -instance ToXml Symbol where - toXml = symbolToXml - -symbolToXml :: Symbol -> Producer -symbolToXml (Symbol name) = - selem "symbol" [txt name] - -xmlToSymbol :: Consumer 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 - - --- | Expr - -instance ToXml Expr where - toXml = exprToXml - -exprToXml :: Expr -> Producer -exprToXml expr = - case expr of - EUndefined -> - eelem "undefined" - ESymbol (Symbol name) -> - selem "symbol" [txt name] - -- ** To simplify, collapse 2.5 - -- to 2.5, and similarly with other - -- literal values? - ELit value -> - selem "literal" [toXml value] - EIf e1 e2 e3 -> - selem "if" [toXml e1, toXml e2, toXml e3] - EList xs -> - selem "list" (map toXml xs) - ECall (Symbol name) xs -> - selem "call" - (selem "symbol" [txt name] : - map toXml xs) - -xmlToExpr :: Consumer XmlTree Expr -xmlToExpr = - isElem >>> - ( - (hasName "undefined" >>> constA EUndefined) <+> - (hasName "symbol" >>> getChildren >>> isText >>> getText >>> - arr (ESymbol . Symbol)) <+> - (hasName "literal" >>> getChildren >>> xmlToValue >>> arr ELit) <+> - (hasName "if" >>> listA (getChildren >>> xmlToExpr) >>> - arr (\ [a, b, c] -> EIf a b c)) <+> - (hasName "list" >>> listA (getChildren >>> xmlToExpr) >>> 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)) - ) - -exampleIfExpr = (EIf (ELit (VBool False)) -- (eCall ">" [eInt 32, eInt 61]) - (ELit (VStr "yes")) - (ELit (VStr "no"))) - -exampleListExpr = EList [ELit (VInt 1), ELit (VInt 2), ELit (VInt 3)] - -exampleCallExpr = ECall (Symbol "foo") [ESymbol (Symbol "x"), ELit (VInt 2)] - --- | Values - -instance ToXml Value where - toXml = valueToXml - -valueToXml :: Value -> Producer -valueToXml value = - case value of - VBool b -> - -- or - -- complicate? selem "bool" [txt (show b)] - eelem (show b) - VChar c -> - selem "char" [txt [c]] - VStr s -> - selem "string" [txt s] - VInt i -> - selem "int" [txt (show i)] - VFloat x -> - selem "float" [txt (show x)] - -- *** Are VFun and VList needed??? - VFun f -> - selem "function" [toXml f] - VList vs -> - selem "list" (map toXml vs) - -exampleVList :: Value -exampleVList = VList [VInt 32, VInt 64, VInt 69] - -xmlToValue :: Consumer 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 VStr) <+> - (hasName "int" >>> getChildren >>> isText >>> getText >>> - arr (VInt . read)) -- dangerous? - <+> - (hasName "float" >>> getChildren >>> isText >>> getText >>> - arr (VFloat . 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) - ) - --- | VpTypes - -instance ToXml VpType where - toXml = vpTypeToXml - -vpTypeToXml :: VpType -> Producer -vpTypeToXml vtype = - case vtype of - VpTypeString -> eelem "string-type" - VpTypeChar -> eelem "char-type" - VpTypeNum -> eelem "num-type" - VpTypeBool -> eelem "bool-type" - VpTypeList eltType -> selem "list-type" [vpTypeToXml eltType] - VpTypeVar typeVarName -> selem "type-variable" [txt typeVarName] - -xmlToVpType :: Consumer XmlTree VpType -xmlToVpType = - isElem >>> - ((hasName "string-type" >>> constA VpTypeString) <+> - (hasName "char-type" >>> constA VpTypeChar) <+> - (hasName "num-type" >>> constA VpTypeNum) <+> - (hasName "bool-type" >>> constA VpTypeBool) <+> - (hasName "list-type" >>> getChildren >>> xmlToVpType >>> - arr VpTypeList) <+> - (hasName "type-variable" >>> getChildren >>> - isText >>> getText >>> arr VpTypeVar) - ) - --- | Functions - -instance ToXml Function where - toXml = functionToXml - -functionToXml :: Function -> Producer -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 name = selem "name" [txt name] - rest = - [selem "return-type" [vpTypeToXml retType], - selem "arg-types" (map vpTypeToXml argTypes), - selem "arg-names" (map name argNames), - selem "body" [toXml body]] - in case mName of - Nothing -> rest - Just fName -> name fName : rest - ) - -xmlToFunction :: Consumer XmlTree Function -xmlToFunction = - let getChildElem :: Consumer XmlTree XmlTree - getChildElem = getChildren >>> isElem - - getFuncName :: Consumer XmlTree String - getFuncName = hasName "name" >>> getChildren >>> isText >>> getText - - getReturnType :: Consumer XmlTree VpType - getReturnType = hasName "return-type" >>> getChildren >>> xmlToVpType - - getArgTypes :: Consumer XmlTree [VpType] - getArgTypes = hasName "arg-types" >>> - listA (getChildren >>> xmlToVpType) - - getArgNames :: Consumer XmlTree [String] - getArgNames = hasName "arg-names" >>> - listA (getChildElem >>> getFuncName) - - getBody :: Consumer 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))) - -exampleFunction = - let esym = ESymbol . Symbol - in Function (Just "cincr") - [VpTypeBool, VpTypeNum, VpTypeNum] - VpTypeNum - (Compound ["incr", "a", "b"] - (EIf (esym "incr") - (ECall (Symbol "+") [esym "a", esym "b"]) - (esym "a"))) - --- | A collection of functions, to be saved or read from a file - -data Functions = Functions [Function] - deriving (Eq, Show) - -functionsToXml :: Functions -> Producer -functionsToXml (Functions fs) = - selem "functions" (map toXml fs) - -xmlToFunctions :: Consumer XmlTree Functions -xmlToFunctions = - isElem >>> -- document root - getChildren >>> - hasName "functions" >>> - listA (getChildren >>> xmlToFunction) >>> - arr Functions - - --- | This is for testing, when I don't know the type --- of the result I'm getting -xmlToX :: Consumer XmlTree Functions -- [Function] -- XmlTree -xmlToX = - isElem -- document root - >>> - getChildren - >>> - hasName "functions" - >>> - listA (getChildren >>> xmlToFunction) - >>> - arr Functions - -instance ToXml Functions where - toXml = functionsToXml - --- | Tests - -testOut :: IO () -testOut = - produceStdout (Functions [exampleFunctions !! 0, exampleFunctions !! 1]) - - -testFromFile :: (Show a) => Consumer XmlTree a -> FilePath -> IO () -testFromFile fromXml filePath = do - { - results <- consumeFile fromXml filePath - ; putStrLn "" - ; print (length results) - ; print results - ; putStrLn "" - } - -testIn :: (Show a) => Consumer XmlTree a -> IO () -testIn fromXml = testFromFile fromXml "-" diff --git a/Tree.hs b/Tree.hs deleted file mode 100644 --- a/Tree.hs +++ /dev/null @@ -1,102 +0,0 @@ --- Tree.hs --- General (not binary) trees - -module 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 - --- 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. --} - --- 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 extra values, if any, provide auxiliary information, --- such as the value of x. --- reprs x is a reduction of reprl x to a single String. --- --- Minimal complete implementation: define repr, or define reprl. - -class Repr a where - - repr :: a -> String - repr = head . reprl - - reprl :: a -> [String] - reprl x = [repr x] - - reprs :: a -> String - reprs = unwords . reprl - -instance Repr Int where repr = show -instance Repr Integer 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? - -data Name = Name String - deriving (Eq, Read, Show) - -instance Repr Name where - repr (Name s) = s - -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/TreeGraph.hs b/TreeGraph.hs deleted file mode 100644 --- a/TreeGraph.hs +++ /dev/null @@ -1,417 +0,0 @@ -module 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, - - -- Tree graph rendering - graphQuickView, - graphWriteImageFile, graphRender, treeRender, - treeWriteImageFile, gtkShowTree - ) - -where - -import IO -import Data.IORef -import Data.List (sort, sortBy) -import System.Cmd - -import Data.Graph.Inductive as G - -import LittleGtk -import Graphics.UI.Gtk.Gdk.EventM - -import Graphics.Rendering.Cairo hiding (translate) - -import Geometry -import Tree as T -import TreeLayout -import Expr -import Util -import Workspace.Functoid -import Workspace.WGraph - -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} -> - let roots = suc graph frameNode - expr = treeToExpr $ graphToExprTree graph (head roots) - impl = Compound args expr - in - -- Check whether the frame contains a single tree - if length roots /= 1 - then Fail "The graph structure is not a tree!" - else case decideTypes expr args env of - Left errmsg -> Fail errmsg - Right (atypes, rtype) -> - Succ (Function (Just name) atypes rtype impl) - - -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) - - - --- ============================================================ --- GRAPH VIEWING AND RENDERING --- ============================================================ - --- Quick view of a graph using GraphViz - -graphQuickView :: (Graph g, Show a, Show b) => g a b -> IO () -graphQuickView g = - let dot_src = graphviz g "graphQuickView" (6, 4) (1, 1) Portrait - dot_file = "tmp.dot" - png_file = "tmp.png" - in do - h <- openFile dot_file WriteMode - hPutStr h dot_src - hClose h - _ <- system ("dot -Tpng -o" ++ png_file ++ " " ++ dot_file) - _ <- system ("feh " ++ png_file) - return () - - -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 kname of - "q" -> liftIO $ widgetDestroy window -- implies mainQuit - _ -> stopEvent - } diff --git a/TreeLayout.hs b/TreeLayout.hs deleted file mode 100644 --- a/TreeLayout.hs +++ /dev/null @@ -1,854 +0,0 @@ -module TreeLayout - (VColor(..), white, cream, black, lightBlue, lightBlueGreen, - lightGray, mediumGray, darkGray, - yellow, darkBlueGreen, blueGreen, - Style(..), VFont(..), defaultStyle, style0, style1, style2, style3, - wstyle, - styleIncreasePadding, - FontTextExtents(..), setFont, ftExtents, - TextBox(..), makeTextBox, tbWidth, tbHeight, tbBottom, drawTextBox, - tbCenter, tbTextCenter, tbBoxCenter, offsetTextBoxCenters, - tbSetWidth, - setColor, - 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, - Draw(..), DrawMode(..), modeTextCol, modeEdgeCol, modeFillCol, - drawBox, - treeLayoutWiden - ) -where - -import System.IO.Unsafe - -import Graphics.Rendering.Cairo hiding (translate) -import Graphics.UI.Gtk (Rectangle) -import Control.Monad (when) -import Data.Traversable () -- imports only instance declarations - -import Geometry -import Tree as T hiding (tree) -import Util - -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) - --- 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) - --- UNUSED --- -- | measureText is not used; should it be? - --- measureText :: Style -> String -> Size --- measureText style str = extentsSize (styleTextExtents style str) - --- -- | extentsSize: unused; should it be? --- extentsSize :: FontTextExtents -> Size --- extentsSize ftExts = Size (textXadvance ftExts) (fontHeight ftExts) - - -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 - margin = textMargin style - textW = textXadvance extents - textH = fontHeight extents + fontDescent extents - - 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} - - -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] - --- 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] - -data Iolet = Iolet Circle - -- | other shapes could be added - deriving (Eq, Read, Show) - -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 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 - ... --} - --- 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 -> Position -> Tree e -> Tree (GNode e) -> Tree Size -> TreeLayout e - -treeLayout2 style - (Position startX startY) -- top left after padding - (T.Node _root subtrees) -- the tree being laid out - -- ^^ actually we don't need the tree as an argument; - -- it's implied by the GNode tree - (T.Node gnode subGNodes) -- "node sizes" - (T.Node (Size treeWidth treeHeight) subTreeSizes) -- tree Sizes - = - 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 - -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 () - translate :: Double -> Double -> a -> a - --- 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 e) => Draw [e] where - draw style mode = mapM_ (draw style mode) - translate dx dy = map (translate dx dy) - -{- Tree must be an instance of Draw, - in order for translate to work in treeLayoutWiden, - but again, this is a bad combination (draw + translate). --} - -instance (Draw e) => Draw (Tree e) where - draw style mode tree = do - draw style mode (rootLabel tree) - draw style mode (subForest tree) - translate dx dy tree = - T.Node (translate dx dy (rootLabel tree)) - (translate dx dy (subForest tree)) - -instance Draw (LayoutNode e) where - draw style mode (LayoutNode gnode _treeBB) = draw style mode gnode - - translate dx dy (LayoutNode gnode treeBB) = - LayoutNode (translate dx dy gnode) - (translate dx dy treeBB) - -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 - - - 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) - -instance Draw TextBox where - - draw style mode = - drawTextBox (Just (styleFont style)) - (Just (modeFillCol mode style)) - Nothing - (modeTextCol mode style) - - translate dx dy (TextBox text textBB boxBB) = - TextBox text (translate dx dy textBB) (translate dx dy boxBB) - -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)) - translate dx dy (BBox x y w h) = BBox (x + dx) (y + dy) w h - -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 ??? ****** - translate dx dy (Position x y) = Position (x + dx) (y + dy) - -instance Draw Iolet where - draw style mode (Iolet circle) = draw style mode circle - translate dx dy (Iolet circle) = Iolet (translate dx dy 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) - - translate dx dy (Circle center radius) = - Circle (translate dx dy center) radius - -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/UITypes.hs b/UITypes.hs deleted file mode 100644 --- a/UITypes.hs +++ /dev/null @@ -1,292 +0,0 @@ -module UITypes (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(..) - , FunctionEditor(..), fedFunctionName - , VCanvas(..), Selection(..), Dragging(..) - ) - -where - -import Data.Map as Map -import Data.Graph.Inductive as G - -import LittleGtk -import Graphics.UI.Gtk.Gdk.EventM (Modifier(..)) - -import RPanel -import TreeLayout -import Workspace.Frame -import Workspace.WGraph -import Expr -import Geometry -import 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 :: Map String VPToolkit, -- ^ collections of tools - vpuiFilePath :: 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 - } - --- | 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 -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 {wsBox :: VBox, -- ^ container of the rest - wsCanvas :: VCanvas, -- ^ the canvas - wsButtonBar :: HBox, - wsStatusbar :: Statusbar} - -data FunctionEditor = FunctionEditor {fedWindow :: Window, - fedWinTitle :: String, - fedFunction :: Function, - fedCanvas :: VCanvas - -- , fedUIRef :: IORef VPUI - } - -fedFunctionName :: FunctionEditor -> String -fedFunctionName = functionName . fedFunction - --- | 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/Util.hs b/Util.hs deleted file mode 100644 --- a/Util.hs +++ /dev/null @@ -1,136 +0,0 @@ -module 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 -import Data.List - --- SuccFail: the result of an attempt, succeeds or fails -data SuccFail a = Succ a -- value - | Fail String -- error message - deriving (Eq, Read, Show) - -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 (unwores). -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/WindowManagement.hs b/WindowManagement.hs deleted file mode 100644 --- a/WindowManagement.hs +++ /dev/null @@ -1,1070 +0,0 @@ -module WindowManagement - ( - -- Window utilities - showWindow - , newWindowTitled - - , showWorkWin - , showWorkspaceWindow - - , showFedWin - , fedWindowTitle - - , showFunctionPadWindow - , newFunctionDialog - - , setWSCanvasCallbacks - , keyBindingsHelpText - ) - -where - -import Control.Monad -import Control.Monad.Trans (liftIO) -- for use in EventM -import Data.IORef -import Data.List -import Data.Map as Map (fromList, lookup) -import Data.Map (Map) -import Data.Maybe - -import Data.Graph.Inductive as G - -import LittleGtk -import Graphics.UI.Gtk.Gdk.EventM - -import CBMgr -import Expr -import Geometry -import GtkForeign as XCursor -import GtkUtil -import RPanel -import SiffML -import UITypes -import Util -import Workspace - --- --------------------------------------------------------------------- --- | 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 = 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 - -- when window is destroyed, remove it from the map - ; uimgr (OnWindowDestroy window - (\ uiref -> - modifyIORef uiref (vpuiRemoveVPUIWindow winId))) - ; return (vpui', vwin, True) - } - Just vw -> - return (vpui, vw, False) - ; when isNew (initCB vpui' winId uimgr) -- add callbacks on new window - ; windowPresent (vpuiWindowWindow vw) - ; return (vpui', vw, isNew) - } - --- | 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 := wsBox ws] - - ; 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 "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 - -- ** Can this use vpuiAddFrame? - ; 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 - ; addArgToolButtons cbmgr winId (functionArgNames function) vpui' - ; addApplyCloseButtons 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 - -showFunctionPadWindow :: CBMgr -> VPUI -> IO VPUI -showFunctionPadWindow cbmgr vpui = - let initWindow _vpui window = do - { - -- widgetSetName window "SiffletFunctionPadWindow" - ; vbox <- vBoxNew False 0 -- non-homogenous, 0 padding - ; set window [containerChild := vbox] - - ; let rpnames = ["Base", "Examples", "My Functions"] - ; rps <- mapM (makeFunctionPadPanel cbmgr) rpnames - ; mapM_ (\ rp -> boxPackStart vbox (rpanelRoot rp) PackNatural 0) - rps - - ; windowMove window 5 5 - ; widgetShowAll window -- redundant? - ; windowPresent window -- redundant? - - ; return $ FunctionPadWindow window (zip rpnames rps) - -- ^^ maybe need reference only the "My Functions" panel though - } - in do - { - (vpui', _, windowIsNew) <- - showWindow functionPadWinId cbmgr initWindow initCBDefault 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 -> String -> IO RPanel -makeFunctionPadPanel cbmgr name = - let VPToolkit _ width toolrows = - case Map.lookup name defaultVPUIToolkits 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 - ((flip 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 vpui = checkForChanges vpui "quit" False vpuiQuit - --- | Open a file (load its function definitions) - -menuFileOpen :: CBMgr -> VPUI -> IO VPUI -menuFileOpen cbmgr vpui = - checkForChanges vpui "open file" 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. --- 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 :: VPUI -> String -> Bool -> (VPUI -> IO VPUI) -> IO VPUI -checkForChanges vpui beforeOperation acknowledge continue = - let mAckIfSaved vpui' = - when (not (vpuiFileChanged vpui') && acknowledge) - ( - showInfoMessage "Changes saved" - ("Your changes are now saved; " ++ - "proceeding to " ++ - beforeOperation ++ ".") - ) - >> - return vpui' - labels = ["Save them", - "Throw them away", - "Cancel " ++ beforeOperation] - 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 - - 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 -> - 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'' <- - showFunctionPadWindow cbmgr vpui' >>= - updateFunctionPadIO title updatePad - ; return $ vpui'' {vpuiFilePath = mpath, - vpuiFileEnv = vpuiGlobalEnv vpui' - } - } - } - -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 - result <- runDialogM (toDialog chooser) chooser fileChooserGetFilename - return result - -loadFile :: VPUI -> FilePath -> IO (SuccFail (VPUI, [Function])) -loadFile vpui filePath = do - { - functions <- consumeFile 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'} - -menuFileSave :: VPUI -> IO VPUI -menuFileSave vpui = - case vpuiFilePath vpui of - Nothing -> menuFileSaveAs vpui - Just filePath -> saveFile vpui filePath - -menuFileSaveAs :: VPUI -> IO VPUI -menuFileSaveAs vpui = do - mpath <- showDialogFileSaveAs vpui - case mpath of - Nothing -> return vpui -- canceled - Just filePath -> saveFile vpui filePath - -showDialogFileSaveAs :: VPUI -> IO (Maybe FilePath) -showDialogFileSaveAs _vpui = do - chooser <- fileChooserDialogNew - (Just "Save file as ...") -- title - Nothing -- transient parent of the dialog - FileChooserActionSave - [("Save", ResponseOk), ("Cancel", ResponseCancel)] -- buttons - result <- runDialogM (toDialog chooser) chooser fileChooserGetFilename - print ("dialog result", result) - return result - --- | Returns the updated VPUI with updated fields --- vpuiFilePath and vpuiFileEnv - --- What about IO errors? ****** - -saveFile :: VPUI -> FilePath -> IO VPUI -saveFile vpui filePath = - let functions = Functions (map (valueFunction . snd) - (vpuiUserEnvAList vpui)) - in produceFile functions filePath >> - return vpui {vpuiFilePath = Just filePath, - vpuiFileEnv = vpuiGlobalEnv 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 " ++ siffletVersionString, - "Copyright (C) 2010 Gregory D. Weber", - "", - "BSD3 License", - "", - "Sifflet home page:", - "http://mypage.iu.edu/~gdweber/software/sifflet/" - ] - --- | The software version number. --- See ACTION: RELEASE CHECKLIST for a list of --- places where this version number needs to be synchronized. -siffletVersionString :: String -siffletVersionString = "0.1.7" - -showAboutDialog :: MenuItemAction -showAboutDialog vpui = showInfoMessage "About Sifflet" aboutText >> return vpui - --- ---------------------------------------------------------------------- - --- Moved here 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 (OnWindowKeyPress 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 - { - clipbox <- eventArea - ; liftIO (readIORef uiref >>= handleExposed winId clipbox) - } - --- | Handle the Exposed event, should be called only for a window --- with a canvas -handleExposed :: WinId -> Rectangle -> VPUI -> IO () -handleExposed winId clipbox 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 clipbox - -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 String KeyBinding -keyBindingsMap = Map.fromList [(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 uiref (f0 cbmgr) - KeyActionST f1 -> - -- update with IO and window ID - modifyIORefIO uiref (f1 winId) - KeyActionDG f2 -> - -- update with IO and cbmgr to set further callbacks - modifyIORefIO uiref (f2 winId cbmgr) - 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 - ; liftIO - (modifyIORefIO uiref - (handleButtonPress winId cbmgr mouseButton x y mods timestamp)) - } - -mouseMoveCallback :: WinId -> IORef VPUI -> EventM EMotion Bool -mouseMoveCallback winId uiref = - tryEvent $ do - { - (x, y) <- eventCoordinates - ; mods <- eventModifier - ; liftIO (modifyIORefIO uiref (handleMouseMove winId x y mods)) - } - -buttonReleaseCallback :: WinId -> IORef VPUI -> EventM EButton Bool -buttonReleaseCallback winId uiref = - tryEvent $ do - { - mouseButton <- eventButton - ; liftIO (modifyIORefIO uiref (handleButtonRelease winId mouseButton)) - } - --- | 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 -> - offerContextMenu winId cbmgr frame RightButton timestamp >> - 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 XCursor.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 XCursor.LeftPtr >> - return vpui' - _ -> return vpui - --- | Show a context menu for mouse click in a frame. -offerContextMenu :: WinId -> CBMgr -> CanvFrame - -> MouseButton -> TimeStamp -> IO () -offerContextMenu winId cbmgr frame button timestamp = do - -- Needs CBMgr to specify menu actions. - { - let menuSpec = - MenuSpec "Context Menu" (contextMenuOptions winId cbmgr frame) - ; 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 -> [MenuItemSpec] -contextMenuOptions winId cbmgr frame = - 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 ++ - [ --- ("Dump frame (debug)", --- \ vpui -> dumpFrame vpui winId frame >> return vpui) --- , ("Dump graph (debug)", \ vpui -> --- dumpGraph vpui winId >> return vpui) --- , ("--QUIT--", \ vpui -> vpuiQuit vpui >> return vpui) - ] diff --git a/Workspace.hs b/Workspace.hs deleted file mode 100644 --- a/Workspace.hs +++ /dev/null @@ -1,20 +0,0 @@ -{- Workspace.hs implements the graphical workspace of Sifflet -} - -module Workspace - ( - module Workspace.Canvas - , module Workspace.Frame - , module Workspace.Functoid - , module Workspace.Tools - , module Workspace.WGraph - , module Workspace.Workspace - ) - -where - -import Workspace.Canvas -import Workspace.Frame -import Workspace.Tools -import Workspace.Functoid -import Workspace.WGraph -import Workspace.Workspace diff --git a/Workspace/Canvas.hs b/Workspace/Canvas.hs deleted file mode 100644 --- a/Workspace/Canvas.hs +++ /dev/null @@ -1,980 +0,0 @@ --- File: Canvas.hs --- Canvas and CanvFrame data and operations - -module Workspace.Canvas - ( - VCanvas(..), Selection(..), Dragging(..) - , atLeastSize - , cfContext - , connect - , disconnect - , drawCanvas - , editFunction - , frameChanged - , nodeContainerFrame - , pointSelection - , vcAddFrame - , vcClearSelection - , vcClearFrame - , vcCloseFrame - , vcEvalDialog - , vcFrameAddFunctoidNode - , vcFrameAddNode - , vcFrameDeleteNode - , vcFrameDeleteTree - , vcFrameSubframes - , vcGetFrame - , vcInvalidateFrameWithParent - , vcInvalidateBox - , vcUpdateFrameAndGraph - , vcanvasNew - , vcanvasNodeAt - , vcanvasNodeRect - , whichFrame - , callFrames - ) - -where - -import Control.Monad -import Data.List as List - -import Data.Graph.Inductive as G -import LittleGtk -import Graphics.Rendering.Cairo hiding (translate) - -import Expr -import Geometry -import GtkUtil -import Tree as T -import TreeGraph -import TreeLayout -import UITypes -import Workspace.Frame -import Workspace.Functoid -import Workspace.WGraph -import 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) = - errcats ["loopWithInlets: insufficient inlets, with these", - "outs remaining:", show (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) - - -graphRenderNode :: - Style -> Maybe Node -> Maybe Selection -> WGraph -> - G.Node -> Maybe Iolet -> Render ([Iolet], [(G.Node, WEdge)]) --- 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 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 - defaultInlet = Iolet (Geometry.Circle - (Position xcenter (bbBottom nodeBB)) 0) - inlets = - case gnodeInlets (nodeGNode lnode) of - [] -> replicate (length outs) defaultInlet - is -> is - - -- 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] - - in if length inlets < length outs' - then errcats ["graphRenderTree: insufficient inlets:", - show (length inlets, length outs'), - show (inlets, outs')] - else 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 - -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 - --- 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 - (_, hi) = nodeRange graph - frameNode = hi + 1 -- implicit: root = hi + 2 - 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 --- --------------------------------------------------------------------- - -drawCanvas :: VCanvas -> Rectangle -> IO () -drawCanvas canvas clipbox = do - { - -- 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 (Rectangle ix iy iwidth iheight) = do - { - rectangle (fromIntegral ix) (fromIntegral iy) - (fromIntegral iwidth) (fromIntegral iheight) - ; 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 - } - - 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 - } - - 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 - } - - ; drawWin <- layoutGetDrawWindow (vcLayout canvas) - ; renderWithDrawable drawWin $ do - { - setClip clipbox - ; drawBackground - -- sorting is a possible bottleneck? - ; (mapM_ renderFrame (sortBy levelOrder frames)) - } - - } - --- | 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 value -> repr value - defaults = map (argDefault (cfEnv frame)) varnames - reader :: Reader [String] [Value] - reader inputs = - mapM stringToValue inputs >>= - typeCheck 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 -- was vpui' = ... - - -- remove it from the frames list - let canvas'' = vcDeleteFrame canvas' frame -- was vpui'' = ... - - -- remove it and its edges from the graph - let -- was vcanvas = vpuiCanvas vpui'' - graph = vcGraph canvas'' - (_mcontext, graph') = match (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/Workspace/Frame.hs b/Workspace/Frame.hs deleted file mode 100644 --- a/Workspace/Frame.hs +++ /dev/null @@ -1,306 +0,0 @@ -module Workspace.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 Expr -import Geometry -import Tree -import TreeLayout -import Workspace.Functoid -import Workspace.WGraph -import 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 -> - if length vars /= length values - then error "buildFooterText: mismatched lists" - else [var ++ " = " ++ repr value | - (var, value) <- zip vars values] - in concat (intersperse ", " items) diff --git a/Workspace/Functoid.hs b/Workspace/Functoid.hs deleted file mode 100644 --- a/Workspace/Functoid.hs +++ /dev/null @@ -1,99 +0,0 @@ -module Workspace.Functoid - (Functoid(..) - , functoidName, functoidArgNames, functoidHeader - , FunctoidLayout(..), flayout - , flayoutBBox, flayoutSize, flayoutWidth, flayoutBottom - , flayoutWiden) - -where - -import Data.Graph.Inductive as G - -import Geometry -import Expr -import TreeLayout - --- | 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 - exprTree = case mvalues of - Nothing -> exprToTree expr - Just _values -> evalTree (exprToTree expr) env - tlo = treeLayout style (exprNodeIoletCounter env) 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 Draw FunctoidLayout where - - draw style mode (FLayoutTree t) = draw style mode t - draw style mode (FLayoutForest f _) = draw style mode f - - translate dx dy (FLayoutTree t) = FLayoutTree (translate dx dy t) - translate dx dy (FLayoutForest f b) = - FLayoutForest (translate dx dy f) (translate dx dy b) diff --git a/Workspace/Tools.hs b/Workspace/Tools.hs deleted file mode 100644 --- a/Workspace/Tools.hs +++ /dev/null @@ -1,552 +0,0 @@ -module Workspace.Tools - ( - ToolId(..) - , Tool(..), ToolContext(..) - , checkMods - , functionTool - , functionToolsFromLists - , makeConnectTool - , makeCopyTool - , makeDeleteTool - , makeDisconnectTool - , makeFixedArgTool - , 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 LittleGtk -import Graphics.UI.Gtk.Gdk.EventM - -import CBMgr -import Expr -import Geometry -import Tree (putTree, repr) -import TreeGraph (graphToOrderedTreeFrom) - -import UITypes -import Util -import Workspace.Canvas -import Workspace.Frame -import Workspace.Functoid -import Workspace.WGraph - - -data ToolId - = ToolConnect - | ToolDisconnect - | ToolIf - | ToolMove - | ToolDelete - | ToolFunction String -- ^ function name - | ToolLiteral Expr - | ToolArg String -- ^ argument name - deriving (Eq, Show) - --- 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 expr -> makeFixedLiteralTool expr - ToolArg argname -> makeFixedArgTool argname - - -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 - -makeFixedLiteralTool :: Expr -> Tool -makeFixedLiteralTool expr = - case expr of - ELit literal -> - let node = ENode (NLit literal) EvalUntried - addLitNode vw toolContext _mods x y = - case toolContext of - TCEditFrame frame -> - vcFrameAddNode vw frame node [] x y - _ -> - return vw -- Nothing - in Tool ("Literal: " ++ repr literal) return (toToolOpVW addLitNode) - _ -> - errcats ["makeFixedLiteralTool: non-literal expression", show expr] - -makeFixedArgTool :: String -> Tool -makeFixedArgTool label = - let node = ENode (NSymbol (Symbol label)) EvalUntried - addArgNode vw toolContext _mods x y = - case toolContext of - TCEditFrame frame -> - vcFrameAddNode vw frame node [] x y - _ -> - return vw -- no effect - in Tool ("Argument: " ++ label) 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 - stringToLiteral -- 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 - --- 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 - { - ; vbox <- vBoxNew False 5 - ; evtBox <- eventBoxNew -- needed for Label visibility - ; label <- labelNew (Just prompt) - ; entry <- entryNew - ; case mcompletions of - Nothing -> return () - Just comps -> addEntryCompletions entry comps - - -- Organize as (vbox (eventbox (label), entry)) - ; containerAdd evtBox label - ; boxPackStartDefaults vbox evtBox - ; boxPackStartDefaults vbox entry - ; layoutPut layout vbox (round xx) (round yy) - ; widgetShowAll vbox - - -- 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 vbox entry) - ; uimgr (OnEntryActivate entry - (entryActivated vbox 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 value -> - grabRemove entry >> - widgetDestroy container >> - readIORef uiref >>= - vpuiSetTool (toolType value) 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) - - -- 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 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 = print . 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 - ; 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/Workspace/WGraph.hs b/Workspace/WGraph.hs deleted file mode 100644 --- a/Workspace/WGraph.hs +++ /dev/null @@ -1,409 +0,0 @@ -module Workspace.WGraph - (WNode(..), WEdge(..), WGraph, wgraphNew, grInsertNode, grRemoveNode - , connectToFrame - , grConnect, grDisconnect - , grAddGraph - , grExtractExprTree, grExtractLayoutNode, grExtractLayoutTree - - , wlab, llab, nodeExprNode, nodeText, nodeValue - , nodeBBox, nodePosition, nodeInputValues - , nodeAllChildren, nodeSimpleChildren, nodeFrameChildren - , nodeAllSimpleDescendants, nodeProperSimpleDescendants - , nodeIsSimple, nodeIsOpen, nodeContainerFrameNode - , nodeParent - - , grUpdateFLayout, grUpdateTreeLayout - , translateNodes - , translateNode, grRelabelNode - , translateTree - , functoidParts, functionToParts - ) - -where - -import Data.List (sort) -import Data.Maybe (fromJust) - -import Data.Graph.Inductive as G - -import Geometry -import TreeLayout -import Expr -import Tree as T -- exports Data.Tree.Tree(Node), etc. -import Workspace.Functoid -import 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 - -data 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 - --- | 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 (_, hi) = nodeRange graph - newNode = succ hi - 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'') - -edgeNotEqual :: WEdge -> (WEdge, G.Node) -> Bool -edgeNotEqual edge pair = edge /= fst pair - -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 = - 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 - --- | 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) - -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} diff --git a/Workspace/Workspace.hs b/Workspace/Workspace.hs deleted file mode 100644 --- a/Workspace/Workspace.hs +++ /dev/null @@ -1,409 +0,0 @@ -{- 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 Workspace.Workspace - ( - -- VPUI and Workspace - vpuiNew - , defaultVPUIToolkits - , Workspace(..), workspaceNewDefault, workspaceNewEditing - , addArgToolButtons - , addApplyCloseButtons - , defineFunction - , openNode - - -- Quitting: - , removeWindow - , vpuiQuit - - -- Windows: - , forallWindowsIO - ) - -where - -import Control.Monad - -import Data.Map (Map, (!), fromList, keys) -import qualified Data.Map as Map (empty) - -import Data.Graph.Inductive as G -import LittleGtk - -import CBMgr -import Examples -import Expr -import Geometry -import GtkUtil -import TreeGraph -import TreeLayout -import UITypes -import Util -import Workspace.Canvas -import Workspace.Frame -import Workspace.Functoid -import Workspace.Tools -import Workspace.WGraph - --- | 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 -> IO VPUI -vpuiNew style env = - return VPUI {vpuiWindows = Map.empty, - vpuiToolkits = Map.empty, - vpuiFilePath = Nothing, - vpuiStyle = style, - vpuiInitialEnv = env, - vpuiGlobalEnv = env, - vpuiFileEnv = env - } - -baseFunctionsRows :: [[String]] -baseFunctionsRows = [["+", "-", "*", "div", "mod", "add1", "sub1", "/"], - ["==", "/=", "<", ">", "<=", ">="], - ["zero?", "positive?", "negative?"], - ["null", "head", "tail", ":"]] - -defaultVPUIToolkits :: Map String VPToolkit -defaultVPUIToolkits = - 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 fromList (zip (map toolkitName toolkits) toolkits) - - --- | 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 - addNoMenu _ = return () - ; workspaceNew style canvSize mViewSize addNoMenu - } - -addArgToolButtons :: CBMgr -> WinId -> [String] -> VPUI -> IO () -addArgToolButtons cbmgr winId labels vpui = - case vpuiGetWindow vpui winId of - VPUIWorkWin ws _ -> - let bbar = wsButtonBar ws - in mapM_ (addArgToolButton cbmgr winId bbar) labels - _ -> return () - -addArgToolButton :: CBMgr -> WinId -> HBox -> String -> IO () -addArgToolButton cbmgr winId buttonBox label = do - { - button <- buttonNewWithLabel label - ; boxPackStart buttonBox button PackNatural 3 -- spacing between buttons - ; widgetShow button - ; cbmgr (AfterButtonClicked button - (\ uiref -> - modifyIORefIO uiref (vpuiSetTool (ToolArg label) winId))) - ; return () - } - --- | Add "Apply" and "Close" buttons to a function-editor window -addApplyCloseButtons :: CBMgr -> WinId -> VPUI -> IO () -addApplyCloseButtons cbmgr winId vpui = - case vpuiGetWindow vpui winId of - VPUIWorkWin ws window -> - addApplyCloseButtons2 cbmgr winId ws window - _ -> return () - -addApplyCloseButtons2 :: CBMgr -> WinId -> Workspace -> Window -> IO () -addApplyCloseButtons2 cbmgr winId ws window = - let bbar = wsButtonBar ws - applyFrame :: VPUI -> IO VPUI - applyFrame vpui = - case vcFrames (vpuiWindowGetCanvas (vpuiGetWindow vpui winId)) of - [frame] -> defineFunction winId frame vpui - _ -> info "ApplyFrame: no unique frame found" >> return vpui - -- addButton :: String -> (IORef VPUI -> IO ()) - addButton label action = do - { - button <- buttonNewWithLabel label - ; boxPackEnd bbar button PackNatural 3 - ; widgetShow button - ; cbmgr (AfterButtonClicked button action) - } - in addButton "Close" (\ _uiref -> widgetDestroy window) >> - addButton "Apply" (\ uiref -> modifyIORefIO uiref applyFrame) - --- | 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 = - let (frame, _) = - frameNewWithLayout style (Position 0 0) 0 - (FunctoidFunc func) Nothing - CallFrame -- mode may change below - 0 prevEnv Nothing - in frame - - --- | 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 -> (VBox -> IO ()) -> IO Workspace -workspaceNew style canvSize mViewSize 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 -} - - -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 - in case functoidToFunction fparts graph frameNode env of - Fail errmsg -> - showErrorMessage 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 - } - --- | 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 = - let winId = "Sifflet Workspace" - in case vpuiTryGetWindow vpui winId 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 winId 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 diff --git a/sifflet.cabal b/sifflet.cabal --- a/sifflet.cabal +++ b/sifflet.cabal @@ -1,5 +1,5 @@ name: sifflet -version: 0.1.7 +version: 1.0 cabal-version: >= 1.6 build-type: Simple license: BSD3 @@ -9,7 +9,7 @@ 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 +stability: Experimental. synopsis: A simple, visual, functional programming language. description: Sifflet is a visual, functional programming language. Sifflet users can make programs by drawing diagrams @@ -25,35 +25,37 @@ -- data-dir: directory -- extra-tmp-files: filename list -extra-source-files: CBMgr.hs Examples.hs Expr.hs Geometry.hs GtkForeign.hs - GtkUtil.hs LittleGtk.hs - RPanel.hs SiffML.hs Tree.hs TreeGraph.hs TreeLayout.hs - UITypes.hs Util.hs WindowManagement.hs Workspace.hs - Workspace/Canvas.hs Workspace/Frame.hs - Workspace/Functoid.hs Workspace/Tools.hs Workspace/WGraph.hs - Workspace/Workspace.hs - README +extra-source-files: README +flag no-link + description: Inhibit linking; just compile. + default: False + executable sifflet main-is: sifflet.hs build-depends: - base >= 4.0.0.0 && < 5, --- begin GTK stuff, should have same version numbers - cairo >= 0.10.0 && < 0.12.0, - glib >= 0.10.0 && < 0.12.0, - gtk >= 0.10.0 && < 0.12.0, --- end - containers >= 0.2 && < 1.0, - fgl >= 5.4 && < 5.4.2.3, - haskell98, - haskell-src >= 1.0 && < 2.0, - hxt >= 8.3 && < 9, - mtl >= 1.1 && < 2.0, - process >= 1.0 && < 2.0 + base >= 4.0 && < 4.3, + -- begin GTK stuff, should have same version numbers + cairo == 0.11.0, + glib == 0.11.0, + gtk == 0.11.0, + -- end + containers >= 0.2 && < 0.4, + fgl >= 5.4 && < 5.5, + haskell98 >= 1.0.1 && < 1.0.2, + haskell-src >= 1.0.1 && < 1.0.2, + hxt >= 8.3 && < 8.6, + mtl >= 1.1 && < 1.2, + process >= 1.0 && < 1.1, + -- and of course our very own ... + sifflet-lib == 1.0 + if !os(windows) - build-depends: unix >= 2.3 && < 3.0 + build-depends: unix >= 2.3 && < 2.5 buildable: True extensions: ForeignFunctionInterface CPP ghc-options: -Wall + if flag(no-link) + ghc-options: -c includes: gtk-2.0/gtk/gtk.h, gtk-2.0/gdk/gdk.h extra-libraries: gdk-x11-2.0 gtk-x11-2.0 diff --git a/sifflet.hs b/sifflet.hs --- a/sifflet.hs +++ b/sifflet.hs @@ -2,28 +2,31 @@ import Data.IORef --- external libraries -import LittleGtk - -- hiding (Frame, Function, Style, buttonPressed, fill, lineWidth, - -- disconnect, function) - --- sifflet modules -import CBMgr -import Examples -import Expr -import GtkUtil -import TreeLayout -import WindowManagement -import Workspace -import UITypes - +import Sifflet.Data.TreeLayout +import Sifflet.Examples +import Sifflet.Language.Expr +import Sifflet.UI -- --------------------------------------------------------------------- --- Environment +-- | 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 + +-- | Main function + main :: IO () main = do { @@ -35,7 +38,7 @@ -- create the user interface ; vpui <- vpuiNew wstyle initialEnv - ; let vpui' = vpui {vpuiToolkits = defaultVPUIToolkits} + ; let vpui' = vpui {vpuiToolkits = defaultVPUIToolkitsWithExamples} workId = "Sifflet Workspace" ; uiref <- newIORef vpui' -- Create wome windows