sifflet (empty) → 0.1.5
raw patch · 26 files changed
+8310/−0 lines, 26 filesdep +basedep +cairodep +containerssetup-changed
Dependencies added: base, cairo, containers, fgl, glib, gtk, haskell-src, haskell98, hxt, mtl, process, unix
Files
- CBMgr.hs +141/−0
- Examples.hs +278/−0
- Expr.hs +1032/−0
- Geometry.hs +131/−0
- GtkForeign.hs +260/−0
- GtkUtil.hs +178/−0
- LICENSE +32/−0
- README +36/−0
- RPanel.hs +154/−0
- Setup.hs +3/−0
- SiffML.hs +394/−0
- Tree.hs +97/−0
- TreeGraph.hs +416/−0
- TreeLayout.hs +854/−0
- UITypes.hs +288/−0
- Util.hs +112/−0
- WindowManagement.hs +1020/−0
- Workspace.hs +20/−0
- Workspace/Canvas.hs +979/−0
- Workspace/Frame.hs +304/−0
- Workspace/Functoid.hs +95/−0
- Workspace/Tools.hs +553/−0
- Workspace/WGraph.hs +415/−0
- Workspace/Workspace.hs +412/−0
- sifflet.cabal +56/−0
- sifflet.hs +50/−0
+ CBMgr.hs view
@@ -0,0 +1,141 @@+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
+ Examples.hs view
@@ -0,0 +1,278 @@+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)
+ Expr.hs view
@@ -0,0 +1,1032 @@+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+ _ -> + error $ "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 _ -> + error $ "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 =+ error $ concat ["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]++ _ -> error $ "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 _) = "<primitive function>"+ show (Compound args body) = + concat ["Compound function, args = " ++ show args ++ + "; body = " ++ show body]++instance Read FunctionImpl where+ readsPrec _ _ = error "readsPrec not implemented for FunctionImpl"++instance Repr Function where+ repr (Function mname _ _ _) =+ case mname of+ Nothing -> "<an unnamed function>"+ Just name -> "<function " ++ 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 -> + error ("functionBody: " +++ "no body available for primitive function")+ Compound _args body -> body++instance Eq Function where+ Function Nothing _ _ _ == Function Nothing _ _ _ = + error "Function (==): equality of nameless functions is undecidable"+ Function mname _ _ _ == Function mname' _ _ _ = mname == mname'++-- | 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 -> error ("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++primArgError :: String -> EvalResult+primArgError name = + error $ name ++ ": wrong number of arguments in primitive function"++primNull :: PFun+primNull [VList list] = EvalOk $ VBool (List.null list)+primNull _ = primArgError "primNull"++primHead :: PFun+primHead [VList list] = + case list of+ x : _xs -> EvalOk x+ [] -> EvalError "head: empty list"+primHead _ = primArgError "primHead"++primTail :: PFun+primTail [VList list] = + case list of+ _x : xs -> EvalOk $ VList xs+ [] -> EvalError "tail: empty list"+primTail _ = primArgError "primTail"++primCons :: PFun+primCons [x, VList xs] = EvalOk $ VList (x:xs)+primCons _ = primArgError "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)
+ Geometry.hs view
@@ -0,0 +1,131 @@+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
+ GtkForeign.hs view
@@ -0,0 +1,260 @@+{-# 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 <chris@cm...> - 2007-05-22 07:48+Hi Axel,++Axel Simon <A.Simon@ke...> 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.++#if MIN_VERSION_gtk(0,10,1)+#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)+import Graphics.UI.Gtk++-- 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)
+ GtkUtil.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE CPP #-}++module GtkUtil (suppressScimBridge,+ createDialog, defaultDialogPosition, + runDialogM, runDialogS, + -- runDialogHelper,+ showInputErrorMessage, showErrorMessage, showInfoMessage,+ showMessage,+ EntryDialog, Reader, + createEntryDialog, runEntryDialog,+ addEntryWithLabel+ )++where++#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) +import System.Posix.Env+#endif+import Graphics.UI.Gtk++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++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
+ LICENSE view
@@ -0,0 +1,32 @@+Sifflet License++Copyright (C) 2010 Gregory D. Weber+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++- Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++- Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++- Neither the name of the copyright holder nor the names of its+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README view
@@ -0,0 +1,36 @@+Sifflet -- README -- Sifflet++Rights+------++Copyright (C) 2010 Gregory D. Weber++BSD3 license -- see the file "LICENSE" for details++Installation+------------++1. Configure, either for system-wide installation:++ $ runghc Setup configure++ or for installation in a user directory:+ + $ runghc Setup configure --user --prefix=~/where/to/install/++2. Build and install:++ $ runghc Setup build+ $ runghc Setup install++Documentation+-------------++Please see the Sifflet home page for documentation:++ http://mypage.iu.edu/~gdweber/software/sifflet/++and especially the tutorial:++ http://mypage.iu.edu/~gdweber/software/sifflet/doc/tutorial.html+
+ RPanel.hs view
@@ -0,0 +1,154 @@+-- | "Rowed Panel." +-- Expandable framed panel with a two-dimensional layout+-- (rows of widgets, but not with aligned columns like in a table).++module 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
+ Setup.hs view
@@ -0,0 +1,3 @@+-- Simple setup+import Distribution.Simple+main = defaultMain
+ SiffML.hs view
@@ -0,0 +1,394 @@+-- | 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++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 <literal><float>2.5</float></literal>+ -- to <float>2.5</float>, 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 ->+ -- <True/> or <False/> + -- 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+ error ("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 "-"
+ Tree.hs view
@@ -0,0 +1,97 @@+-- 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)+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 . drawTree . fmap show
+ TreeGraph.hs view
@@ -0,0 +1,416 @@+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 Graphics.UI.Gtk hiding (Function, Style, fill, lineWidth)+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 -> + error $ "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)))+ _ -> error ("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+ }
+ TreeLayout.hs view
@@ -0,0 +1,854 @@+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 = + error $ "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+++
+ UITypes.hs view
@@ -0,0 +1,288 @@+module UITypes (VPUI(..)+ , WinId, VPUIWindow(..)+ , 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 Graphics.UI.Gtk + hiding (Function, Layout, Style, Size)+import qualified Graphics.UI.Gtk as Gtk (Frame, Layout)+import Graphics.UI.Gtk.Gdk.EventM (Modifier(..))++import RPanel+import TreeLayout+import Workspace.Frame+import Workspace.WGraph+import Expr+import Geometry++-- | 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,+ vpuiToolkits :: Map String VPToolkit, -- collections of tools+ -- A phantom button (never shown) to represent the group of all tools:+ vpuiButtonGroup :: RadioToolButton,+ vpuiFilePath :: Maybe FilePath, -- the file opened or to save+ vpuiFileChanged :: Bool, -- has file changed since open/save?+ vpuiStyle :: Style, -- for windows, canvases, editors+ vpuiInitialEnv :: Env, -- initial value of global environment+ vpuiGlobalEnv :: Env -- the global environment+ }++-- | 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 error ("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 :: Gtk.Frame+ , 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 :: Gtk.Layout,+ 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)+
+ Util.hs view
@@ -0,0 +1,112 @@+module Util (+ -- PARSER UTILITIES+ SuccFail(Succ, Fail)+ , parsef, parseInt, parseDouble, parseVerbatim+ -- STRING UTILITIES+ , par+ -- OUTPUT UTILITIES+ , info+ , fake+ , stub++ -- 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) ++ ")"+++info :: (Show t) => t -> IO ()+info = print++fake :: String -> IO ()+fake what = putStrLn $ "Faking " ++ what ++ "..."++stub :: String -> IO ()+stub name = putStrLn $ "Stub for " ++ name++-- 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
+ WindowManagement.hs view
@@ -0,0 +1,1020 @@+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 Graphics.UI.Gtk hiding (Frame, Function, Style, + add, buttonPressed, disconnect,+ fill, function, lineWidth)++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)" vpuiQuit]+ , 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) [] + 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 ->+ error ("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++-- | Open a file (load its function definitions)++menuFileOpen :: CBMgr -> VPUI -> IO VPUI+menuFileOpen 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, + vpuiFileChanged = False}+ }+ }++showDialogFileOpen :: VPUI -> IO (Maybe FilePath)+showDialogFileOpen _vpui = do+ chooser <- fileChooserDialogNew+ Nothing -- 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+ Nothing -- default 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 vpuiFileChanged++-- 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, vpuiFileChanged = False}++-- | 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.+-- How can this be synchronized with darcs and Cabal?+siffletVersionString :: String+siffletVersionString = "0.1.5"++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 ->+ error ("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 -> vpuiQuit 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)+ ]
+ Workspace.hs view
@@ -0,0 +1,20 @@+{- 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
+ Workspace/Canvas.hs view
@@ -0,0 +1,979 @@+-- 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 Graphics.UI.Gtk hiding (Frame, Function, Style, Size, + buttonPressed, fill, function, + lineWidth, disconnect)+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+++-- 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 = error (concat ["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) = + error ("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 error ("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 values = [] if you do not want the frame to be evaluated+-- as a function call.+-- +-- 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 -> [Value] -> FrameType+ -> Env -> Double -> Double -> Double -> Maybe G.Node + -> IO VCanvas+vcAddFrame canvas functoid values 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 values + 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 = do+ let FunctoidFunc function = cfFunctoid frame -- FunctoidParts should not happen+ varnames = cfVarNames frame+ labels = varnames+ 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)+ dialog <- + createEntryDialog "Input Values" labels defaults reader (-1)+ result <- runEntryDialog dialog+ case result of+ Nothing -> return canvas+ Just values -> evalFrame canvas frame values++evalFrame :: VCanvas -> CanvFrame -> [Value] -> IO VCanvas+-- evaluate the frame, having gotten a list of values from the dialog+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) 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)
+ Workspace/Frame.hs view
@@ -0,0 +1,304 @@+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++-- ---------------------------------------------------------------------+-- 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 -> + error ("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 -> [Value] -> FrameType -- added arg+ -> Node -> Env -> Maybe G.Node + -> (CanvFrame, FunctoidLayout) -- reversed tuple+frameNewWithLayout style (Position x y) z + functoid values 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 values+ env = if null values+ -- dummy extension to be popped off+ then extendEnv [] [] prevEnv + else extendEnv vars values prevEnv+ -- body tlo+ layout0 = flayout style functoid env values+ -- 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] -> [Value] -> String+buildFooterText vars values = + concat (intersperse ", "+ (case values of + [] -> vars+ _ -> + if length vars /= length values+ then error ("buildFooterText: " +++ "mismatched lists")+ else [var ++ " = " ++ repr value |+ (var, value) <- zip vars values]+ ))+
+ Workspace/Functoid.hs view
@@ -0,0 +1,95 @@+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++flayout :: Style -> Functoid -> Env -> [Value] -> FunctoidLayout+flayout style functoid env values =+ 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 = if null values+ then exprToTree expr+ else 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)
+ Workspace/Tools.hs view
@@ -0,0 +1,553 @@+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 Graphics.UI.Gtk + hiding (Frame, Function, Style, Size, buttonPressed, fill, lineWidth,+ disconnect)+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)+ _ ->+ error $ "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) []+ 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 -> [Value] -> FrameType+ -> Env -> Double -> Double -> Double -> Maybe G.Node + -> IO VPUI+vpuiAddFrame vpui winId functoid values mode prevEnv x y z mparent = + let update vw = + vwAddFrame vw functoid values 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 -> [Value] -> FrameType + -> Env -> Double -> Double -> Double -> Maybe G.Node + -> IO VPUIWindow+vwAddFrame vw functoid values mode prevEnv x y z mparent = + let modify canvas = vcAddFrame canvas functoid values 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
+ Workspace/WGraph.hs view
@@ -0,0 +1,415 @@+module Workspace.WGraph + (WNode(..), WEdge(..), WGraph, wgraphNew, grInsertNode, grRemoveNode+ , connectToFrame+ , grConnect, grDisconnect+ , grAddGraph+ , grExtractExprTree, grExtractLayoutNode, grExtractLayoutTree+ + , unmaybe -- move to Util?+ , 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.Graph.Inductive as G++import Geometry+import TreeLayout+import Expr+import Tree as T -- exports Data.Tree.Tree(Node), etc.+import Workspace.Functoid++-- | 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 _) = "<frame>"++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 -> error $ "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++-- | unmaybe is the inverse of Maybe, sort of+unmaybe :: Maybe a -> a+unmaybe (Just x) = x+unmaybe Nothing = error "unmaybe: Nothing"++-- | wlab is like lab with no Maybe: the node *must* have a label+wlab :: WGraph -> Node -> WNode+wlab g n = unmaybe (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 ->+ error (concat ["llab: node is not simple\n",+ "node ", (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 =+ error (concat ["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, _) -> + error ("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+ _ -> error ("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, _) ->+ error $ "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 _, _) ->+ error $ "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, _) -> error ("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}
+ Workspace/Workspace.hs view
@@ -0,0 +1,412 @@+{- 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 Graphics.UI.Gtk as Gtk+ hiding (Frame, Function, Style, Size, buttonPressed, fill, lineWidth,+ disconnect, function, remove)++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 = do+ group <- radioToolButtonNew+ return VPUI {vpuiWindows = Map.empty, + vpuiToolkits = Map.empty,+ vpuiButtonGroup = group,+ vpuiFilePath = Nothing,+ vpuiFileChanged = False,+ vpuiStyle = style,+ vpuiInitialEnv = env,+ vpuiGlobalEnv = 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 argValues = []+ funcFrame = fedFuncFrame style func argValues 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 -> [Value] -> Env -> CanvFrame+fedFuncFrame style func values prevEnv = + let (frame, _) =+ frameNewWithLayout style (Position 0 0) 0 + (FunctoidFunc func) values + 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 :: Gtk.Layout -> 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 :: Gtk.Layout -> IO Gtk.Layout+ 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) [] + 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 [] 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) values CallFrame+ env x y z (Just node)+ EvalOk x ->+ error $ "openNode: non-VList result: " ++ show x+ _ -> + info "Cannot be opened: lacking input values" >>+ return vw
+ sifflet.cabal view
@@ -0,0 +1,56 @@+name: sifflet+version: 0.1.5+cabal-version: >= 1.6+build-type: Simple+license: BSD3+license-file: LICENSE+copyright: (C) 2009-2010 Gregory D. Weber+author: Gregory D. Weber+maintainer: "gdweber" ++ drop 3 "abc@" ++ "iue.edu"+bug-reports: mailto:"gdweber" ++ drop 3 "abc@" ++ "iue.edu"+homepage: http://mypage.iu.edu/~gdweber/software/sifflet/+stability: experimental+synopsis: A simple, visual, functional programming language.+description: Sifflet is a visual, functional programming language.+ Sifflet users can make programs by drawing diagrams+ to connect functions and other units.+ Sifflet show the intermediate steps of the computation+ on the diagram, and can expand function calls to show further details.+ It is intended as an aid for learning about recursion.+category: + Language + , Visual Programming+tested-with: GHC == 6.10, GHC == 6.12+-- data-files: filename list+-- data-dir: directory+-- extra-tmp-files: filename list++extra-source-files: CBMgr.hs Examples.hs Expr.hs Geometry.hs GtkForeign.hs + GtkUtil.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++executable sifflet+ main-is: sifflet.hs+ build-depends: + base >= 4.0.0.0 && < 5,+ cairo >= 0.10,+ containers >= 0.2,+ fgl >= 5.4,+ glib >= 0.10,+ gtk >= 0.10,+ haskell98,+ haskell-src >= 1.0,+ hxt >= 8.3 && < 9,+ mtl >= 1.1,+ process >= 1.0+ if !os(windows)+ build-depends: unix >= 2.3+ buildable: True+ extensions: ForeignFunctionInterface CPP+ ghc-options: -Wall+ includes: gtk-2.0/gtk/gtk.h, gtk-2.0/gdk/gdk.h+ extra-libraries: gdk-x11-2.0 gtk-x11-2.0
+ sifflet.hs view
@@ -0,0 +1,50 @@+module Main (main) where++import Data.IORef++-- external libraries+import Graphics.UI.Gtk + 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+++-- ---------------------------------------------------------------------+-- Environment++initialEnv :: Env+initialEnv = exampleEnv++main :: IO ()+main = do+ {+ -- scim-bridge causes many errors, so don't use it+ suppressScimBridge++ -- Initialize GTK+ ; initGUI++ -- create the user interface+ ; vpui <- vpuiNew wstyle initialEnv+ ; let vpui' = vpui {vpuiToolkits = defaultVPUIToolkits}+ workId = "Sifflet Workspace"+ ; uiref <- newIORef vpui'+ -- Create wome windows+ ; let cbmgr = mkCBMgr uiref+ ; vpui'' <- showWorkWin vpui' workId cbmgr+ ; writeIORef uiref vpui''++ ; showFunctionPadWindow cbmgr vpui'' >>= writeIORef uiref+ -- run GTK+ ; mainGUI+ ; return ()+}