diff --git a/Data/Sifflet/Functoid.hs b/Data/Sifflet/Functoid.hs
new file mode 100644
--- /dev/null
+++ b/Data/Sifflet/Functoid.hs
@@ -0,0 +1,104 @@
+module Data.Sifflet.Functoid
+ (Functoid(..)
+ , functoidName, functoidArgNames, functoidHeader
+ , FunctoidLayout(..), flayout
+ , flayoutBBox, flayoutSize, flayoutWidth, flayoutBottom
+ , flayoutWiden)
+
+where
+
+import Data.Graph.Inductive as G
+
+import Data.Sifflet.Geometry
+import Data.Sifflet.TreeLayout
+
+import Language.Sifflet.Expr
+import Language.Sifflet.ExprTree
+
+
+-- | 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
+ aspecs = functionArgSpecs function
+ exprTree = case mvalues of
+ Nothing -> exprToTree expr
+ Just _values -> evalTree (exprToTree expr) env
+ tlo = treeLayout style
+ (exprNodeIoletCounter env aspecs)
+ 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/Data/Sifflet/Geometry.hs b/Data/Sifflet/Geometry.hs
new file mode 100644
--- /dev/null
+++ b/Data/Sifflet/Geometry.hs
@@ -0,0 +1,162 @@
+module Data.Sifflet.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/Data/Sifflet/Tree.hs b/Data/Sifflet/Tree.hs
new file mode 100644
--- /dev/null
+++ b/Data/Sifflet/Tree.hs
@@ -0,0 +1,67 @@
+-- Tree.hs
+-- General (not binary) trees
+
+module Data.Sifflet.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 Text.Sifflet.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/Data/Sifflet/TreeGraph.hs b/Data/Sifflet/TreeGraph.hs
new file mode 100644
--- /dev/null
+++ b/Data/Sifflet/TreeGraph.hs
@@ -0,0 +1,252 @@
+module Data.Sifflet.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 Data.Sifflet.Functoid
+import Data.Sifflet.Geometry
+import Data.Sifflet.Tree as T
+import Data.Sifflet.TreeLayout
+import Data.Sifflet.WGraph
+
+import Language.Sifflet.Expr
+import Language.Sifflet.ExprTree
+import Language.Sifflet.TypeCheck
+
+import Language.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} ->
+ case suc graph frameNode of
+ [root] ->
+ do
+ {
+ expr <- treeToExpr $ graphToExprTree graph root
+ ; let impl = Compound args expr
+ ; (atypes, rtype) <- decideTypes name expr args env
+ ; Succ (Function (Just name) atypes rtype impl)
+ }
+ _ -> Fail "The graph structure is not a tree!"
+
+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/Data/Sifflet/TreeLayout.hs b/Data/Sifflet/TreeLayout.hs
new file mode 100644
--- /dev/null
+++ b/Data/Sifflet/TreeLayout.hs
@@ -0,0 +1,660 @@
+module Data.Sifflet.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 Data.Sifflet.Geometry
+import Data.Sifflet.Tree as T hiding (tree)
+import Text.Sifflet.Repr ()
+import Language.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.
+newtype 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/Data/Sifflet/WGraph.hs b/Data/Sifflet/WGraph.hs
new file mode 100644
--- /dev/null
+++ b/Data/Sifflet/WGraph.hs
@@ -0,0 +1,478 @@
+module Data.Sifflet.WGraph
+ (WNode(..), WEdge(..), WGraph, WContext
+ , wgraphNew, isWSimple, isWFrame, grInsertNode, grRemoveNode
+ , connectToFrame
+ , grConnect, grDisconnect
+ , grAddGraph
+ , grExtractExprTree, grExtractLayoutNode, grExtractLayoutTree
+
+ , wlab, llab, nodeExprNode, nodeText, nodeValue
+ , nodeBBox, nodePosition, nodeInputValues
+ , graphOrphans, adoptChildren
+ , nodeAllChildren, nodeSimpleChildren, allDescendants, nodeFrameChildren
+ , nodeAllSimpleDescendants, nodeProperSimpleDescendants
+ , nodeIsSimple, nodeIsOpen, nodeContainerFrameNode
+ , nodeParent
+
+ , grUpdateFLayout, grUpdateTreeLayout
+ , printWGraph
+ , translateNodes
+ , translateNode, grRelabelNode
+ , translateTree
+ , functoidParts, functionToParts
+ -- Additional operations on graphs
+ , nfilter
+ )
+
+where
+
+import Data.List (sort)
+import Data.Maybe (fromJust)
+
+import Data.Graph.Inductive as G
+
+import Data.Sifflet.Functoid
+import Data.Sifflet.Geometry
+import Data.Sifflet.Tree as T -- exports Data.Tree.Tree(Node), etc.
+import Data.Sifflet.TreeLayout
+
+import Language.Sifflet.Expr
+import Language.Sifflet.ExprTree
+
+import Text.Sifflet.Repr ()
+
+import Language.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
+
+type WContext = Context WNode WEdge
+
+newtype 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
+
+isWSimple :: WNode -> Bool
+isWSimple (WSimple _) = True
+isWSimple _ = False
+
+isWFrame :: WNode -> Bool
+isWFrame (WFrame _) = True
+isWFrame _ = False
+
+-- | Print a description of the WGraph
+printWGraph :: WGraph -> IO ()
+printWGraph g =
+ let vs = nodes g
+ wnodeLabel v =
+ case lab g v of
+ Just (WFrame v') ->
+ "(WFrame with reference to vertex " ++ show v' ++ ")"
+ Just (WSimple (LayoutNode {nodeGNode = gnode})) ->
+ repr (gnodeValue gnode)
+ Nothing ->
+ "(unlabeled!)"
+ printVertex v = do
+ putStrLn $ "Vertex " ++ show v ++
+ " with label " ++ wnodeLabel v
+ putStrLn $ " " ++ show (indeg g v) ++ " predecessors: " ++
+ show [(v', wnodeLabel v') | v' <- pre g v]
+ putStrLn $ " " ++ show (outdeg g v) ++ " successors: " ++
+ show [(v', wnodeLabel v') | v' <- suc g v]
+ in do
+ putStrLn $ "A WGraph with " ++ show (length vs) ++ " vertices"
+ mapM_ printVertex vs
+
+-- | 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
+
+-- | Find all parentless nodes in a graph
+graphOrphans :: (Graph graph) => graph a b -> [Node]
+graphOrphans g = filter (\ v -> pre g v == []) (nodes g)
+
+-- | Connect the given children to a new parent
+adoptChildren :: WGraph -> G.Node -> [G.Node] -> WGraph
+adoptChildren g0 parent children =
+ let adopt g child = insEdge (parent, child, WEdge (outdeg g parent)) g
+ in foldl adopt g0 children
+
+-- | 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)
+
+-- | All (proper and improper) descendants of a node in a graph
+allDescendants :: (Graph graph) => graph a b -> Node -> [Node]
+allDescendants g n = reachable n g
+
+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}
+
+
+
+-- | Filter the nodes of a graph
+
+nfilter :: (Node -> Bool) -> Gr v e -> Gr v e
+nfilter f g =
+ nfilter' f g (nodes g)
+
+nfilter' :: (Node -> Bool) -> Gr v e -> [Node] -> Gr v e
+nfilter' _f g [] = g
+nfilter' f g (n:ns) = nfilter' f (if f n then g else delNode n g) ns
diff --git a/Graphics/Rendering/Sifflet/Draw.hs b/Graphics/Rendering/Sifflet/Draw.hs
new file mode 100644
--- /dev/null
+++ b/Graphics/Rendering/Sifflet/Draw.hs
@@ -0,0 +1,223 @@
+module Graphics.Rendering.Sifflet.Draw
+ (
+ Draw(..), DrawMode(..)
+ , drawBox
+ , drawTextBox
+ , modeTextCol, modeEdgeCol, modeFillCol
+ , setColor
+
+ )
+
+where
+
+import Control.Monad
+import Graphics.Rendering.Cairo hiding (translate)
+
+import Data.Sifflet.Functoid
+import Data.Sifflet.Geometry
+import Data.Sifflet.Tree
+import Data.Sifflet.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/Graphics/Rendering/Sifflet/DrawTreeGraph.hs b/Graphics/Rendering/Sifflet/DrawTreeGraph.hs
new file mode 100644
--- /dev/null
+++ b/Graphics/Rendering/Sifflet/DrawTreeGraph.hs
@@ -0,0 +1,182 @@
+-- | Tree graph rendering
+module Graphics.Rendering.Sifflet.DrawTreeGraph
+ (
+ graphQuickView
+ , graphWriteImageFile, graphRender, treeRender
+ , treeWriteImageFile, gtkShowTree
+ )
+
+where
+
+import System.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 Graphics.UI.Sifflet.LittleGtk
+
+import Data.Sifflet.Geometry
+import Data.Sifflet.Tree
+import Data.Sifflet.TreeGraph
+import Data.Sifflet.TreeLayout
+import Graphics.Rendering.Sifflet.Draw
+import Text.Sifflet.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/Graphics/UI/Sifflet.hs b/Graphics/UI/Sifflet.hs
new file mode 100644
--- /dev/null
+++ b/Graphics/UI/Sifflet.hs
@@ -0,0 +1,30 @@
+{- Workspace.hs implements the graphical workspace of Sifflet -}
+
+module Graphics.UI.Sifflet
+ (
+ module Graphics.UI.Sifflet.Frame
+ , module Graphics.UI.Sifflet.LittleGtk
+ , module Graphics.UI.Sifflet.RPanel
+ , module Graphics.UI.Sifflet.Types
+ , module Graphics.UI.Sifflet.Callback
+ , module Graphics.UI.Sifflet.Canvas
+ , module Graphics.UI.Sifflet.Tool
+ , module Graphics.UI.Sifflet.Workspace
+ , module Graphics.UI.Sifflet.GtkForeign
+ , module Graphics.UI.Sifflet.GtkUtil
+ , module Graphics.UI.Sifflet.Window
+ )
+
+where
+
+import Graphics.UI.Sifflet.Callback
+import Graphics.UI.Sifflet.Canvas
+import Graphics.UI.Sifflet.Frame
+import Graphics.UI.Sifflet.Tool
+import Graphics.UI.Sifflet.Workspace
+import Graphics.UI.Sifflet.GtkForeign
+import Graphics.UI.Sifflet.GtkUtil
+import Graphics.UI.Sifflet.LittleGtk
+import Graphics.UI.Sifflet.RPanel
+import Graphics.UI.Sifflet.Types
+import Graphics.UI.Sifflet.Window
diff --git a/Graphics/UI/Sifflet/Callback.hs b/Graphics/UI/Sifflet/Callback.hs
new file mode 100644
--- /dev/null
+++ b/Graphics/UI/Sifflet/Callback.hs
@@ -0,0 +1,152 @@
+module Graphics.UI.Sifflet.Callback
+ (
+ CBMgr, CBMgrAction, CBMgrCmd(..), mkCBMgr
+ , MenuSpec(..), MenuItemSpec(..), MenuItemAction
+ , createMenuBar, addMenu, createMenu, createMenuItem
+ , modifyIORefIO
+ )
+
+where
+
+import Data.IORef
+
+import Graphics.UI.Gtk
+
+import Graphics.UI.Sifflet.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 ()
+
+type CBMgrAction = IORef VPUI -> IO ()
+
+-- | Commands for the CBMgr
+data CBMgrCmd
+ = -- window events
+ OnWindowConfigure Window (IORef VPUI -> EventM EConfigure Bool)
+ | OnWindowDestroy Window CBMgrAction
+ | AfterWindowKeyPress 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 CBMgrAction
+ | AfterButtonClicked Button CBMgrAction
+
+ -- Surrender the UIRef to an arbitrary action
+ | WithUIRef CBMgrAction
+
+ | 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 ()
+ AfterWindowKeyPress window action ->
+ after 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 action uiref) >> return ()
+ OnEntryActivate entry action ->
+ onEntryActivate entry (action uiref) >> return ()
+ AfterButtonClicked button action ->
+ afterClicked button (action uiref) >> return ()
+
+ -- Not an event at all; the fact that I need this means the
+ -- CBMgr concept was misguided!
+ WithUIRef action -> action uiref
+
+ 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 (flip modifyIORef), but the type of the
+-- first argument is (a -> IO a) instead of (a -> a).
+-- Note that if a = VPUI, then updateIO :: VPUI -> IO VPUI
+-- and consequently modifyIORefIO updateIO :: CBMgrAction.
+
+modifyIORefIO :: (a -> IO a) -> IORef a -> IO ()
+modifyIORefIO updateIO ref = readIORef ref >>= updateIO >>= writeIORef ref
diff --git a/Graphics/UI/Sifflet/Canvas.hs b/Graphics/UI/Sifflet/Canvas.hs
new file mode 100644
--- /dev/null
+++ b/Graphics/UI/Sifflet/Canvas.hs
@@ -0,0 +1,1011 @@
+-- File: Canvas.hs
+-- Canvas and CanvFrame data and operations
+
+module Graphics.UI.Sifflet.Canvas
+ (
+ atLeastSize
+ , cfContext
+ , connect
+ , defaultFileSaveClipBox
+ , disconnect
+ , drawCanvas
+ , editFunction
+ , frameChanged
+ , nodeContainerFrame
+ , pointSelection
+ , renderCanvas
+ , vcAddFrame
+ , vcClearSelection
+ , vcClearFrame
+ , vcCloseFrame
+ , vcEvalDialog
+ , vcFrameAddFunctoidNode
+ , vcFrameAddNode
+ , vcFrameDeleteNode
+ , vcFrameDeleteTree
+ , vcFrameSubframes
+ , vcGetFrame
+ , vcInvalidateFrameWithParent
+ , vcInvalidateBox
+ , vcUpdateFrameAndGraph
+ , vcanvasNew
+ , vcanvasNodeAt
+ , vcanvasNodeRect
+ , whichFrame
+ , callFrames
+ )
+
+where
+
+-- debug imports
+-- import System.IO.Unsafe
+
+-- standard imports
+
+import Control.Monad
+import Data.List as List
+
+import Data.Graph.Inductive as G
+
+import Graphics.Rendering.Cairo hiding (translate)
+import qualified Graphics.Rendering.Cairo as Cairo
+
+-- Sifflet imports
+
+import Data.Sifflet.Functoid
+import Data.Sifflet.Geometry as Geometry
+import Data.Sifflet.Tree as T
+import Data.Sifflet.TreeGraph
+import Data.Sifflet.TreeLayout
+import Data.Sifflet.WGraph
+
+import Language.Sifflet.Expr
+import Language.Sifflet.ExprTree
+import Language.Sifflet.Parser
+
+import Graphics.Rendering.Sifflet.Draw
+
+import Graphics.UI.Sifflet.Frame
+import Graphics.UI.Sifflet.GtkUtil
+import Graphics.UI.Sifflet.LittleGtk
+import Graphics.UI.Sifflet.Types
+import Language.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) =
+ -- This should not happen, and is deliberately rendered
+ -- with a strange look!
+ -- This repeats some of graphRenderNode, slightly modified
+ let ctx = context graph rootNode
+ lnode :: LayoutNode ExprNode
+ WSimple lnode = lab' ctx
+ bb = gnodeNodeBB (nodeGNode lnode)
+ defaultInlet =
+ Iolet (Geometry.Circle
+ (Position (bbXCenter bb) (bbYCenter bb)) 0)
+
+ in loopWithInlets n [defaultInlet] (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)
+
+
+-- | Render a node.
+-- 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 -> Maybe Node -> Maybe Selection -> WGraph ->
+ G.Node -> Maybe Iolet -> Render ([Iolet], [(G.Node, WEdge)])
+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
+ inlets = gnodeInlets (nodeGNode lnode)
+ -- 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]
+
+ -- Do we need more inlets to match the outs' ?
+ deficit = length outs' - length inlets
+ -- The default inlet is lifted to the center
+ -- to show something is not right!
+ defaultInlet = Iolet (Geometry.Circle
+ (Position xcenter (bbYCenter nodeBB)) 0)
+ inlets' = if deficit > 0
+ then inlets ++ replicate deficit defaultInlet
+ else inlets
+
+ in 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
+-- ---------------------------------------------------------------------
+
+-- | Draw the canvas in its window, on screen
+drawCanvas :: VCanvas -> Rectangle -> IO ()
+drawCanvas canvas cliprect = do
+ drawWin <- layoutGetDrawWindow (vcLayout canvas)
+ renderWithDrawable drawWin $ renderCanvas canvas (bbFromRect cliprect) False
+
+-- | Render the canvas in Cairo
+-- (use with renderWith to provide an alternate surface, such as
+-- an SVG file).
+
+renderCanvas :: VCanvas -> BBox -> Bool -> Render ()
+renderCanvas canvas clipbox translateClip =
+ -- 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 (BBox x y width height) = do
+ rectangle x y width height
+ 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
+ -- end renderEditFrame
+
+ 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
+ -- end renderCallFrame
+
+ 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
+ -- end fancyTether
+
+ -- end of let decls in renderCanvas
+
+ -- main body of renderCanvas
+ in do
+ when translateClip
+ (Cairo.translate (- (bbX clipbox)) (- (bbY clipbox)))
+ setClip clipbox
+ drawBackground
+ -- sorting is a possible bottleneck?
+ mapM_ renderFrame (sortBy levelOrder frames)
+
+defaultFileSaveClipBox :: VCanvas -> BBox
+defaultFileSaveClipBox canvas =
+ let bboxes = map cfBox (vcFrames canvas)
+ BBox x1 y1 w1 h1 = bbMergeList bboxes -- contains all frames
+ pad = exomargin (vcStyle canvas)
+ in BBox (x1 - pad) (y1 - pad) (w1 + 2 * pad) (h1 + 2 * pad)
+
+-- | 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
+
+ reader :: Reader [String] [Value]
+ reader inputs = parseTypedInputs3 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
+
+ -- remove it from the frames list
+ let canvas'' = vcDeleteFrame canvas' frame
+
+ -- remove it and its edges from the graph
+ graph = vcGraph canvas''
+ graph' = delNodes (allDescendants graph (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/Graphics/UI/Sifflet/EditArgsPanel.hs b/Graphics/UI/Sifflet/EditArgsPanel.hs
new file mode 100644
--- /dev/null
+++ b/Graphics/UI/Sifflet/EditArgsPanel.hs
@@ -0,0 +1,332 @@
+-- | A "panel" to be shown on the Function Editor, for adjusting the
+-- arguments of the function being edited -- adding and deleting arguments,
+-- or modifying their "kind" (number of inlets, needed for higher order
+-- functions)
+
+module Graphics.UI.Sifflet.EditArgsPanel
+ (
+ ArgSpecAction
+ , EditArgsPanel
+ , makeEditArgsPanel
+ , editArgsPanelRoot
+ , expandToFit
+ )
+
+where
+
+import Data.IORef
+
+import Graphics.UI.Gtk (EventBox, hButtonBoxNew,
+ containerRemove,
+ ButtonBoxClass, buttonActivated,
+ widgetGetParent,
+ widgetQueueResize)
+
+import Language.Sifflet.Expr
+import Graphics.UI.Sifflet.Callback
+import Graphics.UI.Sifflet.LittleGtk
+import Language.Sifflet.Util (SuccFail(..), parseInt)
+
+type ArgSpecAction = [ArgSpec] -> IO ()
+
+type PanelRoot = EventBox
+
+data EditArgsPanel =
+ EditArgsPanel {editArgsPanelRoot :: PanelRoot,
+ editArgsPanelAction :: ArgSpecAction}
+
+type StateRef = IORef State
+
+data State = State Model UI
+
+newtype Model = Model [ArgSpec]
+ deriving (Show)
+
+data UI = UI PanelRoot Table Label [ArgRow]
+
+data ArgRow = ArgRow Entry Entry Button
+
+
+-- | Create an EditArgsPanel
+-- It currently returns a EditArgsPanel object,
+-- and you can put the root of it into a container, e.g.,
+-- set window [containerChild := editArgsPanelRoot panel]
+
+-- I think it needs to return some more information than this, though,
+-- and maybe know about its parent or larger context, so that when
+-- applied, it can have a "global" effect.
+-- Maybe just in the form of IO () actions, though.
+--
+-- It has this structure (for n existing arguments):
+
+-- EventBox ( = editArgsPanelRoot panel)
+-- +----------------------------------+
+-- | Frame |
+-- | +------------------------------+ |
+-- | | VBox | |
+-- | | +--------------------------+ | |
+-- | | | Table (n+2 rows)x(3 cols)| | |
+-- | | | +----------------------+ | | |
+-- | | | | | | | |
+-- | | | | (arguments) | | | |
+-- | | | +----------------------+ | | |
+-- | | | | | |
+-- | | | HButtonBox | | |
+-- | | | +----------------------+ | | |
+-- | | | | (buttons) | | | |
+-- | | | +----------------------+ | | |
+-- | | | | | |
+-- | | | Label | | |
+-- | | | +----------------------+ | | |
+-- | | | | (status messages) | | | |
+-- | | | +----------------------+ | | |
+-- | | +--------------------------+ | |
+-- | +------------------------------+ |
+-- +----------------------------------+
+
+makeEditArgsPanel :: CBMgr -> [ArgSpec] -> ArgSpecAction
+ -> IO EditArgsPanel
+makeEditArgsPanel cbMgr argSpecs okayAction = do
+ root <- eventBoxNew -- needed for everything to be visible!
+ frame <- frameNew
+ frameSetLabel frame "Edit Arguments"
+
+ let panel = EditArgsPanel {editArgsPanelRoot = root,
+ editArgsPanelAction = okayAction}
+
+ vbox <- vBoxNew False 5 -- non-homogeneous sizes, 5 pixels separation
+
+ -- Create a table of n + 2 rows x 3 cols, non-homogeneous sizes
+ table <- tableNew (length argSpecs + 2) 3 False
+ status <- labelNew Nothing
+
+ stateRef <- newIORef (State (Model argSpecs) (UI root table status []))
+ dressTable stateRef
+
+ btnBox <- hButtonBoxNew
+ fillButtonBox cbMgr btnBox stateRef panel
+
+ containerAdd root frame
+ containerAdd frame vbox
+ boxPackStartDefaults vbox table
+ boxPackStartDefaults vbox btnBox
+ boxPackStartDefaults vbox status
+
+ widgetShowAll root
+ return panel
+
+-- | Fill the table with rows for each argument in the model and more
+
+dressTable :: StateRef -> IO ()
+dressTable sref = do
+ -- read state
+ State (Model args) ui@(UI root table status _rows) <- readIORef sref
+
+ -- add "headings"
+ argLabel <- labelNew (Just "Name")
+ inputsLabel <- labelNew (Just "Inlets")
+ tableAttachCell table argLabel 0 0
+ tableAttachCell table inputsLabel 0 1
+
+-- add rows for existing and new arguments
+ let n = length args
+ argRows <- mapM (uncurry (argRowNew sref))
+ (zip (args ++ [ArgSpec "" 0]) [0 .. n])
+ mapM_ (uncurry (attachRow table))
+ (zip argRows [1 .. n + 1])
+ setStatusOK ui
+ widgetShowAll table
+
+ -- write state
+ writeIORef sref (State (Model args) (UI root table status argRows))
+
+
+-- | Resize a widget to be at least as big as a(nother) widget.
+-- Normally the widget being resized is one that contains the other.
+
+expandToFit :: (WidgetClass v, WidgetClass w) => v -> w -> IO ()
+expandToFit container widget = do
+ Requisition w1 h1 <- widgetSizeRequest container
+ Requisition w2 h2 <- widgetSizeRequest widget
+ let (w, h) = (max w1 w2, max h1 h2)
+ widgetSetSizeRequest container w h
+ widgetQueueResize container
+
+-- | Remove from table and destroy all arg rows
+-- (does not alter model)
+
+stripTable :: StateRef -> IO ()
+stripTable sref = do
+ State model ui@(UI root table status _rows) <- readIORef sref
+ let stripWidget widget =
+ do
+ containerRemove table widget
+ widgetDestroy widget
+
+ widgets <- containerGetChildren table
+ mapM_ stripWidget widgets
+ -- Why is this /not/ equivalent to above two statements?
+ -- liftM (mapM_ stripWidget) (containerGetChildren table)
+ setStatusOK ui
+
+ writeIORef sref (State model (UI root table status []))
+
+attachRow :: Table -> ArgRow -> Int -> IO ()
+attachRow table (ArgRow nameEntry nEntry btn) nrow = do
+ tableAttachCell table nameEntry nrow 0
+ tableAttachCell table nEntry nrow 1
+ tableAttachCell table btn nrow 2
+
+-- | Attach a widget to a table in a single cell, specified by its
+-- row column (top lef = 0 0) coordinates
+
+tableAttachCell :: (WidgetClass w) => Table -> w -> Int -> Int -> IO ()
+tableAttachCell t w top left =
+ tableAttachDefaults t w left (left + 1) top (top + 1)
+
+
+fillButtonBox :: (ButtonBoxClass b) =>
+ CBMgr -> b -> StateRef -> EditArgsPanel -> IO ()
+fillButtonBox cbMgr btnBox sref panel =
+ let addButton (label, action) = do
+ b <- buttonNewWithLabel label
+ containerAdd btnBox b
+ -- on b buttonActivated action
+ cbMgr (AfterButtonClicked b action)
+ addButton' label action = do
+ b <- buttonNewWithLabel label
+ containerAdd btnBox b
+ _ <- on b buttonActivated action
+ return ()
+
+ applyAction :: IO ()
+ applyAction = applyArgRows sref (editArgsPanelAction panel)
+
+ okayAction =
+ applyAction >> closePanel panel
+
+ in do
+ -- addButton' "OK" (cbMgr (WithUIRef okayAction))
+ addButton' "OK" okayAction
+ mapM_ addButton [
+ -- ("Strip", \ _ -> stripTable sref),
+ -- ("Dress", \ _ -> dressTable sref),
+ ("Cancel", \ _ -> closePanel panel)]
+
+-- | Close (destroy) the panel.
+-- I hope this also removes it from its parent.
+
+closePanel :: EditArgsPanel -> IO ()
+closePanel panel = widgetDestroy (editArgsPanelRoot panel)
+
+-- | Create a new ArgRow
+argRowNew :: StateRef -> ArgSpec -> Int -> IO ArgRow
+argRowNew sref (ArgSpec name inlets) n = do
+ e1 <- makeEntry name
+ e2 <- makeEntry (show inlets)
+ -- Create and set up button
+ let (label, action) =
+ case name of
+ "" -> ("Add", addArg sref n)
+ _ -> ("Remove", removeArg sref n)
+ b <- buttonNewWithLabel label
+ _ <- on b buttonActivated action
+ return (ArgRow e1 e2 b)
+
+-- | Add a new argument, nth in the model, from the (n+1)th row in the table
+
+-- Still to do: make sure the name is non-blank, and doesn't duplicate
+-- an existing argument (or global variable??)
+-- and is a valid symbol name (not a number, etc.)?
+
+addArg :: StateRef -> Int -> IO ()
+addArg sref n = do
+ State (Model argSpecs) ui@(UI root _table _status argRows) <- readIORef sref
+ readResult <- readArgRow (argRows !! n)
+
+ case readResult of
+
+ Succ argTool ->
+ do
+ writeIORef sref (State (Model (argSpecs ++ [argTool])) ui)
+ stripTable sref
+ dressTable sref
+ -- Make sure the container (layout) is big enough
+ -- to show the enlarged panel
+ mparent <- widgetGetParent root
+ case mparent of
+ Nothing -> return () -- shouldn't happen
+ Just parent -> expandToFit parent root
+ setStatusOK ui
+
+ Fail msg -> setStatus ui $ "Add: " ++ msg
+
+readArgRow :: ArgRow -> IO (SuccFail ArgSpec)
+readArgRow (ArgRow e1 e2 _) = do
+ name <- entryGetText e1
+ case name of
+ "" -> return $ Fail "blank name is not allowed"
+ _ -> do
+ inletsStr <- entryGetText e2
+ return $ case parseInt ("Inlets for " ++ name) inletsStr of
+ Succ inlets -> Succ (ArgSpec name inlets)
+ Fail msg -> Fail msg
+
+-- | Remove an argument, nth in the model, (n+1)th row in the table
+removeArg :: StateRef -> Int -> IO ()
+removeArg sref n = do
+ State (Model argSpecs) ui <- readIORef sref
+ writeIORef sref (State (Model (listRemove argSpecs n)) ui)
+ stripTable sref
+ dressTable sref
+ setStatusOK ui
+
+-- | Remove the nth element of a list (0 is the head)
+listRemove :: [a] -> Int -> [a]
+listRemove [] _ = error "listRemove: empty"
+listRemove (_:xs) 0 = xs
+listRemove (x:xs) n = x : (listRemove xs (n - 1))
+
+makeEntry :: String -> IO Entry
+makeEntry text = do
+ entry <- entryNew
+ entrySetText entry text
+ return entry
+
+applyArgRows :: StateRef -> ArgSpecAction -> IO ()
+applyArgRows sref action = do
+ State _model ui@(UI _root _table _status argRows) <- readIORef sref
+ readResult <- readArgRows argRows
+ case readResult of
+ Succ newSpecs ->
+ do
+ setStatusOK ui
+ writeIORef sref (State (Model newSpecs) ui)
+ action newSpecs
+ Fail msg ->
+ setStatus ui ("Apply: " ++ msg) >>
+ return ()
+
+
+-- Use a monad transformer or "lift" here???
+
+readArgRows :: [ArgRow] -> IO (SuccFail [ArgSpec])
+readArgRows [] = return (Succ []) -- shouldn't happen!
+readArgRows (_:[]) = return (Succ []) -- last row is for the "add" button
+readArgRows (row:rows) = do
+ results <- readArgRows rows
+ case results of
+ Fail msg -> return $ Fail msg
+ Succ specs ->
+ do
+ result <- readArgRow row
+ case result of
+ Fail msg -> return $ Fail msg
+ Succ spec -> return $ Succ (spec:specs)
+
+setStatusOK :: UI -> IO ()
+setStatusOK ui = setStatus ui ""
+
+setStatus :: UI -> String -> IO ()
+setStatus (UI _ _ status _) msg =
+ labelSetText status msg
diff --git a/Graphics/UI/Sifflet/Frame.hs b/Graphics/UI/Sifflet/Frame.hs
new file mode 100644
--- /dev/null
+++ b/Graphics/UI/Sifflet/Frame.hs
@@ -0,0 +1,307 @@
+module Graphics.UI.Sifflet.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 Data.Sifflet.Functoid
+import Data.Sifflet.Geometry
+import Data.Sifflet.Tree
+import Data.Sifflet.TreeLayout
+import Data.Sifflet.WGraph
+import Language.Sifflet.Expr
+import Language.Sifflet.ExprTree
+import Language.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/Graphics/UI/Sifflet/GtkForeign.hs b/Graphics/UI/Sifflet/GtkForeign.hs
new file mode 100644
--- /dev/null
+++ b/Graphics/UI/Sifflet/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 Graphics.UI.Sifflet.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/Graphics/UI/Sifflet/GtkUtil.hs b/Graphics/UI/Sifflet/GtkUtil.hs
new file mode 100644
--- /dev/null
+++ b/Graphics/UI/Sifflet/GtkUtil.hs
@@ -0,0 +1,224 @@
+{-# LANGUAGE CPP #-}
+
+module Graphics.UI.Sifflet.GtkUtil
+ (suppressScimBridge
+ , showChoicesDialog, defaultDialogPosition
+ , runDialogM, runDialogS
+ -- , runDialogHelper
+ , showInputErrorMessage, showErrorMessage
+ , showInfoMessage
+ , showMessage
+ , EntryDialog, Reader
+ , createEntryDialog, runEntryDialog
+ , addEntryWithLabel
+ )
+
+where
+
+import Control.Monad
+
+#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
+import System.Posix.Env
+#endif
+
+import Graphics.UI.Sifflet.LittleGtk
+import Language.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/Graphics/UI/Sifflet/LittleGtk.hs b/Graphics/UI/Sifflet/LittleGtk.hs
new file mode 100644
--- /dev/null
+++ b/Graphics/UI/Sifflet/LittleGtk.hs
@@ -0,0 +1,185 @@
+-- | 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 Graphics.UI.Sifflet.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
+ , containerGetChildren
+
+ , 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
+ , frameSetLabel
+
+ , 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
+
+ , Table
+ , tableNew
+ , tableAttachDefaults
+
+ , VBox
+ , vBoxNew
+
+ , WidgetClass
+
+ , widgetAddEvents
+ , widgetClassPath
+ , widgetDestroy
+ , widgetGrabFocus
+ , widgetSetCanFocus
+ , widgetSetDoubleBuffered
+ , widgetSetName
+ , widgetSetSizeRequest
+ , widgetShow
+ , widgetShowAll
+ , widgetSizeRequest
+ , widgetVisible
+
+ , Window
+ , windowDeletable
+ , 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/Graphics/UI/Sifflet/RPanel.hs b/Graphics/UI/Sifflet/RPanel.hs
new file mode 100644
--- /dev/null
+++ b/Graphics/UI/Sifflet/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 Graphics.UI.Sifflet.RPanel
+ (
+ RPanel, newRPanel, rpanelId, rpanelRoot, rpanelContent
+ , rpanelAddWidget, rpanelAddWidgets, rpanelNewRow
+ , rpanelAddRows
+ )
+
+where
+
+import Control.Monad
+
+import Graphics.UI.Sifflet.LittleGtk
+import Language.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/Graphics/UI/Sifflet/Tool.hs b/Graphics/UI/Sifflet/Tool.hs
new file mode 100644
--- /dev/null
+++ b/Graphics/UI/Sifflet/Tool.hs
@@ -0,0 +1,585 @@
+module Graphics.UI.Sifflet.Tool
+ (
+ ToolId(..)
+ , checkMods
+ , functionArgToolSpecs
+ , functionTool
+ , functionToolsFromLists
+ , makeConnectTool
+ , makeCopyTool
+ , makeDeleteTool
+ , makeDisconnectTool
+ , 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 Data.Sifflet.Functoid
+import Data.Sifflet.Geometry
+import Data.Sifflet.Tree (putTree, repr)
+import Data.Sifflet.TreeGraph (graphToOrderedTreeFrom)
+import Data.Sifflet.WGraph
+
+import Language.Sifflet.Expr
+import Language.Sifflet.ExprTree
+import Language.Sifflet.Parser
+
+import Graphics.UI.Sifflet.Callback
+import Graphics.UI.Sifflet.Canvas
+import Graphics.UI.Sifflet.Frame
+import Graphics.UI.Sifflet.LittleGtk
+import Graphics.UI.Sifflet.Types
+
+import Language.Sifflet.Util
+
+data ToolId
+ = ToolConnect
+ | ToolDisconnect
+ | ToolIf
+ | ToolMove
+ | ToolDelete
+ | ToolFunction String -- ^ function name
+ | ToolLiteral Expr
+ | ToolArg String Int -- ^ argument name, no. of inputs
+ deriving (Eq, Show)
+
+
+functionArgToolSpecs :: Function -> [ArgSpec]
+functionArgToolSpecs (Function _mname argTypes _rtype impl) =
+ let atspec :: (String, Type) -> ArgSpec
+ atspec (name, t) = ArgSpec name (typeInlets t)
+ typeInlets :: Type -> Int
+ typeInlets (TypeCons "Function" [_t1, t2]) = 1 + typeInlets t2
+ typeInlets _ = 0
+ argNames =
+ case impl of
+ Primitive _ -> ["arg" ++ show i | i <- [1 .. length argTypes]]
+ Compound anames _body -> anames
+ in map atspec (zip argNames argTypes)
+
+-- 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 e -> makeBoundLiteralTool e
+ ToolArg argname n -> makeBoundArgTool argname n
+
+
+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
+
+makeBoundLiteralTool :: Expr -> Tool
+makeBoundLiteralTool e =
+ let enode node = ENode node EvalUntried
+ addLitNode node vw toolContext _mods x y =
+ case toolContext of
+ TCEditFrame frame ->
+ vcFrameAddNode vw frame (enode node) [] x y
+ _ ->
+ return vw -- Nothing
+ mktool node =
+ Tool ("Literal: " ++ repr e)
+ return
+ (toToolOpVW (addLitNode node))
+ in case e of
+ EBool b -> mktool (NBool b)
+ EChar c -> mktool (NChar c)
+ ENumber n -> mktool (NNumber n)
+ EString s -> mktool (NString s)
+ EList es -> if exprIsLiteral e
+ then mktool (NList es)
+ else errcats ["makeBoundLiteralTool: ",
+ "non-literal list expression",
+ show e]
+ _ ->
+ errcats ["makeBoundLiteralTool: non-literal or",
+ "extended expression", show e]
+
+makeBoundArgTool :: String -> Int -> Tool
+makeBoundArgTool label n =
+ let node = ENode (NSymbol (Symbol label)) EvalUntried
+ addArgNode vc toolContext _mods x y =
+ case toolContext of
+ TCEditFrame frame ->
+ vcFrameAddNode vc frame node (map show [1..n]) x y
+ _ ->
+ return vc -- no effect
+ in Tool ("Argument: " ++ label ++ "/" ++ show n)
+ 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
+ parseLiteral -- 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
+
+-- *** Consider merging this with the other "light dialog"
+-- in EditArgsPanel.hs
+
+-- 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
+ {
+ ; root <- eventBoxNew -- needed for Label visibility
+ ; frame <- frameNew
+ ; frameSetLabel frame prompt
+ ; entry <- entryNew
+ ; case mcompletions of
+ Nothing -> return ()
+ Just comps -> addEntryCompletions entry comps
+
+ -- Organize as (eventbox (frame (entry)))
+ ; containerAdd frame entry
+ ; containerAdd root frame
+ ; layoutPut layout root (round xx) (round yy)
+ ; widgetShowAll root
+
+ -- 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 root entry)
+ ; uimgr (OnEntryActivate entry
+ (entryActivated root 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 v ->
+ grabRemove entry >>
+ widgetDestroy container >>
+ readIORef uiref >>=
+ vpuiSetTool (toolType v) 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 =
+ printWGraph . 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/Graphics/UI/Sifflet/Types.hs b/Graphics/UI/Sifflet/Types.hs
new file mode 100644
--- /dev/null
+++ b/Graphics/UI/Sifflet/Types.hs
@@ -0,0 +1,301 @@
+module Graphics.UI.Sifflet.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(..)
+ , VCanvas(..)
+ , Selection(..)
+ , Dragging(..)
+ )
+
+where
+
+import Data.Map as Map
+import Data.Graph.Inductive as G
+
+import Graphics.UI.Gtk.Gdk.EventM (Modifier(..))
+
+import Data.Sifflet.Geometry
+import Data.Sifflet.TreeLayout
+import Data.Sifflet.WGraph
+import Language.Sifflet.Expr
+
+import Graphics.UI.Sifflet.Frame
+import Graphics.UI.Sifflet.LittleGtk
+import Graphics.UI.Sifflet.RPanel
+import Language.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
+ vpuiDebugging :: Bool -- ^ include debug commands in context menu?
+ }
+
+-- | 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 Graphics.UI.Sifflet.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 {wsRootWidget :: VBox, -- ^ container of the rest
+ wsCanvas :: VCanvas, -- ^ the canvas
+ wsButtonBar :: HBox,
+ wsStatusbar :: Statusbar,
+ wsArgToolSpecs :: [ArgSpec] -- ^ none if not editing
+ }
+
+
+-- | 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/Graphics/UI/Sifflet/Window.hs b/Graphics/UI/Sifflet/Window.hs
new file mode 100644
--- /dev/null
+++ b/Graphics/UI/Sifflet/Window.hs
@@ -0,0 +1,1259 @@
+module Graphics.UI.Sifflet.Window
+ (
+ -- Window utilities
+ getOrCreateWindow
+ , showWindow
+ , newWindowTitled
+
+ , showWorkWin
+ , showWorkspaceWindow
+
+ , showFedWin
+ , fedWindowTitle
+
+ , getOrCreateFunctionPadWindow
+ , showFunctionPadWindow
+ , newFunctionDialog
+
+ , openFilePath
+ , setWSCanvasCallbacks
+ , keyBindingsHelpText
+ )
+
+where
+
+-- debug imports
+-- import Debug.Trace
+
+-- standard imports
+
+import Control.Monad
+import Data.IORef
+import Data.List as List
+import Data.Map as Map (fromList, keys, lookup)
+import Data.Map (Map)
+import Data.Maybe
+
+import Data.Graph.Inductive as G
+import Data.Version
+
+import Graphics.Rendering.Cairo
+import Graphics.UI.Gtk.Gdk.EventM
+
+import System.FilePath
+
+-- sifflet imports
+
+import Data.Sifflet.Functoid
+import Data.Sifflet.Geometry
+import Data.Sifflet.WGraph
+
+import Language.Sifflet.Export.Exporter
+import Language.Sifflet.Export.ToHaskell (defaultHaskellOptions, exportHaskell)
+import Language.Sifflet.Export.ToPython (defaultPythonOptions, exportPython)
+import Language.Sifflet.Export.ToScheme (SchemeOptions(..), exportScheme)
+
+import Language.Sifflet.Expr
+import Language.Sifflet.SiffML
+
+import Graphics.UI.Sifflet.Frame
+import Graphics.UI.Sifflet.Canvas
+import Graphics.UI.Sifflet.Types
+import Graphics.UI.Sifflet.Callback
+import Graphics.UI.Sifflet.Tool
+import Graphics.UI.Sifflet.Workspace
+import Graphics.UI.Sifflet.GtkForeign
+import Graphics.UI.Sifflet.GtkUtil
+import Graphics.UI.Sifflet.LittleGtk
+import Graphics.UI.Sifflet.RPanel
+
+import Language.Sifflet.Util
+
+
+import Paths_sifflet_lib as Paths
+
+-- ---------------------------------------------------------------------
+-- | 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 =
+ getOrCreateWindow winId uimgr initWin initCB True vpui
+
+-- | Like showWindow, except that making the window visible is optional
+getOrCreateWindow :: WinId -> CBMgr
+ -> (VPUI -> Window -> IO VPUIWindow)
+ -- ^ initialize Gtk Window
+ -> (VPUI -> WinId -> CBMgr -> IO ())
+ -- ^ initialize callbacks
+ -> Bool -- ^ make window visible
+ -> VPUI -> IO (VPUI, VPUIWindow, Bool)
+getOrCreateWindow winId uimgr initWin initCB visible 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
+ uimgr (OnWindowDestroy window (onWindowDestroy winId))
+ return (vpui', vwin, True)
+ Just vw ->
+ return (vpui, vw, False)
+ when isNew (initCB vpui' winId uimgr) -- add callbacks on new window
+ when visible $
+ -- show it
+ let window = vpuiWindowWindow vw
+ in do
+ widgetShowAll window
+ windowPresent window
+ return (vpui', vw, isNew)
+
+onWindowDestroy :: WinId -> IORef VPUI -> IO ()
+onWindowDestroy winId uiref =
+ if (winId == workspaceId)
+ then
+ readIORef uiref >>=
+ checkForChanges "quit (by closing the workspace window)" True False
+ (\ vpui -> do { mainQuit; return vpui }) >>
+ return ()
+ else modifyIORef uiref (vpuiRemoveVPUIWindow winId)
+
+-- | 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 := wsRootWidget ws]
+ -- this should suppress the window close button,
+ -- but doesn't, at least in Fluxbox
+ -- windowDeletable := False] -- no close button
+ ; 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 "Save image ..." menuFileSaveImage
+ , 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
+ ; 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
+ ; addFedWinButtons 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
+
+-- | Show the function pad window; create it if needed
+showFunctionPadWindow :: CBMgr -> VPUI -> IO VPUI
+showFunctionPadWindow cbmgr vpui = getOrCreateFunctionPadWindow cbmgr True vpui
+
+-- | Create the function pad window if it doesn't exist
+getOrCreateFunctionPadWindow :: CBMgr -> Bool -> VPUI -> IO VPUI
+getOrCreateFunctionPadWindow cbmgr visible vpui =
+ let initWindow _vpui window = do
+ 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
+ return $ FunctionPadWindow window (zip rpnames rps)
+ -- maybe need reference only the "My Functions" panel though **
+ in do
+ (vpui', _, windowIsNew) <- getOrCreateWindow functionPadWinId
+ cbmgr initWindow initCBDefault visible 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
+ (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 = checkForChanges "quit" False True vpuiQuit
+
+-- | Open a file (load its function definitions)
+
+menuFileOpen :: CBMgr -> VPUI -> IO VPUI
+menuFileOpen cbmgr =
+ checkForChanges "open file" True 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.
+-- If offerCancel is true, there is an option to cancel the operation;
+-- this won't work if the user is closing the main (workspace) window.
+-- 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 :: String -> Bool -> Bool -> (VPUI -> IO VPUI)
+ -> VPUI -> IO VPUI
+checkForChanges beforeOperation acknowledge offerCancel continue vpui =
+ let mAckIfSaved vpui' =
+ when (not (vpuiFileChanged vpui') && acknowledge)
+ (
+ showInfoMessage "Changes saved"
+ ("Your changes are now saved; " ++
+ "proceeding to " ++
+ beforeOperation ++ ".")
+ )
+ >>
+ return vpui'
+ choices = [("Save them",
+ menuFileSave vpui >>= mAckIfSaved >>= continue),
+ ("Throw them away",
+ return vpui >>= continue)] ++
+ if offerCancel
+ then [("Cancel " ++ beforeOperation, return vpui)]
+ else []
+ labels = map fst choices
+ actions = map snd choices
+ -- labels = ["Save them",
+ -- "Throw them away",
+ -- ]
+ -- 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 -> openFilePath cbmgr filePath vpui
+
+-- | Now that we have a file path, go ahead and open it,
+-- loading the function definitions into Sifflet
+-- and adding buttons to the function pad "My Functions" area.
+
+openFilePath :: CBMgr -> FilePath -> VPUI -> IO VPUI
+openFilePath cbmgr filePath vpui = 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'' <-
+ getOrCreateFunctionPadWindow cbmgr False vpui' >>=
+ updateFunctionPadIO title updatePad
+ return $ vpui'' {vpuiFilePath = Just filePath,
+ 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]
+
+
+-- | Save an image of a window in a file
+
+menuFileSaveImage :: VPUI -> IO VPUI
+menuFileSaveImage vpui = do
+ (windowId, fileExt) <- chooseImageOptions vpui
+ mfile <- chooseOutputFile ("Save image of " ++ windowId) vpui
+ case mfile of
+ Nothing -> return vpui
+ Just filePath ->
+ saveImageFile vpui windowId filePath fileExt
+
+-- | Returns (WinId, fileExtension),
+-- e.g., ("Sifflet Workspace", ".svg"),
+-- where fileExtension is ".svg", ".ps", or ".pdf"
+chooseImageOptions :: VPUI -> IO (WinId, String)
+chooseImageOptions vpui =
+ let hasCanvas winId =
+ isJust (vpuiWindowLookupCanvas (vpuiGetWindow vpui winId))
+ -- We can only use Cairo to render a window that has a canvas
+ windowChoices = filter hasCanvas (keys (vpuiWindows vpui))
+ windowActions = map return windowChoices
+ formatChoices = ["SVG", "PS", "PDF"]
+ formatActions = map return [".svg", ".ps", ".pdf"]
+ in do
+ ext <- showChoicesDialog "Save Image" "Select image format"
+ formatChoices formatActions
+ winId <- if length windowChoices == 1
+ then return $ head windowChoices
+ else showChoicesDialog "Save Image"
+ "Select window to save as image"
+ windowChoices windowActions
+ return (winId, ext)
+
+-- | Save the window image in the file format specified,
+-- adding the right file extension to the file path if it is
+-- not already present.
+saveImageFile :: VPUI -> WinId -> FilePath -> String -> IO VPUI
+saveImageFile vpui winId path ext =
+ let vpuiWindow = vpuiGetWindow vpui winId
+ canvas = vpuiWindowGetCanvas vpuiWindow
+ -- Size width height = vcSize canvas -- pixels (Double)
+ clipbox@(BBox _ _ width height) = defaultFileSaveClipBox canvas
+ -- cliprect = bbToRect clipbox
+
+ render :: Surface -> IO ()
+ render surface =
+ renderWith surface (renderCanvas canvas clipbox True)
+ -- (BBox 0 0 width height)
+ path' = if takeExtension path == ext
+ then path
+ else addExtension path ext
+
+ in case ext of
+ ".pdf" -> withPDFSurface path' width height render >> return vpui
+ ".ps" -> withPSSurface path' width height render >> return vpui
+ ".svg" -> withSVGSurface path' width height render >> return vpui
+
+ -- Cairo can do PNG too, but it is harder:
+ -- surfaceWriteToPNG surface path'
+ -- (have to get a surface and render to it first?)
+
+ -- Anything else really should not happen, because
+ -- chooseImageOptions returns one of the three extensions above.
+ -- But just in case:
+ _ -> do
+ showErrorMessage $
+ "Unable to save in this file format " ++
+ "(" ++ ext ++ ").\n" ++
+ "Please try a file extension of " ++
+ ".svg, .ps, or .pdf."
+ menuFileSaveImage vpui
+
+
+
+-- | Text shown by the help dialog
+helpText :: String
+helpText =
+ unlines ["Functions menu:",
+ " \"New\" enters a dialog to create a new function.",
+ " \"Function pad\" raises the function pad window.",
+ "Keystroke shortcuts for the menu commands are shown " ++
+ "using \"C-\" for Control. For example, Quit " ++
+ "is C-q, meaning Control+Q.",
+ "",
+ "In a function editor, right-click for the context menu.",
+ "",
+ "For more help, please visit the Sifflet web site,",
+ "http://mypage.iu.edu/~gdweber/software/sifflet/",
+ "especially the Sifflet Tutorial:",
+ "http://mypage.iu.edu/~gdweber/software/sifflet/doc/tutorial.html"
+ ]
+
+-- | Show the help dialog
+showHelpDialog :: MenuItemAction
+showHelpDialog vpui = showInfoMessage "Sifflet Help" helpText >> return vpui
+
+-- | How to report bugs
+bugsText :: String
+bugsText =
+ unlines ["To report bugs, please send mail to " ++ bugReportAddress,
+ "and mention \"Sifflet\" in the Subject header.",
+ "To send praise, follow the same procedure.",
+ "Seriously, whether you like Sifflet or dislike it,",
+ "I'd like to hear from you."
+ ]
+
+bugReportAddress :: String
+bugReportAddress = concat ["gdweber", at, "iue", punctum, "edu"]
+ where at = "@"
+ punctum = "."
+
+showBugs :: MenuItemAction
+showBugs vpui = showInfoMessage "Reporting bugs" bugsText >> return vpui
+
+-- | Text for the About dialog
+aboutText :: String
+aboutText =
+ unlines ["Sifflet version " ++ showVersion Paths.version,
+ "Copyright (C) 2010-2012 Gregory D. Weber",
+ "",
+ "BSD3 License",
+ "",
+ "Sifflet home page:",
+ "http://mypage.iu.edu/~gdweber/software/sifflet/"
+ ]
+
+showAboutDialog :: MenuItemAction
+showAboutDialog vpui = showInfoMessage "About Sifflet" aboutText >> return vpui
+
+-- ----------------------------------------------------------------------
+
+-- Moved here (WHY???) 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 (AfterWindowKeyPress 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
+ {
+ cliprect <- eventArea
+ ; liftIO (readIORef uiref >>= handleExposed winId cliprect)
+ }
+
+-- | Handle the Exposed event, should be called only for a window
+-- with a canvas
+handleExposed :: WinId -> Rectangle -> VPUI -> IO ()
+handleExposed winId cliprect 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 cliprect
+
+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 (f0 cbmgr) uiref
+ KeyActionST f1 ->
+ -- update with IO and window ID
+ modifyIORefIO (f1 winId) uiref
+ KeyActionDG f2 ->
+ -- update with IO and cbmgr to set further callbacks
+ modifyIORefIO (f2 winId cbmgr) uiref
+ 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
+ ; let updateAction =
+ handleButtonPress winId cbmgr mouseButton x y mods timestamp
+ ; liftIO (modifyIORefIO updateAction uiref)
+ }
+
+mouseMoveCallback :: WinId -> IORef VPUI -> EventM EMotion Bool
+mouseMoveCallback winId uiref =
+ tryEvent $ do
+ {
+ (x, y) <- eventCoordinates
+ ; mods <- eventModifier
+ ; liftIO (modifyIORefIO (handleMouseMove winId x y mods) uiref)
+ }
+
+buttonReleaseCallback :: WinId -> IORef VPUI -> EventM EButton Bool
+buttonReleaseCallback winId uiref =
+ tryEvent $ do
+ {
+ mouseButton <- eventButton
+ ; liftIO (modifyIORefIO (handleButtonRelease winId mouseButton) uiref)
+ }
+
+-- | 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 -> do
+ offerContextMenu winId cbmgr frame RightButton timestamp
+ (vpuiDebugging vpui)
+ 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 -> Bool -> IO ()
+offerContextMenu winId cbmgr frame button timestamp debugging = do
+ -- Needs CBMgr to specify menu actions.
+ {
+ let menuSpec =
+ MenuSpec "Context Menu"
+ (contextMenuOptions winId cbmgr frame debugging)
+ ; 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 -> Bool -> [MenuItemSpec]
+contextMenuOptions winId cbmgr frame debugging =
+ 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 ++
+ if debugging
+ then [MenuItem "Dump frame (debug)"
+ (\ vpui -> dumpFrame vpui winId frame >> return vpui)
+ , MenuItem "Dump graph (debug)"
+ (\ vpui -> dumpGraph vpui winId >> return vpui)
+ ]
+ else []
diff --git a/Graphics/UI/Sifflet/Workspace.hs b/Graphics/UI/Sifflet/Workspace.hs
new file mode 100644
--- /dev/null
+++ b/Graphics/UI/Sifflet/Workspace.hs
@@ -0,0 +1,597 @@
+{- 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 Graphics.UI.Sifflet.Workspace
+ (
+ -- VPUI and Workspace
+ vpuiNew
+ , workspaceNewDefault
+ , workspaceNewEditing
+ , addFedWinButtons
+ , defineFunction
+ , workspaceId
+ , openNode
+
+ -- Quitting:
+ , removeWindow
+ , vpuiQuit
+
+ -- Windows:
+ , forallWindowsIO
+
+ , baseFunctionsRows
+ )
+
+where
+
+-- for debugging
+-- import System.IO.Unsafe
+
+import Control.Monad
+
+import Data.IORef
+import Data.List
+import Data.Map ((!), keys)
+import qualified Data.Map as Map (empty)
+import Data.Maybe
+
+import Data.Graph.Inductive as G
+
+import Data.Sifflet.Functoid
+import Data.Sifflet.Geometry
+import Data.Sifflet.TreeGraph
+import Data.Sifflet.TreeLayout
+import Data.Sifflet.WGraph
+
+import Language.Sifflet.Expr
+import Language.Sifflet.ExprTree
+
+import Graphics.UI.Sifflet.Callback
+import Graphics.UI.Sifflet.Canvas
+import Graphics.UI.Sifflet.EditArgsPanel
+import Graphics.UI.Sifflet.Frame
+import Graphics.UI.Sifflet.GtkUtil
+
+import Graphics.UI.Sifflet.LittleGtk
+-- FIX!!
+-- import Graphics.UI.Gtk (widgetSizeRequest, windowResize)
+
+import Graphics.UI.Sifflet.Tool
+import Graphics.UI.Sifflet.Types
+
+import Language.Sifflet.Util
+
+-- | 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 -> Bool -> IO VPUI
+vpuiNew style env debugging =
+ return VPUI {vpuiWindows = Map.empty,
+ vpuiToolkits = [],
+ vpuiFilePath = Nothing,
+ vpuiStyle = style,
+ vpuiInitialEnv = env,
+ vpuiGlobalEnv = env,
+ vpuiFileEnv = env,
+ vpuiDebugging = debugging
+ }
+
+
+
+-- | 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
+ specs = functionArgToolSpecs func
+ addNoMenu _ = return ()
+ ; workspaceNew style canvSize mViewSize specs addNoMenu
+ }
+
+-- Add the buttons for argument tools, apply, close, etc.,
+-- to a function editor window
+
+addFedWinButtons :: CBMgr -> WinId -> VPUI -> IO ()
+addFedWinButtons cbmgr winId vpui =
+ case vpuiGetWindow vpui winId of
+ VPUIWorkWin ws window ->
+ let bbar = wsButtonBar ws
+ argSpecs = wsArgToolSpecs ws
+ applyFrame :: VPUI -> IO VPUI
+ applyFrame vpui' =
+ let frames = vcFrames
+ (vpuiWindowGetCanvas
+ (vpuiGetWindow vpui' winId))
+ in case frames of
+ [] -> info "applyFrame: no frame found on canvas" >>
+ return vpui'
+ _:_:_ -> info ("applyFrame: more than one frame " ++
+ "found on canvas " ++
+ show frames) >>
+ return vpui'
+ [frame] -> defineFunction winId frame vpui'
+
+ editParametersOK :: ArgSpecAction
+ editParametersOK newSpecs =
+ cbmgr (WithUIRef (editParametersOK' newSpecs))
+ editParametersOK' newSpecs uiref =
+ do
+ stripButtonBar
+ dressButtonBar newSpecs
+ vpui' <- readIORef uiref
+ -- Maybe it should update more than just one window
+ -- here, in view of issues 36 and 31
+ -- VVV
+ let vpui'' = vpuiUpdateWindow vpui'
+ winId
+ (updateEditWindowArgSpecs newSpecs)
+ -- Should it also resize (smaller)
+ -- since the panel is being removed?
+ writeIORef uiref vpui''
+ -- redrawing must be done AFTER writing the IORef above.
+ redrawCanvas uiref winId
+
+ editParameters :: VPUI -> IO VPUI
+ editParameters vpui' =
+ do
+ {
+ let argSpecs' = vpuiWindowArgSpecs vpui' winId
+ ; argPanel <-
+ makeEditArgsPanel cbmgr argSpecs' editParametersOK
+ -- attach it to the Gtk Layout at top left
+ ; let canv = wsCanvas ws
+ layout = vcLayout canv
+ panelRoot = editArgsPanelRoot argPanel
+ ; layoutPut layout panelRoot 1 1
+
+ -- Make the layout big enough to see the whole panel
+ ; expandToFit layout panelRoot
+
+ ; return vpui'
+ }
+ addButton :: String -> CBMgrAction -> IO ()
+ addButton label action = do
+ {
+ button <- buttonNewWithLabel label
+ ; boxPackEnd bbar button PackNatural 3
+ ; widgetShow button
+ ; cbmgr (AfterButtonClicked button action)
+ }
+
+ dressButtonBar :: [ArgSpec] -> IO ()
+ dressButtonBar argSpecs' = do
+ {
+ mapM_ (addArgToolButton cbmgr winId bbar) argSpecs'
+ ; addButton "Close" (\ _uiref -> widgetDestroy window)
+ ; addButton "Parameters" (modifyIORefIO editParameters)
+ ; addButton "Apply" (modifyIORefIO applyFrame)
+ }
+
+ stripButtonBar :: IO ()
+ stripButtonBar = do
+ {
+ -- the buttons should be the only children
+ children <- containerGetChildren bbar
+ ; mapM_ widgetDestroy children
+ }
+
+ in dressButtonBar argSpecs
+
+ FunctionPadWindow _ _ -> return () -- should not happen
+
+vpuiWindowArgSpecs :: VPUI -> WinId -> [ArgSpec]
+vpuiWindowArgSpecs vpui winId =
+ case vpuiGetWindow vpui winId of
+ VPUIWorkWin ws _ -> wsArgToolSpecs ws
+ FunctionPadWindow _ _ -> [] -- should not happen
+
+-- | Update an Edit Function window after the "Inputs" dialog,
+-- which might have given it some new ArgSpec's.
+-- In the resulting VPUIWindow, no node inlets or inputs than
+-- its new arity.
+
+updateEditWindowArgSpecs :: [ArgSpec] -> VPUIWindow -> VPUIWindow
+updateEditWindowArgSpecs newSpecs vwin =
+ case vwin of
+ VPUIWorkWin ws0 window ->
+ let canv0 = wsCanvas ws0
+ graph0 = vcGraph canv0
+ argNames = map argName newSpecs
+ in case vcFrames canv0 of
+ [frame0] ->
+ let foid0 = cfFunctoid frame0
+ fnodes0 = fpNodes foid0 :: [G.Node]
+
+ -- Filter out symbol nodes of any removed arguments
+ validNames =
+ "if" : (argNames ++ envSymbols (cfEnv frame0))
+ validNode' :: G.Node -> Bool
+ validNode' = validNode graph0 validNames
+
+ fnodes1 = filter validNode' fnodes0
+ foid1 = foid0 {fpNodes = fnodes1,
+ fpArgs = argNames} -- redundant args here
+ frame1 = frame0 {cfVarNames = argNames, -- and here
+ cfFunctoid = foid1}
+ graph1 = nfilter validNode' graph0
+
+ -- Eliminate excess inlets and edges
+ -- due to reduced arity of functional arguments
+ style = vcStyle canv0
+ graph2 = wLimitOuts style newSpecs graph1
+ -- Frame node adopts orphaned nodes so they are
+ -- not invisible
+ orphans = filter (isWSimple . fromJust . lab graph2)
+ (graphOrphans graph2)
+ graph3 =
+ adoptChildren graph2 (cfFrameNode frame1) orphans
+
+ -- plug back into larger structures
+ canv1 = canv0 {vcGraph = graph3, vcFrames = [frame1]}
+ ws1 = ws0 {wsArgToolSpecs = newSpecs, wsCanvas = canv1}
+ in VPUIWorkWin ws1 window
+ _ -> vwin -- shouldn't happen
+ FunctionPadWindow _ _ -> vwin -- shouldn't happen
+
+
+-- | Given a WGraph and a list of valid symbols, a node is valid
+-- if it is an ExprNode ... labeled with one of the valid symbols
+--
+-- (This function is only used above, in updateEditWindowArgSpecs)
+validNode :: WGraph -> [String] -> G.Node -> Bool
+validNode g validNames n =
+ case G.lab g n of
+ Nothing -> False
+ Just (WFrame _) -> True
+ Just (WSimple loNode) ->
+ let ENode nodeLabel _ = gnodeValue (nodeGNode loNode)
+ in case nodeLabel of
+ NSymbol (Symbol name) -> name `elem` validNames
+ _ -> True
+
+
+-- | Require a node to have <= n inlets in the node
+-- and <= n successors in the graph, where
+-- n is specified in a list of ArgSpec
+
+wLimitOut :: Style -> [ArgSpec] -> WGraph -> Node -> WGraph
+wLimitOut style specs g v =
+ let ordered :: Adj WEdge -> Adj WEdge
+ ordered = sortBy compareAdj
+ compareAdj (WEdge i, _nodei) (WEdge j, _nodej) = compare i j
+ in case match v g of
+ (Nothing, _) -> g
+ (Just (ins, _v, wnode, outs), g') ->
+ -- wnode is the graph-node's "label"
+ case wnode of
+ WFrame _ -> g
+ WSimple lonode@(LayoutNode {nodeGNode = gnode}) ->
+ let ENode eLabel _ = gnodeValue gnode -- :: ExprNode
+ in case eLabel of
+ NSymbol (Symbol name) ->
+ case aspecsLookup name specs of
+ Nothing -> g
+ Just n ->
+ let (inlets, _) =
+ makeIolets style
+ (gnodeNodeBB gnode)
+ (n, 1)
+ gnode' = gnode {gnodeInlets = inlets}
+ wnode' =
+ WSimple (lonode {nodeGNode = gnode'})
+ in (ins, v, wnode', take n (ordered outs)) &
+ g'
+ _ -> g
+
+-- | Like wLimitOut, but applies to a whole graph
+wLimitOuts :: Style -> [ArgSpec] -> WGraph -> WGraph
+wLimitOuts style specs g = foldl (wLimitOut style specs) g (nodes g)
+
+-- | Redraw the entire canvas of a given window
+redrawCanvas :: IORef VPUI -> WinId -> IO ()
+redrawCanvas uiref winId = do
+ {
+ vpui <- readIORef uiref
+ ; let mcanvas = vpuiTryGetWindow vpui winId >>= vpuiWindowLookupCanvas
+ ; case mcanvas of
+ Nothing -> return ()
+ Just canvas ->
+ case vcFrames canvas of
+ [] -> return ()
+ frame:_ -> vcInvalidateBox canvas (cfBox frame)
+ }
+
+addArgToolButton :: CBMgr -> WinId -> HBox -> ArgSpec -> IO ()
+addArgToolButton cbmgr winId buttonBox (ArgSpec label n) = do
+ {
+ button <- buttonNewWithLabel label
+ ; boxPackStart buttonBox button PackNatural 3 -- spacing between buttons
+ ; widgetShow button
+ ; cbmgr (AfterButtonClicked button
+ (modifyIORefIO (vpuiSetTool (ToolArg label n) winId)))
+ ; return ()
+ }
+
+
+-- | 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 =
+ fst (frameNewWithLayout style (Position 0 0) 0
+ (FunctoidFunc func) Nothing
+ CallFrame -- mode may change below
+ 0 prevEnv Nothing)
+
+-- | 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 -> [ArgSpec]
+ -> (VBox -> IO ())
+ -> IO Workspace
+workspaceNew style canvSize mViewSize argSpecs 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 argSpecs)
+}
+
+
+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
+ }
+
+workspaceId :: String
+workspaceId = "Sifflet Workspace"
+
+-- | 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 =
+ case vpuiTryGetWindow vpui workspaceId 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 workspaceId 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/ISSUES b/ISSUES
new file mode 100644
--- /dev/null
+++ b/ISSUES
@@ -0,0 +1,403 @@
+ISSUES
+======
+
+Issues for sifflet and sifflet-lib
+
+This is the ISSUES file for both sifflet and sifflet-lib.
+If you are editing it, be sure you are editing the original
+and not the copies in the app and lib subdirectories.
+
+O = date opened
+R = reporter
+P = priority
+C = closed
+
+OPEN ISSUES
+-----------
+
+41 next issue bug number
+
+40 Duplicate arguments in "Edit Arguments"
+
+ Adding a duplicate argument in the "Edit Arguments" dialog
+ is possible (for example, two arguments named "f").
+ It should not be.
+ O: 2012 July 2
+ R: gdw
+ P: medium
+
+39 No lambda tool
+
+ There is no lambda tool, and since partial application doesn't work
+ (issue 32), this means there is no way to have a function return a function.
+ O: 2012 jul 2
+ R: gdw
+ P: medium
+
+38 Working directory
+
+ Sifflet should have some sense of its working directory,
+ for convenience of opening and saving files
+ O: 2012 july 2
+ R: gdw
+ P: medium
+
+37 Changing helper function definition does not affect displayed function call
+
+ See f2 and testF2 in ../examples/map.sfl
+ When testF2 is called on the workspace, and you edit and chagne f2,
+ apply the new definition, the displayed call is not re-evaluated
+ using the new definition. In fact if you use the displayed
+ testF2 frame to call again, it still uses the old definition --
+ it seems permanently bound to it. To use the new definition
+ of f2, you have to place a new copy of testF2 on the workspace.
+
+ O: 2012 Jun 27
+ R: gdw
+ P: low
+
+36 Cascade effect of changing kind of arguments to a function.
+
+ When we change the number of type (kind) of the arguments of
+ a function, we also change the function's type (or kind); and if
+ it's used in the definitions of other functions, then they may
+ become invalid in turn -- what should be done in this case?
+ O: 2012 Jun 27
+ R: gdw
+ P: medium
+
+33 testMapSumFromZero (see ../examples/map.sfl)
+ In testMapSumFromZero n, with n = [1,2],
+ opening the sumFromZero node displays bogus error messages
+ as though it is a call to sumFromZero with n = [1,2].
+ In fact, the node has no input, so there is no call
+ to sumFromZero until we get into map.
+ The problem doesn't occur with recursive functions.
+ It must be because the node has an inlet that expects n,
+ and finds n in the enclosing environment although it is not called.
+ O: 2012 June 22
+ R: gdw
+ P: low
+
+32 Partial application does not work
+ (e.g., calling the + function with one argument)
+ Comment: See also #39.
+ O: 2012 Jun 21
+ R: gdw
+ P: medium
+
+31 Edit function inputs: when an argument tool is selected,
+ and you change the arity of that argument, the next click
+ of the tool puts the argument down on the canvas with its
+ *old* arity; should be the new arity.
+ Comment: A work-around is to reselect the tool to get the right arity.
+ O: 2012 Jun 21
+ R: gdw
+ P: medium
+
+26 EditArgsPanel: TAB fails to move the cursor to the next field.
+ O: 2011 Jun 23
+ R: gdw
+ P: medium-high
+
+25 Nodes lose unused inlets when applying a function definition.
+ - Suppose the f node has two inlets, but none of them are
+ used by any f nodes in the definition. Then when you apply the
+ definition, all the f nodes lose both of their inlets.
+ On the other hand, if one f node uses none of its two inlets
+ and another uses both, then when you apply the definition,
+ both of them keep both of their inlets.
+ O: 2011 Jun 23
+ R: gdw
+ P: lowest.
+ Comment:
+ This seems not really to be a problem. If NONE of the f nodes
+ use their inlets, then why do they have inlets, anyway?
+ Besides, it should become irrelevant when a new UI is
+ developed without the circular inlets, as in issue 24.
+ Comment: The inlets will reappear if you reopen the "inputs"
+ dialog and then click "OK".
+
+24 Arguments are shifted when applying a function definition.
+ - If a node has 3 inlets and connections on inlets 1 and 2,
+ but not on 0, then when "apply" is clicked the connections are
+ shifted to inlets 0 and 1, leaving 2 open.
+ O: 2011 Jun 23
+ R: gdw
+ P: lowest.
+ This should become irrelevant when and if I develop a new
+ UI that does away with the circular inlets. Why not just
+ let the user make as many connections as they please? And
+ that would get rid of the need for a dialog that lets you
+ change the number of inlets too.
+
+23 typeToXml fails for (TypeCons Function)
+ O: 2011 Jun 23
+ R: gdw
+ P: medium
+
+22 When you connect an input to the second (or generally not first)
+ input port of a node, and leave the first "open", then click on
+ apply, the input is reconnected to the first port instead of the
+ second.
+ -- Is this actually a bug?
+ O: 2011 Jun 2
+ R: gdw
+ P: ???
+
+14 If two frames overlap, then clicks on the top frame
+ sometimes are interpreted as clicks on the lower (hidden) frame.
+ O: 2010 aug 16
+ P: low
+
+13 If you change any of the *example* functions and quit or open,
+ Sifflet prompts you to save changes, but it does not save
+ these particular changes, since they are not in "My Functions".
+ Probably need to re-design the whole organization of examples
+ and my functions, introduce modules associated with files,
+ and show each in its own panel.
+ Opened 2010 May 27.
+ Priority: low
+
+11 When function f, which calls function g, is on the workspace,
+ and you edit g, the changes do not propagate back to f, so that
+ calling f results in calling the *old* g.
+ Example: open test-champ.siff, place two-lovely on the workspace,
+ call it with any argument, edit lovely, apply, call two-lovely
+ again.
+ Opened 2010 May 20.
+ Priority: medium
+
+* * *
+
+CLOSED ISSUES
+-------------
+
+
+1 After using the literal tool, etc., the program stops responding
+ to key presses in the workspace.
+ Opened ??
+ Closed 2009 Oct 5.
+
+2 Fix resize frame
+ Opened ??
+ Closed 2009 Oct 13.
+
+3 Quitting (q and File/quit) should actually quit!
+ Opened ??
+ Closed 2009 Oct 13.
+
+4 vpTypeOf fails for [].
+ Opened ??
+ Closed 2009 Oct 30.
+
+5 Deleting a node leaves its children orphans.
+ Opened ??
+ Closed 2009 Nov 4.
+
+6 After closing "My functions" window and re-opening it,
+ it should "remembers" the function tools that it had when closed,
+ instead of showing up as a blank window.
+ Opened ??
+ Closed 2009 Nov 11
+
+7 If function pad window is closed, then creating a
+ new function results in a "key not found" error.
+ Opened ??
+ Closed 2010 March 1
+
+8 Opening a file twice put duplicate tools in
+ "My Functions" window (and toolkit, presumably).
+ Opened ??
+ Closed 2010 May 13
+
+9 After the dialog suggesting save changes before quitting or
+ opening a new file, the program crashes due to a bug in
+ Gtk2hs 0.10.0 and 0.10.1 (but fixed in gtk2hs darcs).
+ Opened ??
+ Closed 2010 May 20.
+
+10 Evaluating a call frame with zero arguments
+ opens an unnecessary dialog (there are not arguments,
+ so no values needed); moreover, it does not evaluate
+ the function call.
+
+15 In the test function list_of_2, evaluating [] results in
+ "error: unbound variable: []". Ditto repeat_a_b.
+ O: 2010 aug 16
+ P: high
+ C: 2010 aug 16 -- fixed.
+
+16 Editing a function, if you enter the literal ["a", "b"],
+ the program crashes with this message:
+ sifflet-new-expr: makeFixedLiteralTool:
+ non-empty list expression EList [EString "a",EString "b"]
+ O: 2010 aug 16
+ P: high
+ C: 2010 aug 16 -- fixed.
+
+
+17 There is an error in reading a non-empty list element from
+ a SiffML file, e.g.,
+
+
+ a
+ b
+
+
+ due to the fact that the children of the element
+ directly represent values, not expressions, so they are
+ not read correctly (not read at all?) by xmlToExpr.
+ I think I need to use xmlToValue here, but how to connect
+ the two is not easy.
+ In the long run, it is desirable to change the XML doctype,
+ dropping the element so that strings would be
+ e.g. just a
+ and lists would be just e.g.
+
+ a
+ b
+
+ O: 2010 aug 17
+ P: highest
+ C: 2010 aug 17 -- fixed.
+
+19 Closing all program windows leaves executable still running
+ but no way to kill it (Ctrl+C is a no-op).*
+ O: 2010 nov 3
+ R: Andrew Coppin andrewcoppin@btinternet.com
+ P: HIGH
+ C: 2010 dec 9 (actually fixed dec 3): closing the workspace window
+ now "safely" quits from the application.
+
+20 Amend documentation/home page to note that installation on
+ Windows without curl is now definitely feasible
+ O: 2010 nov 3
+ R: Andrew Coppin andrewcoppin@btinternet.com
+ P: medium
+ C: 2010 dec 9 (actually fixed dec 3)
+
+21 Define adds list =
+ if null list
+ then 0
+ else if head list
+ then + list 1
+ else tail (head list)
+ Call the function with list = [1]
+ Sifflet crashes with this error message:
+ evalTreeWithLimit (if): unexpected test result
+ O: 2010 dec 9
+ R: Charles Turner III (turnchan@iue.edu)
+ P: high
+ C: 2010 dec 9
+
+29 typedValue (in Parser.hs) has two conditions that result in
+ run-time errors. For testing higher-order functions, it would
+ be good to be able to type in the name of a function in the global
+ environment, but we don't have access to the environment here,
+ do we? Also in case of failure, it should fail with an error
+ message but not crash sifflet.
+ O: 2012 Jun 15
+ R: gdw
+ P: high
+ Crashes program.
+ C: 2012 June 21 -- fixed.
+
+30 typeToXml: program crashes when saving the map function definition,
+ with message:
+ sifflet-devel: typeToXml: TypeCons Function cannot be converted to XML.
+ Notes:
+ 1. typeToXml is fixed, but now I also need to fix the corresponding
+ part of xmlToType so the file can be read back in.
+ 2. Maybe better still:
+ Why do we need the types in the XML file anyway, now that
+ we have type inference?
+ 3. Also revise schema/DTD for SiffML files.
+ O: 2012 Jun 21
+ R: gdw
+ P: highest - program crash
+ C: 2012 June 22, fixed.
+
+28 EditArgsPanel should change inlets for existing nodes when the arg's
+ kind is changed.
+ - Suppose you change the number of parameters for argument f.
+ Then any existing f nodes on the drawing should have their
+ number of inlets changed correspondingly.
+ Currently this works if the number is increased, but
+ fails if it is decreased and there are now too many
+ connected children in the graph --> error in graphRenderTree.
+ Unfortunately, this is not the place where that can be fixed:
+ even if I reduce nto or nfrom in this context,
+ there are still the contexts in the connected children to
+ consider.
+ - Also, when extra inputs are disconnected (as they should be)
+ they are sometimes also deleted from the canvas (shouldn't be).
+ O: 2011 Jun 23
+ R: gdw
+ P: highest. Crashes program.
+ C: 2012 Jun 27, fixed.
+
+
+18 Sifflet crashes when applying a function if some connections
+ are missing.
+
+ "PS. I presume you know that you can crash the whole of Sifflet by
+ something as trivial as hitting the "apply" button when some
+ connections are missing, and that closing all of the program windows
+ leaves the executable still running but with no way to kill it. (I'm
+ not sure why Ctrl+C is no-op...)"
+ -- email from Andrew Coppin, 2010 Nov 01.
+
+ O: 2010 nov 3
+ R: Andrew Coppin andrewcoppin@btinternet.com
+ P: HIGH
+ C: 2012 Jun 27 -- unable to duplicate either part of this at this time;
+ must have been fixed earlier. Though it might be that the
+ "no way to kill it" issue persists on MS Windows.
+
+35 vcCloseFrame does not remove the frame's subgraph from the canvas graph.
+
+ vcCloseFrame removes only the WFrame node, not the WSimple nodes
+ displayed in the frame. It should remove all of them, otherwise
+ clutter builds up every time a function definition is applied,
+ since the apply command calls vcCloseFrame and then vcAddFrame.
+ O: 2012 Jun 27
+ R: gdw
+ P: high
+ C: 2012 Jun 27 fixed.
+
+12 Four tests fail in testall -u.
+ These seem to all involve issues of text node size
+ and are pretty minor, so maybe the tests need to be
+ fine-tuned to allow for variations in what Cairo says
+ is the text's dimensions.
+ Opened 2010 May 24
+ Priority: medium
+ C: 2012 Jul 2, previously fixed but not closed; all unit tests now pass.
+
+34 In edit function / edit arguments: the edit window sometimes
+ does not sufficiently increase in size,
+ so the edit arguments buttons (OK, cancel)
+ are hidden by the edit function buttons (args, apply, inputs, close).
+ Comment: see darcs change:
+ Tue Jun 7 12:40:24 EDT 2011 gdweber@iue.edu
+ * Crude window resizing to fit as the EditArgsPanel grows
+ - crude because it does not take into account the button bar
+ below the panel
+ Comment: duplicate of #27
+ O: 2012 June 26
+ R: gdw
+ P: top
+ C: 2012 jul 2, fixed
+
+27 EditArgsPanel: window resizing is bad.
+ - Sometimes the window does not expand enough to show the
+ panel's buttons.
+ - Sometimes it shrinks back too much after the panel is closed.
+ - Comment: lib/Graphics/UI/Sifflet/EditArgsPanel.hs
+ Workspace.hs : 138
+
+ O: 2011 Jun 23
+ R: gdw
+ P: top
+ C: 2012 jul 2, fixed
diff --git a/Language/Sifflet/Examples.hs b/Language/Sifflet/Examples.hs
new file mode 100644
--- /dev/null
+++ b/Language/Sifflet/Examples.hs
@@ -0,0 +1,277 @@
+module Language.Sifflet.Examples
+ (exampleFunctions
+ , exampleFunctionNames
+ , exampleEnv
+ , foo, eFoo -- used in Testing.Unit.ExprTests
+ , eMax -- ditto
+ , eFact -- ditto
+ , getExampleFunction
+ )
+
+where
+
+import Language.Sifflet.Expr
+
+-- TEST COMPOUND FUNCTIONS
+
+-- | grossProfit salesA salesB = 0.12 salesA + 0.25 salesB
+
+grossProfit :: Function
+grossProfit =
+ Function (Just "grossProfit") [typeNum, typeNum] typeNum
+ (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") [typeNum] typeNum
+ (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") [typeNum, typeNum] typeNum
+ (Compound ["salesA", "salesB"]
+ (eCall "bonus1" [eCall "grossProfit" [eSymbol "salesA",
+ eSymbol "salesB"]]))
+
+-- | foo a b = 2 * a + b
+foo :: Function
+foo = Function (Just "foo") [typeNum, typeNum] typeNum
+ (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") [typeNum, typeNum] typeNum
+ (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") [typeNum] typeNum
+ (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") [typeNum] typeNum
+ (Compound ["n"]
+ (eIf (eZerop en)
+ (eInt 0)
+ (ePlus en (eSumFromZero (eSub1 en)))))
+
+buggySumFromZero :: Function
+buggySumFromZero =
+ let body = ePlus (eSym "n")
+ (eCall "buggySumFromZero"
+ [eMinus (eSym "n") (eInt 1)])
+ in Function (Just "buggySumFromZero") [typeNum] typeNum
+ (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") [typeNum] typeNum
+ (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") [typeNum, typeNum] typeNum
+ (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") [typeNum, typeNum] typeNum
+ (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?") [typeNum] typeBool
+ (Compound ["n"]
+ (eIf (eZerop en)
+ eTrue
+ (eOddp (eSub1 en))))
+
+oddp = let en = eSymbol "n"
+ in Function (Just "odd?") [typeNum] typeBool
+ (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") [typeNum] typeNum
+ (Compound ["month"]
+ (ePlus (eRabbitBabies m) (eRabbitAdults m)))
+
+rabbitAdults = let m = eSymbol "month"
+ zero = eInt 0
+ one = eInt 1
+ in Function (Just "rabbitAdults") [typeNum] typeNum
+ (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") [typeNum] typeNum
+ (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")
+ [typeList (TypeVar "e1")] typeNum
+ (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")
+ [typeList (TypeVar "e1")] typeNum
+ (Compound ["xs"]
+ (eIf (eCall "null" [xs])
+ zero
+ (ePlus one
+ (eCall "length"
+ [eCall "tail" [xs]]))))
+
+listSum :: Function
+listSum =
+ Function (Just "sum") [typeList typeNum] typeNum
+ (Compound ["xs"] sumbody)
+
+sumbody :: Expr
+sumbody =
+ eIf (eCall "null" [eSym "xs"])
+ (eInt 0)
+ (ePlus (eCall "head" [eSym "xs"])
+ (eCall "sum" [eCall "tail" [eSym "xs"]]))
+
+buggySum :: Function
+buggySum = let xs = eSymbol "xs"
+ in Function (Just "buggySum")
+ [typeList typeNum] typeNum
+ (Compound ["xs"]
+ -- missing "if" and base case
+ (ePlus (eCall "head" [xs])
+ (eCall "buggySum" [eCall "tail" [xs]])))
+
+exampleFunctions :: [Function]
+exampleFunctions = [grossProfit, bonus1, bonus2
+ , foo, Language.Sifflet.Examples.max
+ , fact, sumFromZero, rmul, fib1
+ , Language.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/Language/Sifflet/Export/Exporter.hs b/Language/Sifflet/Export/Exporter.hs
new file mode 100644
--- /dev/null
+++ b/Language/Sifflet/Export/Exporter.hs
@@ -0,0 +1,192 @@
+module Language.Sifflet.Export.Exporter
+ (Exporter
+ , simplifyExpr
+ , commonRuleHigherPrec
+ , commonRuleAtomic
+ , commonRuleLeftToRight
+ , commonRuleAssocRight
+ , commonRuleFuncOp
+ , commonRulesForSimplifyingExprs
+ , ruleIfRight
+ , ruleRightToLeft
+ , applyFirstMatch
+ , findFixed
+ )
+
+where
+
+import Language.Sifflet.Expr
+
+-- | The type of a function to export (user) functions to a file.
+type Exporter = Functions -> FilePath -> IO ()
+
+-- | Simplify an expression by applying rules
+-- top-down throughout the expression
+-- tree and repeatedly until there is no change.
+-- This is intended for removing extra parentheses,
+-- but could be used for other forms of simplification.
+--
+-- Should each rule also know the level in the original expr tree,
+-- with 0 = top level (root)?
+-- That would require additional arguments.
+
+simplifyExpr :: [Expr -> Expr] -> Expr -> Expr
+simplifyExpr rules expr =
+ findFixed (topDown (applyFirstMatch rules)) expr
+
+-- | Repeatedly apply a function to an object until there is no change,
+-- that is, until reaching a fixed point of the function, a point
+-- where f x == x.
+
+findFixed :: (Eq a) => (a -> a) -> a -> a
+findFixed f x =
+ let x' = f x
+ in if x' == x then x else findFixed f x'
+
+
+-- | Common rules for simplifying parentheses.
+
+-- | Remove ()'s around a higher precedence operator: e.g.,
+-- (a * b) + c ==> a * b + c
+-- a + (b * c) ==> a + b * c
+
+commonRuleHigherPrec :: Expr -> Expr
+commonRuleHigherPrec e =
+ case e of
+ EOp op1 (EGroup (EOp op2 subleft subright)) right ->
+ -- left side
+ if opPrec op2 > opPrec op1
+ then EOp op1 (EOp op2 subleft subright) right
+ else e
+ EOp op1 left (EGroup (EOp op2 subleft subright)) ->
+ -- right side
+ if opPrec op2 > opPrec op1
+ then EOp op1 left (EOp op2 subleft subright)
+ else e
+ _ -> e
+
+-- | Remove ()'s around an atomic expression -- a variable,
+-- literal, or list
+
+commonRuleAtomic :: Expr -> Expr
+commonRuleAtomic e =
+ case e of
+ EGroup e' ->
+ if exprIsAtomic e'
+ then e'
+ else e
+ _ -> e
+
+-- | Remove ()'s in the case of (a op1 b) op2 c,
+-- if op1 and op2 have the same precedence, and
+-- both group left to right, since
+-- left to right evaluation makes them unnecessary.
+
+commonRuleLeftToRight :: Expr -> Expr
+commonRuleLeftToRight e =
+ case e of
+ EOp op2 (EGroup (EOp op1 a b)) c ->
+ if opPrec op1 == opPrec op2 &&
+ opGrouping op1 == GroupLtoR &&
+ opGrouping op2 == GroupLtoR
+ then EOp op2 (EOp op1 a b) c
+ else e
+ _ -> e
+
+-- | Remove ()'s in the case of a op (b op c)
+-- if op groups right to left, and note that
+-- it is the same operator op in both places
+-- (though I don't know if that restriction is necessary).
+-- This applies to (:) in Haskell, for example:
+-- x : y : zs == x : (y : zs)
+
+ruleRightToLeft :: Expr -> Expr
+ruleRightToLeft e =
+ case e of
+ EOp op1 a (EGroup (EOp op2 b c)) ->
+ if op1 == op2 && opGrouping op1 == GroupRtoL
+ then EOp op1 a (EOp op2 b c)
+ else e
+ _ -> e
+
+-- Associativity on the right
+-- x + (y + z) --> x + y + z
+-- for + and all other associative operators.
+-- We could add, the left-hand rule
+-- (x + y) + z --> x + y + z
+-- but do not need it,
+-- because it is already covered by the left to right rule
+-- for operators of equal precedence.
+-- It must be the SAME operator on both sides, of course!
+
+commonRuleAssocRight :: Expr -> Expr
+commonRuleAssocRight e =
+ case e of
+ EOp op1 a (EGroup (EOp op2 b c)) ->
+ if op1 == op2 && opAssoc op1
+ then EOp op1 a (EOp op2 b c)
+ else e
+ _ -> e
+
+-- An if expression as the right operand can be unparenthesized.
+-- but not so on the left (at least in Haskell):
+-- x + (if ...) --> x + if ...
+-- but NOT
+-- (if ...) + x --> if ... + x (NOT!)
+
+ruleIfRight :: Expr -> Expr
+ruleIfRight e =
+ case e of
+ EOp op a (EGroup i@(EIf _ _ _)) -> EOp op a i
+ _ -> e
+
+-- In Haskell, a function application has precedence over all
+-- operators. This applies in both the left and right operands.
+
+commonRuleFuncOp :: Expr -> Expr
+commonRuleFuncOp e =
+ case e of
+ EOp op a (EGroup c@(ECall _ _)) -> EOp op a c
+ EOp op (EGroup c@(ECall _ _)) b -> EOp op c b
+ _ -> e
+
+-- | A list of common rules for simplifying expressions.
+-- Does *not* include ruleIfRight, since that works
+-- for Haskell but not Python.
+
+commonRulesForSimplifyingExprs :: [Expr -> Expr]
+commonRulesForSimplifyingExprs =
+ [commonRuleHigherPrec
+ , commonRuleAtomic
+ , commonRuleLeftToRight
+ , commonRuleAssocRight
+ , commonRuleFuncOp]
+
+-- | Try the first rule in a list to see if it changes an expression,
+-- returning the new expression if it does; otherwise, try the next rule,
+-- and so on; if no rule changes the expression, then return the expression.
+-- (Note that (applyFirstMatch rules) is itself a rule.)
+
+applyFirstMatch :: [Expr -> Expr] -> Expr -> Expr
+applyFirstMatch [] e = e
+applyFirstMatch (r:rs) e =
+ let e' = r e
+ in if e' /= e
+ then e'
+ else applyFirstMatch rs e
+
+-- | Apply a rule top-down to all levels of an expression.
+-- Normally, the "rule" would be a value of (applyFirstMatch rules).
+topDown :: (Expr -> Expr) -> Expr -> Expr
+topDown f e =
+ let tdf = topDown f
+ e' = f e
+ in case e' of
+ EIf c a b -> EIf (tdf c) (tdf a) (tdf b)
+ EList xs -> EList (map tdf xs)
+ ELambda x body -> ELambda x (tdf body)
+ ECall fsym args -> ECall fsym (map tdf args)
+ EOp op left right -> EOp op (tdf left) (tdf right)
+ EGroup e'' -> EGroup (tdf e'')
+ _ -> e'
+
diff --git a/Language/Sifflet/Export/Haskell.hs b/Language/Sifflet/Export/Haskell.hs
new file mode 100644
--- /dev/null
+++ b/Language/Sifflet/Export/Haskell.hs
@@ -0,0 +1,159 @@
+-- | Abstract syntax tree and pretty-printing for Haskell 98.
+-- This is only a small subset of the Haskell 98 syntax,
+-- so we do not need to pull in haskell-src and all its complexity.
+-- Moreover, haskell-src gives too little control over the format
+-- of pretty-printed text output.
+
+module Language.Sifflet.Export.Haskell
+ (HsPretty(..)
+ , Module(..)
+ , ExportSpec(..)
+ , ImportDecl(..)
+ , Decl(..)
+ , operatorTable
+ )
+
+where
+
+import Data.List (intercalate)
+import qualified Data.Map as M
+
+import Language.Sifflet.Expr
+import Text.Sifflet.Pretty
+
+class HsPretty a where
+
+ hsPretty :: a -> String
+
+ hsPrettyList :: String -> String -> String -> [a] -> String
+ hsPrettyList pre tween post xs =
+ pre ++ intercalate tween (map hsPretty xs) ++ post
+
+instance HsPretty Symbol where
+ hsPretty = pretty
+
+instance HsPretty Operator where
+ hsPretty = pretty
+
+-- | A Haskell module; moduleDecls are functions and variables.
+
+data Module = Module {moduleName :: String
+ , moduleExports :: Maybe ExportSpec
+ , moduleImports :: ImportDecl
+ , moduleDecls :: [Decl]
+ }
+ deriving (Eq, Show)
+
+instance HsPretty Module where
+ hsPretty m =
+ let pmod = "module " ++ moduleName m
+ pexports = case moduleExports m of
+ Nothing -> ""
+ Just exports -> hsPretty exports
+ pimports = hsPretty (moduleImports m)
+ pdecls = sepLines2 (map hsPretty (moduleDecls m))
+ in unlines [pmod ++ " where",
+ pexports,
+ pimports,
+ pdecls]
+
+-- | A Haskell module's export spec: a list of function and
+-- variable identifiers
+newtype ExportSpec = ExportSpec [String]
+ deriving (Eq, Show)
+
+instance HsPretty ExportSpec where
+ hsPretty (ExportSpec exports) =
+ "(" ++ sepCommaSp exports ++ ")"
+
+-- | A Haskell modules import decls: a list of module identifiers.
+-- No support for "qualified" or "as" or for selecting only some
+-- identifiers from the imported modules.
+
+newtype ImportDecl = ImportDecl [String]
+ deriving (Eq, Show)
+
+instance HsPretty ImportDecl where
+ hsPretty (ImportDecl modnames) =
+ let idecl modname = "import " ++ modname
+ in unlines (map idecl modnames)
+
+-- | Wrap a string in parentheses
+par :: String -> String
+par s = "(" ++ s ++ ")"
+
+-- | A Haskell function or variable declaration.
+-- An explicit type declaration is optional.
+-- Thus we have just enough for
+-- name :: type
+-- name [args] = expr.
+-- Of course [args] would be empty if it's just a variable.
+data Decl = Decl {declIdent :: String
+ , declType :: Maybe [String]
+ , declParams :: [String]
+ , declExpr :: Expr
+ }
+ deriving (Eq, Show)
+
+instance HsPretty Decl where
+ hsPretty decl =
+ let ptypeDecl = "" -- to be improved **
+ pparams = case declParams decl of
+ [] -> ""
+ params -> " " ++ sepSpace params
+ pbody = hsPretty (declExpr decl)
+ in ptypeDecl ++
+ declIdent decl ++ pparams ++ " =\n" ++
+ " " ++ pbody
+
+-- | HsPretty expressions. This is going to be like in Python.hs.
+instance HsPretty Expr where
+ hsPretty pexpr =
+ case pexpr of
+ EUndefined -> "undefined"
+ EChar c -> show c
+ ENumber n -> show n
+ EBool b -> show b
+ EString s -> show s
+ ESymbol sym -> hsPretty sym
+ EList xs -> hsPrettyList "[" ", " "]" xs
+ EIf c a b ->
+ unwords ["if", hsPretty c, "then", hsPretty a, "else", hsPretty b]
+ EGroup e -> par (hsPretty e)
+ ELambda (Symbol x) body ->
+ unwords ["\\", x, "->", hsPretty body]
+ EApp fexpr argexpr ->
+ hsPretty fexpr ++ " " ++ hsPretty argexpr
+ ECall fexpr argExprs ->
+ hsPretty fexpr ++ " " ++ hsPrettyList "" " " "" argExprs
+ EOp op left right ->
+ unwords [hsPretty left, hsPretty op, hsPretty right]
+
+-- | The Haskell operators.
+-- Now what about the associativity of (:)?
+-- It really doesn't even make sense to ask if (:) is
+-- associative in the usual sense,
+-- since (x1 : x2) : xs == x1 : (x2 : xs)
+-- is not only untrue, but the left-hand side is
+-- a type error, except maybe in some very special cases
+-- (and then the right-hand side would probably be a type error).
+-- Is (:) what is called a "right-associative" operator?
+-- And do I need to expand my Operator type to
+-- include this? And then what about (-) and (/)???
+-- Does this affect their relationship with (+) and (-)?
+
+operatorTable :: M.Map String Operator
+operatorTable =
+ M.fromList (map (\ op -> (opName op, op))
+ [ Operator "*" 7 True GroupLtoR -- times
+ , Operator "+" 6 True GroupLtoR -- plus
+ , Operator "-" 6 False GroupLtoR -- minus
+ , Operator ":" 5 False GroupRtoL -- cons
+ , Operator "==" 4 False GroupNone -- eq
+ , Operator "/=" 4 False GroupNone -- ne
+ , Operator ">" 4 False GroupNone -- gt
+ , Operator ">=" 4 False GroupNone -- ge
+ , Operator "<" 4 False GroupNone -- lt
+ , Operator "<=" 4 False GroupNone -- le
+ ])
+
diff --git a/Language/Sifflet/Export/Python.hs b/Language/Sifflet/Export/Python.hs
new file mode 100644
--- /dev/null
+++ b/Language/Sifflet/Export/Python.hs
@@ -0,0 +1,198 @@
+-- | 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 Language.Sifflet.Export.Python
+ (PyPretty(..)
+ , PModule(..)
+ , PStatement(..)
+ , alterParens
+ , ret
+ , condS
+ , var
+ , ident
+ , char
+ , fun
+ , operatorTable
+ )
+
+where
+
+import Data.List (intercalate)
+import qualified Data.Map as M
+
+import Language.Sifflet.Expr
+import Text.Sifflet.Pretty
+
+class PyPretty a where
+
+ pyPretty :: a -> String
+
+ pyPrettyList :: String -> String -> String -> [a] -> String
+ pyPrettyList pre tween post xs =
+ pre ++ intercalate tween (map pyPretty xs) ++ post
+
+pyPrettyParens :: (PyPretty a) => [a] -> String
+pyPrettyParens = pyPrettyList "(" ", " ")"
+
+instance PyPretty Symbol where
+ pyPretty = pretty
+
+instance PyPretty Operator where
+ pyPretty = pretty
+
+-- | Python module -- essentially a list of statements;
+-- should it also have a name?
+newtype PModule = PModule [PStatement]
+ deriving (Eq, Show)
+
+instance PyPretty PModule where
+ pyPretty (PModule ss) = sepLines2 (map pyPretty ss)
+
+-- | Python statement
+data PStatement = PReturn Expr
+ | PImport String -- ^ import statement
+ | PCondS Expr
+ PStatement
+ PStatement -- ^ if condition action alt-action
+ | PFun Symbol
+ [Symbol]
+ PStatement -- ^ function name, formal parameters, body
+ deriving (Eq, Show)
+
+instance PyPretty PStatement where
+ pyPretty s =
+ case s of
+ PReturn e -> "return " ++ pyPretty e
+ PImport modName -> "import " ++ modName
+ PCondS c a b ->
+ sepLines ["if " ++ pyPretty c ++ ":",
+ indentLine 4 (pyPretty a),
+ "else:",
+ indentLine 4 (pyPretty b)]
+ PFun fid params body ->
+ sepLines ["def " ++ pyPretty fid ++
+ pyPrettyParens params ++ ":",
+ indentLine 4 (pyPretty body)]
+
+-- | Expr as an instance of PyPretty.
+-- This instance is only for Exprs as Python exprs,
+-- for export to Python! It will conflict with the
+-- one in ToHaskell.hs (or Haskell.hs).
+--
+-- The EOp case needs work to deal with precedences
+-- and avoid unnecessary parens.
+-- Note that this instance declaration is for *Python* Exprs.
+-- Haskell Exprs of course should not be pretty-printed
+-- the same way!
+instance PyPretty Expr where
+ pyPretty pexpr =
+ case pexpr of
+ EUndefined -> "undefined"
+ EChar _ -> error ("Python pyPretty of Expr: " ++
+ "EChar should have been converted to " ++
+ "EString")
+ EList _ -> error ("Python pyPretty of Expr: " ++
+ "EList should have been converted to " ++
+ "ECall li ...")
+ EIf c a b ->
+ unwords [pyPretty a, "if", pyPretty c, "else", pyPretty b]
+ EGroup e -> pyPrettyParens [e]
+ ESymbol vid -> pyPretty vid
+ ENumber n -> show n
+ EBool b -> show b
+ EString s -> show s
+ ELambda (Symbol x) body ->
+ unwords ["lambda", show x, ":", pyPretty body]
+ EApp fexpr argExpr ->
+ concat [pyPretty fexpr, pyPrettyParens [argExpr]]
+ ECall fexpr argExprs ->
+ concat [pyPretty fexpr, pyPrettyParens argExprs]
+ EOp op left right ->
+ unwords [pyPretty left, pyPretty op, pyPretty right]
+
+alterParens :: (Expr -> Expr) -> 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
+
+
+-- | Python return statement
+ret :: Expr -> 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 :: Expr -> Expr -> Expr -> PStatement
+condS c a b = PCondS c (ret a) (ret b)
+
+-- PExpr smart constructors
+
+-- | Python variable
+var :: String -> Expr
+var name = ESymbol (Symbol name)
+
+-- | Python identifier
+ident :: String -> Symbol
+ident s = Symbol s
+
+-- | Python character expression = string expression with one character
+char :: Char -> Expr
+char c = EString [c]
+
+-- | Python function formal parameter
+param :: String -> Symbol
+param name = Symbol name
+
+-- | Defines function definition
+fun :: String -> [String] -> Expr -> 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.
+--
+-- | Operator information
+-- Arithmetic operators:
+-- + and - have lower precedence than *, /, //, %
+-- | Comparison operators have precedence lower than any arithmetic
+-- operator. Here, I've specified associative = False,
+-- because association doesn't even make sense (well, it does in Python
+-- but not in other languages);
+-- (a == b) == c is in general not well typed.
+
+operatorTable :: M.Map String Operator
+operatorTable =
+ M.fromList (map (\ op -> (opName op, op))
+ [ (Operator "*" 7 True GroupLtoR) -- times
+ , (Operator "//" 7 False GroupLtoR) -- int div
+ , (Operator "/" 7 False GroupLtoR) -- float div
+ , (Operator "%" 7 False GroupLtoR) -- mod
+ , (Operator "+" 6 True GroupLtoR) -- plus
+ , (Operator "-" 6 False GroupLtoR) -- minus
+ , (Operator "==" 4 False GroupNone) -- eq
+ , (Operator "!=" 4 False GroupNone) -- ne
+ , (Operator ">" 4 False GroupNone) -- gt
+ , (Operator ">=" 4 False GroupNone) -- ge
+ , (Operator "<" 4 False GroupNone) -- lt
+ , (Operator "<=" 4 False GroupNone) -- le
+ ])
diff --git a/Language/Sifflet/Export/ToHaskell.hs b/Language/Sifflet/Export/ToHaskell.hs
new file mode 100644
--- /dev/null
+++ b/Language/Sifflet/Export/ToHaskell.hs
@@ -0,0 +1,136 @@
+-- | Exports Sifflet to Haskell
+-- Requires haskell-src package.
+
+module Language.Sifflet.Export.ToHaskell
+ (
+ HaskellOptions(..)
+ , defaultHaskellOptions
+ , exportHaskell
+ , functionsToHsModule
+ , functionToHsDecl
+ , exprToHsExpr
+ )
+where
+
+import Data.Char (toUpper)
+import qualified Data.Map as M
+import System.FilePath (dropExtension, takeFileName)
+
+import Language.Sifflet.Export.Exporter
+import Language.Sifflet.Export.Haskell
+import Language.Sifflet.Expr
+import Language.Sifflet.Util
+
+
+-- Main types and functions
+
+-- | User configurable options for export to Haskell.
+-- Currently these options are unused.
+-- The line width options should probably go somewhere else,
+-- maybe as PrettyOptions.
+data HaskellOptions =
+ HaskellOptions {optionsSoftMaxLineWidth :: Int
+ , optionsHardMaxLineWidth :: Int
+ }
+ deriving (Eq, Show)
+
+-- | The default options for export to Haskell.
+defaultHaskellOptions :: HaskellOptions
+defaultHaskellOptions = HaskellOptions {optionsSoftMaxLineWidth = 72,
+ optionsHardMaxLineWidth = 80}
+
+-- | Export functions with specified options to a file
+exportHaskell :: HaskellOptions -> Exporter
+exportHaskell _options functions path =
+ let header = "-- File: " ++ path ++
+ "\n-- Generated by the Sifflet->Haskell exporter.\n\n"
+ in writeFile path (header ++
+ hsPretty (functionsToHsModule
+ (pathToModuleName path)
+ functions))
+
+
+pathToModuleName :: FilePath -> String
+pathToModuleName path =
+ case dropExtension (takeFileName path) of
+ [] -> "Test"
+ c : cs -> toUpper c : cs
+
+-- ------------------------------------------------------------------------
+
+-- | Converting Sifflet to Haskell syntax tree
+
+-- | Create a module from a module name and Functions.
+functionsToHsModule :: String -> Functions -> Module
+functionsToHsModule modname (Functions fs) =
+ Module {moduleName = modname
+ , moduleExports = Nothing
+ , moduleImports = ImportDecl ["Data.Number.Sifflet"]
+ , moduleDecls = map functionToHsDecl fs
+ }
+
+-- | Create a declaration from a Function.
+-- Needs work: infer and declare the type of the function.
+-- Minimally parenthesized.
+functionToHsDecl :: Function -> Decl
+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) ->
+ Decl {declIdent = fname
+ , declType = Nothing -- to be improved later
+ , declParams = args
+ , declExpr = (simplifyExpr haskellRules)
+ (exprToHsExpr body)}
+
+haskellRules :: [Expr -> Expr]
+haskellRules = commonRulesForSimplifyingExprs ++
+ [ruleIfRight, ruleRightToLeft]
+
+-- | Converts a Sifflet Expr to a fully parenthesized Haskell Expr
+exprToHsExpr :: Expr -> Expr
+exprToHsExpr expr =
+ case expr of
+ EUndefined -> ESymbol (Symbol "undefined")
+ ESymbol _ -> expr
+ EBool _ -> expr
+ EChar _ -> expr
+ ENumber _ -> expr
+ EString _ -> expr
+
+ EIf c a b -> EIf (exprToHsExpr c) (exprToHsExpr a) (exprToHsExpr b)
+ EList es -> EList (map exprToHsExpr es)
+ ELambda x body -> ELambda x (EGroup body)
+ ECall (Symbol fname) args ->
+ case nameToHaskell fname of
+ Left op -> -- operator
+ case args of
+ [left, right] ->
+ EOp op (EGroup (exprToHsExpr left))
+ (EGroup (exprToHsExpr right))
+ _ -> error
+ "exprToHsExpr: operation does not have 2 operands"
+ Right funcName -> -- function
+ ECall (Symbol funcName) (map (EGroup . exprToHsExpr) args)
+ _ -> errcats ["exprToHsExpr: extended expr:", show expr]
+
+-- | Map Sifflet names to Haskell names.
+-- Returns a Left Operator for Haskell operators,
+-- which always have the same name as their corresponding Sifflet
+-- functions, or a Right String for Haskell function and variable names.
+nameToHaskell :: String -> Either Operator String
+nameToHaskell name =
+ case M.lookup name operatorTable of
+ Just op -> Left op
+ Nothing ->
+ -- Most names would have the same names in Haskell,
+ -- but there are a few special cases.
+ Right (case name of
+ "zero?" -> "eqZero"
+ "positive?" -> "gtZero"
+ "negative?" -> "ltZero"
+ "add1" -> "succ"
+ "sub1" -> "pred"
+ _ -> name)
+
diff --git a/Language/Sifflet/Export/ToPython.hs b/Language/Sifflet/Export/ToPython.hs
new file mode 100644
--- /dev/null
+++ b/Language/Sifflet/Export/ToPython.hs
@@ -0,0 +1,171 @@
+-- | Sifflet to abstract syntax tree for Python.
+-- Use Python module's pyPretty to pretty-print the result.
+
+module Language.Sifflet.Export.ToPython
+ (
+ PythonOptions(..)
+ , defaultPythonOptions
+ , exprToPExpr
+ , nameToPython
+ , fixIdentifierChars
+ , functionToPyDef
+ , defToPy
+ , functionsToPyModule
+ , functionsToPrettyPy
+ , exportPython
+ )
+
+where
+
+import Data.Char (isAlpha, isDigit, ord)
+import Control.Monad (unless)
+import Data.Map ((!))
+import System.Directory (copyFile, doesFileExist)
+import System.FilePath (replaceFileName)
+
+import Language.Sifflet.Export.Exporter
+import Language.Sifflet.Export.Python
+import Language.Sifflet.Expr
+-- import Text.Sifflet.Pretty
+import Language.Sifflet.Util
+
+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
+
+-- A lot of these are "pass-through" -- simplify: ***
+exprToPExpr :: Expr -> Expr
+exprToPExpr expr =
+ case expr of
+ EUndefined -> EUndefined -- was var "undefined"
+ ESymbol _ -> expr
+
+ EBool _ -> expr
+ EChar c -> EString [c] -- Python does not distinguish char from str
+ ENumber _ -> expr
+ EString _ -> expr
+
+ EIf cond action altAction ->
+ -- EIf here represents a Python if *expression*:
+ -- value if test else altvalue
+ -- not the familiar if *statement*!
+ EIf (exprToPExpr cond)
+ (exprToPExpr action)
+ (exprToPExpr altAction)
+ EList exprs ->
+ ECall (Symbol "li") (map exprToPExpr exprs)
+ ELambda x body -> ELambda x (EGroup body)
+ ECall (Symbol fname) args ->
+ -- Python distinguishes between functions and operators
+ case nameToPython fname of
+ Left op ->
+ case args of
+ [left, right] ->
+ EOp op (EGroup (exprToPExpr left))
+ (EGroup (exprToPExpr right))
+ _ -> error "exprToPExpr: operation does not have 2 operands"
+ Right pname ->
+ -- I don't think we need (a) for each arg a
+ -- since they are separated by commas
+ ECall (Symbol pname) (map exprToPExpr args)
+ _ -> errcats ["exprToPExpr: extended expr:", show expr]
+
+-- | Convert Sifflet name (of a function) to Python operator (Left)
+-- or function name (Right)
+nameToPython :: String -> Either Operator String
+nameToPython name =
+ let oper oname = Left $ operatorTable ! oname
+ in case name of
+ "+" -> oper "+"
+ "-" -> oper "-"
+ "*" -> oper "*"
+ "div" -> oper "//"
+ "mod" -> oper "%"
+ "/" -> oper "/" -- invalid for integers in Python 2!
+ "==" -> oper "=="
+ "/=" -> oper "!="
+ ">" -> oper ">"
+ ">=" -> oper ">="
+ "<" -> oper "<"
+ "<=" -> oper "<="
+ "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
+
+-- | Create a Python def statement from a Sifflet function.
+-- Minimally parenthesized.
+functionToPyDef :: Function -> PStatement
+functionToPyDef = defToPy . functionToDef
+
+defToPy :: FunctionDefTuple -> PStatement
+defToPy (fname, paramNames, _, _, body) =
+ fun (fixIdentifierChars fname)
+ paramNames
+ ((simplifyExpr pyRules) (exprToPExpr body))
+
+pyRules :: [Expr -> Expr]
+pyRules = commonRulesForSimplifyingExprs
+
+functionsToPyModule :: Functions -> PModule
+functionsToPyModule (Functions fs) = PModule (map functionToPyDef fs)
+
+functionsToPrettyPy :: Functions -> String
+functionsToPrettyPy = pyPretty . 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/Language/Sifflet/Export/ToScheme.hs b/Language/Sifflet/Export/ToScheme.hs
new file mode 100644
--- /dev/null
+++ b/Language/Sifflet/Export/ToScheme.hs
@@ -0,0 +1,321 @@
+module Language.Sifflet.Export.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 Data.Number.Sifflet
+import Language.Sifflet.Export.Exporter
+import Language.Sifflet.Expr
+import Text.Sifflet.Repr
+import Text.Sifflet.Pretty
+import Language.Sifflet.Util
+
+-- 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))
+
+ EBool b -> valueToSExpr (VBool b)
+ EChar c -> valueToSExpr (VChar c)
+ ENumber n -> valueToSExpr (VNumber n)
+ EString s -> valueToSExpr (VString s)
+
+ 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))
+ ELambda (Symbol x) body ->
+ SList [SAtom (SSymbol "lambda"), SList [SAtom (SSymbol x)],
+ exprToSExpr body]
+ ECall fsym args ->
+ SList (exprToSExpr (ESymbol fsym) : map exprToSExpr args)
+ _ -> errcats ["exprToSExpr: extended expr:", show expr]
+
+-- 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
+ VNumber (Exact i) -> SInt i
+ VNumber (Inexact x) -> SFloat x
+ VString 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/Language/Sifflet/Expr.hs b/Language/Sifflet/Expr.hs
new file mode 100644
--- /dev/null
+++ b/Language/Sifflet/Expr.hs
@@ -0,0 +1,1021 @@
+module Language.Sifflet.Expr
+ (
+ ArgSpec(..)
+ , aspecsLookup
+ , EvalResult, EvalRes(EvalOk, EvalError, EvalUntried)
+ , exprToValue, valueToLiteral, valueToLiteral'
+ , Symbol(..)
+ , OStr, OBool, OChar
+ , Expr(..), eSymbol, eSym, eInt, eString, eChar, eFloat
+ , toLambdaExpr
+ , callToApp, mapply
+ , appToCall, mcall
+ , exprIsAtomic
+ , exprIsCompound
+ , eBool, eFalse, eTrue, eIf
+ , eList, eCall
+ , exprIsLiteral
+ , exprSymbols, exprVarNames
+ , Operator(..)
+ , Precedence
+ , OperatorGrouping(..)
+ , Value(..), valueFunction
+ , Functions(..)
+ , Function(..), functionName, functionNArgs
+ , functionArgSpecs
+ , functionArgTypes, functionResultType, functionArgResultTypes
+ , functionType
+ , functionArgNames, functionBody, functionImplementation
+ , FunctionDefTuple, functionToDef, functionFromDef
+ , FunctionImpl(..)
+ , TypeVarName, TypeConsName, Type(..)
+ , typeBool, typeChar, typeNum, typeString
+ , typeList, typeFunction
+ , Env, emptyEnv, makeEnv, extendEnv, envInsertL, envPop
+ , envIns, envSet, envGet
+ , envGetFunction, envLookup, envLookupFunction
+ , envSymbols, envFunctionSymbols, envFunctions
+ , eval, evalWithLimit, stackSize, apply
+ , newUndefinedFunction
+ , ePlus, eTimes, eMinus, eDiv, eMod
+ , eAdd1, eSub1
+ , eEq, eNe, eGt, eGe, eLt, eLe
+ , eZerop, ePositivep, eNegativep
+ , baseEnv)
+
+where
+
+-- drop this after debugging:
+-- import System.IO.Unsafe(unsafePerformIO)
+
+import Data.Map as Map hiding (filter, foldl, map, null)
+import Data.List as List
+
+import Data.Number.Sifflet
+
+import Data.Sifflet.Tree as T
+
+import Text.Sifflet.Pretty
+import Text.Sifflet.Repr ()
+
+import Language.Sifflet.Util
+
+-- | Transform a numerical expression into its negation,
+-- e.g., 5 --> (-5).
+-- Fails if the expression is not an ENumber.
+
+eNegate :: Expr -> SuccFail Expr
+eNegate expr =
+ case expr of
+ ENumber n -> Succ $ ENumber (negate n)
+ _ -> Fail $ "eNegate: cannot handle" ++ show expr
+
+-- Symbols have names, and may or may not have values,
+-- but the value is stored in an environment, not in the symbol itself.
+
+newtype Symbol = Symbol String
+ deriving (Eq, Read, Show)
+
+instance Pretty Symbol where
+ pretty (Symbol s) = s
+
+instance Repr Symbol where repr (Symbol s) = s
+
+-- The Haskell representations of V's primitive data types.
+-- Data.Number.Sifflet.Number represents exact and inexact numbers.
+type OStr = String
+type OBool = Bool
+type OChar = Char
+
+-- | A more highly "parsed" type of expression
+--
+-- Function calls have two kinds:
+-- 1. ECall:
+-- restricted to the case where the function expression
+-- is just a symbol, since otherwise it will be hard to visualize.
+-- 2. EApp: allows any expression to be the function,
+-- but is applied to only one argument.
+-- For now, the type checker will convert ECall expressions to
+-- EApp expressions. Ultimately, the two variants ought to be
+-- unified.
+--
+-- The constructors EOp and EGroup are not used in Sifflet itself,
+-- but they are needed for export to Python, Haskell, and similar languages;
+-- they allow a distinction between operators and functions, and
+-- wrapping expressions in parentheses.
+-- EGroup e represents parentheses used for grouping: (e);
+-- it is not used for other cases of parentheses, e.g.,
+-- around the argument list in a function call.]
+
+data Expr = EUndefined
+ | ESymbol Symbol
+ | EBool Bool
+ | EChar Char
+ | ENumber Number
+ | EString String
+ | EIf Expr Expr Expr -- ^ if test branch1 branch2
+ | EList [Expr]
+ | ELambda Symbol Expr
+ | EApp Expr Expr -- ^ apply function to argument
+ | ECall Symbol [Expr] -- ^ function name, arglist
+ | EOp Operator Expr Expr -- ^ binary operator application
+ | EGroup Expr -- ^ grouping parentheses
+ deriving (Eq, Show)
+
+instance Repr Expr where
+ repr e =
+ case e of
+ EUndefined -> "*undefined*"
+ ESymbol s -> repr s
+ EBool b -> repr b
+ EChar c -> repr c
+ ENumber n -> repr n
+ EString s -> show s
+ EIf t a b -> par "if" (map repr [t, a, b])
+ EList xs -> if exprIsLiteral e
+ then reprList "[" ", " "]" xs
+ else error ("Expr.repr: EList expression is non-literal: "
+ ++ show e)
+ -- check *** was: par "EList" (map repr items)
+ ELambda x body -> par "lambda" [repr x , "->", repr body]
+ EApp f arg -> par (repr f) [repr arg]
+ ECall (Symbol fname) args -> par fname (map repr args)
+ EOp op left right -> unwords [repr left, opName op, repr right]
+ EGroup e' -> "(" ++ repr e' ++ ")"
+
+-- | Try to convert the arguments and body of a function to a lambda expression.
+-- Fails if there are no arguments, since a lambda expression requires one.
+-- If there are multiple arguments, then we get a nested lambda expression.
+
+toLambdaExpr :: [String] -> Expr -> SuccFail Expr
+toLambdaExpr args body =
+ case args of
+ [] -> Fail "toLambdaExpr: no arguments; at least one needed"
+ a:[] -> Succ $ ELambda (Symbol a) body
+ a:as -> do
+ {
+ expr <- toLambdaExpr as body
+ ; Succ $ ELambda (Symbol a) expr
+ }
+
+-- | Convert an ECall expression to an EApp expression
+
+callToApp :: Expr -> Expr
+callToApp expr =
+ case expr of
+ ECall fsym args -> mapply (ESymbol fsym) args
+ _ -> error "callToApp: requires ECall expression"
+
+-- | Helper for callToApp, but may have other uses.
+-- Creates an EApp expression representing a function call
+-- with possibly many arguments.
+mapply :: Expr -> [Expr] -> Expr
+mapply fexpr args =
+ case args of
+ [] -> error "mapply: no argument, cannot happen"
+ arg:[] -> EApp fexpr arg
+ arg:args' -> mapply (EApp fexpr arg) args'
+
+
+-- | Convert an EApp expression to an ECall expression
+
+appToCall :: Expr -> Expr
+appToCall expr =
+ case expr of
+ EApp f arg -> mcall f [arg]
+ _ -> error "appToCall: requires an EApp expression"
+
+
+-- | Helper for appToCall, but may have other uses.
+-- Creates an ECall expression.
+
+mcall :: Expr -> [Expr] -> Expr
+mcall f args =
+ case f of
+ ESymbol fsym -> ECall fsym args
+ EApp g arg -> mcall g (arg:args)
+ _ ->
+ error "mcall: function must be represented as a symbol or an EApp"
+
+-- | An Expr is "extended" if it uses the extended constructors
+-- EOp or EGroup. In pure Sifflet, no extended Exprs are used.
+
+exprIsExtended :: Expr -> Bool
+exprIsExtended e =
+ case e of
+ EOp _ _ _ -> True
+ EGroup _ -> True
+ EIf t a b -> exprIsExtended t ||
+ exprIsExtended a ||
+ exprIsExtended b
+ EList xs -> any exprIsExtended xs
+ ELambda _ body -> exprIsExtended body
+ ECall (Symbol _) args -> any exprIsExtended args
+ _ -> False
+
+-- | Is an Expr a literal? A literal is a boolean, character, number, string,
+-- or list of literals. We (should) only allow user input expressions
+-- to be literal expressions.
+
+exprIsLiteral :: Expr -> Bool
+exprIsLiteral e =
+ case e of
+ EBool _ -> True
+ EChar _ -> True
+ ENumber _ -> True
+ EString _ -> True
+ EList es -> all exprIsLiteral es
+ -- Shouldn't we say that
+ -- EGroup e' *not* a literal, even if e' is a literal?
+ -- But consider carefully the effect on exprIsAtomic and ()'s removal.
+ EGroup _e' -> True -- or False, or exprIsLiteral e' ???
+ _ -> False
+
+-- | Is an expression atomic?
+-- Atomic expressions do not need parentheses in any reasonable language,
+-- because there is nothing to be grouped (symbols, literals)
+-- or in the case of lists, they already have brackets
+-- which separate them from their neighbors.
+--
+-- All lists are atomic, even if they are not literals,
+-- because (for example) we can remove parentheses
+-- from ([a + b, 7])
+
+exprIsAtomic :: Expr -> Bool
+exprIsAtomic e =
+ case e of
+ ESymbol _ -> True
+ EList _ -> True
+ _ -> exprIsLiteral e
+
+-- | Compound = non-atomic
+exprIsCompound :: Expr -> Bool
+exprIsCompound = not . exprIsAtomic
+
+eSymbol, eSym :: String -> Expr
+eSymbol = ESymbol . Symbol
+eSym = eSymbol
+
+eInt :: Integer -> Expr
+eInt = ENumber . Exact
+
+eString :: OStr -> Expr
+eString = EString
+
+eChar :: OChar -> Expr
+eChar = EChar
+
+eFloat :: Double -> Expr
+eFloat = ENumber . Inexact
+
+eBool :: Bool -> Expr
+eBool = EBool
+
+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
+
+-- | An operator, such as * or +
+-- An operator is associative, like +, if (a + b) + c == a + (b + c).
+-- Its grouping is left to right if (a op b op c) means (a op b) op c;
+-- right to left if (a op b op c) means a op (b op c).
+-- Most operators group left to right.
+data Operator = Operator {opName :: String
+ , opPrec :: Precedence
+ , opAssoc :: Bool -- ^ associative?
+ , opGrouping :: OperatorGrouping
+ }
+ deriving (Eq, Show)
+
+instance Pretty Operator where
+ pretty = opName
+
+-- | Operator priority, normally is > 0 or >= 0,
+-- but does that really matter? I think not.
+type Precedence = Int
+
+-- | Operator grouping: left to right or right to left,
+-- or perhaps not at all
+data OperatorGrouping = GroupLtoR | GroupRtoL | GroupNone
+ deriving (Eq, Show)
+
+-- VALUES AND EVALUATION
+
+data Value = VBool OBool
+ | VChar OChar
+ | VNumber Number
+ | VString OStr
+ | VFun Function
+ | VList [Value]
+ deriving (Eq, Show)
+ -- no Read for Function
+
+instance Repr Value where
+ repr (VBool b) = show b
+ repr (VChar c) = show c
+ repr (VNumber n) = show n
+ repr (VString s) = show s
+ repr (VFun f) = repr f
+ repr (VList vs) = reprList "[" ", " "]" vs
+
+valueFunction :: Value -> Function
+valueFunction value =
+ case value of
+ VFun function -> function
+ _ -> error "valueFunction: non-function value"
+
+-- 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
+
+-- | 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
+ VBool b -> Succ $ EBool b
+ VChar c -> Succ $ EChar c
+ VNumber n -> Succ $ ENumber n
+ VString s -> Succ $ EString s
+ -- VList [] -> Succ $ EList []
+ -- VV Should this be fixed? VV
+ -- VList _ -> Fail "cannot convert non-empty list to literal expression"
+ VList vs -> mapM valueToLiteral vs >>= Succ . EList
+ VFun _f -> Fail "cannot convert function to literal expression"
+
+valueToLiteral' :: Value -> Expr
+valueToLiteral' v = case valueToLiteral v of
+ Fail msg -> error ("valueToLiteral: " ++ msg)
+ Succ e -> e
+
+-- | Convert a literal expression to the value it represents.
+-- It is an error if the expression is non-literal.
+-- See exprIsLiteral.
+literalToValue :: Expr -> Value
+literalToValue e =
+ case e of
+ EBool b -> VBool b
+ EChar c -> VChar c
+ ENumber n -> VNumber n
+ EString s -> VString s
+ EList es -> if exprIsLiteral e
+ then VList (map literalToValue es)
+ else errcats ["literalToValue: ",
+ "non-literal list expression: ",
+ show e]
+ _ -> errcats ["literalToValue: non-literal or extended expression: " ,
+ show e]
+
+-- | Type variable name
+type TypeVarName = String
+
+-- | Type constructor name
+type TypeConsName = String
+
+-- | A Type is either a type variable or a constructed type
+-- with a constructor and a list of type parameters
+
+data Type = TypeVar TypeVarName -- named type variable
+ | TypeCons TypeConsName [Type] -- constructed type
+ deriving (Eq)
+
+instance Show Type where
+ show (TypeVar vname) = vname
+ show (TypeCons ctor ts) =
+ case ts of
+ [] -> ctor
+ (t:ts') ->
+ case ctor of
+ "List" -> "[" ++ show t ++ "]"
+ "Function" -> "(" ++ show t ++ " -> " ++
+ show (head ts') ++ ")"
+ _ -> "(" ++ ctor ++ (unwords (map show ts)) ++ ")"
+
+
+typeToArity :: Type -> Int
+typeToArity atype =
+ case atype of
+ TypeCons "Function" [_, next] -> 1 + typeToArity next
+ _ -> 0
+
+-- Primitive types
+
+primType :: TypeConsName -> Type
+primType tname = TypeCons tname []
+
+typeBool, typeChar, typeNum, typeString :: Type
+typeBool = primType "Bool"
+typeChar = primType "Char"
+typeNum = primType "Num"
+typeString = primType "String"
+
+-- Built-in compound types
+
+typeList :: Type -> Type
+typeList t = TypeCons "List" [t]
+
+-- | The type of a function, from its argument types and result type,
+-- where (a -> b) is represented as TypeCons "Function" [a, b].
+-- Note that for n-ary functions, n > 2 implies nested function types:
+-- (a -> b -> c) is represented as
+-- TypeCons "Function" [a, TypeCons "Function" [b, c]], etc.
+
+typeFunction :: [Type] -> Type -> Type
+typeFunction atypes rtype =
+ let func a b = TypeCons "Function" [a, b]
+ in case atypes of
+ [] -> error "typeFunction: empty argument type list"
+ atype:[] -> func atype rtype
+ atype:atypes' -> func atype (typeFunction atypes' rtype)
+
+-- | A collection of functions, typically to be saved or exported
+-- or read from a file
+
+newtype Functions = Functions [Function]
+ deriving (Eq, Show)
+
+-- | A function may have a name and always has an implementation
+data Function = Function (Maybe String) -- function name
+ [Type] -- argument types
+ Type -- result type
+ FunctionImpl -- implementation
+ deriving (Show)
+
+
+data ArgSpec = ArgSpec {argName :: String, -- argument name
+ argInlets :: Int -- number of inputs
+ }
+ deriving (Eq, Show)
+
+-- | Try to find the number of inlets for an argument
+-- from a list of ArgSpec
+aspecsLookup :: String -> [ArgSpec] -> Maybe Int
+aspecsLookup name specs =
+ case specs of
+ [] -> Nothing
+ s:ss ->
+ if argName s == name
+ then Just (argInlets s)
+ else aspecsLookup name ss
+
+functionArgSpecs :: Function -> [ArgSpec]
+functionArgSpecs f@(Function _ argTypes _ _) =
+ [ArgSpec {argName = n, argInlets = typeToArity t} |
+ (n, t) <- zip (functionArgNames f) argTypes]
+
+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 f =
+ let name = functionName f
+ in case functionImplementation f of
+ Primitive _ -> ""
+ Compound _args _body -> ""
+
+newUndefinedFunction :: String -> [String] -> Function
+newUndefinedFunction name argnames =
+ let (atypes, rtype) = undefinedTypes argnames
+ impl = Compound argnames EUndefined
+ in Function (Just name) atypes rtype impl
+
+undefinedTypes :: [String] -> ([Type], Type)
+undefinedTypes argnames =
+ let atypes = [TypeVar ('_' : name) | name <- argnames]
+ rtype = TypeVar "_result"
+ in (atypes, rtype)
+
+functionName :: Function -> String
+functionName (Function mname _ _ _) =
+ case mname of
+ Just name -> name
+ Nothing -> "(unnamed)"
+
+functionNArgs :: Function -> Int
+functionNArgs = length . functionArgTypes
+
+functionArgTypes :: Function -> [Type]
+functionArgTypes (Function _ argtypes _ _) = argtypes
+
+functionResultType :: Function -> Type
+functionResultType (Function _ _ rtype _) = rtype
+
+-- | Type type of a function, a tuple of (arg types, result type)
+functionArgResultTypes :: Function -> ([Type], Type) -- (args., result type)
+functionArgResultTypes f = (functionArgTypes f, functionResultType f)
+
+-- | The type of a function,
+-- where (a -> b) is represented as TypeCons "Function" [a, b]
+functionType :: Function -> Type
+functionType (Function _ argTs resultT _) = typeFunction argTs resultT
+
+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], [Type], Type, 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
+
+ EBool b -> EvalOk (VBool b)
+ EChar c -> EvalOk (VChar c)
+ ENumber n -> EvalOk (VNumber n)
+ EString n -> EvalOk (VString n)
+
+ 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
+
+ ELambda _ _ -> error "evalWithLimit: not implemented for lambda expr"
+ 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
+ _ -> errcats ["evalWithLimit: extended expression not supported",
+ show expr]
+
+-- | 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 "+" (+), -- Number (+)
+ primN2N "-" (-),
+ primN2N "*" (*),
+ primIntDiv,
+ primIntMod,
+ primFloatDiv,
+
+ primN1N "add1" succ,
+ primN1N "sub1" pred,
+
+ -- Comparison
+ primN2B "==" (==),
+ primN2B "/=" (/=),
+ primN2B ">" (>),
+ primN2B ">=" (>=),
+ primN2B "<" (<),
+ primN2B "<=" (<=),
+
+ primN1B "zero?" eqZero,
+ primN1B "positive?" gtZero,
+ primN1B "negative?" ltZero,
+
+ -- List operations
+
+ -- null xs tells if xs is an empty list
+ prim "null" [typeList (TypeVar "a")]
+ typeBool primNull,
+
+ prim "head" [typeList (TypeVar "b")]
+ (TypeVar "b")
+ primHead,
+ prim "tail" [typeList (TypeVar "c")]
+ (typeList (TypeVar "c"))
+ primTail,
+ prim ":" [TypeVar "d", typeList (TypeVar "d")]
+ (typeList (TypeVar "d"))
+ primCons
+ ]
+
+type PFun = [Value] -> EvalResult
+
+-- Primitive functions of arbitrary type
+prim :: String -> [Type] -> Type -> 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 -> (Number -> Number -> Number) -> Function
+primIntDivMod name oper =
+ let func args =
+ let err msg = EvalError $ concat [name, ": ", msg,
+ " (", show args, ")"]
+ in case args of
+ [VNumber a, VNumber b] ->
+ if b == 0
+ then err "zero divisor"
+ else if isExact a && isExact b
+ then EvalOk $ VNumber (oper a b)
+ else err "arguments must be exact numbers"
+ _ -> error "wrong type or number of arguments"
+ in prim name [typeNum, typeNum] typeNum 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
+ [VNumber x, VNumber y] -> EvalOk $ VNumber (x / y)
+ _ -> EvalError $ "/: invalid args: " ++ show args
+ in prim "/" [typeNum, typeNum] typeNum 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
+-- fn = Number function to implement for Number operands.
+primN2N :: String -> (Number -> Number -> Number) -> Function
+primN2N name fn =
+ let impl args =
+ case args of
+ [VNumber x, VNumber y] -> EvalOk $ VNumber (fn x y)
+ _ -> EvalError $ name ++ ": invalid args: " ++ show args
+ in prim name [typeNum, typeNum] typeNum impl
+
+-- | Primitive unary functions number to number
+primN1N :: String -> (Number -> Number) -> Function
+primN1N name fn =
+ let impl args =
+ case args of
+ [VNumber x] -> EvalOk $ VNumber (fn x)
+ _ -> EvalError $ name ++ ": invalid args: " ++ show args
+ in prim name [typeNum] typeNum impl
+
+-- Primitive frunctions with 2 number args and a boolean result
+primN2B :: String -> (Number -> Number -> OBool) -> Function
+primN2B name fn =
+ let impl args =
+ case args of
+ [VNumber x, VNumber y] -> EvalOk $ VBool (fn x y)
+ _ -> EvalError $ name ++ ": invalid args: " ++ show args
+ in prim name [typeNum, typeNum] typeBool impl
+
+
+-- Primitive unary functions number to boolean
+primN1B :: String -> (Number -> Bool) -> Function
+primN1B name fn =
+ let impl args =
+ case args of
+ [VNumber x] -> EvalOk $ VBool (fn x)
+ _ -> EvalError $ name ++ ": invalid args: " ++ show args
+ in prim name [typeNum] typeBool impl
+
+baseEnv :: Env
+baseEnv =
+ makeEnv (map functionName primitiveFunctions)
+ (map VFun primitiveFunctions)
+
+-- | Given an expression, return the list of names of variables
+-- occurring in the expression
+exprSymbols :: Expr -> [Symbol]
+exprSymbols expr =
+ nub $ case expr of
+ EUndefined -> [] -- is *not* a variable
+ ESymbol s -> [s]
+ EIf t a b -> nub $ concat [exprSymbols t,
+ exprSymbols a,
+ exprSymbols b]
+ ELambda x body -> nub (x : exprSymbols body)
+ ECall f args ->
+ case args of
+ [] -> [f]
+ a:as -> nub $ concat [exprSymbols a,
+ exprSymbols (ECall f as)]
+ EList items -> nub $ concatMap exprSymbols items
+ _ -> if exprIsExtended expr
+ then errcats ["exprSymbols: extended expr not supported:",
+ show expr]
+ else [] -- literal types bool, char, number, string
+
+-- | 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]
diff --git a/Language/Sifflet/ExprTree.hs b/Language/Sifflet/ExprTree.hs
new file mode 100644
--- /dev/null
+++ b/Language/Sifflet/ExprTree.hs
@@ -0,0 +1,227 @@
+module Language.Sifflet.ExprTree
+ (
+ ExprTree, ExprNode(..), ExprNodeLabel(..)
+ , exprNodeIoletCounter -- needs work ****** get rid of it???
+ , exprToTree, treeToExpr, exprToReprTree
+ , evalTree, unevalTree
+ )
+
+where
+
+import Data.Number.Sifflet
+
+import Data.Sifflet.Tree as T
+import Data.Sifflet.TreeLayout (IoletCounter)
+
+import Language.Sifflet.Expr
+
+import Text.Sifflet.Repr ()
+
+import Language.Sifflet.Util
+
+
+-- |
+-- EXPRESSION TREES
+-- For pure Sifflet, so not defined for extended expressions.
+
+type ExprTree = Tree ExprNode
+data ExprNode = ENode ExprNodeLabel EvalResult
+ deriving (Eq, Show)
+
+data ExprNodeLabel = NUndefined
+ | NSymbol Symbol
+ |
+ -- formerly NLit Value
+ NBool Bool | NChar Char | NNumber Number
+ | NString String
+ | NList [Expr] -- ???
+ 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
+ NBool b -> reprl b
+ NChar c -> reprl c
+ NNumber n -> reprl n
+ NString s -> [show s]
+ NList es -> reprl (EList es) -- check ***
+
+-- | Counts the number of inlets and outlets for an ExprNode
+exprNodeIoletCounter :: Env -> [ArgSpec] -> IoletCounter ExprNode
+exprNodeIoletCounter env aspecs (ENode nodeLabel _nodeResult) =
+ case nodeLabel of
+ NUndefined -> (0, 1)
+ NSymbol (Symbol "if") -> (3, 1)
+ NSymbol (Symbol s) ->
+ case envLookup env s of
+ Nothing -> -- probably a parameter of the function
+ case aspecsLookup s aspecs of
+ Nothing -> (0, 1)
+ Just i -> (i, 1)
+ Just value ->
+ case value of
+ VFun function -> (functionNArgs function, 1)
+ _ -> (0, 1) -- symbol bound to non-function value
+ _ -> (0, 1)
+
+exprToTree :: Expr -> ExprTree
+exprToTree expr =
+ let leafnode :: ExprNodeLabel -> T.Tree ExprNode
+ leafnode e = node e []
+ node :: ExprNodeLabel -> [T.Tree ExprNode] -> T.Tree ExprNode
+ node e ts = T.Node (ENode e EvalUntried) ts
+ errext = error ("exprToTree: extended expr: " ++ show expr)
+ in case expr of
+ -- EUndefined, ESymbol, and literals map directly
+ -- to NUndefined, NSymbol, E(literal-type)
+ EUndefined -> leafnode NUndefined
+ ESymbol s -> leafnode (NSymbol s)
+
+ -- Literals
+ EBool b -> leafnode (NBool b)
+ EChar c -> leafnode (NChar c)
+ ENumber n -> leafnode (NNumber n)
+ EString s -> leafnode (NString s)
+
+ -- EIf maps to symbol "if" at the root, 3 subtrees
+ EIf t a b -> node (NSymbol (Symbol "if")) (map exprToTree [t, a, b])
+
+ ELambda _x _body -> error "exprToTree: not implemented for lambda expr"
+ EApp f arg -> node (NSymbol (Symbol "@")) (map exprToTree [f, arg])
+ -- ECall maps to symbol f (function name) at the root,
+ -- each argument forms a subtree
+ ECall f args -> node (NSymbol f) (map exprToTree args)
+ EList xs -> leafnode (NList xs)
+ -- Extended Exprs not supported!
+ EGroup _ -> errext
+ EOp _ _ _ -> errext
+
+-- | Convert an expression tree (back) to an expression
+-- It will not give back the *same* expression in the case of an EList.
+treeToExpr :: ExprTree -> SuccFail Expr
+treeToExpr (T.Node (ENode label _) trees) =
+ let lit e = if null trees then Succ e
+ else Fail "literal node with non-empty subtrees"
+ in case label of
+ NUndefined -> Succ EUndefined
+ NBool b -> lit (EBool b)
+ NChar c -> lit (EChar c)
+ NNumber n -> lit (ENumber n)
+ NString s -> lit (EString s)
+ NList xs -> lit (EList xs)
+ NSymbol (Symbol "@") ->
+ case trees of
+ [f, arg] ->
+ do
+ {
+ f' <- treeToExpr f
+ ; arg' <- treeToExpr arg
+ ; Succ $ EApp f' arg'
+ }
+ _ -> Fail "'@' node with /= 2 subtrees"
+ NSymbol (Symbol "if") ->
+ case trees of
+ [q, a, b] ->
+ do
+ {
+ q' <- treeToExpr q
+ ; a' <- treeToExpr a
+ ; b' <- treeToExpr b
+ ; Succ $ EIf q' a' b'
+ }
+ _ -> Fail ("An 'if' node has the wrong number of subtrees" ++
+ " (should be 3)")
+ NSymbol s ->
+ -- VVV Do I really need to distinguish these two cases?
+ if null trees
+ then
+ -- s = terminal symbol
+ Succ $ ESymbol s
+ else -- s = function symbol in function call
+ do
+ {
+ trees' <- mapM treeToExpr trees
+ ; Succ $ ECall s trees'
+ }
+
+-- Convert an expression to a repr tree (of string elements)
+-- (Why?)
+
+exprToReprTree :: Expr -> Tree String
+exprToReprTree = fmap repr . exprToTree
+
+
+-- 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']
+
+ EvalOk weirdValue ->
+ -- This shouldn't happen with proper type
+ -- checking!
+ let msg = "if: non-boolean condition value: " ++
+ repr weirdValue
+ in T.Node (ifNode (EvalError msg)) [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 _ ->
+ let evalResult =
+ case treeToExpr atree of
+ Succ expr -> evalWithLimit expr env ss'
+ Fail msg -> EvalError msg
+ in T.Node (ENode rootOper evalResult)
+ [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
diff --git a/Language/Sifflet/Parser.hs b/Language/Sifflet/Parser.hs
new file mode 100644
--- /dev/null
+++ b/Language/Sifflet/Parser.hs
@@ -0,0 +1,319 @@
+-- | 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, ELambda, and ECall.
+
+module Language.Sifflet.Parser
+ (parseExpr
+ , parseValue
+ , parseLiteral
+ , parseTest
+ , parseSuccFail
+ , parseTypedInput2, parseTypedInputs2
+ , parseTypedInput3, parseTypedInputs3
+ , nothingBut
+ , expr, list
+ , value, typedValue
+ , bool, qchar, qstring, integer, double
+ , number
+ )
+
+where
+
+import Text.ParserCombinators.Parsec
+
+import Data.Number.Sifflet
+import Language.Sifflet.Expr
+import Language.Sifflet.Util
+
+-- | Parse a Sifflet data literal (number, string, char, bool, or list),
+-- returning an Expr
+parseExpr :: String -> SuccFail Expr
+parseExpr = parseSuccFail expr
+
+-- | Parse a Sifflet literal expression and return its Value
+parseValue :: String -> SuccFail Value
+parseValue s =
+ -- take a shortcut here?
+ -- case parseExpr s of -- stringToExpr s of
+ -- Succ expr -> exprToValue expr
+ -- Fail errmsg -> Fail errmsg
+ parseLiteral s >>= exprToValue
+
+parseLiteral :: String -> SuccFail Expr
+parseLiteral s =
+ -- parseValue s >>= valueToLiteral
+ case parseExpr s of
+ Succ e -> if exprIsLiteral e
+ then Succ e
+ else Fail $
+ "parseLiteral: expr is non-literal" ++ show e
+ Fail errmsg -> Fail errmsg
+
+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
+
+-- | Try to parse an input value of a specific type
+parseTypedInput2 :: (String, Type) -> SuccFail Value
+parseTypedInput2 (str, vartype) =
+ parseSuccFail (nothingBut (typedValue vartype)) str
+
+-- | Try to parse input values of specific types
+parseTypedInputs2 :: [String] -- ^ input strings
+ -> [Type] -- ^ expected types
+ -> SuccFail [Value]
+parseTypedInputs2 strs vartypes =
+ mapM parseTypedInput2 (zip strs vartypes)
+
+-- | Try to parse an input value for a named variable of a specific type
+parseTypedInput3 :: (String, String, Type) -> SuccFail Value
+parseTypedInput3 (s, varname, vartype) =
+ case parseSuccFail (nothingBut (typedValue vartype)) s of
+ Fail msg -> Fail ("For variable " ++ varname ++ ":\n" ++ msg)
+ Succ v -> Succ v
+
+-- | Try to parse input values for named variables of specific types
+parseTypedInputs3 :: [String] -- ^ inputs
+ -> [String] -- ^ variable names
+ -> [Type] -- ^ variable types
+ -> SuccFail [Value]
+parseTypedInputs3 strs varnames vartypes =
+ mapM parseTypedInput3 (zip3 strs varnames vartypes)
+
+-- | 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 -- actually only a literal
+-- or a list of literals.
+expr :: Parser Expr
+expr = -- (try (list expr >>= return . EList)) <|>
+ (bool >>= return . EBool) <|>
+ (qchar >>= return . EChar) <|>
+ (qstring >>= return . EString) <|>
+ try (double >>= return . ENumber . Inexact) <|>
+ (integer >>= return . ENumber . Exact) <|>
+ (list expr >>= return . EList)
+
+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" -- ???
+
+
+
+
+-- | Parser for a Value of any primitive or (concrete) list type
+
+value :: Parser Value
+value = (bool >>= return . VBool) <|>
+ (qchar >>= return .VChar) <|>
+ (qstring >>= return . VString) <|>
+ try (double >>= return . VNumber . Inexact) <|>
+ (integer >>= return . VNumber . Exact) <|>
+ (list value >>= return . VList)
+
+-- | Parser for a value with a specific primitive or concrete list type
+-- expected.
+
+typedValue :: Type -> Parser Value
+typedValue t =
+ (case t of
+ TypeCons "Bool" [] -> bool >>= return . VBool
+ TypeCons "Char" [] -> qchar >>= return . VChar
+ TypeCons "String" [] -> qstring >>= return . VString
+ TypeCons "Num" [] -> number >>= return . VNumber
+ TypeCons "List" [e] -> list (typedValue e) >>= return . VList
+ TypeCons "Function" _argTypes ->
+ fail $ "Sorry, but you cannot input a function here.\n\n" ++
+ "Note to developer: typedValue needs access to the " ++
+ "global environment in order to look up function names."
+ TypeCons _ _ ->
+ fail $ "Sorry, but you cannot input that type of value here.\n\n" ++
+ "Note to developer: typedValue needs to implement " ++
+ "the type " ++ show t
+ TypeVar _ -> value -- can't check, so just accept anything
+ )
+ typeName t
+
+-- | A name for the type, for use in parser error reporting
+typeName :: Type -> String
+typeName t =
+ let cerr cname =
+ error ("typeName: improper " ++ cname ++ " type construction")
+ primitive tname args =
+ case args of
+ [] -> tname
+ _ -> cerr tname
+ in case t of
+ TypeVar tvn -> tvn -- could be more specific!
+ TypeCons "Bool" ts -> primitive "boolean" ts
+ TypeCons "Char" ts ->
+ primitive "character" ts -- "character (in single quotes)"
+ TypeCons "Num" ts -> primitive "number" ts
+ TypeCons "String" ts ->
+ primitive "string" ts -- "string (in double quotes)"
+ TypeCons "List" [e] -> "list of " ++ typeName e
+ TypeCons "List" _ -> cerr "List"
+ TypeCons "Function" [_, _] -> "function" -- ???
+ TypeCons "Function" _ -> cerr "Function"
+ TypeCons tname texprs -> tname ++ " " ++ show (map typeName texprs)
+
+bool :: Parser Bool
+bool = (try (string "True" >> return True) <|>
+ (string "False" >> return False))
+ typeName typeBool
+
+
+-- 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 typeChar
+
+-- 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 typeString
+
+-- 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 \\"
+ )
+ )
+
+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 is a Sifflet Number, which is exact unless it contains
+-- a decimal point.
+-- To avoid consuming "123" from "123." and interpreting it as an exact
+-- number, we MUST try to parse double before integer.
+number :: Parser Number
+number = (try (double >>= return . Inexact) <|>
+ (integer >>= return . Exact))
+ typeName typeNum
+
+
+
diff --git a/Language/Sifflet/SiffML.hs b/Language/Sifflet/SiffML.hs
new file mode 100644
--- /dev/null
+++ b/Language/Sifflet/SiffML.hs
@@ -0,0 +1,474 @@
+-- | SiffML : Sifflet Markup Language.
+-- An XML application for storing and retrieving Sifflet programs
+-- and libraries.
+
+module Language.Sifflet.SiffML
+ (
+ ToXml(..)
+ , produceSiffMLFile
+ , consumeSiffMLFile
+ , xmlToFunctions
+ -- for testing
+ , testFromXml
+-- , consumeString
+ )
+
+where
+
+import Text.XML.HXT.Core
+
+import Data.Number.Sifflet
+import Language.Sifflet.Expr
+import Language.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 :: SysConfigList
+defaultOptions = [withIndent yes, withValidate 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 =
+ let literal label text =
+ -- future: (omit label arg.): selem label [txt text]
+ selem "literal" [selem label [txt text]]
+ in case expr of
+ EUndefined ->
+ eelem "undefined"
+ ESymbol (Symbol name) ->
+ selem "symbol" [txt name]
+
+ -- "Literals"
+ -- New way: duplicates parts of valueToXml (bad) ***
+ EBool b ->
+ -- future: selem "bool" [eelem (show b)]
+ selem "literal" [selem "bool" [eelem (show b)]]
+ EChar c ->
+ -- future: selem "char" [txt [c]]
+ literal "char" [c]
+ ENumber (Exact i) ->
+ -- future: selem "int" [txt (show i)]
+ literal "int" (show i)
+ ENumber (Inexact x) ->
+ -- future: selem "float" [txt (show x)]
+ literal "float" (show x)
+ EString s ->
+ -- future: selem "string" [txt s]
+ literal "string" s
+
+ EIf e1 e2 e3 ->
+ selem "if" [toXml e1, toXml e2, toXml e3]
+ EList xs ->
+ -- I predict that this is going to be troublesome! ***
+ -- No checking for whether the list elements are literals!
+ selem "literal" [selem "list"
+ (map (toXml . literalToValue) xs)]
+ -- future: selem "list" (map toXml xs)
+ ELambda _ _ -> error "exprToXml: not implemented for lambda expr"
+ ECall (Symbol name) xs ->
+ selem "call"
+ (selem "symbol" [txt name] :
+ map toXml xs)
+ _ -> errcats ["exprToXml: extended expr:", show expr]
+
+-- | Convert a literal expression to a value.
+-- It is an error if the expr is not a literal.
+-- Compare exprToValue in Expr.hs
+literalToValue :: Expr -> Value
+literalToValue e =
+ if exprIsLiteral e
+ then case e of
+ EBool b -> VBool b
+ EChar c -> VChar c
+ ENumber n -> VNumber n
+ EString s -> VString s
+ EList es -> VList (map literalToValue es)
+ EGroup e' -> literalToValue e'
+ _ -> error "literalToValue: expr is literal, but not literal?"
+ else error ("literalToValue: expr is not a literal: " ++ show e)
+
+xmlToExpr :: XMLConsumer XmlTree Expr
+xmlToExpr =
+ isElem >>>
+ (
+ (hasName "undefined" >>> constA EUndefined) <+>
+ (hasName "symbol" >>> getChildren >>> isText >>> getText >>>
+ arr (ESymbol . Symbol)) <+>
+
+ -- future: remove extra level "literal"
+ (hasName "literal" >>> getChildren >>> xmlToExpr) <+>
+
+ -- boolean values
+ (hasName "True" >>> constA (EBool True)) <+>
+ (hasName "False" >>> constA (EBool False)) <+>
+
+ -- chars
+ (hasName "char" >>> getChildren >>> isText >>> getText >>>
+ -- VVV head dangerous ???
+ arr (EChar . head)) <+>
+
+ -- numbers -- why not use parser instead of read???
+ (hasName "int" >>> getChildren >>> isText >>> getText >>>
+ arr (ENumber . Exact . read)) <+> -- read dangerous?
+ (hasName "float" >>> getChildren >>> isText >>> getText >>>
+ arr (ENumber . Inexact . read)) <+> -- read dangerous?
+
+ -- strings
+ (hasName "string" >>> getChildren >>> isText >>> getText >>>
+ arr EString) <+>
+
+
+ (hasName "if" >>> listA (getChildren >>> xmlToExpr) >>>
+ -- sometimes I get bogus run-time errors here about
+ -- this pattern [a, b, c] being non-exhaustive.
+ -- Of course, it *is* non-exhaustive; but it is
+ -- never violated in practice
+ arr (\ [a, b, c] -> EIf a b c)) <+>
+ -- This is very awkward, but needed for compatibility with the
+ -- present SiffML doctype:
+ (hasName "list" >>>
+ -- future?: listA (getChildren >>> xmlToExpr) >>>
+ -- Anyway, *why* does this not work???
+ listA (getChildren >>> xmlToExpr) >>>
+ -- past?:
+ -- listA (getChildren >>> xmlToValue >>> arr valueToLiteral') >>>
+ 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
+-- Still used in exprToXml in the EList case :-(
+
+instance ToXml Value where
+ toXml = valueToXml
+
+-- Is this still needed? ***
+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]]
+ VString s ->
+ selem "string" [txt s]
+ VNumber (Exact i) ->
+ selem "int" [txt (show i)]
+ VNumber (Inexact 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: still needed? ***
+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 VString) <+>
+ (hasName "int" >>> getChildren >>> isText >>> getText >>>
+ arr (VNumber . Exact . read)) -- dangerous?
+ <+>
+ (hasName "float" >>> getChildren >>> isText >>> getText >>>
+ arr (VNumber . Inexact . 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)
+ )
+
+-- | Types
+
+instance ToXml Type where
+ toXml = typeToXml
+
+typeToXml :: Type -> XMLProducer
+typeToXml vtype =
+ case vtype of
+ TypeVar typeVarName -> selem "type-variable" [txt typeVarName]
+ TypeCons "String" [] -> eelem "string-type"
+ TypeCons "Char" [] -> eelem "char-type"
+ TypeCons "Num" [] -> eelem "num-type"
+ TypeCons "Bool" [] -> eelem "bool-type"
+ TypeCons "List" [eltType] -> selem "list-type" [typeToXml eltType]
+ TypeCons "Function" [argT, resultT] ->
+ selem "function-type" [typeToXml argT, typeToXml resultT]
+ -- error "typeToXml: TypeCons Function cannot be converted to XML"
+ TypeCons _ _ ->
+ errcats ["typeToXml:", show vtype, "cannot be converted to XML"]
+
+xmlToType :: XMLConsumer XmlTree Type
+xmlToType =
+ isElem >>>
+ ((hasName "string-type" >>> constA typeString) <+>
+ (hasName "char-type" >>> constA typeChar) <+>
+ (hasName "num-type" >>> constA typeNum) <+>
+ (hasName "bool-type" >>> constA typeBool) <+>
+ (hasName "list-type" >>> getChildren >>> xmlToType >>> arr typeList) <+>
+ (hasName "function-type" >>>
+ listA (getChildren >>> xmlToType) >>>
+ -- there must be exactly two children, but I'm not checking
+ arr (\ ts -> TypeCons "Function" ts)) <+>
+ (hasName "type-variable" >>> getChildren >>>
+ isText >>> getText >>> arr TypeVar)
+ )
+
+-- | 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" [typeToXml retType],
+ selem "arg-types" (map typeToXml 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 Type
+ getReturnType = hasName "return-type" >>> getChildren >>> xmlToType
+
+ getArgTypes :: XMLConsumer XmlTree [Type]
+ getArgTypes = hasName "arg-types" >>>
+ listA (getChildren >>> xmlToType)
+
+ 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")
+-- [typeBool, typeNum, typeNum]
+-- typeNum
+-- (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) => Int -> a -> XMLConsumer XmlTree b -> IO ()
+testFromXml traceLevel src consumer = do
+ {
+ produceSiffMLFile src "test.xml"
+ ; results <- runX (readDocument
+ (defaultOptions ++ [withTrace traceLevel])
+ "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
+
+
+
+-- 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 "-"
diff --git a/Language/Sifflet/TypeCheck.hs b/Language/Sifflet/TypeCheck.hs
new file mode 100644
--- /dev/null
+++ b/Language/Sifflet/TypeCheck.hs
@@ -0,0 +1,590 @@
+module Language.Sifflet.TypeCheck
+ (valueType, typeCheckValues
+ , typeVarsIn
+ , Subst
+ , subst, substComp, idSubst, deltaSubst
+ , extend, unify
+ , TypeScheme(..), schematicsTS, unknownsTS, substTS
+ , TypeEnv, emptyTypeEnv, install, unknownsTE, substTE
+ , NameSupply(..), newNameSupply, nameSupplyNext, nameSupplyTake
+ , tcExpr, tcExprs
+ , tcVar, newInstance
+ , arrow
+ , envToTypeEnv, baseTypeEnv
+ , fromLambdaType, decideTypes
+ )
+
+where
+
+-- drop this after debugging:
+import System.IO.Unsafe(unsafePerformIO)
+
+import Control.Monad (foldM)
+
+import qualified Data.List as AList (lookup)
+
+import Data.Map as Map hiding (filter, foldr, lookup, map, null)
+import qualified Data.Map as Map (map, lookup)
+
+import Language.Sifflet.Expr
+import Text.Sifflet.Repr
+import Language.Sifflet.Util
+
+
+-- | Determine the type of a value.
+-- May result in a type variable.
+
+valueType :: Value -> SuccFail Type
+valueType v =
+ case v of
+ VBool _ -> Succ typeBool
+ VChar _ -> Succ typeChar
+ VNumber _ -> Succ typeNum
+ VString _ -> Succ typeString
+ VFun (Function _ atypes rtype _) -> Succ $ typeFunction atypes rtype
+
+ VList [] -> Succ $ typeList $ TypeVar "list_element"
+ VList (x:xs) ->
+ do
+ xtype <- valueType x
+ xstypes <- mapM valueType xs
+ if filter (/= xtype) xstypes == []
+ then Succ $ typeList 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.
+
+typeCheckValues :: [String] -> [Type] -> [Value] -> SuccFail [Value]
+typeCheckValues names types values =
+ let check :: (Map String Type) -> [String] -> [Type] -> [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 "typeCheckValues: mismatched list lengths"
+ in check empty names types values
+
+
+
+-- | Try to match a single type and value,
+-- may result in binding a type variable in a new environment
+-- or just the old environment
+-- (Note that this tries to produce a map of type variable names to Types,
+-- instead of TypeSchemes as with TypeEnv below)
+typeMatch :: Type -> Value -> (Map String Type) -> SuccFail (Map String Type)
+typeMatch atype value env =
+ let sorry x etype =
+ Fail $ repr x ++ ": " ++ etype ++ " expected"
+ in case (atype, value) of
+ -- easy cases
+ (TypeCons "Bool" [], VBool _) -> Succ env
+ (TypeCons "Bool" [], x) -> sorry x "True or False"
+ (TypeCons "Char" [], VChar _) -> Succ env
+ (TypeCons "Char" [], x) -> sorry x "character"
+ (TypeCons "Num" [], VNumber _) -> Succ env
+ (TypeCons "Num" [], x) -> sorry x "number"
+ (TypeCons "String" [], VString _) -> Succ env
+ (TypeCons "String" [], x) -> sorry x "string"
+ -- VV Harder
+ -- VV Are the avalues below supposed to be equal to the value above?
+ (TypeVar name, avalue) ->
+ case Map.lookup name env of
+ Nothing ->
+ -- bind type variable
+ valueType avalue >>= \ vtype ->
+ Succ $ Map.insert name vtype env
+ Just concreteType -> typeMatch concreteType avalue env
+ (TypeCons "List" [etype], VList lvalues) ->
+ case lvalues of
+ [] -> Succ env
+ v:vs ->
+ typeMatch etype v env >>=
+ typeMatch (typeList etype) (VList vs)
+ (TypeCons "Function" [_, _], _) ->
+ -- this will require matching type variables with type variables!
+ error "typeMatch: unimplemented case for TypeCons Function"
+ _ -> Fail $ "type mismatch: " ++ show (atype, value)
+
+
+-- The rest of this is based (loosely and conceptually) on the type checker
+-- chapters 8-9 of Simon L. Peyton Jones, The Implementation of Functional
+-- Programming Languages, Prentice Hall, 1987.
+-- Out of print but available on the web at
+-- http://research.microsoft.com/en-us/um/people/simonpj/papers/slpj-book-1987/
+--
+-- Chapter 8: Polymorphic Type Checking, by Peter Hancock.
+-- Chapter 9: A Type-Checker, by Peter Hancock.
+
+-- 9.2 Representation of Type Expressions
+-- ('a -> b' means the textbook notation 'a' corresponds (at least roughly)
+-- to the Sifflet code 'b'.)
+-- tvname -> Language.Sifflet.Expr.TypeVarName
+-- type_exp -> Language.Sifflet.Expr.Type
+-- tvars_in -> typeVarsIn
+
+typeVarsIn :: Type -> [TypeVarName]
+typeVarsIn atype =
+ let tvarsIn atype' result =
+ case atype' of
+ TypeVar vname -> vname : result
+ TypeCons _ctor ts -> foldr tvarsIn result ts
+ -- TypeList t -> foldr tvarsIn result [t]
+ -- TypeFunction ats rt -> foldr tvarsIn result (rt:ats)
+ -- _ -> []
+ in tvarsIn atype []
+
+-- 9.3 Success and Failure
+-- reply -> Language.Sifflet.Util.SuccFail
+
+-- 9.4 Solving Equations
+-- 9.4.1 Substitutions
+-- subst -> Subst
+-- sub_type -> subst
+-- scomp -> substComp
+-- id_subst -> idSubst
+-- delta -> deltaSubst
+
+-- | The type of a substitution function, which maps type variables to types
+
+type Subst = TypeVarName -> Type
+
+-- | Apply a substitution function to a type (possibly a type with variables)
+
+subst :: Subst -> Type -> Type
+subst phi typeExpr =
+ case typeExpr of
+ TypeVar tvn -> phi tvn
+ -- TypeList etype -> TypeList (subst phi etype)
+ -- TypeFunction atypes rtype ->
+ -- TypeFunction (map (subst phi) atypes) (subst phi rtype)
+ TypeCons ctor atypes ->
+ TypeCons ctor (map (subst phi) atypes)
+
+-- | Composing two substitutions
+
+substComp :: Subst -> Subst -> Subst
+substComp sub2 sub1 tvn = subst sub2 (sub1 tvn)
+
+-- | Identity substitution
+
+idSubst :: Subst
+idSubst tvn = TypeVar tvn
+
+-- | A delta substitution is one that affects just a single variable.
+
+deltaSubst :: TypeVarName -> Type -> Subst
+deltaSubst tvn typeExpr tvn' =
+ if tvn == tvn'
+ then typeExpr
+ else TypeVar tvn'
+
+-- 9.4.2. Unification
+-- extend -> extend
+-- unify -> unify
+-- unifyl -> unifyList
+
+-- | Try to extend a substitution by adding a single variable-value pair
+
+extend :: Subst -> TypeVarName -> Type -> SuccFail Subst
+extend phi tvn t =
+ if t == TypeVar tvn
+ then Succ phi
+ else if tvn `elem` typeVarsIn t
+ then Fail ("occurs check: " ++ tvn ++ " is in " ++ (show t))
+ else Succ (deltaSubst tvn t `substComp` phi)
+
+-- extend is untested; we can wait until unify to test
+
+unify :: Subst -> (Type, Type) -> SuccFail Subst
+unify phi (TypeVar tvn, t) =
+ if phi tvn == TypeVar tvn
+ then extend phi tvn (subst phi t)
+ else unify phi (phi tvn, subst phi t)
+unify phi (TypeCons tcn ts, TypeVar tvn) =
+ unify phi (TypeVar tvn, TypeCons tcn ts)
+unify phi types@(TypeCons tcn ts, TypeCons tcn' ts') =
+ if tcn == tcn'
+ then unifyList phi (zip ts ts')
+ else Fail ("cannot unify " ++ show (fst types) ++
+ " with " ++ show (snd types))
+
+unifyList :: Subst -> [(Type, Type)] -> SuccFail Subst
+unifyList = foldM unify
+
+-- 9.5 Keeping track of types
+-- 9.5.2 Look to the variables
+-- type_scheme -> TypeScheme
+-- SCHEME -> TypeScheme
+-- unknowns_scheme -> unknownsTS
+-- sub_scheme -> substTS
+
+-- | A TypeScheme (TypeScheme schematicVariables typeExpression)
+-- is a sort of type template, in which
+-- schematic variables (i.e., type parameters or "generics")
+-- are made explicit; any other type variables
+-- in the type expression are unknowns
+
+data TypeScheme = TypeScheme [TypeVarName] Type
+ deriving (Eq, Show)
+
+schematicsTS :: TypeScheme -> [TypeVarName]
+schematicsTS (TypeScheme schVars _) = schVars
+
+unknownsTS :: TypeScheme -> [TypeVarName]
+unknownsTS (TypeScheme schVars t) =
+ [tv | tv <- typeVarsIn t, not (tv `elem` schVars)]
+
+-- | Apply a substitution to a type scheme, taking care to affect
+-- only the unknowns, not the schematic variables
+
+substTS :: Subst -> TypeScheme -> TypeScheme
+substTS phi (TypeScheme schVars t) =
+ let phi' :: Subst
+ phi' tvn =
+ -- phi' is like phi but excludes the schematic variables
+ if tvn `elem` schVars
+ then TypeVar tvn
+ else phi tvn
+ in TypeScheme schVars (subst phi' t)
+
+-- 9.5.3 Type environments
+-- I'll use maps instead of association lists
+-- type_env -> TypeEnv
+-- unknowns_te -> unknownsTE
+-- sub_te -> substTE
+
+-- | A type environment maps type variable names to type schemes.
+-- Oh, is it really type variable names, or just names?
+-- It seems to me that in envToTypeEnv, it's function names,
+-- instead of type variable names.
+
+type TypeEnv = Map TypeVarName TypeScheme
+
+emptyTypeEnv :: TypeEnv
+emptyTypeEnv = Map.empty
+
+-- -- | The domain of a type environment
+
+-- dom :: TypeEnv -> [TypeVarName]
+-- dom = keys
+
+-- | The range of a type environment
+
+rng :: TypeEnv -> [TypeScheme]
+rng = elems
+
+-- -- | The type scheme value of a type variable name
+-- -- This will fail, of course, if the variable name is not
+-- -- bound in the type environment.
+-- val :: TypeEnv -> TypeVarName -> TypeScheme
+-- val = (!)
+
+-- | Insert a new type variable and its type scheme value
+install :: TypeEnv -> TypeVarName -> TypeScheme -> TypeEnv
+install te tvn ts = insert tvn ts te
+
+-- | The unknowns of a type environment
+
+unknownsTE :: TypeEnv -> [TypeVarName]
+unknownsTE gamma = concatMap unknownsTS (rng gamma)
+
+substTE :: Subst -> TypeEnv -> TypeEnv
+substTE phi gamma = Map.map (substTS phi) gamma
+
+-- 9.6 New variables
+-- I diverge from the "easy" way given in the book
+
+-- | A source of variable names
+
+data NameSupply = NameSupply TypeVarName Int -- prefix, count
+ deriving (Eq, Show)
+
+-- | Creates a name supply
+
+newNameSupply :: TypeVarName -> NameSupply
+newNameSupply prefix = NameSupply prefix 1
+
+-- | Produces next variable from a name supply
+
+nameSupplyNext :: NameSupply -> (TypeVarName, NameSupply)
+nameSupplyNext (NameSupply prefix count) =
+ (prefix ++ show count, NameSupply prefix (count + 1))
+
+-- | Produces next several variables from a name supply
+
+nameSupplyTake :: NameSupply -> Int -> ([TypeVarName], NameSupply)
+nameSupplyTake (NameSupply prefix count) n =
+ ([prefix ++ show i | i <- [count .. count+n-1]],
+ NameSupply prefix (count + n))
+
+-- 9.7 The type checker
+-- tc -> tcExpr
+-- tcl -> tcExprs (type checks a list of Expr)
+--
+-- Additional functions (?) tcExprTree ??
+
+-- | Type check an expression
+
+tcExpr :: TypeEnv -> NameSupply -> Expr -> SuccFail (Subst, Type, NameSupply)
+tcExpr te ns expr =
+ let prim ptype = Succ (idSubst, ptype, ns)
+ in case expr of
+ EUndefined ->
+ let (tvn, ns') = nameSupplyNext ns
+ in Succ (idSubst, TypeVar tvn, ns')
+
+ EBool _ -> prim typeBool
+ EChar _ -> prim typeChar
+ ENumber _ -> prim typeNum
+ EString _ -> prim typeString
+
+ ESymbol (Symbol name) -> tcVar te ns name
+ EIf c a b -> tcIf te ns c a b
+ EList exprs -> tcList te ns exprs
+ ELambda (Symbol x) body -> tcLambda te ns x body
+ EApp f arg -> tcApp te ns f arg
+ ECall _ _ -> tcExpr te ns (callToApp expr)
+
+ -- EOp and EGroup are not needed in Sifflet itself,
+ -- only for export
+ EOp _op _ _ -> Fail "tcExpr: not implemented for EOp"
+ EGroup e -> tcExpr te ns e
+
+-- 9.7.1 Type checking lists of expressions
+-- tcl -> tcExprs
+-- tcl1 -> tcExprs1
+-- tcl2 -> tcExprs2
+-- This occurs in "two stages":
+-- 1. Type check each expression in the list, building up the
+-- type environment as we scan through it.
+-- 2. Cumulatively compose all the substitutions found,
+-- and make sure each type found is a fixed point of the
+-- final substitution.
+-- NOTE: This is to check a list of Exprs, not an Expr of the type EList.
+-- See tcList.
+
+tcExprs :: TypeEnv -> NameSupply -> [Expr]
+ -> SuccFail (Subst, [Type], NameSupply)
+tcExprs _te ns [] = Succ (idSubst, [], ns)
+tcExprs te ns (e:es) = do
+ {
+ (phi, t, ns') <- tcExpr te ns e
+ ; tcExprs1 te ns' es phi t
+ }
+
+tcExprs1 :: TypeEnv -> NameSupply -> [Expr] -> Subst -> Type
+ -> SuccFail (Subst, [Type], NameSupply)
+tcExprs1 te ns es phi t = do
+ {
+ (psi, ts, ns') <- tcExprs (substTE phi te) ns es
+ ; tcExprs2 phi t psi ts ns'
+ }
+
+tcExprs2 :: Subst -> Type -> Subst -> [Type] -> NameSupply
+ -> SuccFail (Subst, [Type], NameSupply)
+tcExprs2 phi t psi ts ns =
+ Succ (substComp psi phi, subst psi t : ts, ns)
+
+-- 9.7.2 Type checking variables
+-- tcvar -> tcVar
+-- newinstance -> newInstance
+-- al_to_subst -> alistToSubst
+
+-- | Type check a variable (actually the variable name).
+-- Find the type scheme associated with the variable in the type environment.
+-- Return a "new instance" of the type scheme, in which its schematic variables
+-- are replaced by new variables, and the unknowns are left as they are.
+
+tcVar :: TypeEnv -> NameSupply -> String -> SuccFail (Subst, Type, NameSupply)
+tcVar te ns name =
+ case Map.lookup name te of
+ Nothing ->
+ Fail ("BUG in type checker: tcVar: unable to find " ++ name ++
+ " in type environment")
+ Just ntype ->
+ let (t, ns') = newInstance ns ntype
+ in Succ (idSubst, t, ns')
+
+newInstance :: NameSupply -> TypeScheme -> (Type, NameSupply)
+newInstance ns (TypeScheme schVars t) =
+ let (names, ns') = nameSupplyTake ns (length schVars)
+ alist = zip schVars names
+ phi = alistToSubst alist
+ in (subst phi t, ns')
+
+-- | Convert an association list of type variable names into a substitution
+
+alistToSubst :: [(TypeVarName, TypeVarName)] -> Subst
+alistToSubst alist tvn =
+ case AList.lookup tvn alist of
+ Just tvn' -> TypeVar tvn'
+ Nothing -> TypeVar tvn
+
+-- 9.7.3 Type checking application
+-- tcap -> tcApp
+-- a $arrow b -> a `arrow` b = TypeCons "Function" [a, b]
+
+tcApp :: TypeEnv -> NameSupply -> Expr -> Expr
+ -> SuccFail (Subst, Type, NameSupply)
+tcApp te ns e1 e2 =
+ let (tvn, ns') = nameSupplyNext ns
+ in do
+ {
+ (phi, [t1, t2], ns'') <- tcExprs te ns' [e1, e2]
+ ; phi' <- unify phi (t1, t2 `arrow` (TypeVar tvn))
+ ; Succ (phi', phi' tvn, ns'')
+ }
+
+arrow :: Type -> Type -> Type
+arrow a b = TypeCons "Function" [a, b]
+
+
+-- 9.7.4 Type checking lambda abstractions
+--
+-- LAMBDA -> ELambda
+
+tcLambda :: TypeEnv -> NameSupply -> String -> Expr
+ -> SuccFail (Subst, Type, NameSupply)
+tcLambda te ns x e =
+ let (tvn, ns') = nameSupplyNext ns
+ te' = install te x (TypeScheme [] (TypeVar tvn))
+ in do
+ {
+ (phi, t, ns'') <- tcExpr te' ns' e
+ ; Succ (phi, phi tvn `arrow` t, ns'')
+ }
+
+-- 9.7.5 Type checking let expressions
+-- Not needed, at least for the present
+
+-- 9.7.6 Type checking letrec expressions
+-- Not needed, at least for the present
+
+
+
+-- Extras (not in the textbook)
+
+-- | Decide the type of a function -- called by the function editor
+-- when the Apply button is clicked.
+-- 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 Succ (argtypes, returntype) if successful;
+-- Fail errormessage otherwise.
+
+decideTypes :: String -> Expr -> [String] -> Env -> SuccFail([Type], Type)
+decideTypes name body args env =
+ let te = envToTypeEnv env
+ -- extend te to bind name to a type variable that will not be used
+ te' = install te name (TypeScheme [] (TypeVar "u"))
+ result :: SuccFail (Type, ([Type], Type))
+ result = do
+ {
+ expr <- toLambdaExpr args body
+ ; (_, t, _) <- tcExpr te' (newNameSupply "t") expr
+ -- ; fromLambdaType t
+ ; res <- fromLambdaType t
+ ; Succ (t, res)
+ }
+ in unsafePerformIO $ do
+ {
+ putStrLn "decideTypes:"
+ ; print (args, body)
+ ; putStrLn "::"
+ -- ; print result
+ -- ; return result
+ ; case result of
+ Succ (t, res) -> do { print t ; return (Succ res) }
+ Fail msg -> do { putStrLn msg; return (Fail msg) }
+ }
+
+fromLambdaType :: Type -> SuccFail ([Type], Type)
+fromLambdaType t =
+ case t of
+ TypeCons "Function" [t1, t2] ->
+ case t2 of
+ TypeCons "Function" _ ->
+ do
+ {
+ (atypes, rtype) <- fromLambdaType t2
+ ; return (t1:atypes, rtype)
+ }
+ _ ->
+ Succ ([t1], t2)
+ TypeCons "Function" _ ->
+ error ("fromLambdaType: invalid function type " ++ show t)
+ _ -> error ("fromLambdaType: non-function type " ++ show t)
+
+-- | Type check an IF expression
+-- *** Failure messages need improvement ***
+
+tcIf :: TypeEnv -> NameSupply -> Expr -> Expr -> Expr
+ -> SuccFail (Subst, Type, NameSupply)
+tcIf te ns expr1 expr2 expr3 = do
+ {
+ (phi, ts, ns') <- tcExprs te ns [expr1, expr2, expr3]
+ ; -- assert ts has length 3
+ phi' <- unifyList phi [(head ts, typeBool), (ts !! 1, ts !! 2)]
+ ; return (phi', subst phi' (ts !! 1), ns')
+ }
+
+-- | Type check a list expression.
+-- NOTE: This is to check a single Expr with the EList type,
+-- in which all elements must be of the same type,
+-- not a general list of Exprs of possibly mixed type.
+-- See tcExprs.
+--
+-- *** Failure messages need improvement ***
+--
+-- IDEA: can this be reduced to [] and application of (:)?
+
+tcList :: TypeEnv -> NameSupply -> [Expr]
+ -> SuccFail (Subst, Type, NameSupply)
+tcList te ns exprs =
+ case exprs of
+ [] ->
+ let (tvn, ns') = nameSupplyNext ns
+ in Succ (idSubst, typeList (TypeVar tvn), ns')
+ e:es ->
+ do
+ {
+ (phi, ts, ns') <- tcExprs te ns [e, EList es]
+ ; -- assert ts has length 2
+ phi' <- unify phi (typeList (head ts), ts !! 1)
+ ; return (phi', subst phi' (ts !! 1), ns')
+ }
+
+
+
+-- | Create a TypeEnv from an Env
+-- Bindings on the left replace bindings of the same name on the right,
+-- if any.
+
+envToTypeEnv :: Env -> TypeEnv
+envToTypeEnv env =
+ let frameTE frame = Map.map vftype frame
+ in Map.unions (Prelude.map frameTE env)
+
+-- | The base type environment, derived from the base environment
+-- of the Sifflet language (built-in functions)
+
+
+baseTypeEnv :: TypeEnv
+baseTypeEnv = Map.map vftype (head baseEnv)
+
+vftype :: Value -> TypeScheme
+vftype (VFun f) = ftype f
+vftype _ = error "vftype: non-function value type"
+
+ftype :: Function -> TypeScheme
+ftype f =
+ let ft = uncurry typeFunction (functionArgResultTypes f)
+ -- treat /all/ type variables in ft as schematic
+ scvars = typeVarsIn ft
+ in TypeScheme scvars ft
diff --git a/Language/Sifflet/Util.hs b/Language/Sifflet/Util.hs
new file mode 100644
--- /dev/null
+++ b/Language/Sifflet/Util.hs
@@ -0,0 +1,135 @@
+module Language.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/RELEASE-NOTES b/RELEASE-NOTES
new file mode 100644
--- /dev/null
+++ b/RELEASE-NOTES
@@ -0,0 +1,159 @@
+% RELEASE NOTES
+
+Release notes for sifflet and sifflet-lib
+
+This is the RELEASE-NOTES file for both sifflet and sifflet-lib.
+If you are editing it, be sure you are editing the original
+and not the copies in the app and lib subdirectories.
+
+Release 2.0.0.0, 2012 July 5
+----------------------------
+
+- Reorganized hierarchical modules to conform to
+ http://www.haskell.org/haskellwiki/Hierarchical_module_names
+ - Sifflet.Data.X is now Data.Sifflet.X
+ for X in [Functoid, Geometry, Tree, TreeGraph,
+ TreeLayout, WGraph]
+ - Sifflet.Foreign.X is now Language.Sifflet.Export.X
+ for X in [Exporter, Haskell, Python, ToHaskell, ToPython, ToScheme]
+ - Sifflet.Language.X is now Language.Sifflet.X
+ for X in [Expr, Parser, SiffML]
+ - Sifflet.Rendering.X is now Graphics.Rendering.Sifflet.X
+ for X in [Draw, DrawTreeGraph]
+ - Sifflet.Text.X is now Text.Sifflet.X
+ for X in [Pretty, Repr]
+ - Sifflet.UI.X is now Graphics.UI.Sifflet.X
+ for X in [Callback, Canvas, Frame, GtkForeign, GtkUtil, LittleGtk,
+ RPanel, Tool, Types, Window, Workspace]
+ - Sifflet.UI is now Graphics.UI.Sifflet
+ - Sifflet.Util is now Language.Sifflet.Util, and
+ Sifflet.Examples is now Language.Sifflet.Examples.
+ (not clear that this is really the best place for it;
+ maybe it hsould be split into pieces, such as
+ Control.Monad.SuccFail, ...)
+ - Sifflet.Examples is now Language.Sifflet.Examples.
+
+- File menu command to save the image of the Workspace or any
+ open editor window, in SVG, PS, or PDF format.
+
+- Implemented type checking with type inference.
+ Type inference can be used for export to languages
+ that require type declarations.
+ Type checking error messages are *not* friendly
+ for novice programmers; this needs improvement.
+
+- Editing a function can now change its type.
+ - It is now possible to change the arguments of a function
+ (add, rename, or remove arguments, or for functional
+ arguments, change the kind or arity).
+
+- Bug fixes:
+ - Fixed bug where the program crashed from incomplete 'if' trees
+ - Various small bug fixes.
+
+- Added RELAX NG schema for siffml version 2.0 (in datafiles).
+ This is an upwards-compatible extension of siffml 1.0,
+ which adds FunctionType to the alternatives for SiffletType.
+
+- Added RELAX NG schema for siffml version 1.0 (in datafiles)
+
+Release 1.2.5.1, 2012 Jun 14 (or later)
+---------------------------------------
+
+- Compatibility with mtl 2.1.1
+
+Release 1.2.5, 2012 Jun 1
+-------------------------
+
+- Compatibility with GHC 7.4.1
+
+Release 1.2.4, 2011 Mar 18
+--------------------------
+
+- Compatibility with HXT > 9.0
+
+Release 1.2.3, 2011 Feb 18
+--------------------------
+
+- Compatibility with GHC 7 and Haskell Platform 2011.2
+
+Release 1.2.2, 2010 Dec 3
+-------------------------
+
+- Offers to save changes before quitting
+
+Release 1.2.1, 2010 Nov 19
+--------------------------
+
+- Compatibility with Haskell GTK packages 0.12
+
+Release 1.2, 2010 Oct 30
+------------------------
+
+- Requires HXT 9.0
+- Avoids indirect dependency on curl
+
+Release 1.1, 2010 Aug 24
+------------------------
+
+- Improved Haskell exporter now removes most unnecessary
+ parentheses.
+- Exported Haskell code now uses the module Data.Number.Sifflet,
+ formerly Sifflet.Data.Number.
+- Sifflet now builds with slightly newer versions of the
+ Haskell "Gtk2hs" libraries (cairo, gtk, glib),
+ should work for versions >= 0.11.0 and < 0.12.
+
+Release 1.0, 2010 Aug 11
+------------------------
+
+- Sifflet now has exporters to Scheme, Python, and Haskell and a small
+ supporting "library" for each of those languages.
+ This is intended for beginning students who are learning these
+ languages, not for "industrial-strength" code production.
+
+- Although the exporters apparently generate correct code,
+ there are at present too many parentheses -- a few extra in Python,
+ many extra in Haskell; no extra parentheses in Scheme, of course.
+
+- Sifflet has a new number type, Sifflet.Data.Number.Number, which allows
+ numbers to be exact or inexact, almost as in Scheme.
+ Originally intended for the Scheme exporter, it is now
+ also used internally by Sifflet's interpreter.
+
+- The code is reorganized. There is now a separate library package,
+ sifflet-lib, in addition to the sifflet package which provides
+ only the executable. At present, the library's API is highly
+ unstable.
+
+- Sifflet has a new parser for user inputs, made with Parsec,
+ allowing more intuitive input
+ of numbers (liberation from Haskell number syntax:
+ for example, 0.0 can now be entered as 0.0, 0., or .0)
+ and providing more intelligible error messages
+ for some kinds of invalid input.
+
+- Sifflet requires Gtk2hs packages (gtk, glib, cairo) version 0.11;
+ support for the 0.10 Gtk2hs packages is dropped.
+
+Release 0.1.7, 2010 June 10
+---------------------------
+
+- Tightened upper bounds on package dependency versions, in anticipation of
+ incompatible changes in the fgl API.
+- No bug fixes or new features.
+- Users who are staying with fgl == 5.4.2.2 will not benefit from upgrading
+ to Sifflet 0.1.7.
+
+Release 0.1.6, 2010 May 27
+--------------------------
+
+- Sifflet offers to save your work if you give the quit or
+ open file command and have unsaved changes.
+- Sifflet now builds with Gtk2hs 0.11.
+- Some bug fixes and improved error checking.
+
+Release 0.1.5, 2010 May 13
+--------------------------
+
+First public release.
diff --git a/Sifflet/Data/Functoid.hs b/Sifflet/Data/Functoid.hs
deleted file mode 100644
--- a/Sifflet/Data/Functoid.hs
+++ /dev/null
@@ -1,98 +0,0 @@
-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
deleted file mode 100644
--- a/Sifflet/Data/Geometry.hs
+++ /dev/null
@@ -1,162 +0,0 @@
-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/Tree.hs b/Sifflet/Data/Tree.hs
deleted file mode 100644
--- a/Sifflet/Data/Tree.hs
+++ /dev/null
@@ -1,67 +0,0 @@
--- 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
deleted file mode 100644
--- a/Sifflet/Data/TreeGraph.hs
+++ /dev/null
@@ -1,250 +0,0 @@
-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
deleted file mode 100644
--- a/Sifflet/Data/TreeLayout.hs
+++ /dev/null
@@ -1,660 +0,0 @@
-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
deleted file mode 100644
--- a/Sifflet/Data/WGraph.hs
+++ /dev/null
@@ -1,410 +0,0 @@
-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
deleted file mode 100644
--- a/Sifflet/Examples.hs
+++ /dev/null
@@ -1,277 +0,0 @@
-module Sifflet.Examples
- (exampleFunctions
- , exampleFunctionNames
- , exampleEnv
- , foo, eFoo -- used in Testing.Unit.ExprTests
- , eMax -- ditto
- , eFact -- ditto
- , getExampleFunction
- )
-
-where
-
-import Sifflet.Language.Expr
-
--- 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 body = ePlus (eSym "n")
- (eCall "buggySumFromZero"
- [eMinus (eSym "n") (eInt 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"] sumbody)
-
-sumbody :: Expr
-sumbody =
- eIf (eCall "null" [eSym "xs"])
- (eInt 0)
- (ePlus (eCall "head" [eSym "xs"])
- (eCall "sum" [eCall "tail" [eSym "xs"]]))
-
-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
deleted file mode 100644
--- a/Sifflet/Foreign/Exporter.hs
+++ /dev/null
@@ -1,191 +0,0 @@
-module Sifflet.Foreign.Exporter
- (Exporter
- , simplifyExpr
- , commonRuleHigherPrec
- , commonRuleAtomic
- , commonRuleLeftToRight
- , commonRuleAssocRight
- , commonRuleFuncOp
- , commonRulesForSimplifyingExprs
- , ruleIfRight
- , ruleRightToLeft
- , applyFirstMatch
- , findFixed
- )
-
-where
-
-import Sifflet.Language.Expr
-
--- | The type of a function to export (user) functions to a file.
-type Exporter = Functions -> FilePath -> IO ()
-
--- | Simplify an expression by applying rules
--- top-down throughout the expression
--- tree and repeatedly until there is no change.
--- This is intended for removing extra parentheses,
--- but could be used for other forms of simplification.
---
--- Should each rule also know the level in the original expr tree,
--- with 0 = top level (root)?
--- That would require additional arguments.
-
-simplifyExpr :: [Expr -> Expr] -> Expr -> Expr
-simplifyExpr rules expr =
- findFixed (topDown (applyFirstMatch rules)) expr
-
--- | Repeatedly apply a function to an object until there is no change,
--- that is, until reaching a fixed point of the function, a point
--- where f x == x.
-
-findFixed :: (Eq a) => (a -> a) -> a -> a
-findFixed f x =
- let x' = f x
- in if x' == x then x else findFixed f x'
-
-
--- | Common rules for simplifying parentheses.
-
--- | Remove ()'s around a higher precedence operator: e.g.,
--- (a * b) + c ==> a * b + c
--- a + (b * c) ==> a + b * c
-
-commonRuleHigherPrec :: Expr -> Expr
-commonRuleHigherPrec e =
- case e of
- EOp op1 (EGroup (EOp op2 subleft subright)) right ->
- -- left side
- if opPrec op2 > opPrec op1
- then EOp op1 (EOp op2 subleft subright) right
- else e
- EOp op1 left (EGroup (EOp op2 subleft subright)) ->
- -- right side
- if opPrec op2 > opPrec op1
- then EOp op1 left (EOp op2 subleft subright)
- else e
- _ -> e
-
--- | Remove ()'s around an atomic expression -- a variable,
--- literal, or list
-
-commonRuleAtomic :: Expr -> Expr
-commonRuleAtomic e =
- case e of
- EGroup e' ->
- if exprIsAtomic e'
- then e'
- else e
- _ -> e
-
--- | Remove ()'s in the case of (a op1 b) op2 c,
--- if op1 and op2 have the same precedence, and
--- both group left to right, since
--- left to right evaluation makes them unnecessary.
-
-commonRuleLeftToRight :: Expr -> Expr
-commonRuleLeftToRight e =
- case e of
- EOp op2 (EGroup (EOp op1 a b)) c ->
- if opPrec op1 == opPrec op2 &&
- opGrouping op1 == GroupLtoR &&
- opGrouping op2 == GroupLtoR
- then EOp op2 (EOp op1 a b) c
- else e
- _ -> e
-
--- | Remove ()'s in the case of a op (b op c)
--- if op groups right to left, and note that
--- it is the same operator op in both places
--- (though I don't know if that restriction is necessary).
--- This applies to (:) in Haskell, for example:
--- x : y : zs == x : (y : zs)
-
-ruleRightToLeft :: Expr -> Expr
-ruleRightToLeft e =
- case e of
- EOp op1 a (EGroup (EOp op2 b c)) ->
- if op1 == op2 && opGrouping op1 == GroupRtoL
- then EOp op1 a (EOp op2 b c)
- else e
- _ -> e
-
--- Associativity on the right
--- x + (y + z) --> x + y + z
--- for + and all other associative operators.
--- We could add, the left-hand rule
--- (x + y) + z --> x + y + z
--- but do not need it,
--- because it is already covered by the left to right rule
--- for operators of equal precedence.
--- It must be the SAME operator on both sides, of course!
-
-commonRuleAssocRight :: Expr -> Expr
-commonRuleAssocRight e =
- case e of
- EOp op1 a (EGroup (EOp op2 b c)) ->
- if op1 == op2 && opAssoc op1
- then EOp op1 a (EOp op2 b c)
- else e
- _ -> e
-
--- An if expression as the right operand can be unparenthesized.
--- but not so on the left (at least in Haskell):
--- x + (if ...) --> x + if ...
--- but NOT
--- (if ...) + x --> if ... + x (NOT!)
-
-ruleIfRight :: Expr -> Expr
-ruleIfRight e =
- case e of
- EOp op a (EGroup i@(EIf _ _ _)) -> EOp op a i
- _ -> e
-
--- In Haskell, a function application has precedence over all
--- operators. This applies in both the left and right operands.
-
-commonRuleFuncOp :: Expr -> Expr
-commonRuleFuncOp e =
- case e of
- EOp op a (EGroup c@(ECall _ _)) -> EOp op a c
- EOp op (EGroup c@(ECall _ _)) b -> EOp op c b
- _ -> e
-
--- | A list of common rules for simplifying expressions.
--- Does *not* include ruleIfRight, since that works
--- for Haskell but not Python.
-
-commonRulesForSimplifyingExprs :: [Expr -> Expr]
-commonRulesForSimplifyingExprs =
- [commonRuleHigherPrec
- , commonRuleAtomic
- , commonRuleLeftToRight
- , commonRuleAssocRight
- , commonRuleFuncOp]
-
--- | Try the first rule in a list to see if it changes an expression,
--- returning the new expression if it does; otherwise, try the next rule,
--- and so on; if no rule changes the expression, then return the expression.
--- (Note that (applyFirstMatch rules) is itself a rule.)
-
-applyFirstMatch :: [Expr -> Expr] -> Expr -> Expr
-applyFirstMatch [] e = e
-applyFirstMatch (r:rs) e =
- let e' = r e
- in if e' /= e
- then e'
- else applyFirstMatch rs e
-
--- | Apply a rule top-down to all levels of an expression.
--- Normally, the "rule" would be a value of (applyFirstMatch rules).
-topDown :: (Expr -> Expr) -> Expr -> Expr
-topDown f e =
- let tdf = topDown f
- e' = f e
- in case e' of
- EIf c a b -> EIf (tdf c) (tdf a) (tdf b)
- EList xs -> EList (map tdf xs)
- ECall fsym args -> ECall fsym (map tdf args)
- EOp op left right -> EOp op (tdf left) (tdf right)
- EGroup e'' -> EGroup (tdf e'')
- _ -> e'
-
diff --git a/Sifflet/Foreign/Haskell.hs b/Sifflet/Foreign/Haskell.hs
deleted file mode 100644
--- a/Sifflet/Foreign/Haskell.hs
+++ /dev/null
@@ -1,155 +0,0 @@
--- | Abstract syntax tree and pretty-printing for Haskell 98.
--- This is only a small subset of the Haskell 98 syntax,
--- so we do not need to pull in haskell-src and all its complexity.
--- Moreover, haskell-src gives too little control over the format
--- of pretty-printed text output.
-
-module Sifflet.Foreign.Haskell
- (HsPretty(..)
- , Module(..)
- , ExportSpec(..)
- , ImportDecl(..)
- , Decl(..)
- , operatorTable
- )
-
-where
-
-import Data.List (intercalate)
-import qualified Data.Map as M
-
-import Sifflet.Language.Expr
-import Sifflet.Text.Pretty
-
-class HsPretty a where
-
- hsPretty :: a -> String
-
- hsPrettyList :: String -> String -> String -> [a] -> String
- hsPrettyList pre tween post xs =
- pre ++ intercalate tween (map hsPretty xs) ++ post
-
-instance HsPretty Symbol where
- hsPretty = pretty
-
-instance HsPretty Operator where
- hsPretty = pretty
-
--- | A Haskell module; moduleDecls are functions and variables.
-
-data Module = Module {moduleName :: String
- , moduleExports :: Maybe ExportSpec
- , moduleImports :: ImportDecl
- , moduleDecls :: [Decl]
- }
- deriving (Eq, Show)
-
-instance HsPretty Module where
- hsPretty m =
- let pmod = "module " ++ moduleName m
- pexports = case moduleExports m of
- Nothing -> ""
- Just exports -> hsPretty exports
- pimports = hsPretty (moduleImports m)
- pdecls = sepLines2 (map hsPretty (moduleDecls m))
- in unlines [pmod ++ " where",
- pexports,
- pimports,
- pdecls]
-
--- | A Haskell module's export spec: a list of function and
--- variable identifiers
-data ExportSpec = ExportSpec [String]
- deriving (Eq, Show)
-
-instance HsPretty ExportSpec where
- hsPretty (ExportSpec exports) =
- "(" ++ sepCommaSp exports ++ ")"
-
--- | A Haskell modules import decls: a list of module identifiers.
--- No support for "qualified" or "as" or for selecting only some
--- identifiers from the imported modules.
-
-data ImportDecl = ImportDecl [String]
- deriving (Eq, Show)
-
-instance HsPretty ImportDecl where
- hsPretty (ImportDecl modnames) =
- let idecl modname = "import " ++ modname
- in unlines (map idecl modnames)
-
--- | Wrap a string in parentheses
-par :: String -> String
-par s = "(" ++ s ++ ")"
-
--- | A Haskell function or variable declaration.
--- An explicit type declaration is optional.
--- Thus we have just enough for
--- name :: type
--- name [args] = expr.
--- Of course [args] would be empty if it's just a variable.
-data Decl = Decl {declIdent :: String
- , declType :: Maybe [String]
- , declParams :: [String]
- , declExpr :: Expr
- }
- deriving (Eq, Show)
-
-instance HsPretty Decl where
- hsPretty decl =
- let ptypeDecl = "" -- to be improved **
- pparams = case declParams decl of
- [] -> ""
- params -> " " ++ sepSpace params
- pbody = hsPretty (declExpr decl)
- in ptypeDecl ++
- declIdent decl ++ pparams ++ " =\n" ++
- " " ++ pbody
-
--- | HsPretty expressions. This is going to be like in Python.hs.
-instance HsPretty Expr where
- hsPretty pexpr =
- case pexpr of
- EUndefined -> "undefined"
- EChar c -> show c
- ENumber n -> show n
- EBool b -> show b
- EString s -> show s
- ESymbol sym -> hsPretty sym
- EList xs -> hsPrettyList "[" ", " "]" xs
- EIf c a b ->
- unwords ["if", hsPretty c, "then", hsPretty a, "else", hsPretty b]
- EGroup e -> par (hsPretty e)
- ECall fexpr argExprs ->
- hsPretty fexpr ++ " " ++ hsPrettyList "" " " "" argExprs
- EOp op left right ->
- unwords [hsPretty left, hsPretty op, hsPretty right]
-
--- | The Haskell operators.
--- Now what about the associativity of (:)?
--- It really doesn't even make sense to ask if (:) is
--- associative in the usual sense,
--- since (x1 : x2) : xs == x1 : (x2 : xs)
--- is not only untrue, but the left-hand side is
--- a type error, except maybe in some very special cases
--- (and then the right-hand side would probably be a type error).
--- Is (:) what is called a "right-associative" operator?
--- And do I need to expand my Operator type to
--- include this? And then what about (-) and (/)???
--- Does this affect their relationship with (+) and (-)?
-
-operatorTable :: M.Map String Operator
-operatorTable =
- M.fromList (map (\ op -> (opName op, op))
- [ Operator "*" 7 True GroupLtoR -- times
- , Operator "+" 6 True GroupLtoR -- plus
- , Operator "-" 6 False GroupLtoR -- minus
- , Operator ":" 5 False GroupRtoL -- cons
- , Operator "==" 4 False GroupNone -- eq
- , Operator "/=" 4 False GroupNone -- ne
- , Operator ">" 4 False GroupNone -- gt
- , Operator ">=" 4 False GroupNone -- ge
- , Operator "<" 4 False GroupNone -- lt
- , Operator "<=" 4 False GroupNone -- le
- ])
-
diff --git a/Sifflet/Foreign/Python.hs b/Sifflet/Foreign/Python.hs
deleted file mode 100644
--- a/Sifflet/Foreign/Python.hs
+++ /dev/null
@@ -1,194 +0,0 @@
--- | 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
- (PyPretty(..)
- , PModule(..)
- , PStatement(..)
- , alterParens
- , ret
- , condS
- , var
- , ident
- , char
- , fun
- , operatorTable
- )
-
-where
-
-import Data.List (intercalate)
-import qualified Data.Map as M
-
-import Sifflet.Language.Expr
-import Sifflet.Text.Pretty
-
-class PyPretty a where
-
- pyPretty :: a -> String
-
- pyPrettyList :: String -> String -> String -> [a] -> String
- pyPrettyList pre tween post xs =
- pre ++ intercalate tween (map pyPretty xs) ++ post
-
-pyPrettyParens :: (PyPretty a) => [a] -> String
-pyPrettyParens = pyPrettyList "(" ", " ")"
-
-instance PyPretty Symbol where
- pyPretty = pretty
-
-instance PyPretty Operator where
- pyPretty = pretty
-
--- | Python module -- essentially a list of statements;
--- should it also have a name?
-data PModule = PModule [PStatement]
- deriving (Eq, Show)
-
-instance PyPretty PModule where
- pyPretty (PModule ss) = sepLines2 (map pyPretty ss)
-
--- | Python statement
-data PStatement = PReturn Expr
- | PImport String -- ^ import statement
- | PCondS Expr
- PStatement
- PStatement -- ^ if condition action alt-action
- | PFun Symbol
- [Symbol]
- PStatement -- ^ function name, formal parameters, body
- deriving (Eq, Show)
-
-instance PyPretty PStatement where
- pyPretty s =
- case s of
- PReturn e -> "return " ++ pyPretty e
- PImport modName -> "import " ++ modName
- PCondS c a b ->
- sepLines ["if " ++ pyPretty c ++ ":",
- indentLine 4 (pyPretty a),
- "else:",
- indentLine 4 (pyPretty b)]
- PFun fid params body ->
- sepLines ["def " ++ pyPretty fid ++
- pyPrettyParens params ++ ":",
- indentLine 4 (pyPretty body)]
-
--- | Expr as an instance of PyPretty.
--- This instance is only for Exprs as Python exprs,
--- for export to Python! It will conflict with the
--- one in ToHaskell.hs (or Haskell.hs).
---
--- The EOp case needs work to deal with precedences
--- and avoid unnecessary parens.
--- Note that this instance declaration is for *Python* Exprs.
--- Haskell Exprs of course should not be pretty-printed
--- the same way!
-instance PyPretty Expr where
- pyPretty pexpr =
- case pexpr of
- EUndefined -> "undefined"
- EChar _ -> error ("Python pyPretty of Expr: " ++
- "EChar should have been converted to " ++
- "EString")
- EList _ -> error ("Python pyPretty of Expr: " ++
- "EList should have been converted to " ++
- "ECall li ...")
- EIf c a b ->
- unwords [pyPretty a, "if", pyPretty c, "else", pyPretty b]
- EGroup e -> pyPrettyParens [e]
- ESymbol vid -> pyPretty vid
- ENumber n -> show n
- EBool b -> show b
- EString s -> show s
- ECall fexpr argExprs ->
- concat [pyPretty fexpr, pyPrettyParens argExprs]
- EOp op left right ->
- unwords [pyPretty left, pyPretty op, pyPretty right]
-
-alterParens :: (Expr -> Expr) -> 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
-
-
--- | Python return statement
-ret :: Expr -> 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 :: Expr -> Expr -> Expr -> PStatement
-condS c a b = PCondS c (ret a) (ret b)
-
--- PExpr smart constructors
-
--- | Python variable
-var :: String -> Expr
-var name = ESymbol (Symbol name)
-
--- | Python identifier
-ident :: String -> Symbol
-ident s = Symbol s
-
--- | Python character expression = string expression with one character
-char :: Char -> Expr
-char c = EString [c]
-
--- | Python function formal parameter
-param :: String -> Symbol
-param name = Symbol name
-
--- | Defines function definition
-fun :: String -> [String] -> Expr -> 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.
---
--- | Operator information
--- Arithmetic operators:
--- + and - have lower precedence than *, /, //, %
--- | Comparison operators have precedence lower than any arithmetic
--- operator. Here, I've specified associative = False,
--- because association doesn't even make sense (well, it does in Python
--- but not in other languages);
--- (a == b) == c is in general not well typed.
-
-operatorTable :: M.Map String Operator
-operatorTable =
- M.fromList (map (\ op -> (opName op, op))
- [ (Operator "*" 7 True GroupLtoR) -- times
- , (Operator "//" 7 False GroupLtoR) -- int div
- , (Operator "/" 7 False GroupLtoR) -- float div
- , (Operator "%" 7 False GroupLtoR) -- mod
- , (Operator "+" 6 True GroupLtoR) -- plus
- , (Operator "-" 6 False GroupLtoR) -- minus
- , (Operator "==" 4 False GroupNone) -- eq
- , (Operator "!=" 4 False GroupNone) -- ne
- , (Operator ">" 4 False GroupNone) -- gt
- , (Operator ">=" 4 False GroupNone) -- ge
- , (Operator "<" 4 False GroupNone) -- lt
- , (Operator "<=" 4 False GroupNone) -- le
- ])
diff --git a/Sifflet/Foreign/ToHaskell.hs b/Sifflet/Foreign/ToHaskell.hs
deleted file mode 100644
--- a/Sifflet/Foreign/ToHaskell.hs
+++ /dev/null
@@ -1,135 +0,0 @@
--- | Exports Sifflet to Haskell
--- Requires haskell-src package.
-
-module Sifflet.Foreign.ToHaskell
- (
- HaskellOptions(..)
- , defaultHaskellOptions
- , exportHaskell
- , functionsToHsModule
- , functionToHsDecl
- , exprToHsExpr
- )
-where
-
-import Data.Char (toUpper)
-import qualified Data.Map as M
-import System.FilePath (dropExtension, takeFileName)
-
-import Sifflet.Foreign.Exporter
-import Sifflet.Foreign.Haskell
-import Sifflet.Language.Expr
-import Sifflet.Util
-
-
--- Main types and functions
-
--- | User configurable options for export to Haskell.
--- Currently these options are unused.
--- The line width options should probably go somewhere else,
--- maybe as PrettyOptions.
-data HaskellOptions =
- HaskellOptions {optionsSoftMaxLineWidth :: Int
- , optionsHardMaxLineWidth :: Int
- }
- deriving (Eq, Show)
-
--- | The default options for export to Haskell.
-defaultHaskellOptions :: HaskellOptions
-defaultHaskellOptions = HaskellOptions {optionsSoftMaxLineWidth = 72,
- optionsHardMaxLineWidth = 80}
-
--- | Export functions with specified options to a file
-exportHaskell :: HaskellOptions -> Exporter
-exportHaskell _options functions path =
- let header = "-- File: " ++ path ++
- "\n-- Generated by the Sifflet->Haskell exporter.\n\n"
- in writeFile path (header ++
- hsPretty (functionsToHsModule
- (pathToModuleName path)
- functions))
-
-
-pathToModuleName :: FilePath -> String
-pathToModuleName path =
- case dropExtension (takeFileName path) of
- [] -> "Test"
- c : cs -> toUpper c : cs
-
--- ------------------------------------------------------------------------
-
--- | Converting Sifflet to Haskell syntax tree
-
--- | Create a module from a module name and Functions.
-functionsToHsModule :: String -> Functions -> Module
-functionsToHsModule modname (Functions fs) =
- Module {moduleName = modname
- , moduleExports = Nothing
- , moduleImports = ImportDecl ["Data.Number.Sifflet"]
- , moduleDecls = map functionToHsDecl fs
- }
-
--- | Create a declaration from a Function.
--- Needs work: infer and declare the type of the function.
--- Minimally parenthesized.
-functionToHsDecl :: Function -> Decl
-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) ->
- Decl {declIdent = fname
- , declType = Nothing -- to be improved later
- , declParams = args
- , declExpr = (simplifyExpr haskellRules)
- (exprToHsExpr body)}
-
-haskellRules :: [Expr -> Expr]
-haskellRules = commonRulesForSimplifyingExprs ++
- [ruleIfRight, ruleRightToLeft]
-
--- | Converts a Sifflet Expr to a fully parenthesized Haskell Expr
-exprToHsExpr :: Expr -> Expr
-exprToHsExpr expr =
- case expr of
- EUndefined -> ESymbol (Symbol "undefined")
- ESymbol _ -> expr
- EBool _ -> expr
- EChar _ -> expr
- ENumber _ -> expr
- EString _ -> expr
-
- EIf c a b -> EIf (exprToHsExpr c) (exprToHsExpr a) (exprToHsExpr b)
- EList es -> EList (map exprToHsExpr es)
- ECall (Symbol fname) args ->
- case nameToHaskell fname of
- Left op -> -- operator
- case args of
- [left, right] ->
- EOp op (EGroup (exprToHsExpr left))
- (EGroup (exprToHsExpr right))
- _ -> error
- "exprToHsExpr: operation does not have 2 operands"
- Right funcName -> -- function
- ECall (Symbol funcName) (map (EGroup . exprToHsExpr) args)
- _ -> errcats ["exprToHsExpr: extended expr:", show expr]
-
--- | Map Sifflet names to Haskell names.
--- Returns a Left Operator for Haskell operators,
--- which always have the same name as their corresponding Sifflet
--- functions, or a Right String for Haskell function and variable names.
-nameToHaskell :: String -> Either Operator String
-nameToHaskell name =
- case M.lookup name operatorTable of
- Just op -> Left op
- Nothing ->
- -- Most names would have the same names in Haskell,
- -- but there are a few special cases.
- Right (case name of
- "zero?" -> "eqZero"
- "positive?" -> "gtZero"
- "negative?" -> "ltZero"
- "add1" -> "succ"
- "sub1" -> "pred"
- _ -> name)
-
diff --git a/Sifflet/Foreign/ToPython.hs b/Sifflet/Foreign/ToPython.hs
deleted file mode 100644
--- a/Sifflet/Foreign/ToPython.hs
+++ /dev/null
@@ -1,170 +0,0 @@
--- | Sifflet to abstract syntax tree for Python.
--- Use Python module's pyPretty to pretty-print the result.
-
-module Sifflet.Foreign.ToPython
- (
- PythonOptions(..)
- , defaultPythonOptions
- , exprToPExpr
- , nameToPython
- , fixIdentifierChars
- , functionToPyDef
- , defToPy
- , functionsToPyModule
- , functionsToPrettyPy
- , exportPython
- )
-
-where
-
-import Data.Char (isAlpha, isDigit, ord)
-import Control.Monad (unless)
-import Data.Map ((!))
-import System.Directory (copyFile, doesFileExist)
-import System.FilePath (replaceFileName)
-
-import Sifflet.Foreign.Exporter
-import Sifflet.Foreign.Python
-import Sifflet.Language.Expr
--- import Sifflet.Text.Pretty
-import Sifflet.Util
-
-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
-
--- A lot of these are "pass-through" -- simplify: ***
-exprToPExpr :: Expr -> Expr
-exprToPExpr expr =
- case expr of
- EUndefined -> EUndefined -- was var "undefined"
- ESymbol _ -> expr
-
- EBool _ -> expr
- EChar c -> EString [c] -- Python does not distinguish char from str
- ENumber _ -> expr
- EString _ -> expr
-
- EIf cond action altAction ->
- -- EIf here represents a Python if *expression*:
- -- value if test else altvalue
- -- not the familiar if *statement*!
- EIf (exprToPExpr cond)
- (exprToPExpr action)
- (exprToPExpr altAction)
- EList exprs ->
- ECall (Symbol "li") (map exprToPExpr exprs)
- ECall (Symbol fname) args ->
- -- Python distinguishes between functions and operators
- case nameToPython fname of
- Left op ->
- case args of
- [left, right] ->
- EOp op (EGroup (exprToPExpr left))
- (EGroup (exprToPExpr right))
- _ -> error "exprToPExpr: operation does not have 2 operands"
- Right pname ->
- -- I don't think we need (a) for each arg a
- -- since they are separated by commas
- ECall (Symbol pname) (map exprToPExpr args)
- _ -> errcats ["exprToPExpr: extended expr:", show expr]
-
--- | Convert Sifflet name (of a function) to Python operator (Left)
--- or function name (Right)
-nameToPython :: String -> Either Operator String
-nameToPython name =
- let oper oname = Left $ operatorTable ! oname
- in case name of
- "+" -> oper "+"
- "-" -> oper "-"
- "*" -> oper "*"
- "div" -> oper "//"
- "mod" -> oper "%"
- "/" -> oper "/" -- invalid for integers in Python 2!
- "==" -> oper "=="
- "/=" -> oper "!="
- ">" -> oper ">"
- ">=" -> oper ">="
- "<" -> oper "<"
- "<=" -> oper "<="
- "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
-
--- | Create a Python def statement from a Sifflet function.
--- Minimally parenthesized.
-functionToPyDef :: Function -> PStatement
-functionToPyDef = defToPy . functionToDef
-
-defToPy :: FunctionDefTuple -> PStatement
-defToPy (fname, paramNames, _, _, body) =
- fun (fixIdentifierChars fname)
- paramNames
- ((simplifyExpr pyRules) (exprToPExpr body))
-
-pyRules :: [Expr -> Expr]
-pyRules = commonRulesForSimplifyingExprs
-
-functionsToPyModule :: Functions -> PModule
-functionsToPyModule (Functions fs) = PModule (map functionToPyDef fs)
-
-functionsToPrettyPy :: Functions -> String
-functionsToPrettyPy = pyPretty . 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
deleted file mode 100644
--- a/Sifflet/Foreign/ToScheme.hs
+++ /dev/null
@@ -1,318 +0,0 @@
-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 Data.Number.Sifflet
-import Sifflet.Foreign.Exporter
-import Sifflet.Language.Expr
-import Sifflet.Text.Repr
-import Sifflet.Text.Pretty
-import Sifflet.Util
-
--- 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))
-
- EBool b -> valueToSExpr (VBool b)
- EChar c -> valueToSExpr (VChar c)
- ENumber n -> valueToSExpr (VNumber n)
- EString s -> valueToSExpr (VString s)
-
- 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)
- _ -> errcats ["exprToSExpr: extended expr:", show expr]
-
--- 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
- VNumber (Exact i) -> SInt i
- VNumber (Inexact x) -> SFloat x
- VString 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
deleted file mode 100644
--- a/Sifflet/Language/Expr.hs
+++ /dev/null
@@ -1,1148 +0,0 @@
-module Sifflet.Language.Expr
- (
- exprToValue, valueToLiteral, valueToLiteral'
- , Symbol(..)
- , OStr, OBool, OChar
- , Expr(..), eSymbol, eSym, eInt, eString, eChar, eFloat
- , exprIsAtomic
- , exprIsCompound
- , eBool, eFalse, eTrue, eIf
- , eList, eCall
- , exprIsLiteral
- , exprSymbols, exprVarNames
- , Operator(..)
- , Precedence
- , OperatorGrouping(..)
- , 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)
-
-import Data.Map as Map hiding (filter, foldl, map, null)
-import Data.List as List
-
-import Data.Number.Sifflet
-import Sifflet.Data.Tree as T
-import Sifflet.Text.Pretty
-import Sifflet.Text.Repr ()
-import Sifflet.Util
-
--- | Transform a numerical expression into its negation,
--- e.g., 5 --> (-5).
--- Fails if the expression is not an ENumber.
-
-eNegate :: Expr -> SuccFail Expr
-eNegate expr =
- case expr of
- ENumber n -> Succ $ ENumber (negate n)
- _ -> Fail $ "eNegate: cannot handle" ++ show expr
-
--- 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 Pretty Symbol where
- pretty (Symbol s) = s
-
-instance Repr Symbol where repr (Symbol s) = s
-
--- The Haskell representations of V's primitive data types.
--- Data.Number.Sifflet.Number represents exact and inexact numbers.
-type OStr = String
-type OBool = Bool
-type OChar = Char
-
--- | A more highly "parsed" type of expression
---
--- 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)
--- The constructors EOp and EGroup are not used in Sifflet itself,
--- but they are needed for export to Python, Haskell, and similar languages;
--- they allow a distinction between operators and functions, and
--- wrapping expressions in parentheses.
--- EGroup e represents parentheses used for grouping: (e);
--- it is not used for other cases of parentheses, e.g.,
--- around the argument list in a function call.]
-
-data Expr = EUndefined
- | ESymbol Symbol
- | EBool Bool
- | EChar Char
- | ENumber Number
- | EString String
- | EIf Expr Expr Expr -- ^ if test branch1 branch2
- | EList [Expr]
- | ECall Symbol [Expr] -- ^ function name, arglist
- | EOp Operator Expr Expr -- ^ binary operator application
- | EGroup Expr -- ^ grouping parentheses
- deriving (Eq, Show)
-
-instance Repr Expr where
- repr e =
- case e of
- EUndefined -> "*undefined*"
- ESymbol s -> repr s
- EBool b -> repr b
- EChar c -> repr c
- ENumber n -> repr n
- EString s -> show s
- EIf t a b -> par "if" (map repr [t, a, b])
- EList xs -> if exprIsLiteral e
- then reprList "[" ", " "]" xs
- else error ("Expr.repr: EList expression is non-literal: "
- ++ show e)
- -- check *** was: par "EList" (map repr items)
- ECall (Symbol fname) args -> par fname (map repr args)
- EOp op left right -> unwords [repr left, opName op, repr right]
- EGroup e' -> "(" ++ repr e' ++ ")"
-
-
--- | An Expr is "extended" if it uses the extended constructors
--- EOp or EGroup. In pure Sifflet, no extended Exprs are used.
-
-exprIsExtended :: Expr -> Bool
-exprIsExtended e =
- case e of
- EOp _ _ _ -> True
- EGroup _ -> True
- EIf t a b -> exprIsExtended t ||
- exprIsExtended a ||
- exprIsExtended b
- EList xs -> any exprIsExtended xs
- ECall (Symbol _) args -> any exprIsExtended args
- _ -> False
-
--- | Is an Expr a literal? A literal is a boolean, character, number, string,
--- or list of literals. We (should) only allow user input expressions
--- to be literal expressions.
-
-exprIsLiteral :: Expr -> Bool
-exprIsLiteral e =
- case e of
- EBool _ -> True
- EChar _ -> True
- ENumber _ -> True
- EString _ -> True
- EList es -> all exprIsLiteral es
- -- Shouldn't we say that
- -- EGroup e' *not* a literal, even if e' is a literal?
- -- But consider carefully the effect on exprIsAtomic and ()'s removal.
- EGroup e' -> True -- or False, or exprIsLiteral e' ???
- _ -> False
-
--- | Is an expression atomic?
--- Atomic expressions do not need parentheses in any reasonable language,
--- because there is nothing to be grouped (symbols, literals)
--- or in the case of lists, they already have brackets
--- which separate them from their neighbors.
---
--- All lists are atomic, even if they are not literals,
--- because (for example) we can remove parentheses
--- from ([a + b, 7])
-
-exprIsAtomic :: Expr -> Bool
-exprIsAtomic e =
- case e of
- ESymbol _ -> True
- EList _ -> True
- _ -> exprIsLiteral e
-
--- | Compound = non-atomic
-exprIsCompound :: Expr -> Bool
-exprIsCompound = not . exprIsAtomic
-
-eSymbol, eSym :: String -> Expr
-eSymbol = ESymbol . Symbol
-eSym = eSymbol
-
-eInt :: Integer -> Expr
-eInt = ENumber . Exact
-
-eString :: OStr -> Expr
-eString = EString
-
-eChar :: OChar -> Expr
-eChar = EChar
-
-eFloat :: Double -> Expr
-eFloat = ENumber . Inexact
-
-eBool :: Bool -> Expr
-eBool = EBool
-
-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
-
--- | An operator, such as * or +
--- An operator is associative, like +, if (a + b) + c == a + (b + c).
--- Its grouping is left to right if (a op b op c) means (a op b) op c;
--- right to left if (a op b op c) means a op (b op c).
--- Most operators group left to right.
-data Operator = Operator {opName :: String
- , opPrec :: Precedence
- , opAssoc :: Bool -- ^ associative?
- , opGrouping :: OperatorGrouping
- }
- deriving (Eq, Show)
-
-instance Pretty Operator where
- pretty = opName
-
--- | Operator priority, normally is > 0 or >= 0,
--- but does that really matter? I think not.
-type Precedence = Int
-
--- | Operator grouping: left to right or right to left,
--- or perhaps not at all
-data OperatorGrouping = GroupLtoR | GroupRtoL | GroupNone
- deriving (Eq, Show)
-
--- |
--- EXPRESSION TREES
--- For pure Sifflet, so not defined for extended expressions.
-
-type ExprTree = Tree ExprNode
-data ExprNode = ENode ExprNodeLabel EvalResult
- deriving (Eq, Show)
-
-data ExprNodeLabel = NUndefined | NSymbol Symbol
- |
- -- formerly NLit Value
- NBool Bool | NChar Char | NNumber Number
- | NString String
- | NList [Expr] -- ???
- 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
- NBool b -> reprl b
- NChar c -> reprl c
- NNumber n -> reprl n
- NString s -> [show s]
- NList es -> reprl (EList es) -- check ***
-
--- 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
- _ -> (0, 1)
-
-exprToTree :: Expr -> ExprTree
-exprToTree expr =
- let leafnode :: ExprNodeLabel -> T.Tree ExprNode
- leafnode e = node e []
- node :: ExprNodeLabel -> [T.Tree ExprNode] -> T.Tree ExprNode
- node e ts = T.Node (ENode e EvalUntried) ts
- errext = error ("exprToTree: extended expr: " ++ show expr)
- in case expr of
- -- EUndefined, ESymbol, and literals map directly
- -- to NUndefined, NSymbol, E(literal-type)
- EUndefined -> leafnode NUndefined
- ESymbol s -> leafnode (NSymbol s)
-
- -- Literals
- EBool b -> leafnode (NBool b)
- EChar c -> leafnode (NChar c)
- ENumber n -> leafnode (NNumber n)
- EString s -> leafnode (NString s)
-
- -- EIf maps to symbol "if" at the root, 3 subtrees
- EIf t a b -> node (NSymbol (Symbol "if")) (map exprToTree [t, a, b])
-
- -- ECall maps to symbol f (function name) at the root,
- -- each argument forms a subtree
- ECall f args -> node (NSymbol f) (map exprToTree args)
- EList xs -> leafnode (NList xs)
- -- Extended Exprs not supported!
- EGroup _ -> errext
- EOp _ _ _ -> errext
-
--- | 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]
- lit e = if null trees then e
- else wrong "literal node with non-empty subtrees"
- in case label of
- NUndefined -> EUndefined
- NBool b -> lit (EBool b)
- NChar c -> lit (EChar c)
- NNumber n -> lit (ENumber n)
- NString s -> lit (EString s)
- NList xs -> lit (EList xs)
- 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)
-
--- 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']
-
- EvalOk weirdValue ->
- -- This shouldn't happen with proper type
- -- checking!
- let msg = "if: non-boolean condition value: " ++
- repr weirdValue
- in T.Node (ifNode (EvalError msg)) [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
- | VNumber Number
- | VString OStr
- | VFun Function
- | VList [Value]
- deriving (Eq, Show)
- -- no Read for Function
-
-instance Repr Value where
- repr (VBool b) = show b
- repr (VChar c) = show c
- repr (VNumber n) = show n
- repr (VString 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
- VBool b -> Succ $ EBool b
- VChar c -> Succ $ EChar c
- VNumber n -> Succ $ ENumber n
- VString s -> Succ $ EString s
- -- VList [] -> Succ $ EList []
- -- VV Should this be fixed? VV
- -- VList _ -> Fail "cannot convert non-empty list to literal expression"
- VList vs -> mapM valueToLiteral vs >>= Succ . EList
- VFun _f -> Fail "cannot convert function to literal expression"
-
-valueToLiteral' :: Value -> Expr
-valueToLiteral' v = case valueToLiteral v of
- Fail msg -> error ("valueToLiteral: " ++ msg)
- Succ e -> e
-
--- | Convert a literal expression to the value it represents.
--- It is an error if the expression is non-literal.
--- See exprIsLiteral.
-literalToValue :: Expr -> Value
-literalToValue e =
- case e of
- EBool b -> VBool b
- EChar c -> VChar c
- ENumber n -> VNumber n
- EString s -> VString s
- EList es -> if exprIsLiteral e
- then VList (map literalToValue es)
- else errcats ["literalToValue: ",
- "non-literal list expression: ",
- show e]
- _ -> errcats ["literalToValue: non-literal or extended expression: " ,
- show e]
-
-
-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, 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, VNumber _) -> Succ env
- (VpTypeNum, x) -> sorry x "number"
- (VpTypeString, VString _) -> 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
- VNumber _ -> Succ VpTypeNum
- VString _ -> 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 (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
-
- EBool b -> EvalOk (VBool b)
- EChar c -> EvalOk (VChar c)
- ENumber n -> EvalOk (VNumber n)
- EString n -> EvalOk (VString n)
-
- 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
- _ -> errcats ["evalWithLimit: extended expression not supported",
- show expr]
-
--- | 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 "+" (+), -- Number (+)
- primN2N "-" (-),
- primN2N "*" (*),
- primIntDiv,
- primIntMod,
- primFloatDiv,
-
- primN1N "add1" succ,
- primN1N "sub1" pred,
-
- -- Comparison
- primN2B "==" (==),
- primN2B "/=" (/=),
- primN2B ">" (>),
- primN2B ">=" (>=),
- primN2B "<" (<),
- primN2B "<=" (<=),
-
- primN1B "zero?" eqZero,
- primN1B "positive?" gtZero,
- primN1B "negative?" ltZero,
-
- -- 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 -> (Number -> Number -> Number) -> Function
-primIntDivMod name oper =
- let func args =
- let err msg = EvalError $ concat [name, ": ", msg,
- " (", show args, ")"]
- in case args of
- [VNumber a, VNumber b] ->
- if b == 0
- then err "zero divisor"
- else if isExact a && isExact b
- then EvalOk $ VNumber (oper a b)
- else 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
- [VNumber x, VNumber y] -> EvalOk $ VNumber (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
--- fn = Number function to implement for Number operands.
-primN2N :: String -> (Number -> Number -> Number) -> Function
-primN2N name fn =
- let impl args =
- case args of
- [VNumber x, VNumber y] -> EvalOk $ VNumber (fn x y)
- _ -> EvalError $ name ++ ": invalid args: " ++ show args
- in prim name [VpTypeNum, VpTypeNum] VpTypeNum impl
-
--- | Primitive unary functions number to number
-primN1N :: String -> (Number -> Number) -> Function
-primN1N name fn =
- let impl args =
- case args of
- [VNumber x] -> EvalOk $ VNumber (fn 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 -> (Number -> Number -> OBool) -> Function
-primN2B name fn =
- let impl args =
- case args of
- [VNumber x, VNumber y] -> EvalOk $ VBool (fn x y)
- _ -> EvalError $ name ++ ": invalid args: " ++ show args
- in prim name [VpTypeNum, VpTypeNum] VpTypeBool impl
-
-
--- Primitive unary functions number to boolean
-primN1B :: String -> (Number -> Bool) -> Function
-primN1B name fn =
- let impl args =
- case args of
- [VNumber x] -> EvalOk $ VBool (fn 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]
- 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
- _ -> if exprIsExtended expr
- then errcats ["exprSymbols: extended expr not supported:",
- show expr]
- else [] -- literal types bool, char, number, string
-
--- | 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
deleted file mode 100644
--- a/Sifflet/Language/Parser.hs
+++ /dev/null
@@ -1,309 +0,0 @@
--- | 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
- , parseValue
- , parseLiteral
- , parseTest
- , parseSuccFail
- , parseTypedInput2, parseTypedInputs2
- , parseTypedInput3, parseTypedInputs3
- , nothingBut
- , expr, list
- , value, typedValue
- , bool, qchar, qstring, integer, double
- , number
- )
-
-where
-
-import Text.ParserCombinators.Parsec
-
-import Data.Number.Sifflet
-import Sifflet.Language.Expr
-import Sifflet.Util
-
--- | Parse a Sifflet data literal (number, string, char, bool, or list),
--- returning an Expr
-parseExpr :: String -> SuccFail Expr
-parseExpr = parseSuccFail expr
-
--- | Parse a Sifflet literal expression and return its Value
-parseValue :: String -> SuccFail Value
-parseValue s =
- -- take a shortcut here?
- -- case parseExpr s of -- stringToExpr s of
- -- Succ expr -> exprToValue expr
- -- Fail errmsg -> Fail errmsg
- parseLiteral s >>= exprToValue
-
-parseLiteral :: String -> SuccFail Expr
-parseLiteral s =
- -- parseValue s >>= valueToLiteral
- case parseExpr s of
- Succ e -> if exprIsLiteral e
- then Succ e
- else Fail $
- "parseLiteral: expr is non-literal" ++ show e
- Fail errmsg -> Fail errmsg
-
-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
-
--- | Try to parse an input value of a specific type
-parseTypedInput2 :: (String, VpType) -> SuccFail Value
-parseTypedInput2 (str, vartype) =
- parseSuccFail (nothingBut (typedValue vartype)) str
-
--- | Try to parse input values of specific types
-parseTypedInputs2 :: [String] -- ^ input strings
- -> [VpType] -- ^ expected types
- -> SuccFail [Value]
-parseTypedInputs2 strs vartypes =
- mapM parseTypedInput2 (zip strs vartypes)
-
--- | Try to parse an input value for a named variable of a specific type
-parseTypedInput3 :: (String, String, VpType) -> SuccFail Value
-parseTypedInput3 (s, varname, vartype) =
- case parseSuccFail (nothingBut (typedValue vartype)) s of
- Fail msg -> Fail ("For variable " ++ varname ++ ":\n" ++ msg)
- Succ v -> Succ v
-
--- | Try to parse input values for named variables of specific types
-parseTypedInputs3 :: [String] -- ^ inputs
- -> [String] -- ^ variable names
- -> [VpType] -- ^ variable types
- -> SuccFail [Value]
-parseTypedInputs3 strs varnames vartypes =
- mapM parseTypedInput3 (zip3 strs varnames vartypes)
-
--- | 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 -- actually only a literal
--- or a list of literals.
-expr :: Parser Expr
-expr = -- (try (list expr >>= return . EList)) <|>
- (bool >>= return . EBool) <|>
- (qchar >>= return . EChar) <|>
- (qstring >>= return . EString) <|>
- try (double >>= return . ENumber . Inexact) <|>
- (integer >>= return . ENumber . Exact) <|>
- (list expr >>= return . EList)
-
-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" -- ???
-
-
-
-
--- | 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 . VString) <|>
- try (double >>= return . VNumber . Inexact) <|>
- (integer >>= return . VNumber . Exact) <|>
- (list value >>= return . VList)
-
--- | Parser for a value with a specific VpType expected.
--- Again, we cannot do this for VpTypeVar (why not?)
--- or VpTypeFunction
-
-typedValue :: VpType -> Parser Value
-typedValue t =
- (case t of
- VpTypeBool -> bool >>= return . VBool
- VpTypeChar -> qchar >>= return . VChar
- VpTypeString -> qstring >>= return . VString
- VpTypeNum -> number >>= return . VNumber
- 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 \\"
- )
- )
-
-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 is a Sifflet Number, which is exact unless it contains
--- a decimal point.
--- To avoid consuming "123" from "123." and interpreting it as an exact
--- number, we MUST try to parse double before integer.
-number :: Parser Number
-number = (try (double >>= return . Inexact) <|>
- (integer >>= return . Exact))
- typeName VpTypeNum
-
-
-
diff --git a/Sifflet/Language/SiffML.hs b/Sifflet/Language/SiffML.hs
deleted file mode 100644
--- a/Sifflet/Language/SiffML.hs
+++ /dev/null
@@ -1,468 +0,0 @@
--- | SiffML : Sifflet Markup Language.
--- An XML application for storing and retrieving Sifflet programs
--- and libraries.
-
-module Sifflet.Language.SiffML
- (
- ToXml(..)
- , produceSiffMLFile
- , consumeSiffMLFile
- , xmlToFunctions
- -- for testing
- , testFromXml
--- , consumeString
- )
-
-where
-
--- import Text.XML.HXT.Arrow
-import Text.XML.HXT.Core
-
-import Data.Number.Sifflet
-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 :: SysConfigList
-defaultOptions = [withIndent yes, withValidate 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 =
- let literal label text =
- -- future: (omit label arg.): selem label [txt text]
- selem "literal" [selem label [txt text]]
- in case expr of
- EUndefined ->
- eelem "undefined"
- ESymbol (Symbol name) ->
- selem "symbol" [txt name]
-
- -- "Literals"
- -- New way: duplicates parts of valueToXml (bad) ***
- EBool b ->
- -- future: selem "bool" [eelem (show b)]
- selem "literal" [selem "bool" [eelem (show b)]]
- EChar c ->
- -- future: selem "char" [txt [c]]
- literal "char" [c]
- ENumber (Exact i) ->
- -- future: selem "int" [txt (show i)]
- literal "int" (show i)
- ENumber (Inexact x) ->
- -- future: selem "float" [txt (show x)]
- literal "float" (show x)
- EString s ->
- -- future: selem "string" [txt s]
- literal "string" s
-
- EIf e1 e2 e3 ->
- selem "if" [toXml e1, toXml e2, toXml e3]
- EList xs ->
- -- I predict that this is going to be troublesome! ***
- -- No checking for whether the list elements are literals!
- selem "literal" [selem "list"
- (map (toXml . literalToValue) xs)]
- -- future: selem "list" (map toXml xs)
- ECall (Symbol name) xs ->
- selem "call"
- (selem "symbol" [txt name] :
- map toXml xs)
- _ -> errcats ["exprToXml: extended expr:", show expr]
-
--- | Convert a literal expression to a value.
--- It is an error if the expr is not a literal.
--- Compare exprToValue in Expr.hs
-literalToValue :: Expr -> Value
-literalToValue e =
- if exprIsLiteral e
- then case e of
- EBool b -> VBool b
- EChar c -> VChar c
- ENumber n -> VNumber n
- EString s -> VString s
- EList es -> VList (map literalToValue es)
- EGroup e' -> literalToValue e'
- _ -> error "literalToValue: expr is literal, but not literal?"
- else error ("literalToValue: expr is not a literal: " ++ show e)
-
-xmlToExpr :: XMLConsumer XmlTree Expr
-xmlToExpr =
- isElem >>>
- (
- (hasName "undefined" >>> constA EUndefined) <+>
- (hasName "symbol" >>> getChildren >>> isText >>> getText >>>
- arr (ESymbol . Symbol)) <+>
-
- -- future: remove extra level "literal"
- (hasName "literal" >>> getChildren >>> xmlToExpr) <+>
-
- -- boolean values
- (hasName "True" >>> constA (EBool True)) <+>
- (hasName "False" >>> constA (EBool False)) <+>
-
- -- chars
- (hasName "char" >>> getChildren >>> isText >>> getText >>>
- -- VVV head dangerous ???
- arr (EChar . head)) <+>
-
- -- numbers -- why not use parser instead of read???
- (hasName "int" >>> getChildren >>> isText >>> getText >>>
- arr (ENumber . Exact . read)) <+> -- read dangerous?
- (hasName "float" >>> getChildren >>> isText >>> getText >>>
- arr (ENumber . Inexact . read)) <+> -- read dangerous?
-
- -- strings
- (hasName "string" >>> getChildren >>> isText >>> getText >>>
- arr EString) <+>
-
-
- (hasName "if" >>> listA (getChildren >>> xmlToExpr) >>>
- -- sometimes I get bogus run-time errors here about
- -- this pattern [a, b, c] being non-exhaustive.
- -- Of course, it *is* non-exhaustive; but it is
- -- never violated in practice
- arr (\ [a, b, c] -> EIf a b c)) <+>
- -- This is very awkward, but needed for compatibility with the
- -- present SiffML doctype:
- (hasName "list" >>>
- -- future?: listA (getChildren >>> xmlToExpr) >>>
- -- Anyway, *why* does this not work???
- listA (getChildren >>> xmlToExpr) >>>
- -- past?:
- -- listA (getChildren >>> xmlToValue >>> arr valueToLiteral') >>>
- 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
--- Still used in exprToXml in the EList case :-(
-
-instance ToXml Value where
- toXml = valueToXml
-
--- Is this still needed? ***
-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]]
- VString s ->
- selem "string" [txt s]
- VNumber (Exact i) ->
- selem "int" [txt (show i)]
- VNumber (Inexact 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: still needed? ***
-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 VString) <+>
- (hasName "int" >>> getChildren >>> isText >>> getText >>>
- arr (VNumber . Exact . read)) -- dangerous?
- <+>
- (hasName "float" >>> getChildren >>> isText >>> getText >>>
- arr (VNumber . Inexact . 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) => Int -> a -> XMLConsumer XmlTree b -> IO ()
-testFromXml traceLevel src consumer = do
- {
- produceSiffMLFile src "test.xml"
- ; results <- runX (readDocument
- (defaultOptions ++ [withTrace traceLevel])
- "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
-
-
-
--- 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 "-"
diff --git a/Sifflet/Rendering/Draw.hs b/Sifflet/Rendering/Draw.hs
deleted file mode 100644
--- a/Sifflet/Rendering/Draw.hs
+++ /dev/null
@@ -1,223 +0,0 @@
-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
deleted file mode 100644
--- a/Sifflet/Rendering/DrawTreeGraph.hs
+++ /dev/null
@@ -1,182 +0,0 @@
--- | Tree graph rendering
-module Sifflet.Rendering.DrawTreeGraph
- (
- graphQuickView
- , graphWriteImageFile, graphRender, treeRender
- , treeWriteImageFile, gtkShowTree
- )
-
-where
-
-import System.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
deleted file mode 100644
--- a/Sifflet/Text/Pretty.hs
+++ /dev/null
@@ -1,56 +0,0 @@
-module Sifflet.Text.Pretty
- (Pretty(..)
- , indentLine, sepLines, sepLines2
- , sepComma, sepCommaSp, sepSpace)
-
-where
-
-import Data.List (intercalate)
-
-
--- | The class of types that can be pretty-printed.
--- (Unfortunately this is not very useful, because
--- and Expr can be pretty Haskell or pretty Python or pretty Scheme,
--- leading to overlapping instance declarations.)
---
--- 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 ", "
-
--- | Separate strings by just spaces (" ")
-sepSpace :: [String] -> String
-sepSpace = unwords
diff --git a/Sifflet/Text/Repr.hs b/Sifflet/Text/Repr.hs
deleted file mode 100644
--- a/Sifflet/Text/Repr.hs
+++ /dev/null
@@ -1,65 +0,0 @@
-module Sifflet.Text.Repr
- (Repr(..)
- , Name(..)
- )
-
-where
-
-import Data.Number.Sifflet
-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 Bool where repr = show
-instance Repr Char where repr = show
-instance Repr Int where repr = show
-instance Repr Integer where repr = show
-instance Repr Number where repr = show
-instance Repr Float where repr = show
-instance Repr Double where repr = show
-
--- instance Repr String won't work because String is a type synonym,
--- unless you ask ghc nicely, which I'd prefer not to do.
--- Use Name data type in Testing/Tree.hs instead, or Symbol in Expr.hs
--- I don't know if I can use Expr.Symbol here, since Expr.hs also
--- imports Tree.hs (this file) -- is mutual import allowed?
-
-data Name = Name String
- deriving (Eq, Read, Show)
-
-instance Repr Name where
- repr (Name s) = s
diff --git a/Sifflet/UI.hs b/Sifflet/UI.hs
deleted file mode 100644
--- a/Sifflet/UI.hs
+++ /dev/null
@@ -1,30 +0,0 @@
-{- 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
deleted file mode 100644
--- a/Sifflet/UI/Callback.hs
+++ /dev/null
@@ -1,140 +0,0 @@
-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
deleted file mode 100644
--- a/Sifflet/UI/Canvas.hs
+++ /dev/null
@@ -1,982 +0,0 @@
--- 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
-
- reader :: Reader [String] [Value]
- reader inputs = parseTypedInputs3 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
deleted file mode 100644
--- a/Sifflet/UI/Frame.hs
+++ /dev/null
@@ -1,306 +0,0 @@
-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
deleted file mode 100644
--- a/Sifflet/UI/GtkForeign.hs
+++ /dev/null
@@ -1,123 +0,0 @@
-{-# 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
deleted file mode 100644
--- a/Sifflet/UI/GtkUtil.hs
+++ /dev/null
@@ -1,224 +0,0 @@
-{-# 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
deleted file mode 100644
--- a/Sifflet/UI/LittleGtk.hs
+++ /dev/null
@@ -1,179 +0,0 @@
--- | The purpose of this module is simply to re-export the
--- Gtk functions and types that I use, and avoid those
--- that I don't, particularly those that conflict with
--- names in Sifflet, like Layout.
--- Just hiding these is not enough, because Graphics.UI.Gtk
--- keeps changing what it exports.
--- For example, in 0.10.5 it no longer exports Function, fill,
--- function.
-
-module 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
- , windowDeletable
- , 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
deleted file mode 100644
--- a/Sifflet/UI/RPanel.hs
+++ /dev/null
@@ -1,154 +0,0 @@
--- | "Rowed Panel."
--- Expandable framed panel with a two-dimensional layout
--- (rows of widgets, but not with aligned columns like in a table).
-
-module 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
deleted file mode 100644
--- a/Sifflet/UI/Tool.hs
+++ /dev/null
@@ -1,561 +0,0 @@
-module Sifflet.UI.Tool
- (
- ToolId(..)
- , checkMods
- , functionTool
- , functionToolsFromLists
- , makeConnectTool
- , makeCopyTool
- , makeDeleteTool
- , makeDisconnectTool
- , 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.Language.Parser
-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 e -> makeBoundLiteralTool e
- ToolArg argname -> makeBoundArgTool 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
-
-makeBoundLiteralTool :: Expr -> Tool
-makeBoundLiteralTool e =
- let enode node = ENode node EvalUntried
- addLitNode node vw toolContext _mods x y =
- case toolContext of
- TCEditFrame frame ->
- vcFrameAddNode vw frame (enode node) [] x y
- _ ->
- return vw -- Nothing
- mktool node =
- Tool ("Literal: " ++ repr e)
- return
- (toToolOpVW (addLitNode node))
- in case e of
- EBool b -> mktool (NBool b)
- EChar c -> mktool (NChar c)
- ENumber n -> mktool (NNumber n)
- EString s -> mktool (NString s)
- EList es -> if exprIsLiteral e
- then mktool (NList es)
- else errcats ["makeBoundLiteralTool: ",
- "non-literal list expression",
- show e]
- _ ->
- errcats ["makeBoundLiteralTool: non-literal or",
- "extended expression", show e]
-
-makeBoundArgTool :: String -> Tool
-makeBoundArgTool 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
- parseLiteral -- 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 v ->
- grabRemove entry >>
- widgetDestroy container >>
- readIORef uiref >>=
- vpuiSetTool (toolType v) 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
deleted file mode 100644
--- a/Sifflet/UI/Types.hs
+++ /dev/null
@@ -1,308 +0,0 @@
-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
deleted file mode 100644
--- a/Sifflet/UI/Window.hs
+++ /dev/null
@@ -1,1172 +0,0 @@
-module Sifflet.UI.Window
- (
- -- Window utilities
- showWindow
- , newWindowTitled
-
- , showWorkWin
- , showWorkspaceWindow
-
- , showFedWin
- , fedWindowTitle
-
- , showFunctionPadWindow
- , newFunctionDialog
-
- , openFilePath
- , 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
-
-
-import Data.Version
-import Paths_sifflet_lib as Paths
-
--- ---------------------------------------------------------------------
--- | 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
- ; uimgr (OnWindowDestroy window (onWindowDestroy 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)
- }
-
-onWindowDestroy :: WinId -> IORef VPUI -> IO ()
-onWindowDestroy winId uiref =
- if (winId == workspaceId)
- then
- readIORef uiref >>=
- checkForChanges "quit (by closing the workspace window)" True False
- (\ vpui -> do { mainQuit; return vpui }) >>
- return ()
- else modifyIORef uiref (vpuiRemoveVPUIWindow winId)
-
--- | 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]
- -- this should suppress the window close button,
- -- but doesn't, at least in Fluxbox
- -- windowDeletable := False] -- no close button
- ; 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 = checkForChanges "quit" False True vpuiQuit
-
--- | Open a file (load its function definitions)
-
-menuFileOpen :: CBMgr -> VPUI -> IO VPUI
-menuFileOpen cbmgr =
- checkForChanges "open file" True 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.
--- If offerCancel is true, there is an option to cancel the operation;
--- this won't work if the user is closing the main (workspace) window.
--- 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 :: String -> Bool -> Bool -> (VPUI -> IO VPUI)
- -> VPUI -> IO VPUI
-checkForChanges beforeOperation acknowledge offerCancel continue vpui =
- let mAckIfSaved vpui' =
- when (not (vpuiFileChanged vpui') && acknowledge)
- (
- showInfoMessage "Changes saved"
- ("Your changes are now saved; " ++
- "proceeding to " ++
- beforeOperation ++ ".")
- )
- >>
- return vpui'
- choices = [("Save them",
- menuFileSave vpui >>= mAckIfSaved >>= continue),
- ("Throw them away",
- return vpui >>= continue)] ++
- if offerCancel
- then [("Cancel " ++ beforeOperation, return vpui)]
- else []
- labels = map fst choices
- actions = map snd choices
- -- labels = ["Save them",
- -- "Throw them away",
- -- ]
- -- 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 -> openFilePath cbmgr filePath vpui
-
--- | Now that we have a file path, go ahead and open it,
--- loading the function definitions into Sifflet
-
-openFilePath :: CBMgr -> FilePath -> VPUI -> IO VPUI
-openFilePath cbmgr filePath vpui = 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 = Just filePath,
- 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 " ++ showVersion Paths.version,
- "Copyright (C) 2010-2012 Gregory D. Weber",
- "",
- "BSD3 License",
- "",
- "Sifflet home page:",
- "http://mypage.iu.edu/~gdweber/software/sifflet/"
- ]
-
-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
deleted file mode 100644
--- a/Sifflet/UI/Workspace.hs
+++ /dev/null
@@ -1,405 +0,0 @@
-{- Currently, this module contains functions for VPUI, VPUIWindow,
-Workspace, VCanvas, and more. A reorganization seems called for,
-but for now I will just keep adding functions here. -}
-
-module Sifflet.UI.Workspace
- (
- -- VPUI and Workspace
- vpuiNew
- , workspaceNewDefault
- , workspaceNewEditing
- , addArgToolButtons
- , addApplyCloseButtons
- , defineFunction
- , workspaceId
- , 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
- }
-
-workspaceId :: String
-workspaceId = "Sifflet Workspace"
-
--- | 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 =
- case vpuiTryGetWindow vpui workspaceId 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 workspaceId 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
deleted file mode 100644
--- a/Sifflet/Util.hs
+++ /dev/null
@@ -1,135 +0,0 @@
-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/Text/Sifflet/Pretty.hs b/Text/Sifflet/Pretty.hs
new file mode 100644
--- /dev/null
+++ b/Text/Sifflet/Pretty.hs
@@ -0,0 +1,56 @@
+module Text.Sifflet.Pretty
+ (Pretty(..)
+ , indentLine, sepLines, sepLines2
+ , sepComma, sepCommaSp, sepSpace)
+
+where
+
+import Data.List (intercalate)
+
+
+-- | The class of types that can be pretty-printed.
+-- (Unfortunately this is not very useful, because
+-- and Expr can be pretty Haskell or pretty Python or pretty Scheme,
+-- leading to overlapping instance declarations.)
+--
+-- 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 ", "
+
+-- | Separate strings by just spaces (" ")
+sepSpace :: [String] -> String
+sepSpace = unwords
diff --git a/Text/Sifflet/Repr.hs b/Text/Sifflet/Repr.hs
new file mode 100644
--- /dev/null
+++ b/Text/Sifflet/Repr.hs
@@ -0,0 +1,65 @@
+module Text.Sifflet.Repr
+ (Repr(..)
+ , Name(..)
+ )
+
+where
+
+import Data.Number.Sifflet
+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 Language.Sifflet.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 Bool where repr = show
+instance Repr Char where repr = show
+instance Repr Int where repr = show
+instance Repr Integer where repr = show
+instance Repr Number where repr = show
+instance Repr Float where repr = show
+instance Repr Double where repr = show
+
+-- instance Repr String won't work because String is a type synonym,
+-- unless you ask ghc nicely, which I'd prefer not to do.
+-- Use Name data type in Testing/Tree.hs instead, or Symbol in Expr.hs
+-- I don't know if I can use Expr.Symbol here, since Expr.hs also
+-- imports Tree.hs (this file) -- is mutual import allowed?
+
+newtype Name = Name String
+ deriving (Eq, Read, Show)
+
+instance Repr Name where
+ repr (Name s) = s
diff --git a/datafiles/siffml-1.0.rnc b/datafiles/siffml-1.0.rnc
new file mode 100644
--- /dev/null
+++ b/datafiles/siffml-1.0.rnc
@@ -0,0 +1,60 @@
+# -*- mode: conf -*-
+# schema for siffml-1.0.
+# RELAX NG compact syntax, using a grammar
+
+start = Functions
+
+# Functions and children
+
+Functions = element functions { CompoundFunction* }
+CompoundFunction =
+ element compound-function { Name, ReturnType, ArgTypes, ArgNames, Body }
+Name = element name { text }
+ReturnType = element return-type { SiffletType }
+ArgTypes = element arg-types { SiffletType* }
+ArgNames = element arg-names { Name* }
+Body = element body { SiffletExpr }
+
+# Types (variants of VpType)
+
+SiffletType =
+ StringType | CharType | NumType | BoolType | ListType | TypeVariable
+
+StringType = element string-type { empty }
+CharType = element char-type { empty }
+NumType = element num-type { empty }
+BoolType = element bool-type { empty }
+ListType = element list-type { SiffletType }
+TypeVariable = element type-variable { text }
+
+# Expressions (variants of Expr)
+# Expr also has a EList constructor, but this is not used in SiffML
+
+SiffletExpr = Undefined | Symbol | Literal | If | Call
+
+Undefined = element undefined { empty }
+Symbol = element symbol { text }
+Literal = element literal { SiffletValue }
+If = element if { SiffletExpr, SiffletExpr, SiffletExpr }
+Call = element call { Symbol, SiffletExpr* }
+
+# A "list" element as an expr is probably a mistake.
+# List = element list { SiffletExpr }
+
+# Values (variants of Value)
+
+SiffletValue = TRUE | FALSE | Char | String | Int | Float | List | Function
+
+TRUE = element True { empty }
+FALSE = element False { empty }
+Char = element char { text }
+String = element string { text }
+Int = element int { text }
+Float = element float { text }
+
+# A "list" element represents a list value, not a list expr.
+List = element list { SiffletValue* }
+
+# Function values shouldn't happen, but just in case:
+Function = element function { CompoundFunction }
+
diff --git a/datafiles/siffml-2.0.rnc b/datafiles/siffml-2.0.rnc
new file mode 100644
--- /dev/null
+++ b/datafiles/siffml-2.0.rnc
@@ -0,0 +1,71 @@
+# -*- mode: conf -*-
+# schema for siffml-2.0.
+# RELAX NG compact syntax, using a grammar
+#
+# All valid siffml-1.0 documents are also valid as siffml-2.0,
+# as the only change is the addition of FunctionType as
+# another alternative in SiffletType
+
+start = Functions
+
+# Functions and children
+
+Functions = element functions { CompoundFunction* }
+CompoundFunction =
+ element compound-function { Name, ReturnType, ArgTypes, ArgNames, Body }
+Name = element name { text }
+ReturnType = element return-type { SiffletType }
+ArgTypes = element arg-types { SiffletType* }
+ArgNames = element arg-names { Name* }
+Body = element body { SiffletExpr }
+
+# Types (variants of VpType)
+
+SiffletType =
+ StringType | CharType | NumType | BoolType | ListType |
+ FunctionType | TypeVariable
+
+StringType = element string-type { empty }
+CharType = element char-type { empty }
+NumType = element num-type { empty }
+BoolType = element bool-type { empty }
+ListType = element list-type { SiffletType }
+
+FunctionType = element function-type {
+ SiffletType, # argument type
+ SiffletType # return type (which may be a function type)
+ }
+
+TypeVariable = element type-variable { text }
+
+# Expressions (variants of Expr)
+# Expr also has a EList constructor, but this is not used in SiffML
+
+SiffletExpr = Undefined | Symbol | Literal | If | Call
+
+Undefined = element undefined { empty }
+Symbol = element symbol { text }
+Literal = element literal { SiffletValue }
+If = element if { SiffletExpr, SiffletExpr, SiffletExpr }
+Call = element call { Symbol, SiffletExpr* }
+
+# A "list" element as an expr is probably a mistake.
+# List = element list { SiffletExpr }
+
+# Values (variants of Value)
+
+SiffletValue = TRUE | FALSE | Char | String | Int | Float | List | Function
+
+TRUE = element True { empty }
+FALSE = element False { empty }
+Char = element char { text }
+String = element string { text }
+Int = element int { text }
+Float = element float { text }
+
+# A "list" element represents a list value, not a list expr.
+List = element list { SiffletValue* }
+
+# Function values shouldn't happen, but just in case:
+Function = element function { CompoundFunction }
+
diff --git a/sifflet-lib.cabal b/sifflet-lib.cabal
--- a/sifflet-lib.cabal
+++ b/sifflet-lib.cabal
@@ -1,5 +1,5 @@
name: sifflet-lib
-version: 1.2.5.1
+version: 2.0.0.0
cabal-version: >= 1.8
build-type: Simple
license: BSD3
@@ -9,25 +9,22 @@
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.
+stability: Experimental.
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).
- Version 1.2.5: Compatibility with GHC 7.4.1.
- Version 1.2.4: Dependencies revised for compatibility with HXT 9.1.
- Version 1.2.3: Dependencies revised for compatibility with GHC 7.0
- and Haskell Platform 2011.2.
+ Version 2.0.0.0 adds partial support for higher-order functions, like map
+ and filter.
category:
Language
, Visual Programming
-tested-with: GHC == 7.4.1
-data-files: sifflet.scm sifflet.py siffml-1.0.dtd
+tested-with: GHC == 7.4.2
+data-files: sifflet.scm sifflet.py siffml-1.0.dtd siffml-1.0.rnc
+ siffml-2.0.rnc
data-dir: datafiles
extra-tmp-files:
-extra-source-files: README
+extra-source-files: README ISSUES RELEASE-NOTES
-- Library section
@@ -58,39 +55,50 @@
extra-libraries: gdk-x11-2.0 gtk-x11-2.0
exposed-modules:
Data.Number.Sifflet
- , Sifflet.Data.Geometry
- , Sifflet.Data.Functoid
- , Sifflet.Data.Tree
- , Sifflet.Data.TreeGraph
- , Sifflet.Data.TreeLayout
- , Sifflet.Data.WGraph
- , Sifflet.Examples
- , Sifflet.Foreign.Exporter
- , Sifflet.Foreign.Haskell
- , 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
+
+ , Data.Sifflet.Functoid
+ , Data.Sifflet.Geometry
+ , Data.Sifflet.Tree
+ , Data.Sifflet.TreeGraph
+ , Data.Sifflet.TreeLayout
+ , Data.Sifflet.WGraph
+
+ , Graphics.Rendering.Sifflet.Draw
+ , Graphics.Rendering.Sifflet.DrawTreeGraph
+
+ , Graphics.UI.Sifflet
+ , Graphics.UI.Sifflet.Callback
+ , Graphics.UI.Sifflet.Canvas
+ , Graphics.UI.Sifflet.EditArgsPanel
+ , Graphics.UI.Sifflet.Frame
+ , Graphics.UI.Sifflet.GtkForeign
+ , Graphics.UI.Sifflet.GtkUtil
+ , Graphics.UI.Sifflet.LittleGtk
+ , Graphics.UI.Sifflet.Tool
+ , Graphics.UI.Sifflet.RPanel
+ , Graphics.UI.Sifflet.Types
+ , Graphics.UI.Sifflet.Window
+ , Graphics.UI.Sifflet.Workspace
+
+ , Language.Sifflet.Examples
+
+ , Language.Sifflet.Export.Exporter
+ , Language.Sifflet.Export.Haskell
+ , Language.Sifflet.Export.Python
+ , Language.Sifflet.Export.ToHaskell
+ , Language.Sifflet.Export.ToPython
+ , Language.Sifflet.Export.ToScheme
+
+ , Language.Sifflet.Expr
+ , Language.Sifflet.ExprTree
+ , Language.Sifflet.Parser
+ , Language.Sifflet.TypeCheck
+ , Language.Sifflet.SiffML
+ , Language.Sifflet.Util
+
+ , Text.Sifflet.Pretty
+ , Text.Sifflet.Repr
+
-- Paths to data files, generated by Cabal
other-modules: Paths_sifflet_lib
hs-source-dirs: