diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -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.
diff --git a/README b/README
new file mode 100644
--- /dev/null
+++ b/README
@@ -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
+
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,3 @@
+-- Simple setup
+import Distribution.Simple
+main = defaultMain
diff --git a/Sifflet/Data/Functoid.hs b/Sifflet/Data/Functoid.hs
new file mode 100644
--- /dev/null
+++ b/Sifflet/Data/Functoid.hs
@@ -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)
diff --git a/Sifflet/Data/Geometry.hs b/Sifflet/Data/Geometry.hs
new file mode 100644
--- /dev/null
+++ b/Sifflet/Data/Geometry.hs
@@ -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
+
diff --git a/Sifflet/Data/Number.hs b/Sifflet/Data/Number.hs
new file mode 100644
--- /dev/null
+++ b/Sifflet/Data/Number.hs
@@ -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
diff --git a/Sifflet/Data/Tree.hs b/Sifflet/Data/Tree.hs
new file mode 100644
--- /dev/null
+++ b/Sifflet/Data/Tree.hs
@@ -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
+
diff --git a/Sifflet/Data/TreeGraph.hs b/Sifflet/Data/TreeGraph.hs
new file mode 100644
--- /dev/null
+++ b/Sifflet/Data/TreeGraph.hs
@@ -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)
+
+
diff --git a/Sifflet/Data/TreeLayout.hs b/Sifflet/Data/TreeLayout.hs
new file mode 100644
--- /dev/null
+++ b/Sifflet/Data/TreeLayout.hs
@@ -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
+
+
+
diff --git a/Sifflet/Data/WGraph.hs b/Sifflet/Data/WGraph.hs
new file mode 100644
--- /dev/null
+++ b/Sifflet/Data/WGraph.hs
@@ -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 _) = ""
+
+wgraphNew :: WGraph
+wgraphNew = empty
+
+-- | Insert new node with given label into graph,
+-- without any new edges;
+-- return the new graph and the new node (number)
+grInsertNode :: (DynGraph g) => g n e -> n -> (g n e, G.Node)
+grInsertNode graph label =
+ let (_, hi) = nodeRange graph
+ newNode = succ hi
+ nodeContext = ([], newNode, label, [])
+ graph' = nodeContext & graph
+ in (graph', newNode)
+
+-- | Remove a node from the graph; return the updated graph.
+grRemoveNode :: (DynGraph g) => g n e -> G.Node -> (g n e)
+grRemoveNode graph node =
+ let (mctx, g') = match node graph
+ in case mctx of
+ Nothing -> errcats ["grRemoveNode: node not found:", show node]
+ Just _ -> g'
+
+-- | Connect parent to child, using inlet as the order of the child
+-- (0, 1, ...). outlet is ignored, since there is only outlet 0.
+-- As rendered, the parent's inlet-th inlet will have a line
+-- to the child's outlet-th outlet.
+-- This is achieved by inserting a labeled edge (parent, child, inlet)
+-- and clearing any incompatible edge. The incompatibles are:
+-- a. from same parent on same inlet to a different child.
+-- b. from the same parent on a different inlet to the same child.
+-- c. from same child (on same outlet) to a different parent.
+--
+-- NOTE: This is confusing, because, from the data flow perspective,
+-- data flows OUT of the child INTO the parent, but from the
+-- "tree in graph" perspective, links are directed OUT of the parent
+-- INTO the child. So beware!
+
+grConnect :: WGraph -> G.Node -> WEdge -> G.Node -> WEdge -> WGraph
+grConnect g parent inlet child _outlet =
+ let (mPcontext, g') = match parent g
+ in case mPcontext of
+ Nothing -> error "grConnect: parent not found"
+ -- should parent below be same as parent above?
+ Just (pins, jparent, plabel, pouts) ->
+ -- jparent == parent
+ let pouts' = filter (edgeNotTo child)
+ (filter (edgeNotEqual inlet) pouts)
+ (mCcontext, g'') = match child g'
+ in case mCcontext of
+ Nothing -> error "grConnect: child not found"
+ Just (_cins, jchild, clabel, couts) ->
+ -- jchild == child
+ -- remove ANY links into the jchild (c)
+ let cins' = []
+ in
+ (pins, jparent, plabel, (inlet, jchild) : pouts') &
+ ((cins', jchild, clabel, couts) & g'')
+
+edgeNotEqual :: WEdge -> (WEdge, G.Node) -> Bool
+edgeNotEqual edge pair = edge /= fst pair
+
+edgeNotTo :: G.Node -> (WEdge, G.Node) -> Bool
+edgeNotTo node pair = node /= snd pair
+
+-- | Removes a link between parent and child
+-- where the edge was labeled inlet (order of child).
+-- Ignores outlet, which should always be 0.
+-- If child is not the inlet-th child of parent,
+-- well, this is an error, but grDisconnect ignores it.
+-- If toFrameP is true, the child node is
+-- reconnected as a child to its frame
+grDisconnect :: WGraph -> G.Node -> WEdge -> G.Node -> WEdge -> Bool -> WGraph
+grDisconnect g parent inlet child _outlet toFrameP =
+ let (mcontext, g') = match parent g
+ g'' = case mcontext of
+ Nothing -> error "grDisconnect: parent not found"
+ Just (ins, jparent, label, outs) ->
+ -- jparent == parent
+ let outs' = filter (/= (inlet, child)) outs
+ in (ins, jparent, label, outs') & g'
+ in if toFrameP
+ then connectToFrame child (nodeContainerFrameNode g parent) g''
+ else g''
+
+connectToFrame :: G.Node -> G.Node -> WGraph -> WGraph
+connectToFrame child frameNode g =
+ insEdge (frameNode, child, WEdge (outdeg g frameNode)) g
+
+grAddGraph :: (DynGraph g) => g n e -> g n e -> g n e
+grAddGraph g1 g2 =
+ let (_, hi1) = nodeRange g1
+ (lo2, _) = nodeRange g2
+ diff = hi1 - lo2 + 1
+
+ adjIncr :: Adj e -> Adj e
+ adjIncr adj = [(x, node + diff) | (x, node) <- adj]
+
+ ctxIncr :: Context n e -> Context n e
+ ctxIncr (adjFrom, node, label, adjTo) =
+ (adjIncr adjFrom, node + diff, label, adjIncr adjTo)
+
+ loop :: (DynGraph g) => g n e -> g n e -> g n e
+ loop ga gb =
+ if isEmpty gb
+ then ga
+ else let (acontext, gb') = matchAny gb in
+ ctxIncr acontext & loop ga gb'
+ in loop g1 g2
+
+-- | Extract from a graph the expression with root node n,
+-- returning a Tree of ExprNode.
+-- Use only the WSimple nodes of the graph (and n had better be one).
+grExtractExprTree :: WGraph -> G.Node -> Tree ExprNode
+grExtractExprTree g = fmap layoutNodeSource . grExtractLayoutTree g
+
+-- ------------------------------------------------------------
+-- | Finding characteristics of the WNodes in a graph
+-- It is an implicit error if there is no label for the node
+
+-- | wlab is like lab with no Maybe: the node *must* have a label
+wlab :: WGraph -> Node -> WNode
+wlab g n = fromJust (lab g n)
+
+-- | llab is the tree layout node of a WSimple node
+llab :: WGraph -> Node -> LayoutNode ExprNode
+llab g n =
+ case wlab g n of
+ WSimple lnode -> lnode
+ WFrame _fnode ->
+ errcat ["llab: node is not simple",
+ "\nnode ", (show n),
+ "\n in graph\n",
+ (show g)]
+
+-- | The ExprNode represented by the graph node
+nodeExprNode :: WGraph -> Node -> ExprNode
+nodeExprNode g n = gnodeValue (nodeGNode (llab g n))
+
+-- | The repr of the node's value
+nodeText :: WGraph -> Node -> String
+nodeText g n = tbText (head (gnodeTextBoxes (nodeGNode (llab g n))))
+
+-- | The result of an evaluated node in an expression tree
+nodeValue :: WGraph -> Node -> EvalResult
+nodeValue g n = mvalue
+ where ENode _ mvalue = nodeExprNode g n
+
+-- | The node's BBox
+nodeBBox :: WGraph -> Node -> BBox
+nodeBBox g n = gnodeNodeBB (nodeGNode (llab g n))
+
+nodePosition :: WGraph -> Node -> Position
+nodePosition g = bbPosition . nodeBBox g
+
+nodeInputValues :: WGraph -> Node -> EvalResult
+nodeInputValues graph node =
+ mapM (nodeValue graph) (nodeSimpleChildren graph node) >>=
+ EvalOk . VList
+
+-- | Finding the children (nodes, numbers) of a node in a graph :
+-- all children, only WSimple-labeled children, only WFrame-labeled children
+-- When constructing the graph, ordered children of a tree node
+-- get graph node numbers in ascending order; therefore,
+-- sorting the graph nodes gives back the original order of
+-- children in the tree (plus WFrames that are added later,
+-- and those should always be after the simple children)
+
+nodeAllChildren :: WGraph -> Node -> [Node]
+nodeAllChildren g n = sort (suc g n)
+
+nodeSimpleChildren :: WGraph -> Node -> [Node]
+nodeSimpleChildren g n = filter (nodeIsSimple g) (nodeAllChildren g n)
+
+nodeAllSimpleDescendants :: WGraph -> Node -> [Node]
+nodeAllSimpleDescendants g n =
+ n : concatMap (nodeAllSimpleDescendants g) (nodeSimpleChildren g n)
+
+nodeProperSimpleDescendants :: WGraph -> Node -> [Node]
+nodeProperSimpleDescendants g n = tail (nodeAllSimpleDescendants g n)
+
+nodeFrameChildren :: WGraph -> Node -> [Node]
+nodeFrameChildren g n = filter (not . nodeIsSimple g) (nodeAllChildren g n)
+
+nodeIsSimple :: WGraph -> Node -> Bool
+nodeIsSimple g n =
+ -- is node n of graph g a WSimple node?
+ case lab g n of
+ Just (WSimple _) -> True
+ _ -> False
+
+-- | An open node has a WFrame-labeled child
+nodeIsOpen :: WGraph -> Node -> Bool
+nodeIsOpen graph node = nodeFrameChildren graph node /= []
+
+-- The root node of the tree in which node occurs.
+-- This is a WSimple node, it may not back up to a WFrame node.
+--
+-- THIS CODE IS UNTESTED, AND CURRENTLY UNUSED (2009/2/4)
+
+-- -- nodeTreeRoot: unused
+-- nodeTreeRoot :: WGraph -> Node -> Node
+-- nodeTreeRoot g n = findRoot n
+-- where findRoot node =
+-- case pre g node of
+-- [] -> (error "nodeTreeRoot: no simple root found")
+-- [parent] ->
+-- if not (nodeIsSimple g parent)
+-- then node
+-- else findRoot parent
+-- _ -> error "nodeTreeRoot: node has multiple parents"
+
+-- -- The root (a WSimple node) of the tree in which a node occurs
+-- -- Huh, don't need this!
+
+-- -- nodeSimpleRoot: unused
+-- nodeSimpleRoot :: WGraph -> Node -> Node
+-- nodeSimpleRoot = undefined
+
+-- | The graph node of the frame that contains the given node
+nodeContainerFrameNode :: WGraph -> Node -> Node
+nodeContainerFrameNode g n =
+ let findFrame node =
+ if not (nodeIsSimple g node)
+ then node
+ else case pre g node of
+ [parent] -> findFrame parent
+ [] -> err "has no parent but is not a frame node" node
+ _:_ -> err "has multiple parents" node
+ err msg node =
+ errcat["nodeContainerFrameNode: node ",
+ show node, " ", msg, "\n",
+ "in graph\n", show g]
+
+ in findFrame n
+
+-- | The parent (if any) of a node
+nodeParent :: WGraph -> Node -> Maybe Node
+nodeParent g n =
+ case pre g n of
+ [] -> Nothing
+ [parent] -> Just parent
+ _ -> error "nodeParent: multiple parents"
+
+
+grUpdateFLayout :: WGraph -> [G.Node] -> FunctoidLayout -> WGraph
+grUpdateFLayout gr ns tlo =
+ case tlo of
+ FLayoutTree t ->
+ case ns of
+ [rootNode] -> grUpdateTreeLayout gr rootNode t
+ _ -> error "grUpdateFLayout: tree tlo, but not a single root"
+ FLayoutForest f _b ->
+ let accum g (n, t) = grUpdateTreeLayout g n t
+ in foldl accum gr (zip ns f)
+
+-- | Replace the tree embedded in graph g with root n, with a new tree.
+grUpdateTreeLayout :: WGraph -> G.Node -> TreeLayout ExprNode -> WGraph
+grUpdateTreeLayout gr n0 t0 = updateTree gr n0 t0
+ where updateTree g n (T.Node root subtrees) =
+ case match n g of
+ (Just (adjFrom, jn, WSimple _, adjTo), g1) ->
+ -- jn == n
+ let g2 = (adjFrom, jn, WSimple root, adjTo) & g1
+ in updateForest g2 (nodeSimpleChildren g jn) subtrees
+ (Just (_adjFrom, _n, _, _adjTo), _) ->
+ error "grUpdateTreeLayout: root node is not a WSimple"
+ (Nothing, _) ->
+ errcats ["grUpdateTreeLayout: no such node:", show n]
+
+ updateForest g [] [] = g
+ updateForest g (n:ns) (t:ts) =
+ case lab g n of
+ Just (WSimple _) -> updateForest (updateTree g n t) ns ts
+ Just (WFrame _) -> updateForest g ns (t:ts) -- shouldn't happen!
+ Nothing -> error "grUpdateTreeLayout: no label for node"
+
+ updateForest _g _ [] = error "too many ns"
+ updateForest _g [] _ = error "too many ts"
+
+-- | Extract just the single tree layout node of the given graph node
+grExtractLayoutNode :: WGraph -> G.Node -> LayoutNode ExprNode
+grExtractLayoutNode g n =
+ case lab g n of
+ Just (WSimple lnode) -> lnode
+ _ -> errcats ["grExtractLayoutNode:",
+ "no label for node, or node is not WSimple:",
+ "node", show n]
+
+-- | Extract the tree layout (tree) descended from the given root node
+grExtractLayoutTree :: WGraph -> G.Node -> TreeLayout ExprNode
+grExtractLayoutTree g n =
+ T.Node (grExtractLayoutNode g n)
+ (map (grExtractLayoutTree g) (nodeSimpleChildren g n))
+
+
+-- | Translate the nodes forming a tree with the given root
+translateTree :: Double -> Double -> WGraph -> G.Node -> WGraph
+translateTree dx dy wgraph root =
+ grUpdateTreeLayout wgraph root
+ (translate dx dy (grExtractLayoutTree wgraph root))
+
+
+translateNodes :: Double -> Double -> WGraph -> [G.Node] -> WGraph
+translateNodes dx dy = foldl (translateNode dx dy)
+
+translateNode :: Double -> Double -> WGraph -> G.Node -> WGraph
+translateNode dx dy wg node =
+ case match node wg of
+ (Nothing, _) ->
+ errcats ["translateNode: no such node:", show node]
+ (Just (adjFrom, jnode, WSimple layoutNode, adjTo), g') ->
+ -- jnode == node
+ (adjFrom, jnode, WSimple (translate dx dy layoutNode), adjTo) & g'
+ (Just _, _) ->
+ errcats ["translateNode: node is not a WSimple:", show node]
+
+
+-- | Replace the label of a node in a graph
+grRelabelNode :: (DynGraph g) => g a b -> G.Node -> a -> g a b
+grRelabelNode g n newLabel =
+ case match n g of
+ (Just (adjFrom, jn, _oldLabel, adjTo), g') ->
+ -- jn == n
+ (adjFrom, jn, newLabel, adjTo) & g'
+ (Nothing, _) -> errcats ["grRelabelNode: no such node:", show n]
+
+-- | Get the parts of a Functoid.
+-- See note on functionToParts (just below).
+-- Seems to be unused ***
+
+functoidParts :: Functoid -> WGraph -> G.Node -> Functoid
+functoidParts functoid graph frameNode =
+ case functoid of
+ fp@FunctoidParts {} -> fp
+ FunctoidFunc function -> functionToParts function graph frameNode
+
+-- | Convert a function to its parts.
+-- COULDN'T THIS BE DONE USING the function's implementation,
+-- and not need to use the graph? Then this could go in Functoid.hs
+-- without circular import between it and WGraph
+functionToParts :: Function -> WGraph -> G.Node -> Functoid
+functionToParts (Function mname _atypes _rtype impl) graph frameNode =
+ case impl of
+ Primitive _ -> error "functionToParts: function is primitive"
+ Compound argnames _body ->
+ FunctoidParts {fpName = case mname of
+ Nothing -> "unnamed function"
+ Just jname -> jname,
+ fpArgs = argnames,
+ fpNodes = nodeProperSimpleDescendants graph frameNode}
diff --git a/Sifflet/Examples.hs b/Sifflet/Examples.hs
new file mode 100644
--- /dev/null
+++ b/Sifflet/Examples.hs
@@ -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
+
diff --git a/Sifflet/Foreign/Exporter.hs b/Sifflet/Foreign/Exporter.hs
new file mode 100644
--- /dev/null
+++ b/Sifflet/Foreign/Exporter.hs
@@ -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 ()
+
diff --git a/Sifflet/Foreign/Python.hs b/Sifflet/Foreign/Python.hs
new file mode 100644
--- /dev/null
+++ b/Sifflet/Foreign/Python.hs
@@ -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
+
diff --git a/Sifflet/Foreign/ToHaskell.hs b/Sifflet/Foreign/ToHaskell.hs
new file mode 100644
--- /dev/null
+++ b/Sifflet/Foreign/ToHaskell.hs
@@ -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 = " [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
diff --git a/Sifflet/Foreign/ToPython.hs b/Sifflet/Foreign/ToPython.hs
new file mode 100644
--- /dev/null
+++ b/Sifflet/Foreign/ToPython.hs
@@ -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"
diff --git a/Sifflet/Foreign/ToScheme.hs b/Sifflet/Foreign/ToScheme.hs
new file mode 100644
--- /dev/null
+++ b/Sifflet/Foreign/ToScheme.hs
@@ -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"
diff --git a/Sifflet/Language/Expr.hs b/Sifflet/Language/Expr.hs
new file mode 100644
--- /dev/null
+++ b/Sifflet/Language/Expr.hs
@@ -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 _) = ""
+ show (Compound args body) =
+ concat ["Compound function, args = " ++ show args ++
+ "; body = " ++ show body]
+
+instance Read FunctionImpl where
+ readsPrec _ _ = error "readsPrec not implemented for FunctionImpl"
+
+instance Repr Function where
+ repr (Function mname _ _ _) =
+ case mname of
+ Nothing -> ""
+ Just name -> ""
+
+newUndefinedFunction :: String -> [String] -> Function
+newUndefinedFunction name argnames =
+ let (atypes, rtype) = undefinedTypes argnames
+ impl = Compound argnames EUndefined
+ in Function (Just name) atypes rtype impl
+
+functionName :: Function -> String
+functionName (Function mname _ _ _) =
+ case mname of
+ Just name -> name
+ Nothing -> "anonymous function"
+
+functionNArgs :: Function -> Int
+functionNArgs = length . functionArgTypes
+
+functionArgTypes :: Function -> [VpType]
+functionArgTypes (Function _ argtypes _ _) = argtypes
+
+functionResultType :: Function -> VpType
+functionResultType (Function _ _ rtype _) = rtype
+
+-- | Type type of a function, a tuple of (arg types, result type)
+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)
diff --git a/Sifflet/Language/Parser.hs b/Sifflet/Language/Parser.hs
new file mode 100644
--- /dev/null
+++ b/Sifflet/Language/Parser.hs
@@ -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
+
+
diff --git a/Sifflet/Language/SiffML.hs b/Sifflet/Language/SiffML.hs
new file mode 100644
--- /dev/null
+++ b/Sifflet/Language/SiffML.hs
@@ -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 2.5
+ -- to 2.5, and similarly with other
+ -- literal values?
+ ELit value ->
+ selem "literal" [toXml value]
+ EIf e1 e2 e3 ->
+ selem "if" [toXml e1, toXml e2, toXml e3]
+ EList xs ->
+ selem "list" (map toXml xs)
+ ECall (Symbol name) xs ->
+ selem "call"
+ (selem "symbol" [txt name] :
+ map toXml xs)
+
+xmlToExpr :: 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 ->
+ -- or
+ -- complicate? selem "bool" [txt (show b)]
+ eelem (show b)
+ VChar c ->
+ selem "char" [txt [c]]
+ VStr s ->
+ selem "string" [txt s]
+ VInt i ->
+ selem "int" [txt (show i)]
+ VFloat x ->
+ selem "float" [txt (show x)]
+ -- Are VFun and VList needed???
+ VFun f ->
+ selem "function" [toXml f]
+ VList vs ->
+ selem "list" (map toXml vs)
+
+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]
diff --git a/Sifflet/Rendering/Draw.hs b/Sifflet/Rendering/Draw.hs
new file mode 100644
--- /dev/null
+++ b/Sifflet/Rendering/Draw.hs
@@ -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
+
diff --git a/Sifflet/Rendering/DrawTreeGraph.hs b/Sifflet/Rendering/DrawTreeGraph.hs
new file mode 100644
--- /dev/null
+++ b/Sifflet/Rendering/DrawTreeGraph.hs
@@ -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
+ }
diff --git a/Sifflet/Text/Pretty.hs b/Sifflet/Text/Pretty.hs
new file mode 100644
--- /dev/null
+++ b/Sifflet/Text/Pretty.hs
@@ -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 ", "
diff --git a/Sifflet/Text/Repr.hs b/Sifflet/Text/Repr.hs
new file mode 100644
--- /dev/null
+++ b/Sifflet/Text/Repr.hs
@@ -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
diff --git a/Sifflet/UI.hs b/Sifflet/UI.hs
new file mode 100644
--- /dev/null
+++ b/Sifflet/UI.hs
@@ -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
diff --git a/Sifflet/UI/Callback.hs b/Sifflet/UI/Callback.hs
new file mode 100644
--- /dev/null
+++ b/Sifflet/UI/Callback.hs
@@ -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
diff --git a/Sifflet/UI/Canvas.hs b/Sifflet/UI/Canvas.hs
new file mode 100644
--- /dev/null
+++ b/Sifflet/UI/Canvas.hs
@@ -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)
diff --git a/Sifflet/UI/Frame.hs b/Sifflet/UI/Frame.hs
new file mode 100644
--- /dev/null
+++ b/Sifflet/UI/Frame.hs
@@ -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)
diff --git a/Sifflet/UI/GtkForeign.hs b/Sifflet/UI/GtkForeign.hs
new file mode 100644
--- /dev/null
+++ b/Sifflet/UI/GtkForeign.hs
@@ -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 - 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)
diff --git a/Sifflet/UI/GtkUtil.hs b/Sifflet/UI/GtkUtil.hs
new file mode 100644
--- /dev/null
+++ b/Sifflet/UI/GtkUtil.hs
@@ -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
diff --git a/Sifflet/UI/LittleGtk.hs b/Sifflet/UI/LittleGtk.hs
new file mode 100644
--- /dev/null
+++ b/Sifflet/UI/LittleGtk.hs
@@ -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
diff --git a/Sifflet/UI/RPanel.hs b/Sifflet/UI/RPanel.hs
new file mode 100644
--- /dev/null
+++ b/Sifflet/UI/RPanel.hs
@@ -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
diff --git a/Sifflet/UI/Tool.hs b/Sifflet/UI/Tool.hs
new file mode 100644
--- /dev/null
+++ b/Sifflet/UI/Tool.hs
@@ -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
diff --git a/Sifflet/UI/Types.hs b/Sifflet/UI/Types.hs
new file mode 100644
--- /dev/null
+++ b/Sifflet/UI/Types.hs
@@ -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)
+
diff --git a/Sifflet/UI/Window.hs b/Sifflet/UI/Window.hs
new file mode 100644
--- /dev/null
+++ b/Sifflet/UI/Window.hs
@@ -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)
+ ]
diff --git a/Sifflet/UI/Workspace.hs b/Sifflet/UI/Workspace.hs
new file mode 100644
--- /dev/null
+++ b/Sifflet/UI/Workspace.hs
@@ -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", ":"]]
diff --git a/Sifflet/Util.hs b/Sifflet/Util.hs
new file mode 100644
--- /dev/null
+++ b/Sifflet/Util.hs
@@ -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
diff --git a/data/sifflet.py b/data/sifflet.py
new file mode 100644
--- /dev/null
+++ b/data/sifflet.py
@@ -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()
diff --git a/data/sifflet.scm b/data/sifflet.scm
new file mode 100644
--- /dev/null
+++ b/data/sifflet.scm
@@ -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)))
+
+
diff --git a/sifflet-lib.cabal b/sifflet-lib.cabal
new file mode 100644
--- /dev/null
+++ b/sifflet-lib.cabal
@@ -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: