sifflet 0.1.7 → 1.0
raw patch · 24 files changed
+46/−8490 lines, 24 filesdep +sifflet-libdep ~basedep ~cairodep ~containers
Dependencies added: sifflet-lib
Dependency ranges changed: base, cairo, containers, fgl, glib, gtk, haskell-src, haskell98, hxt, mtl, process, unix
Files
- CBMgr.hs +0/−141
- Examples.hs +0/−278
- Expr.hs +0/−1059
- Geometry.hs +0/−131
- GtkForeign.hs +0/−269
- GtkUtil.hs +0/−225
- LittleGtk.hs +0/−150
- RPanel.hs +0/−154
- SiffML.hs +0/−396
- Tree.hs +0/−102
- TreeGraph.hs +0/−417
- TreeLayout.hs +0/−854
- UITypes.hs +0/−292
- Util.hs +0/−136
- WindowManagement.hs +0/−1070
- Workspace.hs +0/−20
- Workspace/Canvas.hs +0/−980
- Workspace/Frame.hs +0/−306
- Workspace/Functoid.hs +0/−99
- Workspace/Tools.hs +0/−552
- Workspace/WGraph.hs +0/−409
- Workspace/Workspace.hs +0/−409
- sifflet.cabal +26/−24
- sifflet.hs +20/−17
− CBMgr.hs
@@ -1,141 +0,0 @@-module CBMgr- (- CBMgr, CBMgrCmd(..), mkCBMgr- , MenuSpec(..), MenuItemSpec(..), MenuItemAction- , createMenuBar, addMenu, createMenu, createMenuItem- , modifyIORefIO- ) --where--import Data.IORef--import Graphics.UI.Gtk-import Graphics.UI.Gtk.Gdk.EventM--import UITypes---- | The CBMgr (Callback manager) encapsulates (in an enclosure, no less!)--- an IORef VPUI. It is used *solely* to set up callbacks--- and similar stuff in Gtk, where the callback needs access--- to the IORef. By passing a CBMgr to a function, we can--- avoid passing the IORef directly, and all the harm and--- confusion that could result.------ We only need *one* CBMgr for the application;--- however, two CBMgrs with the same IORef are logically equivalent,--- so there would be no harm in having two as long as they share one IORef.-type CBMgr = CBMgrCmd -> IO ()---- | Commands for the CBMgr-data CBMgrCmd- = -- window events- OnWindowConfigure Window (IORef VPUI -> EventM EConfigure Bool)- | OnWindowDestroy Window (IORef VPUI -> IO ())- | OnWindowKeyPress Window (IORef VPUI -> EventM EKey Bool)- -- layout events- | OnLayoutExpose Layout (IORef VPUI -> EventM EExpose Bool)- | OnLayoutMouseMove Layout (IORef VPUI -> EventM EMotion Bool)- | OnLayoutButtonPress Layout (IORef VPUI -> EventM EButton Bool)- | OnLayoutButtonRelease Layout (IORef VPUI -> EventM EButton Bool)- -- other events- | OnMenuItemActivateLeaf MenuItem (VPUI -> IO VPUI)- | OnEntryActivate Entry (IORef VPUI -> IO ())- | AfterButtonClicked Button (IORef VPUI -> IO ())-- | UMTest---- | Create the CBMgr-mkCBMgr :: IORef VPUI -> CBMgr-mkCBMgr uiref cmd = - case cmd of- -- window events- OnWindowConfigure window action ->- on window configureEvent (action uiref) >> return ()- OnWindowDestroy window action ->- onDestroy window (action uiref) >> return ()- OnWindowKeyPress window action ->- on window keyPressEvent (action uiref) >> return ()- -- layout events- OnLayoutExpose layout action ->- on layout exposeEvent (action uiref) >> return ()- OnLayoutMouseMove layout action ->- on layout motionNotifyEvent (action uiref) >> return ()- OnLayoutButtonPress layout action ->- on layout buttonPressEvent (action uiref) >> return ()- OnLayoutButtonRelease layout action ->- on layout buttonReleaseEvent (action uiref) >> return ()- -- other events- OnMenuItemActivateLeaf menuItem action ->- onActivateLeaf menuItem (modifyIORefIO uiref action) >> return ()- OnEntryActivate entry action ->- onEntryActivate entry (action uiref) >> return ()- AfterButtonClicked button action ->- afterClicked button (action uiref) >> return ()-- UMTest -> - putStrLn "UMTest"----- ============================================================--- MENUS---- Easy creation of menus from lists.--- Originally from ~/src/haskell-etudes/gtk2hs/gMenu.hs--data MenuSpec = MenuSpec String [MenuItemSpec]-data MenuItemSpec = MenuItem String MenuItemAction- | SubMenu MenuSpec--type MenuItemAction = VPUI -> IO VPUI -- was just IO ()--createMenuBar :: [MenuSpec] -> CBMgr -> IO MenuBar-createMenuBar menuSpecs cbmgr = do- bar <- menuBarNew- mapM_ (addMenu bar cbmgr) menuSpecs- return bar--addMenu :: MenuBar -> CBMgr -> MenuSpec -> IO ()-addMenu mbar cbmgr mspec@(MenuSpec name _itemSpecs) = do- menuHead <- menuItemNewWithLabel name -- visible "item" at top of the menu- menuShellAppend mbar menuHead- -- Right-justify help menu.- -- Deprecated (bad for right-to-left languages),- -- but retained for compatibility with menus_hard.py.- menuItemSetRightJustified menuHead (name == "Help") -- ??????-- -- menu = the container for menu items- menu <- createMenu mspec cbmgr- menuItemSetSubmenu menuHead menu--createMenu :: MenuSpec -> CBMgr -> IO Menu-createMenu (MenuSpec _name itemSpecs) cbmgr = do- menu <- menuNew- mapM_ (createMenuItem menu cbmgr) itemSpecs- return menu--createMenuItem :: Menu -> CBMgr -> MenuItemSpec -> IO ()-createMenuItem menu cbmgr mispec = - case mispec of- MenuItem label action ->- do- {- item <- menuItemNewWithLabel label- ; cbmgr (OnMenuItemActivateLeaf item action)- -- *** may need to read/write IORef here ***- ; menuShellAppend menu item- }- SubMenu subspec@(MenuSpec label _itemSpecs) ->- do- {- item <- menuItemNewWithLabel label- ; submenu <- createMenu subspec cbmgr - ; menuItemSetSubmenu item submenu- ; menuShellAppend menu item- }---- | Read an IORef, update with IO, and write the updated value.--- This is like modifyIORef, but the type of the second argument is (a -> IO a)--- instead of (a -> a).-modifyIORefIO :: IORef a -> (a -> IO a) -> IO ()-modifyIORefIO ref updateIO = readIORef ref >>= updateIO >>= writeIORef ref
− Examples.hs
@@ -1,278 +0,0 @@-module Examples (exampleFunctions, exampleFunctionNames, exampleEnv - , eFoo, eMax, eFact -- must these be exported?- )--where---- standard libraries---- extra libraries---- sifflet libraries-import Expr-import Util---- TEST COMPOUND FUNCTIONS---- | grossProfit salesA salesB = 0.12 salesA + 0.25 salesB--grossProfit :: Function-grossProfit = - Function (Just "grossProfit") [VpTypeNum, VpTypeNum] VpTypeNum- (Compound ["salesA", "salesB"]- (eCall "+" [eCall "*" [eFloat 0.12, eSymbol "salesA"],- eCall "*" [eFloat 0.25, eSymbol "salesB"]]))---- | bonus1 profit = if profit > 100000 --- then 1000 + 0.0012 * profit--- else 0-bonus1 :: Function-bonus1 =- Function (Just "bonus1") [VpTypeNum] VpTypeNum- (Compound ["profit"]- (eIf (eCall ">" [eSymbol "profit", eInt 100000])- (eCall "+" [eInt 1000,- eCall "*" [eFloat 0.0012, eSymbol "profit"]])- (eInt 0)))---- | bonus2 salesA salesB = bonus1 (grossProfit salesA salesB)-bonus2 :: Function-bonus2 =- Function (Just "bonus2") [VpTypeNum, VpTypeNum] VpTypeNum- (Compound ["salesA", "salesB"]- (eCall "bonus1" [eCall "grossProfit" [eSymbol "salesA",- eSymbol "salesB"]]))---- foo a b = 2 * a + b-foo :: Function-foo = Function (Just "foo") [VpTypeNum, VpTypeNum] VpTypeNum- (Compound ["a", "b"]- (eCall "+" [eCall "*" [eInt 2, eSymbol "a"],- eSymbol "b"])- )--eFoo :: Expr -> Expr -> Expr-eFoo e1 e2 = eCall "foo" [e1, e2]---- max x y = if x > y then x else y-max :: Function-max = let ex = eSymbol "x"- ey = eSymbol "y"- in Function (Just "max") [VpTypeNum, VpTypeNum] VpTypeNum- (Compound ["x", "y"] (eIf (eGt ex ey) ex ey))--eMax :: Expr -> Expr -> Expr-eMax e1 e2 = eCall "max" [e1, e2]---- fact n = if n == 0 then 1 else n * (fact (n - 1))-fact :: Function-fact = let en = eSymbol "n" in- Function (Just "fact") [VpTypeNum] VpTypeNum- (Compound ["n"] - (eIf (eZerop en) - (eInt 1)- (eTimes en (eFact (eSub1 en)))))--eFact :: Expr -> Expr-eFact e1 = eCall "fact" [e1]---- sum of the integers 0..n--- Lewis and Loftus, Jave Software Solutions, 6th. ed. (they call it "sum")-sumFromZero :: Function-sumFromZero = let en = eSymbol "n" in- Function (Just "sumFromZero") [VpTypeNum] VpTypeNum- (Compound ["n"]- (eIf (eZerop en)- (eInt 0)- (ePlus en (eSumFromZero (eSub1 en)))))--buggySumFromZero :: Function-buggySumFromZero = - let Succ body = stringToExpr "n + buggySumFromZero (n - 1)"- in Function (Just "buggySumFromZero") [VpTypeNum] VpTypeNum - (Compound ["n"] body)--eFib1 :: Expr -> Expr-eFib1 en = eCall "fib1" [en]--fib1 :: Function-fib1 = let en = eSymbol "n"- one = eInt 1- two = eInt 2- in Function (Just "fib1") [VpTypeNum] VpTypeNum- (Compound ["n"]- (eIf (eEq en one)- one- (eIf (eEq en two)- one- (ePlus (eFib1 (eMinus en two))- (eFib1 (eMinus en one))))))---- implying that there should be fib2 ...--eSumFromZero :: Expr -> Expr-eSumFromZero en = eCall "sumFromZero" [en]---- rmul: multiplication by repeated addition.--- The "multiply" function in Hanly and Koffman,--- "Problem Solving and Program Design in C", 5th ed.--eRmul :: Expr -> Expr -> Expr-eRmul em en = eCall "rmul" [em, en]--rmul :: Function-rmul = let em = eSymbol "m"- en = eSymbol "n"- in Function (Just "rmul") [VpTypeNum, VpTypeNum] VpTypeNum- (Compound ["m", "n"]- (eIf (eZerop en)- (eInt 0)- (ePlus em (eRmul em (eSub1 en)))))--eGcd :: Expr -> Expr -> Expr-eGcd em en = eCall "gcd" [em, en]--gcd :: Function-gcd = let em = eSymbol "m"- en = eSymbol "n"- in Function (Just "gcd") [VpTypeNum, VpTypeNum] VpTypeNum- (Compound ["m", "n"]- (eIf (eZerop (eMod em en))- en- (eGcd en (eMod em en))))----- Even and odd, the slow way---- Springer and Friedman, Scheme and the Art of Programming (??)--- Rubio-Sanchez, Urquiza-Fuentes, and Pareja-Flores,--- "A Gentle Introduction to Mutual Recursion",--- in ITiCSE 2008: The 13th SIGCSE Conference on Innovation and--- Technology in Computer Science Education, 2008.--eEvenp, eOddp :: Expr -> Expr-eEvenp en = eCall "even?" [en]-eOddp en = eCall "odd?" [en]--evenp, oddp :: Function--evenp = let en = eSymbol "n"- in Function (Just "even?") [VpTypeNum] VpTypeBool- (Compound ["n"]- (eIf (eZerop en)- eTrue- (eOddp (eSub1 en))))--oddp = let en = eSymbol "n"- in Function (Just "odd?") [VpTypeNum] VpTypeBool- (Compound ["n"]- (eIf (eZerop en)- eFalse- (eEvenp (eSub1 en))))---- Fibonacci series through mutual recursion--- Rubio-Sanchez, Urquiza-Fuentes, and Pareja-Flores, "Gentle Introduction"--eRabbitBabies, eRabbitAdults :: Expr -> Expr-eRabbitBabies en = eCall "rabbitBabies" [en]-eRabbitAdults en = eCall "rabbitAdults" [en]--rabbitTotal, rabbitAdults, rabbitBabies :: Function--rabbitTotal = let m = eSymbol "month"- in Function (Just "rabbitTotal") [VpTypeNum] VpTypeNum- (Compound ["month"]- (ePlus (eRabbitBabies m) (eRabbitAdults m)))--rabbitAdults = let m = eSymbol "month"- zero = eInt 0- one = eInt 1- in Function (Just "rabbitAdults") [VpTypeNum] VpTypeNum - (Compound ["month"]- (eIf (eEq m one)- zero- (ePlus- (eRabbitAdults (eSub1 m)) -- all adults survive- (eRabbitBabies (eSub1 m))))) -- all babies grow up--rabbitBabies = let m = eSymbol "month" - one = eInt 1- in Function (Just "rabbitBabies") [VpTypeNum] VpTypeNum - (Compound ["month"]- (eIf (eEq m one)- one- (eRabbitAdults (eSub1 m)))) -- all adults reproduce- --buggyLength :: Function-buggyLength = let xs = eSymbol "xs"- one = eInt 1- in Function (Just "buggyLength") - [VpTypeList (VpTypeVar "e1")] VpTypeNum- (Compound ["xs"]- (eIf (eCall "null" [xs])- one -- base case off by one, should be zero- (ePlus one - (eCall "buggyLength"- [eCall "tail" [xs]]))))--listLength :: Function-listLength = let xs = eSymbol "xs"- one = eInt 1- zero = eInt 0- in Function (Just "length") - [VpTypeList (VpTypeVar "e1")] VpTypeNum- (Compound ["xs"]- (eIf (eCall "null" [xs])- zero- (ePlus one - (eCall "length"- [eCall "tail" [xs]]))))--listSum :: Function-listSum = - Function (Just "sum") [VpTypeList VpTypeNum] VpTypeNum - (Compound ["xs"] sumbody1)--sumbody1, sumbody2 :: Expr-sumbody1 = let xs = eSymbol "xs"- zero = eInt 0- in eIf (eCall "null" [xs])- zero- (ePlus (eCall "head" [xs])- (eCall "sum" [eCall "tail" [xs]]))--sumbody2 = - let Succ body = - stringToExpr "if null xs then 0 else (head xs) + (sum' (tail xs))"- in body--listSum' :: Function-listSum' = - Function (Just "sum'")- [VpTypeList VpTypeNum] VpTypeNum- (Compound ["xs"] sumbody2)--buggySum :: Function-buggySum = let xs = eSymbol "xs"- in Function (Just "buggySum")- [VpTypeList VpTypeNum] VpTypeNum- (Compound ["xs"]- -- missing "if" and base case- (ePlus (eCall "head" [xs])- (eCall "buggySum" [eCall "tail" [xs]])))--exampleFunctions :: [Function]-exampleFunctions = [grossProfit, bonus1, bonus2,- foo, Examples.max, fact, sumFromZero, rmul, fib1,- Examples.gcd, evenp, oddp,- rabbitBabies, rabbitAdults, rabbitTotal,- buggyLength, listLength, listSum, buggySum,- buggySumFromZero]--exampleFunctionNames :: [String]-exampleFunctionNames = map functionName exampleFunctions--exampleEnv :: Env-exampleEnv = - envInsertL baseEnv exampleFunctionNames (map VFun exampleFunctions)
− Expr.hs
@@ -1,1059 +0,0 @@-module Expr (stringToExpr, exprToValue, stringToValue,- stringToLiteral,- Symbol(..), - Expr(..), eSymbol, eInt, eString, eChar, eFloat,- eBool, eFalse, eTrue, eIf, - eList, eCall,- exprSymbols, exprVarNames,- ExprTree, ExprNode(..), ExprNodeLabel(..), - exprNodeIoletCounter, -- needs work ****** get rid of it???- exprToTree, treeToExpr, exprToReprTree,- EvalResult, EvalRes(EvalOk, EvalError, EvalUntried),- evalTree, unevalTree,- Value(..), valueFunction, - Function(..), functionName, functionNArgs,- functionArgTypes, functionResultType,- functionArgNames, functionBody, functionImplementation,- FunctionDefTuple, functionToDef, functionFromDef,- FunctionImpl(..),- VpType(..), typeCheck, vpTypeOf,- Env, makeEnv, extendEnv, envInsertL, envPop, - envIns, envSet, envGet, - envGetFunction, envLookup, envLookupFunction,- envSymbols, envFunctionSymbols,- eval, apply,- decideTypes, newUndefinedFunction, undefinedTypes,- ePlus, eTimes, eMinus, eDiv, eMod,- eAdd1, eSub1,- eEq, eNe, eGt, eGe, eLt, eLe,- eZerop, ePositivep, eNegativep,- baseEnv)--where---- ****** drop this after debugging:-import System.IO.Unsafe(unsafePerformIO)--import Language.Haskell.Syntax-import Language.Haskell.Parser-{--import Language.Haskell.Pretty--}---import Data.Map as Map hiding (filter, map, null)-import Data.List as List--import Tree as T-import Util--{--testHsParse = do- let (ParseOk (HsModule srcLoc pmod mExports imports decls)) = parseModule "foo x y = x + y"- print $ length decls- print $ decls!!0- putStrLn "Wow, this is complex."--}--stringToExpr :: String -> SuccFail Expr-stringToExpr string =- case parseModule ("x = " ++ string) of- ParseOk (HsModule - _srcLoc -- (SrcLoc ...)- _module -- (Module "Main")- _justMain -- (Just [HsEVar (UnQual (HsIdent "main"))])- _ -- [] - result)- -> - case result of- [HsPatBind _ _ (HsUnGuardedRhs expr) []] -> - hsExpToVp expr- _ -> - errcat ["stringToExpr: unexpected parse result " ++- "from string " ++ show string ++- "; result = " ++ show result]-- ParseFailed _ str -> Fail str -- not very informative--hsExpToVp :: HsExp -> SuccFail Expr-hsExpToVp hsExp = - case hsExp of-- HsVar (UnQual (HsSymbol name)) -> Succ $ eSymbol name -- e.g. "+"- HsVar (UnQual (HsIdent name)) -> Succ $ eSymbol name -- e.g. "head"-- HsLit (HsInt i) -> Succ $ eInt i- HsLit (HsFrac r) -> Succ $ eFloat (fromRational r)- HsLit (HsChar a) -> Succ $ eChar a- HsLit (HsString s) -> Succ $ eString s-- HsCon (UnQual (HsIdent "False")) -> Succ eFalse- HsCon (UnQual (HsIdent "True")) -> Succ eTrue-- HsList items -> - case hsListItemsToVps [] items of- Fail msg -> Fail msg- Succ items' -> Succ (eList items')-- HsNegApp hslit -> hsExpToVp hslit >>= eNegate-- HsApp (HsVar (UnQual (HsIdent name))) hsArg -> - do- arg <- hsExpToVp hsArg- Succ $ eCall name [arg] -- ??? ***- HsApp (HsApp hsApp1 hsArg1) hsArg2 ->- do - call1 <- hsExpToVp (HsApp hsApp1 hsArg1)- arg2 <- hsExpToVp hsArg2- let ECall f args = call1- Succ $ ECall f (args ++ [arg2])- HsInfixApp hsArg1 (HsQVarOp (UnQual (HsSymbol op))) hsArg2 ->- do- arg1 <- hsExpToVp hsArg1- arg2 <- hsExpToVp hsArg2- Succ $ eCall op [arg1, arg2]-- HsIf hsExp1 hsExp2 hsExp3 ->- do- expr1 <- hsExpToVp hsExp1- expr2 <- hsExpToVp hsExp2- expr3 <- hsExpToVp hsExp3- Succ $ eIf expr1 expr2 expr3-- HsParen hsExp1 -> hsExpToVp hsExp1-- _ -> Fail ("hsExpToVp: unknown expression type: " ++ show hsExp)--eNegate :: Expr -> SuccFail Expr-eNegate expr = - case expr of- ELit (VInt i) -> Succ $ ELit (VInt (negate i))- ELit (VFloat x) -> Succ $ ELit (VFloat (negate x))- _ -> Fail $ "eNegate: cannot handle" ++ show expr--hsListItemsToVps :: [Expr] -> [HsExp] -> SuccFail [Expr]-hsListItemsToVps result items =- case items of- [] -> Succ (reverse result)- (x:xs) ->- case hsExpToVp x of- Fail msg -> Fail msg- Succ x' -> hsListItemsToVps (x':result) xs---- Symbols have names, and may or may not have values,--- but the value is stored in an environment, not in the symbol itself.--data Symbol = Symbol String -- symbol name- deriving (Eq, Read, Show)--instance Repr Symbol where repr (Symbol s) = s---- The Haskell representations of V's primitive data types-type OInt = Integer-type OStr = String-type OBool = Bool-type OChar = Char-type OFloat = Double--stringToLiteral :: String -> SuccFail Expr-stringToLiteral s = stringToValue s >>= valueToLiteral- --- | A more highly "parsed" type of expression------ ELit (literals) are "primitive" (self-evaluating) expressions,--- in the sense that if x is a literal, then eval x env = EvalOk x--- for any environment env.--data Expr = EUndefined- | ESymbol Symbol - | ELit Value- | EIf Expr Expr Expr -- if test branch1 branch2- | EList [Expr] -- needed for hsExpToVp case HsList- | ECall Symbol [Expr] -- function name, arglist- -- A function expression other than a symbol will- -- be hard to visualize:- -- | ECall [Expr] -- (function:args) - deriving (Eq, Read, Show)--instance Repr Expr where- repr EUndefined = "*undefined*"- repr (ESymbol s) = repr s- repr (ELit x) = repr x- repr (EIf t a b) = par "if" (map repr [t, a, b])- repr (EList items) = par "EList" (map repr items)- repr (ECall (Symbol fname) args) = par fname (map repr args)--eSymbol :: String -> Expr-eSymbol = ESymbol . Symbol--eInt :: OInt -> Expr-eInt = ELit . VInt--eString :: OStr -> Expr-eString = ELit . VStr--eChar :: OChar -> Expr-eChar = ELit . VChar--eFloat :: OFloat -> Expr-eFloat = ELit . VFloat--eBool :: Bool -> Expr-eBool = ELit . VBool--eFalse, eTrue :: Expr-eFalse = eBool False-eTrue = eBool True--eIf :: Expr -> Expr -> Expr -> Expr-eIf = EIf--eList :: [Expr] -> Expr-eList = EList---- | Example:--- ePlus_2_3 = eCall "+" [eInt 2, eInt 3]-eCall :: String -> [Expr] -> Expr-eCall = ECall . Symbol----- EXPRESSION TREES-type ExprTree = Tree ExprNode-data ExprNode = ENode ExprNodeLabel EvalResult- deriving (Eq, Show)--data ExprNodeLabel = NUndefined | NSymbol Symbol | NLit Value- deriving (Eq, Show)--instance Repr ExprNode where- reprl (ENode label evalRes) =- case label of- NUndefined ->- case evalRes of- EvalUntried -> ["undefined"]- EvalError e -> ["undefined", "error: " ++ e]- EvalOk _ -> - errcats ["reprl of ExprNode: NUndefined with EvalOk",- "should not happen!"]- NSymbol s ->- case evalRes of- EvalOk v -> [repr s, repr v]- EvalError e -> [repr s, "error: " ++ e]- EvalUntried -> reprl s- NLit l -> reprl l---- This was--- exprNodeIoletCounter :: Env -> IoletCounter ExprNode--- but IoletCounter is not available here, so use equivalent type.--- Returns (no. of inlets, no. of outlets)-exprNodeIoletCounter :: Env -> ExprNode -> (Int, Int)-exprNodeIoletCounter env (ENode nodeLabel _nodeResult) =- case nodeLabel of- NUndefined -> (0, 1)- NSymbol (Symbol "if") -> (3, 1) - NSymbol (Symbol s) -> - case envLookup env s of- Nothing -> (0, 1) -- probably a parameter of the function- Just value ->- case value of- VFun function -> (functionNArgs function, 1)- _ -> (0, 1) -- symbol bound to non-function value- NLit _ -> (0, 1)--exprToTree :: Expr -> ExprTree-exprToTree expr =- case expr of- -- EUndefined, ESymbol, ELit map direclty to NUndefined, NSymbol, NLit- EUndefined -> T.Node (ENode NUndefined EvalUntried) []- ESymbol s -> T.Node (ENode (NSymbol s) EvalUntried) []- ELit l -> T.Node (ENode (NLit l) EvalUntried) []- -- EIf maps to symbol "if" at the root, 3 subtrees- EIf t a b -> T.Node (ENode (NSymbol (Symbol "if")) EvalUntried)- (map exprToTree [t, a, b])- -- ECall maps to symbol f (function name) at the root,- -- each argument forms a subtree- ECall f args -> T.Node (ENode (NSymbol f) EvalUntried)- (map exprToTree args)- -- EList maps to the *symbol* (yes!) "[]" or to a ":" (cons) expression- EList [] -> T.Node (ENode (NSymbol (Symbol "[]")) EvalUntried) []- EList (x:xs) -> exprToTree (ECall (Symbol ":") [x, EList xs])---- | Convert an expression tree (back) to an expression--- It will not give back the *same* expression in the case of an EList.-treeToExpr :: ExprTree -> Expr-treeToExpr (T.Node (ENode label _) trees) =- let wrong msg =- errcat ["treeToExpr: ", msg, ": node label = ",- show label, "; trees = ", show trees]- in case label of- NUndefined -> EUndefined- NSymbol s -> - if s == Symbol "if"- then case trees of- [q, a, b] -> - EIf (treeToExpr q) (treeToExpr a) (treeToExpr b)- _ -> wrong "'if' node with /= 3 subtrees"- else - -- VVV Do I really need to distinguish these two cases?- if null trees - then - -- s = terminal symbol- ESymbol s - else -- s = function symbol in function call- ECall s (map treeToExpr trees) - NLit lit -> if null trees then ELit lit- else wrong "literal node with non-empty subtrees"---- Convert an expression to a repr tree (of string elements)--- (Why?)--exprToReprTree :: Expr -> Tree String-exprToReprTree = fmap repr . exprToTree---- Evaluation results (or non-results)--type EvalResult = EvalRes Value--data EvalRes e = EvalOk e | EvalError String | EvalUntried- deriving (Eq, Show)--instance Monad EvalRes where- EvalOk value >>= f = f value- EvalError e >>= _f = EvalError e- EvalUntried >>= _f = EvalUntried- return = EvalOk- fail = EvalError---- Evaluate an expression tree showing the evaluation at each node.--- There's a lot of redundancy in this computation, but does it matter?--evalTree :: ExprTree -> Env -> ExprTree-evalTree atree env = evalTreeWithLimit atree env stackSize--evalTreeWithLimit :: ExprTree -> Env -> Int -> ExprTree-evalTreeWithLimit atree env stacksize =-- let T.Node root subtrees = atree- ss' = pred stacksize- in case root of- ENode (NSymbol (Symbol "if")) _ ->- case subtrees of- [tt, ta, tb] ->- let tt' = evalTreeWithLimit tt env ss'- ENode _ testResult = rootLabel tt'- subEval subtree =- let subtree' = evalTreeWithLimit subtree env ss'- ENode _ subresult = rootLabel subtree'- in (subresult, subtree')- ifNode result = ENode (NSymbol (Symbol "if")) result- in case testResult of- EvalOk (VBool True) -> - let (taValue, ta') = subEval ta in- T.Node (ifNode taValue) [tt', ta', tb]-- EvalOk (VBool False) -> - let (tbValue, tb') = subEval tb in- T.Node (ifNode tbValue) [tt', ta, tb']-- EvalError msg ->- T.Node (ifNode (EvalError msg)) [tt', ta, tb]-- _ -> errcats ["evalTreeWithLimit (if):",- "unexpected test result"]-- _ -> error "evalTreeWithLimit: if: wrong number of subtrees"-- ENode rootOper _ ->- T.Node (ENode rootOper (evalWithLimit (treeToExpr atree) env ss'))- [evalTreeWithLimit s env ss' | s <- subtrees]---- remove the values from the ExprNodes--- "inverse" of evalTree -unevalTree :: ExprTree -> ExprTree-unevalTree atree = - let unevalNode (ENode oper _) = ENode oper EvalUntried- in fmap unevalNode atree---- VALUES AND EVALUATION--data Value = VBool OBool- | VChar OChar- | VInt OInt- | VFloat OFloat- | VStr OStr- | VFun Function- | VList [Value] - deriving (Eq, Read, Show)- -- no Read for Function--instance Repr Value where- repr (VBool b) = show b- repr (VChar c) = show c- repr (VInt i) = show i- repr (VFloat x) = show x- repr (VStr s) = show s- repr (VFun f) = show f- repr (VList l) = - "[" ++ - concat (intersperse ", " (map repr l)) ++ - "]"--valueFunction :: Value -> Function-valueFunction value =- case value of- VFun function -> function- _ -> error "valueFunction: non-function value"---- | The value of an expression in the base environment.--exprToValue :: Expr -> SuccFail Value-exprToValue expr = - case eval expr baseEnv of - EvalOk value -> Succ value- EvalError msg -> Fail msg- EvalUntried -> error "exprToValue: eval resulted in EvalUntried"--valueToLiteral :: Value -> SuccFail Expr-valueToLiteral v = - case v of- VFun _f -> Fail "cannot convert a function to a literal"- _ -> Succ (ELit v)- -stringToValue :: String -> SuccFail Value-stringToValue s =- case stringToExpr s of- Succ expr -> exprToValue expr- Fail errmsg -> Fail errmsg--data VpType = VpTypeString - | VpTypeChar- | VpTypeNum- | VpTypeBool- | VpTypeList VpType -- list with fixed type of elements- | VpTypeFunction [VpType] VpType -- argument, result types- | VpTypeVar String -- named type variable- deriving (Eq, Read, Show)---type TypeEnv = Map String VpType---- | Try to match a single type and value,--- may result in binding a type variable in a new environment--- or just the old environment-typeMatch :: VpType -> Value -> TypeEnv -> SuccFail TypeEnv-typeMatch vptype value env = - let sorry x etype =- Fail $ repr x ++ ": " ++ etype ++ " expected"- in case (vptype, value) of- -- easy cases- (VpTypeBool, VBool _) -> Succ env- (VpTypeBool, x) -> sorry x "True or False"- (VpTypeChar, VChar _) -> Succ env- (VpTypeChar, x) -> sorry x "character"- (VpTypeNum, VInt _) -> Succ env- (VpTypeNum, VFloat _) -> Succ env- (VpTypeNum, x) -> sorry x "number"- (VpTypeString, VStr _) -> Succ env- (VpTypeString, x) -> sorry x "string"- -- VV Harder- -- VV Are the avalues below supposed to be equal to the value above?- (VpTypeVar name, avalue) -> - case Map.lookup name env of- Nothing -> - -- bind type variable- vpTypeOf avalue >>= \ vtype -> Succ $ Map.insert name vtype env- Just concreteType -> typeMatch concreteType avalue env- (VpTypeList etype, VList lvalues) ->- case lvalues of- [] -> Succ env- v:vs -> - typeMatch etype v env >>= - typeMatch (VpTypeList etype) (VList vs)- (VpTypeFunction _atypes _rtype, _) ->- -- this will require matching type variables with type variables!- error "typeMatch: unimplemented case for VpTypeFunction"- _ -> Fail $ "type mismatch: " ++ show (vptype, value)----- | Determine the type of a value.--- May result in a type variable.--vpTypeOf :: Value -> SuccFail VpType-vpTypeOf v =- case v of- VBool _ -> Succ VpTypeBool- VChar _ -> Succ VpTypeChar- VInt _ -> Succ VpTypeNum- VFloat _ -> Succ VpTypeNum- VStr _ -> Succ VpTypeString- VFun (Function _ atypes rtype _) -> Succ $ VpTypeFunction atypes rtype-- VList [] -> Succ $ VpTypeList $ VpTypeVar "list_element"- VList (x:xs) -> - do- xtype <- vpTypeOf x- xstypes <- mapM vpTypeOf xs- if filter (/= xtype) xstypes == []- then Succ $ VpTypeList xtype- else Fail "list with diverse element types"---- | Check whether the values agree with the types (which may be abstract)------ This is *probably* too lenient in the case of type variables:--- it can pass a mixed-type list.--typeCheck :: [String] -> [VpType] -> [Value] -> SuccFail [Value]-typeCheck names types values =- let check :: TypeEnv -> [String] -> [VpType] -> [Value] -> SuccFail [Value]- check _ [] [] [] = Succ []- check env (n:ns) (t:ts) (v:vs) = - case typeMatch t v env of- Succ env' -> check env' ns ts vs >>= Succ . (v:)- Fail msg -> Fail $ "For variable " ++ n ++ ":\n" ++ msg- check _ _ _ _ = error "typeCheck: mismatched list lengths"- in check empty names types values- --- | A function may have a name and always has an implementation-data Function = Function (Maybe String) -- function name- [VpType] -- argument types- VpType -- result type- FunctionImpl -- implementation- deriving (Read, Show)--data FunctionImpl = Primitive ([Value] -> EvalResult) -- a Haskell function- | Compound [String] Expr -- arguments, body--instance Show FunctionImpl where- show (Primitive _) = "<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 -> - errcats ["functionBody:",- "no body available for primitive function"]- Compound _args body -> body---- | We need to be able to say functions are equal (or not) in order--- to tell if environments are equal or not, in order to know whether--- there are unsaved changes. This is tricky since the primitive--- function implementations do not instantiate Eq, so if it's--- primitive == primitive? we go by the names alone (there's nothing--- else to go by). Otherwise all the parts must be equal.-instance Eq Function where- f1 == f2 =- let Function mname1 atypes1 anames1 impl1 = f1- Function mname2 atypes2 anames2 impl2 = f2- in case (impl1, impl2) of- (Primitive _, Primitive _) -> mname1 == mname2- (Compound args1 body1, Compound args2 body2 ) -> - mname1 == mname2 &&- atypes1 == atypes2 &&- anames1 == anames2 &&- args1 == args2 &&- body1 == body2- _ -> False---- | An Environment contains variable bindings and may be linked to --- a next environment------ Perhaps it may also be used to generate Vp type variables (with int id's)--type EnvFrame = Map String Value-type Env = [EnvFrame] -- should be NON-empty-type Binding = (String, Value)--makeEnv :: [String] -> [Value] -> Env -makeEnv names values = extendEnv names values []--extendEnv :: [String] -> [Value] -> Env -> Env-extendEnv names values env = fromList (zip names values) : env---- | Insert names and values from lists into an environment-envInsertL :: Env -> [String] -> [Value] -> Env-envInsertL env names values =- case env of- [] -> error "envInsertL: empty list"- f : fs ->- let ins :: EnvFrame -> Binding -> EnvFrame- ins frame (name, value) = Map.insert name value frame- in foldl ins f (zip names values) : fs--envIns :: Env -> String -> Value -> Env-envIns env name value =- case env of- [] -> error "envIns: empty list"- f : fs -> Map.insert name value f : fs--envSet :: Env -> String -> Value -> Env-envSet env name value = - -- If name is bound in some map in the environment, update the binding- -- in that map; otherwise insert it into the "front" map- let loop :: Env -> Maybe Env- loop env1 =- case env1 of- [] -> Nothing- f:fs ->- case Map.lookup name f of- Just _ -> Just (envIns env1 name value)- Nothing ->- do -- in the Maybe monad:- fs' <- loop fs- return (f:fs')-- in case loop env of- Just result -> result- Nothing -> envIns env name value---- | Get the value of a variable from an environment-envGet :: Env -> String -> Value-envGet env name = case envLookup env name of- Just value -> value- Nothing -> errcats ["envGet: unbound variable:", name]--envGetFunction :: Env -> String -> Function-envGetFunction env name = func - where VFun func = envGet env name--envLookup :: Env -> String -> Maybe Value-envLookup env name =- case env of- [] -> Nothing- f:fs ->- case Map.lookup name f of- Just value -> Just value- Nothing -> envLookup fs name--envLookupFunction :: Env -> String -> Maybe Function-envLookupFunction env name = - case envLookup env name of- Nothing -> Nothing- Just value ->- case value of- VFun function -> Just function- _ -> Nothing---- | List of all symbols bound in the environment-envSymbols :: Env -> [String]-envSymbols env =- case env of- [] -> []- f : fs -> keys f ++ envSymbols fs---- | List of all symbols bound to functions in the environment-envFunctionSymbols :: Env -> [String]-envFunctionSymbols env =- let isFunction s = case envGet env s of- VFun _ -> True- _ -> False- in [s | s <- envSymbols env, isFunction s]---- | Return to the environment prior to an extendEnv-envPop :: Env -> Env-envPop env =- case env of- [] -> error "envPop: empty list"- _f:fs -> fs- -unbound :: String -> Env -> Bool-unbound name env = envLookup env name == Nothing---- EVALUATING EXPRESSIONS---- Limit the stack size for recursion, since we are helping--- novice programmers to learn--stackSize :: Int-stackSize = 1000--eval :: Expr -> Env -> EvalResult-eval expr env = evalWithLimit expr env stackSize--evalWithLimit :: Expr -> Env -> Int -> EvalResult---- Evaluate an expression in an environment with a limited stack--evalWithLimit expr env stacksize =- if stacksize <= 0- then EvalError "stack overflow"- else- let stacksize' = pred stacksize in- case expr of- EUndefined -> EvalError "undefined"- ESymbol (Symbol name) ->- case envLookup env name of- Nothing -> EvalError $ "unbound variable: " ++ name- Just value -> EvalOk value-- ELit value -> EvalOk value-- EIf t a b ->- case evalWithLimit t env stacksize' of- EvalOk (VBool True) -> evalWithLimit a env stacksize'- EvalOk (VBool False) -> evalWithLimit b env stacksize'- result -> result-- ECall fsym args ->- -- evaluating a function call- -- *I assume that call expressions have *symbols* for the - -- functions.- -- To relax this assumption: change the definition of ECall,- -- but how will you visualize it?-- case evalWithLimit (ESymbol fsym) env stacksize' of- EvalOk f -> - case mapM (\ a -> evalWithLimit a env stacksize') args of- EvalOk argvalues -> apply f argvalues env stacksize'- -- why doesn't this work? err -> err- EvalError e -> EvalError e- EvalUntried -> EvalUntried- err -> err-- EList elist ->- case mapM (\ elt -> evalWithLimit elt env stacksize') elist of- EvalOk values -> EvalOk (VList values)- EvalError e -> EvalError e- EvalUntried -> EvalUntried---- | Apply a function fvalue to a list of actual arguments args--- in an environment env and with a limited stack size stacksize-apply :: Value -> [Value] -> Env -> Int -> EvalResult-apply fvalue args env stacksize =- case fvalue of- VFun f ->- case functionImplementation f of- Primitive pf -> pf args- Compound formalArgs body ->- evalWithLimit body (extendEnv formalArgs args env) stacksize- not_a_function ->- EvalError ("apply: first arg is not a function: " ++ - show not_a_function)---- Shortcuts for making expressions that call the primitive functions-ePlus :: Expr -> Expr -> Expr-ePlus e1 e2 = eCall "+" [e1, e2]--eTimes :: Expr -> Expr -> Expr-eTimes e1 e2 = eCall "*" [e1, e2]--eMinus, eDiv, eMod :: Expr -> Expr -> Expr-eMinus e1 e2 = eCall "-" [e1, e2]-eDiv e1 e2 = eCall "div" [e1, e2]-eMod e1 e2 = eCall "mod" [e1, e2]--eAdd1, eSub1 :: Expr -> Expr-eAdd1 e1 = eCall "add1" [e1]-eSub1 e1 = eCall "sub1" [e1]--eEq, eNe, eGt, eGe, eLt, eLe :: Expr -> Expr -> Expr-eEq e1 e2 = eCall "==" [e1, e2]-eNe e1 e2 = eCall "/=" [e1, e2]-eGt e1 e2 = eCall ">" [e1, e2]-eGe e1 e2 = eCall ">=" [e1, e2]-eLt e1 e2 = eCall "<" [e1, e2]-eLe e1 e2 = eCall "<=" [e1, e2]---eZerop, ePositivep, eNegativep :: Expr -> Expr-eZerop e1 = eCall "zero?" [e1]-ePositivep e1 = eCall "positive?" [e1]-eNegativep e1 = eCall "negative?" [e1]---- A good base environment to get started with --primitiveFunctions :: [Function]-primitiveFunctions = [- -- Arithmetic- primN2N "+" (+) (+), -- Integer (+), Double (+)- primN2N "-" (-) (-),- primN2N "*" (*) (*),- primIntDiv,- primIntMod,- primFloatDiv,-- primN1N "add1" succ succ,- primN1N "sub1" pred pred,-- -- Comparison- primN2B "==" (==) (==),- primN2B "/=" (/=) (/=),- primN2B ">" (>) (>),- primN2B ">=" (>=) (>=),- primN2B "<" (<) (<),- primN2B "<=" (<=) (<=),-- primN1B "zero?" (== 0) (== 0.0),- primN1B "positive?" (> 0) (> 0.0),- primN1B "negative?" (< 0) (< 0.0),-- -- List operations-- -- null xs tells if xs is an empty list- prim "null" [VpTypeList (VpTypeVar "a")] - VpTypeBool primNull,-- prim "head" [VpTypeList (VpTypeVar "c")] - (VpTypeVar "c")- primHead,- prim "tail" [VpTypeList (VpTypeVar "c")] - (VpTypeList (VpTypeVar "c"))- primTail,- prim ":" [VpTypeVar "d", VpTypeList (VpTypeVar "d")]- (VpTypeList (VpTypeVar "d"))- primCons- ]--type PFun = [Value] -> EvalResult---- Primitive functions of arbitrary type-prim :: String -> [VpType] -> VpType -> PFun -> Function-prim name atypes rtype = Function (Just name) atypes rtype . Primitive---- Primitive arithmetic functions---- | Integer div and mod operations, for exact integers only.--- Using an inexact (floating point) argument is an error,--- even if the argument is "equal" to an integer (e.g., 5.0).--- Division (div or mod) by zero is an error.-primIntDivMod :: String -> (OInt -> OInt -> OInt) -> Function-primIntDivMod name oper =- let func args =- let err msg = EvalError $ concat [name, ": ", msg, - " (", show args, ")"]- in case args of- [VInt a, VInt b] ->- if b == 0- then err "zero divisor"- else EvalOk $ VInt (oper a b)- [VFloat _, _] -> err "arguments must be exact numbers"- [_, VFloat _] -> err "arguments must be exact numbers"- _ -> error "wrong type or number of arguments"- in prim name [VpTypeNum, VpTypeNum] VpTypeNum func--primIntDiv, primIntMod :: Function-primIntDiv = primIntDivMod "div" div-primIntMod = primIntDivMod "mod" mod---- | Floating point division.--- Integer arguments are coerced to floating point,--- and the result is always floating point.--- operands are ints. --- x / 0 is NaN if x == 0, Infinity if x > 0, -Infinity if x < 0.-primFloatDiv :: Function-primFloatDiv =- let divide args =- case args of- [VInt ix, VInt iy] -> - EvalOk $ VFloat (fromIntegral ix / fromIntegral iy)- [VInt ix, VFloat y] -> EvalOk $ VFloat (fromIntegral ix / y)- [VFloat x, VInt iy] -> EvalOk $ VFloat (x / fromIntegral iy)- [VFloat x, VFloat y] -> EvalOk $ VFloat (x / y)- _ -> EvalError $ "/: invalid args: " ++ show args- in prim "/" [VpTypeNum, VpTypeNum] VpTypeNum divide---- Primitive functions for lists--primArgCountError :: String -> EvalResult-primArgCountError name = - errcat [name, ": wrong number of arguments in primitive function"]---- Some of the type-checking in these primitive functions--- shouldn't be necessary, if Sifflet knew the types of the--- functions and could do type inference and check input values.--primNull :: PFun-primNull args =- case args of- [VList list] -> EvalOk $ VBool (List.null list)- [_] -> EvalError "null: not a list"- _ -> primArgCountError "primNull"--primHead :: PFun-primHead args =- case args of- [VList (x : _xs)] -> EvalOk x- [VList []] -> EvalError "head: empty list"- [_] -> EvalError "head: not a list"- _ -> primArgCountError "primHead"--primTail :: PFun-primTail args =- case args of- [VList (_x : xs)] -> EvalOk $ VList xs- [VList []] -> EvalError "tail: empty list"- [_] -> EvalError "tail: not a list"- _ -> primArgCountError "primTail"--primCons :: PFun-primCons args =- case args of- [x, VList xs] -> EvalOk $ VList (x:xs)- [_, _] -> EvalError "cons: second argument not a list"- _ -> primArgCountError "primCons"---- Functions for constructing Functions of common types---- | Primitive function with 2 number arguments yield an number value--- fi = integer function to implement for integer operands.--- fx = float function to implement for float operands.-primN2N :: String -> (OInt -> OInt -> OInt) -> (OFloat -> OFloat -> OFloat)- -> Function-primN2N name fi fx =- let impl args =- case args of- [VInt ix, VInt iy] -> EvalOk $ VInt (fi ix iy)- [VInt ix, VFloat y] -> EvalOk $ VFloat (fx (fromIntegral ix) y)- [VFloat x, VInt iy] -> EvalOk $ VFloat (fx x (fromIntegral iy))- [VFloat x, VFloat y] -> EvalOk $ VFloat (fx x y)- _ -> EvalError $ name ++ ": invalid args: " ++ show args- in prim name [VpTypeNum, VpTypeNum] VpTypeNum impl---- | Primitive unary functions number to number-primN1N :: String -> (OInt -> OInt) -> (OFloat -> OFloat) -> Function-primN1N name fi fx = - let impl args =- case args of- [VInt ix] -> EvalOk $ VInt (fi ix)- [VFloat x] -> EvalOk $ VFloat (fx x)- _ -> EvalError $ name ++ ": invalid args: " ++ show args- in prim name [VpTypeNum] VpTypeNum impl---- Primitive frunctions with 2 number args and a boolean result-primN2B :: String -> (OInt -> OInt -> OBool) -> (OFloat -> OFloat -> OBool)- -> Function-primN2B name fi fx =- let impl args =- case args of- [VInt x, VInt y] -> EvalOk $ VBool (fi x y)- [VInt ix, VFloat y] -> EvalOk $ VBool (fx (fromIntegral ix) y)- [VFloat x, VInt iy] -> EvalOk $ VBool (fx x (fromIntegral iy))- [VFloat x, VFloat y] -> EvalOk $ VBool (fx x y)- _ -> EvalError $ name ++ ": invalid args: " ++ show args- in prim name [VpTypeNum, VpTypeNum] VpTypeBool impl----- Primitive unary functions number to boolean-primN1B :: String -> (OInt -> Bool) -> (OFloat -> OBool) -> Function-primN1B name fi fx = - let impl args =- case args of- [VInt ix] -> EvalOk $ VBool (fi ix)- [VFloat x] -> EvalOk $ VBool (fx x)- _ -> EvalError $ name ++ ": invalid args: " ++ show args- in prim name [VpTypeNum] VpTypeBool impl--baseEnv :: Env-baseEnv = - makeEnv (map functionName primitiveFunctions)- (map VFun primitiveFunctions)---- | Given an expression, return the list of names of variables--- occurring n the expression-exprSymbols :: Expr -> [Symbol]-exprSymbols expr = - nub $ case expr of- EUndefined -> [] -- is *not* a variable- ESymbol s -> [s]- ELit _ -> []- EIf t a b -> nub $ concat [exprSymbols t,- exprSymbols a,- exprSymbols b]- ECall f args -> - case args of- [] -> [f]- a:as -> nub $ concat [exprSymbols a,- exprSymbols (ECall f as)]- EList items -> nub $ concatMap exprSymbols items---- | exprVarNames expr returns the names of variables in expr--- that are UNBOUND in the base environment. This may not be ideal,--- but it's a start.--exprVarNames :: Expr -> [String]-exprVarNames expr = [name | (Symbol name) <- exprSymbols expr,- unbound name baseEnv]---- | decideTypes tries to find the argument types and return type--- of an expression considered as the body of a function,--- at the same time checking for consistency of inputs and--- outputs between the parts of the expression.--- It returns Right (argtypes, returntype) if successful;--- Left errormessage otherwise.--decideTypes :: Expr -> [String] -> Env -> Either String ([VpType], VpType)-decideTypes expr args _env =- unsafePerformIO $ do - {- print "Fudged the decideTypes"- ; print expr- ; return (if True- then Right (undefinedTypes args)- else Left "decideTypes: not implemented")- }--undefinedTypes :: [String] -> ([VpType], VpType)-undefinedTypes argnames =- let atypes = [VpTypeVar ('_' : name) | name <- argnames]- rtype = VpTypeVar "_result"- in (atypes, rtype)
− Geometry.hs
@@ -1,131 +0,0 @@-module Geometry- (Position(..), - positionDelta, positionDistance,- positionDistanceSquared, positionCloseEnough,- Circle(..), pointInCircle,- Size(..),- BBox(..), - bbX, bbY, bbWidth, bbSetWidth, bbHeight, bbPosition, bbSize,- bbToRect, bbFromRect, bbCenter, bbLeft, bbXCenter, bbRight,- bbTop, bbYCenter, bbBottom,- bbMerge, bbMergeList, pointInBB,- Widen(widen)- )--where--import Graphics.UI.Gtk(Rectangle(Rectangle))---- A Position may be interpreted either absolutely, as a point (x, y);--- or relatively, as an offset (dx, dy)--data Position = Position {posX :: Double, posY :: Double} -- x, y- deriving (Eq, Read, Show)--positionDelta :: Position -> Position -> (Double, Double)-positionDelta (Position x1 y1) (Position x2 y2) = (x2 - x1, y2 - y1)--positionDistance :: Position -> Position -> Double-positionDistance p1 p2 = sqrt (positionDistanceSquared p1 p2)--positionDistanceSquared :: Position -> Position -> Double-positionDistanceSquared (Position x1 y1) (Position x2 y2) =- (x1 - x2) ** 2 + (y1 - y2) ** 2--positionCloseEnough :: Position -> Position -> Double -> Bool-positionCloseEnough p1 p2 radius =- -- Essentially asks if p1 and p2 are nearly intersecting,- -- i.e., if p1 is within a circle with center p2 and the given radius- positionDistanceSquared p1 p2 <= radius ** 2----data Circle = Circle {circleCenter :: Position,- circleRadius :: Double}- deriving (Eq, Read, Show)--pointInCircle :: Position -> Circle -> Bool-pointInCircle point (Circle center radius) =- positionCloseEnough point center radius--data Size = Size {sizeW :: Double, sizeH :: Double} -- width, height- deriving (Eq, Read, Show)---- | BBox x y width height; (x, y) is the top left corner--data BBox = BBox Double Double Double Double- deriving (Eq, Read, Show)---- | BBox accessors and utilities--bbX, bbY, bbWidth, bbHeight :: BBox -> Double-bbX (BBox x _y _w _h) = x--bbY (BBox _x y _w _h) = y-bbWidth (BBox _x _y w _h) = w-bbHeight (BBox _x _y _w h) = h--bbPosition :: BBox -> Position-bbPosition (BBox x y _w _h) = Position x y--bbSize :: BBox -> Size-bbSize (BBox _x _y w h) = Size w h--bbCenter :: BBox -> Position-bbCenter (BBox x y w h) = Position (x + w / 2) (y + h / 2)--bbSetWidth :: BBox -> Double -> BBox-bbSetWidth (BBox x y _w h) nwidth = BBox x y nwidth h--bbLeft, bbXCenter, bbRight :: BBox -> Double-bbLeft = bbX-bbXCenter (BBox x _y w _h) = x + w / 2-bbRight (BBox x _y w _h) = x + w--bbTop, bbYCenter, bbBottom :: BBox -> Double-bbTop = bbY-bbYCenter (BBox _x y _w h) = y + h / 2-bbBottom (BBox _x y _w h) = y + h--bbToRect :: BBox -> Rectangle-bbToRect (BBox x y w h) = - Rectangle (round x) (round y) (round w) (round h)--bbFromRect :: Rectangle -> BBox-bbFromRect (Rectangle x y w h) =- BBox (fromIntegral x) (fromIntegral y)- (fromIntegral w) (fromIntegral h)---- | Form a new BBox which encloses two bboxes-bbMerge :: BBox -> BBox -> BBox-bbMerge bb1 bb2 =- let f1 ! f2 = f1 (f2 bb1) (f2 bb2)- bottom = max ! bbBottom -- i.e., max (bbBottom bb1) (bbBottom bb2)- top = min ! bbTop- left = min ! bbLeft- right = max ! bbRight- in BBox left top (right - left) (bottom - top)--bbMergeList :: [BBox] -> BBox-bbMergeList [] = error "bbMergeList: empty list"-bbMergeList (b:bs) = foldl bbMerge b bs- --- Test whether a point (e.g., from mouse click) is within a--- bounding box-pointInBB :: Position -> BBox -> Bool-pointInBB (Position x y) (BBox x1 y1 w h) =- x >= x1 &&- x <= x1 + w &&- y >= y1 &&- y <= y1 + h--class Widen a where- -- | Make an object have at least a specified minimum width;- -- does nothing if it's already at least that wide- widen :: a -> Double -> a--instance Widen BBox where- widen bb@(BBox x y w h) minWidth =- if w >= minWidth- then bb- else BBox x y minWidth h
− GtkForeign.hs
@@ -1,269 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface, CPP #-}-{-# INCLUDE /usr/include/gtk-2.0/gtk/gtk.h #-}-{-# INCLUDE /usr/include/gtk-2.0/gdk/gdk.h #-}---- NOTE: START GHCI AS FOLLOWS:--- ghci -lgtk-x11-2.0 -lgdk-x11-2.0--- ================================---- File: GtkForeign.hs--- Foreign functions from Gtk---- CURSOR SHAPES--- Original source: https://sourceforge.net/mailarchive/forum.php?thread_name=87ps50ie9o.fsf%40loki.cmears.id.au&forum_name=gtk2hs-users--- Copyright status ??????--{- -Re: [Gtk2hs-users] Changing the mouse cursor shape-From: Chris Mears <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.---- Ah, but it's not really in 0.10.1 released May 10, 2009;--- it's in darcs since Sept. 27, 2009.--#if MIN_VERSION_gtk(0,10,2)-#define GTK_HAS_CURSOR_TYPE 1-#else-#define GTK_HAS_CURSOR_TYPE 0-#endif--module GtkForeign - (-#if GTK_HAS_CURSOR_TYPE- Graphics.UI.Gtk.CursorType(..)-#else- CursorType(..)-#endif- , setCursor)-where--import System.Glib-import System.Glib.FFI-import Foreign.ForeignPtr (castForeignPtr)--#if GTK_HAS_CURSOR_TYPE-import Graphics.UI.Gtk-#else-import Graphics.UI.Gtk (Cursor, widgetGetDrawWindow, DrawWindow, Window)-#endif----- type CursorPtr = Ptr Cursor--foreign import ccall "gdk_window_set_cursor" gdkWindowSetCursor :: - Ptr DrawWindow -> Ptr Cursor -> IO ()--foreign import ccall "gdk_cursor_new" gdkCursorNew :: Int -> IO (Ptr Cursor)---- | Set the X Window cursor for a window to a specified type-setCursor :: Window -> CursorType -> IO ()-setCursor window cursorType = do- c <- gdkCursorNew (cursorTypeNumber cursorType)- d <- widgetGetDrawWindow window- let GObject fp = toGObject d- withForeignPtr (castForeignPtr fp) $ \ptr -> gdkWindowSetCursor ptr c--#if ! GTK_HAS_CURSOR_TYPE--- Cursor types are added to gtk2hs in v. 0.10.1, but we need this for--- earlier versions including 0.10.0.--- For illustrations, see--- http://www.pygtk.org/docs/pygtk/class-gdkcursor.html--data CursorType = XCursor - | Arrow- | BasedArrowDown- | BasedArrowUp- | Boat- | Bogosity- | BottomLeftCorner- | BottomRightCorner- | BottomSide- | BottomTee- | BoxSpiral- | CenterPtr- | Circle- | Clock- | CoffeeMug- | Cross- | CrossReverse- | Crosshair- | DiamondCross- | Dot- | Dotbox- | DoubleArrow- | DraftLarge- | DraftSmall- | DrapedBox- | Exchange- | Fleur- | Gobbler- | Gumby- | Hand1- | Hand2- | Heart- | Icon- | IronCross- | LeftPtr- | LeftSide- | LeftTee- | Leftbutton- | LlAngle- | LrAngle- | Man- | Middlebutton- | Mouse- | Pencil- | Pirate- | Plus- | QuestionArrow- | RightPtr- | RightSide- | RightTee- | Rightbutton- | RtlLogo- | Sailboat- | SbDownArrow- | SbHDoubleArrow- | SbLeftArrow- | SbRightArrow- | SbUpArrow- | SbVDoubleArrow- | Shuttle- | Sizing- | Spider- | Spraycan- | Star- | Target- | Tcross- | TopLeftArrow- | TopLeftCorner- | TopRightCorner- | TopSide- | TopTee- | Trek- | UlAngle- | Umbrella- | UrAngle- | Watch- | Xterm- | LastCursor- | CursorIsPixmap- deriving (Eq, Read, Show)-#endif--cursorTypeNumber :: CursorType -> Int-cursorTypeNumber cursorType =- case cursorType of- XCursor -> 0- Arrow -> 2- BasedArrowDown -> 4- BasedArrowUp -> 6- Boat -> 8- Bogosity -> 10- BottomLeftCorner -> 12- BottomRightCorner -> 14- BottomSide -> 16- BottomTee -> 18- BoxSpiral -> 20- CenterPtr -> 22- Circle -> 24- Clock -> 26- CoffeeMug -> 28- Cross -> 30- CrossReverse -> 32- Crosshair -> 34- DiamondCross -> 36- Dot -> 38- Dotbox -> 40- DoubleArrow -> 42- DraftLarge -> 44- DraftSmall -> 46- DrapedBox -> 48- Exchange -> 50- Fleur -> 52- Gobbler -> 54- Gumby -> 56- Hand1 -> 58- Hand2 -> 60- Heart -> 62- Icon -> 64- IronCross -> 66- LeftPtr -> 68- LeftSide -> 70- LeftTee -> 72- Leftbutton -> 74- LlAngle -> 76- LrAngle -> 78- Man -> 80- Middlebutton -> 82- Mouse -> 84- Pencil -> 86- Pirate -> 88- Plus -> 90- QuestionArrow -> 92- RightPtr -> 94- RightSide -> 96- RightTee -> 98- Rightbutton -> 100- RtlLogo -> 102- Sailboat -> 104- SbDownArrow -> 106- SbHDoubleArrow -> 108- SbLeftArrow -> 110- SbRightArrow -> 112- SbUpArrow -> 114- SbVDoubleArrow -> 116- Shuttle -> 118- Sizing -> 120- Spider -> 122- Spraycan -> 124- Star -> 126- Target -> 128- Tcross -> 130- TopLeftArrow -> 132- TopLeftCorner -> 134- TopRightCorner -> 136- TopSide -> 138- TopTee -> 140- Trek -> 142- UlAngle -> 144- Umbrella -> 146- UrAngle -> 148- Watch -> 150- Xterm -> 152- LastCursor -> (-1)- CursorIsPixmap -> (-1)
− GtkUtil.hs
@@ -1,225 +0,0 @@-{-# LANGUAGE CPP #-}--module GtkUtil (suppressScimBridge,- showChoicesDialog, defaultDialogPosition, - runDialogM, runDialogS, - -- runDialogHelper,- showInputErrorMessage, showErrorMessage,- showInfoMessage,- showMessage,- EntryDialog, Reader, - createEntryDialog, runEntryDialog,- addEntryWithLabel- )--where--import Control.Monad--#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) -import System.Posix.Env-#endif--- import Graphics.UI.Gtk hiding (response) -- Gtk 0.10.1-import Graphics.UI.Gtk -- Gtk 0.10.0 does not have response- -import Util---- SCIM Bridge causes problems, so shush it--suppressScimBridge :: IO ()-suppressScimBridge = -#if defined(mingw32_HOST_OS) || defined(__MINGW32__) - return ()-#else- putEnv "GTK_IM_MODULE=gtk-im-context-simple"-#endif---- ============================================================--- CUSTOMIZABLE DIALOGS---- | Show a message and a set of choices;--- run the action corresponding to the selected choice;--- you might want to include a "Cancel" option with the action return ().--- There *should* be as many actions as there are options.-showChoicesDialog :: String -> String -> [String] -> [IO a] -> IO a-showChoicesDialog title message options actions = do- {- -- Create basic dialog- dialog <- dialogNew- ; windowSetTitle dialog title- ; widgetSetName dialog ("Sifflet-" ++ title)-- -- Add message- ; vbox <- dialogGetUpper dialog- ; label <- labelNew (Just message)- ; boxPackStartDefaults vbox label- ; widgetShowAll vbox-- -- Add buttons- -- Work around bug in gtk2hs v. 0.10.0 and 0.10.1,- -- which is fixed in darcs gtk2hs.- -- fromResponse (ResponseUser i) requires i > 0.- -- so zip [1..] instead of zip [0..]- ; let indexOptions = zip [1..] options- addButton (i, option) = - dialogAddButton dialog option (ResponseUser i)- ; forM_ indexOptions addButton- ; dialogGetActionArea dialog >>= widgetShowAll-- -- Run dialog- ; response <- dialogRun dialog- ; widgetDestroy dialog -- here? or after handling response?- ; case response of- ResponseUser i -> - let j = i - 1 -- work around bug described above- in if j >= 0 && j < length actions- then actions !! j- else errcats ["showChoicesDialog: response index",- show j, "is out of range for actions"]- _ -> errcats ["showChoicesDialog: expected a ResponseUser _ but got",- show response]- }- -createDialog :: String -> (VBox -> IO a) -> IO (Dialog, a)-createDialog title addContent = do- -- Create basic dialog- dialog <- dialogNew- windowSetTitle dialog title- widgetSetName dialog ("Sifflet-" ++ title)-- -- Add custom content- vbox <- dialogGetUpper dialog- content <- addContent vbox-- -- Add standard buttons- dialogAddButton dialog "OK" ResponseOk- dialogAddButton dialog "Cancel" ResponseCancel- dialogSetDefaultResponse dialog ResponseOk -- has no effect?-- return (dialog, content)---- | Where to put a dialog window.--- Possible values are--- WinPosNone WinPosCenter WinPosMouse WinPosCenterAlways --- WinPosCenterOnParent--defaultDialogPosition :: WindowPosition-defaultDialogPosition = WinPosMouse---- | Customizable framework for running a dialog--runDialogS :: Dialog -> a -> (a -> IO (SuccFail b)) -> IO (Maybe b)-runDialogS dialog inputs processInputs = - runDialogHelper dialog inputs processInputs True--runDialogM :: Dialog -> a -> (a -> IO (Maybe b)) -> IO (Maybe b)-runDialogM dialog inputs processInputs =- let process' inputs' = do- result <- processInputs inputs'- case result of- Nothing -> return $ Fail "_Nothing_"- Just value -> return $ Succ value- in runDialogHelper dialog inputs process' False--runDialogHelper :: Dialog -> a -> (a -> IO (SuccFail b)) -> Bool -> IO (Maybe b)-runDialogHelper dialog inputs processInputs retryOnError = do- -- Position and show the dialog- windowSetPosition dialog defaultDialogPosition- widgetShowAll dialog- windowPresent dialog-- let run = do- respId <- dialogRun dialog- return Nothing- case respId of- ResponseOk ->- do- result <- processInputs inputs- case result of- Fail msg ->- if retryOnError- then do- showErrorMessage msg- run -- try again- else finish Nothing- Succ value -> finish (Just value)- _ -> finish Nothing-- finish result = do- widgetDestroy dialog- return result-- run--showInputErrorMessage :: String -> IO ()-showInputErrorMessage message =- showErrorMessage ("Input Error:\n" ++ message)--showErrorMessage :: String -> IO ()-showErrorMessage = showMessage (Just "Error") MessageError ButtonsClose--showInfoMessage :: String -> String -> IO ()-showInfoMessage title = showMessage (Just title) MessageInfo ButtonsClose--showMessage :: Maybe String -> MessageType -> ButtonsType -> String -> IO ()-showMessage mtitle messagetype buttonstype message = do- {- msgDialog <- - messageDialogNew- Nothing -- ? or (Just somewindow) -- what does this do?- [] -- flags- messagetype- buttonstype- message- ; case mtitle of- Nothing -> widgetSetName msgDialog "Sifflet-dialog"- Just title -> windowSetTitle msgDialog title >>- widgetSetName msgDialog ("Sifflet-" ++ title)- ; windowSetPosition msgDialog defaultDialogPosition- ; windowPresent msgDialog- ; dialogRun msgDialog- ; widgetDestroy msgDialog- }---- ============================================================--- INPUT DIALOGS--type Reader a b = (a -> SuccFail b)--data EntryDialog a = EntryDialog Dialog [Entry] (Reader [String] a)--createEntryDialog :: - String -> [String] -> [String] -> (Reader [String] a) -> Int -> - IO (EntryDialog a)-createEntryDialog title labels defaults reader width = do- -- Interpret width = -1 as don't care-- (dialog, entries) <- - createDialog title (addEntries labels defaults)- windowSetDefaultSize dialog width (-1)- return $ EntryDialog dialog entries reader--runEntryDialog :: (Show a) => EntryDialog a -> IO (Maybe a)-runEntryDialog (EntryDialog dialog entries reader) = - let -- processInputs :: [Entry] -> IO (SuccFail a)- -- weird error like in runComboBoxDialog ^- processInputs entries' = do- inputs <- mapM entryGetText entries'- return (reader inputs)-- in runDialogS dialog entries processInputs--addEntries :: [String] -> [String] -> VBox -> IO [Entry]-addEntries labels defaults vbox = do- entries <- mapM (const entryNew) labels- mapM_ (addEntryWithLabel vbox) (zip3 labels entries defaults)- return entries---- | Add a labeled text entry to the vbox.--addEntryWithLabel :: VBox -> (String, Entry, String) -> IO ()-addEntryWithLabel vbox (name, entry, defaultValue) = do- label <- labelNew (Just name)- entrySetText entry defaultValue- boxPackStartDefaults vbox label- boxPackStartDefaults vbox entry
− LittleGtk.hs
@@ -1,150 +0,0 @@--- The purpose of this module is simply to re-export the--- Gtk functions and types that I use, and avoid those--- that I don't, particularly those that conflict with--- names in Sifflet, like Layout.--- Just hiding these is not enough, because Graphics.UI.Gtk--- keeps changing what it exports.--- For example, in 0.10.5 it no longer exports Function, fill,--- function.--module LittleGtk- (- -- These are just directly re-exported from Gtk:-- -- Attributes- AttrOp(..), -- for (:=)- get,- set,-- adjustmentNew,-- boxPackEnd,- boxPackStart,- boxPackStartDefaults,-- Button,- buttonNewWithLabel,-- ContainerClass,- castToContainer,- containerAdd,- containerChild,- containerForeach,-- customStoreSetColumn,-- -- Dialog- toDialog,-- DrawWindow,- drawWindowInvalidateRect,-- entryCompletionInsertPrefix,- entryCompletionModel,- entryCompletionNew,- entryCompletionSetTextColumn,-- Entry,- entryGetText,- entryGetCompletion,- entryNew,- entrySetCompletion,-- EventMask(..), -- eventBoxNew,-- exposeEvent,-- fileChooserDialogNew, - fileChooserGetFilename,-- FileChooserAction(..),-- grabAdd,- grabRemove,-- HBox, - hBoxNew,-- keyPressEvent,-- labelNew,-- Layout, - layoutGetDrawWindow,- layoutNew, - layoutPut,- layoutSetSize,-- listStoreNew,-- makeColumnIdString,-- menuPopup,-- on, - onDestroy, - onSizeRequest, -- Packing(..),-- PolicyType(PolicyAutomatic),-- Rectangle(..),-- renderWithDrawable, -- Requisition(..),-- ResponseId(..),-- ScrolledWindow,- scrolledWindowNew,- scrolledWindowSetPolicy,-- Statusbar,- statusbarGetContextId,- statusbarNew,- statusbarPop,- statusbarPush,-- VBox, - vBoxNew, -- WidgetClass,-- widgetAddEvents,- widgetClassPath,- widgetDestroy,- widgetGrabFocus,- widgetSetCanFocus, - widgetSetDoubleBuffered,- widgetSetName,- widgetSetSizeRequest,- widgetShow,- widgetShowAll, - widgetVisible,-- Window,- windowMove,- windowNew, - windowPresent,- windowTitle,-- -- General GTK stuff- initGUI, - mainGUI, - mainQuit, -- -- These are renamed:- GtkFrame,- GtkLayout- )--where--import Graphics.UI.Gtk--type GtkFrame = Frame-type GtkLayout = Layout
− RPanel.hs
@@ -1,154 +0,0 @@--- | "Rowed Panel." --- Expandable framed panel with a two-dimensional layout--- (rows of widgets, but not with aligned columns like in a table).--module RPanel- (- RPanel, newRPanel, rpanelId, rpanelRoot, rpanelContent- , rpanelAddWidget, rpanelAddWidgets, rpanelNewRow- , rpanelAddRows- )--where--import Control.Monad-import Graphics.UI.Gtk--import Util--debugTracing :: Bool-debugTracing = False--data RPanel - = RPanel {- -- Public- rpId :: String -- ^ text for the expander button- , rpRoot :: Frame -- ^ use the root to add rpanel to a container- , rpContent :: [[String]] -- ^ ids of widgets added, in rows-- -- Widgets that make up the RPanel- , rpFrame :: Frame -- ^ frame, same as root- , rpExpander :: Expander -- ^ expander- , rpVBox :: VBox -- ^ vbox to contain the rows- , rpCurrentRow :: HBox -- ^ next element goes here if it fits-- -- Geometry book-keeping- , rpCurrentRowFreeWidth :: Int -- ^ free width in current row- , rpMaxWidth :: Int -- ^ maximum row width- , rpHPad :: Int -- ^ horizontal padding- }--rpanelId :: RPanel -> String-rpanelId = rpId--rpanelRoot :: RPanel -> Frame-rpanelRoot = rpRoot--rpanelContent :: RPanel -> [[String]]-rpanelContent = rpContent--newRPanel :: String -> Int -> Int -> Int -> IO RPanel-newRPanel cid hpad vpad maxWidth = do- {- frame <- frameNew -- adds a border (not labeled, since the expander is)- - ; expander <- expanderNew cid- ; expanderSetExpanded expander True- ; set frame [containerChild := expander]-- ; vbox <- vBoxNew False vpad -- non-homogeneous heights- ; widgetSetSizeRequest vbox maxWidth (-1) -- height = don't care- ; set expander [containerChild := vbox]-- ; hbox <- hBoxNew False hpad -- non-homogeoneous widths- ; boxPackStart vbox hbox PackNatural 0-- ; return $ RPanel {rpId = cid- , rpRoot = frame- , rpFrame = frame- , rpExpander = expander- , rpVBox = vbox- , rpCurrentRow = hbox- , rpContent = [[]]- , rpCurrentRowFreeWidth = maxWidth - hpad- , rpMaxWidth = maxWidth - hpad- , rpHPad = hpad- }- }---- | Given a list of (name, widget) pairs, add each of the widgets--- and its name to the rpanel-rpanelAddWidgets :: (WidgetClass widget) =>- RPanel -> [(String, widget)] -> IO RPanel-rpanelAddWidgets rp pairs = - let addPair rp' (widgetId, widget) = rpanelAddWidget rp' widgetId widget- in foldM addPair rp pairs---- | Add a single named widget to the RPanel-rpanelAddWidget :: (WidgetClass widget) =>- RPanel -> String -> widget -> IO RPanel-rpanelAddWidget rp widgetId widget = do- {- Requisition widgetWidth _ <- widgetSizeRequest widget- ; let freeWidth = rpCurrentRowFreeWidth rp- freeWidth' = freeWidth - widgetWidth - rpHPad rp- ; if freeWidth' >= 0 || freeWidth == rpMaxWidth rp- -- Either there is room enough, OR we're at the start of a row- -- so starting another won't help -- in fact it would lead to- -- infinite recursion- then do- {- let content' = insertLastLast (rpContent rp) widgetId- packMode = -- PackNatural -- to left justify- PackGrow -- to fill- -- PackRepel -- to center-- ; boxPackStart (rpCurrentRow rp) widget packMode 0- -- ; widgetShow widget -- do this here???- ; when debugTracing $- putStr (unlines ["Adding " ++ widgetId ++ - " width " ++ show widgetWidth- , "Free width = " ++ show freeWidth ++- " -> " ++ show freeWidth'- , "Content -> " ++ show content'])-- ; return $ rp {rpContent = content'- , rpCurrentRowFreeWidth = freeWidth'}- }- else - -- We're out of room, but not at the start of the current row,- -- so start a new row- do- {- rp' <- rpanelNewRow rp- ; rpanelAddWidget rp' widgetId widget- }- }---- | Force the RPanel to begin a new row--rpanelNewRow :: RPanel -> IO RPanel-rpanelNewRow rp = do- {- hbox <- hBoxNew False (rpHPad rp)- ; boxPackStart (rpVBox rp) hbox PackNatural 0- ; return $ rp {rpCurrentRow = hbox- , rpContent = insertLast (rpContent rp) []- , rpCurrentRowFreeWidth = rpMaxWidth rp}- }---- | Given a list of lists, each sublist representing a row of widgets,--- add the widgets to the RPanel, preserving the row structure--- as much as possible.--- (Row structure will be broken if any intended row is too wide.)-rpanelAddRows :: (WidgetClass widget) =>- RPanel -> [[(String, widget)]] -> IO RPanel-rpanelAddRows rp rows = foldM rpanelAddRow rp rows---- | Add a row of widgets to an RPanel.--- This does not start a new row before the first widget,--- but after the last, so at the end, the current row will be empty.-rpanelAddRow :: (WidgetClass widget) =>- RPanel -> [(String, widget)] -> IO RPanel-rpanelAddRow rp row = - rpanelAddWidgets rp row >>= rpanelNewRow
− SiffML.hs
@@ -1,396 +0,0 @@--- | SiffML : Sifflet Markup Language.--- An XML application for storing and retrieving Sifflet programs--- and libraries.--module SiffML- (- ToXml(..)- , produceFile- , consumeFile- , Functions(..)- , xmlToFunctions- , testOut -- testing- , xmlToX -- testing- , testIn, testFromFile -- testing- )--where--import Text.XML.HXT.Arrow-import Text.XML.HXT.DOM.FormatXmlTree--import Expr-import Examples-import Util--class ToXml a where- toXml :: a -> Producer---- | A Producer produces XML-type Producer = IOSLA (XIOState ()) XmlTree XmlTree---- | A Consumer consumes XML-type Consumer a b = IOSLA (XIOState ()) a b--defaultOptions = [(a_indent, v_yes), (a_validate, v_no)]--produceStdout :: (ToXml a) => a -> IO ()-produceStdout src = produceFile src "-"--produceFile :: (ToXml a) => a -> FilePath -> IO ()-produceFile src path = - let arrow :: Producer- arrow = toXml src- options = defaultOptions- in do- {- putStrLn ""- ; [rc] <- runX (root [] [arrow] >>>- writeDocument options path >>>- getErrStatus)- ; putStrLn (case rc of- 0 -> "Okay"- _ -> "Failed")-- }--produceXmlTrees :: (ToXml a) => a -> IO [XmlTree]-produceXmlTrees src = - let arrow :: Producer- arrow = toXml src- options = defaultOptions- in do- {- putStrLn ""- ; docs <- runX (root [] [arrow] >>> writeDocument options "-")- ; case docs of- [] -> putStrLn "Failed"- doc : _ ->- print doc- ; return docs-- }---consumeFile :: Consumer XmlTree a -> FilePath -> IO [a]-consumeFile fromXml filePath =- let options = defaultOptions- in runX (readDocument options filePath >>> fromXml)--consumeStdin :: Consumer XmlTree a -> IO [a]-consumeStdin fromXml = consumeFile fromXml "-"---- | testFromXml :: (ToXml a, Show a) => a -> Consumer XmlTree a -> IO ()--- VVV This type generalization (a, a to a, b) is for debugging, undo it later:-testFromXml :: (ToXml a, Show b) => a -> Consumer XmlTree b -> IO ()-testFromXml src consumer = do- {- produceFile src "test.xml"- ; results <- runX (readDocument defaultOptions "test.xml" >>>- isElem >>> -- document root- getChildren >>>- consumer)- ; case results of- [] -> putStrLn "Failed"- result : _ -> print result- }--testToXmlAndBack :: (ToXml a, Show a) => a -> Consumer XmlTree a -> IO ()-testToXmlAndBack = testFromXml---- | Symbols--instance ToXml Symbol where- toXml = symbolToXml--symbolToXml :: Symbol -> Producer-symbolToXml (Symbol name) =- selem "symbol" [txt name]--xmlToSymbol :: Consumer XmlTree Symbol-xmlToSymbol = - isElem >>> hasName "symbol" >>> -- symbol element- getChildren >>> isText >>> -- text element- getText >>> -- String- arr Symbol -- quasi (return . Symbol)--testXmlToSymbol :: Symbol -> IO ()-testXmlToSymbol sym = testFromXml sym xmlToSymbol----- | Expr--instance ToXml Expr where- toXml = exprToXml--exprToXml :: Expr -> Producer-exprToXml expr =- case expr of- EUndefined -> - eelem "undefined"- ESymbol (Symbol name) -> - selem "symbol" [txt name]- -- ** To simplify, collapse <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- errcats ["functionToXml:",- "primitive functions cannot be exported to XML",- show (mName, argTypes, retType)]- Compound argNames body ->- selem "compound-function"- (let name name = selem "name" [txt name]- rest = - [selem "return-type" [vpTypeToXml retType],- selem "arg-types" (map vpTypeToXml argTypes),- selem "arg-names" (map name argNames),- selem "body" [toXml body]]- in case mName of- Nothing -> rest- Just fName -> name fName : rest- )--xmlToFunction :: Consumer XmlTree Function-xmlToFunction = - let getChildElem :: Consumer XmlTree XmlTree- getChildElem = getChildren >>> isElem-- getFuncName :: Consumer XmlTree String- getFuncName = hasName "name" >>> getChildren >>> isText >>> getText-- getReturnType :: Consumer XmlTree VpType- getReturnType = hasName "return-type" >>> getChildren >>> xmlToVpType-- getArgTypes :: Consumer XmlTree [VpType]- getArgTypes = hasName "arg-types" >>> - listA (getChildren >>> xmlToVpType)-- getArgNames :: Consumer XmlTree [String]- getArgNames = hasName "arg-names" >>> - listA (getChildElem >>> getFuncName)-- getBody :: Consumer XmlTree Expr- getBody = hasName "body" >>> getChildren >>> xmlToExpr -- in - isElem >>> hasName "compound-function" >>> - -- NOTE:- -- If arr1 "produces" a, and arr2 "produces" b,- -- then (arr1 &&& arr2) "produces" (a, b).- (- ( -- function name is optional, though it *should* be in the XML file- listA (getChildElem >>> getFuncName)) &&& - (getChildElem >>> getReturnType) &&&- (getChildElem >>> getArgTypes) &&&- (getChildElem >>> getArgNames) &&&- (getChildElem >>> getBody)- )- >>>- (arr (\ (names, (returnType, (argTypes, (argNames, body)))) -> - Function (case names of - [] -> Nothing- (fname : _) -> (Just fname)- )- argTypes- returnType (Compound argNames body)))--exampleFunction = - let esym = ESymbol . Symbol- in Function (Just "cincr") - [VpTypeBool, VpTypeNum, VpTypeNum]- VpTypeNum- (Compound ["incr", "a", "b"]- (EIf (esym "incr")- (ECall (Symbol "+") [esym "a", esym "b"])- (esym "a")))---- | A collection of functions, to be saved or read from a file--data Functions = Functions [Function]- deriving (Eq, Show)--functionsToXml :: Functions -> Producer-functionsToXml (Functions fs) =- selem "functions" (map toXml fs)--xmlToFunctions :: Consumer XmlTree Functions-xmlToFunctions =- isElem >>> -- document root- getChildren >>>- hasName "functions" >>>- listA (getChildren >>> xmlToFunction) >>>- arr Functions----- | This is for testing, when I don't know the type --- of the result I'm getting-xmlToX :: Consumer XmlTree Functions -- [Function] -- XmlTree-xmlToX = - isElem -- document root- >>>- getChildren- >>>- hasName "functions" - >>>- listA (getChildren >>> xmlToFunction) - >>>- arr Functions--instance ToXml Functions where- toXml = functionsToXml---- | Tests--testOut :: IO ()-testOut = - produceStdout (Functions [exampleFunctions !! 0, exampleFunctions !! 1])---testFromFile :: (Show a) => Consumer XmlTree a -> FilePath -> IO ()-testFromFile fromXml filePath = do- {- results <- consumeFile fromXml filePath- ; putStrLn ""- ; print (length results)- ; print results- ; putStrLn ""- }--testIn :: (Show a) => Consumer XmlTree a -> IO ()-testIn fromXml = testFromFile fromXml "-"
− Tree.hs
@@ -1,102 +0,0 @@--- Tree.hs--- General (not binary) trees--module Tree (T.Tree(..), tree, leaf, isLeaf, treeSize, treeDepth- , Repr(..)- -- Since String is not an instance of Repr,- -- we need to convert (Tree String) to (Tree Name)- , Name(..), nameTree- , putTree, putTreeR, putTreeRs, putTreeS- , drawTreeShow- )-where--import Data.Tree as T---- Makers--tree :: e -> Forest e -> T.Tree e-tree root subtrees = T.Node {rootLabel = root, subForest = subtrees}--leaf :: e -> T.Tree e-leaf x = tree x []--isLeaf :: T.Tree e -> Bool-isLeaf (T.Node _root []) = True-isLeaf _ = False--treeSize :: T.Tree e -> Int-treeSize (T.Node _root subtrees) = 1 + sum (map treeSize subtrees)--treeDepth :: T.Tree e -> Int-treeDepth (T.Node _root []) = 1-treeDepth (T.Node _root subtrees) = 1 + maximum (map treeDepth subtrees)--{- tree_map or treeMap:- removed; use (Functor) fmap instead--}--{- tree_mapM:- removed, use Data.Traversable.mapM instead.--}---- class Repr: representable by a String or a list of Strings---- repr x is a String representation of x.--- reprl x is a [String] representation of x,--- where the first element should be the same as repr x,--- and the extra values, if any, provide auxiliary information,--- such as the value of x.--- reprs x is a reduction of reprl x to a single String.------ Minimal complete implementation: define repr, or define reprl.--class Repr a where-- repr :: a -> String- repr = head . reprl-- reprl :: a -> [String]- reprl x = [repr x]-- reprs :: a -> String- reprs = unwords . reprl--instance Repr Int where repr = show-instance Repr Integer where repr = show-instance Repr Float where repr = show-instance Repr Double where repr = show---- instance Repr String won't work because String is a type synonym,--- unless you ask ghc nicely, which I'd prefer not to do.--- Use Name data type in Testing/Tree.hs instead, or Symbol in Expr.hs--- I don't know if I can use Expr.Symbol here, since Expr.hs also--- imports Tree.hs (this file) -- is mutual import allowed?--data Name = Name String- deriving (Eq, Read, Show)--instance Repr Name where- repr (Name s) = s--nameTree :: T.Tree String -> T.Tree Name-nameTree = fmap Name--putTree :: (Show e) => T.Tree e -> IO ()-putTree = putTreeS---- putTreeR -- using repr (first part)-putTreeR :: (Repr e) => T.Tree e -> IO()-putTreeR = putStrLn . drawTree . fmap repr---- putTreeRs -- using reprs (all parts)-putTreeRs :: (Repr e) => T.Tree e -> IO()-putTreeRs = putStrLn . drawTree . fmap reprs----- putTreeS -- using show-putTreeS :: (Show e) => T.Tree e -> IO ()-putTreeS = putStrLn . drawTreeShow--drawTreeShow :: (Show e) => T.Tree e -> String-drawTreeShow = drawTree . fmap show
− TreeGraph.hs
@@ -1,417 +0,0 @@-module TreeGraph (LayoutGraph, - flayoutToGraph, treeLayoutToGraph,- -- treeToGraph, - orderedTreeToGraph, - treeGraphNodesTree, graphToTreeOriginal,- graphToTreeStructure, - flayoutToGraphRoots,- graphToOrderedTree, graphToOrderedTreeFrom,- orderedChildren, adjCompareEdge,- nextNodes, -- exported for testing; any other reason?- grTranslateNode, grTranslateSubtree, grTranslateGraph,-- -- moved from Workspace.hs:- functoidToFunction, graphToExprTree,-- -- Tree graph rendering- graphQuickView, - graphWriteImageFile, graphRender, treeRender,- treeWriteImageFile, gtkShowTree- )--where--import IO-import Data.IORef-import Data.List (sort, sortBy)-import System.Cmd--import Data.Graph.Inductive as G--import LittleGtk-import Graphics.UI.Gtk.Gdk.EventM--import Graphics.Rendering.Cairo hiding (translate)--import Geometry-import Tree as T-import TreeLayout-import Expr-import Util-import Workspace.Functoid-import Workspace.WGraph--type LayoutGraph n e = Gr (LayoutNode n) e--flayoutToGraph :: FunctoidLayout -> WGraph-flayoutToGraph tlo = - case tlo of - FLayoutTree t -> treeLayoutToGraph t- FLayoutForest ts _bbox -> - foldl grAddGraph wgraphNew (map treeLayoutToGraph ts)--treeLayoutToGraph :: TreeLayout ExprNode -> WGraph-treeLayoutToGraph = orderedTreeToGraph . fmap WSimple----- flayoutToGraphRoots returns a list of graph nodes (Ints)--- corresponding to the root of the tree, or the roots of--- the trees in the forest.--- The list is ordered in the same sense as the graph nodes.--flayoutToGraphRoots :: FunctoidLayout -> [G.Node]-flayoutToGraphRoots (FLayoutTree _t) = [1]-flayoutToGraphRoots (FLayoutForest trees _bbox) =- let loop _ [] res = reverse res- loop next (t:ts) res =- loop (next + treeSize t) ts (next:res)- in loop 1 trees []----- {-# DEPRECATED treeToGraph "use ??? instead" #-}---- treeToGraph :: Tree e -> Gr e ()--- treeToGraph (T.Node root subtrees) = --- -- Convert an ordered tree to a graph.--- -- The graph edge labels from parent to child --- -- are integers corresponding to the order of the children.--- -- So, to recover the ordered list of children, --- -- sort by the edge label.--- let g0 = empty :: Gr e ()--- g1 = insNode (1, root) g0---- grow :: Gr e () -> [(Tree e, G.Node)] -> G.Node -> Gr e ()--- -- grow graph [(tree, parent)] node--- grow g [] _ = g--- grow g ((t, p):tps) n =--- -- insert t forming g', insert ts into g'--- let edge = ((), p) -- predecessors, or both?--- g' = ([edge], n, (rootLabel t), []) & g -- assume pred only--- in grow g' (tps ++ [(s, n) | s <- subForest t])--- (succ n)---- in grow g1 [(s, 1) | s <- subtrees] 2--sprout :: G.Node -> Tree e -> [(G.Node, WEdge, Tree e)]-sprout parent (T.Node _ subtrees) =- -- create triples (parent graph node, edge, subtree)- let m = length subtrees - 1- in [(parent, WEdge e, s) | (e, s) <- zip [0..m] subtrees]---orderedTreeToGraph :: Tree e -> Gr e WEdge-orderedTreeToGraph otree = - -- Convert an ordered tree to a graph.- -- The graph edge labels from parent to child - -- are integers corresponding to the order of the children.- -- So, to recover the ordered list of children, - -- sort by the edge label.- let g0 = empty :: Gr e WEdge- g1 = insNode (1, rootLabel otree) g0-- grow :: Gr e WEdge -> [(G.Node, WEdge, Tree e)] -> G.Node -> Gr e WEdge- -- grow graph [(parent, edgeLabel, subtree), ...] node- grow g [] _ = g- grow g ((p, e, t):pets) n =- -- insert pet forming g', insert pets into g';- -- n is the node id for the root of this subtree- let adj = (e, p) -- to parent (priority, node)- g' = ([adj], n, (rootLabel t), []) & g - n' = succ n- in grow g' (pets ++ - sprout n t- -- [(s, n) | s <- subForest t])- )- n'-- in grow g1 (sprout 1 otree) 2---- And what about this (e, Node) type? Is it some sort of monad?--treeGraphNodesTree :: Tree e -> Tree Node-treeGraphNodesTree atree =- -- returns a tree of Nodes of the Graph (treeToGraph atree)- let gnTree :: Tree e -> Node -> Node -> (Tree Node, Node)- gnTree (T.Node _root subtrees) rootNode next =- -- rootNode = Node (number) for the root,- -- next = next unused Node- let (nNodes, next') = nextNodes subtrees next- (subtrees', next'') = gnSubtrees subtrees nNodes next'- in (T.Node rootNode subtrees', next'')-- gnSubtrees :: [Tree e] -> [Node] -> Node -> ([Tree Node], Node)- gnSubtrees [] [] next = ([], next)- gnSubtrees (t:ts) (n:ns) next = - let (t', next') = gnTree t n next- (ts', next'') = gnSubtrees ts ns next'- in ((t' : ts'), next'')- gnSubtrees _ _ _ = error "gnSubtrees: list lengths do not match"-- in fst (gnTree atree 1 2)--nextNodes :: [e] -> Node -> ([Node], Node)-nextNodes items next = - -- next is the next unused Node (number).- -- Returns list of new nodes, and a new "next" node- -- E.g., nextNodes [a, b] 3 = ([3, 4], 5)- -- nextNodes [c, d, e] 5 = ([5, 6, 7], 8)- -- nextNodes [] 8 = ([], 8)- let n = length items- next' = next + n- in ([next .. (next' - 1)], next')---- When a tree is converted to a graph,--- each tree node's ordered children get graph node numbers--- in ascending order. Therefore, when reconstructing the tree,--- sorting the graph nodes restores the order of the children--- as in the tree.--graphToOrderedTree :: Gr e WEdge -> Tree e--- inverse of orderedTreeToGraph-graphToOrderedTree g = graphToOrderedTreeFrom g 1--graphToOrderedTreeFrom :: Gr e WEdge -> G.Node -> Tree e-graphToOrderedTreeFrom g n =- case lab g n of- Just label -> - T.Node label (map (graphToOrderedTreeFrom g) (orderedChildren g n))- Nothing -> - errcats ["missing label for node", show n]---- | List of the nodes children, ordered by edge number-orderedChildren :: Gr e WEdge -> G.Node -> [G.Node]-orderedChildren g = map fst . sortBy adjCompareEdge . lsuc g--adjCompareEdge :: (Node, WEdge) -> (Node, WEdge) -> Ordering-adjCompareEdge (_n1, e1) (_n2, e2) = compare e1 e2--{-# DEPRECATED graphToTreeOriginal "use ??? instead" #-}--graphToTreeOriginal :: Gr e () -> G.Node -> Tree e--- (\g -> graphToTreeOriginal g 1) is the inverse of treeToGraph-graphToTreeOriginal g n =- case lab g n of- Just label -> T.Node label (map (graphToTreeOriginal g) - (sort (suc g n)))- _ -> errcats ["missing label for node", show n]--{-# DEPRECATED graphToTreeStructure "use ??? instead" #-}--graphToTreeStructure :: Gr n e -> G.Node -> Tree G.Node--- This is *not* an inverse of treeToGraph.--- Rather, graphToTreeStructure (treeToGraph t 1) is a tree t' of Nodes--- (i.e., integer identifiers of nodes in the graph)--- which parallels the structure of t.--graphToTreeStructure g n = T.Node n (map (graphToTreeStructure g)- (sort (suc g n)))--grTranslateNode :: - Node -> Double -> Double -> LayoutGraph n e -> LayoutGraph n e-grTranslateNode node dx dy graph = - grUpdateNodeLabel graph node (translate dx dy)--grTranslateSubtree :: - Node -> Double -> Double -> LayoutGraph n e -> LayoutGraph n e-grTranslateSubtree root dx dy graph = - let trSubtrees :: [Node] -> LayoutGraph n e -> LayoutGraph n e- trSubtrees [] g = g- trSubtrees (r:rs) g = trSubtrees (rs ++ suc g r)- (grTranslateNode r dx dy g)- in trSubtrees [root] graph--grTranslateGraph :: Double -> Double -> LayoutGraph n e -> LayoutGraph n e-grTranslateGraph dx dy graph = nmap (translate dx dy) graph--grUpdateNodeLabel :: (DynGraph g) => g a b -> Node -> (a -> a) -> g a b-grUpdateNodeLabel graph node updater =- case match node graph of- (Nothing, _) -> error "no such node"- (Just (preds, jnode, label, succs), graph') ->- -- jnode == node- (preds, jnode, updater label, succs) & graph'--functoidToFunction :: - Functoid -> WGraph -> G.Node -> Env -> SuccFail Function-functoidToFunction functoid graph frameNode env =- case functoid of- FunctoidFunc f -> Succ f- FunctoidParts {fpName = name, fpArgs = args} ->- let roots = suc graph frameNode- expr = treeToExpr $ graphToExprTree graph (head roots)- impl = Compound args expr- in - -- Check whether the frame contains a single tree- if length roots /= 1- then Fail "The graph structure is not a tree!"- else case decideTypes expr args env of- Left errmsg -> Fail errmsg- Right (atypes, rtype) -> - Succ (Function (Just name) atypes rtype impl)---graphToExprTree :: WGraph -> G.Node -> Tree ExprNode-graphToExprTree g root =- let extractExprNode wnode =- case wnode of- WSimple layoutNode -> gnodeValue (nodeGNode layoutNode)- WFrame _ -> error "graphToExprTreeFrom: unexpected WFrame node"- in fmap extractExprNode (graphToOrderedTreeFrom g root)------ ============================================================--- GRAPH VIEWING AND RENDERING--- ============================================================---- Quick view of a graph using GraphViz--graphQuickView :: (Graph g, Show a, Show b) => g a b -> IO ()-graphQuickView g = - let dot_src = graphviz g "graphQuickView" (6, 4) (1, 1) Portrait- dot_file = "tmp.dot"- png_file = "tmp.png"- in do- h <- openFile dot_file WriteMode- hPutStr h dot_src- hClose h- _ <- system ("dot -Tpng -o" ++ png_file ++ " " ++ dot_file)- _ <- system ("feh " ++ png_file)- return ()---graphWriteImageFile :: (Repr n) => - Style -> Maybe Node -> Maybe Node ->- Double -> Double -> - LayoutGraph n e -> String -> - IO String -graphWriteImageFile style mactive mselected dwidth dheight graph file = do- withImageSurface FormatARGB32 (round dwidth) (round dheight) $ \surf -> do- renderWith surf $ - graphRender style mactive mselected graph- surfaceWriteToPNG surf file- return file--graphRender :: (Repr n) => - Style -> Maybe Node -> Maybe Node -> LayoutGraph n e -> - Render ()-graphRender style mactive mselected graph = do- let renderNode :: Node -> Render ()- renderNode node = do- let Just layoutNode = lab graph node - -- ^^ is this safe? it can't be Nothing?- nodeBB = gnodeNodeBB (nodeGNode layoutNode)- active = (mactive == Just node)- selected = case mselected of- Nothing -> False- Just sel -> sel == node- mode = if active then DrawActive- else if selected then DrawSelectedNode -- !!!- else DrawNormal- xcenter = bbXCenter nodeBB- draw style mode layoutNode- connectParent node xcenter (bbTop nodeBB)- return ()-- connectParent node x y = - let parents = pre graph node in- case parents of- [] -> return ()- [parent] -> do- let Just playoutNode = lab graph parent- parentBB = gnodeNodeBB (nodeGNode playoutNode)- px = bbXCenter parentBB- py = bbBottom parentBB- setColor (styleNormalEdgeColor style)- moveTo px (py + snd (vtinypad style)) -- bottom of parent- lineTo x (y - fst (vtinypad style)) -- top of node- stroke-- _ -> error "Too many parents"- - setAntialias AntialiasDefault-- -- canvas background- setColor (styleNormalFillColor style)- let Just layoutNode = lab graph 1 -- root node, represents whole tree- BBox x y bwidth bheight = nodeTreeBB layoutNode- rectangle x y bwidth bheight- fill-- -- draw the graph/tree- setLineWidth (lineWidth style)- mapM_ renderNode (nodes graph)--treeRender :: (Repr e) => Style -> TreeLayout e -> Render ()-treeRender style = graphRender style Nothing Nothing . orderedTreeToGraph--treeWriteImageFile :: (Repr e) => - Style -> IoletCounter e -> Tree e -> String -> IO String--treeWriteImageFile style counter atree filename = do- let tlo = treeLayout style counter atree- Size surfWidth surfHeight = treeLayoutPaddedSize style tlo- withImageSurface FormatARGB32 (round surfWidth) (round surfHeight) $ - \ surf -> do- renderWith surf $ treeRender style tlo- surfaceWriteToPNG surf filename- return filename---- ============================================================--- Simple tree viewing.--- gtkShowTree displays a single tree very simply--- Works for any kind of (Repr e, Show e) => Tree e.--gtkShowTree :: (Repr e, Show e) => - Style -> IoletCounter e -> Tree e -> IO ()-gtkShowTree style counter atree = do- let tlo = treeLayout style counter atree- Size dwidth dheight = treeLayoutPaddedSize style tlo-- tloRef <- newIORef tlo-- _ <- initGUI-- -- init window- window <- windowNew- set window [windowTitle := "Test Cairo Tree"]- _ <- onDestroy window mainQuit-- -- init vbox- vbox <- vBoxNew False 5 -- width not homogeneous; spacing- set window [containerChild := vbox]-- -- init canvas- canvas <- layoutNew Nothing Nothing- _ <- onSizeRequest canvas - (return (Requisition (round dwidth) (round dheight)))- widgetSetCanFocus canvas True -- to receive key events-- -- event handlers- _ <- on canvas exposeEvent (updateCanvas style canvas tloRef)- _ <- on canvas keyPressEvent (keyPress window)-- -- pack, show, and run- boxPackStartDefaults vbox canvas- widgetShowAll window- mainGUI--updateCanvas :: (Repr e) => Style -> Layout -> IORef (TreeLayout e) - -> EventM EExpose Bool-updateCanvas style canvas tloRef = - tryEvent $ liftIO $ do- { - tlo <- readIORef tloRef- ; win <- layoutGetDrawWindow canvas- ; renderWithDrawable win (treeRender style tlo)- }--keyPress :: Window -> EventM EKey Bool-keyPress window =- tryEvent $ do- {- kname <- eventKeyName- ; case kname of- "q" -> liftIO $ widgetDestroy window -- implies mainQuit- _ -> stopEvent- }
− TreeLayout.hs
@@ -1,854 +0,0 @@-module TreeLayout - (VColor(..), white, cream, black, lightBlue, lightBlueGreen, - lightGray, mediumGray, darkGray,- yellow, darkBlueGreen, blueGreen,- Style(..), VFont(..), defaultStyle, style0, style1, style2, style3,- wstyle,- styleIncreasePadding,- FontTextExtents(..), setFont, ftExtents,- TextBox(..), makeTextBox, tbWidth, tbHeight, tbBottom, drawTextBox,- tbCenter, tbTextCenter, tbBoxCenter, offsetTextBoxCenters,- tbSetWidth,- setColor,- treeSizes, - GNode(..), treeGNodes, gnodeText, gnodeTextBB, - Iolet(..), ioletCenter, makeIolets, makeIoletsRow,- pointInIolet,- IoletCounter, zeroIoletCounter, - makeGNode,- TreeLayout, LayoutNode(..), layoutNodeSource, layoutRootBB, layoutTreeBB,- treeLayout, - treeLayoutPaddedSize, treeLayoutSize, treeLayoutWidth, - layoutTreeMoveCenterTo,- pointInLayoutNode, pointInGNode, findRect,- Draw(..), DrawMode(..), modeTextCol, modeEdgeCol, modeFillCol, - drawBox,- treeLayoutWiden- )-where--import System.IO.Unsafe--import Graphics.Rendering.Cairo hiding (translate)-import Graphics.UI.Gtk (Rectangle)-import Control.Monad (when)-import Data.Traversable () -- imports only instance declarations--import Geometry-import Tree as T hiding (tree)-import Util--data VColor = ColorRGB Double Double Double |- ColorRGBA Double Double Double Double--black, white, cream, lightBlue, lightBlueGreen :: VColor--black = ColorRGB 0 0 0-white = ColorRGB 1 1 1-cream = ColorRGB 0.94902 0.94902 0.82745-lightBlue = ColorRGB 0.43529 0.43922 0.95686-lightBlueGreen = ColorRGB 0 1 1--lightGray, mediumGray, darkGray :: VColor-lightGray = ColorRGBA 0.75 0.75 0.75 0.5-mediumGray = ColorRGB 0.5 0.5 0.5-darkGray = ColorRGB 0.25 0.25 0.25--yellow, darkBlueGreen, blueGreen :: VColor--yellow = ColorRGB 0.9 0.9 0-darkBlueGreen = ColorRGB 0 0.3 0.3-blueGreen = ColorRGB 0 0.4 0.4---- darkRed = ColorRGB 0.5 0 0, -- dark red--data VFont = VFont {vfontFace :: String, vfontSlant :: FontSlant,- vfontWeight :: FontWeight,- vfontSize :: Double}--data Style = - Style {styleFont :: VFont,- lineWidth :: Double,- textMargin :: Double, -- in box on all four sides- hpad, vpad :: Double, -- internode (interbox) spacing- exomargin :: Double, -- margin of the tree within the window- vtinypad :: (Double, Double), -- node-edge spacing (above, below)- styleFramePad :: Double, -- pad between frames- styleNormalTextColor, styleNormalFillColor, - styleNormalEdgeColor,- styleActiveTextColor, styleActiveFillColor,- styleActiveEdgeColor,- styleSelectedTextColor, styleSelectedFillColor, - styleSelectedEdgeColor,- styleTetherColor :: VColor,- -- auxiliary text style, e.g., the value of an ExprNode- styleAuxOffset :: Position, -- center-to-center offset dx dy- styleAuxColor :: VColor,- styleAuxFont :: VFont,- styleIoletRadius :: Double, -- *** could extend to other shapes- styleShowNodeBoxes :: Bool, -- draw a box around expr nodes- styleShowNodePorts :: Bool -- draw the I/O ports of expr nodes- }--styleIncreasePadding :: Style -> Double -> Style--- increase hpad, vpad of style by multiplication-styleIncreasePadding style factor =- style {hpad = factor * hpad style,- vpad = factor * vpad style}--style0, style1, style2, style3, defaultStyle :: Style--style0 = - let green = ColorRGB 0.1 0.9 0.1- veryDarkGray = ColorRGB 0.1 0.1 0.1- brighterGreen = ColorRGB 0.5 0.95 0.5- in Style {styleFont = VFont "serif" FontSlantNormal FontWeightNormal 18, - lineWidth = 2, - textMargin = 18.0, -- text within its box- hpad = 27, vpad = 36, -- inter-node separation- exomargin = 0,- vtinypad = (4.5, 4.5), -- node-edge separation- styleFramePad = 35, -- padding between frames- -- Foreground and background colors- styleNormalTextColor = green,- styleNormalEdgeColor = green,- styleNormalFillColor = veryDarkGray,- styleActiveTextColor = brighterGreen,- styleActiveEdgeColor = brighterGreen,- styleActiveFillColor = mediumGray,- styleSelectedTextColor = blueGreen,- styleSelectedEdgeColor = blueGreen,- styleSelectedFillColor = darkGray,- styleTetherColor = white,- styleAuxOffset = Position 0.0 (-20.0),- styleAuxColor = lightGray,- styleAuxFont = - VFont "serif" FontSlantItalic FontWeightNormal 12,- styleIoletRadius = 5,- styleShowNodeBoxes = True, -- draw a box around expr nodes- styleShowNodePorts = True -- draw the I/O ports of expr nodes- }--style1 = - let veryDarkBlue = ColorRGB 0 0 0.1- pinkIHope = ColorRGB 1 0.9 0.9- in style0 {styleNormalTextColor = veryDarkBlue,- styleNormalEdgeColor = veryDarkBlue,- styleNormalFillColor = lightGray,- styleActiveTextColor = pinkIHope,- styleActiveEdgeColor = pinkIHope- }--style2 = - let darkPink = ColorRGB 1 0.5 0.5- in style1 {styleNormalFillColor = white,- styleActiveTextColor = darkPink,- styleActiveEdgeColor = darkPink}--style3 = - let semiTranspBlue = ColorRGBA 0 0.2 0.9 0.5- in style0 {exomargin = 10,- styleNormalTextColor = yellow,- styleNormalEdgeColor = yellow,- styleNormalFillColor = darkBlueGreen,- styleActiveTextColor = yellow,- styleActiveEdgeColor = yellow,- styleActiveFillColor = blueGreen,- styleAuxColor = semiTranspBlue- } --defaultStyle = style3--wstyle :: Style-wstyle = - style3 { - -- smaller to allow multiple frames on one canvas- styleFont = VFont "serif" FontSlantNormal FontWeightNormal 14,- textMargin = 8.0,- hpad = 10.0, vpad = 24.0, - vtinypad = (0.0, 0.0),- exomargin = 10.0, -- between tree and window edges- styleFramePad = 15,-- -- colors- styleNormalTextColor = yellow,- styleNormalEdgeColor = mediumGray,- styleNormalFillColor = darkBlueGreen,-- styleActiveTextColor = yellow,- styleActiveEdgeColor = mediumGray,- styleActiveFillColor = blueGreen,-- styleSelectedTextColor = black,- styleSelectedEdgeColor = lightBlueGreen,- styleSelectedFillColor = lightBlueGreen,-- styleTetherColor =- ColorRGBA 0.7 0.7 0.7 0.3, -- light gray- - -- node values- styleAuxOffset = Position 0 (-16),- styleAuxFont = VFont "serif" FontSlantItalic FontWeightNormal 12,- styleAuxColor = ColorRGBA 0.9 0.5 0.5 1.0,- -- ColorRGBA 1 0.9 0.9 0.75 - styleIoletRadius = 5- }- --pointInLayoutNode :: Position -> LayoutNode e -> Bool-pointInLayoutNode point = pointInGNode point . nodeGNode--pointInGNode :: Position -> GNode e -> Bool-pointInGNode point = pointInBB point . gnodeNodeBB---- UNUSED: findNode (except in findRect)--- find the node, if any, containing a point --- ****** might need to adjust this to take iolets into account ******-findNode :: Position -> TreeLayout e -> Maybe (LayoutNode e)-findNode point (T.Node node@(LayoutNode _rootGNode treeBB) sublayouts) =- if pointInBB point treeBB- then if pointInLayoutNode point node- then Just node- else findInSubs point sublayouts- else Nothing-- where findInSubs :: Position -> [TreeLayout e] -> Maybe (LayoutNode e)- findInSubs _p [] = Nothing- findInSubs p (l:ls) = - let found = findNode p l in- case found of- (Just _) -> found- Nothing -> findInSubs p ls---- UNUSED: findRect-findRect :: Position -> TreeLayout e -> Maybe Rectangle-findRect point tlo = - case findNode point tlo of- Nothing -> Nothing- Just node -> Just (bbToRect (gnodeNodeBB (nodeGNode node)))--setFont :: VFont -> Render ()-setFont (VFont face slant weight size) = do- selectFontFace face slant weight- setFontSize size--data FontTextExtents = FontTextExtents {- fontAscent::Double, fontDescent::Double, fontHeight::Double,- fontMaxXadvance::Double, fontMaxYadvance::Double,- textXbearing::Double, textYbearing::Double,- extTextWidth::Double, extTextHeight::Double,- textXadvance::Double, textYadvance::Double}- deriving (Eq, Read, Show)---- Rationale for unsafePerformIO:--- font extents of a string will not change unless the font itself--- changes, which is extremely unlikely--styleTextExtents :: Style -> String -> FontTextExtents-styleTextExtents style str = - unsafePerformIO $ - withImageSurface FormatARGB32 0 0 $ \ surface ->- renderWith surface $ - setFont (styleFont style) >>- ftExtents str---- | ftExtents: used for what?-ftExtents :: String -> Render FontTextExtents-ftExtents text = do- FontExtents asc desc fheight maxxadv maxyadv <- fontExtents- TextExtents xbear ybear twidth theight xadv yadv <- textExtents text- return (FontTextExtents asc desc fheight maxxadv maxyadv- xbear ybear twidth theight xadv yadv)---- UNUSED--- -- | measureText is not used; should it be?---- measureText :: Style -> String -> Size--- measureText style str = extentsSize (styleTextExtents style str)---- -- | extentsSize: unused; should it be?--- extentsSize :: FontTextExtents -> Size--- extentsSize ftExts = Size (textXadvance ftExts) (fontHeight ftExts)---data TextBox = TextBox {tbText :: String,- tbTextBB :: BBox, -- BBox of text without margins- tbBoxBB :: BBox -- of text with margins- }- deriving (Eq, Read, Show)--makeTextBox :: Style -> String -> TextBox-makeTextBox style text =- let extents = styleTextExtents style text- margin = textMargin style- textW = textXadvance extents- textH = fontHeight extents + fontDescent extents-- boxW = textW + 2.0 * margin -- max (textW + 2.0 * margin) minWidth- boxH = textH + 2.0 * margin-- boxX = 0- boxY = 0-- textX = (boxW - textW) / 2.0- -- raise text slightly, by a fraction of its font descent- -- (why? because it just looks better!)- -- Maybe this should be made an aspect of style?- raise = 0.5 * fontDescent extents- textY = fontHeight extents + (boxH - textH) / 2.0 - raise-- textBB = BBox textX textY textW textH- boxBB = BBox boxX boxY boxW boxH-- in TextBox text textBB boxBB--instance Widen TextBox where- widen tb@(TextBox _text textBB boxBB) minWidth =- let w = bbWidth boxBB- in if w >= minWidth- then tb- else let dw = minWidth - w - in tb {tbTextBB = translate (dw / 2) 0 textBB,- tbBoxBB = widen boxBB minWidth}---tbWidth :: TextBox -> Double-tbWidth = bbWidth .tbBoxBB--tbSetWidth :: TextBox -> Double -> TextBox-tbSetWidth tbox w = - let TextBox text textBB boxBB = tbox- boxBB' = bbSetWidth boxBB w- (dx, dy) = positionDelta (bbCenter boxBB) (bbCenter boxBB')- in TextBox text (translate dx dy textBB) boxBB'--tbHeight :: TextBox -> Double-tbHeight = bbHeight . tbBoxBB--tbBottom :: TextBox -> Double-tbBottom = bbBottom . tbBoxBB---- The geometric "center" of a TextBox is the center of its "BoxBB"-tbCenter :: TextBox -> Position-tbCenter = tbBoxCenter- -tbBoxCenter :: TextBox -> Position-tbBoxCenter = bbCenter . tbBoxBB---- and the center of its text should have the same x coordinate,--- but due to the way text is positioned, maybe not the same y.--- But do we ever need this?-tbTextCenter :: TextBox -> Position-tbTextCenter = bbCenter . tbTextBB--offsetTextBoxCenters :: Position -> TextBox -> TextBox -> TextBox-offsetTextBoxCenters offset anchor floater =- -- Position the floater text box so that its center differs- -- from the anchor text box by the given offset.- -- (The offset argument comes first, like dx dy in translate.)- let Position ax ay = tbBoxCenter anchor- Position fx fy = tbBoxCenter floater- Position ox oy = offset- -- translate floater by (dx, dy), where fx + dx = ax + ox, - -- so dx = ax + ox - fx; and dy similarly- dx = ax + ox - fx- dy = ay + oy - fy- in translate dx dy floater----- GNode = graphical node, suitable for drawing-data GNode e = GNode {gnodeValue :: e, - gnodeTextBoxes :: [TextBox], -- one or two only- gnodeNodeBB :: BBox, -- encloses all textboxes- gnodeInlets :: [Iolet], -- input connectors- gnodeOutlets :: [Iolet] -- output connectors- }- deriving (Eq)--gnodeText :: GNode e -> String-gnodeText = tbText . head . gnodeTextBoxes--gnodeTextBB :: GNode e -> BBox-gnodeTextBB = tbTextBB . head . gnodeTextBoxes--instance (Show e) => Show (GNode e) where- show (GNode v tbs nodeBB inlets outlets) = - par "GNode" [show v, show tbs, show nodeBB, show inlets, show outlets]---- An IoletCounter returns (no. of inlets, no. of outlets)-type IoletCounter e = e -> (Int, Int)---- A sort of "default" IoletCounter returning zeroes-zeroIoletCounter :: IoletCounter e-zeroIoletCounter _node = (0, 0)---- An IoletsMaker ???--- type IoletsMaker e = Style -> e -> ([Position], [Position])--makeGNode :: (Repr e) => Style -> IoletCounter e -> e -> GNode e-makeGNode style countIolets value =- -- The function countIolets creates a tuple (# of inlets, # of outlets)- -- for the node, of course being (0, 0) if we don't want any.- let textboxes1 = map (makeTextBox style) (reprl value)- textboxes2 = case textboxes1 of- [_tb] -> textboxes1- [tb1, tb2] -> - [tb1, - offsetTextBoxCenters (styleAuxOffset style) tb1 tb2]- _ -> wrong textboxes1- nodeBB = case textboxes2 of- [tb] -> tbBoxBB tb- [tb1, tb2] -> bbMerge (tbBoxBB tb1) (tbBoxBB tb2)- _ -> wrong textboxes2- wrong tbs = - errcats ["makeGNode: wrong no. of text boxes;",- "expected 1 or 2, but got", show (length tbs)]- (inlets, outlets) = makeIolets style nodeBB (countIolets value)- in GNode value textboxes2 nodeBB inlets outlets--makeIolets :: Style -> BBox -> (Int, Int) -> ([Iolet], [Iolet])-makeIolets style bbox (nin, nout) =- -- make the (inlets, outlets)- (makeIoletsRow style (bbXCenter bbox) (bbBottom bbox) nin,- makeIoletsRow style (bbXCenter bbox) (bbTop bbox) nout)--makeIoletsRow :: Style -> Double -> Double -> Int -> [Iolet]-makeIoletsRow style cx cy n =- -- make a row of n Iolets, centered at (cx, cy)- let radius = styleIoletRadius style- diam = 2 * radius -- diameter- w = fromIntegral n * diam- x1 = cx - w / 2 + radius -- the center of the first iolet- x i = x1 + fromIntegral (i - 1) * diam- make i = Iolet (Circle (Position (x i) cy) radius)- in map make [1..n]--data Iolet = Iolet Circle- -- | other shapes could be added- deriving (Eq, Read, Show)--ioletCenter :: Iolet -> Position-ioletCenter (Iolet circle) = circleCenter circle--pointInIolet :: Position -> Iolet -> Bool-pointInIolet point (Iolet circle) = pointInCircle point circle---- Build a Tree of node Sizes parallel to the Repr tree,--- each node in the Size tree is the size of --- the corresponding node in the repr tree.---- treeSizes: given a tree of *node* sizes, for the root nodes of the tree--- and its subtrees, returns a tree of *tree* sizes--treeSizes :: Style -> Tree (GNode e) -> Tree Size-treeSizes style gTree = - let subtreeSizes = map (treeSizes style) (subForest gTree)- (BBox _ _ rootWidth rootHeight) = gnodeNodeBB (rootLabel gTree)- treeWidth = max rootWidth (paddedWidth style subtreeSizes)- treeHeight = rootHeight + paddedHeight style subtreeSizes- in T.Node (Size treeWidth treeHeight) subtreeSizes---- (paddedWidth style subtrees) and (paddedHeight style subtrees)--- compute the total size of all subtrees--- of of a Size tree, including padding.-paddedWidth :: Style -> [Tree Size] -> Double-paddedWidth _style [] = 0-paddedWidth style subtrees =- sum [w | (T.Node (Size w _h) _) <- subtrees] +- hpad style * fromIntegral (length subtrees - 1)---- UNUSED:--- -- | pairSum is unused; should it be?--- pairSum :: (Double, Double) -> Double--- pairSum (a, b) = a + b--paddedHeight :: Style -> [Tree Size] -> Double-paddedHeight _style [] = 0-paddedHeight style subtrees = - vpad style + maximum [h | (T.Node (Size _w h) _) <- subtrees]---- A TreeLayout is a Tree of LayoutNodes.--- The root node in a TreeLayout identifies the root of the source Tree --- (nodeSource) and the node's bounding box (nodeNodeBB).--- It also tells the bounding box of the whole tree (nodeTreeBB).--- The subtrees of the TreeLayout are the TreeLayouts --- of the subtrees of the source Tree.--type TreeLayout e = Tree (LayoutNode e)--data LayoutNode e = LayoutNode {nodeGNode :: GNode e,- nodeTreeBB :: BBox}- deriving (Eq)--layoutNodeSource :: LayoutNode e -> e-layoutNodeSource = gnodeValue . nodeGNode--instance (Show e) => Show (LayoutNode e) where- show (LayoutNode gnode treebb) = par "LayoutNode" [show gnode, show treebb]--instance Widen (LayoutNode e) where- widen node@(LayoutNode gNode treeBB) minWidth =- let dw = bbWidth treeBB - minWidth- in if dw <= 0- then node- else LayoutNode (translate (dw / 2) 0 gNode)- (widen treeBB minWidth)--{- try this, it's tough!-instance (Draw n, Widen n) = Widen (Tree n) where- ...--}---- UNUSED--- -- | layoutRootSource: unused--- layoutRootSource :: TreeLayout e -> e--- layoutRootSource tree = layoutNodeSource (rootLabel tree)--layoutRootBB :: TreeLayout e -> BBox-layoutRootBB = gnodeNodeBB . nodeGNode . rootLabel--layoutTreeBB :: TreeLayout e -> BBox-layoutTreeBB = nodeTreeBB . rootLabel--treeLayout :: (Repr e) => Style -> IoletCounter e -> Tree e -> TreeLayout e-treeLayout style counter tree = - let t1 = treeGNodes style counter tree- t2 = treeSizes style t1- start = Position (hpad style) (vpad style)- t3 = treeLayout2 style start tree t1 t2- in treeLayoutAddMargin t3 (exomargin style)----- treeGNodes produces a tree of (GNode e),--- based on a top left corner at (0, 0) which, of course, will need--- to be translated in the final tlo.--treeGNodes :: Repr e => - Style -> IoletCounter e -> Tree e -> Tree (GNode e)-treeGNodes style counter tree = fmap (makeGNode style counter) tree--treeLayout2 :: (Repr e) =>- Style -> Position -> Tree e -> Tree (GNode e) -> Tree Size -> TreeLayout e--treeLayout2 style - (Position startX startY) -- top left after padding- (T.Node _root subtrees) -- the tree being laid out - -- ^^ actually we don't need the tree as an argument;- -- it's implied by the GNode tree- (T.Node gnode subGNodes) -- "node sizes"- (T.Node (Size treeWidth treeHeight) subTreeSizes) -- tree Sizes- = - let - nodeHeight = bbHeight (gnodeNodeBB gnode)- -- center the root in its level- -- UNUSED:- -- nodeCenterX = startX + treeWidth / 2- -- nodeCenterY = startY + nodeHeight-- -- center the subtrees (may be wider or narrower than the root)- subtreesTotalWidth = paddedWidth style subTreeSizes- subX = startX + (treeWidth - subtreesTotalWidth) / 2 -- first subtree- subY = startY + nodeHeight + vpad style-- sublayouts :: (Repr e) =>- Double -> [Tree e] -> [Tree (GNode e)] -> [Tree Size] -> - [TreeLayout e]- sublayouts _ [] [] [] = []- sublayouts x (t:ts) (g:gs) (s:ss) = - treeLayout2 style (Position x subY) t g s :- sublayouts (x + sizeW (rootLabel s) + hpad style) ts gs ss- sublayouts _ _ _ _ = error "treeLayout2: mismatched list lengths"-- in T.Node (LayoutNode -- root node- (centerGNode gnode startX startY treeWidth nodeHeight) -- node- (BBox startX startY treeWidth treeHeight)) -- whole tree- (sublayouts subX subtrees subGNodes subTreeSizes)---- | Center a GNode in a rectangular area-centerGNode :: GNode e -> Double -> Double -> Double -> Double -> GNode e-centerGNode gnode startx starty awidth aheight =- let cx = startx + awidth / 2 -- desired center- cy = starty + aheight / 2- Position cgx cgy = bbCenter (gnodeNodeBB gnode)- in translate (cx - cgx) (cy - cgy) gnode- -treeLayoutPaddedSize :: Style -> TreeLayout e -> Size-treeLayoutPaddedSize style tlo =- let Size w h = treeLayoutSize tlo- in Size (w + 2.0 * hpad style) (h + 2.0 * vpad style)--treeLayoutSize :: TreeLayout e -> Size-treeLayoutSize tlo = - let BBox _x _y w h = layoutTreeBB tlo in Size w h--layoutTreeMoveCenterTo :: - Double -> Double -> TreeLayout e -> TreeLayout e-layoutTreeMoveCenterTo newX newY layoutTree =- let Position oldX oldY = bbCenter (nodeTreeBB (rootLabel layoutTree))- in translate (newX - oldX) (newY - oldY) layoutTree--treeLayoutAddMargin :: TreeLayout e -> Double -> TreeLayout e-treeLayoutAddMargin tree margin =- let LayoutNode {nodeGNode = rootGNode, nodeTreeBB = treeBB} =- rootLabel tree- subtrees = subForest tree- BBox x y w h = treeBB- treeBB' = BBox (x - margin) (y - margin) - (w + 2 * margin) (h + 2 * margin)- root' = translate margin margin (LayoutNode rootGNode treeBB')- subtrees' = translate margin margin subtrees- in T.Node root' subtrees'-- --treeLayoutWidth :: TreeLayout e -> Double-treeLayoutWidth = bbWidth . layoutTreeBB--treeLayoutWiden :: TreeLayout e -> Double -> TreeLayout e-treeLayoutWiden tlo minWidth =- let w = treeLayoutWidth tlo- in- if w >= minWidth- then tlo- else let dw = minWidth - w- T.Node root subs = translate (dw / 2) 0 tlo- LayoutNode rootGNode treeBB = root- root' = LayoutNode rootGNode - (translate (-dw / 2) - 0 - (widen treeBB minWidth))- in T.Node root' subs--setColor :: VColor -> Render ()--setColor (ColorRGB red green blue) =- setSourceRGB red green blue --setColor (ColorRGBA red green blue alpha) =- setSourceRGBA red green blue alpha----- Drawing things--- ****** THINK: is this class well conceived?--- A lot of things could be done with draw and translate--- if it were not tied to Style and DrawMode--class Draw a where- draw :: Style -> DrawMode -> a -> Render ()- translate :: Double -> Double -> a -> a---- VV DrawMode is now very awkward, since --- a node needs to know not only if it is selected,--- but which port(s) are selected--data DrawMode = DrawNormal | DrawActive - | DrawSelectedNode - | DrawSelectedInlet Int - | DrawSelectedOutlet Int- deriving (Eq)--instance (Draw e) => Draw [e] where- draw style mode = mapM_ (draw style mode)- translate dx dy = map (translate dx dy)--{- Tree must be an instance of Draw,- in order for translate to work in treeLayoutWiden,- but again, this is a bad combination (draw + translate).--}--instance (Draw e) => Draw (Tree e) where- draw style mode tree = do- draw style mode (rootLabel tree)- draw style mode (subForest tree)- translate dx dy tree = - T.Node (translate dx dy (rootLabel tree))- (translate dx dy (subForest tree))--instance Draw (LayoutNode e) where- draw style mode (LayoutNode gnode _treeBB) = draw style mode gnode-- translate dx dy (LayoutNode gnode treeBB) = - LayoutNode (translate dx dy gnode)- (translate dx dy treeBB)--instance Draw (GNode e) where-- draw style mode (GNode _value textboxes nodeBB inlets outlets) = - do- -- draw node box- let (nodeTextCol, nodeEdgeCol, nodeFillCol) = - case mode of- DrawActive -> - (styleActiveTextColor, - styleActiveEdgeColor,- styleActiveFillColor)- DrawSelectedNode -> - (styleSelectedTextColor, - styleSelectedEdgeColor,- styleSelectedFillColor)- _ -> (styleNormalTextColor, - styleNormalEdgeColor, - styleNormalFillColor)- - -- (overall box for the node)- when (styleShowNodeBoxes style) $- drawBox (Just (nodeFillCol style))- (Just (nodeEdgeCol style)) nodeBB- -- -- assert textboxes has one or two elements- -- draw the first text box- drawTextBox (Just (styleFont style))- (Just (nodeFillCol style)) -- background- Nothing -- frame color- (nodeTextCol style) -- text color- (head textboxes)-- -- draw the second textbox, if any, using "aux" style- case (tail textboxes) of- [tbAux] -> - drawTextBox (Just (styleAuxFont style))- Nothing- Nothing- (styleAuxColor style)- tbAux- _ -> return ()--- -- Draw the iolets- when (styleShowNodePorts style) $ do- drawInlets style mode inlets- drawOutlets style mode outlets- -- translate dx dy (GNode value textboxes nodeBB inlets outlets) = - GNode value - (map (translate dx dy) textboxes)- (translate dx dy nodeBB)- (translate dx dy inlets)- (translate dx dy outlets)--instance Draw TextBox where-- draw style mode =- drawTextBox (Just (styleFont style))- (Just (modeFillCol mode style)) - Nothing- (modeTextCol mode style) -- translate dx dy (TextBox text textBB boxBB) = - TextBox text (translate dx dy textBB) (translate dx dy boxBB)--drawTextBox :: Maybe VFont -> Maybe VColor -> Maybe VColor -> VColor ->- TextBox -> Render ()-drawTextBox mfont mbgcolor mframecolor textcolor - (TextBox text textBB boxBB) = do- let BBox textX textY _textW _textH = textBB- drawBox mbgcolor mframecolor boxBB- setColor textcolor- case mfont of - (Just font) -> setFont font- _ -> return ()- moveTo textX textY- showText text--instance Draw BBox where- draw style mode = - drawBox (Just (modeFillCol mode style)) - (Just (modeEdgeCol mode style)) - translate dx dy (BBox x y w h) = BBox (x + dx) (y + dy) w h--drawBox :: Maybe VColor -> Maybe VColor -> BBox -> Render ()-drawBox mBgColor mFgColor (BBox x y w h) = - -- draw the BBox, in the specified colors, irrespective of style- let setup color = - do- rectangle x y w h- setColor color- in case (mBgColor, mFgColor) of- (Just bgColor, Just fgColor) ->- do- setup bgColor- fillPreserve- setColor fgColor- stroke- (Just bgColor, Nothing) -> - do- setup bgColor- fill- (Nothing, Just fgColor) -> - do- setup fgColor- stroke- _ -> return ()--instance Draw Position where- draw _style _mode _pos = return () -- bare points are invisible ??? ******- translate dx dy (Position x y) = Position (x + dx) (y + dy)--instance Draw Iolet where- draw style mode (Iolet circle) = draw style mode circle- translate dx dy (Iolet circle) = Iolet (translate dx dy circle)--drawIolet :: Iolet -> VColor -> VColor -> Render ()-drawIolet (Iolet circle) = drawCircle circle--drawInlets :: Style -> DrawMode -> [Iolet] -> Render ()-drawInlets style mode inlets =- let selected i = mode == DrawSelectedInlet i- in drawIolets selected style inlets--drawOutlets :: Style -> DrawMode -> [Iolet] -> Render ()-drawOutlets style mode outlets =- let selected o = mode == DrawSelectedOutlet o- in drawIolets selected style outlets--drawIolets :: (Int -> Bool) -> Style -> [Iolet] -> Render ()-drawIolets selected style iolets =- -- (selected n) should be true iff n is the selected iolet- let loop _ [] = return ()- loop n (p:ps) = - uncurry (drawIolet p)- (if selected n - then (styleSelectedFillColor style, - styleSelectedEdgeColor style)- else (styleNormalFillColor style, - styleNormalEdgeColor style)) >>- loop (n + 1) ps- in loop 0 iolets- -instance Draw Circle where- draw style mode circle = - drawCircle circle (modeFillCol mode style) (modeEdgeCol mode style) -- translate dx dy (Circle center radius) =- Circle (translate dx dy center) radius--drawCircle :: Circle -> VColor -> VColor -> Render ()-drawCircle (Circle (Position x y) r) bgColor fgColor = do- newPath -- otherwise we get a line to the arc- arc x y r 0 (2 * pi)- setColor bgColor- fillPreserve- setColor fgColor- stroke---- Helper functions to find the background and foreground colors for a mode--modeFillCol :: DrawMode -> (Style -> VColor)-modeFillCol DrawNormal = styleNormalFillColor-modeFillCol DrawActive = styleActiveFillColor-modeFillCol _ = styleSelectedFillColor--modeTextCol :: DrawMode -> (Style -> VColor)-modeTextCol DrawNormal = styleNormalTextColor-modeTextCol DrawActive = styleActiveTextColor-modeTextCol _ = styleSelectedTextColor--modeEdgeCol :: DrawMode -> (Style -> VColor)-modeEdgeCol DrawNormal = styleNormalEdgeColor-modeEdgeCol DrawActive = styleActiveEdgeColor-modeEdgeCol _ = styleSelectedEdgeColor---
− UITypes.hs
@@ -1,292 +0,0 @@-module UITypes (VPUI(..)- , WinId, VPUIWindow(..)- , vpuiFileChanged- , vpuiUserEnvAList- -- operations on a VPUI involving its window- , vpuiInsertWindow- , vpuiTryGetWindow- , vpuiGetWindow- , vpuiUpdateWindow- , vpuiReplaceWindow- , vpuiUpdateWindowIO- , vpuiRemoveVPUIWindow-- -- operations on a window involving its canvas- , vpuiWindowLookupCanvas, vpuiWindowGetCanvas- , vpuiWindowSetCanvas, vpuiWindowModCanvas - , vpuiWindowModCanvasIO-- -- operation on a VPUI involving the canvas of its window- , vpuiModCanvas, vpuiModCanvasIO-- -- other operations on a window- , vpuiWindowWindow-- , VPToolkit(..), Toolbox(..), Tool(..), ToolContext(..)- , CanvasToolOp- , ToolOp- , toToolOpVW - , Workspace(..)- , FunctionEditor(..), fedFunctionName- , VCanvas(..), Selection(..), Dragging(..)- )--where--import Data.Map as Map -import Data.Graph.Inductive as G--import LittleGtk-import Graphics.UI.Gtk.Gdk.EventM (Modifier(..))--import RPanel-import TreeLayout-import Workspace.Frame-import Workspace.WGraph-import Expr-import Geometry-import Util---- | VPUI: Sifflet (formerly VisiProg) User Interface--- The initialEnv is apt to contain "builtin" functions;--- it's preserved here so that when writing to a file,--- we can skip the functions that were in the initial env.-data VPUI = VPUI {- vpuiWindows :: Map WinId VPUIWindow, -- ^ all the windows of the program- vpuiToolkits :: Map String VPToolkit, -- ^ collections of tools- vpuiFilePath :: Maybe FilePath, -- ^ the file opened or to save- vpuiStyle :: Style, -- ^ for windows, canvases, editors- vpuiInitialEnv :: Env, -- ^ initial value of global environment- vpuiGlobalEnv :: Env, -- ^ the global environment- vpuiFileEnv :: Env -- ^ global env as of last file open or save,- -- used to detect unsaved changes- }---- | Tell whether the global environmkent has changed since the--- last file open or save-vpuiFileChanged :: VPUI -> Bool-vpuiFileChanged vpui = vpuiGlobalEnv vpui /= vpuiFileEnv vpui---- | Extract from the environment the part defined by the user-vpuiUserEnvAList :: VPUI -> [(String, Value)]-vpuiUserEnvAList vpui =- let env' = vpuiGlobalEnv vpui -- I hope- env = vpuiInitialEnv vpui- in if length env == 1 && length env' == 1- then assocs (Map.difference (head env') (head env))- else errcats ["vpuiUserEnv: env lengths are not one",- "|env'|:", show (length env'),- "|env|:", show (length env)]---- | Insert a window in the window map-vpuiInsertWindow :: VPUI -> WinId -> VPUIWindow -> VPUI-vpuiInsertWindow vpui winId vw =- vpui {vpuiWindows = Map.insert winId vw (vpuiWindows vpui)}---- | Try to get the VPUIWindow with the given window ID,--- return Just result or Nothing-vpuiTryGetWindow :: VPUI -> WinId -> Maybe VPUIWindow-vpuiTryGetWindow vpui winId = Map.lookup winId (vpuiWindows vpui)---- | Get the VPUIWindow with the given window ID;--- it is an error if this fails.-vpuiGetWindow :: VPUI -> WinId -> VPUIWindow-vpuiGetWindow vpui winId = vpuiWindows vpui ! winId---- | Replace a VPUIWindow with given window ID;--- it is an error if this fails.-vpuiReplaceWindow :: VPUI -> WinId -> VPUIWindow -> VPUI-vpuiReplaceWindow vpui winId vpuiWin =- let winMap = vpuiWindows vpui- winMap' = insert winId vpuiWin winMap- in vpui {vpuiWindows = winMap'}---- | Apply an update function to a VPUIWindow with given window ID;--- it is an error if this fails.-vpuiUpdateWindow :: VPUI -> WinId -> (VPUIWindow -> VPUIWindow) -> VPUI-vpuiUpdateWindow vpui winId updater =- let winMap = vpuiWindows vpui- winMap' = adjust updater winId winMap- in vpui {vpuiWindows = winMap'}---- | Apply an update IO action to a VPUIWindow with given window ID;--- it is an error if this fails.-vpuiUpdateWindowIO :: WinId -> (VPUIWindow -> IO VPUIWindow) -> VPUI -> IO VPUI-vpuiUpdateWindowIO winId updater vpui = do- {- let winMap = vpuiWindows vpui- vw = winMap ! winId- ; vw' <- updater vw- ; let winMap' = insert winId vw' winMap- ; return $ vpui {vpuiWindows = winMap'}- }---- | Remove a window from the windows map; it has already been destroyed--- in the GUI-vpuiRemoveVPUIWindow :: WinId -> VPUI -> VPUI-vpuiRemoveVPUIWindow winId vpui =- let winMap = vpuiWindows vpui- winMap' = delete winId winMap- in vpui {vpuiWindows = winMap'}--data VPUIWindow = -- VPUIJustWindow Window - VPUIWorkWin Workspace Window- | FunctionPadWindow Window [(String, RPanel)]---vpuiWindowWindow :: VPUIWindow -> Window-vpuiWindowWindow vw =- case vw of- VPUIWorkWin _ w -> w- FunctionPadWindow w _ -> w---- | Try to find canvas; fail gracefully-vpuiWindowLookupCanvas :: VPUIWindow -> Maybe VCanvas-vpuiWindowLookupCanvas vw =- case vw of- VPUIWorkWin ws _ -> Just (wsCanvas ws)- _ -> Nothing---- | Find canvas or fail dramatically-vpuiWindowGetCanvas :: VPUIWindow -> VCanvas-vpuiWindowGetCanvas vw =- case vpuiWindowLookupCanvas vw of- Nothing -> error "vpuiWindowGetCanvas: no canvas found"- Just canvas -> canvas--vpuiWindowSetCanvas :: VPUIWindow -> VCanvas -> VPUIWindow-vpuiWindowSetCanvas vw canvas =- case vw of- VPUIWorkWin ws w -> VPUIWorkWin (ws {wsCanvas = canvas}) w- _ -> error "vpuiWindowSetCanvas: not a workspace window"--vpuiWindowModCanvas :: VPUIWindow -> (VCanvas -> VCanvas) -> VPUIWindow-vpuiWindowModCanvas vw f =- case vpuiWindowLookupCanvas vw of- Nothing -> error "vpuiWindowModCanvas: plain VPUIWindow"- Just canvas -> vpuiWindowSetCanvas vw (f canvas)--vpuiWindowModCanvasIO :: VPUIWindow -> (VCanvas -> IO VCanvas) -> IO VPUIWindow-vpuiWindowModCanvasIO vw f =- case vpuiWindowLookupCanvas vw of- Nothing -> error "vpuiWindowModCanvas: plain VPUIWindow"- Just canvas -> - do- { - canvas' <- f canvas- ; return $ vpuiWindowSetCanvas vw canvas'- }---- | Update the canvas of the specified window, without IO-vpuiModCanvas :: VPUI -> WinId -> (VCanvas -> VCanvas) -> VPUI-vpuiModCanvas vpui winId modCanvas = - let modWindow vw = vpuiWindowModCanvas vw modCanvas- in vpuiUpdateWindow vpui winId modWindow---- | Update the canvas of the specified window, with IO-vpuiModCanvasIO :: VPUI -> WinId -> (VCanvas -> IO VCanvas) -> IO VPUI-vpuiModCanvasIO vpui winId modCanvas = - let modWindow vw = vpuiWindowModCanvasIO vw modCanvas- in vpuiUpdateWindowIO winId modWindow vpui--type WinId = String--data Workspace = Workspace {wsBox :: VBox, -- ^ container of the rest- wsCanvas :: VCanvas, -- ^ the canvas- wsButtonBar :: HBox,- wsStatusbar :: Statusbar}--data FunctionEditor = FunctionEditor {fedWindow :: Window,- fedWinTitle :: String,- fedFunction :: Function,- fedCanvas :: VCanvas- -- , fedUIRef :: IORef VPUI- }--fedFunctionName :: FunctionEditor -> String-fedFunctionName = functionName . fedFunction---- | Toolkit functions are organized in groups (rows) for presentation--- in a toolbox-data VPToolkit = VPToolkit {toolkitName :: String,- toolkitWidth :: Int, -- (-1) = don't care- toolkitRows :: [[Tool]]}---- | A Toolbox is a framed VBox with a set of Toolbars attached-data Toolbox = Toolbox {toolboxFrame :: GtkFrame- , toolboxVBox :: VBox}---- | ToolOp a is intended for a = VPUIWindow or VCanvas--- type ToolOp a --- = VPUI -> a -> ToolContext -> [Modifier] -> Double -> Double -> IO a--type ToolOp - = VPUI -> WinId -> ToolContext -> [Modifier] -> Double -> Double -> IO VPUI--type CanvasToolOp- = VCanvas -> ToolContext -> [Modifier] -> Double -> Double -> IO VCanvas--data Tool = Tool {toolName :: String, -- the tool's name-- -- what to do when the tool is selected from the toolbox- toolActivated :: VCanvas -> IO VCanvas,-- -- what to do to apply the tool to a point on the canvas- toolOp :: ToolOp- }---- | A helper for making toolOps from actions on VCanvas--toToolOpVW :: CanvasToolOp -> ToolOp-toToolOpVW vcOp vpui winId toolContext mods x y = do- {- let vw = vpuiGetWindow vpui winId- canv = vpuiWindowGetCanvas vw- ; canv' <- vcOp canv toolContext mods x y- ; let vw' = vpuiWindowSetCanvas vw canv'- ; return $ vpuiReplaceWindow vpui winId vw'- }- --- | ToolContext: The way a tool should be applied depends on --- where it is being used --data ToolContext = TCWorkspace - | TCCallFrame CanvFrame - | TCEditFrame CanvFrame- | TCExprNode -- ???------ | A canvas that can display multiple boxes representing --- expressions or function definitions or calls--data VCanvas = VCanvas {- vcLayout :: GtkLayout,- vcStyle :: Style,- vcGraph :: WGraph,- vcFrames :: [CanvFrame],- vcSize :: Size,- -- vcLocalEnv :: Env, -- only good for function editor, I think? - vcMousePos :: (Double, Double),- vcTool :: Maybe Tool, -- current tool on this canvas- vcActive :: Maybe Node, -- active node, if any- vcSelected :: Maybe Selection, -- selected node(s), if any- vcDragging :: Maybe Dragging -- what we're dragging, if anything- }---data Selection = SelectionNode {selNode :: G.Node}- | SelectionInlet {selNode :: G.Node,- selInEdge :: WEdge} -- numbered from 0- | SelectionOutlet {selNode :: G.Node,- selOutEdge :: WEdge} -- normally just 0- deriving (Eq, Read, Show)---- | A Dragging keeps track of the object (node) being dragged--- and the current mouse position.--data Dragging = Dragging { draggingNode :: G.Node,- draggingPosition :: Position- }- deriving (Eq, Read, Show)-
− Util.hs
@@ -1,136 +0,0 @@-module Util (- -- PARSER UTILITIES- SuccFail(Succ, Fail)- , parsef, parseInt, parseDouble, parseVerbatim- -- STRING UTILITIES- , par- -- OUTPUT UTILITIES- , putCatsLn- , putCatLn- , info- , fake- , stub-- -- ERROR REPORTING- , errcat- , errcats-- -- LIST UTILITIES- , map2, mapM2- , adjustAList, adjustAListM- , insertLastLast, insertLast- )--where--import Control.Monad-import Data.List---- SuccFail: the result of an attempt, succeeds or fails-data SuccFail a = Succ a -- value- | Fail String -- error message- deriving (Eq, Read, Show)--instance Monad SuccFail where- Succ val >>= f = f val- Fail err >>= _f = Fail err- return = Succ- fail = Fail---- PARSER UTILITIES--parsef :: (Read a) => String -> String -> String -> SuccFail a-parsef typeName inputLabel input =- case reads input of- [(value, "")] -> Succ value- [(_, more)] -> - Fail $ inputLabel ++ ": extra characters after " ++ - typeName ++ ": " ++ more- _ -> Fail $ inputLabel ++ ": cannot parse as " ++ - typeName ++ ": " ++ input--parseInt :: String -> String -> SuccFail Int-parseInt = parsef "integer"--parseDouble :: String -> String -> SuccFail Double-parseDouble = parsef "real number"--parseVerbatim :: String -> String -> SuccFail String-parseVerbatim _label = Succ---- | Enclose in parentheses, like a Lisp function call.--- Example: par "foo" ["x", "y"] = "(foo x y)"--par :: String -> [String] -> String-par f xs = "(" ++ unwords (f:xs) ++ ")"---- | Write a list of words, separated by spaces-putCatsLn :: [String] -> IO ()-putCatsLn = putStrLn . unwords---- | Write a list of words, not separated by spaces-putCatLn :: [String] -> IO ()-putCatLn = putStrLn . concat--info :: (Show t) => t -> IO ()-info = print--fake :: String -> IO ()-fake what = putStrLn $ "Faking " ++ what ++ "..."--stub :: String -> IO ()-stub name = putStrLn $ "Stub for " ++ name---- ERROR REPORTING---- | Signal an error using a list of strings to be concatenated-errcat :: [String] -> a-errcat = error . concat---- | Signal an error using a list of strings to be concatenated--- with spaces between (unwores).-errcats :: [String] -> a-errcats = error . unwords---- LIST UTILITIES---- | Generalization of map to lists of lists-map2 :: (a -> b) -> [[a]] -> [[b]]-map2 f rows = -- map (\ row -> map f row) rows- map (map f) rows---- | Generalization of mapM to lists of lists-mapM2 :: (Monad m) => (a -> m b) -> [[a]] -> m [[b]]-mapM2 f rows = -- mapM (\ row -> mapM f row) rows- mapM (mapM f) rows---- | Insert an item into a list of lists of items,--- making it the last element in the last sublist-insertLastLast :: [[a]] -> a -> [[a]]-insertLastLast xss x = init xss ++ [insertLast (last xss) x]---- | Insert an item in a list of items, making it the last element-insertLast :: [a] -> a -> [a]-insertLast xs x = xs ++ [x]---- | Update a value at a given key by applying a function.--- Similar to Data.Map.adjust.---- This implementation, using map, could be inefficient--- if the key to be updated is near the front of a long list.-adjustAList :: (Eq k) => k -> (v -> v) -> [(k, v)] -> [(k, v)]-adjustAList key f alist =- map (\ (k, v) -> if k == key then (k, f v) else (k, v)) - alist---- | Monadic generalization of adjustAList ---- Same caution re. inefficiency-adjustAListM :: (Eq k, Monad m) => - k -> (v -> m v) -> [(k, v)] -> m [(k, v)]-adjustAListM key f alist =- mapM (\ (k, v) -> - if k == key - then do { v' <- f v; return (k, v') }- else return (k, v))- alist
− WindowManagement.hs
@@ -1,1070 +0,0 @@-module WindowManagement- (- -- Window utilities- showWindow- , newWindowTitled-- , showWorkWin- , showWorkspaceWindow-- , showFedWin- , fedWindowTitle-- , showFunctionPadWindow- , newFunctionDialog-- , setWSCanvasCallbacks- , keyBindingsHelpText- )--where--import Control.Monad-import Control.Monad.Trans (liftIO) -- for use in EventM-import Data.IORef-import Data.List-import Data.Map as Map (fromList, lookup)-import Data.Map (Map)-import Data.Maybe--import Data.Graph.Inductive as G--import LittleGtk -import Graphics.UI.Gtk.Gdk.EventM--import CBMgr-import Expr-import Geometry-import GtkForeign as XCursor-import GtkUtil-import RPanel-import SiffML-import UITypes-import Util-import Workspace---- ------------------------------------------------------------------------ | Finding, creating, and initializing windows (VPUIWindow)---- | Find and show a window, if it exists.--- If not, create the window, put it in the vpui's window map,--- and initialize it and any auxiliary objects using the initWin function.--- The 3rd argument of initWin will be the window's title.--- Always presents the window (shows and raises).--- Returns a 3-tuple: the VPUIWindow contains the Window,--- and the Bool value is True if the Window is new--- (and therefore might need some further initialization).--- The third tuple element is an IORef to the VPUIWindow;--- it may be useful for setting up signal and event handling.--showWindow :: WinId -> CBMgr- -> (VPUI -> Window -> IO VPUIWindow) -- initializes Gtk Window- -> (VPUI -> WinId -> CBMgr -> IO ()) -- initializes callbacks- -> VPUI -> IO (VPUI, VPUIWindow, Bool)-showWindow winId uimgr initWin initCB vpui = do- {- (vpui', vw, isNew) <- - case vpuiTryGetWindow vpui winId of- Nothing ->- do- {- window <- newWindowTitled winId- ; widgetSetName window ("Sifflet-" ++ winId)- ; vwin <- initWin vpui window- ; let vpui' = vpuiInsertWindow vpui winId vwin- -- when window is destroyed, remove it from the map- ; uimgr (OnWindowDestroy window - (\ uiref ->- modifyIORef uiref (vpuiRemoveVPUIWindow winId)))- ; return (vpui', vwin, True)- }- Just vw ->- return (vpui, vw, False)- ; when isNew (initCB vpui' winId uimgr) -- add callbacks on new window- ; windowPresent (vpuiWindowWindow vw)- ; return (vpui', vw, isNew)- }---- | Default "do-nothing" add-callbacks function-initCBDefault :: VPUI -> WinId -> CBMgr -> IO ()-initCBDefault _vpui _winId _uimgr = return ()--newWindowTitled :: String -> IO Window-newWindowTitled winId = do- window <- windowNew- set window [windowTitle := winId]- widgetSetName window ("Sifflet-" ++ winId)- return window---- | Show a workspace window, with a given title, _not_ editing a function--showWorkWin :: VPUI -> WinId -> CBMgr -> IO VPUI-showWorkWin vpui winId uimgr = do- {- (vpui', _, _) <- showWorkspaceWindow winId uimgr Nothing vpui- ; return vpui'- }---- | Show a workspace window with a given title and maybe function to edit--showWorkspaceWindow :: WinId -> CBMgr -> Maybe Function -> VPUI- -> IO (VPUI, VPUIWindow, Bool)-showWorkspaceWindow winId cbmgr mfunc =- showWindow winId cbmgr (workspaceWindowInit cbmgr winId mfunc) - setWSCanvasCallbacks----- | Initialize a Workspace window.--- Called in sifflet.hs:Main from showWindow called from showWorkspaceWindow.--workspaceWindowInit :: CBMgr -> WinId -> Maybe Function -> VPUI -> Window- -> IO VPUIWindow-workspaceWindowInit cbmgr winId mfunc vpui window = do- {- let style = vpuiStyle vpui- env = vpuiGlobalEnv vpui- ; ws <- case mfunc of - Nothing -> workspaceNewDefault style (buildMainMenu cbmgr)- Just func -> workspaceNewEditing style env func- ; set window [windowTitle := winId, containerChild := wsBox ws]-- ; widgetShowAll window- ; windowPresent window-- ; return $ VPUIWorkWin ws window- }---- Menu specs here need to coordinate accelerators (shortcuts)--- with keyBindingsList in WindowManagement.hs--buildMainMenu :: CBMgr -> VBox -> IO ()-buildMainMenu cbmgr vbox = do- {- -- menu bar - let mspecs = - [MenuSpec "File"- [ -- "new" isn't implemented yet- -- MenuItem "New ..." menuFileNew- -- , - -- Temporarily disabling file I/O operations- MenuItem "Open ... (C-o)" (menuFileOpen cbmgr)- , MenuItem "Save (C-s)" menuFileSave- , MenuItem "Save as ..." menuFileSaveAs- , MenuItem "Quit (C-q)" menuFileQuit]- , MenuSpec "Functions"- [MenuItem "New ... (n)"- (newFunctionDialog "ignore" cbmgr)- , MenuItem "Function Pad"- (showFunctionPadWindow cbmgr)]- , MenuSpec "Help"- [MenuItem "Help ..." showHelpDialog- , MenuItem "Complaints and praise ..." showBugs- , MenuItem "About ..." showAboutDialog]- ]- ; menubar <- createMenuBar mspecs cbmgr- ; boxPackStart vbox menubar PackNatural 0-}---- | Show a function editor window = a workspace window --- editing a given function.--- Use argNames for a new function; ignore them if funcName is bound.--showFedWin :: CBMgr -> String -> [String] -> VPUI -> IO VPUI-showFedWin cbmgr funcName argNames vpui = do- {- ; let initEnv = vpuiGlobalEnv vpui- function = case envLookupFunction initEnv funcName of- Nothing -> newUndefinedFunction funcName argNames- Just func -> func- winId = fedWindowTitle funcName-- ; (vpui', vw, isNew) <- showWorkspaceWindow winId cbmgr (Just function) vpui-- ; if isNew- then do- {- let canvas = vpuiWindowGetCanvas vw- -- ** Can this use vpuiAddFrame?- ; canvas' <- vcAddFrame canvas (FunctoidFunc function) - Nothing EditFrame- initEnv 0 0 0 Nothing- ; canvas'' <- - case vcFrames canvas' of- [] -> info "showFedWin: ERROR: no frame on canvas" >> - return canvas'- _:_:_ -> - info "showFedWin: ERROR: too many frames on canvas" >> - return canvas'- [frame] -> editFunction canvas' frame - ; addArgToolButtons cbmgr winId (functionArgNames function) vpui'- ; addApplyCloseButtons cbmgr winId vpui'- ; return (vpuiReplaceWindow vpui' winId - (vpuiWindowSetCanvas vw canvas''))- }- else return vpui'- }--fedWindowTitle :: String -> WinId-fedWindowTitle funcName = "Edit " ++ funcName--updateFunctionPadIO :: String -> (RPanel -> IO RPanel) -> VPUI -> IO VPUI-updateFunctionPadIO padName update =- let updateWindow vw =- case vw of- FunctionPadWindow window rpAList ->- do- {- rpAList' <- adjustAListM padName update rpAList- ; return (FunctionPadWindow window rpAList')- }- _ -> return vw- in vpuiUpdateWindowIO "Function Pad" updateWindow--showFunctionPadWindow :: CBMgr -> VPUI -> IO VPUI-showFunctionPadWindow cbmgr vpui = - let initWindow _vpui window = do- {- -- widgetSetName window "SiffletFunctionPadWindow"- ; vbox <- vBoxNew False 0 -- non-homogenous, 0 padding- ; set window [containerChild := vbox]-- ; let rpnames = ["Base", "Examples", "My Functions"]- ; rps <- mapM (makeFunctionPadPanel cbmgr) rpnames- ; mapM_ (\ rp -> boxPackStart vbox (rpanelRoot rp) PackNatural 0)- rps-- ; windowMove window 5 5- ; widgetShowAll window -- redundant?- ; windowPresent window -- redundant?-- ; return $ FunctionPadWindow window (zip rpnames rps) - -- ^^ maybe need reference only the "My Functions" panel though- }- in do- {- (vpui', _, windowIsNew) <- - showWindow functionPadWinId cbmgr initWindow initCBDefault vpui- -- "My Functions" default is empty; add any user-defined- -- functions in the environment to it- ; if windowIsNew- then addUserFunctions cbmgr vpui'- else return vpui'- }--functionPadWinId :: String-functionPadWinId = "Function Pad"--addUserFunctions :: CBMgr -> VPUI -> IO VPUI-addUserFunctions cbmgr vpui =- let names = map fst (vpuiUserEnvAList vpui)- update rp = do- {- buttons <- mapM (makeToolButton cbmgr . functionTool) names- ; rp' <- rpanelAddWidgets rp (zip names buttons)- ; widgetShowAll (rpanelRoot rp')- ; return rp'- } - in updateFunctionPadIO "My Functions" update vpui--makeFunctionPadPanel :: CBMgr -> String -> IO RPanel-makeFunctionPadPanel cbmgr name =- let VPToolkit _ width toolrows = - case Map.lookup name defaultVPUIToolkits of- Nothing ->- errcats ["makeFunctionPadPanel:",- "can't find toolkit definition:", name]- Just atoolkit -> atoolkit- in do- {- buttonRows <- makeToolButtonRows cbmgr toolrows- :: IO [[(String, Button)]]- ; rp <- newRPanel name 3 3 width- ; rpanelAddRows rp buttonRows- }--makeToolButtonRows :: CBMgr -> [[Tool]] -> IO [[(String, Button)]]-makeToolButtonRows cbmgr toolRows = - mapM2 (makeNamedToolButton cbmgr) toolRows--makeNamedToolButton :: CBMgr -> Tool -> IO (String, Button)-makeNamedToolButton cbmgr tool = do- {- button <- makeToolButton cbmgr tool- ; return (toolName tool, button)- }--makeToolButton :: CBMgr -> Tool -> IO Button-makeToolButton cbmgr tool = do- {- button <- buttonNewWithLabel (toolName tool)- ; cbmgr (AfterButtonClicked button- ((flip modifyIORefIO) - (forallWindowsIO (vpuiWindowSetTool tool))))- ; return button- }---- | Add a tool button to the function pad window in a specified panel-addFunctionPadToolButton :: CBMgr -> String -> Tool -> VPUIWindow - -> IO VPUIWindow-addFunctionPadToolButton cbmgr panelId tool vw = - case vw of- FunctionPadWindow window panelAList ->- let adjustPanel :: RPanel -> IO RPanel- adjustPanel rp = do- {- -- make the tool button from the tool- button <- makeToolButton cbmgr tool- -- add it to the panel- ; rp' <- rpanelAddWidget rp (toolName tool) button- ; widgetShowAll (rpanelRoot rp')- ; return rp'- }- in do- {- panelAList' <- adjustAListM panelId adjustPanel panelAList- ; return $ FunctionPadWindow window panelAList'- }- _ -> return vw----- | Ask user for new function name and arguments,--- then begin editing the function.--newFunctionDialog :: WinId -> CBMgr -> VPUI -> IO VPUI-newFunctionDialog _winId cbmgr vpui =- -- _winId is ignored, but needed for use in KeyBindingsList- let reader :: Reader [String] (String, [String])- reader inputLines =- case inputLines of- [fname, fargs] ->- return (fname, words fargs)- _ -> fail "wrong number of lines"- in do- {- inputDialog <- - createEntryDialog "New Function"- ["Function name", "Argument names (space between)"]- ["", ""]- reader- (-1)- ; values <- runEntryDialog inputDialog- ; case values of- Nothing -> return vpui- Just (name, args) -> editNewFunction cbmgr name args vpui- }---- --------------------------------------------------------------- Implementation of menu commands---- -- | Create a new file, but what does this mean?---- menuFileNew :: VPUI -> IO VPUI--- menuFileNew vpui = putStrLn "Not implemented: \"New\"" >> return vpui--- -- Notes for future implementation:--- -- checkChangesAndContinue vpui ...----- | Quit from Sifflet--menuFileQuit :: VPUI -> IO VPUI-menuFileQuit vpui = checkForChanges vpui "quit" False vpuiQuit---- | Open a file (load its function definitions)--menuFileOpen :: CBMgr -> VPUI -> IO VPUI-menuFileOpen cbmgr vpui =- checkForChanges vpui "open file" True (continueFileOpen cbmgr)---- | Offer to save changes, if any, and continue with the continuation.--- The continuation gets the current vpui if there are no changes--- or if the offer to save is rejected; otherwise, it gets a--- vpui which knows it has saved its last changes.--- The message, if any, is a confirmation that the file was--- saved and that we are going on to the next operation ----- useful for open file, but not for quit.--checkForChanges :: VPUI -> String -> Bool -> (VPUI -> IO VPUI) -> IO VPUI-checkForChanges vpui beforeOperation acknowledge continue =- let mAckIfSaved vpui' = - when (not (vpuiFileChanged vpui') && acknowledge)- (- showInfoMessage "Changes saved" - ("Your changes are now saved; " ++- "proceeding to " ++- beforeOperation ++ ".")- ) - >>- return vpui'- labels = ["Save them", - "Throw them away", - "Cancel " ++ beforeOperation]- actions = [menuFileSave vpui >>= mAckIfSaved >>= continue, -- save- return vpui >>= continue, -- throw away- return vpui] -- cancel- offerSaveAndContinue = showChoicesDialog "Save changes?"- ("There are unsaved changes. " ++- "Before you " ++ beforeOperation ++- ", would you ...")- labels- actions- - in if vpuiFileChanged vpui- then offerSaveAndContinue- else continue vpui---- | Continue with opening the file, after having possibly saved changes-continueFileOpen :: CBMgr -> VPUI -> IO VPUI-continueFileOpen cbmgr vpui = do- mpath <- showDialogFileOpen vpui- case mpath of- Nothing -> return vpui- Just filePath ->- do- {- loadResult <- loadFile vpui filePath- ; case loadResult of- Fail msg ->- showErrorMessage msg >> return vpui- Succ (vpui', functions) -> - let title = "My Functions"- updatePad rp =- -- Figure out which functions are new,- -- i.e., not already on the pad- let oldNames = concat (rpanelContent rp)- loadedNames = map functionName functions- -- use set difference to avoid duplicates- newNames = loadedNames \\ oldNames- newTools = map functionTool newNames- in do - {- ; newPairs <- - mapM (makeNamedToolButton cbmgr) newTools- ; rp' <- rpanelAddWidgets rp newPairs- ; widgetShowAll (rpanelRoot rp)- ; return rp'- }- in do- {- vpui'' <- - showFunctionPadWindow cbmgr vpui' >>=- updateFunctionPadIO title updatePad - ; return $ vpui'' {vpuiFilePath = mpath, - vpuiFileEnv = vpuiGlobalEnv vpui'- }- }- }--showDialogFileOpen :: VPUI -> IO (Maybe FilePath)-showDialogFileOpen _vpui = do- chooser <- fileChooserDialogNew- (Just "Open file ...") -- default title- Nothing -- transient parent of the dialog- FileChooserActionOpen- [("Open", ResponseOk), ("Cancel", ResponseCancel)] -- buttons- result <- runDialogM (toDialog chooser) chooser fileChooserGetFilename- return result--loadFile :: VPUI -> FilePath -> IO (SuccFail (VPUI, [Function]))-loadFile vpui filePath = do- {- functions <- consumeFile xmlToFunctions filePath- ; case functions of- [Functions fs] ->- let vpui' = foldl bindFunction vpui fs- in return (Succ (vpui', fs))- _ ->- return (Fail "file format error")-- }--bindFunction :: VPUI -> Function -> VPUI-bindFunction vpui function =- let env = vpuiGlobalEnv vpui- Function (Just name) _argTypes _resType _impl = function- env' = envIns env name (VFun function)- in vpui {vpuiGlobalEnv = env'}--menuFileSave :: VPUI -> IO VPUI-menuFileSave vpui =- case vpuiFilePath vpui of- Nothing -> menuFileSaveAs vpui- Just filePath -> saveFile vpui filePath--menuFileSaveAs :: VPUI -> IO VPUI-menuFileSaveAs vpui = do- mpath <- showDialogFileSaveAs vpui- case mpath of- Nothing -> return vpui -- canceled- Just filePath -> saveFile vpui filePath--showDialogFileSaveAs :: VPUI -> IO (Maybe FilePath)-showDialogFileSaveAs _vpui = do- chooser <- fileChooserDialogNew- (Just "Save file as ...") -- title- Nothing -- transient parent of the dialog- FileChooserActionSave- [("Save", ResponseOk), ("Cancel", ResponseCancel)] -- buttons- result <- runDialogM (toDialog chooser) chooser fileChooserGetFilename- print ("dialog result", result)- return result---- | Returns the updated VPUI with updated fields--- vpuiFilePath and vpuiFileEnv---- What about IO errors? ******--saveFile :: VPUI -> FilePath -> IO VPUI-saveFile vpui filePath = - let functions = Functions (map (valueFunction . snd)- (vpuiUserEnvAList vpui))- in produceFile functions filePath >>- return vpui {vpuiFilePath = Just filePath, - vpuiFileEnv = vpuiGlobalEnv vpui}---- | Text shown by the help dialog-helpText :: String-helpText =- unlines ["Functions menu:",- " \"New\" enters a dialog to create a new function.",- " \"Function pad\" raises the function pad window.",- "Keystroke shortcuts for the menu commands are shown " ++- "using \"C-\" for Control. For example, Quit " ++- "is C-q, meaning Control+Q.",- "",- "In a function editor, right-click for the context menu.",- "",- "For more help, please visit the Sifflet web site,",- "http://mypage.iu.edu/~gdweber/software/sifflet/",- "especially the Sifflet Tutorial:",- "http://mypage.iu.edu/~gdweber/software/sifflet/doc/tutorial.html"- ]---- | Show the help dialog-showHelpDialog :: MenuItemAction-showHelpDialog vpui = showInfoMessage "Sifflet Help" helpText >> return vpui---- | How to report bugs-bugsText :: String-bugsText =- unlines ["To report bugs, please send mail to " ++ bugReportAddress,- "and mention \"Sifflet\" in the Subject header.",- "To send praise, follow the same procedure.",- "Seriously, whether you like Sifflet or dislike it,",- "I'd like to hear from you."- ]--bugReportAddress :: String-bugReportAddress = concat ["gdweber", at, "iue", punctum, "edu"]- where at = "@"- punctum = "."--showBugs :: MenuItemAction-showBugs vpui = showInfoMessage "Reporting bugs" bugsText >> return vpui---- | Text for the About dialog-aboutText :: String-aboutText =- unlines ["Sifflet version " ++ siffletVersionString,- "Copyright (C) 2010 Gregory D. Weber",- "",- "BSD3 License",- "",- "Sifflet home page:",- "http://mypage.iu.edu/~gdweber/software/sifflet/"- ]---- | The software version number.--- See ACTION: RELEASE CHECKLIST for a list of--- places where this version number needs to be synchronized.-siffletVersionString :: String-siffletVersionString = "0.1.7"--showAboutDialog :: MenuItemAction-showAboutDialog vpui = showInfoMessage "About Sifflet" aboutText >> return vpui---- -------------------------------------------------------------------------- Moved here from Callbacks.hs:--setWSCanvasCallbacks :: VPUI -> WinId -> CBMgr -> IO ()-setWSCanvasCallbacks vpui winId cbmgr = do- {- let vw = vpuiGetWindow vpui winId- window = vpuiWindowWindow vw- ; case vpuiWindowLookupCanvas vw of- Nothing ->- errcats ["setWSCanvasCallbacks: VPUIWindow is not a VPUIWorkWin",- "and has no canvas"]- Just canvas ->- do- {- -- Notice when the window size is changed- ; cbmgr (OnWindowConfigure window (configuredCallback winId))-- -- Keypress events -- send to canvas window because the Gtk.Layout- -- cannot receive them (why ever not?)- ; cbmgr (OnWindowKeyPress window (keyPressCallback winId cbmgr))-- -- Send remaining events to the Gtk.Layout (why?)- ; let layout = vcLayout canvas- ; widgetSetCanFocus layout True- ; cbmgr (OnLayoutExpose layout (exposedCallback winId))-- -- Mouse events - ; widgetAddEvents layout [PointerMotionMask]- ; cbmgr (OnLayoutMouseMove layout (mouseMoveCallback winId))- ; cbmgr (OnLayoutButtonPress layout - (buttonPressCallback winId cbmgr))- ; cbmgr (OnLayoutButtonRelease layout (buttonReleaseCallback winId))- }- }---- | Context menu command to edit the function displayed in --- a CallFrame--editFrameFunction :: CBMgr -> CanvFrame -> VPUI -> IO VPUI-editFrameFunction cbmgr frame vpui =- let func = cfFunctoid frame- in showFedWin cbmgr (functoidName func) (functoidArgNames func) vpui---- | Create a new function, add it to the global environment --- with body undefined, and start editing it in a new window. --- Also update and show "My Functions" toolbox and--- update its toolkit.--editNewFunction :: CBMgr -> String -> [String] -> VPUI -> IO VPUI-editNewFunction cbmgr name args vpui = - let updateEnv :: VPUI -> IO VPUI- updateEnv vpui' =- let env = vpuiGlobalEnv vpui'- env' = envIns env name (VFun (newUndefinedFunction name args))- in return $ vpui' {vpuiGlobalEnv = env'} - in - -- Show window first, with the *old* functions- showFunctionPadWindow cbmgr vpui >>=- updateEnv >>=- vpuiUpdateWindowIO functionPadWinId- (addFunctionPadToolButton cbmgr "My Functions" - (functionTool name)) >>=- showFedWin cbmgr name args--configuredCallback :: WinId -> IORef VPUI -> EventM EConfigure Bool-configuredCallback winId uiref =- tryEvent $ do- {- (w, h) <- eventSize- ; liftIO $ modifyIORef uiref (handleConfigured winId w h)- -- We *must* "stop the event", forcing the event handler - -- to return False, or else the canvas remains "squeezed in"- -- -- Weird!!- ; stopEvent- }---- | Handle the Configured event.-handleConfigured :: WinId -> Int -> Int -> VPUI -> VPUI-handleConfigured winId width height vpui = - let vw = vpuiGetWindow vpui winId- vw' = vpuiWindowModCanvas vw - (atLeastSize (Size (fromIntegral width) (fromIntegral height)))- in vpuiReplaceWindow vpui winId vw'--exposedCallback :: WinId -> IORef VPUI -> EventM EExpose Bool-exposedCallback winId uiref =- tryEvent $ do- {- clipbox <- eventArea- ; liftIO (readIORef uiref >>= handleExposed winId clipbox)- }---- | Handle the Exposed event, should be called only for a window--- with a canvas-handleExposed :: WinId -> Rectangle -> VPUI -> IO ()-handleExposed winId clipbox vpui = - let vw = vpuiGetWindow vpui winId -- error if not found- in case vpuiWindowLookupCanvas vw of- Nothing -> info "handleExposed: no canvas found!"- Just canvas -> drawCanvas canvas clipbox --data KeyBinding = KeyBinding {kbGtkKeyName :: String,- kbAltKeyName :: Maybe String, -- for humans- kbRequiredModifiers :: [Modifier],- kbDescription :: String,- kbAction :: KeyAction}--data KeyAction - = KeyActionST (WinId -> VPUI -> IO VPUI) -- ^ set a tool- | KeyActionDG (WinId -> CBMgr -> VPUI -> IO VPUI) -- ^ start a dialog- | KeyActionModIO (CBMgr -> VPUI -> IO VPUI) -- ^ modify VPUI with IO- | KeyActionHQ (VPUI -> IO ()) -- ^ help or quit---- | Key bindings map. This is derived from keyBindingsList.-keyBindingsMap :: Map String KeyBinding-keyBindingsMap = Map.fromList [(kbGtkKeyName kb, kb) | kb <- keyBindingsList]---- | KeyBinding list for workspace and function editor windows.--keyBindingsList :: [KeyBinding]-keyBindingsList = - [- -- Bindings to set tools- KeyBinding "c" Nothing [] "connect" - (KeyActionST (vpuiSetTool ToolConnect))- , KeyBinding "d" Nothing [] "disconnect" - (KeyActionST (vpuiSetTool ToolDisconnect))- , KeyBinding "i" Nothing [] "if" (KeyActionST (vpuiSetTool ToolIf))- , KeyBinding "m" Nothing [] "move" (KeyActionST (vpuiSetTool ToolMove))- , KeyBinding "KP_Delete" (Just "Keypad-Del") [] "delete" - (KeyActionST (vpuiSetTool ToolDelete))-- -- Bindings to start dialogs- , KeyBinding "n" Nothing [] "new function" (KeyActionDG newFunctionDialog)- , KeyBinding "f" Nothing [] "function" (KeyActionDG showFunctionEntry)- , KeyBinding "l" Nothing [] "literal" (KeyActionDG showLiteralEntry)-- -- Help and quit-- , KeyBinding "question" (Just "?") [] "help" (KeyActionHQ vpuiKeyHelp)-- -- Shortcuts for menu commands (GTK "accelerators", but not done- -- in the standard GTK way).- -- These need to be coordinated with buildMainMenu,- -- in WindowManagement.hs---- Oops! Binding Ctrl+F here interferes with binding just plain f above.--- , KeyBinding "f" (Just "Control-f") [Control] "function-pad"--- (KeyActionModIO showFunctionPadWindow)-- , KeyBinding "o" (Just "Control-o") [Control] "open"- (KeyActionModIO menuFileOpen)- , KeyBinding "s" (Just "Control-s") [Control] "save"- (KeyActionModIO (\ _cbmgr -> menuFileSave))- , KeyBinding "q" (Just "Control-q") [Control] "quit" - (KeyActionHQ (\ vpui -> menuFileQuit vpui >> return ()))- ]---- | Unused argument needed for key bindings-vpuiKeyHelp :: VPUI -> IO ()-vpuiKeyHelp _vpui = putStrLn keyBindingsHelpText---- | Help text built from key bindings-keyBindingsHelpText :: String-keyBindingsHelpText = - let add :: String -> KeyBinding -> String- add result (kb@KeyBinding {kbAltKeyName = mkey}) =- concat [result, " ", - case mkey of - Nothing -> kbGtkKeyName kb- Just akey -> akey, - " = ", kbDescription kb, "\n"]- in foldl add "" keyBindingsList---- | What to do when a key is pressed-keyPressCallback :: WinId -> CBMgr -> IORef VPUI -> EventM EKey Bool-keyPressCallback winId cbmgr uiref =- tryEvent $ do- {- kname <- eventKeyName- ; mods <- eventModifier- -- ; liftIO $ print mods-- ; let giveUp = - -- liftIO (info ("Unrecognized key: " ++ kname)) >> - stopEvent-- ; case Map.lookup kname keyBindingsMap of- Nothing -> - giveUp- Just keyBinding -> - if checkMods (kbRequiredModifiers keyBinding) mods- then liftIO $ - case kbAction keyBinding of- KeyActionModIO f0 ->- -- update with IO- modifyIORefIO uiref (f0 cbmgr)- KeyActionST f1 ->- -- update with IO and window ID- modifyIORefIO uiref (f1 winId)- KeyActionDG f2 ->- -- update with IO and cbmgr to set further callbacks- modifyIORefIO uiref (f2 winId cbmgr)- KeyActionHQ f3 ->- -- no update, no cbmgr, no further callbacks- readIORef uiref >>= f3- else giveUp- }--buttonPressCallback :: WinId -> CBMgr -> IORef VPUI -> EventM EButton Bool-buttonPressCallback winId cbmgr uiref =- tryEvent $ do- {- ; (x, y) <- eventCoordinates- ; mouseButton <- eventButton- ; mods <- eventModifier- ; timestamp <- eventTime- ; liftIO - (modifyIORefIO uiref - (handleButtonPress winId cbmgr mouseButton x y mods timestamp))- }--mouseMoveCallback :: WinId -> IORef VPUI -> EventM EMotion Bool-mouseMoveCallback winId uiref =- tryEvent $ do- {- (x, y) <- eventCoordinates- ; mods <- eventModifier- ; liftIO (modifyIORefIO uiref (handleMouseMove winId x y mods))- }--buttonReleaseCallback :: WinId -> IORef VPUI -> EventM EButton Bool-buttonReleaseCallback winId uiref =- tryEvent $ do- {- mouseButton <- eventButton- ; liftIO (modifyIORefIO uiref (handleButtonRelease winId mouseButton))- }---- | Handle the ButtonPress event. Should be called only for a window--- with a canvas.-handleButtonPress :: WinId -> CBMgr -> MouseButton - -> Double -> Double -- x, y- -> [Modifier] -> TimeStamp -- timestamp not needed?- -> VPUI ->IO VPUI-handleButtonPress winId cbmgr mouseButton x y mods timestamp vpui =- let vw = vpuiGetWindow vpui winId- in case vpuiWindowLookupCanvas vw of- Nothing -> info "handleButtonPress: no canvas found!" >>- return vpui- Just canvas ->- case whichFrame canvas x y of- Nothing ->- case vcTool canvas of- Nothing -> return vpui- Just tool -> toolOp tool vpui winId TCWorkspace mods x y - Just frame -> - frameButtonPressed winId cbmgr vw- frame mods (x, y)- mouseButton timestamp vpui---- | Handles button pressed in a frame-frameButtonPressed :: WinId -> CBMgr -> VPUIWindow -> CanvFrame - -> [Modifier] -> (Double, Double) -> MouseButton - -> TimeStamp - -> VPUI- -> IO VPUI-frameButtonPressed winId cbmgr vw frame mods (x, y) mouseButton timestamp vpui =- let retWrap :: VPUIWindow -> IO VPUI- retWrap = return . vpuiReplaceWindow vpui winId- in case mouseButton of- LeftButton ->- if cfPointInHeader frame x y - then beginFrameDrag vw frame x y >>= retWrap- else if cfPointInFooter frame x y- then leftButtonPressedInFrameFooter vw frame >>= retWrap- else frameBodyButtonPressed vpui winId frame - mouseButton mods x y- MiddleButton -> return vpui- RightButton -> - offerContextMenu winId cbmgr frame RightButton timestamp >> - return vpui- OtherButton _ -> return vpui---- | Handles button pressed in the body of a frame--- frameBodyButtonPressed needs VPUIWindow because it calls a toolOp.--- mb (mouse button) is unused, but might be used later.-frameBodyButtonPressed :: VPUI -> WinId -> CanvFrame - -> MouseButton -> [Modifier] -> Double -> Double - -> IO VPUI-frameBodyButtonPressed vpui winId frame _mb mods x y = do- {- let vw = vpuiGetWindow vpui winId- canvas = vpuiWindowGetCanvas vw- mnode = vcanvasNodeAt canvas (Position x y)- ; case mnode of- Nothing -> - case vcTool canvas of- Nothing -> return vpui- Just tool -> toolOp tool vpui winId (cfContext frame) mods x y- Just node -> - do- {- vw' <- openNode vw node- ; return $ vpuiReplaceWindow vpui winId vw'- }- }---- | Handles left button pressed in the footer of a frame-leftButtonPressedInFrameFooter ::- VPUIWindow -> CanvFrame -> IO VPUIWindow-leftButtonPressedInFrameFooter vw frame = - let canvas = vpuiWindowGetCanvas vw- in case frameType frame of- CallFrame -> - -- request argument values and evaluate call- if cfEvalReady frame- then do- canvas' <- vcEvalDialog canvas frame- return $ vpuiWindowSetCanvas vw canvas'- else return vw- EditFrame ->- -- ignore- return vw---- | Handles beginning of mouse-drag-beginFrameDrag :: VPUIWindow -> CanvFrame -> Double -> Double - -> IO VPUIWindow-beginFrameDrag vw frame x y = - let canvas = vpuiWindowGetCanvas vw- window = vpuiWindowWindow vw- dragging = Dragging {draggingNode = cfFrameNode frame,- draggingPosition = Position x y}- canvas' = canvas {vcDragging = Just dragging}- in setCursor window XCursor.Fleur >> - (return $ vpuiWindowSetCanvas vw canvas')---- | Handle mouse move event-handleMouseMove :: WinId -> Double -> Double -> [Modifier] -> VPUI -> IO VPUI-handleMouseMove winId x y mods vpui =--- Needs to be in IO because of drawWindowInvalidateRect- let vw = vpuiGetWindow vpui winId- in case vpuiWindowLookupCanvas vw of- Nothing -> - info "SQUAWK! No canvas! Shouldn't happen!" >>- return vpui -- shouldn't happen- Just canvas -> - do- {- -- Highlight the active node, if any- let active = vcActive canvas- active' = vcanvasNodeAt canvas (Position x y)-- invalidate :: DrawWindow -> Maybe G.Node -> IO ()- invalidate win mnode =- case mnode of- Nothing -> return ()- Just node -> - drawWindowInvalidateRect win - (vcanvasNodeRect canvas node) False-- ; when (active /= active') $- do- {- win <- layoutGetDrawWindow (vcLayout canvas)- ; invalidate win active- ; invalidate win active'- }- -- if dragging, continue drag- ; canvas' <- continueDrag (canvas {vcActive = active', - vcMousePos = (x, y)}) - mods x y- ; let vw' = vpuiWindowSetCanvas vw canvas'- ; return $ vpuiReplaceWindow vpui winId vw'- }--continueDrag :: VCanvas -> [Modifier] -> Double -> Double -> IO VCanvas-continueDrag canvas mods x y =- case vcDragging canvas of- Nothing -> return canvas- Just dragging -> - let graph = vcGraph canvas- dnode = draggingNode dragging- wnode = wlab graph dnode- Position oldX oldY = draggingPosition dragging- (dx, dy) = (x - oldX, y - oldY)- in- case wnode of- WSimple _ -> - continueDragSimple canvas dragging dnode mods x y dx dy - WFrame frameNode -> - continueDragFrame canvas dragging frameNode x y dx dy --continueDragSimple :: VCanvas -> Dragging -> G.Node -> [Modifier] - -> Double -> Double -> Double -> Double -> IO VCanvas-continueDragSimple canvas dragging simpleNode mods x y dx dy =- let graph = vcGraph canvas- frame = nodeContainerFrame canvas graph simpleNode- dragging' = dragging {draggingPosition = Position x y}- translateSelection = if checkMods [Shift] mods- then translateTree- else translateNode- graph' = translateSelection dx dy graph simpleNode- canvas' = canvas {vcGraph = graph'}- in vcInvalidateFrameWithParent canvas graph frame >>- return (canvas' {vcDragging = Just dragging'})--continueDragFrame :: - VCanvas -> Dragging -> G.Node -> - Double -> Double -> Double -> Double -> IO VCanvas-continueDragFrame canvas dragging frameNode x y dx dy =- let graph = vcGraph canvas- frame = vcGetFrame canvas graph frameNode- frame' = translateFrame frame dx dy- graph' = grTranslateFrameNodes graph frame dx dy- canvas' = vcUpdateFrameAndGraph canvas frame' graph'- dragging' = Just dragging {draggingPosition = Position x y}- in - -- Tell the GUI about the changes so they will be redrawn- -- Mark the frame changed so it will be redrawn- frameChanged canvas graph frame graph' frame' >>- -- Also, any frames opened from nodes of this frame- mapM_ (\f -> frameChanged canvas graph f graph' f)- (vcFrameSubframes canvas frame) >>- -- Return the modified canvas- return (canvas' {vcDragging = dragging'})--handleButtonRelease :: WinId -> MouseButton -> VPUI -> IO VPUI-handleButtonRelease winId mouseButton vpui =- case mouseButton of- LeftButton -> - -- End drag- let vw = vpuiGetWindow vpui winId- canvas = vpuiWindowGetCanvas vw- window = vpuiWindowWindow vw- vw' = vpuiWindowSetCanvas vw (canvas {vcDragging = Nothing})- vpui' = vpuiReplaceWindow vpui winId vw'- in setCursor window XCursor.LeftPtr >>- return vpui'- _ -> return vpui---- | Show a context menu for mouse click in a frame.-offerContextMenu :: WinId -> CBMgr -> CanvFrame - -> MouseButton -> TimeStamp -> IO ()-offerContextMenu winId cbmgr frame button timestamp = do- -- Needs CBMgr to specify menu actions.- {- let menuSpec = - MenuSpec "Context Menu" (contextMenuOptions winId cbmgr frame)- ; menu <- createMenu menuSpec cbmgr- ; widgetShowAll menu- ; menuPopup menu (Just (button, timestamp))- }---- | Options for context menu that depend on the frame type.--contextMenuOptions :: WinId -> CBMgr -> CanvFrame -> [MenuItemSpec]-contextMenuOptions winId cbmgr frame =- let typeDependentOptions :: [MenuItemSpec]- typeDependentOptions =- case frameType frame of- CallFrame -> - [MenuItem "Edit" (editFrameFunction cbmgr frame)- , MenuItem "Close" (\ vpui -> closeFrame vpui winId frame)]- EditFrame -> - [- -- The next items duplicate parts of keyBindingsList- MenuItem "CONNECT (c)" (vpuiSetTool ToolConnect winId)- , MenuItem "DISCONNECT (d)" (vpuiSetTool ToolDisconnect winId)- , MenuItem "IF (i)" (vpuiSetTool ToolIf winId)- , MenuItem "FUNCTION (f)" (showFunctionEntry winId cbmgr)- , MenuItem "LITERAL (l)" (showLiteralEntry winId cbmgr)- -- , ("CLEAR (not implemented)", clearFrame winId frame)- , MenuItem "MOVE (m)" (vpuiSetTool ToolMove winId)- , MenuItem "DELETE (KP-Del)" (vpuiSetTool ToolDelete winId)- ]- in typeDependentOptions ++- [--- ("Dump frame (debug)", --- \ vpui -> dumpFrame vpui winId frame >> return vpui)--- , ("Dump graph (debug)", \ vpui -> --- dumpGraph vpui winId >> return vpui)--- , ("--QUIT--", \ vpui -> vpuiQuit vpui >> return vpui)- ]
− Workspace.hs
@@ -1,20 +0,0 @@-{- Workspace.hs implements the graphical workspace of Sifflet -}--module Workspace - (- module Workspace.Canvas- , module Workspace.Frame- , module Workspace.Functoid- , module Workspace.Tools- , module Workspace.WGraph- , module Workspace.Workspace- )--where--import Workspace.Canvas-import Workspace.Frame-import Workspace.Tools-import Workspace.Functoid-import Workspace.WGraph-import Workspace.Workspace
− Workspace/Canvas.hs
@@ -1,980 +0,0 @@--- File: Canvas.hs--- Canvas and CanvFrame data and operations--module Workspace.Canvas- (- VCanvas(..), Selection(..), Dragging(..)- , atLeastSize- , cfContext- , connect- , disconnect- , drawCanvas- , editFunction- , frameChanged- , nodeContainerFrame- , pointSelection- , vcAddFrame- , vcClearSelection- , vcClearFrame- , vcCloseFrame- , vcEvalDialog- , vcFrameAddFunctoidNode- , vcFrameAddNode- , vcFrameDeleteNode- , vcFrameDeleteTree- , vcFrameSubframes- , vcGetFrame- , vcInvalidateFrameWithParent- , vcInvalidateBox- , vcUpdateFrameAndGraph- , vcanvasNew- , vcanvasNodeAt- , vcanvasNodeRect- , whichFrame - , callFrames- )--where--import Control.Monad-import Data.List as List--import Data.Graph.Inductive as G-import LittleGtk-import Graphics.Rendering.Cairo hiding (translate)--import Expr-import Geometry-import GtkUtil-import Tree as T-import TreeGraph-import TreeLayout-import UITypes-import Workspace.Frame-import Workspace.Functoid-import Workspace.WGraph-import Util---- Experimental:-enableDoubleBuffering :: Bool-enableDoubleBuffering = True--vcanvasNew :: Style -> Double -> Double -> IO VCanvas-vcanvasNew style width height = do- -- create gtkLayout (the "drawing canvas")- gtkLayout <- layoutNew Nothing Nothing- -- Turn double buffering on or off. - -- Normally, double buffering eliminates flicker,- -- but if the rendering is through the network,- -- it might be better to disable it.- -- See docs for Graphics.UI.Gtk.Gdk.DrawWindow- -- (drawWindow{Begin,End}PaintRegion), and- -- Graphics.UI.Gtk.Abstract.Widget- -- (widgetSetDoubleBuffered).- widgetSetDoubleBuffered gtkLayout enableDoubleBuffering-- -- create the VCanvas- let vCanvas = VCanvas {vcLayout = gtkLayout, vcStyle = style, - vcGraph = wgraphNew,- vcFrames = [],- -- | vcSize is the requested size of the- -- canvas (Gtk.Layout)- vcSize = Size width height,- -- but this is the requested size;- -- how can I get the actual, current size?- -- Answer: - -- layoutGetSize :: Layout -> IO (Int, Int)- -- removed: vcLocalEnv = env,- vcMousePos = (0, 0), -- ???- vcTool = Nothing,- vcDragging = Nothing,- vcActive = Nothing,- vcSelected = Nothing-- }- -- Most essential event handlers- _ <- onSizeRequest gtkLayout- (return (Requisition (round width) (round height)))- - return vCanvas--nodeContainerFrame :: VCanvas -> WGraph -> G.Node -> CanvFrame-nodeContainerFrame vcanvas g = vcGetFrame vcanvas g . nodeContainerFrameNode g---- Ask the VCanvas to find the frame whose frame node element is the--- given Node; it is an error if not found or if there is more than one.-vcGetFrame :: VCanvas -> WGraph -> Node -> CanvFrame-vcGetFrame vcanvas graph frameNode = - let frames = [f | f <- vcFrames vcanvas, cfFrameNode f == frameNode]- err phrase = errcats ["vcGetFrame", phrase,- "frameNode:", show frameNode, - "\nframes:", show frames,- "\ngraph:\n", show graph]- in case frames of- [frame] -> frame- [] -> err "no frame found"- (_:_:_) -> err "multiple frames found"---- | Ask the vcanvas to update the frame and install a new graph.--- Frames are identified by their frame nodes, so the new frame --- must have the same frame node as the old.--- It is an unreported error if there is not exactly one match.-vcUpdateFrameAndGraph :: VCanvas -> CanvFrame -> WGraph -> VCanvas-vcUpdateFrameAndGraph vcanvas newFrame newGraph =- let frames = vcFrames vcanvas- frameNode = cfFrameNode newFrame -- should match frameNode of old frame- frames' = - [if cfFrameNode f == frameNode then newFrame else f | f <- frames]- in vcanvas {vcFrames = frames', vcGraph = newGraph}---- | Like vcUpdateFrameAndGraph, but keep the canvas's old graph.-vcUpdateFrame :: VCanvas -> CanvFrame -> VCanvas-vcUpdateFrame vcanvas newFrame =- vcUpdateFrameAndGraph vcanvas newFrame (vcGraph vcanvas)---- Delete a frame from the vcanvas's frames ref--- This does not update the graph -- see vcCloseFrame for that.-vcDeleteFrame :: VCanvas -> CanvFrame -> VCanvas-vcDeleteFrame vcanvas frame =- let frames = vcFrames vcanvas- node = cfFrameNode frame- frames' = [f | f <- frames, cfFrameNode f /= node]- in vcanvas {vcFrames = frames'}---- RENDERING--- perhaps ought to be its own module---- *** Perhaps this ought to be called graphRenderFunctoid!--graphRenderFunctoidParts :: - Style -> Maybe Node -> Maybe Selection -> WGraph -> CanvFrame -> Render ()-graphRenderFunctoidParts style mact msel graph frame = - case cfFunctoid frame of- FunctoidFunc _ -> error "graphRenderFunctoidParts: not an edit frame"- FunctoidParts {} -> - graphRenderForest style mact msel graph - (nodeProperSimpleDescendants graph - (cfFrameNode frame))--graphRenderForest :: - Style -> Maybe Node -> Maybe Selection -> WGraph -> [G.Node] -> Render ()-graphRenderForest style mact msel graph roots = - let renderNode node = graphRenderTree style mact msel graph node False- in mapM_ renderNode roots--graphRenderTree :: Style -> Maybe Node -> Maybe Selection -> WGraph ->- G.Node -> Bool -> Render ()-graphRenderTree style mact msel graph rootNode fillBackground =- let loop :: Maybe Iolet -> G.Node -> Render ()- loop mInlet currentNode = do- -- Render the root- (inlets, outs) <-- graphRenderNode style mact msel graph currentNode mInlet- -- Render the subtrees- loopWithInlets 0 inlets (sortBy adjCompareEdge outs)- - -- loopWithInlets n inletPositions outs:- -- n = the current inlet number, starting from 0- -- inletPositions = the points to connect to on the parent- -- outs = a list of (child, edge) pairs (adjs)- -- going to *simple* children (i.e., not frame nodes)- -- There must be at least as many inlets as there are outs.- -- If the edge of the first outs equals n, we use the- -- first inletPosition. Otherwise we skip the inlet- -- but not out.- loopWithInlets :: Int -> [Iolet] -> [(G.Node, WEdge)] -> Render ()- loopWithInlets _n _is [] = return ()- loopWithInlets n (i:is) (a:as) =- -- n: number of child, i: inlet, a: adjacency (node, edge)- let (node, edge) = a in- if edge == WEdge n- then do- loop (Just i) node -- draw node with current inlet- loopWithInlets (n + 1) is as -- and draw the rest- else -- skip current inlet- loopWithInlets (n + 1) is (a:as) - - loopWithInlets _n [] (a:as) = - errcats ["loopWithInlets: insufficient inlets, with these",- "outs remaining:", show (a:as)]-- in do- graphStartRender style graph rootNode fillBackground- loop Nothing rootNode--graphStartRender :: Style -> WGraph -> G.Node -> Bool -> Render ()-graphStartRender style graph rootNode fillBackground = do- -- global actions: can be done once for the whole drawing- -- instead of once per subtree- -- Choose: Antialias{Default,None,Gray,Subpixel}- setAntialias AntialiasDefault-- -- draw the canvas background- setColor (styleNormalFillColor style)- let rootCtx = context graph rootNode- WSimple lroot = lab' rootCtx- BBox x y w' h' = nodeTreeBB lroot- when fillBackground $ do { rectangle x y w' h'; fill}-- -- now set up for the rest- -- setColor (styleNormalTextColor style)- setLineWidth (lineWidth style)---graphRenderNode :: - Style -> Maybe Node -> Maybe Selection -> WGraph ->- G.Node -> Maybe Iolet -> Render ([Iolet], [(G.Node, WEdge)])--- Returns a list of inlets and a list of "outs":--- a list of (child, edge) pairs (adjs) --- going to *simple* children only (not to frames formed--- by expanding a node).--- This can then be used if we wish to render the children of--- the node, as when rendering a tree.-graphRenderNode style mact msel graph node mInlet = - -- status of this node- let nodeActive = mact == Just node- mode = if nodeActive- then DrawActive- else case msel of- Nothing -> DrawNormal- Just sel ->- if selNode sel /= node then DrawNormal- else case sel of- SelectionNode _ -> DrawSelectedNode- SelectionInlet {selInEdge = WEdge i} ->- DrawSelectedInlet i- SelectionOutlet {selOutEdge = WEdge o} ->- DrawSelectedOutlet o- - connectInlet :: Iolet -> Double -> Double -> Render ()- connectInlet inlet tx ty = do- -- draw the line from the parent inlet to this node's outlet- let Position px py = ioletCenter inlet- setColor (styleNormalEdgeColor style)- moveTo px (py + snd (vtinypad style)) -- bottom of parent- lineTo tx (ty - fst (vtinypad style)) -- top of this node- stroke -- ctx = context graph node- lnode :: LayoutNode ExprNode- WSimple lnode = lab' ctx-- -- where to connect to this node- nodeBB = gnodeNodeBB (nodeGNode lnode)- xcenter = bbXCenter nodeBB- defaultInlet = Iolet (Geometry.Circle - (Position xcenter (bbBottom nodeBB)) 0)- inlets =- case gnodeInlets (nodeGNode lnode) of- [] -> replicate (length outs) defaultInlet- is -> is- - -- children (nodes and edges)- outs = lsuc' ctx :: [(G.Node, WEdge)]- -- omit links to frames opened from a node- outs' = [(child, edge) |- (child, edge) <- outs, nodeIsSimple graph child]-- in if length inlets < length outs'- then errcats ["graphRenderTree: insufficient inlets:", - show (length inlets, length outs'),- show (inlets, outs')]- else do-- -- Render the node- draw style mode lnode-- -- Connect to its parent (if any)- case mInlet of- Nothing -> return ()- Just inlet -> connectInlet inlet xcenter (bbTop nodeBB) -- return (inlets, outs')---- END OF RENDERING--- ------------------------------------------------------------------------- | Make nothing be selected--vcClearSelection :: VCanvas -> IO VCanvas-vcClearSelection canvas =- case vcSelected canvas of- Nothing -> return canvas- Just sel ->- let node = selectionNode sel- in do- vcInvalidateSimpleNode canvas node- return (canvas {vcSelected = Nothing})---- | The Graph Node of a Selection-selectionNode :: Selection -> G.Node-selectionNode sel =- case sel of- SelectionNode n -> n- SelectionInlet n _ -> n- SelectionOutlet n _ -> n---- | What is selected (if anything) at a point--pointSelection :: WGraph -> CanvFrame -> Position -> Maybe Selection-pointSelection graph frame point =- -- Try to find something to select at the point,- -- i.e., a node or an iolet on the node- case cfFunctoid frame of- FunctoidFunc _ -> error "graphFindFunctionPart: not an edit frame"- FunctoidParts {fpNodes = grNodes} ->- let layoutNodes = map (grExtractLayoutNode graph) grNodes- tuples = zip grNodes layoutNodes-- loop :: [(G.Node, LayoutNode ExprNode)] -> Maybe Selection- loop [] = Nothing- loop (t:ts) = -- (n:ns) =- let (gn, ln) = t -- graph node, tlo node- gnode = nodeGNode ln- inlets = gnodeInlets gnode- outlets = gnodeOutlets gnode- in- -- look at the ports first,- case pointIolet point 0 inlets of- Just i ->- Just (SelectionInlet gn (WEdge i))- Nothing ->- case pointIolet point 0 outlets of- Just o ->- Just (SelectionOutlet gn (WEdge o))- Nothing ->- -- try in the node proper- if pointInGNode point gnode- then- Just (SelectionNode gn)- else- -- try the remaining tuples- loop ts -- in loop tuples---- | Connect nodes--connect :: VCanvas -> G.Node -> WEdge -> G.Node -> WEdge -> IO VCanvas-connect canvas parent inlet child outlet = do- -- if parent and child are different,- -- connect the ith inlet of node parent- -- to the oth outlet of node child- -- provided that doing so would not create a cycle- -- parent -> child -> ... -> parent-- let graph = vcGraph canvas- if elem parent (reachable child graph)- then - do- showErrorMessage "Sorry, this connection would create a cycle."- return canvas- else - -- now we need to store a labeled edges (inlet -> outlet)- -- and to clear any previous connections of the two.- let graph' = grConnect graph parent inlet child outlet- in return $ canvas {vcGraph = graph'}---- | Disconnect nodes---- disconnect wouldn't need to be in the IO monad,--- except that it needs the same type signature as connect-disconnect :: VCanvas -> G.Node -> WEdge -> G.Node -> WEdge - -> IO VCanvas-disconnect canvas parent inlet child outlet = do- -- Opposite of connect, except we don't have to check for cycles- -- of any kind. We also reconnect the child to the frame node- -- as its "parent."- let graph = vcGraph canvas- graph' = grDisconnect graph parent inlet child outlet True- return $ canvas {vcGraph = graph'}--vcFrameAddFunctoidNode :: - VCanvas -> CanvFrame -> Functoid -> Double -> Double -> IO VCanvas-vcFrameAddFunctoidNode canvas frame nodeFunc x y = - let exprNode = ENode (NSymbol (Symbol (functoidName nodeFunc))) EvalUntried- args = functoidArgNames nodeFunc- in vcFrameAddNode canvas frame exprNode args x y--vcFrameAddNode :: VCanvas -> CanvFrame -> ExprNode -> [String] - -> Double -> Double -> IO VCanvas-vcFrameAddNode canvas frame exprNode inletLabels x y =- case cfFunctoid frame of- FunctoidFunc _function -> error "vcFrameAddNode: frame is not an edit frame"- fp@FunctoidParts {fpNodes = ns} -> - do- let -- Converting to a tree to lay it out seems overkill--- exprTree = T.Node exprNode []- style = styleIncreasePadding (vcStyle canvas) 10- counter = argIoletCounter inletLabels- layoutTree = treeLayout style counter exprTree-- let graph = vcGraph canvas- layoutTree' = layoutTreeMoveCenterTo x y layoutTree- layoutRoot = rootLabel layoutTree'- newNode = WSimple layoutRoot- -- insert into graph- (graph', gNodeId) = grInsertNode graph newNode- frameNode = cfFrameNode frame- edge = (frameNode, gNodeId, WEdge (outdeg graph frameNode + 1))- graph'' = insEdge edge graph'- -- insert into the fpNodes- ns' = (gNodeId:ns)- fp' = fp {fpNodes = ns'}-- {-- -- DON'T!- -- Adjust header and footer for new body size-- -- BUT: IS THERE ANYTHING HERE THAT I SHOULD KEEP- -- WHEN I MAKE FRAMES KEEP A MINIMUM SIZE TO FIT- -- THE LAYOUT OF THEIR BODIES?-- layoutNodes = map (grExtractLayoutNode graph') ns'- bodyBB = -- layoutTreeBB layoutTree'- bbMergeList (map nodeTreeBB layoutNodes)- header' = alignHeader (cfHeader frame) bodyBB- footer' = alignFooter (cfFooter frame) bodyBB- -- grow box to fit new node- box' = bbMergeList [tbBoxBB header', tbBoxBB footer', bodyBB]- -- insert into frame- frame' = frame {cfHeader = header',- cfFooter = footer',- cfBox = box', - cfFunctoid = fp'}- -}- frame' = frame {cfFunctoid = fp'}-- -- store new frame and graph into canvas- canvas' = vcUpdateFrameAndGraph canvas frame' graph''-- -- Ready to redraw- frameChanged canvas graph frame graph'' frame' -- return canvas'--vcFrameDeleteNode :: VCanvas -> CanvFrame -> G.Node -> IO VCanvas-vcFrameDeleteNode canvas frame node = - let -- Remove the graph node from the frame and canvas,- -- giving its orphaned children the frame as their new parent- graph = vcGraph canvas- frameNode = cfFrameNode frame- children = nodeAllChildren graph node- -- Remove node from graph- graph' = grRemoveNode graph node- -- Frame adopts orphans- graph'' = foldl (\ g child -> connectToFrame child frameNode g) - graph' - children- -- Remove node from funcparts- fp@FunctoidParts {fpNodes = ns} = cfFunctoid frame- fp' = fp {fpNodes = List.delete node ns}- frame' = frame {cfFunctoid = fp'}- - -- Update references- canvas' = vcUpdateFrameAndGraph canvas frame' graph''- in do- -- Ask to be redrawn- frameChanged canvas graph frame graph'' frame'- return canvas'---- | Remove the (sub)tree rooted at the given node.--- Removes it from the graph of the canvas--- and from the FunctoidParts of the frame.-vcFrameDeleteTree :: VCanvas -> CanvFrame -> G.Node -> IO VCanvas-vcFrameDeleteTree canvas frame rootNode = -- let removeTree :: (WGraph, [G.Node]) -> G.Node -> (WGraph, [G.Node])- removeTree (g, ns) root =- let g' = grRemoveNode g root- ns' = List.delete root ns- in foldl removeTree (g', ns') (nodeAllChildren g root)- - graph = vcGraph canvas- fp@FunctoidParts {fpNodes = fnodes} = cfFunctoid frame- (graph', fnodes') = removeTree (graph, fnodes) rootNode- frame' = frame {cfFunctoid = fp {fpNodes = fnodes'}}- - -- Update references- canvas' = vcUpdateFrameAndGraph canvas frame' graph'- in do- -- Ask to be redrawn- frameChanged canvas graph frame graph' frame'- return canvas'----- | Add a frame representing a functoid to the canvas.------ Use mvalues = Nothing if you do not want the frame to be evaluated--- as a function call, otherwise mvalues = Just values.--- --- prevEnv is *supposed* to be the previous environment, --- i.e., that of the--- "parent" frame or the canvas, not of the new frame,--- because vcAddFrame itself will extend the environment--- with the new (vars, values).--- But this is odd, because openNode calls vcAddFrame --- apparently with the *new* environment as prevEnv,--- and yet it works correctly.------ Caution: I think it is necessary for the canvas to have been realized--- before calling this function!--vcAddFrame :: VCanvas -> Functoid -> Maybe [Value] -> FrameType- -> Env -> Double -> Double -> Double -> Maybe G.Node - -> IO VCanvas-vcAddFrame canvas functoid mvalues mode prevEnv x y z mparent = do- let graph = vcGraph canvas- (_, hi) = nodeRange graph- frameNode = hi + 1 -- implicit: root = hi + 2- style = vcStyle canvas- (newFrame, tlo) = frameNewWithLayout style (Position x y) z - functoid mvalues - CallFrame -- mode may change below- frameNode prevEnv mparent- inAdj = case mparent of- Nothing -> []- Just parent -> - -- Adjacency (priority, parent)- [(WEdge (outdeg graph parent), parent)]- -- add the new frame node, possibly linked to its parent,- -- and the tree of the new frame- graph' = grAddGraph - ((inAdj, frameNode, WFrame frameNode, []) & graph)- (flayoutToGraph tlo)- -- connect the frame to the tree-layout roots- layoutRoots = map (+ frameNode) (flayoutToGraphRoots tlo)- outEdges = [(frameNode, root, WEdge priority) | - (priority, root) <- zip [0..] layoutRoots]- graph'' = insEdges outEdges graph'- -- update the frames and the graph in the canvas- frames = vcFrames canvas-- canvas' = canvas {vcFrames = (newFrame:frames)- , vcGraph = graph''}-- -- Make sure canvas is big enough to contain newFrame- -- This is also done when the window is resized- -- (../Callbacks.hs: configuredCallback).-- frameBB = cfBox newFrame- canvas'' = - atLeastSize (Size (bbRight frameBB) (bbBottom frameBB)) canvas'-- -- Request redraw of the region, including tether to parent, if any- -- error occurs here if the widget is not yet realized, I think- vcInvalidateFrameWithParent canvas graph'' newFrame- case mode of- CallFrame -> return canvas''- EditFrame -> editFunction canvas'' newFrame ---- | Return a canvas of at least the specified size--- and otherwise like the given canvas.-atLeastSize :: Size -> VCanvas -> VCanvas-atLeastSize minSize@(Size minW minH) canvas =- let Size w h = vcSize canvas- frames = vcFrames canvas- frames' = if canvasEditing canvas- then -- only one frame, expand it to fill desired size- [atLeastSizeFrame minSize (head frames)]- else frames- in canvas {vcSize = Size (max w minW) (max h minH), vcFrames = frames'}--vcInvalidateFrameWithParent :: VCanvas -> WGraph -> CanvFrame -> IO ()-vcInvalidateFrameWithParent vcanvas graph frame =- -- "Invalidate" the frame itself, and if it has a parent,- -- the region between it and its parent, so that the frame- -- and its tether will be redrawn- let box1 = cfBox frame- box2 = - case cfParent frame of- Just parent -> bbMerge (nodeBBox graph parent) box1- Nothing -> box1- in vcInvalidateBox vcanvas box2--vcInvalidateSimpleNode :: VCanvas -> G.Node -> IO ()-vcInvalidateSimpleNode vcanvas node = - -- For WSimple nodes --- -- Similarly, invalidate the node itself - -- (but not yet its parent (if any))- case wlab (vcGraph vcanvas) node of- WFrame _ -> error "vcInvalidateSimpleNodeWithParent: node is not simple"- WSimple layoutNode ->- vcInvalidateBox vcanvas (gnodeNodeBB (nodeGNode layoutNode))--vcInvalidateBox :: VCanvas -> BBox -> IO ()-vcInvalidateBox vcanvas (BBox x y width height) = - -- take into account the line width of the box as drawn- -- and the radius of Iolets. We'll do this even- -- though frames do not have Iolets on their edges!- -- This is also a little broader than necessary even for- -- WSimple nodes, since the Iolets are on top and bottom,- -- not on the side.- let style = vcStyle vcanvas- t = lineWidth style + styleIoletRadius style- rect = bbToRect (BBox (x - t) (y - t) - (width + 2 * t) (height + 2 * t)) - in do- win <- layoutGetDrawWindow (vcLayout vcanvas)- drawWindowInvalidateRect win rect False--frameChanged :: - VCanvas -> WGraph -> CanvFrame -> WGraph -> CanvFrame -> IO ()-frameChanged vcanvas g f g' f' = - -- (graph g, frame f) has been replaced by (g', f')- do- vcInvalidateFrameWithParent vcanvas g f -- old- vcInvalidateFrameWithParent vcanvas g' f' -- new---- MORE RENDERING--- -----------------------------------------------------------------------drawCanvas :: VCanvas -> Rectangle -> IO ()-drawCanvas canvas clipbox = do- {- -- alternatively match {eventRegion = region}, from which you can get a- -- list of rectangles-- ; let graph = vcGraph canvas- mactive = vcActive canvas- mselected = vcSelected canvas- frames = vcFrames canvas- Size w h = vcSize canvas- - style = vcStyle canvas-- setClip (Rectangle ix iy iwidth iheight) = do- {- rectangle (fromIntegral ix) (fromIntegral iy)- (fromIntegral iwidth) (fromIntegral iheight)- ; clip- }-- drawBackground = do- {- setColor (ColorRGB 0.4 0.4 0.4)- ; rectangle 0 0 w h- ; fill- }-- renderFrame frame = - case frameType frame of- EditFrame -> renderEditFrame frame- CallFrame -> renderCallFrame frame-- renderEditFrame frame = do- {- renderFrameHeader frame- -- ; renderFrameFooter frame- -- the body:- ; setAntialias AntialiasDefault- ; setColor (styleNormalFillColor style)- ; drawBox (Just (styleNormalFillColor style)) Nothing - (frameBodyBox frame)- -- now draw the nodes, if any:- ; graphRenderFunctoidParts style mactive mselected graph frame- ; renderFrameBorder frame- }-- renderCallFrame frame = do- {- let frameRoot = cfRoot frame- -- Just (WSimple _) = lab graph frameRoot -- can't be WFrame!- -- BBox x y width height = nodeTreeBB layoutNode-- -- draw tether from parent (if any)- -- drawTether (nodeParent graph (cfFrameNode frame)) frame- ; fancyTether (nodeParent graph (cfFrameNode frame)) frame-- -- render the graph -- requires the graph, which is *not*- -- in the frame! That's why this is not a "frame method".- ; graphRenderTree style mactive mselected graph frameRoot True-- -- render the header and footer- -- MAYBE do this before the tether?- -- Footer needs to be drawn after body- -- in case the frame is resized too small- ; renderFrameHeader frame- ; renderFrameFooter frame - ; renderFrameBorder frame- }-- renderFrameHeader frame = drawtb cream black black (cfHeader frame)-- renderFrameFooter frame =- drawtb cream black - (if cfEvalReady frame - then lightBlue - else styleAuxColor style)- (cfFooter frame)-- renderFrameBorder frame = drawBox Nothing (Just black) (cfBox frame)- drawtb bgcolor framecolor textcolor tbox = - drawTextBox (Just (styleFont style)) - (Just bgcolor) - (Just framecolor) - textcolor tbox- --- plainTether :: Maybe G.Node -> CanvFrame -> Render ()--- plainTether Nothing _ = return ()--- plainTether (Just parent) frame = --- let pb = nodeBBox graph parent--- fb = cfBox frame--- line f1 f2 = do--- {--- moveTo (f1 pb) (f2 pb) --- ; lineTo (f1 fb) (f2 fb)--- }--- in do--- {--- -- outline the frame's parent--- drawBox Nothing (Just (styleTetherColor style)) pb--- -- draw tether lines--- ; setColor (styleTetherColor style)--- ; line bbLeft bbTop--- ; line bbLeft bbBottom--- ; line bbRight bbTop--- ; line bbRight bbBottom--- ; stroke--- }-- fancyTether :: Maybe G.Node -> CanvFrame -> Render ()- fancyTether Nothing _ = return ()- fancyTether (Just parent) frame = - let pb = nodeBBox graph parent- fb = cfBox frame- side f1 f2 f3 f4 =- do- newPath- moveTo (f1 pb) (f2 pb)- lineTo (f1 fb) (f2 fb)- lineTo (f3 fb) (f4 fb)- lineTo (f3 pb) (f4 pb)- closePath- fill- in do- {- -- outline the frame's parent- drawBox Nothing (Just (styleTetherColor style)) pb- -- draw tether lines- ; setColor (styleTetherColor style)- ; side bbLeft bbTop bbRight bbTop- ; side bbRight bbTop bbRight bbBottom- ; side bbRight bbBottom bbLeft bbBottom- ; side bbLeft bbBottom bbLeft bbTop- }-- ; drawWin <- layoutGetDrawWindow (vcLayout canvas)- ; renderWithDrawable drawWin $ do- {- setClip clipbox- ; drawBackground- -- sorting is a possible bottleneck? - ; (mapM_ renderFrame (sortBy levelOrder frames))- }-- }---- | Find the node, if any, at a given position on the canvas.-vcanvasNodeAt :: VCanvas -> Position -> Maybe G.Node-vcanvasNodeAt vcanvas point =- - -- searchFrames could be done with the Maybe monad, I guess- let searchFrames :: [CanvFrame] -> Maybe G.Node- searchFrames [] = Nothing- searchFrames (f:fs) =- case frameNodeAt f (vcGraph vcanvas) point of- Nothing -> searchFrames fs- Just node -> Just node- - in searchFrames (vcFrames vcanvas)- --vcanvasNodeRect :: VCanvas -> G.Node -> Rectangle-vcanvasNodeRect vcanvas node =- let Just (WSimple layoutNode) = lab (vcGraph vcanvas) node- in bbToRect (gnodeNodeBB (nodeGNode layoutNode))--whichFrame :: VCanvas -> Double -> Double -> Maybe CanvFrame-whichFrame vcanvas x y = - -- Find the frame, if any, in which (x, y) occurs.- -- If there's more than one match, we should return the- -- one "on top" or at the highest level -- this is not yet implemented.- let frames = vcFrames vcanvas- inFrame position = pointInBB position . cfBox- matches = filter (inFrame (Position x y)) frames- in case matches of- [] -> Nothing- [m1] -> Just m1- (m1:_:_) -> - -- multiple frames match, so here needs some additional work- Just m1---- | editFunction: reverse of defineFunction: replace the call frame by--- an edit frame; does not change the VPUI (global env.), just the canvas..-editFunction :: VCanvas -> CanvFrame -> IO VCanvas-editFunction canvas frame = - case frameType frame of- EditFrame -> - return canvas- - CallFrame ->- let FunctoidFunc function = cfFunctoid frame- parts = functionToParts function (vcGraph canvas) - (cfFrameNode frame)- frame' = frame {cfFunctoid = parts, frameType = EditFrame}- -- Make the frame fill the canvas.- frame'' = atLeastSizeFrame (vcSize canvas) frame'- in return $ vcUpdateFrame canvas frame''---- | Find a frame's subframes, i.e., those that were expanded--- to trace the execution of a function call.--- Cannot be in an edit frame.-vcFrameSubframes :: VCanvas -> CanvFrame -> [CanvFrame]-vcFrameSubframes canvas frame =- let graph = vcGraph canvas- subframeNodes = - case frameType frame of- EditFrame -> []- CallFrame -> grTreeSubframeNodes graph (cfRoot frame)- in map (vcGetFrame canvas graph) subframeNodes----- | Given a graph with a rooted tree, collect list of "subframes,"--- i.e., frames that are children of nodes in the tree-grTreeSubframeNodes :: WGraph -> G.Node -> [G.Node]-grTreeSubframeNodes g root =- nodeFrameChildren g root ++ - concatMap (grTreeSubframeNodes g) (nodeSimpleChildren g root)--vcEvalDialog :: VCanvas -> CanvFrame -> IO VCanvas-vcEvalDialog canvas frame =- let FunctoidFunc function = cfFunctoid frame -- FunctoidParts shouldn't happen- varnames = cfVarNames frame- in if null varnames- then evalFrame canvas frame [] -- skip dialog, no inputs- else let argDefault env arg = - case envLookup env arg of- Nothing -> ""- Just value -> repr value- defaults = map (argDefault (cfEnv frame)) varnames- reader :: Reader [String] [Value]- reader inputs =- mapM stringToValue inputs >>= - typeCheck varnames (functionArgTypes function)- in do- dialog <- - createEntryDialog "Input Values" varnames defaults reader (-1)- result <- runEntryDialog dialog- case result of- Nothing -> return canvas- Just values -> evalFrame canvas frame values---- | Evaluate the frame, having gotten a list of values from the dialog--evalFrame :: VCanvas -> CanvFrame -> [Value] -> IO VCanvas-evalFrame canvas frame values = do- -- Close subframes (those that were made by- -- expanding a node of this frame)- canvas' <- vcCloseSubframes canvas frame-- -- Re-evaluate expression tree and update display- let graph = vcGraph canvas'-- -- Pop the current frame's values, if any, before- -- extending with the new values.- -- A frame with no values has a dummy extension,- -- so this is still okay.- frameNode = cfFrameNode frame- -- It's a call frame, so it has a root- root = cfRoot frame- style = vcStyle canvas'- headerTB = cfHeader frame-- -- The tlo may *change*, since showing values may require- -- extra space.-- (frame', tlo') = frameNewWithLayout style - (bbPosition (tbBoxBB headerTB))- (cfLevel frame)- (cfFunctoid frame) (Just values) CallFrame- frameNode - (envPop (cfEnv frame))- Nothing-- -- Since the frame is a call frame, we should have a tree tlo.-- case tlo' of- FLayoutTree _t ->- do- -- update the tree in the graph- let graph' = grUpdateFLayout graph [root] tlo'- canvas'' = vcUpdateFrameAndGraph canvas' frame' graph'- - -- request redrawing of old and new areas- frameChanged canvas' graph frame graph' frame'- - return canvas''-- FLayoutForest _f _b ->- error "vcEvalDialog: finishDialog: tlo is not a tree"---- *** WORK HERE ***--- This will be a lot like vcEvalDialog, except we are *un*-evaluating.--- :-(---- | vcClearFrame - clear a frame in a canvas; not yet implemented--- What does this mean?--vcClearFrame :: VCanvas -> CanvFrame -> IO VCanvas-vcClearFrame canvas _frame = - showInfoMessage "Sorry" "Stub: vcClear is not yet implemented" >>- return canvas---- | Close a frame and any subframes of it--vcCloseFrame :: VCanvas -> CanvFrame -> IO VCanvas-vcCloseFrame canvas frame = do- -- close any subframes of this frame- canvas' <- vcCloseSubframes canvas frame -- was vpui' = ...-- -- remove it from the frames list- let canvas'' = vcDeleteFrame canvas' frame -- was vpui'' = ...-- -- remove it and its edges from the graph- let -- was vcanvas = vpuiCanvas vpui''- graph = vcGraph canvas''- (_mcontext, graph') = match (cfFrameNode frame) graph- canvas''' = canvas'' {vcGraph = graph'}-- -- graphically invalidate the region of the frame- -- and its tether (i.e., to its parent)- -- (yes, using the *old* vcanvas, graph, and frame)-- vcInvalidateFrameWithParent canvas (vcGraph canvas) frame- return canvas'''---- | Close any subframes of the frame, but not the frame itself-vcCloseSubframes :: VCanvas -> CanvFrame -> IO VCanvas-vcCloseSubframes canvas frame =- foldM vcCloseFrame canvas (vcFrameSubframes canvas frame)---cfContext :: CanvFrame -> ToolContext-cfContext frame =- case frameType frame of- EditFrame -> TCEditFrame frame- CallFrame -> TCCallFrame frame---- | Is our canvas editing a function?-canvasEditing :: VCanvas -> Bool-canvasEditing canvas =- case vcFrames canvas of- [oneFrame] -> frameType oneFrame == EditFrame- _ -> False---- | Find the frames that are calling the named function-callFrames :: VCanvas -> String -> [CanvFrame]-callFrames canvas funcName =- let isCaller frame = functoidName (cfFunctoid frame) == funcName- in filter isCaller (vcFrames canvas)
− Workspace/Frame.hs
@@ -1,306 +0,0 @@-module Workspace.Frame- (- CanvFrame(..), FrameType(..)- , argIoletCounter- , atLeastSizeFrame- , cfEvalReady- , cfPointInHeader- , cfPointInFooter- , cfRoot- , frameNewWithLayout- , frameBodyBox- , frameNodeAt- , frameOffset- , levelOrder- , nodeCompoundFunction- , pointIolet- , resizeFrame- , translateFrame- , grTranslateFrameNodes- )--where--import Data.Function-import Data.List--import Data.Graph.Inductive as G--import Expr-import Geometry-import Tree-import TreeLayout-import Workspace.Functoid-import Workspace.WGraph-import Util---- ------------------------------------------------------------------------ CanvFrame operations--- -------------------------------------------------------------------------- | A CanvFrame represents (indirectly, through cfRoot, and we--- access to the graph which is provided by the VCanvas)--- a "subgraph" such as the expression tree--- of a function which is being edited or called.--data CanvFrame = CanvFrame {- cfHeader :: TextBox -- ^ top area of the frame- , cfFooter :: TextBox -- ^ bottom area- , cfVarNames :: [String] -- ^ variable (parameter) names- , cfParent :: Maybe G.Node -- ^ the node opened to make this frame- , cfFrameNode :: G.Node -- ^ this frame as a node in the graph;- -- also serves as the ID of the frame.- , cfEnv :: Env -- ^ environment for evaluation- , cfBox :: BBox -- ^ box of the whole frame (header, tree, and footer)- , cfLevel :: Double -- ^ 0 = bottom level, 1 = next higher, etc.- , cfFunctoid :: Functoid -- ^ includes tlo for an edit frame- , frameType :: FrameType -- ^ edit or call frame- }- deriving (Show)- ----- | CanvFrame needs to be Eq in order to be Ord,--- but maybe the Eq and Ord definitions should be more--- in the same spirit?-instance Eq CanvFrame where (==) = (==) `on` cfFrameNode--data FrameType = EditFrame | CallFrame deriving (Eq, Read, Show)---- | Use levelOrder for sorting frames before drawing them-levelOrder :: CanvFrame -> CanvFrame -> Ordering-levelOrder f1 f2 = compare (cfLevel f1) (cfLevel f2) ---- | The root of the tree displayed in the frame-cfRoot :: CanvFrame -> G.Node-cfRoot frame = - case frameType frame of- EditFrame -> error "cfRoot: an edit frame has no root"- CallFrame -> succ (cfFrameNode frame)---- | A frame is "eval ready" -- that is, okay to run the Eval Frame dialog ----- if it is a call frame with no parent-cfEvalReady :: CanvFrame -> Bool-cfEvalReady frame = - (frameType frame == CallFrame) && (cfParent frame == Nothing)--cfPointInHeader :: CanvFrame -> Double -> Double -> Bool-cfPointInHeader frame x y = - pointInBB (Position x y) (tbBoxBB (cfHeader frame))--cfPointInFooter :: CanvFrame -> Double -> Double -> Bool-cfPointInFooter frame x y = - pointInBB (Position x y) (tbBoxBB (cfFooter frame))--frameBodyBox :: CanvFrame -> BBox-frameBodyBox frame =- -- the space between the header and footer- let hbb = tbBoxBB (cfHeader frame)- fbb = tbBoxBB (cfFooter frame)- top = bbBottom hbb- bottom = bbTop fbb- -- assuming both header and footer are left aligned and same width- in BBox (bbLeft hbb) top (bbWidth hbb) (bottom - top)--editFrameNodes :: CanvFrame -> [G.Node]-editFrameNodes frame =- case frameType frame of- EditFrame -> fpNodes (cfFunctoid frame)- CallFrame -> error "editFrameNodes: not an EditFrame"--frameNodeAt :: CanvFrame -> WGraph -> Position -> Maybe G.Node-frameNodeAt frame graph point = - case frameType frame of- CallFrame -> callFrameNodeAt frame graph point- EditFrame -> editFrameNodeAt frame graph point--editFrameNodeAt :: CanvFrame -> WGraph -> Position -> Maybe G.Node-editFrameNodeAt _frame _graph _point = Nothing -- STUB ***- -- *** this could probably make use of the function that finds- -- a selection from a point--callFrameNodeAt :: CanvFrame -> WGraph -> Position -> Maybe G.Node-callFrameNodeAt frame graph point = - let search :: [G.Node] -> Maybe G.Node- search [] = Nothing- search (r:rs) =- case lab graph r of- Just (WFrame _) -> search rs- Just (WSimple layoutNode) ->- let LayoutNode rootGNode treeBB = layoutNode- in- if pointInBB point treeBB - -- it's in the tree rooted at r- then if pointInBB point (gnodeNodeBB rootGNode) - -- it's in the root node- then Just r- else search (suc graph r) -- maybe in the subtrees- else search rs -- maybe in the siblings- Nothing -> - errcats ["editFrameNodeAt: search: no label for node",- show r]- -- since this is a call frame, it had better have a root- in search [cfRoot frame]--atLeastSizeFrame :: Size -> CanvFrame -> CanvFrame-atLeastSizeFrame (Size minW minH) frame =- let BBox _ _ width height = cfBox frame- dwidth = if minW > width then minW - width else 0- dheight = if minH > height then minH - height else 0- in resizeFrame frame dwidth dheight--resizeFrame :: CanvFrame -> Double -> Double -> CanvFrame-resizeFrame frame dw dh = - let BBox x y bwidth height = frameBodyBox frame- -- do not shrink body to negative size- bwidth' = max 0 (bwidth + dw)- height' = max 0 (height + dh)- bodyBB' = BBox x y bwidth' height'- header' = alignHeader (cfHeader frame) bodyBB'- footer' = alignFooter (cfFooter frame) bodyBB'- frameBox' = bbMergeList [tbBoxBB header', tbBoxBB footer', bodyBB']- in frame {cfHeader = header', cfFooter = footer', cfBox = frameBox'}---translateFrame :: CanvFrame -> Double -> Double -> CanvFrame-translateFrame frame dx dy =- frame {cfHeader = translate dx dy (cfHeader frame),- cfFooter = translate dx dy (cfFooter frame),- cfBox = translate dx dy (cfBox frame)}----- | Where to position a new frame that is grown out of an old frame?--- This is a very rough draft of frameOffset-frameOffset :: Style -> CanvFrame -> Position-frameOffset style oldFrame = - let bb = cfBox oldFrame- in Position (bbRight bb + styleFramePad style) (bbTop bb - 40)----nodeCompoundFunction :: WGraph -> CanvFrame -> Node -> Maybe Function-nodeCompoundFunction graph frame node = - case lab graph node of- Nothing -> error "nodeCompoundFunction: no label for node"- Just (WFrame _) -> error "nodeCompoundFunction: node has a WFrame label"- Just (WSimple layoutNode) ->- case gnodeValue (nodeGNode layoutNode) of- ENode (NSymbol (Symbol "if")) _mvalue -> Nothing -- not a function- ENode (NSymbol (Symbol symbolName)) _mvalue ->- case envLookup (cfEnv frame) symbolName of- Nothing -> Nothing -- unbound symbol okay, at least sometimes- Just (VFun func@(Function _ _ _ (Compound _ _))) -> Just func- Just _ -> Nothing -- not a compound function- _ -> Nothing -- not a symbol--grTranslateFrameNodes :: WGraph -> CanvFrame -> Double -> Double -> WGraph-grTranslateFrameNodes wgraph frame dx dy =- case frameType frame of- CallFrame -> translateTree dx dy wgraph (cfRoot frame)- EditFrame -> translateNodes dx dy wgraph (editFrameNodes frame)- -pointIolet :: Position -> Int -> [Iolet] -> Maybe Int-pointIolet point n iolets =- -- find the number of the iolet, if any, containing point- case iolets of - [] -> Nothing- (p:ps) ->- if pointInIolet point p - then Just n- else pointIolet point (n + 1) ps----- | argIoletCounter returns (no. of inlets, no. of outlets)--- derived from the argument list of a function still being defined-argIoletCounter :: [String] -> ExprNode -> (Int, Int)-argIoletCounter labels _exprNode = (length labels, 1)---- | Aligning a CanvFrame's header and footer with the body of the frame.--- Aligns the header above, and the footer below, the body of the frame,--- also matching the width if the body widened--alignHeader :: TextBox -> BBox -> TextBox-alignHeader header bodybox =- let headerBB = tbBoxBB header- y0 = bbBottom headerBB- y1 = bbTop bodybox- x0 = bbLeft headerBB- x1 = bbLeft bodybox- in translate (x1 - x0) (y1 - y0) (tbSetWidth header (bbWidth bodybox))--alignFooter :: TextBox -> BBox -> TextBox-alignFooter footer bodybox =- let footerBB = tbBoxBB footer- y0 = bbTop footerBB- y1 = bbBottom bodybox- x0 = bbLeft footerBB- x1 = bbLeft bodybox- in translate (x1 - x0) (y1 - y0) (tbSetWidth footer (bbWidth bodybox))----- | Figure out the frame layout for a function. Returns the layout and frame.--- Currently, the frame is marked as a "call frame"; if you want to edit it,--- call (editFrame? editFunction?)--frameNewWithLayout :: Style -> Position -> Double- -> Functoid -> Maybe [Value] -> FrameType -- added arg- -> Node -> Env -> Maybe G.Node - -> (CanvFrame, FunctoidLayout) -- reversed tuple-frameNewWithLayout style (Position x y) z - functoid mvalues mode frameNode prevEnv mparent = - -- Figure out the positions for a function call with the- -- given function and (possibly) values as arguments- let headerText = functoidHeader functoid- vars = functoidArgNames functoid- footerText = buildFooterText vars mvalues- env = case mvalues of- Nothing ->- -- dummy extension to be popped off- extendEnv [] [] prevEnv - Just values ->- extendEnv vars values prevEnv- -- body tlo- layout0 = flayout style functoid env mvalues- -- header and footer layouts- headerTB0 = makeTextBox style headerText -- at 0 0- footerTB0 = makeTextBox style footerText -- at 0 0-- -- make all three the same width- Size lw lh = flayoutSize layout0- fwidth = maximum [tbWidth headerTB0, lw, tbWidth footerTB0]- -- The __widen functions ensure that each part - -- (header, footer, tree tlo) have the desired width.- headerTB1 = translate x y (widen headerTB0 fwidth)- (dx, dy) = (x - hpad style, tbBottom headerTB1 - vpad style)- layout1 = translate dx dy (flayoutWiden layout0 fwidth)- footerTB1 = translate x (flayoutBottom layout1) - (widen footerTB0 fwidth)- frameBox = BBox x y fwidth - (tbHeight headerTB0 + lh + tbHeight footerTB0)- frame = CanvFrame {cfHeader = headerTB1,- cfFooter = footerTB1,- cfVarNames = vars,- cfParent = mparent,- cfFrameNode = frameNode,- cfEnv = env, - cfBox = frameBox,- cfLevel = z,- cfFunctoid = functoid,- frameType = mode}- in (frame, layout1)----buildFooterText :: [String] -> Maybe [Value] -> String-buildFooterText vars mvalues = - let items =- case mvalues of- Nothing -> vars- Just [] -> vars- Just values ->- if length vars /= length values- then error "buildFooterText: mismatched lists"- else [var ++ " = " ++ repr value |- (var, value) <- zip vars values]- in concat (intersperse ", " items)
− Workspace/Functoid.hs
@@ -1,99 +0,0 @@-module Workspace.Functoid- (Functoid(..)- , functoidName, functoidArgNames, functoidHeader- , FunctoidLayout(..), flayout- , flayoutBBox, flayoutSize, flayoutWidth, flayoutBottom- , flayoutWiden)--where--import Data.Graph.Inductive as G--import Geometry-import Expr-import TreeLayout---- | A Functoid is either a FunctoidParts, representing a partially--- defined function, or a (completely defined) Function.--- A FunctoidParts represents an incompletely defined function,--- which has a function name, argument names, and a list of graph nodes --- representing the function body which might not yet form--- a complete expression tree, e.g., nodes might--- be unconnected.--data Functoid = FunctoidParts {fpName :: String,- fpArgs :: [String],- fpNodes :: [G.Node]}- | FunctoidFunc {fpFunc :: Function}- deriving (Show)--functoidName :: Functoid -> String-functoidName (FunctoidParts {fpName = name}) = name-functoidName (FunctoidFunc function) = functionName function--functoidArgNames :: Functoid -> [String]-functoidArgNames (FunctoidParts {fpArgs = args}) = args-functoidArgNames (FunctoidFunc function) = functionArgNames function--functoidHeader :: Functoid -> String-functoidHeader f = unwords (functoidName f : functoidArgNames f)---- | What is a FunctoidLayout? You can think of it as a --- tree layout for a Frame,--- or for a Functoid, or as a Forest of Tree Layouts!--- For an Edit frame, it must be a forest, since the nodes are not--- yet necessarily connected into a tree.--- For a call frame, it will be a single TreeLayout (singleton list).--data FunctoidLayout = FLayoutTree (TreeLayout ExprNode)- | FLayoutForest [TreeLayout ExprNode] BBox---- | Graphically lay out the Functoid.--- mvalues: Nothing implies an uncalled frame,--- Just values implies a called frame, even with 0 arguments.--flayout :: Style -> Functoid -> Env -> Maybe [Value] -> FunctoidLayout-flayout style functoid env mvalues =- case functoid of- FunctoidParts {} ->- -- *** STUB: [] and bbox- -- WELL: is this supposed to CREATE the tlo or RETRIEVE the tlo?- -- Either way, it won't work without access to the WGraph!- FLayoutForest [] (BBox (hpad style) (vpad style) 300 300)- FunctoidFunc function ->- let expr = functionBody function- exprTree = case mvalues of- Nothing -> exprToTree expr- Just _values -> evalTree (exprToTree expr) env- tlo = treeLayout style (exprNodeIoletCounter env) exprTree- in FLayoutTree tlo--flayoutBBox :: FunctoidLayout -> BBox-flayoutBBox aflayout =- case aflayout of- FLayoutTree t -> layoutTreeBB t- FLayoutForest _ bbox -> bbox--flayoutSize :: FunctoidLayout -> Size-flayoutSize = bbSize . flayoutBBox--flayoutWidth :: FunctoidLayout -> Double-flayoutWidth = bbWidth . flayoutBBox--flayoutBottom :: FunctoidLayout -> Double-flayoutBottom = bbBottom . flayoutBBox--flayoutWiden :: FunctoidLayout -> Double -> FunctoidLayout -flayoutWiden aflayout minWidth =- case aflayout of- FLayoutTree t -> FLayoutTree (treeLayoutWiden t minWidth)- FLayoutForest f bbox -> FLayoutForest f bbox -- *** STUB ***--instance Draw FunctoidLayout where-- draw style mode (FLayoutTree t) = draw style mode t- draw style mode (FLayoutForest f _) = draw style mode f-- translate dx dy (FLayoutTree t) = FLayoutTree (translate dx dy t)- translate dx dy (FLayoutForest f b) = - FLayoutForest (translate dx dy f) (translate dx dy b)
− Workspace/Tools.hs
@@ -1,552 +0,0 @@-module Workspace.Tools - (- ToolId(..)- , Tool(..), ToolContext(..)- , checkMods- , functionTool- , functionToolsFromLists- , makeConnectTool- , makeCopyTool- , makeDeleteTool- , makeDisconnectTool- , makeFixedArgTool- , makeIfTool- , makeMoveTool- , showFunctionEntry- , showLiteralEntry- , vpuiSetTool- , vpuiWindowSetTool-- , vwAddFrame- , vpuiAddFrame-- -- Statusbar- , wsPopStatusbar, wsPushStatusbar-- -- frame context menu commands (do these belong elsewhere?)- , dumpFrame- , dumpGraph- , dumpWorkWin- , clearFrame- , closeFrame- )--where--import Control.Monad-import Control.Monad.Trans (liftIO)-import Data.IORef-import Data.List--import Data.Graph.Inductive as G--import LittleGtk -import Graphics.UI.Gtk.Gdk.EventM--import CBMgr-import Expr-import Geometry-import Tree (putTree, repr)-import TreeGraph (graphToOrderedTreeFrom)--import UITypes-import Util-import Workspace.Canvas-import Workspace.Frame-import Workspace.Functoid-import Workspace.WGraph---data ToolId - = ToolConnect- | ToolDisconnect- | ToolIf- | ToolMove- | ToolDelete- | ToolFunction String -- ^ function name- | ToolLiteral Expr- | ToolArg String -- ^ argument name- deriving (Eq, Show)---- Tools--vpuiSetTool :: ToolId -> WinId -> VPUI -> IO VPUI-vpuiSetTool toolId winId =- vpuiUpdateWindowIO winId (vpuiWindowSetTool (toolIdToTool toolId))--vpuiWindowSetTool :: Tool -> VPUIWindow -> IO VPUIWindow-vpuiWindowSetTool tool vw =- case vw of- VPUIWorkWin ws _ ->- do- {- ; wsPopStatusbar ws- ; wsPushStatusbar ws ("Tool: " ++ toolName tool)- ; let canvas' = (wsCanvas ws) {vcTool = Just tool}- ; canvas'' <- toolActivated tool canvas'- ; return $ vpuiWindowSetCanvas vw canvas''- }- _ -> return vw--toolIdToTool :: ToolId -> Tool-toolIdToTool toolId =- case toolId of- ToolConnect -> makeConnectTool- ToolDisconnect -> makeDisconnectTool- ToolIf -> makeIfTool- ToolMove -> makeMoveTool- ToolDelete -> makeDeleteTool- ToolFunction funcname -> functionTool funcname- ToolLiteral expr -> makeFixedLiteralTool expr- ToolArg argname -> makeFixedArgTool argname---defaultContextDescription :: String-defaultContextDescription = "default context"--wsPushStatusbar :: Workspace -> String -> IO ()-wsPushStatusbar ws msg = do - {- let sbar = wsStatusbar ws- ; contextId <- statusbarGetContextId sbar defaultContextDescription- ; _ <- statusbarPush sbar contextId msg- ; return ()- }--wsPopStatusbar :: Workspace -> IO ()-wsPopStatusbar ws = do- {- let sbar = wsStatusbar ws- ; contextId <- statusbarGetContextId sbar defaultContextDescription- ; statusbarPop sbar contextId- }--makeMoveTool :: Tool-makeMoveTool = - let move canv toolContext _mods x y = - case toolContext of- TCEditFrame frame ->- let graph = vcGraph canv- in case pointSelection graph frame (Position x y) of- sel@(Just (SelectionNode node)) ->- let dragging = - Dragging {draggingNode = node,- draggingPosition = Position x y}- in do- {- vcInvalidateFrameWithParent canv graph frame- ; return $ canv {vcSelected = sel,- vcDragging = Just dragging}- }- _ -> -- no node selected, do nothing- return canv- _ ->- return canv -- not an edit frame, do nothing- in Tool "MOVE" return (toToolOpVW move)--makeDeleteTool :: Tool-makeDeleteTool = - let del :: CanvasToolOp- del canv toolContext mods x y =- case toolContext of- TCEditFrame frame -> - let graph = vcGraph canv- in case pointSelection graph frame (Position x y) of- Just (SelectionNode node) ->- if checkMods [Shift] mods- then vcFrameDeleteTree canv frame node- else vcFrameDeleteNode canv frame node- _ ->- return canv -- no node selected, do nothing-- _ -> - return canv -- not an edit frame, do nothing- - in Tool "DELETE" vcClearSelection (toToolOpVW del)---- | Check that all required modifiers are in found-checkMods :: [Modifier] -> [Modifier] -> Bool-checkMods required found =- all (\ r -> elem r found) required--makeConnectTool :: Tool-makeConnectTool = - Tool "CONNECT" vcClearSelection (toToolOpVW (conn connect))- -makeDisconnectTool :: Tool-makeDisconnectTool = - Tool "DISCONNECT" vcClearSelection (toToolOpVW (conn disconnect))--conn :: (VCanvas -> G.Node -> WEdge -> G.Node -> WEdge -> IO VCanvas)- -> CanvasToolOp-conn action canvas toolContext _mods x y =- case toolContext of- TCEditFrame frame ->- let oldSel = vcSelected canvas- graph = vcGraph canvas- requestRedraw =- vcInvalidateFrameWithParent canvas graph frame- in case pointSelection graph frame (Position x y) of- - -- Overall algorithm: If we're on a port and there's- -- an opposite port selected, apply the action them- -- and clear the selection. Otherwise, if we're on- -- a port, select it. Otherwise do nothing.-- Just sel@(SelectionInlet parent inlet) ->- -- Case 1: we're on an inlet port, - -- opposite port = outlet- do - {- requestRedraw- ; case oldSel of- Just (SelectionOutlet child outlet) ->- do- {- canvas' <- action canvas parent - inlet child outlet- ; return $ canvas' {vcSelected = Nothing}- }- _ -> return $ canvas {vcSelected = Just sel}- }- Just sel@(SelectionOutlet child outlet) ->- -- Case 2: we're on an outlet port, - -- opposite port = inlet- do- {- requestRedraw- ; case oldSel of- Just (SelectionInlet parent inlet) ->- do- {- canvas' <- action canvas parent - inlet child outlet- ; return $ canvas' {vcSelected = Nothing}- }- _ -> return $ canvas {vcSelected = Just sel}- }-- _ -> - -- Case 3: we're not on an iolet, do nothing- return canvas- _ -> - -- not in an edit frame, do nothing- return canvas--makeFixedLiteralTool :: Expr -> Tool-makeFixedLiteralTool expr =- case expr of- ELit literal ->- let node = ENode (NLit literal) EvalUntried- addLitNode vw toolContext _mods x y =- case toolContext of- TCEditFrame frame ->- vcFrameAddNode vw frame node [] x y- _ ->- return vw -- Nothing- in Tool ("Literal: " ++ repr literal) return (toToolOpVW addLitNode)- _ ->- errcats ["makeFixedLiteralTool: non-literal expression", show expr]--makeFixedArgTool :: String -> Tool-makeFixedArgTool label = - let node = ENode (NSymbol (Symbol label)) EvalUntried- addArgNode vw toolContext _mods x y =- case toolContext of- TCEditFrame frame ->- vcFrameAddNode vw frame node [] x y- _ ->- return vw -- no effect- in Tool ("Argument: " ++ label) return (toToolOpVW addArgNode)--makeIfTool :: Tool-makeIfTool = - let if_ vpui toolContext _mods x y =- case toolContext of- TCEditFrame frame ->- let node = ENode (NSymbol (Symbol "if")) EvalUntried- labels = ["test", "left", "right"]- in vcFrameAddNode vpui frame node labels x y- _ ->- return vpui -- do nothing- in Tool "if" return (toToolOpVW if_)--makeCopyTool :: Tool-makeCopyTool = dummyTool "COPY"--dummyTool :: String -> Tool-dummyTool name = - let op vpui _winId _context _mods x y =- info ("dummyTool", name, x, y) >>- return vpui- in Tool ("*" ++ name ++ "*") return op---- functionTool needs the VPUI in its op,--- because it needs to get an environment.--functionTool :: String -> Tool-functionTool name =- let op :: ToolOp- op vpui winId toolContext _mods x y = - -- Some of these are not used in some cases,- -- but with lazy evaluation it doesn't hurt to- -- declare them all up here:- let env = vpuiGlobalEnv vpui- func = envGetFunction env name- in case toolContext of- TCCallFrame _ -> - return vpui -- do nothing- TCEditFrame frame ->- let modify canvas =- vcFrameAddFunctoidNode canvas frame- (FunctoidFunc func)- x y- in vpuiModCanvasIO vpui winId modify- TCExprNode ->- return vpui -- do nothing- TCWorkspace ->- case functionImplementation func of- Primitive _ -> - return vpui -- do nothing- Compound _ _ -> - -- Add a call frame to the workspace- vpuiAddFrame vpui winId (FunctoidFunc func) - Nothing CallFrame - env x y 0 Nothing- in Tool name return op----- | Add a frame representing a functoid to the canvas --- of a particular window, specified by its window id (title).--vpuiAddFrame :: VPUI -> WinId -> Functoid -> Maybe [Value] -> FrameType- -> Env -> Double -> Double -> Double -> Maybe G.Node - -> IO VPUI-vpuiAddFrame vpui winId functoid mvalues mode prevEnv x y z mparent = - let update vw = - vwAddFrame vw functoid mvalues mode prevEnv x y z mparent- in vpuiUpdateWindowIO winId update vpui---- | Add a frame representing a functoid to the canvas --- of a VPUIWindow (which ought to have a canvas, of course).--- Otherwise like vcAddFrame.--vwAddFrame :: VPUIWindow -> Functoid -> Maybe [Value] -> FrameType - -> Env -> Double -> Double -> Double -> Maybe G.Node - -> IO VPUIWindow-vwAddFrame vw functoid mvalues mode prevEnv x y z mparent = - let modify canvas = vcAddFrame canvas functoid mvalues mode prevEnv- x y z mparent- in vpuiWindowModCanvasIO vw modify--functionToolsFromLists :: [[String]] -> [[Tool]]-functionToolsFromLists = map2 functionTool- --- | Open an entry for user input of function name to select a function tool.--- Returns unaltered VPUI, for convenience in menus and key callbacks.--showFunctionEntry :: WinId -> CBMgr -> VPUI -> IO VPUI-showFunctionEntry winId uimgr vpui = - let env = vpuiGlobalEnv vpui- fsymbols = (envFunctionSymbols env)- -- Check whether the name is bound to a function- checkFunctionName :: String -> SuccFail String- checkFunctionName name =- case envLookup env name of- Nothing -> Fail $ name ++ ": unbound variable"- Just (VFun _) -> Succ name- _ -> Fail $ name ++ ": bound to non-function value"- in showToolEntry winId "Function name" - (Just fsymbols) -- completions- checkFunctionName -- parser- -- activateTool -- action- ToolFunction -- tool type specifier- uimgr -- state- vpui---- | Show an entry for input of a literal value.--- Returns unaltered VPUI, for convenience in menus and key callbacks.--showLiteralEntry :: WinId -> CBMgr -> VPUI -> IO VPUI-showLiteralEntry winId = - -- Needs uimgr for action when entry is activated- showToolEntry winId "Literal value" - Nothing -- completions- stringToLiteral -- parser- -- activateTool -- action- ToolLiteral -- tool type specifier---- | New, light replacement for most dialogs---- | Prompt for input in a text entry.--- When the user presses Return, attempt to parse the input text.--- If parse succeeds, apply the toolType to the resulting value--- to produce a ToolId and set the corresponding tool.--- If user presses Escape, the input is closed with no action.--- If mcompletions is (Just comps), comps is a list of possible--- completions for the entry.--- --- Returns the vpui, with NO UPDATE, for convenience in callbacks and menus---- Note: this has been specialized; the action only sets a tool--- on the window. It can be generalized again--- to any sort of action if needed.-showToolEntry :: WinId -> String -> Maybe [String] - -> (String -> SuccFail a) -> (a -> ToolId)- -> CBMgr -> VPUI- -> IO VPUI-showToolEntry winId prompt mcompletions parser toolType uimgr vpui =- let vw = vpuiGetWindow vpui winId- in case vpuiWindowLookupCanvas vw of- Nothing -> error "showToolEntry: no canvas!"- Just canvas ->- let layout = vcLayout canvas- (xx, yy) = vcMousePos canvas- in do- {- ; vbox <- vBoxNew False 5- ; evtBox <- eventBoxNew -- needed for Label visibility- ; label <- labelNew (Just prompt)- ; entry <- entryNew- ; case mcompletions of- Nothing -> return ()- Just comps -> addEntryCompletions entry comps-- -- Organize as (vbox (eventbox (label), entry))- ; containerAdd evtBox label- ; boxPackStartDefaults vbox evtBox- ; boxPackStartDefaults vbox entry- ; layoutPut layout vbox (round xx) (round yy)- ; widgetShowAll vbox-- -- grab and handle events- ; grabAdd entry -- all keyboard and mouse events of the app- ; widgetGrabFocus entry -- grabs keyboard events, still necessary- -- Set actions for TAB (entry completion) and ESC (cancel)- ; _ <- on entry keyPressEvent (entryKeyPress vbox entry)- ; uimgr (OnEntryActivate entry- (entryActivated vbox winId entry parser toolType))- ; return vpui- }---- | When activated, send a message to set the current tool -entryActivated :: (ContainerClass c) => - c -> WinId -> Entry - -> (String -> SuccFail a) -- parser- -> (a -> ToolId) -- tool type- -> IORef VPUI -- state- -> IO ()-entryActivated container winId entry parser toolType uiref = do--- This could be rewritten in the form of :: ... -> VPUI -> IO VPUI--- and transformed in the CBMgr, "lifting" the readIORef/writeIORef,--- in fact streamlining it to "mutateIORef"- {- text <- entryGetText entry- ; case parser text of- Fail msg -> info msg- Succ value -> - grabRemove entry >>- widgetDestroy container >>- readIORef uiref >>= - vpuiSetTool (toolType value) winId >>=- writeIORef uiref- }--addEntryCompletions :: Entry -> [String] -> IO ()-addEntryCompletions entry comps = do- {- -- prepare the model- model <- listStoreNew comps-- -- make EntryCompletion and set model and column- ; ec <- entryCompletionNew- ; set ec [entryCompletionModel := Just model]- ; customStoreSetColumn model (makeColumnIdString 0) id- ; entryCompletionSetTextColumn ec (makeColumnIdString 0)-- -- attach EntryCompletion to Entry- ; entrySetCompletion entry ec- ; return ()- }---- | Set actions for Tab and Escape-entryKeyPress :: (ContainerClass c) => c -> Entry -> EventM EKey Bool-entryKeyPress container entry =- tryEvent $ do- {- kname <- eventKeyName- ; case kname of- "Escape" ->- liftIO $ - grabRemove entry >>- widgetDestroy container- "Tab" ->- -- complete the entry as far as possible- liftIO $- entryGetCompletion entry >>=- entryCompletionInsertPrefix- _ -> stopEvent- } ---- | For debugging (frame context menu command)-dumpFrame :: VPUI -> WinId -> CanvFrame -> IO ()-dumpFrame vpui winId frame = - let vw = vpuiGetWindow vpui winId- canv = vpuiWindowGetCanvas vw- graph = vcGraph canv- frameNode = cfFrameNode frame- frame' = vcGetFrame canv graph frameNode -- ?? possibly different- tree = graphToOrderedTreeFrom graph frameNode- in - info ("frame functoid:", cfFunctoid frame) >>- info ("frame' functoid:", cfFunctoid frame') >>- info ("frame' all descendants:", - nodeAllSimpleDescendants graph frameNode) >>- info "Tree rooted at frame:" >>- putTree tree---- | For debugging (frame context menu command)-dumpGraph :: VPUI -> WinId -> IO ()-dumpGraph vpui = print . vcGraph . vpuiWindowGetCanvas . vpuiGetWindow vpui---- | For debugging the window's widget children-dumpWorkWin :: VPUI -> WinId -> IO ()-dumpWorkWin vpui winId =- case vpuiTryGetWindow vpui winId of- Nothing -> putStrLn ("dumpWorkWin: no window found with id " ++ winId)- Just vpuiWindow ->- let window = vpuiWindowWindow vpuiWindow- in dumpWidget window >>- containerForeach window dumpWidget--dumpWidget :: (WidgetClass w) => w -> IO ()-dumpWidget w = do- {- (_, path, _) <- widgetClassPath w- ; cname <- widgetClassName w- ; vis <- get w widgetVisible- ; print (path, cname, vis)- ; when (elem cname ["GtkVBox", "GtkHBox", "GtkLayout"]) $- containerForeach (castToContainer w) dumpWidget- }--widgetClassName :: (WidgetClass w) => w -> IO String-widgetClassName w = do- {- (_len, _path, rpath) <- widgetClassPath w- ; return (case elemIndex '.' rpath of- Nothing -> "Nil"- Just n -> reverse (take n rpath))- }---- | Clear frame indicated by mouse location-clearFrame :: WinId -> CanvFrame -> VPUI -> IO VPUI-clearFrame winId frame vpui =- let clear canvas = vcClearFrame canvas frame- in vpuiModCanvasIO vpui winId clear---- | Close frame (context menu command)-closeFrame :: VPUI -> WinId -> CanvFrame -> IO VPUI-closeFrame vpui winId frame =- let close canvas = vcCloseFrame canvas frame- in vpuiModCanvasIO vpui winId close
− Workspace/WGraph.hs
@@ -1,409 +0,0 @@-module Workspace.WGraph - (WNode(..), WEdge(..), WGraph, wgraphNew, grInsertNode, grRemoveNode- , connectToFrame- , grConnect, grDisconnect- , grAddGraph- , grExtractExprTree, grExtractLayoutNode, grExtractLayoutTree- - , wlab, llab, nodeExprNode, nodeText, nodeValue- , nodeBBox, nodePosition, nodeInputValues- , nodeAllChildren, nodeSimpleChildren, nodeFrameChildren- , nodeAllSimpleDescendants, nodeProperSimpleDescendants- , nodeIsSimple, nodeIsOpen, nodeContainerFrameNode- , nodeParent-- , grUpdateFLayout, grUpdateTreeLayout- , translateNodes- , translateNode, grRelabelNode- , translateTree- , functoidParts, functionToParts- )--where --import Data.List (sort)-import Data.Maybe (fromJust)--import Data.Graph.Inductive as G--import Geometry-import TreeLayout-import Expr-import Tree as T -- exports Data.Tree.Tree(Node), etc.-import Workspace.Functoid-import Util---- | A WGraph consists of WNodes with (sort of) Int-labled edges;--- the edge labels serve to order the children of a node.--type WGraph = Gr WNode WEdge--data WEdge = WEdge Int- deriving (Eq, Read, Show)--instance Ord WEdge where- compare (WEdge i) (WEdge j) = compare i j---- | Two kinds of WNodes:--- A WSimple node represents a node in an expression tree, e.g., "if", "+"--- A WFrame node represents a panel or frame that displays an expression tree,--- function call, or something similar.--data WNode = WSimple (LayoutNode ExprNode) - | WFrame G.Node- deriving (Eq, Show)--instance Repr WNode where- repr (WSimple lnode) = repr (gnodeValue (nodeGNode lnode))- repr (WFrame _) = "<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 -> errcats ["grRemoveNode: node not found:", show node]- Just _ -> g'---- | Connect parent to child, using inlet as the order of the child--- (0, 1, ...). outlet is ignored, since there is only outlet 0.--- As rendered, the parent's inlet-th inlet will have a line--- to the child's outlet-th outlet.--- This is achieved by inserting a labeled edge (parent, child, inlet)--- and clearing any incompatible edge. The incompatibles are:--- a. from same parent on same inlet to a different child.--- b. from the same parent on a different inlet to the same child.--- c. from same child (on same outlet) to a different parent.------ NOTE: This is confusing, because, from the data flow perspective,--- data flows OUT of the child INTO the parent, but from the--- "tree in graph" perspective, links are directed OUT of the parent--- INTO the child. So beware!--grConnect :: WGraph -> G.Node -> WEdge -> G.Node -> WEdge -> WGraph-grConnect g parent inlet child _outlet =- let (mPcontext, g') = match parent g- in case mPcontext of- Nothing -> error "grConnect: parent not found"- -- should parent below be same as parent above?- Just (pins, jparent, plabel, pouts) ->- -- jparent == parent- let pouts' = filter (edgeNotTo child)- (filter (edgeNotEqual inlet) pouts)- (mCcontext, g'') = match child g'- in case mCcontext of- Nothing -> error "grConnect: child not found"- Just (_cins, jchild, clabel, couts) ->- -- jchild == child- -- remove ANY links into the jchild (c)- let cins' = []- in - (pins, jparent, plabel, (inlet, jchild) : pouts') & - ((cins', jchild, clabel, couts) & g'')--edgeNotEqual :: WEdge -> (WEdge, G.Node) -> Bool-edgeNotEqual edge pair = edge /= fst pair--edgeNotTo :: G.Node -> (WEdge, G.Node) -> Bool-edgeNotTo node pair = node /= snd pair---- | Removes a link between parent and child--- where the edge was labeled inlet (order of child).--- Ignores outlet, which should always be 0.--- If child is not the inlet-th child of parent,--- well, this is an error, but grDisconnect ignores it.--- If toFrameP is true, the child node is--- reconnected as a child to its frame-grDisconnect :: WGraph -> G.Node -> WEdge -> G.Node -> WEdge -> Bool -> WGraph-grDisconnect g parent inlet child _outlet toFrameP =- let (mcontext, g') = match parent g- g'' = case mcontext of- Nothing -> error "grDisconnect: parent not found"- Just (ins, jparent, label, outs) ->- -- jparent == parent- let outs' = filter (/= (inlet, child)) outs- in (ins, jparent, label, outs') & g'- in if toFrameP- then connectToFrame child (nodeContainerFrameNode g parent) g''- else g''--connectToFrame :: G.Node -> G.Node -> WGraph -> WGraph-connectToFrame child frameNode g =- insEdge (frameNode, child, WEdge (outdeg g frameNode)) g--grAddGraph :: (DynGraph g) => g n e -> g n e -> g n e-grAddGraph g1 g2 =- let (_, hi1) = nodeRange g1- (lo2, _) = nodeRange g2- diff = hi1 - lo2 + 1-- adjIncr :: Adj e -> Adj e- adjIncr adj = [(x, node + diff) | (x, node) <- adj]-- ctxIncr :: Context n e -> Context n e- ctxIncr (adjFrom, node, label, adjTo) = - (adjIncr adjFrom, node + diff, label, adjIncr adjTo)-- loop :: (DynGraph g) => g n e -> g n e -> g n e- loop ga gb =- if isEmpty gb- then ga- else let (acontext, gb') = matchAny gb in- ctxIncr acontext & loop ga gb'- in loop g1 g2---- | Extract from a graph the expression with root node n, --- returning a Tree of ExprNode.--- Use only the WSimple nodes of the graph (and n had better be one).-grExtractExprTree :: WGraph -> G.Node -> Tree ExprNode-grExtractExprTree g = fmap layoutNodeSource . grExtractLayoutTree g---- --------------------------------------------------------------- | Finding characteristics of the WNodes in a graph--- It is an implicit error if there is no label for the node---- | wlab is like lab with no Maybe: the node *must* have a label-wlab :: WGraph -> Node -> WNode-wlab g n = fromJust (lab g n)---- | llab is the tree layout node of a WSimple node-llab :: WGraph -> Node -> LayoutNode ExprNode-llab g n = - case wlab g n of- WSimple lnode -> lnode- WFrame _fnode ->- errcat ["llab: node is not simple",- "\nnode ", (show n),- "\n in graph\n",- (show g)]---- | The ExprNode represented by the graph node-nodeExprNode :: WGraph -> Node -> ExprNode-nodeExprNode g n = gnodeValue (nodeGNode (llab g n))---- | The repr of the node's value-nodeText :: WGraph -> Node -> String-nodeText g n = tbText (head (gnodeTextBoxes (nodeGNode (llab g n))))---- | The result of an evaluated node in an expression tree-nodeValue :: WGraph -> Node -> EvalResult-nodeValue g n = mvalue- where ENode _ mvalue = nodeExprNode g n---- | The node's BBox-nodeBBox :: WGraph -> Node -> BBox-nodeBBox g n = gnodeNodeBB (nodeGNode (llab g n))--nodePosition :: WGraph -> Node -> Position-nodePosition g = bbPosition . nodeBBox g--nodeInputValues :: WGraph -> Node -> EvalResult-nodeInputValues graph node = - mapM (nodeValue graph) (nodeSimpleChildren graph node) >>= - EvalOk . VList- --- | Finding the children (nodes, numbers) of a node in a graph :--- all children, only WSimple-labeled children, only WFrame-labeled children--- When constructing the graph, ordered children of a tree node --- get graph node numbers in ascending order; therefore,--- sorting the graph nodes gives back the original order of--- children in the tree (plus WFrames that are added later,--- and those should always be after the simple children)--nodeAllChildren :: WGraph -> Node -> [Node]-nodeAllChildren g n = sort (suc g n) --nodeSimpleChildren :: WGraph -> Node -> [Node]-nodeSimpleChildren g n = filter (nodeIsSimple g) (nodeAllChildren g n)--nodeAllSimpleDescendants :: WGraph -> Node -> [Node]-nodeAllSimpleDescendants g n = - n : concatMap (nodeAllSimpleDescendants g) (nodeSimpleChildren g n)--nodeProperSimpleDescendants :: WGraph -> Node -> [Node]-nodeProperSimpleDescendants g n = tail (nodeAllSimpleDescendants g n)--nodeFrameChildren :: WGraph -> Node -> [Node]-nodeFrameChildren g n = filter (not . nodeIsSimple g) (nodeAllChildren g n)- -nodeIsSimple :: WGraph -> Node -> Bool-nodeIsSimple g n = - -- is node n of graph g a WSimple node?- case lab g n of- Just (WSimple _) -> True- _ -> False---- | An open node has a WFrame-labeled child-nodeIsOpen :: WGraph -> Node -> Bool-nodeIsOpen graph node = nodeFrameChildren graph node /= []---- The root node of the tree in which node occurs.--- This is a WSimple node, it may not back up to a WFrame node.------ THIS CODE IS UNTESTED, AND CURRENTLY UNUSED (2009/2/4)---- -- nodeTreeRoot: unused--- nodeTreeRoot :: WGraph -> Node -> Node--- nodeTreeRoot g n = findRoot n--- where findRoot node = --- case pre g node of--- [] -> (error "nodeTreeRoot: no simple root found")--- [parent] -> --- if not (nodeIsSimple g parent)--- then node--- else findRoot parent--- _ -> error "nodeTreeRoot: node has multiple parents"---- -- The root (a WSimple node) of the tree in which a node occurs--- -- Huh, don't need this!---- -- nodeSimpleRoot: unused--- nodeSimpleRoot :: WGraph -> Node -> Node--- nodeSimpleRoot = undefined---- | The graph node of the frame that contains the given node-nodeContainerFrameNode :: WGraph -> Node -> Node-nodeContainerFrameNode g n = - let findFrame node =- if not (nodeIsSimple g node)- then node- else case pre g node of- [parent] -> findFrame parent- [] -> err "has no parent but is not a frame node" node- _:_ -> err "has multiple parents" node- err msg node =- errcat["nodeContainerFrameNode: node ",- show node, " ", msg, "\n",- "in graph\n", show g]- - in findFrame n---- | The parent (if any) of a node-nodeParent :: WGraph -> Node -> Maybe Node-nodeParent g n = - case pre g n of- [] -> Nothing- [parent] -> Just parent- _ -> error "nodeParent: multiple parents"---grUpdateFLayout :: WGraph -> [G.Node] -> FunctoidLayout -> WGraph-grUpdateFLayout gr ns tlo =- case tlo of- FLayoutTree t -> - case ns of- [rootNode] -> grUpdateTreeLayout gr rootNode t- _ -> error "grUpdateFLayout: tree tlo, but not a single root"- FLayoutForest f _b ->- let accum g (n, t) = grUpdateTreeLayout g n t- in foldl accum gr (zip ns f)---- | Replace the tree embedded in graph g with root n, with a new tree.-grUpdateTreeLayout :: WGraph -> G.Node -> TreeLayout ExprNode -> WGraph-grUpdateTreeLayout gr n0 t0 = updateTree gr n0 t0- where updateTree g n (T.Node root subtrees) =- case match n g of- (Just (adjFrom, jn, WSimple _, adjTo), g1) ->- -- jn == n- let g2 = (adjFrom, jn, WSimple root, adjTo) & g1- in updateForest g2 (nodeSimpleChildren g jn) subtrees- (Just (_adjFrom, _n, _, _adjTo), _) ->- error "grUpdateTreeLayout: root node is not a WSimple"- (Nothing, _) -> - errcats ["grUpdateTreeLayout: no such node:", show n]-- updateForest g [] [] = g- updateForest g (n:ns) (t:ts) = - case lab g n of- Just (WSimple _) -> updateForest (updateTree g n t) ns ts- Just (WFrame _) -> updateForest g ns (t:ts) -- shouldn't happen!- Nothing -> error "grUpdateTreeLayout: no label for node"-- updateForest _g _ [] = error "too many ns"- updateForest _g [] _ = error "too many ts"---- | Extract just the single tree layout node of the given graph node-grExtractLayoutNode :: WGraph -> G.Node -> LayoutNode ExprNode-grExtractLayoutNode g n =- case lab g n of- Just (WSimple lnode) -> lnode- _ -> errcats ["grExtractLayoutNode:",- "no label for node, or node is not WSimple:",- "node", show n]---- | Extract the tree layout (tree) descended from the given root node-grExtractLayoutTree :: WGraph -> G.Node -> TreeLayout ExprNode-grExtractLayoutTree g n =- T.Node (grExtractLayoutNode g n)- (map (grExtractLayoutTree g) (nodeSimpleChildren g n))----- | Translate the nodes forming a tree with the given root-translateTree :: Double -> Double -> WGraph -> G.Node -> WGraph-translateTree dx dy wgraph root = - grUpdateTreeLayout wgraph root - (translate dx dy (grExtractLayoutTree wgraph root))---translateNodes :: Double -> Double -> WGraph -> [G.Node] -> WGraph-translateNodes dx dy = foldl (translateNode dx dy)--translateNode :: Double -> Double -> WGraph -> G.Node -> WGraph-translateNode dx dy wg node =- case match node wg of- (Nothing, _) ->- errcats ["translateNode: no such node:", show node]- (Just (adjFrom, jnode, WSimple layoutNode, adjTo), g') ->- -- jnode == node- (adjFrom, jnode, WSimple (translate dx dy layoutNode), adjTo) & g'- (Just _, _) ->- errcats ["translateNode: node is not a WSimple:", show node]----- | Replace the label of a node in a graph-grRelabelNode :: (DynGraph g) => g a b -> G.Node -> a -> g a b-grRelabelNode g n newLabel =- case match n g of- (Just (adjFrom, jn, _oldLabel, adjTo), g') ->- -- jn == n- (adjFrom, jn, newLabel, adjTo) & g'- (Nothing, _) -> errcats ["grRelabelNode: no such node:", show n]---- | Get the parts of a Functoid.--- See note on functionToParts (just below).--- ** Seems to be unused--functoidParts :: Functoid -> WGraph -> G.Node -> Functoid-functoidParts functoid graph frameNode =- case functoid of- fp@FunctoidParts {} -> fp- FunctoidFunc function -> functionToParts function graph frameNode---- | Convert a function to its parts.--- COULDN'T THIS BE DONE USING the function's implementation,--- and not need to use the graph? Then this could go in Functoid.hs--- without circular import between it and WGraph-functionToParts :: Function -> WGraph -> G.Node -> Functoid-functionToParts (Function mname _atypes _rtype impl) graph frameNode =- case impl of - Primitive _ -> error "functionToParts: function is primitive"- Compound argnames _body ->- FunctoidParts {fpName = case mname of- Nothing -> "unnamed function"- Just jname -> jname,- fpArgs = argnames, - fpNodes = nodeProperSimpleDescendants graph frameNode}
− Workspace/Workspace.hs
@@ -1,409 +0,0 @@-{- Currently, this module contains functions for VPUI, VPUIWindow,-Workspace, VCanvas, and more. A reorganization seems called for,-but for now I will just keep adding functions here. -}--module Workspace.Workspace- (- -- VPUI and Workspace- vpuiNew- , defaultVPUIToolkits- , Workspace(..), workspaceNewDefault, workspaceNewEditing- , addArgToolButtons- , addApplyCloseButtons- , defineFunction- , openNode-- -- Quitting:- , removeWindow- , vpuiQuit-- -- Windows:- , forallWindowsIO- )--where--import Control.Monad--import Data.Map (Map, (!), fromList, keys)-import qualified Data.Map as Map (empty)--import Data.Graph.Inductive as G-import LittleGtk--import CBMgr-import Examples-import Expr-import Geometry-import GtkUtil-import TreeGraph-import TreeLayout-import UITypes-import Util-import Workspace.Canvas-import Workspace.Frame-import Workspace.Functoid-import Workspace.Tools-import Workspace.WGraph---- | Create a new VPUI.--- This used to set up the basic "q to quit" and "on exposed" callbacks,--- but now does not even do that. --- The 'init' function argument--- may perform additional initialization;--- if there is none, simply use 'return'.---- The following comment is out of date,--- but may explain some bizarre features historically:---- Note that if you want to set up callbacks,--- there is some trickiness: the vpui contains the workspace,--- and the layout (which is on the workspace) needs to have callbacks--- which know the uiref. So, create the workspace, vpui, and uiref,--- in that order, and then set up the callbacks.---vpuiNew :: Style -> Env -> IO VPUI-vpuiNew style env =- return VPUI {vpuiWindows = Map.empty,- vpuiToolkits = Map.empty,- vpuiFilePath = Nothing,- vpuiStyle = style,- vpuiInitialEnv = env,- vpuiGlobalEnv = env,- vpuiFileEnv = env- }--baseFunctionsRows :: [[String]]-baseFunctionsRows = [["+", "-", "*", "div", "mod", "add1", "sub1", "/"],- ["==", "/=", "<", ">", "<=", ">="],- ["zero?", "positive?", "negative?"],- ["null", "head", "tail", ":"]]--defaultVPUIToolkits :: Map String VPToolkit-defaultVPUIToolkits =- let toolkits =- -- each item has name, width, list of rows tools- [VPToolkit "Base" 500 (functionToolsFromLists baseFunctionsRows),- VPToolkit "Examples" 500 - (functionToolsFromLists [exampleFunctionNames]),- VPToolkit "My Functions" 500 (functionToolsFromLists [[]])]- in fromList (zip (map toolkitName toolkits) toolkits)----- | Create a new "main" workspace window, with a given style.--- The second argument should set up a menu bar and place it on the vbox, --- or do nothing if no menu is wanted.-workspaceNewDefault :: Style -> (VBox -> IO ()) -> IO Workspace-workspaceNewDefault style = - workspaceNew style (Size 3600.0 2400.0) (Just (Size 900.0 600.0)) --workspaceNewEditing :: Style -> Env -> Function -> IO Workspace-workspaceNewEditing style initEnv func = do- {- ; let funcFrame = fedFuncFrame style func initEnv -- throw-away- Size fwidth fheight = bbSize (cfBox funcFrame)- canvSize = Size (max fwidth 300) (max fheight 300)- mViewSize = Nothing- addNoMenu _ = return ()- ; workspaceNew style canvSize mViewSize addNoMenu- }--addArgToolButtons :: CBMgr -> WinId -> [String] -> VPUI -> IO ()-addArgToolButtons cbmgr winId labels vpui =- case vpuiGetWindow vpui winId of- VPUIWorkWin ws _ -> - let bbar = wsButtonBar ws- in mapM_ (addArgToolButton cbmgr winId bbar) labels- _ -> return ()- -addArgToolButton :: CBMgr -> WinId -> HBox -> String -> IO ()-addArgToolButton cbmgr winId buttonBox label = do- {- button <- buttonNewWithLabel label- ; boxPackStart buttonBox button PackNatural 3 -- spacing between buttons- ; widgetShow button- ; cbmgr (AfterButtonClicked button - (\ uiref ->- modifyIORefIO uiref (vpuiSetTool (ToolArg label) winId)))- ; return ()- }---- | Add "Apply" and "Close" buttons to a function-editor window-addApplyCloseButtons :: CBMgr -> WinId -> VPUI -> IO ()-addApplyCloseButtons cbmgr winId vpui = - case vpuiGetWindow vpui winId of- VPUIWorkWin ws window ->- addApplyCloseButtons2 cbmgr winId ws window- _ -> return ()--addApplyCloseButtons2 :: CBMgr -> WinId -> Workspace -> Window -> IO ()-addApplyCloseButtons2 cbmgr winId ws window =- let bbar = wsButtonBar ws- applyFrame :: VPUI -> IO VPUI- applyFrame vpui = - case vcFrames (vpuiWindowGetCanvas (vpuiGetWindow vpui winId)) of- [frame] -> defineFunction winId frame vpui- _ -> info "ApplyFrame: no unique frame found" >> return vpui- -- addButton :: String -> (IORef VPUI -> IO ())- addButton label action = do- {- button <- buttonNewWithLabel label- ; boxPackEnd bbar button PackNatural 3- ; widgetShow button- ; cbmgr (AfterButtonClicked button action)- }- in addButton "Close" (\ _uiref -> widgetDestroy window) >>- addButton "Apply" (\ uiref -> modifyIORefIO uiref applyFrame)---- | fedFuncFrame generates a throw-away frame for the sole purplse--- of obtaining its measurements before initializing the canvas--fedFuncFrame :: Style -> Function -> Env -> CanvFrame-fedFuncFrame style func prevEnv = - let (frame, _) =- frameNewWithLayout style (Position 0 0) 0 - (FunctoidFunc func) Nothing- CallFrame -- mode may change below- 0 prevEnv Nothing- in frame----- | If mViewSize is Nothing, no scrollbars are put on the canvas,--- and its display size request is its natural size.--- If mViewSize = Just viewSize, then scrollbars are wrapped around--- the canvas, and its displayed size request is viewSize.--- addMenuBar is an action which, if desired, adds a menu bar;--- if you don't want one, just pass (\ _ -> return ()).--workspaceNew :: Style -> Size -> Maybe Size -> (VBox -> IO ()) -> IO Workspace-workspaceNew style canvSize mViewSize addMenuBar = do- {- ; let Size dcWidth dcHeight = canvSize -- Double, Double- (icWidth, icHeight) = (round dcWidth, round dcHeight)-- scrolled :: GtkLayout -> Size -> IO ScrolledWindow- scrolled layout viewSize = do- {- let Size dvWidth dvHeight = viewSize -- Double, Double- (iViewWidth, iViewHeight) = (round dvWidth, round dvHeight)- -- Wrap layout directly in a ScrolledWindow .- -- Adjustments: value lower upper stepIncr pageIncr pageSize- ; xAdj <- adjustmentNew 0.0 0.0 dcWidth 10.0 dvWidth dvWidth- ; yAdj <- adjustmentNew 0.0 0.0 dcHeight 10.0 dvHeight dvHeight- ; scrollWin <- scrolledWindowNew (Just xAdj) (Just yAdj)- -- show scrollbars? (never, always, or if needed)- ; scrolledWindowSetPolicy scrollWin PolicyAutomatic PolicyAutomatic- -- request view size for _layout_- ; widgetSetSizeRequest layout iViewWidth iViewHeight- ; set scrollWin [containerChild := layout]- ; return scrollWin- }-- bare :: GtkLayout -> IO GtkLayout- bare layout = do- {- -- request canvas size for _layout_- ; widgetSetSizeRequest layout icWidth icHeight -- new- ; return layout- }-- -- The canvas itself- ; vcanvas <- vcanvasNew style dcWidth dcHeight- ; let layout = vcLayout vcanvas- -- Set the actual size of the canvas layout, which may be more- -- than is displayed if scrollbars are used- ; layoutSetSize layout icWidth icHeight-- -- An empty HBox for buttons (or it may remain empty)- ; buttonBar <- hBoxNew False 3-- -- The Statusbar- ; statusBar <- statusbarNew- - -- All together in a VBox- ; vbox <- vBoxNew False 0 -- not equal space allotments, 0 spacing-- ; addMenuBar vbox-- ; let packGrow :: WidgetClass w => w -> IO ()- packGrow w = boxPackStart vbox w PackGrow 0- ; case mViewSize of- Nothing -> bare layout >>= packGrow- Just viewSize -> scrolled layout viewSize >>= packGrow-- ; boxPackStart vbox buttonBar PackNatural 0- ; boxPackStart vbox statusBar PackNatural 0- ; return $ Workspace vbox vcanvas buttonBar statusBar-}---vpuiQuit :: VPUI -> IO VPUI-vpuiQuit vpui = do- {- -- *** This should also check for unsaved changes? ***- vpui' <- foldM (\ vp winId -> removeWindow vp True winId)- vpui- (vpuiAllWindowKeys vpui)- ; mainQuit- ; return vpui'- }---- | List of all window ids of the vpui, --vpuiAllWindowKeys :: VPUI -> [WinId]-vpuiAllWindowKeys = keys . vpuiWindows---- | Perform action on all windows--- (actually (WinId, VPUIWindow) pairs.--- Returns updated VPUI (in case any windows are changed).--forallWindowsIO :: (VPUIWindow -> IO VPUIWindow) -> VPUI -> IO VPUI-forallWindowsIO action vpui = - let loop ks vpui' =- case ks of- [] -> return vpui'- k : ks' -> - let w = vpuiGetWindow vpui' k- in do - {- w' <- action w- ; loop ks' (vpuiReplaceWindow vpui' k w')- }- in loop (vpuiAllWindowKeys vpui) vpui----- | This function is called either when a window *has been* destroyed,--- with destroy = False,--- or when you *want to* destroy a window, with destroy = True.---- WOULD BE BETTER to have two functions, windowRemoved and removeWindow???---- | removeWindow actually *closes* the window if destroy = True,--- as well as removing it from the vpui's windows map.-removeWindow :: VPUI -> Bool -> WinId -> IO VPUI-removeWindow vpui destroy winId = do- {- -- Remove the window from vpui;- -- if destroy is true, also destroy it.- -- It is an error if the window id does not exist.- let vwMap = vpuiWindows vpui- ; when destroy $ widgetDestroy (vpuiWindowWindow (vwMap ! winId))- ; return $ vpuiRemoveVPUIWindow winId vpui- }---- | Context menu command to apply the function definition--- of an EditFrame.---- | "Execute" the definition currently represented in the frame,--- i.e., bind the function name in the global environment--- to the function definition found in the frame.--defineFunction :: WinId -> CanvFrame -> VPUI -> IO VPUI-defineFunction winId frame vpui = - case frameType frame of- CallFrame ->- showErrorMessage "Software error\nNot in an edit frame!"- >> return vpui- EditFrame ->- case cfFunctoid frame of- FunctoidFunc _function ->- return vpui- fparts@FunctoidParts {} ->- let env = vpuiGlobalEnv vpui- vw = vpuiGetWindow vpui winId- canv = vpuiWindowGetCanvas vw- graph = vcGraph canv- frameNode = cfFrameNode frame- in case functoidToFunction fparts graph frameNode env of- Fail errmsg -> - showErrorMessage errmsg >>- return vpui- Succ function ->- let BBox x y _ _ = cfBox frame- z = cfLevel frame- fname = functionName function- env' = envSet env fname (VFun function)- vpui' = vpui {vpuiGlobalEnv = env'}- in do - {- ; canv' <- vcCloseFrame canv frame- -- ** can this use vpuiAddFrame?- ; canv'' <- - vcAddFrame canv' (FunctoidFunc function) - Nothing - EditFrame- env' x y z Nothing- ; let vw' = vpuiWindowSetCanvas vw canv''- vpui'' = vpuiReplaceWindow vpui' winId vw'- ; vpuiUpdateCallFrames vpui'' fname- }---- | In the workspace window, update each frame calling the named function --- to reflect the current function definition-vpuiUpdateCallFrames :: VPUI -> String -> IO VPUI-vpuiUpdateCallFrames vpui fname = - let winId = "Sifflet Workspace" - in case vpuiTryGetWindow vpui winId of- Nothing -> return vpui- Just w -> do- {- ; let canvas = vpuiWindowGetCanvas w- env = vpuiGlobalEnv vpui- frames = callFrames canvas fname- update canv frame = canvasUpdateCallFrame canv frame fname env- ; canvas' <- foldM update canvas frames - ; let w' = vpuiWindowSetCanvas w canvas'- ; return $ vpuiReplaceWindow vpui winId w'- }---- | In the canvas, update a call frame with the current function--- definition from the environment, returning a new canvas.--- Root call frames are torn down and rebuilt with the new function definition.--- Call frames that are called by other call frames are simply torn down.-canvasUpdateCallFrame :: VCanvas -> CanvFrame -> String -> Env -> IO VCanvas-canvasUpdateCallFrame canvas frame fname env = do- {- -- Tear down old frame- canvas' <- vcCloseFrame canvas frame- ; case cfParent frame of- Nothing -> - -- root frame; build up new frame- let Position x y = bbPosition (cfBox frame)- z = cfLevel frame- functoid = FunctoidFunc {fpFunc = envGetFunction env fname}- in vcAddFrame canvas' functoid Nothing CallFrame env x y z Nothing- Just _ -> - -- frame with a parent; finished- return canvas'- }--openNode :: VPUIWindow -> G.Node -> IO VPUIWindow-openNode vw node = do- let canvas = vpuiWindowGetCanvas vw- graph = vcGraph canvas- if not (nodeIsSimple graph node)- then return vw -- WFrame node -- is this possible?- else if nodeIsOpen graph node- then info "Already open" >> return vw- else let frame = nodeContainerFrame canvas graph node- in case nodeCompoundFunction graph frame node of- Nothing -> - info "Cannot be opened" >> return vw- Just function ->- case nodeInputValues graph node of- EvalOk (VList values) ->- let env = extendEnv (functionArgNames function)- values (cfEnv frame)- Position x y = - frameOffset (vcStyle canvas) frame- z = succ (cfLevel frame)- in vwAddFrame vw - (FunctoidFunc function) - (Just values) CallFrame- env x y z (Just node)- EvalOk x ->- errcats ["openNode: non-VList result:", show x]- _ -> - info "Cannot be opened: lacking input values" >>- return vw
sifflet.cabal view
@@ -1,5 +1,5 @@ name: sifflet-version: 0.1.7+version: 1.0 cabal-version: >= 1.6 build-type: Simple license: BSD3@@ -9,7 +9,7 @@ maintainer: "gdweber" ++ drop 3 "abc@" ++ "iue.edu" bug-reports: mailto:"gdweber" ++ drop 3 "abc@" ++ "iue.edu" homepage: http://mypage.iu.edu/~gdweber/software/sifflet/-stability: experimental+stability: Experimental. synopsis: A simple, visual, functional programming language. description: Sifflet is a visual, functional programming language. Sifflet users can make programs by drawing diagrams@@ -25,35 +25,37 @@ -- data-dir: directory -- extra-tmp-files: filename list -extra-source-files: CBMgr.hs Examples.hs Expr.hs Geometry.hs GtkForeign.hs - GtkUtil.hs LittleGtk.hs - RPanel.hs SiffML.hs Tree.hs TreeGraph.hs TreeLayout.hs- UITypes.hs Util.hs WindowManagement.hs Workspace.hs- Workspace/Canvas.hs Workspace/Frame.hs- Workspace/Functoid.hs Workspace/Tools.hs Workspace/WGraph.hs- Workspace/Workspace.hs- README+extra-source-files: README +flag no-link+ description: Inhibit linking; just compile.+ default: False+ executable sifflet main-is: sifflet.hs build-depends: - base >= 4.0.0.0 && < 5,--- begin GTK stuff, should have same version numbers- cairo >= 0.10.0 && < 0.12.0,- glib >= 0.10.0 && < 0.12.0,- gtk >= 0.10.0 && < 0.12.0,--- end- containers >= 0.2 && < 1.0,- fgl >= 5.4 && < 5.4.2.3,- haskell98,- haskell-src >= 1.0 && < 2.0,- hxt >= 8.3 && < 9,- mtl >= 1.1 && < 2.0,- process >= 1.0 && < 2.0+ base >= 4.0 && < 4.3,+ -- begin GTK stuff, should have same version numbers+ cairo == 0.11.0,+ glib == 0.11.0,+ gtk == 0.11.0,+ -- end+ containers >= 0.2 && < 0.4,+ fgl >= 5.4 && < 5.5,+ haskell98 >= 1.0.1 && < 1.0.2,+ haskell-src >= 1.0.1 && < 1.0.2,+ hxt >= 8.3 && < 8.6,+ mtl >= 1.1 && < 1.2,+ process >= 1.0 && < 1.1,+ -- and of course our very own ...+ sifflet-lib == 1.0+ if !os(windows)- build-depends: unix >= 2.3 && < 3.0+ build-depends: unix >= 2.3 && < 2.5 buildable: True extensions: ForeignFunctionInterface CPP ghc-options: -Wall+ if flag(no-link)+ ghc-options: -c includes: gtk-2.0/gtk/gtk.h, gtk-2.0/gdk/gdk.h extra-libraries: gdk-x11-2.0 gtk-x11-2.0
sifflet.hs view
@@ -2,28 +2,31 @@ import Data.IORef --- external libraries-import LittleGtk - -- hiding (Frame, Function, Style, buttonPressed, fill, lineWidth,- -- disconnect, function)---- sifflet modules-import CBMgr-import Examples-import Expr-import GtkUtil-import TreeLayout-import WindowManagement-import Workspace-import UITypes-+import Sifflet.Data.TreeLayout+import Sifflet.Examples+import Sifflet.Language.Expr+import Sifflet.UI -- ------------------------------------------------------------------------ Environment+-- | Environment initialEnv :: Env initialEnv = exampleEnv +-- | Default toolkit++defaultVPUIToolkitsWithExamples :: [(String, VPToolkit)]+defaultVPUIToolkitsWithExamples =+ let toolkits =+ -- each item has name, width, list of rows tools+ [VPToolkit "Base" 500 (functionToolsFromLists baseFunctionsRows),+ VPToolkit "Examples" 500 + (functionToolsFromLists [exampleFunctionNames]),+ VPToolkit "My Functions" 500 (functionToolsFromLists [[]])]+ in zip (map toolkitName toolkits) toolkits++-- | Main function+ main :: IO () main = do {@@ -35,7 +38,7 @@ -- create the user interface ; vpui <- vpuiNew wstyle initialEnv- ; let vpui' = vpui {vpuiToolkits = defaultVPUIToolkits}+ ; let vpui' = vpui {vpuiToolkits = defaultVPUIToolkitsWithExamples} workId = "Sifflet Workspace" ; uiref <- newIORef vpui' -- Create wome windows