sifflet-lib (empty) → 1.0
raw patch · 39 files changed
+10760/−0 lines, 39 filesdep +basedep +cairodep +containerssetup-changed
Dependencies added: base, cairo, containers, directory, fgl, filepath, glib, gtk, haskell-src, haskell98, hxt, mtl, parsec, process, unix
Files
- LICENSE +32/−0
- README +36/−0
- Setup.hs +3/−0
- Sifflet/Data/Functoid.hs +98/−0
- Sifflet/Data/Geometry.hs +162/−0
- Sifflet/Data/Number.hs +288/−0
- Sifflet/Data/Tree.hs +67/−0
- Sifflet/Data/TreeGraph.hs +250/−0
- Sifflet/Data/TreeLayout.hs +660/−0
- Sifflet/Data/WGraph.hs +410/−0
- Sifflet/Examples.hs +290/−0
- Sifflet/Foreign/Exporter.hs +8/−0
- Sifflet/Foreign/Python.hs +435/−0
- Sifflet/Foreign/ToHaskell.hs +351/−0
- Sifflet/Foreign/ToPython.hs +165/−0
- Sifflet/Foreign/ToScheme.hs +311/−0
- Sifflet/Language/Expr.hs +1073/−0
- Sifflet/Language/Parser.hs +288/−0
- Sifflet/Language/SiffML.hs +403/−0
- Sifflet/Rendering/Draw.hs +223/−0
- Sifflet/Rendering/DrawTreeGraph.hs +182/−0
- Sifflet/Text/Pretty.hs +48/−0
- Sifflet/Text/Repr.hs +62/−0
- Sifflet/UI.hs +30/−0
- Sifflet/UI/Callback.hs +140/−0
- Sifflet/UI/Canvas.hs +988/−0
- Sifflet/UI/Frame.hs +306/−0
- Sifflet/UI/GtkForeign.hs +123/−0
- Sifflet/UI/GtkUtil.hs +224/−0
- Sifflet/UI/LittleGtk.hs +178/−0
- Sifflet/UI/RPanel.hs +154/−0
- Sifflet/UI/Tool.hs +549/−0
- Sifflet/UI/Types.hs +308/−0
- Sifflet/UI/Window.hs +1147/−0
- Sifflet/UI/Workspace.hs +402/−0
- Sifflet/Util.hs +135/−0
- data/sifflet.py +107/−0
- data/sifflet.scm +28/−0
- sifflet-lib.cabal +96/−0
+ LICENSE view
@@ -0,0 +1,32 @@+Sifflet License++Copyright (C) 2010 Gregory D. Weber+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++- Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++- Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++- Neither the name of the copyright holder nor the names of its+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README view
@@ -0,0 +1,36 @@+Sifflet -- README -- Sifflet++Rights+------++Copyright (C) 2010 Gregory D. Weber++BSD3 license -- see the file "LICENSE" for details++Installation+------------++1. Configure, either for system-wide installation:++ $ runghc Setup configure++ or for installation in a user directory:+ + $ runghc Setup configure --user --prefix=~/where/to/install/++2. Build and install:++ $ runghc Setup build+ $ runghc Setup install++Documentation+-------------++Please see the Sifflet home page for documentation:++ http://mypage.iu.edu/~gdweber/software/sifflet/++and especially the tutorial:++ http://mypage.iu.edu/~gdweber/software/sifflet/doc/tutorial.html+
+ Setup.hs view
@@ -0,0 +1,3 @@+-- Simple setup+import Distribution.Simple+main = defaultMain
+ Sifflet/Data/Functoid.hs view
@@ -0,0 +1,98 @@+module Sifflet.Data.Functoid+ (Functoid(..)+ , functoidName, functoidArgNames, functoidHeader+ , FunctoidLayout(..), flayout+ , flayoutBBox, flayoutSize, flayoutWidth, flayoutBottom+ , flayoutWiden)++where++import Data.Graph.Inductive as G++import Sifflet.Data.Geometry+import Sifflet.Language.Expr+import Sifflet.Data.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 Translate FunctoidLayout where+ translate dx dy fl =+ case fl of+ FLayoutTree t -> + FLayoutTree (translate dx dy t)+ FLayoutForest f b ->+ FLayoutForest (translate dx dy f) (translate dx dy b)
+ Sifflet/Data/Geometry.hs view
@@ -0,0 +1,162 @@+module Sifflet.Data.Geometry+ (Position(..), + positionDelta, positionDistance,+ positionDistanceSquared, positionCloseEnough,+ Circle(..), pointInCircle,+ Size(..),+ BBox(..), + bbX, bbY, bbWidth, bbSetWidth, bbHeight, bbPosition, bbSize,+ bbToRect, bbFromRect, bbCenter, bbLeft, bbXCenter, bbRight,+ bbTop, bbYCenter, bbBottom,+ bbMerge, bbMergeList, pointInBB,+ Widen(widen),+ Translate(..)+ )++where++import Data.Tree as T+import Graphics.UI.Gtk(Rectangle(Rectangle))++-- A Position may be interpreted either absolutely, as a point (x, y);+-- or relatively, as an offset (dx, dy)++data Position = Position {posX :: Double, posY :: Double} -- x, y+ deriving (Eq, Read, Show)++positionDelta :: Position -> Position -> (Double, Double)+positionDelta (Position x1 y1) (Position x2 y2) = (x2 - x1, y2 - y1)++positionDistance :: Position -> Position -> Double+positionDistance p1 p2 = sqrt (positionDistanceSquared p1 p2)++positionDistanceSquared :: Position -> Position -> Double+positionDistanceSquared (Position x1 y1) (Position x2 y2) =+ (x1 - x2) ** 2 + (y1 - y2) ** 2++positionCloseEnough :: Position -> Position -> Double -> Bool+positionCloseEnough p1 p2 radius =+ -- Essentially asks if p1 and p2 are nearly intersecting,+ -- i.e., if p1 is within a circle with center p2 and the given radius+ positionDistanceSquared p1 p2 <= radius ** 2++++data Circle = Circle {circleCenter :: Position,+ circleRadius :: Double}+ deriving (Eq, Read, Show)++pointInCircle :: Position -> Circle -> Bool+pointInCircle point (Circle center radius) =+ positionCloseEnough point center radius++data Size = Size {sizeW :: Double, sizeH :: Double} -- width, height+ deriving (Eq, Read, Show)++-- | BBox x y width height; (x, y) is the top left corner++data BBox = BBox Double Double Double Double+ deriving (Eq, Read, Show)++-- | BBox accessors and utilities++bbX, bbY, bbWidth, bbHeight :: BBox -> Double+bbX (BBox x _y _w _h) = x++bbY (BBox _x y _w _h) = y+bbWidth (BBox _x _y w _h) = w+bbHeight (BBox _x _y _w h) = h++bbPosition :: BBox -> Position+bbPosition (BBox x y _w _h) = Position x y++bbSize :: BBox -> Size+bbSize (BBox _x _y w h) = Size w h++bbCenter :: BBox -> Position+bbCenter (BBox x y w h) = Position (x + w / 2) (y + h / 2)++bbSetWidth :: BBox -> Double -> BBox+bbSetWidth (BBox x y _w h) nwidth = BBox x y nwidth h++bbLeft, bbXCenter, bbRight :: BBox -> Double+bbLeft = bbX+bbXCenter (BBox x _y w _h) = x + w / 2+bbRight (BBox x _y w _h) = x + w++bbTop, bbYCenter, bbBottom :: BBox -> Double+bbTop = bbY+bbYCenter (BBox _x y _w h) = y + h / 2+bbBottom (BBox _x y _w h) = y + h++bbToRect :: BBox -> Rectangle+bbToRect (BBox x y w h) = + Rectangle (round x) (round y) (round w) (round h)++bbFromRect :: Rectangle -> BBox+bbFromRect (Rectangle x y w h) =+ BBox (fromIntegral x) (fromIntegral y)+ (fromIntegral w) (fromIntegral h)++-- | Form a new BBox which encloses two bboxes+bbMerge :: BBox -> BBox -> BBox+bbMerge bb1 bb2 =+ let f1 ! f2 = f1 (f2 bb1) (f2 bb2)+ bottom = max ! bbBottom -- i.e., max (bbBottom bb1) (bbBottom bb2)+ top = min ! bbTop+ left = min ! bbLeft+ right = max ! bbRight+ in BBox left top (right - left) (bottom - top)++bbMergeList :: [BBox] -> BBox+bbMergeList [] = error "bbMergeList: empty list"+bbMergeList (b:bs) = foldl bbMerge b bs+ +-- Test whether a point (e.g., from mouse click) is within a+-- bounding box+pointInBB :: Position -> BBox -> Bool+pointInBB (Position x y) (BBox x1 y1 w h) =+ x >= x1 &&+ x <= x1 + w &&+ y >= y1 &&+ y <= y1 + h++class Widen a where+ -- | Make an object have at least a specified minimum width;+ -- does nothing if it's already at least that wide+ widen :: a -> Double -> a++instance Widen BBox where+ widen bb@(BBox x y w h) minWidth =+ if w >= minWidth+ then bb+ else BBox x y minWidth h++-- | A Translate is a thing that can be repositioned by+-- delta x and delta y++class Translate a where+ translate :: Double -- ^ delta X+ -> Double -- ^ delta Y+ -> a -- ^ thing in old position+ -> a -- ^ thing in new position++instance (Translate e) => Translate [e] where+ translate dx dy = map (translate dx dy)++instance (Translate e) => Translate (Tree e) where+ translate dx dy t = + T.Node (translate dx dy (rootLabel t))+ (translate dx dy (subForest t))+++instance Translate BBox where+ translate dx dy (BBox x y w h) = BBox (x + dx) (y + dy) w h++instance Translate Position where+ translate dx dy (Position x y) = Position (x + dx) (y + dy)++instance Translate Circle where+ translate dx dy (Circle center radius) =+ Circle (translate dx dy center) radius+
+ Sifflet/Data/Number.hs view
@@ -0,0 +1,288 @@+-- | This module provides the Number type and many operations upon it.+-- Most of the operations are provided by making Number an instance+-- of the classes Num, Real, Enum, Integral, Fractional, Floating,+-- and RealFrac. These are, I think, all of the normal Haskell+-- numeric type classes *except* RealFloat.+-- There are also a few functions defined in addition to the+-- class methods.+--+-- The *primary* purpose of this module is to be the library module+-- used by Sifflet programs exported to Haskell.+-- The *secondary* purpose (maybe no less important, but+-- realized after the first) is to implement the Sifflet+-- number Values (currently done with the VInt and VFloat constructors).++module Sifflet.Data.Number+ (+ Number(..)+ , isExact, toInexact+ , add1, sub1, eqZero, gtZero, ltZero+ -- The following are only for testing, and should ultimately go to+ -- the tests directory:+ , testI, testJ, testX, testY+ )++where++-- | A Number represents a real number, which can be exact (Integer)+-- or inexact (Double).++data Number = Exact Integer | Inexact Double+ deriving (Eq, Read)++-- | Tell whether a Number is exact+isExact :: Number -> Bool+isExact (Exact _) = True+isExact _ = False++-- | Take a number, which may be exact or inexact, and+-- produce the inexact number which equals it.+-- Note that there is no inverse function toExact, +-- because some inexact numbers like 3.5 are not equal to any exact number.+-- The class RealFrac provides methods round, ceiling, floor, truncate+-- for converting to exact numbers.++toInexact :: Number -> Number+toInexact (Exact x) = Inexact (fromIntegral x)+toInexact xx = xx++toDouble :: Number -> Double+toDouble (Exact ix) = fromIntegral ix+toDouble (Inexact rx) = rx++-- | Unary operations fall into two groups:+-- exactOp1 works only for an exact operand;+-- it is an error if the operand is inexact.+-- The result is always exact.+-- (Unused)+-- inexactOp1 works directly for an inexact operand;+-- otherwise by conversion of its exact operand to inexact;+-- the result is always inexact.+-- eitherOp1 works for either exact or inexact operand,+-- and the result is exact if and only if the operand is exact.++exactOp1 :: String -> (Integer -> Integer) -> (Number -> Number)+exactOp1 name f x =+ case x of+ Exact i -> Exact (f i)+ _ -> error ("Number:" ++ name ++ ": inexact operand: " ++ show x)++inexactOp1 :: (Double -> Double) -> (Number -> Number)+-- inexactOp1 f x = Inexact (f (toDouble x))+inexactOp1 f = Inexact . f . toDouble++eitherOp1 :: (Integer -> Integer) -> (Double -> Double)+ -> (Number -> Number)+eitherOp1 fi fr arg =+ case arg of+ Exact i -> Exact (fi i)+ Inexact r -> Inexact (fr r)++-- | Binary operations fall in 3 groups:+-- exactOp2 is implemented only for exact, exact operands;+-- if there's any inexact operand, it's an error.+-- Integer division operations (quot, rem, div, mod)+-- are like this. The result is always exact.+-- eitherOp2 is implemented directly for exact, exact operands+-- and inexact, inexact operands; if one operand is+-- exact and the other inexact, the exact operand+-- is converted to inexact. Most arithmetic operations+-- (+, -, *) are like this. The result may be exact or inexact.+-- inexactop2 is directly implemented for inexact, inexact operands,+-- but handles exact operands by converting them to inexact+-- (even if both are exact). Math functions such as+-- exp, log, sqrt, and sin are like this. The result+-- is always inexact.++exactOp2 :: String -> (Integer -> Integer -> Integer)+ -> (Number -> Number -> Number)++exactOp2 _ f (Exact i) (Exact j) = Exact (f i j)+exactOp2 name _ x y = + error ("Number:" ++ name ++ ": inexact operand(s): " ++ + show x ++ ", " ++ show y)++inexactOp2 :: (Double -> Double -> Double)+ -> (Number -> Number -> Number)++inexactOp2 f x y = Inexact (f (toDouble x) (toDouble y))+++eitherOp2 :: (Integer -> Integer -> Integer)+ -> (Double -> Double -> Double)+ -> (Number -> Number -> Number)++eitherOp2 fi _ (Exact i) (Exact j) = Exact (fi i j)+eitherOp2 _ fx x y = Inexact (fx (toDouble x) (toDouble y))+++-- | This Show instance will not be compatible with the+-- derived Read instance above -- so fix it.+-- (And yet, mysteriously, ghci accepts 1 and 1.0 as Number literals.)++instance Show Number where+ show (Exact i) = show i+ show (Inexact x) = show x++-- | Number as an ordered type+instance Ord Number where+ compare (Exact x) (Exact y) = compare x y+ compare (Inexact x) (Inexact y) = compare x y+ compare (Exact x) (Inexact y) = compare (fromIntegral x) y+ compare (Inexact x) (Exact y) = compare x (fromIntegral y)+ -- This could take the place of the previous two:+ -- compare mx my = compare (toInexact mx) (toInexact my)++-- | Number as an instance of Num+instance Num Number where+ (+) = eitherOp2 (+) (+)+ (-) = eitherOp2 (-) (-)+ (*) = eitherOp2 (*) (*)++ negate = eitherOp1 negate negate+ abs = eitherOp1 abs abs+ signum = eitherOp1 signum signum++ fromInteger = Exact++-- | Numbers are Real, i.e., can be converted to Rational+instance Real Number where+ toRational (Exact i) = toRational i+ toRational (Inexact x) = toRational x++-- | In Haskell both Intgeger and Double are instances of Enum,+-- so Number should be an instance too. Also, this is a prerequisite+-- of being an instance of Integral.++instance Enum Number where++ succ = eitherOp1 succ succ+ pred = eitherOp1 pred pred++ toEnum i = Exact (toEnum i)+ fromEnum x = case x of+ Exact i -> fromEnum i+ Inexact r -> fromEnum r++ -- Use default definitions for these methods:+ -- enumFrom :: a -> [a] -- [n..]+ -- enumFromThen :: a -> a -> [a] -- [n,n'..]+ -- enumFromTo :: a -> a -> [a] -- [n..m]+ -- enumFromThenTo :: a -> a -> a -> [a] -- [n,n'..m]+++-- | Numbers are Integral, i.e., can do integer division and convert to+-- Integer. However, there is a restriction: this only works for Exact+-- numbers; for Inexact, there will be an error.+-- Some may see this as regrettable, but how is it different in principle+-- from division, which doesn't work for zero divisors, and+-- square root, which doesn't work for negative numbers?++instance Integral Number where++ quot = exactOp2 "quot" quot+ rem = exactOp2 "rem" rem+ div = exactOp2 "div" div+ mod = exactOp2 "mod" mod++ Exact i `quotRem` Exact j = + let (q, r) = i `quotRem` j in (Exact q, Exact r)+ _ `quotRem` _ = error "Number:quotRem: inexact operand(s)"++ Exact i `divMod` Exact j = + let (d, m) = i `divMod` j in (Exact d, Exact m)+ _ `divMod` _ = error "Number:divMod: inexact operand(s)"++ toInteger (Exact i) = i+ toInteger _ = error "Number:toInteger: inexact operand"++ ++-- | Numbers are Fractional, i.e., support division and conversion +-- from Rational.+-- This works directly for inexact Numbers, and otherwise by+-- conversion from Exact to Inexact.+instance Fractional Number where+ + (/) = inexactOp2 (/)+ recip = inexactOp1 recip+ fromRational r = Inexact (fromRational r)++-- | Numbers are Floating, i.e., support exponential, log, and trig functions.+-- This works directly for inexact Numbers, and otherwise by+-- conversion from Exact to Inexact.+instance Floating Number where++ pi = Inexact pi++ exp = inexactOp1 exp+ log = inexactOp1 log++ sqrt = inexactOp1 sqrt++ sin = inexactOp1 sin+ cos = inexactOp1 cos+ tan = inexactOp1 tan++ asin = inexactOp1 asin+ acos = inexactOp1 acos+ atan = inexactOp1 atan++ sinh = inexactOp1 sinh+ cosh = inexactOp1 cosh+ tanh = inexactOp1 tanh+ asinh = inexactOp1 asinh+ acosh = inexactOp1 acosh+ atanh = inexactOp1 atanh++ -- These methods have defaults:+ -- (**), logBase :: a -> a -> a++instance RealFrac Number where++ properFraction x =+ case x of + Exact i -> (fromIntegral i, Inexact 0.0)+ Inexact r -> let (w, p) = properFraction r+ in (w, Inexact p)++ -- Default methods:+ -- truncate :: (Integral b) => a -> b+ -- round :: (Integral b) => a -> b+ -- ceiling :: (Integral b) => a -> b+ -- floor :: (Integral b) => a -> b+++-- Haskell functions that implement certain Sifflet functions.++add1 :: Number -> Number+add1 = (+ 1)++sub1 :: Number -> Number+sub1 = (+ (-1))++eqZero :: Number -> Bool+eqZero = (== 0)++gtZero :: Number -> Bool+gtZero = (> 0)++ltZero :: Number -> Bool+ltZero = (< 0)++-- Omitting instance RealFloat, this is for data+-- that are *really* floating-point!++-- ------------------------------------------------------------------------+-- TESTING+-- ------------------------------------------------------------------------++testI, testJ, testK :: Number+testI = Exact 32+testJ = Exact 35+testK = 40++testX, testY, testZ :: Number+testX = Inexact 32.0+testY = Inexact 35.0+testZ = 37.5
+ Sifflet/Data/Tree.hs view
@@ -0,0 +1,67 @@+-- Tree.hs+-- General (not binary) trees++module Sifflet.Data.Tree + (T.Tree(..), tree, leaf, isLeaf, treeSize, treeDepth+ , Repr(..)+ -- Since String is not an instance of Repr,+ -- we need to convert (Tree String) to (Tree Name)+ , Name(..), nameTree+ , putTree, putTreeR, putTreeRs, putTreeS+ , drawTreeShow+ )++where++import Data.Tree as T+import Sifflet.Text.Repr++-- Makers++tree :: e -> Forest e -> T.Tree e+tree root subtrees = T.Node {rootLabel = root, subForest = subtrees}++leaf :: e -> T.Tree e+leaf x = tree x []++isLeaf :: T.Tree e -> Bool+isLeaf (T.Node _root []) = True+isLeaf _ = False++treeSize :: T.Tree e -> Int+treeSize (T.Node _root subtrees) = 1 + sum (map treeSize subtrees)++treeDepth :: T.Tree e -> Int+treeDepth (T.Node _root []) = 1+treeDepth (T.Node _root subtrees) = 1 + maximum (map treeDepth subtrees)++{- tree_map or treeMap:+ removed; use (Functor) fmap instead+-}++{- tree_mapM:+ removed, use Data.Traversable.mapM instead.+-}++nameTree :: T.Tree String -> T.Tree Name+nameTree = fmap Name++putTree :: (Show e) => T.Tree e -> IO ()+putTree = putTreeS++-- putTreeR -- using repr (first part)+putTreeR :: (Repr e) => T.Tree e -> IO()+putTreeR = putStrLn . drawTree . fmap repr++-- putTreeRs -- using reprs (all parts)+putTreeRs :: (Repr e) => T.Tree e -> IO()+putTreeRs = putStrLn . drawTree . fmap reprs+++-- putTreeS -- using show+putTreeS :: (Show e) => T.Tree e -> IO ()+putTreeS = putStrLn . drawTreeShow++drawTreeShow :: (Show e) => T.Tree e -> String+drawTreeShow = drawTree . fmap show+
+ Sifflet/Data/TreeGraph.hs view
@@ -0,0 +1,250 @@+module Sifflet.Data.TreeGraph + (LayoutGraph, + flayoutToGraph, treeLayoutToGraph,+ -- treeToGraph, + orderedTreeToGraph, + treeGraphNodesTree, graphToTreeOriginal,+ graphToTreeStructure, + flayoutToGraphRoots,+ graphToOrderedTree, graphToOrderedTreeFrom,+ orderedChildren, adjCompareEdge,+ nextNodes, -- exported for testing; any other reason?+ grTranslateNode, grTranslateSubtree, grTranslateGraph,++ -- moved from Workspace.hs:+ functoidToFunction, graphToExprTree,++ )++where++import Data.List (sort, sortBy)++import Data.Graph.Inductive as G++import Sifflet.Data.Functoid+import Sifflet.Data.Geometry+import Sifflet.Data.Tree as T+import Sifflet.Data.TreeLayout+import Sifflet.Data.WGraph+import Sifflet.Language.Expr+import Sifflet.Util++type LayoutGraph n e = Gr (LayoutNode n) e++flayoutToGraph :: FunctoidLayout -> WGraph+flayoutToGraph tlo = + case tlo of + FLayoutTree t -> treeLayoutToGraph t+ FLayoutForest ts _bbox -> + foldl grAddGraph wgraphNew (map treeLayoutToGraph ts)++treeLayoutToGraph :: TreeLayout ExprNode -> WGraph+treeLayoutToGraph = orderedTreeToGraph . fmap WSimple+++-- flayoutToGraphRoots returns a list of graph nodes (Ints)+-- corresponding to the root of the tree, or the roots of+-- the trees in the forest.+-- The list is ordered in the same sense as the graph nodes.++flayoutToGraphRoots :: FunctoidLayout -> [G.Node]+flayoutToGraphRoots (FLayoutTree _t) = [1]+flayoutToGraphRoots (FLayoutForest trees _bbox) =+ let loop _ [] res = reverse res+ loop next (t:ts) res =+ loop (next + treeSize t) ts (next:res)+ in loop 1 trees []+++-- {-# DEPRECATED treeToGraph "use ??? instead" #-}++-- treeToGraph :: Tree e -> Gr e ()+-- treeToGraph (T.Node root subtrees) = +-- -- Convert an ordered tree to a graph.+-- -- The graph edge labels from parent to child +-- -- are integers corresponding to the order of the children.+-- -- So, to recover the ordered list of children, +-- -- sort by the edge label.+-- let g0 = empty :: Gr e ()+-- g1 = insNode (1, root) g0++-- grow :: Gr e () -> [(Tree e, G.Node)] -> G.Node -> Gr e ()+-- -- grow graph [(tree, parent)] node+-- grow g [] _ = g+-- grow g ((t, p):tps) n =+-- -- insert t forming g', insert ts into g'+-- let edge = ((), p) -- predecessors, or both?+-- g' = ([edge], n, (rootLabel t), []) & g -- assume pred only+-- in grow g' (tps ++ [(s, n) | s <- subForest t])+-- (succ n)++-- in grow g1 [(s, 1) | s <- subtrees] 2++sprout :: G.Node -> Tree e -> [(G.Node, WEdge, Tree e)]+sprout parent (T.Node _ subtrees) =+ -- create triples (parent graph node, edge, subtree)+ let m = length subtrees - 1+ in [(parent, WEdge e, s) | (e, s) <- zip [0..m] subtrees]+++orderedTreeToGraph :: Tree e -> Gr e WEdge+orderedTreeToGraph otree = + -- Convert an ordered tree to a graph.+ -- The graph edge labels from parent to child + -- are integers corresponding to the order of the children.+ -- So, to recover the ordered list of children, + -- sort by the edge label.+ let g0 = empty :: Gr e WEdge+ g1 = insNode (1, rootLabel otree) g0++ grow :: Gr e WEdge -> [(G.Node, WEdge, Tree e)] -> G.Node -> Gr e WEdge+ -- grow graph [(parent, edgeLabel, subtree), ...] node+ grow g [] _ = g+ grow g ((p, e, t):pets) n =+ -- insert pet forming g', insert pets into g';+ -- n is the node id for the root of this subtree+ let adj = (e, p) -- to parent (priority, node)+ g' = ([adj], n, (rootLabel t), []) & g + n' = succ n+ in grow g' (pets ++ + sprout n t+ -- [(s, n) | s <- subForest t])+ )+ n'++ in grow g1 (sprout 1 otree) 2++-- And what about this (e, Node) type? Is it some sort of monad?++treeGraphNodesTree :: Tree e -> Tree Node+treeGraphNodesTree atree =+ -- returns a tree of Nodes of the Graph (treeToGraph atree)+ let gnTree :: Tree e -> Node -> Node -> (Tree Node, Node)+ gnTree (T.Node _root subtrees) rootNode next =+ -- rootNode = Node (number) for the root,+ -- next = next unused Node+ let (nNodes, next') = nextNodes subtrees next+ (subtrees', next'') = gnSubtrees subtrees nNodes next'+ in (T.Node rootNode subtrees', next'')++ gnSubtrees :: [Tree e] -> [Node] -> Node -> ([Tree Node], Node)+ gnSubtrees [] [] next = ([], next)+ gnSubtrees (t:ts) (n:ns) next = + let (t', next') = gnTree t n next+ (ts', next'') = gnSubtrees ts ns next'+ in ((t' : ts'), next'')+ gnSubtrees _ _ _ = error "gnSubtrees: list lengths do not match"++ in fst (gnTree atree 1 2)++nextNodes :: [e] -> Node -> ([Node], Node)+nextNodes items next = + -- next is the next unused Node (number).+ -- Returns list of new nodes, and a new "next" node+ -- E.g., nextNodes [a, b] 3 = ([3, 4], 5)+ -- nextNodes [c, d, e] 5 = ([5, 6, 7], 8)+ -- nextNodes [] 8 = ([], 8)+ let n = length items+ next' = next + n+ in ([next .. (next' - 1)], next')++-- When a tree is converted to a graph,+-- each tree node's ordered children get graph node numbers+-- in ascending order. Therefore, when reconstructing the tree,+-- sorting the graph nodes restores the order of the children+-- as in the tree.++graphToOrderedTree :: Gr e WEdge -> Tree e+-- inverse of orderedTreeToGraph+graphToOrderedTree g = graphToOrderedTreeFrom g 1++graphToOrderedTreeFrom :: Gr e WEdge -> G.Node -> Tree e+graphToOrderedTreeFrom g n =+ case lab g n of+ Just label -> + T.Node label (map (graphToOrderedTreeFrom g) (orderedChildren g n))+ Nothing -> + errcats ["missing label for node", show n]++-- | List of the nodes children, ordered by edge number+orderedChildren :: Gr e WEdge -> G.Node -> [G.Node]+orderedChildren g = map fst . sortBy adjCompareEdge . lsuc g++adjCompareEdge :: (Node, WEdge) -> (Node, WEdge) -> Ordering+adjCompareEdge (_n1, e1) (_n2, e2) = compare e1 e2++{-# DEPRECATED graphToTreeOriginal "use ??? instead" #-}++graphToTreeOriginal :: Gr e () -> G.Node -> Tree e+-- (\g -> graphToTreeOriginal g 1) is the inverse of treeToGraph+graphToTreeOriginal g n =+ case lab g n of+ Just label -> T.Node label (map (graphToTreeOriginal g) + (sort (suc g n)))+ _ -> errcats ["missing label for node", show n]++{-# DEPRECATED graphToTreeStructure "use ??? instead" #-}++graphToTreeStructure :: Gr n e -> G.Node -> Tree G.Node+-- This is *not* an inverse of treeToGraph.+-- Rather, graphToTreeStructure (treeToGraph t 1) is a tree t' of Nodes+-- (i.e., integer identifiers of nodes in the graph)+-- which parallels the structure of t.++graphToTreeStructure g n = T.Node n (map (graphToTreeStructure g)+ (sort (suc g n)))++grTranslateNode :: + Node -> Double -> Double -> LayoutGraph n e -> LayoutGraph n e+grTranslateNode node dx dy graph = + grUpdateNodeLabel graph node (translate dx dy)++grTranslateSubtree :: + Node -> Double -> Double -> LayoutGraph n e -> LayoutGraph n e+grTranslateSubtree root dx dy graph = + let trSubtrees :: [Node] -> LayoutGraph n e -> LayoutGraph n e+ trSubtrees [] g = g+ trSubtrees (r:rs) g = trSubtrees (rs ++ suc g r)+ (grTranslateNode r dx dy g)+ in trSubtrees [root] graph++grTranslateGraph :: Double -> Double -> LayoutGraph n e -> LayoutGraph n e+grTranslateGraph dx dy graph = nmap (translate dx dy) graph++grUpdateNodeLabel :: (DynGraph g) => g a b -> Node -> (a -> a) -> g a b+grUpdateNodeLabel graph node updater =+ case match node graph of+ (Nothing, _) -> error "no such node"+ (Just (preds, jnode, label, succs), graph') ->+ -- jnode == node+ (preds, jnode, updater label, succs) & graph'++functoidToFunction :: + Functoid -> WGraph -> G.Node -> Env -> SuccFail Function+functoidToFunction functoid graph frameNode env =+ case functoid of+ FunctoidFunc f -> Succ f+ FunctoidParts {fpName = name, fpArgs = args} ->+ 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)++
+ Sifflet/Data/TreeLayout.hs view
@@ -0,0 +1,660 @@+module Sifflet.Data.TreeLayout + (VColor(..), white, cream, black, lightBlue, lightBlueGreen+ , lightGray, mediumGray, darkGray+ , yellow, darkBlueGreen, blueGreen+ , Style(..), VFont(..), defaultStyle, style0, style1, style2, style3+ , wstyle+ , styleIncreasePadding+ , FontTextExtents(..), setFont, measureText, styleTextExtents, ftExtents+ , TextBox(..), makeTextBox, tbWidth, tbHeight, tbBottom+ , tbCenter, tbTextCenter, tbBoxCenter, offsetTextBoxCenters+ , tbSetWidth+ , treeSizes+ , GNode(..), treeGNodes, gnodeText, gnodeTextBB+ , Iolet(..), ioletCenter, makeIolets, makeIoletsRow+ , pointInIolet+ , IoletCounter, zeroIoletCounter+ , makeGNode+ , TreeLayout, LayoutNode(..)+ , layoutNodeSource, layoutRootBB, layoutTreeBB+ , treeLayout+ , treeLayoutPaddedSize, treeLayoutSize, treeLayoutWidth+ , layoutTreeMoveCenterTo+ , pointInLayoutNode, pointInGNode, findRect+ , treeLayoutWiden+ )++where++import System.IO.Unsafe++-- All this VVV is needed just to measure a piece of text;+-- maybe font and text should be split out to a new module?++import Graphics.Rendering.Cairo (FontExtents(..),+ FontSlant(..), FontWeight(..),+ Format(..), Render,+ TextExtents(..),+ fontExtents,+ renderWith,+ textExtents,+ selectFontFace, setFontSize,+ withImageSurface)++import Graphics.UI.Gtk (Rectangle)+import Data.Traversable () -- imports only instance declarations++import Sifflet.Data.Geometry+import Sifflet.Data.Tree as T hiding (tree)+import Sifflet.Text.Repr ()+import Sifflet.Util++-- Do colors really belong here???++data VColor = ColorRGB Double Double Double |+ ColorRGBA Double Double Double Double++black, white, cream, lightBlue, lightBlueGreen :: VColor++black = ColorRGB 0 0 0+white = ColorRGB 1 1 1+cream = ColorRGB 0.94902 0.94902 0.82745+lightBlue = ColorRGB 0.43529 0.43922 0.95686+lightBlueGreen = ColorRGB 0 1 1++lightGray, mediumGray, darkGray :: VColor+lightGray = ColorRGBA 0.75 0.75 0.75 0.5+mediumGray = ColorRGB 0.5 0.5 0.5+darkGray = ColorRGB 0.25 0.25 0.25++yellow, darkBlueGreen, blueGreen :: VColor++yellow = ColorRGB 0.9 0.9 0+darkBlueGreen = ColorRGB 0 0.3 0.3+blueGreen = ColorRGB 0 0.4 0.4++-- darkRed = ColorRGB 0.5 0 0, -- dark red++data VFont = VFont {vfontFace :: String, vfontSlant :: FontSlant,+ vfontWeight :: FontWeight,+ vfontSize :: Double}++data Style = + Style {styleFont :: VFont,+ lineWidth :: Double,+ textMargin :: Double, -- in box on all four sides+ hpad, vpad :: Double, -- internode (interbox) spacing+ exomargin :: Double, -- margin of the tree within the window+ vtinypad :: (Double, Double), -- node-edge spacing (above, below)+ styleFramePad :: Double, -- pad between frames+ styleNormalTextColor, styleNormalFillColor, + styleNormalEdgeColor,+ styleActiveTextColor, styleActiveFillColor,+ styleActiveEdgeColor,+ styleSelectedTextColor, styleSelectedFillColor, + styleSelectedEdgeColor,+ styleTetherColor :: VColor,+ -- auxiliary text style, e.g., the value of an ExprNode+ styleAuxOffset :: Position, -- center-to-center offset dx dy+ styleAuxColor :: VColor,+ styleAuxFont :: VFont,+ styleIoletRadius :: Double, -- could extend to other shapes ***+ styleShowNodeBoxes :: Bool, -- draw a box around expr nodes+ styleShowNodePorts :: Bool -- draw the I/O ports of expr nodes+ }++styleIncreasePadding :: Style -> Double -> Style+-- increase hpad, vpad of style by multiplication+styleIncreasePadding style factor =+ style {hpad = factor * hpad style,+ vpad = factor * vpad style}++style0, style1, style2, style3, defaultStyle :: Style++style0 = + let green = ColorRGB 0.1 0.9 0.1+ veryDarkGray = ColorRGB 0.1 0.1 0.1+ brighterGreen = ColorRGB 0.5 0.95 0.5+ in Style {styleFont = VFont "serif" FontSlantNormal FontWeightNormal 18, + lineWidth = 2, + textMargin = 18.0, -- text within its box+ hpad = 27, vpad = 36, -- inter-node separation+ exomargin = 0,+ vtinypad = (4.5, 4.5), -- node-edge separation+ styleFramePad = 35, -- padding between frames+ -- Foreground and background colors+ styleNormalTextColor = green,+ styleNormalEdgeColor = green,+ styleNormalFillColor = veryDarkGray,+ styleActiveTextColor = brighterGreen,+ styleActiveEdgeColor = brighterGreen,+ styleActiveFillColor = mediumGray,+ styleSelectedTextColor = blueGreen,+ styleSelectedEdgeColor = blueGreen,+ styleSelectedFillColor = darkGray,+ styleTetherColor = white,+ styleAuxOffset = Position 0.0 (-20.0),+ styleAuxColor = lightGray,+ styleAuxFont = + VFont "serif" FontSlantItalic FontWeightNormal 12,+ styleIoletRadius = 5,+ styleShowNodeBoxes = True, -- draw a box around expr nodes+ styleShowNodePorts = True -- draw the I/O ports of expr nodes+ }++style1 = + let veryDarkBlue = ColorRGB 0 0 0.1+ pinkIHope = ColorRGB 1 0.9 0.9+ in style0 {styleNormalTextColor = veryDarkBlue,+ styleNormalEdgeColor = veryDarkBlue,+ styleNormalFillColor = lightGray,+ styleActiveTextColor = pinkIHope,+ styleActiveEdgeColor = pinkIHope+ }++style2 = + let darkPink = ColorRGB 1 0.5 0.5+ in style1 {styleNormalFillColor = white,+ styleActiveTextColor = darkPink,+ styleActiveEdgeColor = darkPink}++style3 = + let semiTranspBlue = ColorRGBA 0 0.2 0.9 0.5+ in style0 {exomargin = 10,+ styleNormalTextColor = yellow,+ styleNormalEdgeColor = yellow,+ styleNormalFillColor = darkBlueGreen,+ styleActiveTextColor = yellow,+ styleActiveEdgeColor = yellow,+ styleActiveFillColor = blueGreen,+ styleAuxColor = semiTranspBlue+ } ++defaultStyle = style3++wstyle :: Style+wstyle = + style3 { + -- smaller to allow multiple frames on one canvas+ styleFont = VFont "serif" FontSlantNormal FontWeightNormal 14,+ textMargin = 8.0,+ hpad = 10.0, vpad = 24.0, + vtinypad = (0.0, 0.0),+ exomargin = 10.0, -- between tree and window edges+ styleFramePad = 15,++ -- colors+ styleNormalTextColor = yellow,+ styleNormalEdgeColor = mediumGray,+ styleNormalFillColor = darkBlueGreen,++ styleActiveTextColor = yellow,+ styleActiveEdgeColor = mediumGray,+ styleActiveFillColor = blueGreen,++ styleSelectedTextColor = black,+ styleSelectedEdgeColor = lightBlueGreen,+ styleSelectedFillColor = lightBlueGreen,++ styleTetherColor =+ ColorRGBA 0.7 0.7 0.7 0.3, -- light gray+ + -- node values+ styleAuxOffset = Position 0 (-16),+ styleAuxFont = VFont "serif" FontSlantItalic FontWeightNormal 12,+ styleAuxColor = ColorRGBA 0.9 0.5 0.5 1.0,+ -- ColorRGBA 1 0.9 0.9 0.75 + styleIoletRadius = 5+ }+ ++pointInLayoutNode :: Position -> LayoutNode e -> Bool+pointInLayoutNode point = pointInGNode point . nodeGNode++pointInGNode :: Position -> GNode e -> Bool+pointInGNode point = pointInBB point . gnodeNodeBB++-- UNUSED: findNode (except in findRect)+-- find the node, if any, containing a point +-- might need to adjust this to take iolets into account ******+findNode :: Position -> TreeLayout e -> Maybe (LayoutNode e)+findNode point (T.Node node@(LayoutNode _rootGNode treeBB) sublayouts) =+ if pointInBB point treeBB+ then if pointInLayoutNode point node+ then Just node+ else findInSubs point sublayouts+ else Nothing++ where findInSubs :: Position -> [TreeLayout e] -> Maybe (LayoutNode e)+ findInSubs _p [] = Nothing+ findInSubs p (l:ls) = + let found = findNode p l in+ case found of+ (Just _) -> found+ Nothing -> findInSubs p ls++-- UNUSED: findRect+findRect :: Position -> TreeLayout e -> Maybe Rectangle+findRect point tlo = + case findNode point tlo of+ Nothing -> Nothing+ Just node -> Just (bbToRect (gnodeNodeBB (nodeGNode node)))++setFont :: VFont -> Render ()+setFont (VFont face slant weight size) = do+ selectFontFace face slant weight+ setFontSize size++data FontTextExtents = FontTextExtents {+ fontAscent::Double, fontDescent::Double, fontHeight::Double,+ fontMaxXadvance::Double, fontMaxYadvance::Double,+ textXbearing::Double, textYbearing::Double,+ extTextWidth::Double, extTextHeight::Double,+ textXadvance::Double, textYadvance::Double}+ deriving (Eq, Read, Show)++measureText :: Style -> String -> Size+measureText style str =+ let extents = styleTextExtents style str+ in Size (textXadvance extents)+ (fontHeight extents + fontDescent extents)++-- Rationale for unsafePerformIO:+-- font extents of a string will not change unless the font itself+-- changes, which is extremely unlikely++styleTextExtents :: Style -> String -> FontTextExtents+styleTextExtents style str = + unsafePerformIO $ + withImageSurface FormatARGB32 0 0 $ \ surface ->+ renderWith surface $ + setFont (styleFont style) >>+ ftExtents str++-- | ftExtents: used for what?+ftExtents :: String -> Render FontTextExtents+ftExtents text = do+ FontExtents asc desc fheight maxxadv maxyadv <- fontExtents+ TextExtents xbear ybear twidth theight xadv yadv <- textExtents text+ return (FontTextExtents asc desc fheight maxxadv maxyadv+ xbear ybear twidth theight xadv yadv)++data TextBox = TextBox {tbText :: String,+ tbTextBB :: BBox, -- BBox of text without margins+ tbBoxBB :: BBox -- of text with margins+ }+ deriving (Eq, Read, Show)++makeTextBox :: Style -> String -> TextBox+makeTextBox style text =+ let extents = styleTextExtents style text+ Size textW textH = measureText style text+ -- textW = textXadvance extents+ -- textH = fontHeight extents + fontDescent extents+ margin = textMargin style++ boxW = textW + 2.0 * margin -- max (textW + 2.0 * margin) minWidth+ boxH = textH + 2.0 * margin++ boxX = 0+ boxY = 0++ textX = (boxW - textW) / 2.0+ -- raise text slightly, by a fraction of its font descent+ -- (why? because it just looks better!)+ -- Maybe this should be made an aspect of style?+ raise = 0.5 * fontDescent extents+ textY = fontHeight extents + (boxH - textH) / 2.0 - raise++ textBB = BBox textX textY textW textH+ boxBB = BBox boxX boxY boxW boxH++ in TextBox text textBB boxBB++instance Widen TextBox where+ widen tb@(TextBox _text textBB boxBB) minWidth =+ let w = bbWidth boxBB+ in if w >= minWidth+ then tb+ else let dw = minWidth - w + in tb {tbTextBB = translate (dw / 2) 0 textBB,+ tbBoxBB = widen boxBB minWidth}++instance Translate TextBox where+ translate dx dy (TextBox text textBB boxBB) = + TextBox text (translate dx dy textBB) (translate dx dy boxBB)+++tbWidth :: TextBox -> Double+tbWidth = bbWidth .tbBoxBB++tbSetWidth :: TextBox -> Double -> TextBox+tbSetWidth tbox w = + let TextBox text textBB boxBB = tbox+ boxBB' = bbSetWidth boxBB w+ (dx, dy) = positionDelta (bbCenter boxBB) (bbCenter boxBB')+ in TextBox text (translate dx dy textBB) boxBB'++tbHeight :: TextBox -> Double+tbHeight = bbHeight . tbBoxBB++tbBottom :: TextBox -> Double+tbBottom = bbBottom . tbBoxBB++-- The geometric "center" of a TextBox is the center of its "BoxBB"+tbCenter :: TextBox -> Position+tbCenter = tbBoxCenter+ +tbBoxCenter :: TextBox -> Position+tbBoxCenter = bbCenter . tbBoxBB++-- and the center of its text should have the same x coordinate,+-- but due to the way text is positioned, maybe not the same y.+-- But do we ever need this?+tbTextCenter :: TextBox -> Position+tbTextCenter = bbCenter . tbTextBB++offsetTextBoxCenters :: Position -> TextBox -> TextBox -> TextBox+offsetTextBoxCenters offset anchor floater =+ -- Position the floater text box so that its center differs+ -- from the anchor text box by the given offset.+ -- (The offset argument comes first, like dx dy in translate.)+ let Position ax ay = tbBoxCenter anchor+ Position fx fy = tbBoxCenter floater+ Position ox oy = offset+ -- translate floater by (dx, dy), where fx + dx = ax + ox, + -- so dx = ax + ox - fx; and dy similarly+ dx = ax + ox - fx+ dy = ay + oy - fy+ in translate dx dy floater+++-- GNode = graphical node, suitable for drawing+data GNode e = GNode {gnodeValue :: e, + gnodeTextBoxes :: [TextBox], -- one or two only+ gnodeNodeBB :: BBox, -- encloses all textboxes+ gnodeInlets :: [Iolet], -- input connectors+ gnodeOutlets :: [Iolet] -- output connectors+ }+ deriving (Eq)++gnodeText :: GNode e -> String+gnodeText = tbText . head . gnodeTextBoxes++gnodeTextBB :: GNode e -> BBox+gnodeTextBB = tbTextBB . head . gnodeTextBoxes++instance (Show e) => Show (GNode e) where+ show (GNode v tbs nodeBB inlets outlets) = + par "GNode" [show v, show tbs, show nodeBB, show inlets, show outlets]++instance Translate (GNode e) where+ translate dx dy (GNode value textboxes nodeBB inlets outlets) = + GNode value + (map (translate dx dy) textboxes)+ (translate dx dy nodeBB)+ (translate dx dy inlets)+ (translate dx dy outlets)+++-- An IoletCounter returns (no. of inlets, no. of outlets)+type IoletCounter e = e -> (Int, Int)++-- A sort of "default" IoletCounter returning zeroes+zeroIoletCounter :: IoletCounter e+zeroIoletCounter _node = (0, 0)++-- An IoletsMaker ???+-- type IoletsMaker e = Style -> e -> ([Position], [Position])++makeGNode :: (Repr e) => Style -> IoletCounter e -> e -> GNode e+makeGNode style countIolets value =+ -- The function countIolets creates a tuple (# of inlets, # of outlets)+ -- for the node, of course being (0, 0) if we don't want any.+ let textboxes1 = map (makeTextBox style) (reprl value)+ textboxes2 = case textboxes1 of+ [_tb] -> textboxes1+ [tb1, tb2] -> + [tb1, + offsetTextBoxCenters (styleAuxOffset style) tb1 tb2]+ _ -> wrong textboxes1+ nodeBB = case textboxes2 of+ [tb] -> tbBoxBB tb+ [tb1, tb2] -> bbMerge (tbBoxBB tb1) (tbBoxBB tb2)+ _ -> wrong textboxes2+ wrong tbs = + errcats ["makeGNode: wrong no. of text boxes;",+ "expected 1 or 2, but got", show (length tbs)]+ (inlets, outlets) = makeIolets style nodeBB (countIolets value)+ in GNode value textboxes2 nodeBB inlets outlets++makeIolets :: Style -> BBox -> (Int, Int) -> ([Iolet], [Iolet])+makeIolets style bbox (nin, nout) =+ -- make the (inlets, outlets)+ (makeIoletsRow style (bbXCenter bbox) (bbBottom bbox) nin,+ makeIoletsRow style (bbXCenter bbox) (bbTop bbox) nout)++makeIoletsRow :: Style -> Double -> Double -> Int -> [Iolet]+makeIoletsRow style cx cy n =+ -- make a row of n Iolets, centered at (cx, cy)+ let radius = styleIoletRadius style+ diam = 2 * radius -- diameter+ w = fromIntegral n * diam+ x1 = cx - w / 2 + radius -- the center of the first iolet+ x i = x1 + fromIntegral (i - 1) * diam+ make i = Iolet (Circle (Position (x i) cy) radius)+ in map make [1..n]++-- | An Iolet is a circular port.+-- Other shapes could be added.+data Iolet = Iolet Circle+ deriving (Eq, Read, Show)++instance Translate Iolet where+ translate dx dy (Iolet circle) = Iolet (translate dx dy circle)++ioletCenter :: Iolet -> Position+ioletCenter (Iolet circle) = circleCenter circle++pointInIolet :: Position -> Iolet -> Bool+pointInIolet point (Iolet circle) = pointInCircle point circle++-- Build a Tree of node Sizes parallel to the Repr tree,+-- each node in the Size tree is the size of +-- the corresponding node in the repr tree.++-- treeSizes: given a tree of *node* sizes, for the root nodes of the tree+-- and its subtrees, returns a tree of *tree* sizes++treeSizes :: Style -> Tree (GNode e) -> Tree Size+treeSizes style gTree = + let subtreeSizes = map (treeSizes style) (subForest gTree)+ (BBox _ _ rootWidth rootHeight) = gnodeNodeBB (rootLabel gTree)+ treeWidth = max rootWidth (paddedWidth style subtreeSizes)+ treeHeight = rootHeight + paddedHeight style subtreeSizes+ in T.Node (Size treeWidth treeHeight) subtreeSizes++-- (paddedWidth style subtrees) and (paddedHeight style subtrees)+-- compute the total size of all subtrees+-- of of a Size tree, including padding.+paddedWidth :: Style -> [Tree Size] -> Double+paddedWidth _style [] = 0+paddedWidth style subtrees =+ sum [w | (T.Node (Size w _h) _) <- subtrees] ++ hpad style * fromIntegral (length subtrees - 1)++-- UNUSED:+-- -- | pairSum is unused; should it be?+-- pairSum :: (Double, Double) -> Double+-- pairSum (a, b) = a + b++paddedHeight :: Style -> [Tree Size] -> Double+paddedHeight _style [] = 0+paddedHeight style subtrees = + vpad style + maximum [h | (T.Node (Size _w h) _) <- subtrees]++-- A TreeLayout is a Tree of LayoutNodes.+-- The root node in a TreeLayout identifies the root of the source Tree +-- (nodeSource) and the node's bounding box (nodeNodeBB).+-- It also tells the bounding box of the whole tree (nodeTreeBB).+-- The subtrees of the TreeLayout are the TreeLayouts +-- of the subtrees of the source Tree.++type TreeLayout e = Tree (LayoutNode e)++data LayoutNode e = LayoutNode {nodeGNode :: GNode e,+ nodeTreeBB :: BBox}+ deriving (Eq)++layoutNodeSource :: LayoutNode e -> e+layoutNodeSource = gnodeValue . nodeGNode++instance (Show e) => Show (LayoutNode e) where+ show (LayoutNode gnode treebb) = par "LayoutNode" [show gnode, show treebb]++instance Translate (LayoutNode e) where+ translate dx dy (LayoutNode gnode treeBB) = + LayoutNode (translate dx dy gnode)+ (translate dx dy treeBB)++instance Widen (LayoutNode e) where+ widen node@(LayoutNode gNode treeBB) minWidth =+ let dw = bbWidth treeBB - minWidth+ in if dw <= 0+ then node+ else LayoutNode (translate (dw / 2) 0 gNode)+ (widen treeBB minWidth)++-- Try this, it's tough!+-- instance (Draw n, Widen n) = Widen (Tree n) where ...+-- But why not just+-- instance (Widen n) = Widen (Tree n) where ...+++-- UNUSED+-- -- | layoutRootSource: unused+-- layoutRootSource :: TreeLayout e -> e+-- layoutRootSource tree = layoutNodeSource (rootLabel tree)++layoutRootBB :: TreeLayout e -> BBox+layoutRootBB = gnodeNodeBB . nodeGNode . rootLabel++layoutTreeBB :: TreeLayout e -> BBox+layoutTreeBB = nodeTreeBB . rootLabel++treeLayout :: (Repr e) => Style -> IoletCounter e -> Tree e -> TreeLayout e+treeLayout style counter tree = + let t1 = treeGNodes style counter tree+ t2 = treeSizes style t1+ start = Position (hpad style) (vpad style)+ t3 = treeLayout2 style start tree t1 t2+ in treeLayoutAddMargin t3 (exomargin style)+++-- treeGNodes produces a tree of (GNode e),+-- based on a top left corner at (0, 0) which, of course, will need+-- to be translated in the final tlo.++treeGNodes :: Repr e => + Style -> IoletCounter e -> Tree e -> Tree (GNode e)+treeGNodes style counter tree = fmap (makeGNode style counter) tree++treeLayout2 :: (Repr e) =>+ Style -- ^ tree style+ -> Position -- ^ top left after padding+ -> Tree e -- ^ the tree being laid out + -- (actually we don't need the tree as an argument;+ -- it's implied by the GNode tree)+ -> Tree (GNode e) -- ^ "node sizes"+ -> Tree Size -- ^ tree Sizes+ -> TreeLayout e++treeLayout2 style+ (Position startX startY)+ (T.Node _root subtrees)+ (T.Node gnode subGNodes) + (T.Node (Size treeWidth treeHeight) subTreeSizes) + = + let + nodeHeight = bbHeight (gnodeNodeBB gnode)+ -- center the root in its level+ -- UNUSED:+ -- nodeCenterX = startX + treeWidth / 2+ -- nodeCenterY = startY + nodeHeight++ -- center the subtrees (may be wider or narrower than the root)+ subtreesTotalWidth = paddedWidth style subTreeSizes+ subX = startX + (treeWidth - subtreesTotalWidth) / 2 -- first subtree+ subY = startY + nodeHeight + vpad style++ sublayouts :: (Repr e) =>+ Double -> [Tree e] -> [Tree (GNode e)] -> [Tree Size] -> + [TreeLayout e]+ sublayouts _ [] [] [] = []+ sublayouts x (t:ts) (g:gs) (s:ss) = + treeLayout2 style (Position x subY) t g s :+ sublayouts (x + sizeW (rootLabel s) + hpad style) ts gs ss+ sublayouts _ _ _ _ = error "treeLayout2: mismatched list lengths"++ in T.Node (LayoutNode -- root node+ (centerGNode gnode startX startY treeWidth nodeHeight) -- node+ (BBox startX startY treeWidth treeHeight)) -- whole tree+ (sublayouts subX subtrees subGNodes subTreeSizes)++-- | Center a GNode in a rectangular area+centerGNode :: GNode e -> Double -> Double -> Double -> Double -> GNode e+centerGNode gnode startx starty awidth aheight =+ let cx = startx + awidth / 2 -- desired center+ cy = starty + aheight / 2+ Position cgx cgy = bbCenter (gnodeNodeBB gnode)+ in translate (cx - cgx) (cy - cgy) gnode+ +treeLayoutPaddedSize :: Style -> TreeLayout e -> Size+treeLayoutPaddedSize style tlo =+ let Size w h = treeLayoutSize tlo+ in Size (w + 2.0 * hpad style) (h + 2.0 * vpad style)++treeLayoutSize :: TreeLayout e -> Size+treeLayoutSize tlo = + let BBox _x _y w h = layoutTreeBB tlo in Size w h++layoutTreeMoveCenterTo :: + Double -> Double -> TreeLayout e -> TreeLayout e+layoutTreeMoveCenterTo newX newY layoutTree =+ let Position oldX oldY = bbCenter (nodeTreeBB (rootLabel layoutTree))+ in translate (newX - oldX) (newY - oldY) layoutTree++treeLayoutAddMargin :: TreeLayout e -> Double -> TreeLayout e+treeLayoutAddMargin tree margin =+ let LayoutNode {nodeGNode = rootGNode, nodeTreeBB = treeBB} =+ rootLabel tree+ subtrees = subForest tree+ BBox x y w h = treeBB+ treeBB' = BBox (x - margin) (y - margin) + (w + 2 * margin) (h + 2 * margin)+ root' = translate margin margin (LayoutNode rootGNode treeBB')+ subtrees' = translate margin margin subtrees+ in T.Node root' subtrees'++ ++treeLayoutWidth :: TreeLayout e -> Double+treeLayoutWidth = bbWidth . layoutTreeBB++treeLayoutWiden :: TreeLayout e -> Double -> TreeLayout e+treeLayoutWiden tlo minWidth =+ let w = treeLayoutWidth tlo+ in+ if w >= minWidth+ then tlo+ else let dw = minWidth - w+ T.Node root subs = translate (dw / 2) 0 tlo+ LayoutNode rootGNode treeBB = root+ root' = LayoutNode rootGNode + (translate (-dw / 2) + 0 + (widen treeBB minWidth))+ in T.Node root' subs+++
+ Sifflet/Data/WGraph.hs view
@@ -0,0 +1,410 @@+module Sifflet.Data.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 Sifflet.Data.Functoid+import Sifflet.Data.Geometry+import Sifflet.Data.Tree as T -- exports Data.Tree.Tree(Node), etc.+import Sifflet.Data.TreeLayout+import Sifflet.Language.Expr+import Sifflet.Text.Repr ()+import Sifflet.Util++-- | A WGraph consists of WNodes with (sort of) Int-labled edges;+-- the edge labels serve to order the children of a node.++type WGraph = Gr WNode WEdge++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}
+ Sifflet/Examples.hs view
@@ -0,0 +1,290 @@+module Sifflet.Examples + (exampleFunctions+ , exampleFunctionNames+ , exampleEnv + , foo, eFoo -- used in Testing.Unit.ExprTests+ , eMax -- ditto+ , eFact -- ditto+ , getExampleFunction+ )++where++import Sifflet.Language.Expr+-- import Sifflet.UI (VPToolkit(..), functionToolsFromLists,+-- baseFunctionsRows)+import Sifflet.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"])+ )++-- | An expression representing a call to foo+eFoo :: Expr -> Expr -> Expr+eFoo e1 e2 = eCall "foo" [e1, e2]++-- | max x y = if x > y then x else y+max :: Function+max = let ex = eSymbol "x"+ ey = eSymbol "y"+ in Function (Just "max") [VpTypeNum, VpTypeNum] VpTypeNum+ (Compound ["x", "y"] (eIf (eGt ex ey) ex ey))++-- | An expression representing a call to max+eMax :: Expr -> Expr -> Expr+eMax e1 e2 = eCall "max" [e1, e2]++-- | fact n = if n == 0 then 1 else n * (fact (n - 1))+fact :: Function+fact = let en = eSymbol "n" in+ Function (Just "fact") [VpTypeNum] VpTypeNum+ (Compound ["n"] + (eIf (eZerop en) + (eInt 1)+ (eTimes en (eFact (eSub1 en)))))++-- | An expression representing a call to fact+eFact :: Expr -> Expr+eFact e1 = eCall "fact" [e1]++-- | sum of the integers 0..n+-- Lewis and Loftus, Jave Software Solutions, 6th. ed. (they call it "sum")+sumFromZero :: Function+sumFromZero = let en = eSymbol "n" in+ Function (Just "sumFromZero") [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.++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)))))++-- | An expression representing a call to rmul+eRmul :: Expr -> Expr -> Expr+eRmul em en = eCall "rmul" [em, en]++eGcd :: Expr -> Expr -> Expr+eGcd em en = eCall "gcd" [em, en]++gcd :: Function+gcd = let em = eSymbol "m"+ en = eSymbol "n"+ in Function (Just "gcd") [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, Sifflet.Examples.max+ , fact, sumFromZero, rmul, fib1+ , Sifflet.Examples.gcd, evenp, oddp+ , rabbitBabies, rabbitAdults, rabbitTotal+ , buggyLength, listLength, listSum, buggySum+ , buggySumFromZero]++exampleFunctionNames :: [String]+exampleFunctionNames = map functionName exampleFunctions++exampleEnv :: Env+exampleEnv = + envInsertL baseEnv exampleFunctionNames (map VFun exampleFunctions)++-- | This function will be in error if the function name is not+-- found in exampleEnv.+getExampleFunction :: String -> Function+getExampleFunction = envGetFunction exampleEnv+
+ Sifflet/Foreign/Exporter.hs view
@@ -0,0 +1,8 @@+module Sifflet.Foreign.Exporter (Exporter) where++import System.FilePath+import Sifflet.Language.Expr++-- | The type of a function to export (user) functions to a file.+type Exporter = Functions -> FilePath -> IO ()+
+ Sifflet/Foreign/Python.hs view
@@ -0,0 +1,435 @@+-- | Abstract syntax tree and pretty-printing for Python.+-- Works for Python 2 and 3.+-- A lot of the data structures are inspired by the language-python package;+-- I have chosen not to have language-python as a dependency of sifflet-lib,+-- however, because it would be overkill and still allows to little control+-- over pretty-printing of Python expressionsw.++module Sifflet.Foreign.Python+ (PModule(..)+ , PStatement(..)+ , PExpr(..)+ , PIdentifier(..)+ , PParameter(..)+ , POperator(..)+ , Precedence+ , alterParens+ , atomic+ , compound+ , ret+ , condS+ , condE+ , var+ , ident+ , pInt+ , pFloat+ , bool+ , char+ , string+ , paren+ , noParens+ , fullParens+ , bestParens+ , simplifyParens+ , par+ , unpar+ , call+ , param+ , fun+ , opTimes+ , opIDiv+ , opFDiv+ , opMod+ , opPlus+ , opMinus+ , opEq+ , opNe+ , opGt+ , opGe+ , opLt+ , opLe+ )++where++import Sifflet.Text.Pretty++-- | The class of types that can be parenthesized, that is,+-- they may contain parentheses, and their parentheses may be altered.+-- class Parenthesize a where+-- alterParens :: (PExpr -> PExpr) -> a -> a+-- ^^ Don't need a class for this!++-- This doesn't seem right. It is too general.+-- instance (Pretty a) => Pretty [a] where+-- pretty as = sepCommaSp (map pretty as)++prettyParens :: (Pretty a) => [a] -> String+prettyParens = prettyList "(" ", " ")"++prettyBrackets :: (Pretty a) => [a] -> String+prettyBrackets = prettyList "[" ", " "]"++-- | Python module -- essentially a list of statements;+-- should it also have a name?+data PModule = PModule [PStatement]+ deriving (Eq, Show)++instance Pretty PModule where+ pretty (PModule ss) = sepLines2 (map pretty ss)++-- | Python statement+data PStatement = PReturn PExpr+ | PImport String -- ^ import statement+ | PCondS PExpr + PStatement + PStatement -- ^ if condition action alt-action+ | PFun PIdentifier + [PParameter]+ PStatement -- ^ function name, formal parameters, body+ deriving (Eq, Show)++instance Pretty PStatement where+ pretty s =+ case s of+ PReturn e -> "return " ++ pretty e+ PImport modName -> "import " ++ modName+ PCondS c a b ->+ sepLines ["if " ++ pretty c ++ ":",+ indentLine 4 (pretty a),+ "else:",+ indentLine 4 (pretty b)]+ PFun fid params body ->+ sepLines ["def " ++ pretty fid ++ + prettyParens params ++ ":",+ indentLine 4 (pretty body)]+++-- | Python expression+data PExpr = PCondE PExpr+ PExpr+ PExpr -- ^ if: condition, value, alt-value+ | PParen PExpr -- ^ expression in parentheses; is this needed?+ | PCall PExpr+ [PExpr] -- ^ function call: function expression (typically a PVariable), argument expressions+ | POperate POperator+ PExpr+ PExpr -- ^ binary operation: operator, left, right+ -- base cases+ | PVariable PIdentifier -- ^ variable identifier+ | PInt Integer+ | PFloat Double+ | PBool Bool+ | PString String+ deriving (Eq, Show)++-- | PExpr as an instance of Pretty.+-- The POperate case needs work to deal with precedences+-- and avoid unnecessary parens+instance Pretty PExpr where+ pretty pexpr =+ case pexpr of+ PCondE c a b -> + unwords [pretty a, "if", pretty c, "else", pretty b]+ PParen e -> prettyParens [e]+ PVariable vid -> pretty vid+ PInt i -> show i+ PFloat x -> show x+ PBool b -> show b+ PString s -> show s+ PCall fexpr argExprs -> + concat [pretty fexpr, prettyParens argExprs]+ POperate op left right -> + unwords [pretty left, pretty op, pretty right]+++-- | Python identifier (variable name, etc.)+data PIdentifier = PIdentifier String+ deriving (Eq, Show)++instance Pretty PIdentifier where+ pretty (PIdentifier s) = s++-- | Python function formal parameter+data PParameter = PParameter PIdentifier+ deriving (Eq, Show)++instance Pretty PParameter where+ pretty (PParameter pident) = pretty pident++-- | Python operator, such as * or ++data POperator = POperator {opName :: String,+ opPrec :: Precedence,+ opAssoc :: Bool -- ^ associative?+ }+ deriving (Eq, Show)++instance Pretty POperator where+ pretty (POperator s _ _) = s++-- | Operator priority, actually should be > 0 or >= 0+type Precedence = Int++-- | Alter the parentheses of a statement by applying a+-- transformer t to the expressions in the statement.++alterParens :: (PExpr -> PExpr) -> PStatement -> PStatement+alterParens t s =+ case s of+ PReturn e -> PReturn (t e)+ PCondS c a b -> PCondS (t c) (alterParens t a) (alterParens t b)+ PFun fid params b -> PFun fid params (alterParens t b)+ _ -> s++atomic :: PExpr -> Bool+atomic pexpr =+ case pexpr of+ PVariable _ -> True+ PInt _ -> True+ PFloat _ -> True+ PBool _ -> True+ PString _ -> True+ _ -> False++compound :: PExpr -> Bool+compound = not . atomic+++-- | Python return statement+ret :: PExpr -> PStatement+ret pexpr = PReturn pexpr++-- | Python if STATEMENT++-- This is the if STATEMENT:+-- if c:+-- a+-- else:+-- b+--+-- But do I need this at all?++condS :: PExpr -> PExpr -> PExpr -> PStatement+condS c a b = PCondS c (ret a) (ret b)++-- | Python if EXPRESSION++-- This is the if EXPRESSION:+-- "a if c else b", which means (in Haskell) "if c then a else b".+-- I didn't even know there was such a thing!+-- It works in both Python 2.6.5 and 3.1.2.+condE :: PExpr -> PExpr -> PExpr -> PExpr+condE c a b = PCondE c a b -- paren (PCondE c a b)+ +-- PExpr smart constructors++-- | Python variable+var :: String -> PExpr+var name = PVariable (PIdentifier name)++-- | Python identifier+ident :: String -> PIdentifier+ident s = PIdentifier s++-- | Python integer expression+pInt :: Integer -> PExpr+pInt i = PInt i++-- | Python float expression+pFloat :: Double -> PExpr+pFloat x = PFloat x++-- | Python boolean expression+bool :: Bool -> PExpr+bool b = PBool b++-- | Python character expression = string expression with one character+char :: Char -> PExpr+char c = string [c]++-- | Python string expression+string :: String -> PExpr+string s = PString s++-- | Python expression in parentheses.++-- Wraps parentheses around an expression.+-- This is needed (at least sometimes!) +-- in calls and binary operator applications.+-- Also in condE!+-- I'm doing it always to be safe (but ugly, not pretty!!)++paren :: PExpr -> PExpr+paren pexpr = PParen pexpr++-- | Remove all grouping parentheses in expression.+-- Does not affect parentheses required for function arguments+-- or parameters.+-- This will sometimes alter the semantics.++-- I don't need noParens; it's just here as an exercise+noParens :: PExpr -> PExpr+noParens pexpr =+ let t = noParens + in case pexpr of+ PParen e -> t e+ PCondE c a b -> PCondE (t c) (t a) (t b)+ PCall fe aes -> PCall (t fe) (map t aes)+ POperate op left right -> POperate op (t left) (t right)+ -- remaining cases are simple and therefore have no parens+ _ -> pexpr++-- | Wrap each subexpression in grouping parentheses.+-- This will typically look like too many parentheses.++-- I don't need fullParens; it's just here as an exercise+fullParens :: PExpr -> PExpr+fullParens pexpr =+ let t = paren . fullParens+ in case pexpr of+ PCondE c a b -> PCondE (t c) (t a) (t b)+ PCall fe aes -> PCall (t fe) (map t aes)+ POperate op left right -> POperate op (t left) (t right)+ -- PParen and base cases need no more ()'s+ _ -> pexpr++-- | Use parentheses for grouping where needed,+-- but cautiously, erring on the side of extra parentheses if not sure+-- they can be removed.++bestParens :: PExpr -> PExpr+bestParens = simplifyParens . fullParens++-- | Remove grouping parentheses that are provably not needed.+-- This may not remove *all* unnecessary grouping parentheses.+-- You can always add more cases to make it better!++simplifyParens :: PExpr -> PExpr+simplifyParens pexpr =+ let t = simplifyParens+ ut = unpar . t+ in case pexpr of+ PParen e -> + -- 1. Atomic expressions, like 5, do not need parens,+ -- because there is nothing to be grouped+ if atomic e + then e+ else case e of+ -- function call (fact(n)) -> fact(n)+ PCall _ _ -> ut e+ _ -> PParen (t e)+ PCondE c a b -> PCondE (ut c) (ut a) (ut b)+ PCall fe aes -> PCall (t fe) (map ut aes)+ POperate op left right -> + sop (POperate op (t left) (t right))+ -- remaining cases are simple and therefore have no parens+ _ -> pexpr++-- | Various rules for removing extra parentheses in operations.+-- Probably incomplete. If the PExpr is not an operation, then+-- it is passed through without change. +sop :: PExpr -> PExpr+sop = sopLeft . sopRight++sopLeft :: PExpr -> PExpr+sopLeft pexpr =+ case pexpr of+ POperate op1 (PParen (POperate op2 left2 right2)) right ->+ if opPrec op2 > opPrec op1+ -- higher precedcence in left subtree+ -- e.g. (a * b) + c ==> a * b + c+ then POperate op1 (POperate op2 left2 right2) right+ else if opPrec op2 == opPrec op1+ -- equal precedence operations, left to right+ -- e.g. (a + b) - c ==> a + b - c+ then POperate op1 (POperate op2 left2 right2) right+ else pexpr+ _ -> pexpr++sopRight :: PExpr -> PExpr+sopRight pexpr = + case pexpr of+ POperate op1 left (PParen (POperate op2 left2 right2)) ->+ if opPrec op2 > opPrec op1+ -- higher precedcence in left subtree+ -- e.g. (a * b) + c ==> a * b + c+ then POperate op1 left (POperate op2 left2 right2)+ else if op1 == op2 && opAssoc op1+ -- associative operation, e.g.+ -- a + (b + c) ==> a + b + c+ then POperate op1 left (POperate op2 left2 right2)+ else pexpr+ _ -> pexpr+++-- | Adding and removing top-level parentheses.+-- Axioms: par (unpar e) == e; unpar (par e) == e.++-- | Add parentheses around an expression. Top level only.+par :: PExpr -> PExpr+par e = PParen e++-- | Remove parentheses around an expression. Top level only.+unpar :: PExpr -> PExpr+unpar pexpr =+ case pexpr of+ PParen e -> e+ _ -> pexpr -- no-op+ +-- | The "operator precedence" of an expression.+-- If the expression is an operation, then this is the+-- precedence of its operator;+-- otherwise, it's not clear what it should be, but for now, -1.++exprPrec :: PExpr -> Precedence+exprPrec pexpr =+ case pexpr of+ POperate op _ _ -> opPrec op+ _ -> (-1)++-- | Python function call expression+call :: String -> [PExpr] -> PExpr+call fname argExprs = PCall (var fname) argExprs++-- arg :: PExpr -> PArgument+-- arg expr = ArgExpr {arg_expr = expr, arg_annot = ()}++-- | Python function formal parameter+param :: String -> PParameter+param name = PParameter (ident name)++-- | Defines function definition+fun :: String -> [String] -> PExpr -> PStatement+fun fname paramNames bodyExpr = + PFun (ident fname) (map param paramNames) (ret bodyExpr)++-- | Binary operators+-- Precedence levels are rather *informally* described in+-- The Python Language Reference,+-- http://docs.python.org/reference/.+-- I am adopting the infixr levels from Haskell,+-- which seem to be consistent with Python,+-- at least for the operators that Sifflet uses.++-- | Arithmetic operators+-- + and - have lower precedence than *, /, //, %+opTimes, opIDiv, opFDiv, opMod, opPlus, opMinus :: POperator+opTimes = POperator "*" 7 True+opIDiv = POperator "//" 7 False+opFDiv = POperator "/" 7 False+opMod = POperator "%" 7 False+opPlus = POperator "+" 6 True+opMinus = POperator "-" 6 False++-- | Comparison operators have precedence lower than any arithmetic+-- operator. Here, I've specified associative = False,+-- because association doesn't even make sense;+-- (a == b) == c is in general not well typed.+opEq, opNe, opGt, opGe, opLt, opLe :: POperator+opEq = POperator "==" 4 False+opNe = POperator "!=" 4 False+opGt = POperator ">" 4 False+opGe = POperator ">=" 4 False+opLt = POperator "<" 4 False+opLe = POperator "<=" 4 False+
+ Sifflet/Foreign/ToHaskell.hs view
@@ -0,0 +1,351 @@+-- | Exports Sifflet to Haskell+-- Requires haskell-src package.++module Sifflet.Foreign.ToHaskell+ (+ HaskellOptions(..)+ , HasParens(..)+ , defaultHaskellOptions+ , exportHaskell+ , functionsToHsModule+ , functionToHsDecl+ , exprToHsExp+ , valueToHsExp+ , prettyModule+ )+where++import Char (toUpper)+import Language.Haskell.Parser -- only for reverse engineering+import Language.Haskell.Syntax+import qualified Language.Haskell.Pretty as HsPretty++import Sifflet.Foreign.Exporter+import Sifflet.Language.Expr+import Sifflet.Examples++import System.FilePath (dropExtension, takeFileName)++-- Main types and functions++-- | User configurable options for export to Haskell.+-- Currently just a place-holder.+data HaskellOptions = HaskellOptions+ deriving (Eq, Show)++-- | The default options for export to Haskell.+defaultHaskellOptions :: HaskellOptions+defaultHaskellOptions = HaskellOptions++-- | Export functions with specified options to a file+-- Work needed: add a declaration "import Sifflet.Data.Number".+exportHaskell :: HaskellOptions -> Exporter+exportHaskell _options functions path =+ let header = "-- File: " ++ path +++ "\n-- Generated by the Sifflet->Haskell exporter.\n\n"+ in writeFile path (header ++ + hspp (simplifyParens+ (functionsToHsModule + (pathToModuleName path)+ functions)))+++pathToModuleName :: FilePath -> String+pathToModuleName path =+ case dropExtension (takeFileName path) of+ [] -> "Test"+ c : cs -> toUpper c : cs++-- ------------------------------------------------------------------------++-- | Shortcuts for Hs*** data constructors,+-- with lots of defaults for features I'm not using.++-- | There is no source location in the conventional sense.+srcLoc :: SrcLoc+srcLoc = SrcLoc {srcFilename = "", srcLine = 0, srcColumn = 0}+ -- {srcFileName = "<unknown", srcLine = 1, srcColumn = 1}++-- | A Haskell module.+hsModule :: String -> [HsImportDecl] -> [HsDecl] -> HsModule+hsModule name importDecls decls =+ HsModule srcLoc (Module name) + Nothing -- :: Maybe [HsExportSpec]+ importDecls + decls++-- | A Haskell import declaration+hsImportDecl :: String -> HsImportDecl+hsImportDecl name =+ HsImportDecl {importLoc = srcLoc,+ importModule = Module name,+ importQualified = False,+ importAs = Nothing,+ importSpecs = Nothing}+++-- | A function binding (declaration and definition)+hsFunBind :: [HsMatch] -> HsDecl+hsFunBind matches =+ HsFunBind matches++-- | Identifier, as the name of a function+hsIdent :: String -> HsName+hsIdent = HsIdent ++-- | Symbol, as the name of an operator+hsSymbol :: String -> HsName+hsSymbol = HsSymbol++-- | Pattern variable, as in the argument list of a function+-- (pattern match)++hsPVar :: String -> HsPat+hsPVar = HsPVar . hsIdent++-- | A variable used in an expression (rather than in an argument list)+hsVar :: String -> HsExp+hsVar = HsVar . UnQual . hsIdent++-- | An infix operator application.+-- Probably needs parentheses added.+hsOperate :: HsExp -> HsQOp -> HsExp -> HsExp+hsOperate left qop right =+ HsInfixApp left qop right++-- | A prefix function application.+-- Need to work some parentheses in here, probably.+hsCall :: HsExp -> [HsExp] -> HsExp+hsCall hfunc hargs = + case hargs of + [] -> + case hfunc of+ HsVar (UnQual (HsIdent name)) -> hfunc+ _ -> error ("hsCall: unexpected form of unary function: " +++ show hfunc)+ a : [] -> HsApp hfunc a+ a : as -> hsCall (HsApp hfunc a) as++-- | An infix operator+hsOp :: String -> HsQOp+-- hsOp name = HsQVarOp (UnQual (HsSymbol name))+hsOp = HsQVarOp . UnQual . hsSymbol++-- | A clause of a function binding+-- hsMatch :: ??++-- ------------------------------------------------------------------------++-- | Converting Sifflet to Haskell syntax tree++-- | Create a module from a module name and Functions.+functionsToHsModule :: String -> Functions -> HsModule+functionsToHsModule mname (Functions fs) =+ hsModule mname + [hsImportDecl "Sifflet.Data.Number"] -- sifflet-Haskell library+ (map functionToHsDecl fs)+ +-- | Create a declaration from a Function.+-- Needs work: infer and declare the type of the function.+functionToHsDecl :: Function -> HsDecl+functionToHsDecl (Function mname atypes rtype impl) =+ case (mname, impl) of+ (Nothing, _) -> error "functionToHsDecl: function has no name"+ (_, Primitive _) -> error "functionToHsDecl: function is primitive"+ (Just fname, Compound args body) ->+ -- forget about type declarations for now+ -- ...+ HsFunBind [HsMatch srcLoc+ (hsIdent fname)+ (map hsPVar args)+ (HsUnGuardedRhs (exprToHsExp body))+ [] -- decls (??)+ ]+ +exprToHsExp :: Expr -> HsExp+exprToHsExp expr =+ case expr of+ EUndefined -> hsVar "undefined"+ ESymbol (Symbol s) -> hsVar s+ ELit v -> valueToHsExp v+ EIf c a b -> + HsIf (exprToHsExp c) (exprToHsExp a) (exprToHsExp b)+ EList es -> HsList (map exprToHsExp es)+ ECall (Symbol fname) args -> + case nameToHaskell fname of+ HsSymbol opName ->+ case args of+ [left, right] -> + HsParen (hsOperate (exprToHsExp left) + (hsOp opName)+ (exprToHsExp right))+ _ -> error "exprToHsExp: operation does not have 2 operands"+ HsIdent funcName ->+ HsParen (hsCall (hsVar funcName) (map exprToHsExp args))++-- ... and somewhere we need to work in HsParen hsExp as needed :-(++valueToHsExp :: Value -> HsExp+valueToHsExp value =+ case value of+ VBool b -> HsCon (UnQual (HsIdent (if b then "True" else "False")))+ VChar c -> HsLit (HsChar c)+ -- Should negative numbers get wrapped in parentheses??+ VInt i -> HsLit (HsInt i)+ VFloat x -> HsLit (HsFrac (toRational x))+ VStr s -> HsLit (HsString s)+ VFun _ -> error "valueToHsLiteral: I don't know how to convert a VFun"+ VList vs -> HsList (map valueToHsExp vs)++-- | Map Sifflet names to Haskell names.+-- Returns the variant HsSymbol for operator names, HsIdent for others+-- (function names, variables, etc.).+-- This might need to be extended with fixity and associativity information,+-- but that can come later when I start to deal with parentheses.+nameToHaskell :: String -> HsName+nameToHaskell name =+ if elem name ["+", "-", "*", "/",+ "==", "/=", "<", ">", "<=", ">=",+ ":"]+ then HsSymbol name+ else + -- some special cases will need to be inserted here,+ -- for zero?, positive? negative?, at least;+ -- add1, sub1 too.+ HsIdent (case name of+ "zero?" -> "eqZero"+ "positive?" -> "gtZero"+ "negative?" -> "ltZero"+ _ -> name)++-- ------------------------------------------------------------------------+-- | Simplifying parentheses+-- This belongs elsewhere, since non-Haskelly things can also+-- be instances.++class HasParens a where+ simplifyParens :: a -> a++instance HasParens HsModule where+ simplifyParens (HsModule locus name exportDecls importDecls decls) =+ HsModule locus name exportDecls importDecls (map simplifyParens decls)++instance HasParens HsDecl where+ simplifyParens decl =+ case decl of+ HsFunBind [HsMatch locus fname args + (HsUnGuardedRhs body)+ []] ->+ HsFunBind [HsMatch locus fname args + (HsUnGuardedRhs (simplifyParens body))+ []]+ _ ->+ decl++instance HasParens HsExp where+ simplifyParens hexp =+ let t = simplifyParens+ ut = unpar . t+ unpar e =+ case e of+ HsParen e' -> e'+ _ -> e+ in case hexp of+ HsIf c a b -> HsIf (ut c) (ut a) (ut b)+ HsList es -> HsList (map t es)++ HsParen e -> + if atomic e then e+ else case e of+ -- work needed here ...+ _ -> hexp+ -- Infix operator application+ HsInfixApp left qop right ->+ -- This *** needs work *** along the lines of Python.hs+ HsInfixApp left qop right+ -- Function applications:+ -- (f a) b ---> f a b.+ -- So why put the parentheses around f a in the first place?+ HsApp (HsParen (HsApp hf ha)) hb ->+ HsApp (HsApp hf ha) hb+ _ -> hexp++-- | Is an expression atomic? Yes if it's a value, a boolean value+-- (i.e., the unary constructor True or False), or a literal; otherwise no.+-- Actually *any* unary constructor could be considered atomic,+-- but I'm not sure how to deal with this. Not urgent,+-- since Sifflet export uses no unary constructors but True and False.++atomic :: HsExp -> Bool+atomic hexp =+ case hexp of+ HsVar (UnQual (HsIdent _)) -> True -- variable+ HsCon (UnQual (HsIdent _)) -> True -- unary constructors: True, False+ HsLit _ -> True -- literals+ HsList _ -> False -- list+ HsIf _ _ _ -> False -- if expression+ HsInfixApp _ _ _ -> False+ HsApp _ _ -> False+ -- well what are the other cases?+ _ -> error ("atomic: don't know how to handle: " ++ show hexp)++-- ------------------------------------------------------------------------++-- | Facilities for testing++asModule :: [String] -> String+asModule strings = unlines ("module Test where" : strings)++test1 :: String+test1 = asModule [+ -- "foo :: Int -> Int -> Int",+ "foo x y = x + y"]++test2 :: String+test2 = asModule [+ "foo1 x = bar (codd x)",+ "foo2 = bar . codd"]++prettyDS :: [String] -> IO ()+prettyDS declStrings = prettyModule (asModule declStrings)++prettyES :: String -> IO ()+prettyES expString = prettyModule (asModule ["x = " ++ expString])++hspp :: (HsPretty.Pretty a) => a -> String+hspp = HsPretty.prettyPrint++prettyModule :: String -> IO ()+prettyModule string =+ case parseModule string of+ ParseOk m -> putStrLn (hspp m)+ ParseFailed loc msg -> putStrLn (show loc ++ ": " ++ msg)++prettyE :: Expr -> IO ()+prettyE expr =+ putStrLn (hspp (exprToHsExp expr))++prettyV :: Value -> IO ()+prettyV value =+ putStrLn (hspp (valueToHsExp value))++testParse :: String -> ParseResult HsModule+testParse string = parseModule string++testCallPrefix :: IO ()+testCallPrefix = prettyE $ ECall (Symbol "mod") [ELit (VInt 7), ELit (VInt 5)]++testCallInfix :: IO ()+testCallInfix = prettyE $ ECall (Symbol "+") [ELit (VInt 7), ELit (VInt 5)]++testFunBind :: Function -> IO ()+testFunBind f = putStrLn (hspp (simplifyParens (functionToHsDecl f)))++testExportModule :: String -> [Function] -> IO ()+testExportModule moduleName fs = + putStrLn (hspp (simplifyParens+ (functionsToHsModule moduleName (Functions fs))))++-- | Test export of an example function, specified by name+testEF :: String -> IO ()+testEF = testFunBind . getExampleFunction
+ Sifflet/Foreign/ToPython.hs view
@@ -0,0 +1,165 @@+-- | Sifflet to abstract syntax tree for Python.+-- Use Python module's pretty to pretty-print the result.++module Sifflet.Foreign.ToPython+ (+ PythonOptions(..)+ , defaultPythonOptions+ , exprToPExpr+ , valueToPExpr+ , nameToPython+ , fixIdentifierChars+ , functionToPyDef+ , defToPy+ , functionsToPyModule+ , functionsToPrettyPy+ , exportPython+ )++where++import Char (isAlpha, isDigit, ord)+import Control.Monad (unless)++import Sifflet.Foreign.Exporter+import Sifflet.Foreign.Python+import Sifflet.Language.Expr+import Sifflet.Text.Pretty++import System.Directory (copyFile, doesFileExist)+import System.FilePath (replaceFileName)++import Paths_sifflet_lib -- Cabal-generated paths module++-- | Options for Python export.+-- Should probably include choices like Python2 or Python3;+-- if statement or if expression. Right now, just a placeholder.++data PythonOptions = PythonOptions+ deriving (Eq, Show)+++defaultPythonOptions :: PythonOptions+defaultPythonOptions = PythonOptions++exprToPExpr :: Expr -> PExpr+exprToPExpr expr =+ case expr of+ EUndefined -> var "undefined"+ ESymbol (Symbol str) -> var str -- ???+ ELit value -> valueToPExpr value+ EIf cond action altAction ->+ -- 2 choices here: Python if statement (condS)+ -- or Python if expression (condE)+ condE (exprToPExpr cond) + (exprToPExpr action)+ (exprToPExpr altAction)+ EList exprs -> + call "li" (map exprToPExpr exprs)+ ECall (Symbol fname) args -> + -- Python distinguishes between functions and operators+ case nameToPython fname of+ Left operator ->+ case args of+ [left, right] -> + POperate operator+ (exprToPExpr left)+ (exprToPExpr right)+ _ -> error "exprToPExpr: operation does not have 2 operands"+ Right pname ->+ call pname (map exprToPExpr args)+++valueToPExpr :: Value -> PExpr+valueToPExpr value =+ case value of+ VList vs -> call "li" (map valueToPExpr vs)+ VBool b -> bool b+ VChar c -> char c+ VInt i -> pInt i+ VFloat x -> pFloat x+ VStr s -> string s+ VFun f -> var "undefined" -- fix! Is it fixable? ***+ -- Scheme: SFunction f++-- | Convert Sifflet name (of a function) to Python name+nameToPython :: String -> Either POperator String+nameToPython name =+ case name of + "+" -> Left opPlus+ "-" -> Left opMinus+ "*" -> Left opTimes+ "div" -> Left opIDiv+ "mod" -> Left opMod+ "/" -> Left opFDiv -- invalid for integers in Python 2!+ "==" -> Left opEq+ "/=" -> Left opNe+ ">" -> Left opGt+ ">=" -> Left opGe+ "<" -> Left opLt+ "<=" -> Left opLe+ "add1" -> Right "add1"+ "sub1" -> Right "sub1"+ "zero?" -> Right "eqZero"+ "positive?" -> Right "gtZero"+ "negative?" -> Right "ltZero"+ "null" -> Right "null"+ "head" -> Right "head"+ "tail" -> Right "tail"+ ":" -> Right "cons"+ _ -> Right (fixIdentifierChars name)++-- | Remove characters that are not valid in a Python identifier,+-- and in some cases, insert other characters to show what's missing++fixIdentifierChars :: String -> String+fixIdentifierChars =+ let fix s =+ case s of+ [] -> []+ c:cs ->+ if isAlpha c || isDigit c || c == '_'+ then c : fix cs+ else case c of+ '?' -> "_QUESTION_" ++ fix cs+ -- other cases can be inserted here+ _ -> "_CHR" ++ show (ord c) ++ "_" ++ fix cs+++ in fix++functionToPyDef :: Function -> PStatement+functionToPyDef = defToPy . functionToDef++defToPy :: FunctionDefTuple -> PStatement+defToPy (fname, paramNames, _, _, body) =+ fun (fixIdentifierChars fname) paramNames (exprToPExpr body)++functionsToPyModule :: Functions -> PModule+functionsToPyModule (Functions fs) = PModule (map functionToPyDef fs)++functionsToPrettyPy :: Functions -> String+functionsToPrettyPy = pretty . functionsToPyModule++exportPython :: PythonOptions -> Exporter+exportPython _options funcs path = + let header = "# File: " ++ path +++ "\n# Generated by the Sifflet->Python exporter.\n\n" +++ "from sifflet import *\n\n"+ libDest = replaceFileName path "sifflet.py"+ in do+ {+ libDestExists <- doesFileExist libDest+ ; unless libDestExists + (do+ -- copy sifflet.py to the same directory as path+ {+ libSrc <- pythonLibSiffletPath + ; copyFile libSrc libDest+ }+ )+ ; writeFile path (header ++ (functionsToPrettyPy funcs))+ }++pythonLibSiffletPath :: IO FilePath+pythonLibSiffletPath = getDataFileName "sifflet.py"
+ Sifflet/Foreign/ToScheme.hs view
@@ -0,0 +1,311 @@+module Sifflet.Foreign.ToScheme+ (SExpr(..)+ , Atom(..)+ , Indent+ , Exporter+ , SchemeOptions(..)+ , defaultSchemeOptions+ , exprToSExpr+ , functionNameToSchemeName+ , valueToSExpr+ , exprToSchemeRepr+ , exprToSchemePretty+ , exprToScheme+ , inl+ , sepLines2+ , functionsToSExprs+ , functionsToPrettyScheme+ , defToSExpr+ , exportScheme+ )++where++import Paths_sifflet_lib -- generated by Cabal++import Sifflet.Foreign.Exporter+import Sifflet.Language.Expr+import Sifflet.Text.Repr+import Sifflet.Text.Pretty++-- Scheme S-exprs+-- --------------++-- Names beginning with S are generally Scheme things,+-- and of course, SExpr also stands for Symbolic Expression.++data SExpr = SAtom Atom | SList [SExpr]+ deriving (Eq, Show)++data Atom = SFloat Double+ | SInt Integer+ | SSymbol String+ | SString String+ | SChar Char+ | SBool Bool+ | SFunction Function+ deriving (Eq, Show)++type Indent = Int++data SchemeOptions = + SchemeOptions { defineWithLambda :: Bool + -- ^ use explicit lambda in function definitions,+ -- (define f (lambda (a b) ...)+ }+ deriving (Eq, Show)++defaultSchemeOptions :: SchemeOptions+defaultSchemeOptions = SchemeOptions {defineWithLambda = False}++-- | An SExpr is "flattish" if it is an atom+-- or is a list containing only atoms, +-- where the empty list () is an atom.++flattish :: [SExpr] -> Bool+flattish sexprs =+ case sexprs of+ [] -> True+ x:xs -> atom x && flattish xs++atom :: SExpr -> Bool+atom sexpr =+ case sexpr of+ SAtom _ -> True+ SList [] -> True+ _ -> False++-- Converting Sifflet Exprs to SExprs++exprToSExpr :: Expr -> SExpr+exprToSExpr expr =+ case expr of+ EUndefined -> + SAtom (SSymbol "*sifflet-undefined*")+ ESymbol (Symbol str) -> + SAtom (SSymbol (functionNameToSchemeName str))+ ELit value -> + valueToSExpr value+ EIf cond action altAction ->+ SList [SAtom (SSymbol "if"), exprToSExpr cond,+ exprToSExpr action, exprToSExpr altAction]+ EList exprs -> + -- This case is not likely to be used,+ -- but if it is, the exprs might need to be evaluated,+ -- so we have to use list instead of quote+ SList (SAtom (SSymbol "list") : (map exprToSExpr exprs))+ ECall fsym args -> + SList (exprToSExpr (ESymbol fsym) : map exprToSExpr args) ++-- Convert Sifflet function names to corresponding Scheme function names.+-- There are a few special cases; otherwise, the names are the same.+-- In particular, all of these have the same names in Sifflet+-- as in standard (R5RS) Scheme:+-- +, -, *, +-- All of these are defined in the library sifflet.scm, +-- with the prefix "sifflet-" (e.g., sifflet-div):+-- div, add1, sub1, /, not-equal?+-- Notes: 1+ and 1- are commonly found in Scheme implementations,+-- but not standard.++functionNameToSchemeName :: String -> String+functionNameToSchemeName name =+ case name of+ "mod" -> "modulo"+ "add1" -> "sifflet-add1"+ "sub1" -> "sifflet-sub1"+ "==" -> "equal?"+ "/=" -> "sifflet-not-equal?"+ "null" -> "null?"+ "head" -> "car"+ "tail" -> "cdr"+ ":" -> "cons"+ _ -> name++-- Converting Sifflet Values to SExprs++valueToSExpr :: Value -> SExpr+valueToSExpr value =+ case value of+ VList vs -> + SList [SAtom (SSymbol "quote"), SList (map valueToSExpr vs)]+ _ ->+ SAtom (case value of+ VBool b -> SBool b+ VChar c -> SChar c+ VInt i -> SInt i+ VFloat x -> SFloat x+ VStr s -> SString s+ VFun f -> SFunction f+ VList _ -> + error ("valueToSExpr: Impossible! " +++ "We can't have VList here!")+ )++-- Converting Exprs to Strings of Scheme code++exprToSchemeRepr :: Expr -> String+exprToSchemeRepr = repr . exprToSExpr++exprToSchemePretty :: Expr -> String+exprToSchemePretty = pretty . exprToSExpr++exprToScheme :: Expr -> String+exprToScheme = exprToSchemePretty++-- Converting SExprs to Strings of Scheme code++instance Repr SExpr where+ repr sexpr =+ case sexpr of+ SAtom satom ->+ case satom of+ SFloat x -> show x+ SInt i -> show i+ SSymbol name -> name -- without ""+ SString str -> show str -- with ""+ SChar char -> show char+ SBool False -> "#f"+ SBool True -> "#t"+ -- SFunction: is this case really needed?+ -- Isn't the conversion to Scheme function names+ -- done in exprToSExpr? + SFunction (Function mname _ _ _) ->+ case mname of+ Nothing -> + error "SExpr/repr: cannot repr unnamed function"+ Just name -> + functionNameToSchemeName name+ SList exprs ->+ "(" ++ unwords (map repr exprs) ++ ")"++instance Pretty SExpr where+ pretty = prettyLoop 0++prettyLoop :: Indent -> SExpr -> String+prettyLoop ind sexpr =+ case sexpr of+ SAtom _ -> repr sexpr+ SList xs ->+ if flattish xs+ then repr sexpr+ else+ case xs of+ [] -> error "prettyLoop: non-flattish xs cannot be []."+ [SAtom (SSymbol "if"), _, _, _] ->+ displayList2 ind (ind + 4) xs+ [SAtom (SSymbol "define"), _, _] ->+ displayList2 ind (ind + 4) xs+ [SAtom (SSymbol "lambda"), _, _] ->+ displayList2 ind (ind + 4) xs+ SAtom (SSymbol name) : args ->+ -- If it starts as a symbol, it's probably a function call,+ -- so put function name and first argument on one line,+ -- and indent everything following to first argument.+ case args of+ [] ->+ -- no argument+ displayList1 ind (ind + length name + 2) xs+ _ ->+ -- at least one argument, so at least two elements+ -- in the list+ displayList2 ind (ind + length name + 2) xs+ _ -> displayList1 ind (ind + 1) xs+++-- | Newline and indent+inl :: Int -> String+inl ind = "\n" ++ replicate ind ' '++-- displayList1 "shows" the first list element on the first line+-- and then the rest on succeeding lines, so it must have at+-- least one element+displayList1 :: Indent -> Indent -> [SExpr] -> String+displayList1 ind ind' xs =+ case xs of+ [] -> error "displayList1: empty list"+ x:xs' -> "(" ++ + prettyLoop ind x ++ + displayTail ind' xs'++-- Like displayList1 but "shows" the first *two* list elements+-- on the first line.+displayList2 :: Indent -> Indent -> [SExpr] -> String+displayList2 ind ind' xs =+ case xs of+ x0:x1:xs' -> "(" ++ prettyLoop ind x0 +++ " " ++ prettyLoop ind' x1 +++ displayTail ind' xs'+ _ -> error "displayList2: list is too short"++-- displayTail "shows" the tail of an SExpr which is a list,+-- it assumes the initial "(" and first element have already+-- been "shown"+displayTail :: Indent -> [SExpr] -> String+displayTail ind xs =+ case xs of+ [] -> ")"+ -- to prevent final ")" from being on a line by itself+ x:[] -> inl ind ++ prettyLoop ind x ++ ")"+ x:xs' -> inl ind ++ prettyLoop ind x ++ displayTail ind xs'++++-- Converting Sifflet definitions to Scheme definitions.++-- | Convert Sifflet Functions to Scheme SExprs+functionsToSExprs :: SchemeOptions -> Functions -> [SExpr]+functionsToSExprs options (Functions fs) =+ map (defToSExpr options . functionToDef) fs++-- | Convert Sifflet Functions to pretty Scheme+functionsToPrettyScheme :: SchemeOptions -> Functions -> String+functionsToPrettyScheme options = + sepLines2 . map pretty . functionsToSExprs options++-- | Convert a FunctionDefTuple to a Scheme SExpr.+-- Use the form (define (name . args) body)+-- except when there are zero arguments, which becomes a+-- Scheme constant rather than a function,+-- use (define name expr).++defToSExpr :: SchemeOptions -> FunctionDefTuple -> SExpr+defToSExpr options (name, args, _atypes, _rtype, body) =+ let asym = SAtom . SSymbol+ sdefine = asym "define"+ sname = asym name+ sbody = exprToSExpr body+ in case args of+ [] -> SList [sdefine, sname, sbody]+ _:_ ->+ let argAtoms = map asym args+ in if defineWithLambda options+ then let slambda = asym "lambda"+ sargs = SList argAtoms+ slambdaArgsBody = SList [slambda, sargs, sbody]+ in SList [sdefine, sname, slambdaArgsBody]+ else let snameArgs = SList (sname : argAtoms)+ in SList [sdefine, snameArgs, sbody]++-- | Export functions to a Scheme file.++-- This, too, could use an extra "explicit lambda" argument,+-- like defToSExpr.++exportScheme :: SchemeOptions -> Exporter+exportScheme options functions path = do+ {+ let header = ";;; File: " ++ path +++ "\n;;; Generated by the Sifflet->Scheme exporter."+ ; lib <- schemeLibSiffletPath >>= readFile+ ; writeFile path + (sepLines2 [header,+ functionsToPrettyScheme options functions,+ lib])+ }++-- | The path to the "sifflet.scm" file.+schemeLibSiffletPath :: IO FilePath++-- getDataFileName is provided by Cabal+schemeLibSiffletPath = getDataFileName "sifflet.scm"
+ Sifflet/Language/Expr.hs view
@@ -0,0 +1,1073 @@+module Sifflet.Language.Expr+ (stringToExpr, exprToValue, stringToValue+ , stringToLiteral+ , Symbol(..)+ , OInt, OStr, OBool, OChar, OFloat+ , 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+ , Functions(..)+ , Function(..), functionName, functionNArgs+ , functionArgTypes, functionResultType, functionType+ , functionArgNames, functionBody, functionImplementation+ , FunctionDefTuple, functionToDef, functionFromDef+ , FunctionImpl(..)+ , VpType(..), typeMatch, typeCheck, vpTypeOf+ , TypeEnv, emptyTypeEnv+ , Env, emptyEnv, makeEnv, extendEnv, envInsertL, envPop+ , envIns, envSet, envGet+ , envGetFunction, envLookup, envLookupFunction+ , envSymbols, envFunctionSymbols, envFunctions+ , 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)++-- Try to get rid of these:+import Language.Haskell.Syntax+import Language.Haskell.Parser+++import Data.Map as Map hiding (filter, map, null)+import Data.List as List++import Sifflet.Data.Tree as T+import Sifflet.Text.Repr ()+import Sifflet.Util++{-# DEPRECATED stringToExpr "Use Sifflet.Language.Parser.parseExpr or Sifflet.Language.Parser.parseInput instead But stringToExpr is more general, so it may be needed in some cases." #-}++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.+-- I've restricted function calls to the case where the function expression+-- is just a symbol, since otherwise it will be hard to visualize.+-- But with some thought, it may be possible to generalize+-- this to +-- ECall [Expr] -- (function:args) + +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+ 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 vs) = reprList "[" ", " "]" vs++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 =+ -- take a shortcut here?+ case stringToExpr s of+ Succ expr -> exprToValue expr+ Fail errmsg -> Fail errmsg++data VpType = VpTypeBool+ | VpTypeChar+ | VpTypeNum+ | VpTypeString + | 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++emptyTypeEnv :: TypeEnv+emptyTypeEnv = Map.empty++-- | 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 collection of functions, typically to be saved or exported+-- or read from a file++data Functions = Functions [Function]+ deriving (Eq, Show)++-- | 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)+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)++emptyEnv :: Env+emptyEnv = makeEnv [] []++makeEnv :: [String] -> [Value] -> Env +makeEnv names values = extendEnv names values []++extendEnv :: [String] -> [Value] -> Env -> Env+extendEnv names values env = fromList (zip names values) : env++-- | Insert names and values from lists into an environment+envInsertL :: Env -> [String] -> [Value] -> Env+envInsertL env names values =+ case env of+ [] -> error "envInsertL: empty list"+ f : fs ->+ let ins :: EnvFrame -> Binding -> EnvFrame+ ins frame (name, value) = Map.insert name value frame+ in foldl ins f (zip names values) : fs++envIns :: Env -> String -> Value -> Env+envIns env name value =+ case env of+ [] -> error "envIns: empty list"+ f : fs -> Map.insert name value f : fs++envSet :: Env -> String -> Value -> Env+envSet env name value = + -- If name is bound in some map in the environment, update the binding+ -- in that map; otherwise insert it into the "front" map+ let loop :: Env -> Maybe Env+ loop env1 =+ case env1 of+ [] -> Nothing+ f:fs ->+ case Map.lookup name f of+ Just _ -> Just (envIns env1 name value)+ Nothing ->+ do -- in the Maybe monad:+ fs' <- loop fs+ return (f:fs')++ in case loop env of+ Just result -> result+ Nothing -> envIns env name value++-- | Get the value of a variable from an environment+envGet :: Env -> String -> Value+envGet env name = case envLookup env name of+ Just value -> value+ Nothing -> errcats ["envGet: unbound variable:", name]++envGetFunction :: Env -> String -> Function+envGetFunction env name = func + where VFun func = envGet env name++envLookup :: Env -> String -> Maybe Value+envLookup env name =+ case env of+ [] -> Nothing+ f:fs ->+ case Map.lookup name f of+ Just value -> Just value+ Nothing -> envLookup fs name++envLookupFunction :: Env -> String -> Maybe Function+envLookupFunction env name = + case envLookup env name of+ Nothing -> Nothing+ Just value ->+ case value of+ VFun function -> Just function+ _ -> Nothing++-- | List of all symbols bound in the environment+envSymbols :: Env -> [String]+envSymbols env =+ case env of+ [] -> []+ f : fs -> keys f ++ envSymbols fs++-- | List of all symbols bound to functions in the environment+envFunctionSymbols :: Env -> [String]+envFunctionSymbols env =+ let isFunction s = case envGet env s of+ VFun _ -> True+ _ -> False+ in [s | s <- envSymbols env, isFunction s]++-- | All the functions in the environment+envFunctions :: Env -> Functions+envFunctions env = + Functions (map (envGetFunction env) + (envFunctionSymbols env))++-- | Return to the environment prior to an extendEnv+envPop :: Env -> Env+envPop env =+ case env of+ [] -> error "envPop: empty list"+ _f:fs -> fs+ +unbound :: String -> Env -> Bool+unbound name env = envLookup env name == Nothing++-- EVALUATING EXPRESSIONS++-- Limit the stack size for recursion, since we are helping+-- novice programmers to learn++stackSize :: Int+stackSize = 1000++eval :: Expr -> Env -> EvalResult+eval expr env = evalWithLimit expr env stackSize++evalWithLimit :: Expr -> Env -> Int -> EvalResult++-- Evaluate an expression in an environment with a limited stack++evalWithLimit expr env stacksize =+ if stacksize <= 0+ then EvalError "stack overflow"+ else+ let stacksize' = pred stacksize in+ case expr of+ EUndefined -> EvalError "undefined"+ ESymbol (Symbol name) ->+ case envLookup env name of+ Nothing -> EvalError $ "unbound variable: " ++ name+ Just value -> EvalOk value++ 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)
+ Sifflet/Language/Parser.hs view
@@ -0,0 +1,288 @@+-- | A parser for Sifflet input values.+-- This is not a parser for all Sifflet expressions,+-- but just those that might be input in textual form+-- through the function call dialog that asks for the argument values.+-- So, it is limited (deliberately) to "data" types of expressions:+-- that is, Exprs using the constructors:+-- ELit+-- EList+-- That means excluding Exprs constructed with EUndefined,+-- ESymbol, EIf, and ECall.++module Sifflet.Language.Parser+ (parseExpr, parseInput+ -- , parseInputAsValue+ , parseTest+ , parseSuccFail, nothingBut+ , expr, list, literal+ , value, typedValue+ , bool, qchar, qstring, integer, double+ , number+ )++where++import Text.ParserCombinators.Parsec++import Sifflet.Language.Expr+import Sifflet.Util+++-- | Parse a Sifflet data literal (number, string, char, bool, or list)+parseExpr :: String -> SuccFail Expr+parseExpr = parseSuccFail expr++-- | Parse a Sifflet input containing exactly one data expression+-- possibly flanked by white space+parseInput :: String -> SuccFail Expr+parseInput = parseSuccFail input++parseSuccFail :: Parser a -> String -> SuccFail a+parseSuccFail p s =+ case parse p "user input" s of+ Left perr -> Fail (show perr)+ Right v -> Succ v+++-- | Like expr, but consumes the entire input,+-- so there must not be any extraneous characters after the Expr.+input :: Parser Expr+input = nothingBut expr++-- | 'nothingBut p is like 'p', but consumes the entire input,+-- so there must be no extraneous characters (except space)+-- after whatever 'p' parses.+nothingBut :: Parser a -> Parser a+nothingBut p = (many space >> p) `prog1` (many space >> eof)++prog1 :: (Monad m) => m a -> m b -> m a+prog1 m1 m2 = m1 >>= (\ r -> m2 >> return r)++-- | Parse a Sifflet data expression+expr :: Parser Expr+expr = -- (try (list expr >>= return . EList)) <|>+ literal+ +list :: Parser a -> Parser [a]+list element = + let sep = try (skipMany space >> char ',' >> skipMany space)+ in (char '[' >> many space >> sepBy element sep)+ `prog1`+ (many space >> char ']')+ -- do I need (...) above?+ <?> "list" -- ???+++literal :: Parser Expr+literal = value >>= return . ELit++-- | Parser for a Value of any type (any VpType),+-- except that we cannot parse as VpTypeVar or VpTypeFunction.++value :: Parser Value+value = (bool >>= return . VBool) <|>+ (qchar >>= return .VChar) <|>+ (qstring >>= return . VStr) <|>+ try (double >>= return . VFloat) <|>+ (integer >>= return . VInt) <|>+ (list value >>= return . VList)++-- | Parser for a value with a specific VpType expected.+-- Again, we cannot do this for VpTypeVar (why not?)+-- or VpTypeFunctiopn++typedValue :: VpType -> Parser Value+typedValue t = + (case t of+ VpTypeBool -> bool >>= return . VBool+ VpTypeChar -> qchar >>= return . VChar+ VpTypeString -> qstring >>= return . VStr+ VpTypeNum -> do { en <- number;+ case en of+ Left x -> return (VFloat x)+ Right i -> return (VInt i)+ }+ VpTypeList e -> list (typedValue e) >>= return . VList+ VpTypeVar _ -> value -- can't check, so just accept anything+ VpTypeFunction _ _ -> + error "typedValue: not implemented for VpTypeFunction"+ )+ <?> typeName t++-- | A name for the type, for use in parser error reporting+typeName :: VpType -> String+typeName t =+ case t of + VpTypeBool -> "boolean" -- "boolean (True or False)"+ VpTypeChar -> "character" -- "character (in single quotes)"+ VpTypeNum -> "number"+ VpTypeString -> "string" -- "string (in double quotes)"+ VpTypeList e -> "list" ++ -- "list (in brackets)" +++ case e of+ VpTypeVar _ -> ""+ _ -> " of " ++ typeName e++ VpTypeVar _ -> "anything" -- could be more specific!+ VpTypeFunction _ _ -> "function" -- ???+++bool :: Parser Bool+bool = (try (string "True" >> return True) <|>+ (string "False" >> return False))+ <?> typeName VpTypeBool+++-- quoted character 'c'+qchar :: Parser Char+qchar = + let sq = '\'' -- single quote character+ in (((char sq <?> "opening single quote") >> + (try escapedChar <|> noneOf [sq])) + `prog1`+ (char sq <?> "closing single quote")+ )+ <?> typeName VpTypeChar+ +-- quoted string "c..."++qstring :: Parser String+qstring = + let dq = '\"' -- double quote character+ in (char dq >> + many (escapedChar <|> noneOf [dq] <?> "")) + `prog1` + (char dq <?> "close of quotation")+ -- Do I need (...) above?+ <?> typeName VpTypeString++-- escapedChar recognizes the following escape sequences:+-- \t = tab+-- \n = newline+-- \r = carriage return+-- \\ = backslash+-- Anything else that begins with \ is an error.++escapedChar :: Parser Char+escapedChar = + let bs = '\\' -- backslash character+ in char bs >> + (oneOf "ntr\\" <?> "n, t, r, or \\ to follow \\") >>=+ (\ c ->+ return (case c of+ 'n' -> '\n'+ 't' -> '\t'+ 'r' -> '\r'+ '\\' -> '\\'+ _ -> error "escapedChar: c MUST be n, t, r, or \\"+ )+ )++ -- do { _ <- char bs;+ -- c <- oneOf "ntr\\"+ -- <?>+ -- "n, t, r, or \\ to follow \\";+ -- return (case c of+ -- 'n' -> '\n'+ -- 't' -> '\t'+ -- 'r' -> '\r'+ -- '\\' -> '\\'+ -- _ -> error "escapedChar: c MUST be n, t, r, or \\"+ -- )+ -- }++++data Sign = Minus | Plus++-- Integer ::= (+|-)? digit+++integer :: Parser Integer -- sign, digits+integer = do { s <- optSign;+ u <- unsignedInteger;+ return (applySign s u)+ }+ <?> "integer"++unsignedInteger :: Parser Integer+unsignedInteger = many1 digit >>= return . read++-- An optional + or - defaulting to +++optSign :: Parser Sign -- 1: negative; 0: non-negative+optSign = try ( char '-' >> return Minus ) <|>+ try ( char '+' >> return Plus ) <|>+ return Plus++applySign :: (Num n) => Sign -> n -> n+applySign s x =+ case s of + Minus -> (- x)+ Plus -> x++-- A double (float) may begin with a sign (+ or -) and must contain+-- a decimal point along with at least one digit before and/or after+-- the decimal point.+-- So there are three cases:+-- [sign] digits '.' digits+-- [sign] digits '.'+-- [sign] '.' digits++double :: Parser Double++-- Double FAILS if there is a decimal point.+-- It succeeds in the following cases:++double = + let digits1 = many1 digit+ point = char '.'+ -- wpf: whole-part point fraction-part+ wpf = do { dd <- digits1;+ dd' <- point >> digits1;+ return (dd, dd')+ }+ -- wp: whole-part point+ wp = do { dd <- digits1 `prog1` point;+ return (dd, "0")+ }+ -- pf: point fraction-part+ pf = do { dd' <- point >> digits1;+ return ("0", dd')+ }+ -- optional trailing exponent notation e.g. e-4+ scale = do { i <- oneOf "eE" >> integer;+ return (10 ** fromIntegral i)+ }+ <|> return 1++ in do { sign <- optSign+ ; (whole, frac) <- (try wpf <|>+ try wp <|>+ try pf)+ ; m <- scale;+ ; let w = read (whole ++ ".0") -- whole part as number+ f = read ("0." ++ frac) -- frac part as number+ ; return (m * applySign sign (w + f))+ }+ <?> "real number"++-- A number may be either a double (with decimal point) or an integer (without).+-- To avoid consuming "123" from "123." and interpreting it as an integer,+-- we MUST try to parse double before integer.+number :: Parser (Either Double Integer)+number = (try (double >>= return . Left) <|> + (integer >>= return . Right))+ <?> typeName VpTypeNum++-- -- numberValue :: Parser Value+-- -- numberValue = do { x <- number;+-- -- case x of+-- -- value :: Parser Value+-- value = (bool >>= return . VBool) <|>+-- (qchar >>= return . VChar)++-- Left dx -> return (VFloat dx)+-- -- Right ix -> return (VInt ix)+-- -- }+-- -- <?> typeName VpTypeNumber++
+ Sifflet/Language/SiffML.hs view
@@ -0,0 +1,403 @@+-- | SiffML : Sifflet Markup Language.+-- An XML application for storing and retrieving Sifflet programs+-- and libraries.++module Sifflet.Language.SiffML+ (+ ToXml(..)+ , produceSiffMLFile+ , consumeSiffMLFile+ , xmlToFunctions+ -- , testOut -- testing+ -- , xmlToX -- testing+ -- , testIn, testFromFile -- testing+ )++where++import Text.XML.HXT.Arrow++import Sifflet.Language.Expr+import Sifflet.Util++class ToXml a where+ toXml :: a -> XMLProducer++-- | An XMLProducer produces XML+type XMLProducer = IOSLA (XIOState ()) XmlTree XmlTree++-- | An XMLConsumer consumes XML+type XMLConsumer a b = IOSLA (XIOState ()) a b++defaultOptions :: [(String, String)]+defaultOptions = [(a_indent, v_yes), (a_validate, v_no)]++produceSiffMLFile :: (ToXml a) => a -> FilePath -> IO ()+produceSiffMLFile src path = + let arrow :: XMLProducer+ arrow = toXml src+ options = defaultOptions+ in do+ {+ putStrLn ""+ ; [rc] <- runX (root [] [arrow] >>>+ writeDocument options path >>>+ getErrStatus)+ ; putStrLn (case rc of+ 0 -> "Okay"+ _ -> "Failed")++ }+consumeSiffMLFile :: XMLConsumer XmlTree a -> FilePath -> IO [a]+consumeSiffMLFile fromXml filePath =+ let options = defaultOptions+ in runX (readDocument options filePath >>> fromXml)++-- | Symbols++instance ToXml Symbol where+ toXml = symbolToXml++symbolToXml :: Symbol -> XMLProducer+symbolToXml (Symbol name) =+ selem "symbol" [txt name]+++-- | Expr++instance ToXml Expr where+ toXml = exprToXml++exprToXml :: Expr -> XMLProducer+exprToXml expr =+ 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 :: XMLConsumer 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))+ )++-- | Values++instance ToXml Value where+ toXml = valueToXml++valueToXml :: Value -> XMLProducer+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)++xmlToValue :: XMLConsumer XmlTree Value+xmlToValue = + isElem >>>+ ((hasName "True" >>> constA (VBool True)) <+>+ (hasName "False" >>> constA (VBool False)) <+>+ (hasName "char" >>> getChildren >>> isText >>> getText >>>+ arr (VChar . head)) <+>+ (hasName "string" >>> getChildren >>> isText >>> getText >>> + arr 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 -> XMLProducer+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]+ VpTypeFunction _ _ -> errcats ["vpTypeToXml: VpTypeFunction cannot be",+ "converted to XML"]++xmlToVpType :: XMLConsumer 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 -> XMLProducer+functionToXml (Function mName argTypes retType impl) =+ case impl of+ Primitive _ ->+ -- shouldn't happen+ errcats ["functionToXml:",+ "primitive functions cannot be exported to XML",+ show (mName, argTypes, retType)]+ Compound argNames body ->+ selem "compound-function"+ (let name s = selem "name" [txt s]+ rest = + [selem "return-type" [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 :: XMLConsumer XmlTree Function+xmlToFunction = + let getChildElem :: XMLConsumer XmlTree XmlTree+ getChildElem = getChildren >>> isElem++ getFuncName :: XMLConsumer XmlTree String+ getFuncName = hasName "name" >>> getChildren >>> isText >>> getText++ getReturnType :: XMLConsumer XmlTree VpType+ getReturnType = hasName "return-type" >>> getChildren >>> xmlToVpType++ getArgTypes :: XMLConsumer XmlTree [VpType]+ getArgTypes = hasName "arg-types" >>> + listA (getChildren >>> xmlToVpType)++ getArgNames :: XMLConsumer XmlTree [String]+ getArgNames = hasName "arg-names" >>> + listA (getChildElem >>> getFuncName)++ getBody :: XMLConsumer XmlTree Expr+ getBody = hasName "body" >>> getChildren >>> xmlToExpr ++ in + isElem >>> hasName "compound-function" >>> + -- NOTE:+ -- If arr1 "produces" a, and arr2 "produces" b,+ -- then (arr1 &&& arr2) "produces" (a, b).+ (+ ( -- function name is optional, though it *should* be in the XML file+ listA (getChildElem >>> getFuncName)) &&& + (getChildElem >>> getReturnType) &&&+ (getChildElem >>> getArgTypes) &&&+ (getChildElem >>> getArgNames) &&&+ (getChildElem >>> getBody)+ )+ >>>+ (arr (\ (names, (returnType, (argTypes, (argNames, body)))) -> + Function (case names of + [] -> Nothing+ (fname : _) -> (Just fname)+ )+ argTypes+ returnType (Compound argNames body)))++functionsToXml :: Functions -> XMLProducer+functionsToXml (Functions fs) =+ selem "functions" (map toXml fs)++xmlToFunctions :: XMLConsumer XmlTree Functions+xmlToFunctions =+ isElem >>> -- document root+ getChildren >>>+ hasName "functions" >>>+ listA (getChildren >>> xmlToFunction) >>>+ arr Functions++instance ToXml Functions where+ toXml = functionsToXml++-- -- | Examples and tests++-- exampleFunction :: Function+-- exampleFunction = +-- let esym = ESymbol . Symbol+-- in Function (Just "cincr") +-- [VpTypeBool, VpTypeNum, VpTypeNum]+-- VpTypeNum+-- (Compound ["incr", "a", "b"]+-- (EIf (esym "incr")+-- (ECall (Symbol "+") [esym "a", esym "b"])+-- (esym "a")))++-- -- | This is for testing, when I don't know the type +-- -- of the result I'm getting+-- xmlToX :: XMLConsumer XmlTree Functions -- [Function] -- XmlTree+-- xmlToX = +-- isElem -- document root+-- >>>+-- getChildren+-- >>>+-- hasName "functions" +-- >>>+-- listA (getChildren >>> xmlToFunction) +-- >>>+-- arr Functions++-- -- | Tests++-- testOut :: IO ()+-- testOut = +-- produceStdout (Functions [exampleFunctions !! 0, exampleFunctions !! 1])+++-- testFromFile :: (Show a) => XMLConsumer XmlTree a -> FilePath -> IO ()+-- testFromFile fromXml filePath = do+-- {+-- results <- consumeSiffMLFile fromXml filePath+-- ; putStrLn ""+-- ; print (length results)+-- ; print results+-- ; putStrLn ""+-- }++-- testIn :: (Show a) => XMLConsumer XmlTree a -> IO ()+-- testIn fromXml = testFromFile fromXml "-"++-- UNUSED:++-- -- | testFromXml :: (ToXml a, Show a) => a -> XMLConsumer XmlTree a -> IO ()+-- -- VVV This type generalization (a, a to a, b) is for debugging, undo it later:+-- testFromXml :: (ToXml a, Show b) => a -> XMLConsumer XmlTree b -> IO ()+-- testFromXml src consumer = do+-- {+-- produceSiffMLFile 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 -> XMLConsumer XmlTree a -> IO ()+-- testToXmlAndBack = testFromXml+++-- xmlToSymbol :: XMLConsumer XmlTree Symbol+-- xmlToSymbol = +-- isElem >>> hasName "symbol" >>> -- symbol element+-- getChildren >>> isText >>> -- text element+-- getText >>> -- String+-- arr Symbol -- quasi (return . Symbol)++-- testXmlToSymbol :: Symbol -> IO ()+-- testXmlToSymbol sym = testFromXml sym xmlToSymbol+++-- exampleIfExpr :: Expr+-- exampleIfExpr = (EIf (ELit (VBool False)) -- (eCall ">" [eInt 32, eInt 61]) +-- (ELit (VStr "yes")) +-- (ELit (VStr "no")))++-- exampleListExpr :: Expr+-- exampleListExpr = EList [ELit (VInt 1), ELit (VInt 2), ELit (VInt 3)]++-- exampleCallExpr :: Expr+-- exampleCallExpr = ECall (Symbol "foo") [ESymbol (Symbol "x"), ELit (VInt 2)]+++-- produceStdout :: (ToXml a) => a -> IO ()+-- produceStdout src = produceSiffMLFile src "-"+++-- produceXmlTrees :: (ToXml a) => a -> IO [XmlTree]+-- produceXmlTrees src = +-- let arrow :: XMLProducer+-- arrow = toXml src+-- options = defaultOptions+-- in do+-- {+-- putStrLn ""+-- ; docs <- runX (root [] [arrow] >>> writeDocument options "-")+-- ; case docs of+-- [] -> putStrLn "Failed"+-- doc : _ ->+-- print doc+-- ; return docs++-- }++++-- consumeStdin :: XMLConsumer XmlTree a -> IO [a]+-- consumeStdin fromXml = consumeSiffMLFile fromXml "-"+++-- exampleVList :: Value+-- exampleVList = VList [VInt 32, VInt 64, VInt 69]
+ Sifflet/Rendering/Draw.hs view
@@ -0,0 +1,223 @@+module Sifflet.Rendering.Draw+ ( + Draw(..), DrawMode(..)+ , drawBox+ , drawTextBox+ , modeTextCol, modeEdgeCol, modeFillCol+ , setColor++ )++where++import Control.Monad+import Graphics.Rendering.Cairo hiding (translate)++import Sifflet.Data.Functoid+import Sifflet.Data.Geometry+import Sifflet.Data.Tree+import Sifflet.Data.TreeLayout++setColor :: VColor -> Render ()++setColor (ColorRGB red green blue) =+ setSourceRGB red green blue ++setColor (ColorRGBA red green blue alpha) =+ setSourceRGBA red green blue alpha++-- Drawing things+-- THINK: is this class well conceived?+-- A lot of things could be done with draw and translate+-- if it were not tied to Style and DrawMode++class Draw a where+ draw :: Style -> DrawMode -> a -> Render ()++-- VV DrawMode is now very awkward, since +-- a node needs to know not only if it is selected,+-- but which port(s) are selected++data DrawMode = DrawNormal | DrawActive + | DrawSelectedNode + | DrawSelectedInlet Int + | DrawSelectedOutlet Int+ deriving (Eq)++instance Draw FunctoidLayout where+ draw style mode (FLayoutTree t) = draw style mode t+ draw style mode (FLayoutForest f _) = draw style mode f++instance (Draw e) => Draw [e] where+ draw style mode = mapM_ (draw style mode)++instance (Draw e) => Draw (Tree e) where+ draw style mode t = do+ draw style mode (rootLabel t)+ draw style mode (subForest t)++instance Draw (LayoutNode e) where+ draw style mode (LayoutNode gnode _treeBB) = draw style mode gnode++instance Draw (GNode e) where++ draw style mode (GNode _value textboxes nodeBB inlets outlets) = + do+ -- draw node box+ let (nodeTextCol, nodeEdgeCol, nodeFillCol) = + case mode of+ DrawActive -> + (styleActiveTextColor, + styleActiveEdgeColor,+ styleActiveFillColor)+ DrawSelectedNode -> + (styleSelectedTextColor, + styleSelectedEdgeColor,+ styleSelectedFillColor)+ _ -> (styleNormalTextColor, + styleNormalEdgeColor, + styleNormalFillColor)+ + -- (overall box for the node)+ when (styleShowNodeBoxes style) $+ drawBox (Just (nodeFillCol style))+ (Just (nodeEdgeCol style)) nodeBB+ ++ -- assert textboxes has one or two elements+ -- draw the first text box+ drawTextBox (Just (styleFont style))+ (Just (nodeFillCol style)) -- background+ Nothing -- frame color+ (nodeTextCol style) -- text color+ (head textboxes)++ -- draw the second textbox, if any, using "aux" style+ case (tail textboxes) of+ [tbAux] -> + drawTextBox (Just (styleAuxFont style))+ Nothing+ Nothing+ (styleAuxColor style)+ tbAux+ _ -> return ()+++ -- Draw the iolets+ when (styleShowNodePorts style) $ do+ drawInlets style mode inlets+ drawOutlets style mode outlets+ ++instance Draw TextBox where+ draw style mode =+ drawTextBox (Just (styleFont style))+ (Just (modeFillCol mode style)) + Nothing+ (modeTextCol mode style) ++drawTextBox :: Maybe VFont -> Maybe VColor -> Maybe VColor -> VColor ->+ TextBox -> Render ()+drawTextBox mfont mbgcolor mframecolor textcolor + (TextBox text textBB boxBB) = do+ let BBox textX textY _textW _textH = textBB+ drawBox mbgcolor mframecolor boxBB+ setColor textcolor+ case mfont of + (Just font) -> setFont font+ _ -> return ()+ moveTo textX textY+ showText text++instance Draw BBox where+ draw style mode = + drawBox (Just (modeFillCol mode style)) + (Just (modeEdgeCol mode style)) ++drawBox :: Maybe VColor -> Maybe VColor -> BBox -> Render ()+drawBox mBgColor mFgColor (BBox x y w h) = + -- draw the BBox, in the specified colors, irrespective of style+ let setup color = + do+ rectangle x y w h+ setColor color+ in case (mBgColor, mFgColor) of+ (Just bgColor, Just fgColor) ->+ do+ setup bgColor+ fillPreserve+ setColor fgColor+ stroke+ (Just bgColor, Nothing) -> + do+ setup bgColor+ fill+ (Nothing, Just fgColor) -> + do+ setup fgColor+ stroke+ _ -> return ()++instance Draw Position where+ draw _style _mode _pos = return () -- bare points are invisible ??? ******++instance Draw Iolet where+ draw style mode (Iolet circle) = draw style mode circle++drawIolet :: Iolet -> VColor -> VColor -> Render ()+drawIolet (Iolet circle) = drawCircle circle++drawInlets :: Style -> DrawMode -> [Iolet] -> Render ()+drawInlets style mode inlets =+ let selected i = mode == DrawSelectedInlet i+ in drawIolets selected style inlets++drawOutlets :: Style -> DrawMode -> [Iolet] -> Render ()+drawOutlets style mode outlets =+ let selected o = mode == DrawSelectedOutlet o+ in drawIolets selected style outlets++drawIolets :: (Int -> Bool) -> Style -> [Iolet] -> Render ()+drawIolets selected style iolets =+ -- (selected n) should be true iff n is the selected iolet+ let loop _ [] = return ()+ loop n (p:ps) = + uncurry (drawIolet p)+ (if selected n + then (styleSelectedFillColor style, + styleSelectedEdgeColor style)+ else (styleNormalFillColor style, + styleNormalEdgeColor style)) >>+ loop (n + 1) ps+ in loop 0 iolets+ +instance Draw Circle where+ draw style mode circle = + drawCircle circle (modeFillCol mode style) (modeEdgeCol mode style) ++drawCircle :: Circle -> VColor -> VColor -> Render ()+drawCircle (Circle (Position x y) r) bgColor fgColor = do+ newPath -- otherwise we get a line to the arc+ arc x y r 0 (2 * pi)+ setColor bgColor+ fillPreserve+ setColor fgColor+ stroke++-- Helper functions to find the background and foreground colors for a mode++modeFillCol :: DrawMode -> (Style -> VColor)+modeFillCol DrawNormal = styleNormalFillColor+modeFillCol DrawActive = styleActiveFillColor+modeFillCol _ = styleSelectedFillColor++modeTextCol :: DrawMode -> (Style -> VColor)+modeTextCol DrawNormal = styleNormalTextColor+modeTextCol DrawActive = styleActiveTextColor+modeTextCol _ = styleSelectedTextColor++modeEdgeCol :: DrawMode -> (Style -> VColor)+modeEdgeCol DrawNormal = styleNormalEdgeColor+modeEdgeCol DrawActive = styleActiveEdgeColor+modeEdgeCol _ = styleSelectedEdgeColor+
+ Sifflet/Rendering/DrawTreeGraph.hs view
@@ -0,0 +1,182 @@+-- | Tree graph rendering+module Sifflet.Rendering.DrawTreeGraph+ (+ graphQuickView+ , graphWriteImageFile, graphRender, treeRender+ , treeWriteImageFile, gtkShowTree+ )++where++import IO+import Data.IORef+import System.Cmd+import Graphics.UI.Gtk.Gdk.EventM++import Graphics.Rendering.Cairo hiding (translate)+import Data.Graph.Inductive as G++import Sifflet.UI.LittleGtk++import Sifflet.Data.Geometry+import Sifflet.Data.Tree+import Sifflet.Data.TreeGraph+import Sifflet.Data.TreeLayout+import Sifflet.Rendering.Draw+import Sifflet.Text.Repr ()++-- ============================================================+-- 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+ }
+ Sifflet/Text/Pretty.hs view
@@ -0,0 +1,48 @@+module Sifflet.Text.Pretty + (Pretty(..)+ , indentLine, sepLines, sepLines2+ , sepComma, sepCommaSp)++where++import Data.List (intercalate)+++-- | The class of types that can be pretty-printed.+-- pretty x is a pretty String representation of x.+-- prettyList prefix infix postfix xs is a pretty String representation+-- of the list xs, with prefix, infix, and postfix specifying the+-- punctuation. For example, if (pretty x) => "x",+-- then prettyList "[" ", " "]" [x, x, x] => "[x, x, x]".+--+-- Minimal complete implementation: define pretty.++class Pretty a where++ pretty :: a -> String++ prettyList :: String -> String -> String -> [a] -> String+ prettyList pre tween post xs =+ pre ++ intercalate tween (map pretty xs) ++ post++-- | Indent a single line n spaces.+indentLine :: Int -> String -> String+indentLine n line = replicate n ' ' ++ line++-- | sepLines is like unlines, but omits the \n at the end of the+-- last line.+sepLines :: [String] -> String+sepLines = intercalate "\n"++-- | sepLines2 is like sepLines, but adds an extra \n between each+-- pair of lines so they are "double spaced."+sepLines2 :: [String] -> String+sepLines2 = intercalate "\n\n"++-- | Separate strings by commas and nothing else (",")+sepComma :: [String] -> String+sepComma = intercalate ","++-- | Separate strings by commas and spaces (", ")+sepCommaSp :: [String] -> String+sepCommaSp = intercalate ", "
+ Sifflet/Text/Repr.hs view
@@ -0,0 +1,62 @@+module Sifflet.Text.Repr+ (Repr(..)+ , Name(..)+ )++where++import Data.List (intercalate)++-- | class Repr: representable by a String or a list of Strings+--+-- repr x is a String representation of x.+-- reprl x is a [String] representation of x,+-- where the first element should be the same as repr x,+-- and the rest provide auxiliary information+-- that you want to be shown with x.+-- reprs x is a reduction of reprl x to a single String.+-- reprList prefix infix postfix xs is the representation of a list of xs+--+-- Minimal complete implementation: define repr, or define reprl.+-- The normal way is to define repr. Define reprl instead,+-- if for some reason you want to include additional information+-- such as the value of an expression in an expression node.+--+-- Examples:+-- - (3 :: Int) has repr => "3", reprl => ["3"], reprs => "3"+-- - In Sifflet.Language.Expr, (ENode (NSymbol "x") (EvalOk (3 :: Int)+-- has reprl => ["x", "3"], reprs => "x 3", and repr => "x".+-- - reprList "(" " " ")" [3 :: Int, 4, 5] => "(3 4 5)"++class Repr a where++ repr :: a -> String+ repr = head . reprl++ reprl :: a -> [String]+ reprl x = [repr x]++ reprs :: a -> String+ reprs = unwords . reprl++ reprList :: String -> String -> String -> [a] -> String+ reprList pre tween post xs =+ pre ++ intercalate tween (map repr xs) ++ post++instance Repr Int where repr = show+instance Repr Integer where repr = show+instance Repr Float where repr = show+instance Repr Double where repr = show+instance Repr Char 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
+ Sifflet/UI.hs view
@@ -0,0 +1,30 @@+{- Workspace.hs implements the graphical workspace of Sifflet -}++module Sifflet.UI+ (+ module Sifflet.UI.Frame+ , module Sifflet.UI.LittleGtk+ , module Sifflet.UI.RPanel+ , module Sifflet.UI.Types+ , module Sifflet.UI.Callback+ , module Sifflet.UI.Canvas+ , module Sifflet.UI.Tool+ , module Sifflet.UI.Workspace+ , module Sifflet.UI.GtkForeign+ , module Sifflet.UI.GtkUtil+ , module Sifflet.UI.Window+ )++where++import Sifflet.UI.Callback+import Sifflet.UI.Canvas+import Sifflet.UI.Frame+import Sifflet.UI.Tool+import Sifflet.UI.Workspace+import Sifflet.UI.GtkForeign+import Sifflet.UI.GtkUtil+import Sifflet.UI.LittleGtk+import Sifflet.UI.RPanel+import Sifflet.UI.Types+import Sifflet.UI.Window
+ Sifflet/UI/Callback.hs view
@@ -0,0 +1,140 @@+module Sifflet.UI.Callback+ (+ CBMgr, CBMgrCmd(..), mkCBMgr+ , MenuSpec(..), MenuItemSpec(..), MenuItemAction+ , createMenuBar, addMenu, createMenu, createMenuItem+ , modifyIORefIO+ ) ++where++import Data.IORef++import Graphics.UI.Gtk++import Sifflet.UI.Types++-- | The CBMgr (Callback manager) encapsulates (in an enclosure, no less!)+-- an IORef VPUI. It is used *solely* to set up callbacks+-- and similar stuff in Gtk, where the callback needs access+-- to the IORef. By passing a CBMgr to a function, we can+-- avoid passing the IORef directly, and all the harm and+-- confusion that could result.+--+-- We only need *one* CBMgr for the application;+-- however, two CBMgrs with the same IORef are logically equivalent,+-- so there would be no harm in having two as long as they share one IORef.+type CBMgr = CBMgrCmd -> IO ()++-- | 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
+ Sifflet/UI/Canvas.hs view
@@ -0,0 +1,988 @@+-- File: Canvas.hs+-- Canvas and CanvFrame data and operations++module Sifflet.UI.Canvas+ (+ atLeastSize+ , cfContext+ , connect+ , disconnect+ , drawCanvas+ , editFunction+ , frameChanged+ , nodeContainerFrame+ , pointSelection+ , vcAddFrame+ , vcClearSelection+ , vcClearFrame+ , vcCloseFrame+ , vcEvalDialog+ , vcFrameAddFunctoidNode+ , vcFrameAddNode+ , vcFrameDeleteNode+ , vcFrameDeleteTree+ , vcFrameSubframes+ , vcGetFrame+ , vcInvalidateFrameWithParent+ , vcInvalidateBox+ , vcUpdateFrameAndGraph+ , vcanvasNew+ , vcanvasNodeAt+ , vcanvasNodeRect+ , whichFrame + , callFrames+ )++where++import Control.Monad+import Data.List as List++import Data.Graph.Inductive as G++import Graphics.Rendering.Cairo hiding (translate)++import Sifflet.Data.Functoid+import Sifflet.Data.Geometry as Geometry+import Sifflet.Data.Tree as T+import Sifflet.Data.TreeGraph+import Sifflet.Data.TreeLayout+import Sifflet.Data.WGraph+import Sifflet.Language.Expr+import Sifflet.Language.Parser+import Sifflet.Rendering.Draw+import Sifflet.UI.Frame+import Sifflet.UI.GtkUtil+import Sifflet.UI.LittleGtk+import Sifflet.UI.Types+import Sifflet.Util++-- Experimental:+enableDoubleBuffering :: Bool+enableDoubleBuffering = True++vcanvasNew :: Style -> Double -> Double -> IO VCanvas+vcanvasNew style width height = do+ -- create gtkLayout (the "drawing canvas")+ gtkLayout <- layoutNew Nothing Nothing+ -- Turn double buffering on or off. + -- Normally, double buffering eliminates flicker,+ -- but if the rendering is through the network,+ -- it might be better to disable it.+ -- See docs for Graphics.UI.Gtk.Gdk.DrawWindow+ -- (drawWindow{Begin,End}PaintRegion), and+ -- Graphics.UI.Gtk.Abstract.Widget+ -- (widgetSetDoubleBuffered).+ widgetSetDoubleBuffered gtkLayout enableDoubleBuffering++ -- create the VCanvas+ let vCanvas = VCanvas {vcLayout = gtkLayout, vcStyle = style, + vcGraph = wgraphNew,+ vcFrames = [],+ -- vcSize is the requested size of the+ -- canvas (Gtk.Layout)+ vcSize = Size width height,+ -- but this is the requested size;+ -- how can I get the actual, current size?+ -- Answer: + -- layoutGetSize :: Layout -> IO (Int, Int)+ -- removed: vcLocalEnv = env,+ vcMousePos = (0, 0), -- ???+ vcTool = Nothing,+ vcDragging = Nothing,+ vcActive = Nothing,+ vcSelected = Nothing++ }+ -- Most essential event handlers+ _ <- onSizeRequest gtkLayout+ (return (Requisition (round width) (round height)))+ + return vCanvas++nodeContainerFrame :: VCanvas -> WGraph -> G.Node -> CanvFrame+nodeContainerFrame vcanvas g = vcGetFrame vcanvas g . nodeContainerFrameNode g++-- Ask the VCanvas to find the frame whose frame node element is the+-- given Node; it is an error if not found or if there is more than one.+vcGetFrame :: VCanvas -> WGraph -> Node -> CanvFrame+vcGetFrame vcanvas graph frameNode = + let frames = [f | f <- vcFrames vcanvas, cfFrameNode f == frameNode]+ err phrase = errcats ["vcGetFrame", phrase,+ "frameNode:", show frameNode, + "\nframes:", show frames,+ "\ngraph:\n", show graph]+ in case frames of+ [frame] -> frame+ [] -> err "no frame found"+ (_:_:_) -> err "multiple frames found"++-- | Ask the vcanvas to update the frame and install a new graph.+-- Frames are identified by their frame nodes, so the new frame +-- must have the same frame node as the old.+-- It is an unreported error if there is not exactly one match.+vcUpdateFrameAndGraph :: VCanvas -> CanvFrame -> WGraph -> VCanvas+vcUpdateFrameAndGraph vcanvas newFrame newGraph =+ let frames = vcFrames vcanvas+ frameNode = cfFrameNode newFrame -- should match frameNode of old frame+ frames' = + [if cfFrameNode f == frameNode then newFrame else f | f <- frames]+ in vcanvas {vcFrames = frames', vcGraph = newGraph}++-- | Like vcUpdateFrameAndGraph, but keep the canvas's old graph.+vcUpdateFrame :: VCanvas -> CanvFrame -> VCanvas+vcUpdateFrame vcanvas newFrame =+ vcUpdateFrameAndGraph vcanvas newFrame (vcGraph vcanvas)++-- Delete a frame from the vcanvas's frames ref+-- This does not update the graph -- see vcCloseFrame for that.+vcDeleteFrame :: VCanvas -> CanvFrame -> VCanvas+vcDeleteFrame vcanvas frame =+ let frames = vcFrames vcanvas+ node = cfFrameNode frame+ frames' = [f | f <- frames, cfFrameNode f /= node]+ in vcanvas {vcFrames = frames'}++-- RENDERING+-- perhaps ought to be its own module++-- Perhaps this ought to be called graphRenderFunctoid! ***++graphRenderFunctoidParts :: + Style -> Maybe Node -> Maybe Selection -> WGraph -> CanvFrame -> Render ()+graphRenderFunctoidParts style mact msel graph frame = + case cfFunctoid frame of+ FunctoidFunc _ -> error "graphRenderFunctoidParts: not an edit frame"+ FunctoidParts {} -> + graphRenderForest style mact msel graph + (nodeProperSimpleDescendants graph + (cfFrameNode frame))++graphRenderForest :: + Style -> Maybe Node -> Maybe Selection -> WGraph -> [G.Node] -> Render ()+graphRenderForest style mact msel graph roots = + let renderNode node = graphRenderTree style mact msel graph node False+ in mapM_ renderNode roots++graphRenderTree :: Style -> Maybe Node -> Maybe Selection -> WGraph ->+ G.Node -> Bool -> Render ()+graphRenderTree style mact msel graph rootNode fillBackground =+ let loop :: Maybe Iolet -> G.Node -> Render ()+ loop mInlet currentNode = do+ -- Render the root+ (inlets, outs) <-+ graphRenderNode style mact msel graph currentNode mInlet+ -- Render the subtrees+ loopWithInlets 0 inlets (sortBy adjCompareEdge outs)+ + -- loopWithInlets n inletPositions outs:+ -- n = the current inlet number, starting from 0+ -- inletPositions = the points to connect to on the parent+ -- outs = a list of (child, edge) pairs (adjs)+ -- going to *simple* children (i.e., not frame nodes)+ -- There must be at least as many inlets as there are outs.+ -- If the edge of the first outs equals n, we use the+ -- first inletPosition. Otherwise we skip the inlet+ -- but not out.+ loopWithInlets :: Int -> [Iolet] -> [(G.Node, WEdge)] -> Render ()+ loopWithInlets _n _is [] = return ()+ loopWithInlets n (i:is) (a:as) =+ -- n: number of child, i: inlet, a: adjacency (node, edge)+ let (node, edge) = a in+ if edge == WEdge n+ then do+ loop (Just i) node -- draw node with current inlet+ loopWithInlets (n + 1) is as -- and draw the rest+ else -- skip current inlet+ loopWithInlets (n + 1) is (a:as) + + loopWithInlets _n [] (a:as) = + 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 v -> repr v+ defaults = map (argDefault (cfEnv frame)) varnames+ parseTypedInput :: (String, String, VpType) -> SuccFail Value+ parseTypedInput (s, varname, vartype) =+ case parseSuccFail (nothingBut (typedValue vartype)) s of+ Fail msg ->+ Fail ("For variable " ++ varname ++ ":\n" ++ msg)+ Succ v -> Succ v+ reader :: Reader [String] [Value]+ reader inputs =+ mapM parseTypedInput -- parseInputAsTypedValue' + (zip3 inputs varnames (functionArgTypes function))+ in do+ dialog <- + createEntryDialog "Input Values" varnames defaults reader (-1)+ result <- runEntryDialog dialog+ case result of+ Nothing -> return canvas+ Just values -> evalFrame canvas frame values++-- | Evaluate the frame, having gotten a list of values from the dialog++evalFrame :: VCanvas -> CanvFrame -> [Value] -> IO VCanvas+evalFrame canvas frame values = do+ -- Close subframes (those that were made by+ -- expanding a node of this frame)+ canvas' <- vcCloseSubframes canvas frame++ -- Re-evaluate expression tree and update display+ let graph = vcGraph canvas'++ -- Pop the current frame's values, if any, before+ -- extending with the new values.+ -- A frame with no values has a dummy extension,+ -- so this is still okay.+ frameNode = cfFrameNode frame+ -- It's a call frame, so it has a root+ root = cfRoot frame+ style = vcStyle canvas'+ headerTB = cfHeader frame++ -- The tlo may *change*, since showing values may require+ -- extra space.++ (frame', tlo') = frameNewWithLayout style + (bbPosition (tbBoxBB headerTB))+ (cfLevel frame)+ (cfFunctoid frame) (Just values) CallFrame+ frameNode + (envPop (cfEnv frame))+ Nothing++ -- Since the frame is a call frame, we should have a tree tlo.++ case tlo' of+ FLayoutTree _t ->+ do+ -- update the tree in the graph+ let graph' = grUpdateFLayout graph [root] tlo'+ canvas'' = vcUpdateFrameAndGraph canvas' frame' graph'+ + -- request redrawing of old and new areas+ frameChanged canvas' graph frame graph' frame'+ + return canvas''++ FLayoutForest _f _b ->+ error "vcEvalDialog: finishDialog: tlo is not a tree"++-- WORK HERE ***+-- This will be a lot like vcEvalDialog, except we are *un*-evaluating.+-- :-(++-- | vcClearFrame - clear a frame in a canvas; not yet implemented+-- What does this mean?++vcClearFrame :: VCanvas -> CanvFrame -> IO VCanvas+vcClearFrame canvas _frame = + showInfoMessage "Sorry" "Stub: vcClear is not yet implemented" >>+ return canvas++-- | Close a frame and any subframes of it++vcCloseFrame :: VCanvas -> CanvFrame -> IO VCanvas+vcCloseFrame canvas frame = do+ -- close any subframes of this frame+ canvas' <- vcCloseSubframes canvas frame -- 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)
+ Sifflet/UI/Frame.hs view
@@ -0,0 +1,306 @@+module Sifflet.UI.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 Sifflet.Data.Functoid+import Sifflet.Data.Geometry+import Sifflet.Data.Tree+import Sifflet.Data.TreeLayout+import Sifflet.Data.WGraph+import Sifflet.Language.Expr+import Sifflet.Util++-- ---------------------------------------------------------------------+-- CanvFrame operations+-- ---------------------------------------------------------------------+++-- | A CanvFrame represents (indirectly, through cfRoot, and we+-- access to the graph which is provided by the VCanvas)+-- a "subgraph" such as the expression tree+-- of a function which is being edited or called.++data CanvFrame = CanvFrame {+ cfHeader :: TextBox -- ^ top area of the frame+ , cfFooter :: TextBox -- ^ bottom area+ , cfVarNames :: [String] -- ^ variable (parameter) names+ , cfParent :: Maybe G.Node -- ^ the node opened to make this frame+ , cfFrameNode :: G.Node -- ^ this frame as a node in the graph;+ -- also serves as the ID of the frame.+ , cfEnv :: Env -- ^ environment for evaluation+ , cfBox :: BBox -- ^ box of the whole frame (header, tree, and footer)+ , cfLevel :: Double -- ^ 0 = bottom level, 1 = next higher, etc.+ , cfFunctoid :: Functoid -- ^ includes tlo for an edit frame+ , frameType :: FrameType -- ^ edit or call frame+ }+ deriving (Show)+ +++-- | CanvFrame needs to be Eq in order to be Ord,+-- but maybe the Eq and Ord definitions should be more+-- in the same spirit?+instance Eq CanvFrame where (==) = (==) `on` cfFrameNode++data FrameType = EditFrame | CallFrame deriving (Eq, Read, Show)++-- | Use levelOrder for sorting frames before drawing them+levelOrder :: CanvFrame -> CanvFrame -> Ordering+levelOrder f1 f2 = compare (cfLevel f1) (cfLevel f2) ++-- | The root of the tree displayed in the frame+cfRoot :: CanvFrame -> G.Node+cfRoot frame = + case frameType frame of+ EditFrame -> error "cfRoot: an edit frame has no root"+ CallFrame -> succ (cfFrameNode frame)++-- | A frame is "eval ready" -- that is, okay to run the Eval Frame dialog --+-- if it is a call frame with no parent+cfEvalReady :: CanvFrame -> Bool+cfEvalReady frame = + (frameType frame == CallFrame) && (cfParent frame == Nothing)++cfPointInHeader :: CanvFrame -> Double -> Double -> Bool+cfPointInHeader frame x y = + pointInBB (Position x y) (tbBoxBB (cfHeader frame))++cfPointInFooter :: CanvFrame -> Double -> Double -> Bool+cfPointInFooter frame x y = + pointInBB (Position x y) (tbBoxBB (cfFooter frame))++frameBodyBox :: CanvFrame -> BBox+frameBodyBox frame =+ -- the space between the header and footer+ let hbb = tbBoxBB (cfHeader frame)+ fbb = tbBoxBB (cfFooter frame)+ top = bbBottom hbb+ bottom = bbTop fbb+ -- assuming both header and footer are left aligned and same width+ in BBox (bbLeft hbb) top (bbWidth hbb) (bottom - top)++editFrameNodes :: CanvFrame -> [G.Node]+editFrameNodes frame =+ case frameType frame of+ EditFrame -> fpNodes (cfFunctoid frame)+ CallFrame -> error "editFrameNodes: not an EditFrame"++frameNodeAt :: CanvFrame -> WGraph -> Position -> Maybe G.Node+frameNodeAt frame graph point = + case frameType frame of+ CallFrame -> callFrameNodeAt frame graph point+ EditFrame -> editFrameNodeAt frame graph point++editFrameNodeAt :: CanvFrame -> WGraph -> Position -> Maybe G.Node+editFrameNodeAt _frame _graph _point = Nothing -- STUB ***+ -- this could probably make use of the function that finds ***+ -- a selection from a point ***++callFrameNodeAt :: CanvFrame -> WGraph -> Position -> Maybe G.Node+callFrameNodeAt frame graph point = + let search :: [G.Node] -> Maybe G.Node+ search [] = Nothing+ search (r:rs) =+ case lab graph r of+ Just (WFrame _) -> search rs+ Just (WSimple layoutNode) ->+ let LayoutNode rootGNode treeBB = layoutNode+ in+ if pointInBB point treeBB + -- it's in the tree rooted at r+ then if pointInBB point (gnodeNodeBB rootGNode) + -- it's in the root node+ then Just r+ else search (suc graph r) -- maybe in the subtrees+ else search rs -- maybe in the siblings+ Nothing -> + errcats ["editFrameNodeAt: search: no label for node",+ show r]+ -- since this is a call frame, it had better have a root+ in search [cfRoot frame]++atLeastSizeFrame :: Size -> CanvFrame -> CanvFrame+atLeastSizeFrame (Size minW minH) frame =+ let BBox _ _ width height = cfBox frame+ dwidth = if minW > width then minW - width else 0+ dheight = if minH > height then minH - height else 0+ in resizeFrame frame dwidth dheight++resizeFrame :: CanvFrame -> Double -> Double -> CanvFrame+resizeFrame frame dw dh = + let BBox x y bwidth height = frameBodyBox frame+ -- do not shrink body to negative size+ bwidth' = max 0 (bwidth + dw)+ height' = max 0 (height + dh)+ bodyBB' = BBox x y bwidth' height'+ header' = alignHeader (cfHeader frame) bodyBB'+ footer' = alignFooter (cfFooter frame) bodyBB'+ frameBox' = bbMergeList [tbBoxBB header', tbBoxBB footer', bodyBB']+ in frame {cfHeader = header', cfFooter = footer', cfBox = frameBox'}+++translateFrame :: CanvFrame -> Double -> Double -> CanvFrame+translateFrame frame dx dy =+ frame {cfHeader = translate dx dy (cfHeader frame),+ cfFooter = translate dx dy (cfFooter frame),+ cfBox = translate dx dy (cfBox frame)}+++-- | Where to position a new frame that is grown out of an old frame?+-- This is a very rough draft of frameOffset+frameOffset :: Style -> CanvFrame -> Position+frameOffset style oldFrame = + let bb = cfBox oldFrame+ in Position (bbRight bb + styleFramePad style) (bbTop bb - 40)++++nodeCompoundFunction :: WGraph -> CanvFrame -> Node -> Maybe Function+nodeCompoundFunction graph frame node = + case lab graph node of+ Nothing -> error "nodeCompoundFunction: no label for node"+ Just (WFrame _) -> error "nodeCompoundFunction: node has a WFrame label"+ Just (WSimple layoutNode) ->+ case gnodeValue (nodeGNode layoutNode) of+ ENode (NSymbol (Symbol "if")) _mvalue -> Nothing -- not a function+ ENode (NSymbol (Symbol symbolName)) _mvalue ->+ case envLookup (cfEnv frame) symbolName of+ Nothing -> Nothing -- unbound symbol okay, at least sometimes+ Just (VFun func@(Function _ _ _ (Compound _ _))) -> Just func+ Just _ -> Nothing -- not a compound function+ _ -> Nothing -- not a symbol++grTranslateFrameNodes :: WGraph -> CanvFrame -> Double -> Double -> WGraph+grTranslateFrameNodes wgraph frame dx dy =+ case frameType frame of+ CallFrame -> translateTree dx dy wgraph (cfRoot frame)+ EditFrame -> translateNodes dx dy wgraph (editFrameNodes frame)+ +pointIolet :: Position -> Int -> [Iolet] -> Maybe Int+pointIolet point n iolets =+ -- find the number of the iolet, if any, containing point+ case iolets of + [] -> Nothing+ (p:ps) ->+ if pointInIolet point p + then Just n+ else pointIolet point (n + 1) ps+++-- | argIoletCounter returns (no. of inlets, no. of outlets)+-- derived from the argument list of a function still being defined+argIoletCounter :: [String] -> ExprNode -> (Int, Int)+argIoletCounter labels _exprNode = (length labels, 1)++-- | Aligning a CanvFrame's header and footer with the body of the frame.+-- Aligns the header above, and the footer below, the body of the frame,+-- also matching the width if the body widened++alignHeader :: TextBox -> BBox -> TextBox+alignHeader header bodybox =+ let headerBB = tbBoxBB header+ y0 = bbBottom headerBB+ y1 = bbTop bodybox+ x0 = bbLeft headerBB+ x1 = bbLeft bodybox+ in translate (x1 - x0) (y1 - y0) (tbSetWidth header (bbWidth bodybox))++alignFooter :: TextBox -> BBox -> TextBox+alignFooter footer bodybox =+ let footerBB = tbBoxBB footer+ y0 = bbTop footerBB+ y1 = bbBottom bodybox+ x0 = bbLeft footerBB+ x1 = bbLeft bodybox+ in translate (x1 - x0) (y1 - y0) (tbSetWidth footer (bbWidth bodybox))+++-- | Figure out the frame layout for a function. Returns the layout and frame.+-- Currently, the frame is marked as a "call frame"; if you want to edit it,+-- call (editFrame? editFunction?)++frameNewWithLayout :: Style -> Position -> Double+ -> Functoid -> Maybe [Value] -> FrameType -- added arg+ -> Node -> Env -> Maybe G.Node + -> (CanvFrame, FunctoidLayout) -- reversed tuple+frameNewWithLayout style (Position x y) z + functoid mvalues mode frameNode prevEnv mparent = + -- Figure out the positions for a function call with the+ -- given function and (possibly) values as arguments+ let headerText = functoidHeader functoid+ vars = functoidArgNames functoid+ footerText = buildFooterText vars mvalues+ env = case mvalues of+ Nothing ->+ -- dummy extension to be popped off+ extendEnv [] [] prevEnv + Just values ->+ extendEnv vars values prevEnv+ -- body tlo+ layout0 = flayout style functoid env mvalues+ -- header and footer layouts+ headerTB0 = makeTextBox style headerText -- at 0 0+ footerTB0 = makeTextBox style footerText -- at 0 0++ -- make all three the same width+ Size lw lh = flayoutSize layout0+ fwidth = maximum [tbWidth headerTB0, lw, tbWidth footerTB0]+ -- The __widen functions ensure that each part + -- (header, footer, tree tlo) have the desired width.+ headerTB1 = translate x y (widen headerTB0 fwidth)+ (dx, dy) = (x - hpad style, tbBottom headerTB1 - vpad style)+ layout1 = translate dx dy (flayoutWiden layout0 fwidth)+ footerTB1 = translate x (flayoutBottom layout1) + (widen footerTB0 fwidth)+ frameBox = BBox x y fwidth + (tbHeight headerTB0 + lh + tbHeight footerTB0)+ frame = CanvFrame {cfHeader = headerTB1,+ cfFooter = footerTB1,+ cfVarNames = vars,+ cfParent = mparent,+ cfFrameNode = frameNode,+ cfEnv = env, + cfBox = frameBox,+ cfLevel = z,+ cfFunctoid = functoid,+ frameType = mode}+ in (frame, layout1)++++buildFooterText :: [String] -> Maybe [Value] -> String+buildFooterText vars mvalues = + let items =+ case mvalues of+ Nothing -> vars+ Just [] -> vars+ Just values ->+ if length vars /= length values+ then error "buildFooterText: mismatched lists"+ else [var ++ " = " ++ repr value |+ (var, value) <- zip vars values]+ in concat (intersperse ", " items)
+ Sifflet/UI/GtkForeign.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE ForeignFunctionInterface, CPP #-}++-- | Provides a function to set the cursor to a specified shape.+-- Generalized from an example in email+-- Re: [Gtk2hs-users] Changing the mouse cursor shape+-- From: Chris Mears <chris@cm...> - 2007-05-22 07:48+-- found on+-- https://sourceforge.net/mailarchive/forum.php?thread_name=87ps50ie9o.fsf%40loki.cmears.id.au&forum_name=gtk2hs-users+-- and modified by removing the definition of data Cursor+-- since that is now part of gtk2hs/gtk+-- although the enum values are not :-(++-- The CursorType type itself is now exported from+-- Graphics.UI.Gtk.Gdk.Cursor, as also cursorNew+-- and cursorNewFromPixmap.++module Sifflet.UI.GtkForeign (setCursor)+where++import System.Glib+import System.Glib.FFI+import Foreign.ForeignPtr ()++import Graphics.UI.Gtk++foreign import ccall "gdk_window_set_cursor" gdkWindowSetCursor :: + Ptr DrawWindow -> Ptr Cursor -> IO ()++foreign import ccall "gdk_cursor_new" gdkCursorNew :: Int -> IO (Ptr Cursor)++-- | Set the X Window cursor for a window to a specified type+setCursor :: Window -> CursorType -> IO ()+setCursor window cursorType = do+ c <- gdkCursorNew (cursorTypeNumber cursorType)+ d <- widgetGetDrawWindow window+ let GObject fp = toGObject d+ withForeignPtr (castForeignPtr fp) $ \ptr -> gdkWindowSetCursor ptr c++-- These numbers are from /usr/include/gtk-2.0/gdk/gdkcursor.h++cursorTypeNumber :: CursorType -> Int+cursorTypeNumber cursorType =+ case cursorType of+ XCursor -> 0+ Arrow -> 2+ BasedArrowDown -> 4+ BasedArrowUp -> 6+ Boat -> 8+ Bogosity -> 10+ BottomLeftCorner -> 12+ BottomRightCorner -> 14+ BottomSide -> 16+ BottomTee -> 18+ BoxSpiral -> 20+ CenterPtr -> 22+ Circle -> 24+ Clock -> 26+ CoffeeMug -> 28+ Cross -> 30+ CrossReverse -> 32+ Crosshair -> 34+ DiamondCross -> 36+ Dot -> 38+ Dotbox -> 40+ DoubleArrow -> 42+ DraftLarge -> 44+ DraftSmall -> 46+ DrapedBox -> 48+ Exchange -> 50+ Fleur -> 52+ Gobbler -> 54+ Gumby -> 56+ Hand1 -> 58+ Hand2 -> 60+ Heart -> 62+ Icon -> 64+ IronCross -> 66+ LeftPtr -> 68+ LeftSide -> 70+ LeftTee -> 72+ Leftbutton -> 74+ LlAngle -> 76+ LrAngle -> 78+ Man -> 80+ Middlebutton -> 82+ Mouse -> 84+ Pencil -> 86+ Pirate -> 88+ Plus -> 90+ QuestionArrow -> 92+ RightPtr -> 94+ RightSide -> 96+ RightTee -> 98+ Rightbutton -> 100+ RtlLogo -> 102+ Sailboat -> 104+ SbDownArrow -> 106+ SbHDoubleArrow -> 108+ SbLeftArrow -> 110+ SbRightArrow -> 112+ SbUpArrow -> 114+ SbVDoubleArrow -> 116+ Shuttle -> 118+ Sizing -> 120+ Spider -> 122+ Spraycan -> 124+ Star -> 126+ Target -> 128+ Tcross -> 130+ TopLeftArrow -> 132+ TopLeftCorner -> 134+ TopRightCorner -> 136+ TopSide -> 138+ TopTee -> 140+ Trek -> 142+ UlAngle -> 144+ Umbrella -> 146+ UrAngle -> 148+ Watch -> 150+ Xterm -> 152+ LastCursor -> 153+ BlankCursor -> (-2)+ CursorIsPixmap -> (-1)
+ Sifflet/UI/GtkUtil.hs view
@@ -0,0 +1,224 @@+{-# LANGUAGE CPP #-}++module Sifflet.UI.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 Sifflet.UI.LittleGtk+import Sifflet.Util++-- SCIM Bridge causes problems, so shush it++suppressScimBridge :: IO ()+suppressScimBridge = +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) + return ()+#else+ putEnv "GTK_IM_MODULE=gtk-im-context-simple"+#endif++-- ============================================================+-- CUSTOMIZABLE DIALOGS++-- | Show a message and a set of choices;+-- run the action corresponding to the selected choice;+-- 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+ 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
+ Sifflet/UI/LittleGtk.hs view
@@ -0,0 +1,178 @@+-- | 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 Sifflet.UI.LittleGtk+ (+ -- These are just directly re-exported from Gtk:++ -- Attributes+ AttrOp(..) -- for (:=)+ , get+ , set++ , adjustmentNew++ , boxPackEnd+ , boxPackStart+ , boxPackStartDefaults++ , Button+ , buttonNewWithLabel+ , buttonPressEvent++ , ButtonsType(..)++ , ContainerClass+ , castToContainer+ , containerAdd+ , containerChild+ , containerForeach++ , CursorType(..)+ , customStoreSetColumn++ -- Dialog+ , Dialog+ , dialogNew+ , dialogAddButton+ , dialogGetActionArea+ , dialogGetUpper + , dialogRun+ , dialogSetDefaultResponse+ , toDialog++ , DrawWindow+ , drawWindowInvalidateRect++ , entryCompletionInsertPrefix+ , entryCompletionModel+ , entryCompletionNew+ , entryCompletionSetTextColumn++ , Entry+ , entryGetText+ , entryGetCompletion+ , entryNew+ , entrySetCompletion+ , entrySetText++ , EventMask(..)++ , eventBoxNew++ , Expander+ , expanderNew+ , expanderSetExpanded++ , exposeEvent++ , fileChooserDialogNew+ , fileChooserGetFilename++ , FileChooserAction(..)++ , frameNew++ , grabAdd+ , grabRemove++ , HBox+ , hBoxNew++ , keyPressEvent++ , Label+ , labelNew+ , labelSetText++ , Layout+ , layoutGetDrawWindow+ , layoutNew+ , layoutPut+ , layoutSetSize++ , listStoreNew++ , makeColumnIdString++ , menuPopup++ , MessageType(..)+ , messageDialogNew++ , on+ , onDestroy+ , onSizeRequest++ , Packing(..)++ , PolicyType(PolicyAutomatic)++ , Rectangle(..)++ , renderWithDrawable++ , Requisition(..)++ , ResponseId(..)++ , ScrolledWindow+ , scrolledWindowNew+ , scrolledWindowSetPolicy++ , Statusbar+ , statusbarGetContextId+ , statusbarNew+ , statusbarPop+ , statusbarPush++ , VBox+ , vBoxNew++ , WidgetClass++ , widgetAddEvents+ , widgetClassPath+ , widgetDestroy+ , widgetGrabFocus+ , widgetSetCanFocus+ , widgetSetDoubleBuffered+ , widgetSetName+ , widgetSetSizeRequest+ , widgetShow+ , widgetShowAll+ , widgetSizeRequest+ , widgetVisible++ , Window+ , windowMove+ , windowNew+ , windowPresent+ , windowSetDefaultSize+ , windowSetPosition+ , windowSetTitle+ , windowTitle++ , WindowPosition(..)+ -- General GTK stuff+ , initGUI+ , mainGUI+ , mainQuit++ -- These are renamed:+ , GtkFrame+ , GtkLayout+ )++where++import Graphics.UI.Gtk++type GtkFrame = Frame+type GtkLayout = Layout
+ Sifflet/UI/RPanel.hs view
@@ -0,0 +1,154 @@+-- | "Rowed Panel." +-- Expandable framed panel with a two-dimensional layout+-- (rows of widgets, but not with aligned columns like in a table).++module Sifflet.UI.RPanel+ (+ RPanel, newRPanel, rpanelId, rpanelRoot, rpanelContent+ , rpanelAddWidget, rpanelAddWidgets, rpanelNewRow+ , rpanelAddRows+ )++where++import Control.Monad++import Sifflet.UI.LittleGtk+import Sifflet.Util++debugTracing :: Bool+debugTracing = False++data RPanel + = RPanel {+ -- Public+ rpId :: String -- ^ text for the expander button+ , rpRoot :: GtkFrame -- ^ use the root to add rpanel to a container+ , rpContent :: [[String]] -- ^ ids of widgets added, in rows++ -- Widgets that make up the RPanel+ , rpFrame :: GtkFrame -- ^ frame, same as root+ , rpExpander :: Expander -- ^ expander+ , rpVBox :: VBox -- ^ vbox to contain the rows+ , rpCurrentRow :: HBox -- ^ next element goes here if it fits++ -- Geometry book-keeping+ , rpCurrentRowFreeWidth :: Int -- ^ free width in current row+ , rpMaxWidth :: Int -- ^ maximum row width+ , rpHPad :: Int -- ^ horizontal padding+ }++rpanelId :: RPanel -> String+rpanelId = rpId++rpanelRoot :: RPanel -> GtkFrame+rpanelRoot = rpRoot++rpanelContent :: RPanel -> [[String]]+rpanelContent = rpContent++newRPanel :: String -> Int -> Int -> Int -> IO RPanel+newRPanel cid hpad vpad maxWidth = do+ {+ frame <- frameNew -- adds a border (not labeled, since the expander is)+ + ; expander <- expanderNew cid+ ; expanderSetExpanded expander True+ ; set frame [containerChild := expander]++ ; vbox <- vBoxNew False vpad -- non-homogeneous heights+ ; widgetSetSizeRequest vbox maxWidth (-1) -- height = don't care+ ; set expander [containerChild := vbox]++ ; hbox <- hBoxNew False hpad -- non-homogeoneous widths+ ; boxPackStart vbox hbox PackNatural 0++ ; return $ RPanel {rpId = cid+ , rpRoot = frame+ , rpFrame = frame+ , rpExpander = expander+ , rpVBox = vbox+ , rpCurrentRow = hbox+ , rpContent = [[]]+ , rpCurrentRowFreeWidth = maxWidth - hpad+ , rpMaxWidth = maxWidth - hpad+ , rpHPad = hpad+ }+ }++-- | Given a list of (name, widget) pairs, add each of the widgets+-- and its name to the rpanel+rpanelAddWidgets :: (WidgetClass widget) =>+ RPanel -> [(String, widget)] -> IO RPanel+rpanelAddWidgets rp pairs = + let addPair rp' (widgetId, widget) = rpanelAddWidget rp' widgetId widget+ in foldM addPair rp pairs++-- | Add a single named widget to the RPanel+rpanelAddWidget :: (WidgetClass widget) =>+ RPanel -> String -> widget -> IO RPanel+rpanelAddWidget rp widgetId widget = do+ {+ Requisition widgetWidth _ <- widgetSizeRequest widget+ ; let freeWidth = rpCurrentRowFreeWidth rp+ freeWidth' = freeWidth - widgetWidth - rpHPad rp+ ; if freeWidth' >= 0 || freeWidth == rpMaxWidth rp+ -- Either there is room enough, OR we're at the start of a row+ -- so starting another won't help -- in fact it would lead to+ -- infinite recursion+ then do+ {+ let content' = insertLastLast (rpContent rp) widgetId+ packMode = -- PackNatural -- to left justify+ PackGrow -- to fill+ -- PackRepel -- to center++ ; boxPackStart (rpCurrentRow rp) widget packMode 0+ -- ; widgetShow widget -- do this here???+ ; when debugTracing $+ putStr (unlines ["Adding " ++ widgetId ++ + " width " ++ show widgetWidth+ , "Free width = " ++ show freeWidth +++ " -> " ++ show freeWidth'+ , "Content -> " ++ show content'])++ ; return $ rp {rpContent = content'+ , rpCurrentRowFreeWidth = freeWidth'}+ }+ else + -- We're out of room, but not at the start of the current row,+ -- so start a new row+ do+ {+ rp' <- rpanelNewRow rp+ ; rpanelAddWidget rp' widgetId widget+ }+ }++-- | Force the RPanel to begin a new row++rpanelNewRow :: RPanel -> IO RPanel+rpanelNewRow rp = do+ {+ hbox <- hBoxNew False (rpHPad rp)+ ; boxPackStart (rpVBox rp) hbox PackNatural 0+ ; return $ rp {rpCurrentRow = hbox+ , rpContent = insertLast (rpContent rp) []+ , rpCurrentRowFreeWidth = rpMaxWidth rp}+ }++-- | Given a list of lists, each sublist representing a row of widgets,+-- add the widgets to the RPanel, preserving the row structure+-- as much as possible.+-- (Row structure will be broken if any intended row is too wide.)+rpanelAddRows :: (WidgetClass widget) =>+ RPanel -> [[(String, widget)]] -> IO RPanel+rpanelAddRows rp rows = foldM rpanelAddRow rp rows++-- | Add a row of widgets to an RPanel.+-- This does not start a new row before the first widget,+-- but after the last, so at the end, the current row will be empty.+rpanelAddRow :: (WidgetClass widget) =>+ RPanel -> [(String, widget)] -> IO RPanel+rpanelAddRow rp row = + rpanelAddWidgets rp row >>= rpanelNewRow
+ Sifflet/UI/Tool.hs view
@@ -0,0 +1,549 @@+module Sifflet.UI.Tool+ (+ ToolId(..)+ , checkMods+ , functionTool+ , functionToolsFromLists+ , makeConnectTool+ , makeCopyTool+ , makeDeleteTool+ , makeDisconnectTool+ , makeFixedArgTool+ , makeIfTool+ , makeMoveTool+ , showFunctionEntry+ , showLiteralEntry+ , vpuiSetTool+ , vpuiWindowSetTool++ , vwAddFrame+ , vpuiAddFrame++ -- Statusbar+ , wsPopStatusbar, wsPushStatusbar++ -- frame context menu commands (do these belong elsewhere?)+ , dumpFrame+ , dumpGraph+ , dumpWorkWin+ , clearFrame+ , closeFrame+ )++where++import Control.Monad+import Control.Monad.Trans (liftIO)+import Data.IORef+import Data.List++import Data.Graph.Inductive as G++import Graphics.UI.Gtk.Gdk.EventM++import Sifflet.Data.Functoid+import Sifflet.Data.Geometry+import Sifflet.Data.Tree (putTree, repr)+import Sifflet.Data.TreeGraph (graphToOrderedTreeFrom)+import Sifflet.Data.WGraph+import Sifflet.Language.Expr+import Sifflet.UI.Callback+import Sifflet.UI.Canvas+import Sifflet.UI.Frame+import Sifflet.UI.LittleGtk +import Sifflet.UI.Types+import Sifflet.Util++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
+ Sifflet/UI/Types.hs view
@@ -0,0 +1,308 @@+module Sifflet.UI.Types + (VPUI(..)+ , WinId, VPUIWindow(..)+ , vpuiFileChanged+ , vpuiUserEnvAList++ -- | Operations on a VPUI involving its window+ , vpuiInsertWindow+ , vpuiTryGetWindow+ , vpuiGetWindow+ , vpuiUpdateWindow+ , vpuiReplaceWindow+ , vpuiUpdateWindowIO+ , vpuiRemoveVPUIWindow++ -- | Operations on a window involving its canvas+ , vpuiWindowLookupCanvas, vpuiWindowGetCanvas+ , vpuiWindowSetCanvas, vpuiWindowModCanvas + , vpuiWindowModCanvasIO++ -- | Operation on a VPUI involving the canvas of its window+ , vpuiModCanvas, vpuiModCanvasIO+ + -- | Other operations on a window+ , vpuiWindowWindow++ , VPToolkit(..)++ , Toolbox(..)+ , Tool(..)+ , ToolContext(..)++ , CanvasToolOp+ , ToolOp+ , toToolOpVW ++ , Workspace(..)+ , FunctionEditor(..)+ , fedFunctionName+ , VCanvas(..)+ , Selection(..)+ , Dragging(..)+ )++where++import Data.Map as Map +import Data.Graph.Inductive as G++import Graphics.UI.Gtk.Gdk.EventM (Modifier(..))++import Sifflet.Data.Geometry+import Sifflet.Data.TreeLayout+import Sifflet.Data.WGraph+import Sifflet.Language.Expr++import Sifflet.UI.Frame+import Sifflet.UI.LittleGtk+import Sifflet.UI.RPanel+import Sifflet.Util+++-- | VPUI: Sifflet (formerly VisiProg) User Interface+-- The initialEnv is apt to contain "builtin" functions;+-- it's preserved here so that when writing to a file,+-- we can skip the functions that were in the initial env.+data VPUI = VPUI {+ vpuiWindows :: Map WinId VPUIWindow, -- ^ all the windows of the program+ vpuiToolkits :: [(String, VPToolkit)], -- ^ ordered association list,+ -- collections of tools+ 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+-- But you probably want to use Sifflet.UI.Window.UserFunctions+-- instead of this.+vpuiUserEnvAList :: VPUI -> [(String, Value)]+vpuiUserEnvAList vpui =+ let env' = vpuiGlobalEnv vpui -- I hope+ env = vpuiInitialEnv vpui+ in if length env == 1 && length env' == 1+ then assocs (Map.difference (head env') (head env))+ else errcats ["vpuiUserEnv: env lengths are not one",+ "|env'|:", show (length env'),+ "|env|:", show (length env)]++-- | Insert a window in the window map+vpuiInsertWindow :: VPUI -> WinId -> VPUIWindow -> VPUI+vpuiInsertWindow vpui winId vw =+ vpui {vpuiWindows = Map.insert winId vw (vpuiWindows vpui)}++-- | Try to get the VPUIWindow with the given window ID,+-- return Just result or Nothing+vpuiTryGetWindow :: VPUI -> WinId -> Maybe VPUIWindow+vpuiTryGetWindow vpui winId = Map.lookup winId (vpuiWindows vpui)++-- | Get the VPUIWindow with the given window ID;+-- it is an error if this fails.+vpuiGetWindow :: VPUI -> WinId -> VPUIWindow+vpuiGetWindow vpui winId = vpuiWindows vpui ! winId++-- | Replace a VPUIWindow with given window ID;+-- it is an error if this fails.+vpuiReplaceWindow :: VPUI -> WinId -> VPUIWindow -> VPUI+vpuiReplaceWindow vpui winId vpuiWin =+ let winMap = vpuiWindows vpui+ winMap' = insert winId vpuiWin winMap+ in vpui {vpuiWindows = winMap'}++-- | Apply an update function to a VPUIWindow with given window ID;+-- it is an error if this fails.+vpuiUpdateWindow :: VPUI -> WinId -> (VPUIWindow -> VPUIWindow) -> VPUI+vpuiUpdateWindow vpui winId updater =+ let winMap = vpuiWindows vpui+ winMap' = adjust updater winId winMap+ in vpui {vpuiWindows = winMap'}++-- | Apply an update IO action to a VPUIWindow with given window ID;+-- it is an error if this fails.+vpuiUpdateWindowIO :: WinId -> (VPUIWindow -> IO VPUIWindow) -> VPUI -> IO VPUI+vpuiUpdateWindowIO winId updater vpui = do+ {+ let winMap = vpuiWindows vpui+ vw = winMap ! winId+ ; vw' <- updater vw+ ; let winMap' = insert winId vw' winMap+ ; return $ vpui {vpuiWindows = winMap'}+ }++-- | Remove a window from the windows map; it has already been destroyed+-- in the GUI+vpuiRemoveVPUIWindow :: WinId -> VPUI -> VPUI+vpuiRemoveVPUIWindow winId vpui =+ let winMap = vpuiWindows vpui+ winMap' = delete winId winMap+ in vpui {vpuiWindows = winMap'}++data VPUIWindow = -- VPUIJustWindow Window + VPUIWorkWin Workspace Window+ | FunctionPadWindow Window [(String, RPanel)]+++vpuiWindowWindow :: VPUIWindow -> Window+vpuiWindowWindow vw =+ case vw of+ VPUIWorkWin _ w -> w+ FunctionPadWindow w _ -> w++-- | Try to find canvas; fail gracefully+vpuiWindowLookupCanvas :: VPUIWindow -> Maybe VCanvas+vpuiWindowLookupCanvas vw =+ case vw of+ VPUIWorkWin ws _ -> Just (wsCanvas ws)+ _ -> Nothing++-- | Find canvas or fail dramatically+vpuiWindowGetCanvas :: VPUIWindow -> VCanvas+vpuiWindowGetCanvas vw =+ case vpuiWindowLookupCanvas vw of+ Nothing -> error "vpuiWindowGetCanvas: no canvas found"+ Just canvas -> canvas++vpuiWindowSetCanvas :: VPUIWindow -> VCanvas -> VPUIWindow+vpuiWindowSetCanvas vw canvas =+ case vw of+ VPUIWorkWin ws w -> VPUIWorkWin (ws {wsCanvas = canvas}) w+ _ -> error "vpuiWindowSetCanvas: not a workspace window"++vpuiWindowModCanvas :: VPUIWindow -> (VCanvas -> VCanvas) -> VPUIWindow+vpuiWindowModCanvas vw f =+ case vpuiWindowLookupCanvas vw of+ Nothing -> error "vpuiWindowModCanvas: plain VPUIWindow"+ Just canvas -> vpuiWindowSetCanvas vw (f canvas)++vpuiWindowModCanvasIO :: VPUIWindow -> (VCanvas -> IO VCanvas) -> IO VPUIWindow+vpuiWindowModCanvasIO vw f =+ case vpuiWindowLookupCanvas vw of+ Nothing -> error "vpuiWindowModCanvas: plain VPUIWindow"+ Just canvas -> + do+ { + canvas' <- f canvas+ ; return $ vpuiWindowSetCanvas vw canvas'+ }++-- | Update the canvas of the specified window, without IO+vpuiModCanvas :: VPUI -> WinId -> (VCanvas -> VCanvas) -> VPUI+vpuiModCanvas vpui winId modCanvas = + let modWindow vw = vpuiWindowModCanvas vw modCanvas+ in vpuiUpdateWindow vpui winId modWindow++-- | Update the canvas of the specified window, with IO+vpuiModCanvasIO :: VPUI -> WinId -> (VCanvas -> IO VCanvas) -> IO VPUI+vpuiModCanvasIO vpui winId modCanvas = + let modWindow vw = vpuiWindowModCanvasIO vw modCanvas+ in vpuiUpdateWindowIO winId modWindow vpui++type WinId = String++data Workspace = Workspace {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)+
+ Sifflet/UI/Window.hs view
@@ -0,0 +1,1147 @@+module Sifflet.UI.Window+ (+ -- 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 as List+import Data.Map as Map (fromList, lookup)+import Data.Map (Map)++import Data.Graph.Inductive as G++import Graphics.UI.Gtk.Gdk.EventM++import Sifflet.Data.Functoid+import Sifflet.Data.Geometry+import Sifflet.Data.WGraph++import Sifflet.Foreign.Exporter+import Sifflet.Foreign.ToHaskell (defaultHaskellOptions, exportHaskell)+import Sifflet.Foreign.ToPython (defaultPythonOptions, exportPython)+import Sifflet.Foreign.ToScheme (SchemeOptions(..), exportScheme)++import Sifflet.Language.Expr+import Sifflet.Language.SiffML++import Sifflet.UI.Frame+import Sifflet.UI.Canvas+import Sifflet.UI.Types+import Sifflet.UI.Callback+import Sifflet.UI.Tool+import Sifflet.UI.Workspace+import Sifflet.UI.GtkForeign+import Sifflet.UI.GtkUtil+import Sifflet.UI.LittleGtk+import Sifflet.UI.RPanel++import Sifflet.Util++-- ---------------------------------------------------------------------+-- | 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 "Export to Haskell ..." + menuFileExportHaskell+ , MenuItem "Export to Python3 ..." menuFileExportPython+ , MenuItem "Export to Scheme ..." menuFileExportScheme+ , 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 vpui) 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 -> VPUI -> String -> IO RPanel+makeFunctionPadPanel cbmgr vpui name =+ let VPToolkit _ width toolrows = + case List.lookup name (vpuiToolkits vpui) of+ Nothing ->+ errcats ["makeFunctionPadPanel:",+ "can't find toolkit definition:", name]+ Just atoolkit -> atoolkit+ in do+ {+ buttonRows <- makeToolButtonRows cbmgr toolrows+ :: IO [[(String, Button)]]+ ; rp <- newRPanel name 3 3 width+ ; rpanelAddRows rp buttonRows+ }++makeToolButtonRows :: CBMgr -> [[Tool]] -> IO [[(String, Button)]]+makeToolButtonRows cbmgr toolRows = + mapM2 (makeNamedToolButton cbmgr) toolRows++makeNamedToolButton :: CBMgr -> Tool -> IO (String, Button)+makeNamedToolButton cbmgr tool = do+ {+ button <- makeToolButton cbmgr tool+ ; return (toolName tool, button)+ }++makeToolButton :: CBMgr -> Tool -> IO Button+makeToolButton cbmgr tool = do+ {+ button <- buttonNewWithLabel (toolName tool)+ ; cbmgr (AfterButtonClicked button+ ((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 <- consumeSiffMLFile xmlToFunctions filePath+ ; case functions of+ [Functions fs] ->+ let vpui' = foldl bindFunction vpui fs+ in return (Succ (vpui', fs))+ _ ->+ return (Fail "file format error")++ }++bindFunction :: VPUI -> Function -> VPUI+bindFunction vpui function =+ let env = vpuiGlobalEnv vpui+ Function (Just name) _argTypes _resType _impl = function+ env' = envIns env name (VFun function)+ in vpui {vpuiGlobalEnv = env'}++-- | Implements File menu "Save" command.++menuFileSave :: VPUI -> IO VPUI+menuFileSave vpui = + case vpuiFilePath vpui of+ Nothing -> menuFileSaveAs vpui+ Just filePath -> saveFile vpui filePath++-- | Implements File menu "Save as" command.+menuFileSaveAs :: VPUI -> IO VPUI+menuFileSaveAs vpui = do+ {+ mFilePath <- chooseOutputFile "Save" vpui+ ; case mFilePath of+ Nothing -> return vpui+ Just filePath -> saveFile vpui filePath+ }++-- | Unconditionally save user functions in SiffML file.+-- Called from menuFileSave and menuFileSaveAs.+-- Updates vpuiFilePath and vpuiFileEnv.+saveFile :: VPUI -> FilePath -> IO VPUI+saveFile vpui filePath =+ produceSiffMLFile (userFunctions vpui) filePath >>+ return vpui {vpuiFilePath = Just filePath, + vpuiFileEnv = vpuiGlobalEnv vpui}++-- | The user-defined functions of the environment+userFunctions :: VPUI -> Functions+userFunctions vpui = + Functions (map (valueFunction . snd) + (vpuiUserEnvAList vpui))++-- | Export user functions to a file,+-- given an exporter and a path,+-- returning the vpui unchanged.+maybeExportUserFunctions :: VPUI -> (opts -> Exporter) + -> Maybe (FilePath, opts) -> IO VPUI+maybeExportUserFunctions vpui export mpathOptions =+ case mpathOptions of+ Nothing -> return vpui + Just (path, options) -> + export options (userFunctions vpui) path >> return vpui++-- | Export user functions to Haskell file+menuFileExportHaskell :: VPUI -> IO VPUI+menuFileExportHaskell vpui =+ chooseOutputFile "Export Haskell" vpui >>=+ maybeDefaultOptions defaultHaskellOptions >>=+ maybeExportUserFunctions vpui exportHaskell++-- | Export user functions to Python file+menuFileExportPython :: VPUI -> IO VPUI+menuFileExportPython vpui =+ chooseOutputFile "Export Python" vpui >>=+ maybeDefaultOptions defaultPythonOptions >>=+ maybeExportUserFunctions vpui exportPython++-- | Export user functions to Scheme file+menuFileExportScheme :: VPUI -> IO VPUI+menuFileExportScheme vpui =+ chooseOutputFile "Export Scheme" vpui >>= + maybeRunSchemeOptionsDialog >>=+ -- maybeExportUserFunctions vpui (exportScheme defaultSchemeOptions) + maybeExportUserFunctions vpui exportScheme++-- | Choose an output file, for file save, save as, and export commands+chooseOutputFile :: String -> VPUI -> IO (Maybe FilePath)+chooseOutputFile verb _vpui = do+ chooser <- fileChooserDialogNew+ (Just (verb ++ " to file ...")) -- title+ Nothing -- transient parent of the dialog+ FileChooserActionSave+ [(verb, ResponseOk), ("Cancel", ResponseCancel)] -- buttons+ result <- runDialogM (toDialog chooser) chooser fileChooserGetFilename+ return result++maybeDefaultOptions :: a -> Maybe FilePath -> IO (Maybe (FilePath, a))+maybeDefaultOptions defaultOptions mpath =+ case mpath of+ Nothing -> return Nothing+ Just path -> return $ Just (path, defaultOptions)++maybeRunSchemeOptionsDialog :: Maybe FilePath + -> IO (Maybe (FilePath, SchemeOptions))+maybeRunSchemeOptionsDialog mpath =+ case mpath of+ Nothing -> return Nothing+ Just path ->+ let result :: Bool -> IO (Maybe (FilePath, SchemeOptions))+ result useLambda =+ return (Just (path, + SchemeOptions {defineWithLambda = useLambda}))+ in showChoicesDialog "Scheme Export Options"+ "Use lambda in function definitions?"+ ["Yes", "No"]+ [result True, result False]++-- | 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 = "1.0"++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 Fleur >> + (return $ vpuiWindowSetCanvas vw canvas')++-- | Handle mouse move event+handleMouseMove :: WinId -> Double -> Double -> [Modifier] -> VPUI -> IO VPUI+handleMouseMove winId x y mods vpui =+-- Needs to be in IO because of drawWindowInvalidateRect+ let vw = vpuiGetWindow vpui winId+ in case vpuiWindowLookupCanvas vw of+ Nothing -> + info "SQUAWK! No canvas! Shouldn't happen!" >>+ return vpui -- shouldn't happen+ Just canvas -> + do+ {+ -- Highlight the active node, if any+ let active = vcActive canvas+ active' = vcanvasNodeAt canvas (Position x y)++ invalidate :: DrawWindow -> Maybe G.Node -> IO ()+ invalidate win mnode =+ case mnode of+ Nothing -> return ()+ Just node -> + drawWindowInvalidateRect win + (vcanvasNodeRect canvas node) False++ ; when (active /= active') $+ do+ {+ win <- layoutGetDrawWindow (vcLayout canvas)+ ; invalidate win active+ ; invalidate win active'+ }+ -- if dragging, continue drag+ ; canvas' <- continueDrag (canvas {vcActive = active', + vcMousePos = (x, y)}) + mods x y+ ; let vw' = vpuiWindowSetCanvas vw canvas'+ ; return $ vpuiReplaceWindow vpui winId vw'+ }++continueDrag :: VCanvas -> [Modifier] -> Double -> Double -> IO VCanvas+continueDrag canvas mods x y =+ case vcDragging canvas of+ Nothing -> return canvas+ Just dragging -> + let graph = vcGraph canvas+ dnode = draggingNode dragging+ wnode = wlab graph dnode+ Position oldX oldY = draggingPosition dragging+ (dx, dy) = (x - oldX, y - oldY)+ in+ case wnode of+ WSimple _ -> + continueDragSimple canvas dragging dnode mods x y dx dy + WFrame frameNode -> + continueDragFrame canvas dragging frameNode x y dx dy ++continueDragSimple :: VCanvas -> Dragging -> G.Node -> [Modifier] + -> Double -> Double -> Double -> Double -> IO VCanvas+continueDragSimple canvas dragging simpleNode mods x y dx dy =+ let graph = vcGraph canvas+ frame = nodeContainerFrame canvas graph simpleNode+ dragging' = dragging {draggingPosition = Position x y}+ translateSelection = if checkMods [Shift] mods+ then translateTree+ else translateNode+ graph' = translateSelection dx dy graph simpleNode+ canvas' = canvas {vcGraph = graph'}+ in vcInvalidateFrameWithParent canvas graph frame >>+ return (canvas' {vcDragging = Just dragging'})++continueDragFrame :: + VCanvas -> Dragging -> G.Node -> + Double -> Double -> Double -> Double -> IO VCanvas+continueDragFrame canvas dragging frameNode x y dx dy =+ let graph = vcGraph canvas+ frame = vcGetFrame canvas graph frameNode+ frame' = translateFrame frame dx dy+ graph' = grTranslateFrameNodes graph frame dx dy+ canvas' = vcUpdateFrameAndGraph canvas frame' graph'+ dragging' = Just dragging {draggingPosition = Position x y}+ in + -- Tell the GUI about the changes so they will be redrawn+ -- Mark the frame changed so it will be redrawn+ frameChanged canvas graph frame graph' frame' >>+ -- Also, any frames opened from nodes of this frame+ mapM_ (\f -> frameChanged canvas graph f graph' f)+ (vcFrameSubframes canvas frame) >>+ -- Return the modified canvas+ return (canvas' {vcDragging = dragging'})++handleButtonRelease :: WinId -> MouseButton -> VPUI -> IO VPUI+handleButtonRelease winId mouseButton vpui =+ case mouseButton of+ LeftButton -> + -- End drag+ let vw = vpuiGetWindow vpui winId+ canvas = vpuiWindowGetCanvas vw+ window = vpuiWindowWindow vw+ vw' = vpuiWindowSetCanvas vw (canvas {vcDragging = Nothing})+ vpui' = vpuiReplaceWindow vpui winId vw'+ in setCursor window LeftPtr >>+ return vpui'+ _ -> return vpui++-- | Show a context menu for mouse click in a frame.+offerContextMenu :: WinId -> CBMgr -> CanvFrame + -> MouseButton -> TimeStamp -> 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)+ ]
+ Sifflet/UI/Workspace.hs view
@@ -0,0 +1,402 @@+{- 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 Sifflet.UI.Workspace+ (+ -- VPUI and Workspace+ vpuiNew+ , workspaceNewDefault+ , workspaceNewEditing+ , addArgToolButtons+ , addApplyCloseButtons+ , defineFunction+ , openNode++ -- Quitting:+ , removeWindow+ , vpuiQuit++ -- Windows:+ , forallWindowsIO++ , baseFunctionsRows+ )++where++import Control.Monad++import Data.Map ((!), keys)+import qualified Data.Map as Map (empty)++import Data.Graph.Inductive as G++import Sifflet.Data.Functoid+import Sifflet.Data.Geometry+import Sifflet.Data.TreeLayout+import Sifflet.Language.Expr+import Sifflet.UI.GtkUtil+import Sifflet.UI.LittleGtk+import Sifflet.Util++import Sifflet.UI.Callback+import Sifflet.Data.TreeGraph+import Sifflet.UI.Types+import Sifflet.UI.Canvas+import Sifflet.UI.Frame+import Sifflet.UI.Tool+import Sifflet.Data.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 = [],+ vpuiFilePath = Nothing,+ vpuiStyle = style,+ vpuiInitialEnv = env,+ vpuiGlobalEnv = env,+ vpuiFileEnv = env+ }++++-- | 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++baseFunctionsRows :: [[String]]+baseFunctionsRows = [["+", "-", "*", "div", "mod", "add1", "sub1", "/"],+ ["==", "/=", "<", ">", "<=", ">="],+ ["zero?", "positive?", "negative?"],+ ["null", "head", "tail", ":"]]
+ Sifflet/Util.hs view
@@ -0,0 +1,135 @@+module Sifflet.Util (+ -- | Parser Utilities+ SuccFail(Succ, Fail)+ , parsef, parseInt, parseDouble, parseVerbatim+ -- | String Utilities+ , par+ -- Output Utilities+ , putCatsLn+ , putCatLn+ , info+ , fake+ , stub++ -- | Error Reporting+ , errcat+ , errcats++ -- | List Utilities+ , map2, mapM2+ , adjustAList, adjustAListM+ , insertLastLast, insertLast+ )++where++import Control.Monad()++-- SuccFail: the result of an attempt, succeeds or fails+data SuccFail a = Succ a -- value+ | Fail String -- error message+ deriving (Eq, Read, Show)++instance Monad SuccFail where+ Succ val >>= f = f val+ Fail err >>= _f = Fail err+ return = Succ+ fail = Fail++-- PARSER UTILITIES++parsef :: (Read a) => String -> String -> String -> SuccFail a+parsef typeName inputLabel input =+ case reads input of+ [(value, "")] -> Succ value+ [(_, more)] -> + Fail $ inputLabel ++ ": extra characters after " ++ + typeName ++ ": " ++ more+ _ -> Fail $ inputLabel ++ ": cannot parse as " ++ + typeName ++ ": " ++ input++parseInt :: String -> String -> SuccFail Int+parseInt = parsef "integer"++parseDouble :: String -> String -> SuccFail Double+parseDouble = parsef "real number"++parseVerbatim :: String -> String -> SuccFail String+parseVerbatim _label = Succ++-- | Enclose in parentheses, like a Lisp function call.+-- Example: par "foo" ["x", "y"] = "(foo x y)"++par :: String -> [String] -> String+par f xs = "(" ++ unwords (f:xs) ++ ")"++-- | Write a list of words, separated by spaces+putCatsLn :: [String] -> IO ()+putCatsLn = putStrLn . unwords++-- | Write a list of words, not separated by spaces+putCatLn :: [String] -> IO ()+putCatLn = putStrLn . concat++info :: (Show t) => t -> IO ()+info = print++fake :: String -> IO ()+fake what = putStrLn $ "Faking " ++ what ++ "..."++stub :: String -> IO ()+stub name = putStrLn $ "Stub for " ++ name++-- ERROR REPORTING++-- | Signal an error using a list of strings to be concatenated+errcat :: [String] -> a+errcat = error . concat++-- | Signal an error using a list of strings to be concatenated+-- with spaces between (unwords).+errcats :: [String] -> a+errcats = error . unwords++-- LIST UTILITIES++-- | Generalization of map to lists of lists+map2 :: (a -> b) -> [[a]] -> [[b]]+map2 f rows = -- map (\ row -> map f row) rows+ map (map f) rows++-- | Generalization of mapM to lists of lists+mapM2 :: (Monad m) => (a -> m b) -> [[a]] -> m [[b]]+mapM2 f rows = -- mapM (\ row -> mapM f row) rows+ mapM (mapM f) rows++-- | Insert an item into a list of lists of items,+-- making it the last element in the last sublist+insertLastLast :: [[a]] -> a -> [[a]]+insertLastLast xss x = init xss ++ [insertLast (last xss) x]++-- | Insert an item in a list of items, making it the last element+insertLast :: [a] -> a -> [a]+insertLast xs x = xs ++ [x]++-- | Update a value at a given key by applying a function.+-- Similar to Data.Map.adjust.++-- This implementation, using map, could be inefficient+-- if the key to be updated is near the front of a long list.+adjustAList :: (Eq k) => k -> (v -> v) -> [(k, v)] -> [(k, v)]+adjustAList key f alist =+ map (\ (k, v) -> if k == key then (k, f v) else (k, v)) + alist++-- | Monadic generalization of adjustAList ++-- Same caution re. inefficiency+adjustAListM :: (Eq k, Monad m) => + k -> (v -> m v) -> [(k, v)] -> m [(k, v)]+adjustAListM key f alist =+ mapM (\ (k, v) -> + if k == key + then do { v' <- f v; return (k, v') }+ else return (k, v))+ alist
+ data/sifflet.py view
@@ -0,0 +1,107 @@+# File: sifflet.py+# Python definitions for built-in Sifflet functions++# The variable "undefined" (sifflet.undefined) is reserved for Sifflet,+# representing an undefined variable.+# Identifiers containing any of the substrings _QUESTION_, _CHR0_,+# _CHR1_, ... _CHR255_ are reserved for Sifflet.+# For example: "zero_QUESTION_", "zero_CHR33_".++def add1 (n):+ return n + 1++def sub1 (n):+ return n - 1++def eqZero (n):+ return (n == 0)++def gtZero (n):+ return (n > 0)++def ltZero (n):+ return (n < 0)++def null (xs):+ return xs.null()++def head (xs):+ return xs.head()++def tail (xs):+ return xs.tail()++def cons (x, xs):+ return Cons(x, xs)++# The List data type+# These could use some methods to implement operations,+# like __eq__ and __repr__+ +# List delimiters++ListBegin = "li("+ListEnd = ")"++class List:++ pass++class Null (List):++ def __repr__ (self): return ListBegin + ListEnd++ def __repr2__ (self, _): return ListEnd++ def null(self): return True++ def head(self): error("head: empty list")++ def tail(self): error("tail: empty list")++class Cons (List):++ def __init__ (self, h, t):+ self.__head = h+ self.__tail = t++ def __repr__ (self):+ return self.__repr2__(ListBegin)++ def __repr2__ (self, prefix):+ return prefix + repr(self.__head) + self.__tail.__repr2__(", ")++ def null (self): return False++ def head (self): return self.__head++ def tail (self): return self.__tail++## Create a List (linked list) from any number of arguments,+## using the same notation as when Lists are converted to string reprs:+def li (*args): return al_to_ll(args)++# Convert between our List type and Python's built-in list type.+# Axioms:+# I. If alist is a Python list, then ll_to_al(al_to_ll(alist)) == alist+# II. If llist is a List, then al_to_ll(ll_to_al(llist)) == llist++## al_to_ll: convert Python list to our List type (linked list)+def al_to_ll (alist):+ node = Null()+ n = len(alist)+ for i in range(n - 1, -1, -1):+ node = cons(alist[i], node)+ return node+++## ll_to_al: convert our List type to Python list (array list)+def ll_to_al (llist):+ alist = []+ while not null(llist):+ alist.append(head(llist))+ llist = tail(llist)+ return alist++# Handy+empty = Null()
+ data/sifflet.scm view
@@ -0,0 +1,28 @@+;;; Sifflet function library for Scheme+;;;+;;; All symbols beginning with "sifflet-" or "*sifflet-" are+;;; reserved by Sifflet.+;;;+;;; The symbol *sifflet-undefined* is expected NOT to be defined!++;;; Adding and subtracting 1++(define (sifflet-add1 n) (+ n 1))++(define (sifflet-sub1 n) (- n 1))++;;; Scheme's quotient function is incompatible with Haskell div.+(define (sifflet-div x y) (floor (/ x y)))++;;; Scheme's / operation typically gives exact results:+;;; should this make any difference?+(define sifflet-/+ (if (exact? (/ 3 2))+ (lambda (x y) (exact->inexact (/ x y)))+ /))++;;; == and /= belong to the Eq class, which implies general+;;; equality, not limited to numbers.+(define (sifflet-not-equal? x y) (not (= x y)))++
+ sifflet-lib.cabal view
@@ -0,0 +1,96 @@+name: sifflet-lib+version: 1.0+cabal-version: >= 1.6+build-type: Simple+license: BSD3+license-file: LICENSE+copyright: (C) 2009-2010 Gregory D. Weber+author: Gregory D. Weber+maintainer: "gdweber" ++ drop 3 "abc@" ++ "iue.edu"+bug-reports: mailto:"gdweber" ++ drop 3 "abc@" ++ "iue.edu"+homepage: http://mypage.iu.edu/~gdweber/software/sifflet/+stability: Experimental; expect API, especially the location of+ modules in Haskell's hierarchical module system, to change radically+ and without notice.+synopsis: Library of modules shared by sifflet and its+ tests and its exporters.+description: Supporting modules for the Sifflet visual, functional programming + language (Hackage 'sifflet' package).+category: + Language+ , Visual Programming+tested-with: GHC == 6.12+data-files: sifflet.scm sifflet.py+data-dir: data+extra-tmp-files:+extra-source-files: README++-- Library section++library++ build-depends:+ 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,+ directory >= 1.0 && < 1.1,+ filepath >= 1.1 && < 1.2,+ fgl >= 5.4 && < 5.5,+ haskell98 >= 1.0.1 && < 1.0.2,+-- This (haskell-src) should probably be phased out as I replace+-- parts of it with Parsec.+-- But no, it is needed for export in Sifflet.Language.ToHaskell.+ haskell-src >= 1.0.1 && < 1.0.2,+ hxt >= 8.3 && < 8.6,+ mtl >= 1.1 && < 1.2,+ parsec >= 2.1.0.1 && < 2.3, + process >= 1.0 && < 1.1+ if !os(windows)+ build-depends: unix >= 2.3 && < 2.5+ buildable: True+ extensions: ForeignFunctionInterface CPP+ ghc-options: -Wall+ includes: gtk-2.0/gtk/gtk.h, gtk-2.0/gdk/gdk.h+ extra-libraries: gdk-x11-2.0 gtk-x11-2.0+ exposed-modules: + Sifflet.Data.Geometry+ , Sifflet.Data.Functoid+ , Sifflet.Data.Number+ , Sifflet.Data.Tree+ , Sifflet.Data.TreeGraph+ , Sifflet.Data.TreeLayout+ , Sifflet.Data.WGraph+ , Sifflet.Examples+ , Sifflet.Foreign.Exporter+ , Sifflet.Foreign.Python+ , Sifflet.Foreign.ToHaskell+ , Sifflet.Foreign.ToPython+ , Sifflet.Foreign.ToScheme+ , Sifflet.Language.Expr+ , Sifflet.Language.Parser+ , Sifflet.Language.SiffML+ , Sifflet.Rendering.Draw+ , Sifflet.Rendering.DrawTreeGraph+ , Sifflet.Text.Pretty+ , Sifflet.Text.Repr+ , Sifflet.UI+ , Sifflet.UI.Callback+ , Sifflet.UI.Canvas+ , Sifflet.UI.Frame+ , Sifflet.UI.GtkForeign+ , Sifflet.UI.GtkUtil+ , Sifflet.UI.LittleGtk+ , Sifflet.UI.Tool+ , Sifflet.UI.RPanel+ , Sifflet.UI.Types+ , Sifflet.UI.Window+ , Sifflet.UI.Workspace+ , Sifflet.Util+-- Paths to data files, generated by Cabal+ other-modules: Paths_sifflet_lib+ hs-source-dirs:+ build-tools: