diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,22 @@
+Copyright (c) 2013 Daniel Díaz Carrete
+
+Permission is hereby granted, free of charge, to any person
+obtaining a copy of this software and associated documentation
+files (the "Software"), to deal in the Software without
+restriction, including without limitation the rights to use,
+copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the
+Software is furnished to do so, subject to the following
+conditions:
+
+The above copyright notice and this permission notice shall be
+included in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
+OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
+OTHER DEALINGS IN THE SOFTWARE.
diff --git a/README.md b/README.md
new file mode 100644
--- /dev/null
+++ b/README.md
@@ -0,0 +1,38 @@
+Pianola is a Haskell library that lets you monitor and control Java Swing applications through a network connection. This can be useful for performing automated GUI testing.
+
+To work with the library, the Application Under Test (AUT) must have been instrumented with a Java-side Pianola agent. For instructions on how to compile an set up the agent, check the README file in the **backends/java-swing** folder.
+
+A Java Swing example application is included in the **backends/java-swing-testapp** folder.
+
+For instructions on how to use the library, check out the Haddock documentation for the **Pianola.Tutorial** package.
+
+The **tests** folder contains automated tests for the library. For the tests to work, the Java example application must be up and running.
+
+The **examples** folder contains scripts for interacting with popular Java Swing applications (only **DbVisualizer** at the moment). Check out the corresponding README for instructions on how to set up the Pianola agent for these applications.
+
+Pianola offers some of the functionality of tools like [Marathon](http://marathontesting.com/), although it doesn't have any recording capabilities. The scripts must be written by hand. Also, unlike Marathon, Pianola doesn't concern itself with launching the AUT, which must be started through other means.
+
+Rationale
+=========
+
+* I dislike the "recording" approach taken by many GUI test automation frameworks for developing tests scripts. In any minimally complex test case, you will have to refactor the script aggresively anyway, to remove duplication and increase modularity. I prefer to program the scripts in an incremental manner, ideally with the help of a good REPL.
+
+* Sometimes, it can become inconvenient if the test framework needs to control the launch of the AUT, instead of having it started by other means.
+
+* Pianola doesn't require the client and the AUT to reside in the same machine.
+
+* I'm partial to statically typed languages. I find very annoying when a long-running script developed in a dynamically typed language fails midway due to a dumb error like the misspelling of a variable's name. I realize that this inconvenience is solved through unit testing, but when then things you are developing are *themselves* test scripts, isn't it a bit of overkill to have tests of tests?
+
+* Related to the previous point: statically typed languages give you more assurances that you don't break anything when refactoring.
+
+* Haskell is (at least in theory) good at handling tree-like structures, like the containment hierarchy of the components in a GUI.
+
+* Haskell's higher-order functions should (at least in theory) give more flexibility when locating individual components. For example, identifying a component depending on an arbitrary predicate applied to its text.
+
+* [Marathon](http://marathontesting.com/) is a versatile tool that can handle many corner cases when testing Swing GUIs. Still, there are annoyances. There isn't (to my knowledge) an easy way to identify a component by its text in other manner than by total equality.
+
+* Marathon annoyance #2: There isn't (to my knowledge) an easy way to handle components which may or may not appear during a test's execution. For example, a warning dialog which appears only occasionally. There doesn't seem to be a "find component, if it exists" operation.
+
+* Marathon annoyance #3: There isn't (to my knowledge) a way to make Marathon scripts fail quickly when they can't find a component in the GUI. Sometimes they block for a surprisingly long time before failing!
+
+
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/backends/java-swing-testapp/README.md b/backends/java-swing-testapp/README.md
new file mode 100644
--- /dev/null
+++ b/backends/java-swing-testapp/README.md
@@ -0,0 +1,25 @@
+This is a test Java Swing application for the Pianola agent.
+
+Compiling the test application
+==============================
+
+The pianola agent must have been previously compiled with **mvn install** so that its jar is accessible in the local maven repository.
+
+Before compiling the application, edit the **pom.xml** file. Find the line:
+
+> -javaagent:${settings.localRepository}/info/danidiaz/pianola/pianola-driver/${myprops.pianola-driver.version}/pianola-driver-${myprops.pianola-driver.version}.jar=port/26060,popupTrigger/release
+
+In Linux, **popupTrigger/release** should be changed to **popupTrigger/press**.
+
+Compile the application with
+
+> mvn install
+
+Executing the test application
+==============================
+
+Once compiled, execute the application with
+
+> mvn exec:exec
+
+The GUI should appear, and client libaries should be able to interact with it through the pianola agent.
diff --git a/backends/java-swing-testapp/pom.xml b/backends/java-swing-testapp/pom.xml
new file mode 100644
--- /dev/null
+++ b/backends/java-swing-testapp/pom.xml
@@ -0,0 +1,70 @@
+
+ 4.0.0
+
+ info.danidiaz.pianola
+ pianola-testapp
+ 1.0-SNAPSHOT
+ jar
+
+ pianola-testapp
+ http://maven.apache.org
+
+
+ UTF-8
+ 1.0
+
+
+
+
+
+ org.apache.maven.plugins
+ maven-jar-plugin
+ 2.4
+
+
+
+ true
+ info.danidiaz.pianola.testapp.Main
+
+
+
+
+
+
+
+ org.codehaus.mojo
+ exec-maven-plugin
+ 1.2.1
+
+ java
+
+
+ -javaagent:${settings.localRepository}/info/danidiaz/pianola/pianola-driver/${myprops.pianola-driver.version}/pianola-driver-${myprops.pianola-driver.version}.jar=port/26060,popupTrigger/release
+
+ -classpath
+
+ info.danidiaz.pianola.testapp.Main
+
+
+
+
+
+
+
+
+
+ info.danidiaz.pianola
+ pianola-driver
+ ${myprops.pianola-driver.version}
+
+
+ junit
+ junit
+ 4.10
+ test
+
+
+
+
diff --git a/backends/java-swing-testapp/src/main/java/info/danidiaz/pianola/testapp/Main.java b/backends/java-swing-testapp/src/main/java/info/danidiaz/pianola/testapp/Main.java
new file mode 100644
--- /dev/null
+++ b/backends/java-swing-testapp/src/main/java/info/danidiaz/pianola/testapp/Main.java
@@ -0,0 +1,27 @@
+package info.danidiaz.pianola.testapp;
+
+import javax.swing.JFrame;
+
+public class Main
+{
+ public static void main( String[] args )
+ {
+ System.out.println( "Hello World!" );
+
+ javax.swing.SwingUtilities.invokeLater(new Runnable() {
+ public void run() {
+ new Main().createAndShowGUI();
+ }
+ });
+ }
+
+ private void createAndShowGUI() {
+ //Create and set up the window.
+ final JFrame frame = new TestAppFrame();
+
+ frame.pack();
+ frame.setLocationRelativeTo(null);
+ frame.setVisible(true);
+ }
+
+}
diff --git a/backends/java-swing-testapp/src/main/java/info/danidiaz/pianola/testapp/TestAppFrame.java b/backends/java-swing-testapp/src/main/java/info/danidiaz/pianola/testapp/TestAppFrame.java
new file mode 100644
--- /dev/null
+++ b/backends/java-swing-testapp/src/main/java/info/danidiaz/pianola/testapp/TestAppFrame.java
@@ -0,0 +1,530 @@
+package info.danidiaz.pianola.testapp;
+
+import java.awt.BorderLayout;
+import java.awt.Dimension;
+import java.awt.GridLayout;
+import java.awt.HeadlessException;
+import java.awt.event.ActionEvent;
+import java.awt.event.ActionListener;
+import java.awt.event.ItemEvent;
+import java.awt.event.ItemListener;
+import java.awt.event.MouseAdapter;
+import java.awt.event.MouseEvent;
+import java.io.File;
+
+import javax.swing.BoxLayout;
+import javax.swing.JButton;
+import javax.swing.JCheckBox;
+import javax.swing.JCheckBoxMenuItem;
+import javax.swing.JComboBox;
+import javax.swing.JDialog;
+import javax.swing.JFileChooser;
+import javax.swing.JFrame;
+import javax.swing.JLabel;
+import javax.swing.JMenu;
+import javax.swing.JMenuBar;
+import javax.swing.JMenuItem;
+import javax.swing.JPanel;
+import javax.swing.JPopupMenu;
+import javax.swing.JScrollPane;
+import javax.swing.JTabbedPane;
+import javax.swing.JTable;
+import javax.swing.JTextArea;
+import javax.swing.JTextField;
+import javax.swing.JTree;
+import javax.swing.ListSelectionModel;
+import javax.swing.SwingConstants;
+import javax.swing.SwingWorker;
+import javax.swing.border.BevelBorder;
+import javax.swing.event.DocumentEvent;
+import javax.swing.event.DocumentListener;
+import javax.swing.event.ListSelectionEvent;
+import javax.swing.event.ListSelectionListener;
+import javax.swing.event.TableModelEvent;
+import javax.swing.event.TableModelListener;
+import javax.swing.event.TreeExpansionEvent;
+import javax.swing.event.TreeExpansionListener;
+import javax.swing.table.DefaultTableModel;
+import javax.swing.tree.DefaultMutableTreeNode;
+import javax.swing.tree.DefaultTreeModel;
+import javax.swing.tree.TreePath;
+import javax.swing.tree.TreeSelectionModel;
+
+public class TestAppFrame extends JFrame {
+
+ private final JTextField textField = new JTextField(18);
+
+ private final JLabel statusLabel;
+ private final JButton clearStatusLabel;
+
+ public TestAppFrame() throws HeadlessException {
+ super("Test app frame");
+
+ getContentPane().setLayout(new BorderLayout());
+ JTabbedPane tabbedPane = new JTabbedPane();
+ tabbedPane.addTab("tab one", createTabOne());
+ tabbedPane.setToolTipTextAt(0, "tooltip for tab one");
+ tabbedPane.addTab("tab two", createTabTwo());
+ tabbedPane.setToolTipTextAt(1, "tooltip for tab two");
+ JPanel panels [] = createTabJTree();
+ tabbedPane.addTab("tab JTree a", panels[0]);
+ tabbedPane.setToolTipTextAt(2, "tooltip for tab three");
+ tabbedPane.addTab("tab JTree b", panels[1]);
+ tabbedPane.setToolTipTextAt(3, "tooltip for tab four");
+ tabbedPane.addTab("labels", createTabLabeledFields());
+ tabbedPane.setToolTipTextAt(4, "tooltip for labels");
+
+ getContentPane().add(tabbedPane, BorderLayout.CENTER);
+
+
+ JPanel statusPanel = new JPanel(new BorderLayout());
+ statusPanel.setBorder(new BevelBorder(BevelBorder.LOWERED));
+ statusPanel.setPreferredSize(new Dimension(this.getWidth(), 36));
+ //statusPanel.setLayout(new BoxLayout(statusPanel, BoxLayout.X_AXIS));
+
+ statusLabel = new JLabel("");
+ statusLabel.setName("status bar");
+ statusLabel.setHorizontalAlignment(SwingConstants.LEFT);
+ statusPanel.add(statusLabel,BorderLayout.CENTER);
+
+ clearStatusLabel = new JButton("clear");
+ clearStatusLabel.addActionListener(new ActionListener() {
+
+ @Override
+ public void actionPerformed(ActionEvent arg0) {
+ statusLabel.setText("");
+
+ }
+ });
+ statusPanel.add(clearStatusLabel, BorderLayout.EAST);
+
+
+ getContentPane().add(statusPanel, BorderLayout.SOUTH);
+
+ JMenu menu = new JMenu("Menu1");
+ JMenuItem item1 = new JMenuItem("item1");
+ JMenuItem item2 = new JMenuItem("item2");
+ menu.add(item1);
+ menu.add(item2);
+ JMenu subMenu = new JMenu("SubMenu1");
+ JMenuItem menuitem1 = new JMenuItem("submenuitem1");
+ menuitem1.addActionListener(new ActionListener() {
+
+ @Override
+ public void actionPerformed(ActionEvent arg0) {
+ statusLabel.setText("clicked on submenuitem1");
+ }
+ });
+ subMenu.add(menuitem1);
+ final JCheckBoxMenuItem checkBoxMenuItem = new JCheckBoxMenuItem("submenuitem2");
+ checkBoxMenuItem.addItemListener(new ItemListener() {
+
+ @Override
+ public void itemStateChanged(ItemEvent arg0) {
+ statusLabel.setText("checkbox in menu is now "+checkBoxMenuItem.isSelected());
+ }
+ });
+ subMenu.add(checkBoxMenuItem);
+ menu.add(subMenu);
+
+ JMenuBar menuBar = new JMenuBar();
+ menuBar.add(menu);
+ setJMenuBar(menuBar);
+
+ setDefaultCloseOperation(JFrame.DISPOSE_ON_CLOSE);
+
+
+
+ }
+
+ private void createAndShowDialog(JFrame frame) {
+ final JDialog dialog = new JDialog(frame,true);
+ dialog.setTitle("foo dialog");
+ dialog.getContentPane().setLayout(new BorderLayout());
+ dialog.getContentPane().add(new JTextArea(18, 10),BorderLayout.CENTER);
+
+ JButton actionButton = new JButton("click this");
+ actionButton.addActionListener(new ActionListener() {
+ @Override
+ public void actionPerformed(ActionEvent arg0) {
+ statusLabel.setText("clicked button in dialog");
+ }
+ });
+
+ JButton dialogButton = new JButton("close dialog");
+ dialogButton.addActionListener(new ActionListener() {
+
+ @Override
+ public void actionPerformed(ActionEvent e) {
+ dialog.setVisible(false);
+
+ }
+ });
+ dialog.getContentPane().add(actionButton,BorderLayout.NORTH);
+ dialog.getContentPane().add(dialogButton,BorderLayout.SOUTH);
+ //Display the window.
+ dialog.pack();
+ dialog.setLocationRelativeTo(null);
+ dialog.setVisible(true);
+ }
+
+ private JPanel createTabOne() {
+ JPanel mainPanel = new JPanel(new BorderLayout());
+ JPanel textPanel = new JPanel(new BorderLayout());
+
+ textField.setText("En un lugar de la Mancha");
+ textField.getDocument().addDocumentListener(new DocumentListener() {
+
+ @Override
+ public void removeUpdate(DocumentEvent arg0) {
+ statusLabel.setText(textField.getText());
+ }
+
+ @Override
+ public void insertUpdate(DocumentEvent arg0) {
+ statusLabel.setText(textField.getText());
+ }
+
+ @Override
+ public void changedUpdate(DocumentEvent arg0) {
+ statusLabel.setText(textField.getText());
+ }
+ });
+
+ textPanel.add(textField,BorderLayout.NORTH);
+
+ textPanel.add(new JTextArea(18, 28),BorderLayout.CENTER);
+ JButton fooButton = new JButton("open dialog");
+ fooButton.setToolTipText("open dialog tooltip");
+ fooButton.addActionListener(new ActionListener() {
+
+ @Override
+ public void actionPerformed(ActionEvent e) {
+
+ createAndShowDialog(TestAppFrame.this);
+ }
+ });
+
+ JPanel dialogButtonPanel = new JPanel(new GridLayout(2,1));
+ dialogButtonPanel.add(fooButton);
+ JButton slowDialogButton = new JButton("open slow dialog");
+ slowDialogButton.addActionListener(new ActionListener() {
+
+ @Override
+ public void actionPerformed(ActionEvent arg0) {
+ new DialogOpenDelayer(TestAppFrame.this,statusLabel).execute();
+ }
+ });
+ dialogButtonPanel.add(slowDialogButton);
+
+ textPanel.add(dialogButtonPanel,BorderLayout.SOUTH);
+
+ JPanel westPanel = new JPanel(new GridLayout(6,1));
+ JComboBox combo = new JComboBox(new Object [] { "aaa","bbb","ccc",
+ "ddd",
+ "eee",
+ "fff",
+ "ggg",
+ "hhh",
+ "iii",
+ "111",
+ "222",
+ "333"
+ });
+ combo.addItemListener(new ItemListener() {
+ @Override
+ public void itemStateChanged(ItemEvent arg0) {
+ statusLabel.setText("selected in combo: " + arg0.getItem());
+
+ }
+ });
+
+ westPanel.add(combo);
+ final JCheckBox checkBox = new JCheckBox("This is a checkbox");
+ checkBox.addItemListener(new ItemListener() {
+
+ @Override
+ public void itemStateChanged(ItemEvent arg0) {
+ statusLabel.setText("checkbox is now "+checkBox.isSelected());
+ }
+ });
+ westPanel.add(checkBox);
+
+
+ JLabel label = new JLabel("This is a label");
+
+ final JPopupMenu popup = new JPopupMenu();
+ JMenuItem popupitem1 = new JMenuItem("popupitem1");
+ JMenuItem popupitem2 = new JMenuItem("popupitem2");
+ popupitem2.addActionListener(new ActionListener() {
+
+ @Override
+ public void actionPerformed(ActionEvent arg0) {
+ statusLabel.setText("clicked on popupitem2");
+ }
+ });
+ popup.add(popupitem1);
+ popup.add(popupitem2);
+ label.addMouseListener(new MouseAdapter() {
+
+ @Override
+ public void mousePressed(MouseEvent e){
+ if (e.isPopupTrigger())
+ doPop(e);
+ }
+ @Override
+ public void mouseReleased(MouseEvent e){
+ if (e.isPopupTrigger())
+ doPop(e);
+ }
+
+ private void doPop(MouseEvent e){
+ popup.show(e.getComponent(), e.getX(), e.getY());
+ }
+
+ });
+
+ westPanel.add(label);
+
+ JLabel label2 = new JLabel("click dbl click");
+ label2.addMouseListener(new MouseAdapter() {
+
+ @Override
+ public void mouseClicked(MouseEvent e) {
+ super.mouseClicked(e);
+
+ if (e.getClickCount() == 1) {
+ statusLabel.setText("clicked on label");
+ } else if (e.getClickCount() == 2) {
+ statusLabel.setText("double-clicked on label");
+ }
+ }
+ });
+ westPanel.add(label2);
+
+ final JFileChooser fc = new JFileChooser();
+ final JButton fileChooserButton = new JButton("Open file chooser");
+ fileChooserButton.addActionListener(new ActionListener() {
+
+ @Override
+ public void actionPerformed(ActionEvent arg0) {
+ int returnVal = fc.showOpenDialog(fileChooserButton);
+ if (returnVal == JFileChooser.APPROVE_OPTION) {
+ File file = fc.getSelectedFile();
+ statusLabel.setText("file is: " + file);
+ }
+ }
+ });
+ westPanel.add(fileChooserButton);
+
+ mainPanel.add(textPanel,BorderLayout.CENTER);
+ mainPanel.add(westPanel,BorderLayout.EAST);
+
+ return mainPanel;
+ }
+
+ private JPanel createTabTwo() {
+ JPanel mainPanel = new JPanel(new BorderLayout());
+
+ final JTable table = new JTable(new DefaultTableModel(
+ new Object[][] {
+ new Object[] { "row1", 2, 3 },
+ new Object[] { "row2", 4 , 6 },
+ new Object[] { "row3", 6 , 7 },
+ },
+
+ new Object[] { "col1", "col2", "col3" }
+ ));
+ table.getSelectionModel().addListSelectionListener(new ListSelectionListener() {
+
+ @Override
+ public void valueChanged(ListSelectionEvent arg0) {
+ ListSelectionModel lsm = (ListSelectionModel)arg0.getSource();
+ if (lsm.isSelectionEmpty()) {
+ } else {
+ int minIndex = lsm.getMinSelectionIndex();
+ statusLabel.setText("selected index in table: "+ minIndex);
+ }
+ }
+ });
+ table.getModel().addTableModelListener(new TableModelListener() {
+
+ @Override
+ public void tableChanged(TableModelEvent arg0) {
+ int row = arg0.getFirstRow();
+ int col = arg0.getColumn();
+ Object o = table.getModel().getValueAt(row,col);
+ statusLabel.setText("table value at row "+row+" col " +col + " is "+o);
+ }
+ });
+ mainPanel.add(table,BorderLayout.CENTER);
+ return mainPanel;
+ }
+
+ private JPanel[] createTabJTree() {
+ JPanel[] panels = new JPanel[2];
+ panels [0] = new JPanel(new BorderLayout());
+ panels [1] = new JPanel(new BorderLayout());
+ DefaultMutableTreeNode root = new DefaultMutableTreeNode("this is the root");
+ DefaultMutableTreeNode leafa = new DefaultMutableTreeNode("leaf a");
+ root.add(leafa);
+ DefaultMutableTreeNode leafaa = new DefaultMutableTreeNode("leaf a a");
+ leafa.add(leafaa);
+
+ DefaultMutableTreeNode leafaaa = new DefaultMutableTreeNode("leaf a a a");
+ DefaultMutableTreeNode leafaab = new DefaultMutableTreeNode("leaf a a b");
+ DefaultMutableTreeNode leafaac = new DefaultMutableTreeNode("leaf a a c");
+ leafaa.add(leafaaa);
+ leafaa.add(leafaab);
+ leafaa.add(leafaac);
+
+ DefaultMutableTreeNode leafab = new DefaultMutableTreeNode("leaf a b");
+ leafa.add(leafab);
+ DefaultMutableTreeNode leafb = new DefaultMutableTreeNode("leaf b");
+ DefaultMutableTreeNode leafba = new DefaultMutableTreeNode("leaf b a");
+ leafb.add(leafba);
+
+ root.add(leafb);
+
+ DefaultTreeModel model = new DefaultTreeModel(root);
+
+ Object o [] = new Object[] { root, leafa };
+ final TreePath treepath = new TreePath(o);
+
+ final JTree tree = new JTree(model);
+ tree.getSelectionModel().setSelectionMode(TreeSelectionModel.SINGLE_TREE_SELECTION);
+ tree.setRootVisible(true);
+ tree.addTreeExpansionListener(new TreeExpansionListener() {
+
+ @Override
+ public void treeExpanded(TreeExpansionEvent arg0) {
+ statusLabel.setText("leaf a is collapsed: "+tree.isCollapsed(treepath));
+ }
+
+ @Override
+ public void treeCollapsed(TreeExpansionEvent arg0) {
+ statusLabel.setText("leaf a is collapsed: "+tree.isCollapsed(treepath));
+ }
+ });
+ panels[0].add(new JScrollPane(tree),BorderLayout.CENTER);
+
+ final JTree tree2 = new JTree(model);
+ tree2.getSelectionModel().setSelectionMode(TreeSelectionModel.SINGLE_TREE_SELECTION);
+ tree2.setRootVisible(false);
+ tree2.addTreeExpansionListener(new TreeExpansionListener() {
+
+ @Override
+ public void treeExpanded(TreeExpansionEvent arg0) {
+ statusLabel.setText("leaf a is collapsed: "+tree2.isCollapsed(treepath));
+ }
+
+ @Override
+ public void treeCollapsed(TreeExpansionEvent arg0) {
+ statusLabel.setText("leaf a is collapsed: "+tree2.isCollapsed(treepath));
+ }
+ });
+ panels[1].add(new JScrollPane(tree2),BorderLayout.CENTER);
+
+ return panels;
+ }
+
+ private JPanel createTabLabeledFields() {
+ JPanel mainPanel = new JPanel(new BorderLayout());
+ JPanel gridPanel = new JPanel(new GridLayout(3,2,10,10));
+ gridPanel.add(new JLabel("label1"));
+
+ final JTextField textField = new JTextField(10);
+ textField.getDocument().addDocumentListener(new DocumentListener() {
+
+ @Override
+ public void removeUpdate(DocumentEvent arg0) {
+ statusLabel.setText(textField.getText());
+ }
+
+ @Override
+ public void insertUpdate(DocumentEvent arg0) {
+ statusLabel.setText(textField.getText());
+ }
+
+ @Override
+ public void changedUpdate(DocumentEvent arg0) {
+ statusLabel.setText(textField.getText());
+ }
+ });
+ gridPanel.add(textField);
+ gridPanel.add(new JLabel("label2"));
+ gridPanel.add(new JTextField(10));
+ gridPanel.add(new JLabel("label3"));
+ gridPanel.add(new JButton("boo"));
+ mainPanel.add(gridPanel,BorderLayout.NORTH);
+ return mainPanel;
+ }
+
+ private static class DialogOpenDelayer extends SwingWorker {
+
+ JFrame frame;
+ JLabel statusLabel;
+
+ public DialogOpenDelayer(JFrame frame, JLabel statusLabel) {
+ super();
+ this.frame = frame;
+ this.statusLabel = statusLabel;
+ }
+
+ @Override
+ protected Object doInBackground() throws Exception {
+ Thread.currentThread().sleep(7000);
+ return "";
+ }
+
+ @Override
+ protected void done() {
+ super.done();
+
+ final JDialog dialog = new JDialog(frame,true);
+ dialog.setTitle("slow dialog");
+ dialog.getContentPane().setLayout(new BorderLayout());
+ dialog.getContentPane().add(new JTextArea(18, 10),BorderLayout.CENTER);
+
+ JButton dialogButton = new JButton("close dialog");
+ dialogButton.addActionListener(new ActionListener() {
+
+ @Override
+ public void actionPerformed(ActionEvent e) {
+ new DialogCloseDelayer(dialog, statusLabel).execute();
+
+ }
+ });
+ dialog.getContentPane().add(dialogButton,BorderLayout.SOUTH);
+ //Display the window.
+ dialog.pack();
+ dialog.setLocationRelativeTo(null);
+ dialog.setVisible(true);
+ }
+ }
+
+ private static class DialogCloseDelayer extends SwingWorker {
+
+ JDialog dialog;
+ JLabel statusLabel;
+
+ public DialogCloseDelayer(JDialog dialog,JLabel statusLabel) {
+ super();
+ this.dialog = dialog;
+ this.statusLabel = statusLabel;
+ }
+
+ @Override
+ protected Object doInBackground() throws Exception {
+ Thread.currentThread().sleep(7000);
+ return "";
+ }
+
+ @Override
+ protected void done() {
+ super.done();
+ statusLabel.setText("Performed delayed close");
+ dialog.setVisible(false);
+ }
+ }
+}
diff --git a/backends/java-swing/README.md b/backends/java-swing/README.md
new file mode 100644
--- /dev/null
+++ b/backends/java-swing/README.md
@@ -0,0 +1,38 @@
+The Pianola agent instruments a running Java Swing desktop application.
+
+When the application starts, the agent opens a network socket (default port 26060) and begins listening for queries and requests. Keep in mind that, as of now, the connection is **completely unsecured**!
+
+The agent offers a "snapshot" method which serializes the current component hierarchy of the GUI and sends it back to the client. After analyzing the snapshot, the client can invoke methods to generate events on specific components, like for example clicking on a button.
+
+**Important**: Every change in the GUI, however minimal, must be followed by getting a new snapshot. Re-using a snapshot in the client to invoke several actions based on it won't work and should be discouraged by the client-side libraries.
+
+When a snapshot is taken, the agent also stores in memory image captures of all the windows at the moment of the request. However, these images are not sent along with the snapshot for efficiency reasons. They are requested through an special method. When a new snapshot is taken, the old images are discarded.
+
+Building the agent
+==================
+
+Building the agent requires Maven.
+
+Invoke
+
+> mvn install
+
+If the compilation is successful, the **pianola-driver** jar should appear in the **target** folder. Additionally, the **target/dependency** folder should contain **javassist** and **msgpack** jars (also a **json-simple** jar, but this it isn't used for anything).
+
+Configuring the Application Under Test
+======================================
+
+The **pianola**, **javassist** and **msgpack** jars must be in the classpath of the AUT.
+
+Additionally, when starting the AUT an argument of the following form must be passed to the JVM:
+
+> -javaagent:C:\Path\To\Pianola\pianola-driver-1.0.jar=port/26060,popupTrigger/release
+
+See the documentation of the [java.lang.instrument](http://docs.oracle.com/javase/6/docs/api/java/lang/instrument/package-summary.html) packgage for details on how to start agents from the command line.
+
+The correct value of the **popupTrigger** parameter varies depending on the operating system. On Windows it is **popupTrigger/release**, Linux users should use **popupTrigger/press**.
+
+If configured correctly, the agent should start automatically with the application.
+
+
+
diff --git a/backends/java-swing/pom.xml b/backends/java-swing/pom.xml
new file mode 100644
--- /dev/null
+++ b/backends/java-swing/pom.xml
@@ -0,0 +1,62 @@
+
+ 4.0.0
+
+ info.danidiaz.pianola
+ pianola-driver
+ 1.0
+ jar
+
+ pianola-driver
+ http://maven.apache.org
+
+
+ UTF-8
+
+
+
+
+ org.msgpack
+ msgpack
+ 0.6.6
+
+
+
+ junit
+ junit
+ 4.10
+ test
+
+
+
+
+
+
+ org.apache.maven.plugins
+ maven-jar-plugin
+ 2.4
+
+
+
+ info.danidiaz.pianola.driver.Driver
+
+
+
+
+
+ maven-dependency-plugin
+
+
+ package
+
+ copy-dependencies
+
+
+ runtime
+
+
+
+
+
+
+
diff --git a/backends/java-swing/src/main/java/info/danidiaz/pianola/driver/Driver.java b/backends/java-swing/src/main/java/info/danidiaz/pianola/driver/Driver.java
new file mode 100644
--- /dev/null
+++ b/backends/java-swing/src/main/java/info/danidiaz/pianola/driver/Driver.java
@@ -0,0 +1,309 @@
+package info.danidiaz.pianola.driver;
+
+import java.awt.image.BufferedImage;
+import java.io.BufferedInputStream;
+import java.io.BufferedOutputStream;
+import java.io.ByteArrayOutputStream;
+import java.io.IOException;
+import java.io.InputStream;
+import java.io.OutputStream;
+import java.io.PrintWriter;
+import java.io.StringWriter;
+import java.net.ServerSocket;
+import java.net.Socket;
+import java.util.HashMap;
+import java.util.Map;
+
+import javax.imageio.ImageIO;
+
+import org.msgpack.MessagePack;
+import org.msgpack.MessageTypeException;
+import org.msgpack.packer.MessagePackPacker;
+import org.msgpack.packer.Packer;
+import org.msgpack.unpacker.MessagePackUnpacker;
+import org.msgpack.unpacker.Unpacker;
+
+public class Driver implements Runnable
+{
+
+ // http://www.iana.org/assignments/service-names-port-numbers/service-names-port-numbers.xml
+ private final static int DEFAULT_PORT = 26060;
+
+ private final ServerSocket serverSocket;
+ private final MessagePack messagePack;
+
+ boolean releaseIsPopupTrigger;
+
+ private int lastSnapshotId = 0;
+ private Snapshot lastSnapshot = null;
+
+ private ByteArrayOutputStream imageBuffer = new ByteArrayOutputStream();
+
+ // http://docs.oracle.com/javase/6/docs/api/java/lang/instrument/package-summary.html
+ public static void premain(String agentArgs) {
+ agentArgs = agentArgs == null ? "" : agentArgs;
+
+ System.out.println( "Hi, I'm the agent, started with options: " + agentArgs );
+
+ try {
+ int port = DEFAULT_PORT;
+ boolean releaseIsPopupTrigger = true;
+ String [] splittedArgs = agentArgs.split(",",0);
+ for (int i=0;i actionMap = new HashMap();
+ for (Action a: Action.values()) {
+ actionMap.put(a.getName(),a);
+ }
+
+ boolean shutdownServer = false;
+ while (!shutdownServer) {
+ Socket clientSocket = serverSocket.accept();
+
+ InputStream sistream = new BufferedInputStream(clientSocket.getInputStream());
+ Unpacker unpacker = new MessagePackUnpacker(messagePack,sistream);
+
+ OutputStream sostream = new BufferedOutputStream(clientSocket.getOutputStream());
+ Packer packer = new MessagePackPacker(messagePack,sostream);
+
+ try {
+ String methodName = unpacker.readString();
+ if (methodName.equals("shutdown")) {
+ shutdownServer = true;
+ } else if (methodName.equals("snapshot")) {
+ lastSnapshotId++;
+ Snapshot pianola = new Snapshot(lastSnapshot,releaseIsPopupTrigger);
+ packer.write((int)0); // No error happened.
+ pianola.buildAndWrite(lastSnapshotId,packer);
+ lastSnapshot = pianola;
+ } else {
+ int snapshotId = unpacker.readInt();
+ if (snapshotId == lastSnapshotId) {
+ if (actionMap.containsKey(methodName)) {
+ actionMap.get(methodName).unpackInvokePack(unpacker,
+ lastSnapshot,
+ imageBuffer,
+ packer
+ );
+ } else {
+ packer.write((int)1); // An error happened.
+ packer.write((int)2); // Server error.
+ packer.write("Unsupported method: " + methodName);
+ }
+ } else {
+ packer.write((int)1); // An error happened.
+ packer.write((int)1); // Snapshot mismatch error.
+ packer.write((int)snapshotId);
+ packer.write((int)lastSnapshotId);
+ }
+ }
+ sostream.flush();
+ } catch (IOException ioe) {
+ ioe.printStackTrace();
+ } catch (MessageTypeException msgte) {
+ msgte.printStackTrace();
+ } catch (Exception e) {
+ e.printStackTrace();
+ } finally {
+ sistream.close();
+ sostream.close();
+ clientSocket.close();
+ }
+ }
+ serverSocket.close();
+ } catch (IOException ioe) {
+ ioe.printStackTrace();
+ }
+ }
+}
diff --git a/backends/java-swing/src/main/java/info/danidiaz/pianola/driver/ImageBin.java b/backends/java-swing/src/main/java/info/danidiaz/pianola/driver/ImageBin.java
new file mode 100644
--- /dev/null
+++ b/backends/java-swing/src/main/java/info/danidiaz/pianola/driver/ImageBin.java
@@ -0,0 +1,56 @@
+package info.danidiaz.pianola.driver;
+
+import java.awt.Dimension;
+import java.awt.image.BufferedImage;
+import java.util.Collection;
+import java.util.HashMap;
+import java.util.LinkedList;
+import java.util.List;
+import java.util.Map;
+
+public class ImageBin {
+
+ /*Some multimap class from Guava or Apache Commons would be better here,
+ but I want to avoid dependencies.*/
+ private Map> dimIndexedMultimap;
+
+ public ImageBin() {
+ this.dimIndexedMultimap = new HashMap>();
+ }
+
+ public ImageBin(Collection imageColl) {
+ this();
+
+ for (BufferedImage image: imageColl) {
+ Dimension d = getDimension(image);
+ if (!dimIndexedMultimap.containsKey(d)) {
+ dimIndexedMultimap.put(d,new LinkedList());
+ }
+ dimIndexedMultimap.get(d).add(image);
+ }
+ }
+
+ private static Dimension getDimension(BufferedImage image) {
+ return new Dimension(image.getWidth(), image.getHeight());
+ }
+
+ public void flush() {
+ for (List imageList: this.dimIndexedMultimap.values()) {
+ for (BufferedImage image: imageList) {
+ image.flush();
+ }
+ }
+ this.dimIndexedMultimap.clear();
+ }
+
+ public BufferedImage obtainImage(Dimension d) {
+ if (this.dimIndexedMultimap.containsKey(d)) {
+ List imageList = this.dimIndexedMultimap.get(d);
+ if (!imageList.isEmpty()) {
+ return imageList.remove(0);
+ }
+ }
+
+ return new BufferedImage(d.width, d.height, BufferedImage.TYPE_INT_RGB);
+ }
+}
diff --git a/backends/java-swing/src/main/java/info/danidiaz/pianola/driver/Snapshot.java b/backends/java-swing/src/main/java/info/danidiaz/pianola/driver/Snapshot.java
new file mode 100644
--- /dev/null
+++ b/backends/java-swing/src/main/java/info/danidiaz/pianola/driver/Snapshot.java
@@ -0,0 +1,725 @@
+package info.danidiaz.pianola.driver;
+
+import java.awt.Component;
+import java.awt.Container;
+import java.awt.Point;
+import java.awt.Rectangle;
+import java.awt.Window;
+import java.awt.event.KeyEvent;
+import java.awt.event.MouseEvent;
+import java.awt.event.WindowEvent;
+import java.awt.image.BufferedImage;
+import java.io.IOException;
+import java.lang.reflect.InvocationTargetException;
+import java.util.ArrayList;
+import java.util.HashMap;
+import java.util.List;
+import java.util.Map;
+
+import javax.swing.AbstractButton;
+import javax.swing.JCheckBoxMenuItem;
+import javax.swing.JComboBox;
+import javax.swing.JComponent;
+import javax.swing.JDialog;
+import javax.swing.JFrame;
+import javax.swing.JLabel;
+import javax.swing.JLayeredPane;
+import javax.swing.JList;
+import javax.swing.JMenuBar;
+import javax.swing.JPanel;
+import javax.swing.JPopupMenu;
+import javax.swing.JRadioButtonMenuItem;
+import javax.swing.JTabbedPane;
+import javax.swing.JTable;
+import javax.swing.JTextField;
+import javax.swing.JToggleButton;
+import javax.swing.JTree;
+import javax.swing.ListCellRenderer;
+import javax.swing.RootPaneContainer;
+import javax.swing.SwingUtilities;
+import javax.swing.table.TableCellRenderer;
+import javax.swing.table.TableModel;
+import javax.swing.text.JTextComponent;
+import javax.swing.tree.TreeCellRenderer;
+import javax.swing.tree.TreeModel;
+import javax.swing.tree.TreePath;
+
+import org.msgpack.packer.Packer;
+
+public class Snapshot {
+
+ private ImageBin imageBin;
+
+ private List windowArray = new ArrayList();
+ private Map windowImageMap = new HashMap();
+
+ private List componentArray = new ArrayList();
+
+ boolean releaseIsPopupTrigger;
+
+ public Snapshot(Snapshot pianola, boolean releaseIsPopupTrigger) {
+ this.imageBin = pianola==null ? new ImageBin() : pianola.obtainImageBin();
+ this.releaseIsPopupTrigger = releaseIsPopupTrigger;
+ }
+ public void buildAndWrite(final int snapid, final Packer packer) throws IOException {
+
+ try {
+ SwingUtilities.invokeAndWait(new Runnable() {
+
+ @Override
+ public void run() {
+ try {
+ Window warray[] = Window.getOwnerlessWindows();
+ writeWindowArray(snapid, packer, warray);
+ } catch (IOException e) {
+ e.printStackTrace();
+ }
+ }
+ });
+ } catch (InterruptedException e) {
+ e.printStackTrace();
+ } catch (InvocationTargetException e) {
+ e.printStackTrace();
+ } finally {
+ this.imageBin.flush();
+ }
+ }
+
+ private static int countShowing(Component[] warray) {
+ int visibleCount = 0;
+ for (int i=0;i -javaagent:C:\Progs\DbVisualizer\lib\pianola-driver-1.0.jar=port/26060,popupTrigger/release
+
+In Linux, use **popupTrigger/press** instead of **popupTrigger/release**.
+
+**NOTE**: Unfortunately, I haven't been able to manipulate the tree to the left side of the main window using Pianola. Perhaps it is is some kind of custom component instead of a JTree or a subclass of JTree.
diff --git a/examples/dbvisualizer.hs b/examples/dbvisualizer.hs
new file mode 100644
--- /dev/null
+++ b/examples/dbvisualizer.hs
@@ -0,0 +1,60 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Main where
+
+import Prelude hiding (catch,(.),id)
+import Data.Monoid
+import Data.Tree
+import qualified Data.Text as T
+import Network
+import Control.Category
+import Control.Monad
+import Control.Error
+import Control.Applicative
+
+import Pianola.Model.Swing.Driver
+
+import System.Environment
+import System.Exit (exitFailure)
+
+type Test = Pianola Protocol LogEntry (GUI Protocol) ()
+
+testCase:: T.Text -> Test
+testCase jarpath = do
+ with (windowTitled (T.isInfixOf "DbVisualizer")) $ do
+ poke $ toFront
+ pokeMaybe $ children >=> contentPane >=> clickButtonByText (=="Cancel")
+ selectInMenuBar $ map (==) ["Tools","Driver Manager..."]
+ sleep 1
+ with (windowTitled (=="Driver Manager")) $ with contentPane $ do
+ logmsg "Opened Driver Manager"
+ logmsg "Selecting MySQL"
+ with descendants $ do
+ poke $ tableCellByText 0 (=="MySQL") >=> return._clickCell.fst
+ sleep 2
+ poke $ clickButtonByToolTip (T.isInfixOf "Open file")
+ with window $ with childWindow $ with contentPane $ do
+ poke $ descendants >=> hasText (=="") >=> setText jarpath
+ sleep 2
+ poke $ clickButtonByText $ \txt -> or $ map (txt==) ["Open","Abrir"]
+ sleep 2
+ with window $ poke close
+ return ()
+
+main :: IO ()
+main = do
+ args <- getArgs
+ case args of
+ addr : jarpath : _ -> do
+ let port = PortNumber . fromIntegral $ 26060
+ endpoint = Endpoint addr port
+ r <- runEitherT $ simpleSwingDriver endpoint (testCase $ T.pack jarpath) $ screenshotStream "."
+ case r of
+ Left err -> do
+ putStrLn $ "result: " <> show err
+ exitFailure
+ Right _ -> putStrLn $ "result: all ok"
+ _ -> putStrLn "Required args: host jarpath"
+
+
diff --git a/pianola.cabal b/pianola.cabal
new file mode 100644
--- /dev/null
+++ b/pianola.cabal
@@ -0,0 +1,90 @@
+name: pianola
+version: 0.1.0
+license: MIT
+license-file: LICENSE
+data-files:
+author: Daniel Díaz Carrete
+maintainer: diaz_carrete@yahoo.com
+category: Jvm, GUI
+Synopsis: Remotely controlling Java Swing applications
+Description: This is a library for remotely controlling
+ Java Swing desktop applications that have been
+ instrumented with a special pianola agent.
+
+ The agent exposes the Swing component hierarchy
+ over the network, and accepts requests for
+ generating GUI events. The library handles the
+ interaction on the Haskell side.
+build-type: Simple
+cabal-version: >= 1.10
+Extra-Source-Files:
+ README.md
+ tests/README.md
+ examples/dbvisualizer.hs
+ examples/README.md
+ backends/java-swing/pom.xml
+ backends/java-swing/README.md
+ backends/java-swing/src/main/java/info/danidiaz/pianola/driver/*.java
+ backends/java-swing-testapp/pom.xml
+ backends/java-swing-testapp/README.md
+ backends/java-swing-testapp/src/main/java/info/danidiaz/pianola/testapp/*.java
+
+Library
+ hs-source-dirs: src
+ exposed-modules:
+ Pianola.Internal
+ Pianola.Util
+ Pianola.Geometry
+ Pianola.Pianola
+ Pianola.Pianola.Driver
+ Pianola.Tutorial
+ Pianola.Protocol
+ Pianola.Protocol.IO
+ Pianola.Model.Swing
+ Pianola.Model.Swing.Driver
+ Pianola.Model.Swing.Protocol
+ other-modules:
+ build-depends:
+ base >= 4.4 && < 5,
+ text >= 0.11,
+ containers >= 0.4,
+ bytestring >= 0.9,
+ msgpack >= 0.7,
+ iteratee >= 0.8,
+ attoparsec >= 0.10,
+ attoparsec-iteratee >= 0.3,
+ filepath >= 1.3,
+ network >= 2.4,
+ logict >= 0.5,
+ errors >= 1.3,
+ either >= 3.4,
+ pipes >= 3.1,
+ free >= 3.2,
+ comonad >= 3.0,
+ comonad-transformers >= 3.0,
+ streams >= 3.1,
+ transformers >= 0.2,
+ mtl >= 2.1
+ default-language: Haskell2010
+
+Test-suite test-pianola
+ type: exitcode-stdio-1.0
+ hs-source-dirs: tests
+ main-is: tests-pianola.hs
+ build-depends:
+ base >= 4.4,
+ text >= 0.11,
+ containers >= 0.4,
+ filepath >= 1.3,
+ network >= 2.4,
+ errors >= 1.3,
+ streams >= 3.1,
+ transformers >= 0.2,
+ pianola
+ default-language: Haskell2010
+
+Source-repository head
+ type: git
+ location: https://github.com/danidiaz/pianola.git
+
+
diff --git a/src/Pianola/Geometry.hs b/src/Pianola/Geometry.hs
new file mode 100644
--- /dev/null
+++ b/src/Pianola/Geometry.hs
@@ -0,0 +1,87 @@
+{-# LANGUAGE FlexibleInstances #-}
+
+module Pianola.Geometry (
+ Interval,
+ Point1d,
+ inside1d,
+ before1d,
+ after1d,
+ Point2d,
+ Dimensions2d,
+ mid,
+ Geometrical (..),
+ sameLevelRightOf
+ ) where
+
+import Prelude hiding (catch,(.),id)
+import Control.Category
+
+type Interval = (Int,Int)
+
+type Point1d = Int
+
+inside1d :: Interval -> Point1d -> Bool
+inside1d (x1,x2) u = x1 <= u && u <= x2
+
+before1d :: Interval -> Point1d -> Bool
+before1d (x1,_) x = x <= x1
+
+after1d :: Interval -> Point1d -> Bool
+after1d (_,x2) x = x2 <= x
+
+-- | (x,y)
+type Point2d = (Int,Int)
+
+-- | (width,height)
+type Dimensions2d = (Int,Int)
+
+mid :: Interval -> Point1d
+mid (x1,x2) = div (x1+x2) 2
+
+-- | Class of objects with rectangular shape and located in a two-dimensional
+-- plane.
+class Geometrical g where
+ -- | Position of the north-west corner.
+ nwcorner :: g -> Point2d
+
+ dimensions :: g -> Dimensions2d
+
+ width :: g -> Int
+ width = fst . dimensions
+
+ height :: g -> Int
+ height = snd . dimensions
+
+ minX :: g -> Int
+ minX = fst . nwcorner
+
+ midX :: g -> Int
+ midX = mid . yband
+
+ minY :: g -> Int
+ minY = snd . nwcorner
+
+ midY :: g -> Int
+ midY = mid . yband
+
+ xband :: g -> Interval
+ xband g =
+ let gminX = minX g
+ in (gminX, gminX + (fst . dimensions) g)
+
+ yband :: g -> Interval
+ yband g =
+ let gminY = minY g
+ in (gminY, gminY + (snd . dimensions) g)
+
+ area :: g -> Int
+ area g = width g * height g
+
+ midpoint :: g -> Point2d
+ midpoint g = (midX g, midY g)
+
+-- | True if the second object is roughly at the same height and to the right
+-- of the first object.
+sameLevelRightOf :: (Geometrical g1, Geometrical g2) => g1 -> g2 -> Bool
+sameLevelRightOf ref c =
+ inside1d (yband c) (midY ref) && after1d (xband ref) (minX c)
diff --git a/src/Pianola/Internal.hs b/src/Pianola/Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/Pianola/Internal.hs
@@ -0,0 +1,42 @@
+-- | This module should not be imported by clients unless for the purpose of
+-- extending the library.
+--
+-- The constructors of the data types defined in this module are meant to be
+-- hidden from the client.
+
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module Pianola.Internal (
+ Nullipotent(..),
+ Tag,
+ Sealed(..),
+ addTag
+ ) where
+
+import Prelude hiding (catch,(.),id)
+import Data.Foldable (Foldable)
+import Data.Traversable
+import qualified Data.Text as T
+
+-- | Wraps a monad in order to tag those operations which don't actually change
+-- the state of the remote system. For example: taking a screenshot doesn't
+-- change the state of a GUI, as opposed to clicking a button.
+newtype Nullipotent m a = Nullipotent { runNullipotent :: m a }
+ deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Monad)
+
+type Tag = T.Text
+
+-- | Encapsulates a monadic action so that clients can't manipulate it in any
+-- way, only dispatch it to some function.
+--
+-- There may be tags attached that describe the action. Clients should be able
+-- to inspect the tags.
+data Sealed m = Sealed {
+ tags :: [Tag],
+ unseal :: m ()
+ }
+
+addTag :: Tag -> Sealed m -> Sealed m
+addTag t (Sealed ts a) = Sealed (t:ts) a
+
diff --git a/src/Pianola/Model/Swing.hs b/src/Pianola/Model/Swing.hs
new file mode 100644
--- /dev/null
+++ b/src/Pianola/Model/Swing.hs
@@ -0,0 +1,497 @@
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module Pianola.Model.Swing (
+ GUI (..),
+ Window (..),
+ WindowInfo (..),
+ WindowLike (..),
+ Windowed (..),
+ ComponentW (..),
+ Component (..),
+ ComponentInfo (..),
+ ComponentType (..),
+ ComponentLike (..),
+ Cell (..),
+ Tab (..),
+ mainWindow,
+ childWindow,
+ windowTitled,
+ clickButtonByText,
+ clickButtonByToolTip,
+ rightClickByText,
+ popupItem,
+ selectInMenuBar,
+ toggleInMenuBar,
+ selectInComboBox,
+ selectTabByText,
+ selectTabByToolTip,
+ expand,
+ labeledBy
+ ) where
+
+import Prelude hiding (catch)
+import Data.Tree
+import Data.Function
+import Data.Functor.Identity
+import qualified Data.Text as T
+import Control.Error
+import Control.Monad
+import Control.Comonad
+import Control.Applicative
+import Control.Monad.Trans.Class
+import Control.Comonad.Trans.Class
+import Control.Comonad.Trans.Env
+import Data.List
+import Pianola.Util
+import Pianola.Pianola
+import Pianola.Geometry
+import Control.Monad.Logic
+
+-- | A client-side representation of the state of a remote Swing GUI.
+-- Interaction with the GUI is through actions in the monad /m/.
+type GUI m = [Window m]
+
+newtype Window m = Window { unWindow :: Tree (WindowInfo m) }
+
+-- | Typeclass instantiated by windows and components aware of belonging to a
+-- window.
+class Windowed w where
+ window :: Monad n => w m -> n (Window m)
+
+-- | Typeclass which provides convenience functions to supplement the bare fields of a 'WindowInfo' record.
+class Windowed w => WindowLike w where
+ wInfo :: w m -> WindowInfo m
+
+ title :: (Monad m,Monad n) => (w m) -> n T.Text
+ title = return . _windowTitle . wInfo
+
+ -- | If the window has a title that satisfies the predicate, returns the
+ -- window, otherwise 'mzero'.
+ hasTitle :: MonadPlus n => (T.Text -> Bool) -> w m -> n (w m)
+ hasTitle f w = do
+ guard . f $ _windowTitle . wInfo $ w
+ return w
+
+ -- | Convenience function to access the components in the popup layer. Most
+ -- of the time, clients should use 'popupItem' instead of this function.
+ popupLayer :: Monad m => Glance m l (w m) (Component m)
+ popupLayer = replusify . _popupLayer . wInfo
+
+ -- | Convenience function to log an screenshot of a window.
+ logcapture :: Monad m => Pianola m LogEntry (w m) ()
+ logcapture = (peek $ liftN._capture.wInfo) >>= logimg
+
+ -- | Convenience function which returns the content pane component
+ -- augmented with a reference to the containing window.
+ contentPane :: Monad m => Glance m l (w m) (ComponentW m)
+ contentPane win =
+ let concrete = runIdentity $ window win
+ in return . ComponentW
+ . EnvT concrete
+ . unComponent
+ . _contentPane
+ . wInfo
+ $ win
+
+ -- | Brings the window to the front of the screen.
+ toFront :: Monad m => Glance m l (w m) (Sealed m)
+ toFront = return . _toFront . wInfo
+
+ -- | Sends an /escape/ keypress to the window.
+ escape :: Monad m => Glance m l (w m) (Sealed m)
+ escape = return . _escape . wInfo
+
+ -- | Sends an /enter/ keypress to the window.
+ enter :: Monad m => Glance m l (w m) (Sealed m)
+ enter = return . _enter . wInfo
+
+ close :: Monad m => Glance m l (w m) (Sealed m)
+ close = return . _close . wInfo
+
+instance Treeish (Window m) where
+ children (Window c) = children c >>= return . Window
+ descendants (Window c) = descendants c >>= return . Window
+
+instance WindowLike Window where
+ wInfo = rootLabel . unWindow
+
+instance Windowed Window where
+ window = return . id
+
+data WindowInfo m = WindowInfo
+ { _windowTitle::T.Text
+ -- | Width, height.
+ , _windowDim::(Int,Int)
+ -- | List of components in the menu bar. See 'selectInMenuBar'.
+ , _menu::[Component m]
+ -- | List of components in the popup layer.
+ , _popupLayer:: [Component m]
+ -- | The contents pane. All non-popup components of the window are
+ -- descendants of the contents pane. See 'contentPane' and 'descendants'.
+ , _contentPane::Component m
+ -- | Action which returns a screenshot capture of the window. See 'logcapture'.
+ , _capture::Nullipotent m Image
+ -- | See 'escape'.
+ , _escape::Sealed m
+ -- | See 'enter'.
+ , _enter::Sealed m
+ -- | See 'close'.
+ , _close::Sealed m
+ -- | See 'toFront'.
+ , _toFront::Sealed m
+ }
+
+-- | A component which carries a reference to the window to which it belongs.
+-- See 'Windowed'.
+newtype ComponentW m = ComponentW
+ { unComponentW :: EnvT (Window m) Tree (ComponentInfo m) }
+
+instance Treeish (ComponentW m) where
+ children (ComponentW c) = children c >>= return . ComponentW
+ descendants (ComponentW c) = descendants c >>= return . ComponentW
+
+instance ComponentLike ComponentW where
+ cInfo = rootLabel . lower . unComponentW
+
+instance Windowed ComponentW where
+ window = return . ask . unComponentW
+
+newtype Component m = Component
+ { unComponent :: Tree (ComponentInfo m) }
+
+instance Treeish (Component m) where
+ children (Component c) = children c >>= return . Component
+ descendants (Component c) = descendants c >>= return . Component
+
+instance ComponentLike Component where
+ cInfo = rootLabel . unComponent
+
+data ComponentInfo m = ComponentInfo
+ { -- | The position of the component within the containing window.
+ _pos::(Int,Int)
+ -- | Width and height.
+ , _dim::(Int,Int)
+ , _name::Maybe T.Text
+ , _tooltip::Maybe T.Text
+ -- | The textual value of the component.
+ , _text::Maybe T.Text
+ , _enabled::Bool
+ , _componentType::ComponentType m
+ , _click::Sealed m
+ , _doubleClick::Sealed m
+ , _rightClick::Sealed m
+ }
+
+instance ComponentLike c => Geometrical (c m) where
+ nwcorner = _pos . cInfo
+ dimensions = _dim . cInfo
+
+-- | Typeclass which provides convenience functions to supplement the bare fields of a 'ComponentInfo' record.
+class ComponentLike c where
+ cInfo :: c m -> ComponentInfo m
+
+ cType :: c m -> ComponentType m
+ cType = _componentType . cInfo
+
+ -- | Returns the component's textual content or 'mzero' if it doesn't have
+ -- any.
+ text :: MonadPlus n => c m -> n T.Text
+ text = justZ . _text . cInfo
+
+ -- | If the component has some kind of textual content and the text
+ -- satisfies the predicate, returns the component, otherwise 'mzero'.
+ hasText:: MonadPlus n => (T.Text -> Bool) -> c m -> n (c m)
+ hasText f c = do
+ t <- text $ c
+ guard $ f t
+ return c
+
+ -- | Returns the component's tooltip or 'mzero' if it doesn't have any.
+ tooltip :: MonadPlus n => c m -> n T.Text
+ tooltip = justZ . _tooltip . cInfo
+
+ -- | If the component has a tooltip and the tooltip satisfies the
+ -- predicate, returns the component, otherwise 'mzero'.
+ hasToolTip:: MonadPlus n => (T.Text -> Bool) -> c m -> n (c m)
+ hasToolTip f c = do
+ t <- tooltip $ c
+ guard $ f t
+ return c
+
+ -- | If the component has a name and the name satisfies the predicate,
+ -- returns the component, otherwise 'mzero'.
+ hasName:: MonadPlus n => (T.Text -> Bool) -> c m -> n (c m)
+ hasName f c = do
+ t <- justZ._name.cInfo $ c
+ guard $ f t
+ return c
+
+ -- | Toggles the component to the desired state if the component is
+ -- toggleable, 'mzero' otherwise.
+ toggle:: MonadPlus n => Bool -> c m -> n (Sealed m)
+ toggle b (cType -> Toggleable _ f) = return $ f b
+ toggle _ _ = mzero
+
+ -- | Returns the click action of a component.
+ click:: Monad n => c m -> n (Sealed m)
+ click = return._click.cInfo
+
+ doubleClick:: Monad n => c m -> n (Sealed m)
+ doubleClick = return._doubleClick.cInfo
+
+ rightClick:: Monad n => c m -> n (Sealed m)
+ rightClick = return._rightClick.cInfo
+
+ -- | If the component is a button returns its click action, otherwise
+ -- 'mzero'.
+ clickButton:: MonadPlus n => c m -> n (Sealed m)
+ clickButton (cType -> Button a) = return a
+ clickButton _ = mzero
+
+ -- | If the component is a combo box returns its click action, otherwise
+ -- 'mzero'.
+ clickCombo:: MonadPlus n => c m -> n (Sealed m)
+ clickCombo (cType -> ComboBox _ a) = return a
+ clickCombo _ = mzero
+
+ -- | If the component is a list and has a cell whose renderer's text
+ -- satisfies the predicate, returns the cell, otherwise 'mzero'.
+ listCellByText:: MonadPlus n => (T.Text -> Bool) -> c m -> n (Cell m)
+ listCellByText f (cType -> List l) = do
+ cell <- replusify l
+ let renderer = _renderer cell
+ descendants >=> hasText f $ renderer
+ return cell
+ listCellByText _ _ = mzero
+
+ -- | If the component is a table and has a cell at the specified column
+ -- whose renderer's text satisfies the predicate, returns a pair of the
+ -- cell and the row to which it belongs, otherwise 'mzero'.
+ tableCellByText:: MonadPlus n => Int -> (T.Text -> Bool) -> c m -> n (Cell m,[Cell m])
+ tableCellByText colIndex f (cType -> Table listOfCols) = do
+ column <- atZ listOfCols colIndex
+ (rowfocus,row) <- replusify $ zip column $ transpose listOfCols
+ let renderer = _renderer rowfocus
+ descendants >=> hasText f $ renderer
+ return (rowfocus,row)
+ tableCellByText _ _ _ = mzero
+
+ -- | If the component is a tree and has a cell at the specified depth
+ -- (starting at 0 for the root) whose renderer's text satisfies the
+ -- predicate, returns the subtree which has the cell as a root, otherwise
+ -- 'mzero'.
+ treeCellByText :: MonadPlus n => Int -> (T.Text -> Bool) -> c m -> n (Tree (Cell m))
+ treeCellByText depth f (cType -> Treegui cellForest) = do
+ tree <- replusify cellForest
+ level <- flip atZ depth . levels . duplicate $ tree
+ subtree <- replusify level
+ let renderer = _renderer . rootLabel $ subtree
+ descendants >=> hasText f $ renderer
+ return subtree
+ treeCellByText _ _ _ = mzero
+
+ -- | Returns the tabs of a component if the component is a tabbed pane,
+ -- 'mzero' otherwise.
+ tab:: MonadPlus n => c m -> n (Tab m)
+ tab (cType -> TabbedPane p) = replusify p
+ tab _ = mzero
+
+ -- | If the component is a text field and is editable, set the text of the
+ -- text field. Otherwise 'mzero'.
+ setText:: MonadPlus n => T.Text -> c m -> n (Sealed m)
+ setText txt c = case (cType c) of
+ TextField (Just f) -> return $ f txt
+ _ -> mzero
+
+-- | Represents data specific to each subclass of Swing components.
+data ComponentType m =
+ Panel
+ -- | A check box, either in a window or in a popup menu. The bool value is the
+ -- current selection state.
+ |Toggleable Bool (Bool -> Sealed m)
+ -- | A button with its selection action. Menu items in popup menus are also
+ -- treated as buttons.
+ |Button (Sealed m)
+ -- | 'Nothing' when the textfield is not editable.
+ |TextField (Maybe (T.Text -> Sealed m))
+ |Label
+ -- | A combo box which may already have a selection, and which offers a click
+ -- action which shows the drop-down list. See 'selectInComboBox'.
+ |ComboBox (Maybe (Component m)) (Sealed m)
+ -- | See 'listCellByText'.
+ |List [Cell m]
+ -- | Tables are represented as lists of columns. See 'tableCellByText'.
+ |Table [[Cell m]]
+ -- | A list of trees of 'Cell'. It is a list of trees instead of a single tree
+ -- so that JTrees which do not show the root can be represented. See 'treeCellByText'.
+ |Treegui (Forest (Cell m))
+ -- | In Swing, popup menus reside in the popup layer of a window or, if the
+ -- popup extends beyond the window, in the contents pane of a child window
+ -- created to hold the popup. See 'popupItem'.
+ |PopupMenu
+ -- | See 'selectTabByText'.
+ |TabbedPane [Tab m]
+ -- | The text value holds the name of the class.
+ |Other T.Text
+
+-- | Complex gui components like lists, tables and trees are represented as
+-- list of cells, list of lists (list of columns) of cells, and trees of cells,
+-- respectively.
+--
+-- Bear in mind that in Swing the renderer sub-components of a complex
+-- component do /not/ count as children of the component. However, editor
+-- components /do/ count as children of the component.
+--
+-- A common case is to double click on a table cell to activate the cell's
+-- editor, and then having to look for that editor among the descendants of the
+-- table.
+data Cell m = Cell
+ {
+ -- | The rendering component. Clients should not try to invoke actions on
+ -- rendering components, as they are inert and only used for display
+ -- purposes.
+ _renderer::Component m
+ , _clickCell::Sealed m
+ , _doubleClickCell::Sealed m
+ , _rightClickCell::Sealed m
+ -- | Always 'Nothing' for cells not belonging to trees.
+ , _expand:: Maybe (Bool -> Sealed m)
+ }
+
+data Tab m = Tab
+ { _tabText::T.Text
+ , _tabToolTip::Maybe T.Text
+ , _isTabSelected:: Bool
+ , _selectTab::Sealed m
+ }
+
+-- | Returns the main window of the application. Only works properly when there
+-- is only one top-level window.
+mainWindow :: Glance m l (GUI m) (Window m)
+mainWindow = replusify
+
+-- | Returns the children of a window.
+childWindow :: Glance m l (Window m) (Window m)
+childWindow = children
+
+-- | Returns all visible windows whose title satisfies the predicate.
+windowTitled :: (T.Text -> Bool) -> Glance m l (GUI m) (Window m)
+windowTitled f = replusify >=> descendants >=> hasTitle f
+
+-- | If the component or *any of its descendants* is a button whose text
+-- satisfies the predicate, returns the click action. Otherwise 'mzero'.
+clickButtonByText :: (Monad m,ComponentLike c,Treeish (c m)) => (T.Text -> Bool) -> Glance m l (c m) (Sealed m)
+clickButtonByText f = descendants >=> hasText f >=> clickButton
+
+-- | Similar to 'clickButtonByText'.
+clickButtonByToolTip :: (Monad m,ComponentLike c,Treeish (c m)) => (T.Text -> Bool) -> Glance m l (c m) (Sealed m)
+clickButtonByToolTip f = descendants >=> hasToolTip f >=> clickButton
+
+-- | Similar to 'clickButtonByText'.
+rightClickByText :: (Monad m,ComponentLike c,Treeish (c m)) => (T.Text -> Bool) -> Glance m l (c m) (Sealed m)
+rightClickByText f = descendants >=> hasText f >=> rightClick
+
+-- | Returns all the visible popup items belonging to a window (that is, not
+-- only the popup components themselves, but all their clickable children).
+-- Clients should use this function instead of trying to access the popup layer
+-- directly.
+popupItem :: Monad m => Glance m l (Window m) (Component m)
+popupItem w =
+ let insidepop = children >=> contentPane >=> descendants >=> \c ->
+ case cType c of
+ PopupMenu -> descendants c
+ _ -> mzero
+ in (popupLayer >=> descendants $ w) `mplus`
+ (insidepop >=> return . Component . lower . unComponentW $ w)
+
+-- | Performs a sequence of selections in a window menu, based to the text of
+-- the options. Pass it something like
+--
+-- > map (==) ["menuitem1","menuitem2',...]
+--
+-- To match the exact names of the options.
+selectInMenuBar :: Monad m => [T.Text -> Bool] -> Pianola m l (Window m) ()
+selectInMenuBar ps =
+ let go (firstitem,middleitems,lastitem) = do
+ poke $ replusify._menu.wInfo >=> descendants >=> hasText firstitem >=> clickButton
+ let pairs = zip middleitems (clickButton <$ middleitems) ++
+ [(lastitem, clickButton)]
+ forM_ pairs $ \(txt,action) ->
+ pmaybe pfail $ retryPoke1s 7 $
+ popupItem >=> hasText txt >=> action
+ clip l = (,,) <$> headZ l <*> (initZ l >>= tailZ) <*> lastZ l
+ in maybe pfail go (clip ps)
+
+-- | Like 'selectInMenuBar', but for when the last item is a toggleable
+-- component. The boolean paramenter is the desired selection state.
+toggleInMenuBar :: Monad m => Bool -> [T.Text -> Bool] -> Pianola m l (Window m) ()
+toggleInMenuBar toggleStatus ps =
+ let go (firstitem,middleitems,lastitem) = do
+ poke $ replusify._menu.wInfo >=> descendants >=> hasText firstitem >=> clickButton
+ let pairs = zip middleitems (clickButton <$ middleitems) ++
+ [(lastitem, toggle toggleStatus)]
+ forM_ pairs $ \(txt,action) ->
+ pmaybe pfail $ retryPoke1s 7 $
+ popupItem >=> hasText txt >=> action
+ replicateM_ (length pairs) $ poke escape
+ clip l = (,,) <$> headZ l <*> (initZ l >>= tailZ) <*> lastZ l
+ in maybe pfail go (clip ps)
+
+-- | If the component is a combo box, clicks on it and selects an option by its
+-- text. Otherwise fails.
+selectInComboBox :: (Monad m, ComponentLike c, Windowed c) => (T.Text -> Bool) -> Pianola m l (c m) ()
+selectInComboBox f = do
+ poke $ clickCombo
+ poke $ window >=> popupItem >=> listCellByText f >=> return._clickCell
+
+-- | If the component is a tabbed pane returns the select action of a tab whose
+-- text matches the predicate. Returns 'mzero' if the component is not a tabbed
+-- pane.
+selectTabByText :: (Monad m,ComponentLike c) => (T.Text -> Bool) -> Glance m l (c m) (Sealed m)
+selectTabByText f =
+ tab >=> \aTab -> do
+ guard $ f . _tabText $ aTab
+ return $ _selectTab aTab
+
+-- | Similar to 'selecTabByText'.
+selectTabByToolTip :: (Monad m,ComponentLike c) => (T.Text -> Bool) -> Glance m l (c m) (Sealed m)
+selectTabByToolTip f =
+ tab >=> \aTab -> do
+ tooltip <- justZ . _tabToolTip $ aTab
+ guard $ f tooltip
+ return $ _selectTab aTab
+
+-- | Returns the expand/collapse action of the root node of a tree of cells,
+-- depending on a boolean parameter. Useful with gui trees.
+expand :: Monad m => Bool -> Glance m l (Tree (Cell m)) (Sealed m)
+expand b cell = (justZ . _expand . rootLabel $ cell) <*> pure b
+
+-- | Takes a component, searches its descendants to find a label whose text
+-- matches the predicate, finds the component to which the label applies, and
+-- returns it.
+--
+-- Useful for targeting text fields in form-like dialogs.
+labeledBy :: (Monad m,ComponentLike c,Treeish (c m)) => (T.Text -> Bool) -> Glance m l (c m) (c m)
+labeledBy f o = do
+ ref <- descendants o
+ Label {} <- return . cType $ ref
+ hasText f ref
+ let
+ positioned = sameLevelRightOf ref
+ labellable c = case cType c of
+ Toggleable {} -> True
+ Button {} -> True
+ TextField {} -> True
+ ComboBox {} -> True
+ List {} -> True
+ Table {} -> True
+ Treegui {} -> True
+ _ -> False
+ candidates <- lift . observeAllT $ do
+ c <- descendants o
+ guard $ labellable c && positioned c
+ return c
+ headZ $ sortBy (compare `on` minX) candidates
+
diff --git a/src/Pianola/Model/Swing/Driver.hs b/src/Pianola/Model/Swing/Driver.hs
new file mode 100644
--- /dev/null
+++ b/src/Pianola/Model/Swing/Driver.hs
@@ -0,0 +1,25 @@
+module Pianola.Model.Swing.Driver (
+ simpleSwingDriver,
+ module Pianola.Util,
+ module Pianola.Pianola,
+ module Pianola.Protocol,
+ module Pianola.Protocol.IO,
+ module Pianola.Pianola.Driver,
+ module Pianola.Model.Swing
+) where
+
+import Prelude hiding (catch,(.),id,head,repeat,tail,map,iterate)
+import Data.Stream.Infinite
+import Control.Error
+import Pianola.Util
+import Pianola.Protocol
+import Pianola.Protocol.IO
+import Pianola.Pianola
+import Pianola.Pianola.Driver
+import Pianola.Model.Swing
+import Pianola.Model.Swing.Protocol (snapshot)
+
+-- | Specialization of 'simpleDriver' which doesn't require the client to
+-- provide the snapshot action.
+simpleSwingDriver :: Endpoint -> Pianola Protocol LogEntry (GUI Protocol) a -> Stream FilePath -> EitherT DriverError IO a
+simpleSwingDriver = simpleDriver snapshot
diff --git a/src/Pianola/Model/Swing/Protocol.hs b/src/Pianola/Model/Swing/Protocol.hs
new file mode 100644
--- /dev/null
+++ b/src/Pianola/Model/Swing/Protocol.hs
@@ -0,0 +1,145 @@
+{-# LANGUAGE FlexibleInstances #-}
+
+module Pianola.Model.Swing.Protocol (
+ snapshot
+ ) where
+
+import Prelude hiding (catch,(.),id)
+import Data.Monoid
+import Data.MessagePack
+import Data.Attoparsec.ByteString
+import qualified Data.Text as T
+import qualified Data.Iteratee as I
+import qualified Data.Attoparsec.Iteratee as AI
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as BL
+import Control.Category
+import Control.Error
+import Control.Monad
+import Control.Applicative
+
+import Pianola.Util
+import Pianola.Internal
+import Pianola.Protocol
+import Pianola.Model.Swing
+
+iterget :: (Monad m, Unpackable a) => I.Iteratee B.ByteString m a
+iterget = AI.parserToIteratee get
+
+-- | Monadic action to obtain a local representation of the state of a remote
+-- Swing GUI.
+snapshot :: Protocol (GUI Protocol)
+snapshot = call [pack "snapshot"] iterget >>= hoistEither
+
+makeAction :: T.Text -> [BL.ByteString] -> Sealed Protocol
+makeAction method args = Sealed [T.pack "@" <> method] $
+ call (pack method:args) iterget >>= hoistEither
+
+instance Unpackable (Window Protocol) where
+ get = Window <$> get
+
+instance Unpackable (WindowInfo Protocol) where
+ get = do
+ snapid <- get::Parser Int
+ wid <- get::Parser Int
+ v1 <- get
+ v2 <- get
+ v3 <- get
+ v4 <- get
+ v5 <- get
+ let packedargs = map pack [snapid,wid]
+ getWindowImage = Nullipotent $
+ call (pack "getWindowImage":packedargs) iterget >>= hoistEither
+ escape = makeAction (T.pack "escape") packedargs
+ enter = makeAction (T.pack "enter") packedargs
+ closeWindow = makeAction (T.pack "closeWindow") packedargs
+ toFront = makeAction (T.pack "toFront") packedargs
+ return (WindowInfo v1 v2 v3 v4 v5 getWindowImage escape enter closeWindow toFront)
+
+instance Unpackable (ComponentInfo Protocol) where
+ get = do
+ snapid <- get::Parser Int
+ cid <- get::Parser Int
+ v1 <- get
+ v2 <- get
+ v3 <- get
+ v4 <- get
+ v5 <- get
+ v6 <- get
+ v7 <- get
+ let click = makeAction (T.pack "click") [pack snapid, pack cid]
+ doubleClick = makeAction (T.pack "doubleClick") [pack snapid, pack cid]
+ rightClick = makeAction (T.pack "rightClick") [pack snapid, pack cid]
+ return (ComponentInfo v1 v2 v3 v4 v5 v6 v7 click doubleClick rightClick)
+
+instance Unpackable (Component Protocol) where
+ get = Component <$> get
+
+instance Unpackable (ComponentType Protocol) where
+ get = do
+ snapid <- get::Parser Int
+ typeTag <- get::Parser Int
+ case typeTag of
+ 1 -> return Panel
+ 2 -> do
+ v2 <- get::Parser Int
+ v3 <- get
+ let toggle b = makeAction (T.pack "toggle") $
+ [pack snapid, pack v2, pack b]
+ return $ Toggleable v3 toggle
+ 3 -> do
+ v2 <- get::Parser Int
+ let click = makeAction (T.pack "clickButton") $
+ [pack snapid, pack v2]
+ return $ Button click
+ 4 -> do
+ v2 <- get::Parser (Maybe Int)
+ let setText cid txt = makeAction (T.pack "setTextField") $
+ [pack snapid, pack cid, pack txt]
+ return . TextField $ fmap setText v2
+ 5 -> return Label
+ 6 -> do
+ cid <- get::Parser (Maybe Int)
+ let clickCombo = makeAction (T.pack "clickCombo") $
+ [pack snapid, pack cid]
+ renderer <- get
+ return $ ComboBox renderer clickCombo
+ 7 -> List <$> get
+ 8 -> Table <$> get
+ 9 -> Treegui <$> get
+ 50 -> return PopupMenu
+ 70 -> TabbedPane <$> get
+ 77 -> do
+ v2 <- get
+ return (Other v2)
+
+
+instance Unpackable (Cell Protocol) where
+ get = do
+ snapid <- get::Parser Int
+ componentid <- get::Parser Int
+ rowid <- get::Parser Int
+ columnid <- get::Parser Int
+ renderer <- get
+ isTreeCell <- get
+ let packed3 = map pack [snapid, componentid, rowid]
+ packed4 = packed3 ++ [pack columnid]
+ clickCell = makeAction (T.pack "clickCell") packed4
+ doubleClickCell = makeAction (T.pack "doubleClickCell") packed4
+ rightClickCell = makeAction (T.pack "rightClickCell") packed4
+ expandCollapse b = makeAction (T.pack "expandCollapseCell") $
+ packed3 ++ [pack b]
+ return $ Cell renderer clickCell doubleClickCell rightClickCell (guard isTreeCell *> pure expandCollapse)
+
+instance Unpackable (Tab Protocol) where
+ get = do
+ snapid <- get::Parser Int
+ componentid <- get::Parser Int
+ tabid <- get::Parser Int
+ text <- get
+ tooltipMaybe <- get
+ selected <- get
+ let selecttab = makeAction (T.pack "selectTab" ) $
+ map pack [snapid, componentid, tabid]
+ return $ Tab text tooltipMaybe selected selecttab
+
diff --git a/src/Pianola/Pianola.hs b/src/Pianola/Pianola.hs
new file mode 100644
--- /dev/null
+++ b/src/Pianola/Pianola.hs
@@ -0,0 +1,322 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module Pianola.Pianola (
+ Glance(..),
+ missing,
+ collect,
+ liftN,
+ Pianola(..),
+ Delay,
+ pfail,
+ pmaybe,
+ peek,
+ peekMaybe,
+ retryPeek1s,
+ retryPeek,
+ poke,
+ pokeMaybe,
+ retryPoke1s,
+ retryPoke,
+ sleep,
+ with,
+ withMaybe,
+ withRetry1s,
+ withRetry,
+ ralentize,
+ ralentizeByTag,
+ autolog,
+ play
+ ) where
+
+import Prelude hiding (catch,(.))
+import Data.Functor.Compose
+import Data.Monoid
+import Control.Category
+import Control.Error
+import Control.Applicative
+import Control.Proxy
+import Control.Monad
+import Control.Monad.Free
+import Control.Monad.Logic
+
+import Pianola.Util
+
+-- | A Glance is just a kleisli arrow used to locate and extract particular
+-- elements of type /a/ in a data structure of type /o/.
+--
+-- The following effects are allowed:
+--
+-- * Nondeterminism and failure. A Glance can return more than one value (or zero
+-- values, with 'mzero'). See the 'replusify' function, which is a valid Glance.
+--
+-- * Logging. A Glance can log messages of type /l/ about the elements it
+-- encounters during search, even elements visited in search branches which
+-- ultimately fail to produce any results. See 'logmsg'.
+--
+-- * Interactions with the server through the monad /m/, but only interactions
+-- that don't change the state of the GUI. For example, getting a image capture
+-- of a window. See 'Nullipotent'.
+--
+-- The following effects are forbidden:
+--
+-- * Any kind of delay effect. Glances must return as soon as possible.
+--
+-- * Interactions with the server which /do/ change the state of the GUI. Note
+-- that you can target and return the actions of type 'Sealed' which dangle
+-- on the branches of the source data structure. You just can't execute them
+-- inside a Glance. To actually execute them, pass the glance as an argument to
+-- 'poke'.
+type Glance m l o a = o -> LogicT (Produ l (Nullipotent m)) a
+
+-- | Takes all the values returned by a 'Glance' and returns a new Glance in
+-- which those values have been collected in a 'MonadPlus' (often a list). This
+-- is useful when we want to recover a list of components which meet certain
+-- criteria in order to compare them among themselves. For example, getting all
+-- the buttons present in a window and sorting them left to right by their
+-- position on the screen.
+collect :: (Monad m, MonadPlus n) => Glance m l o a -> Glance m l o (n a)
+collect = fmap $ \x -> lift $ observeAllT x >>= return . replusify
+
+-- | Executes a 'Nullipotent' action in the context of a 'Glance'.
+liftN :: Monad m => Glance m l (Nullipotent m a) a
+liftN = lift . lift
+
+-- | When the 'Glance' passed as argument finds nothing, the returned glance
+-- finds a single (). When the Glance passed as argument finds one or more
+-- values, the returned Glance finds zero results.
+--
+-- This function can be used in combination with 'retryPeek1s' to wait for the
+-- dissapearance of a component on screen.
+missing :: Monad m => Glance m l o a -> Glance m l o ()
+missing = fmap lnot
+
+-- A Glance wrapped in a constructor to make it an instance of Functor.
+type ObserverF m l o = Compose ((->) o) (LogicT (Produ l (Nullipotent m)))
+
+-- A bunch of Glances chained together.
+type Observer m l o = Free (ObserverF m l o)
+
+-- Transforms the context of an Observer by composing all the Glances contained in the Observer with another Glance.
+focus :: Monad m => Glance m l o' o -> Observer m l o a -> Observer m l o' a
+focus prefix v =
+ let nattrans (Compose k) = Compose $ prefix >=> k
+ in hoistFree nattrans v
+
+-- Uses the value of type m o to unwind all the Glances in an Observer. When
+-- one Glance returns with more than one result, one of the results is selected
+-- in order to continue. Also, the Nullipotent restriction is removed.
+runObserver :: Monad m => m o -> Observer m l o a -> MaybeT (Produ l m) a
+runObserver _ (Pure b) = return b
+runObserver mom (Free f) =
+ let squint = fmap $ hoist (hoist runNullipotent) . tomaybet
+ in join $ (lift . lift $ mom) >>= squint (getCompose $ runObserver mom <$> f)
+
+type Delay = Int
+
+-- | A computation which interacts which an external system represented locally
+-- by the type /o/, using actions on the monad /m/, emitting log messages of
+-- type /l/, and returning a value of type /a/.
+--
+-- The following effects are allowed:
+--
+-- * Purely observational interactions with the external system. See 'peek'.
+--
+-- * Logging. Log messages are emitted in the middle of the computation, unlike
+-- in a Writer monad. See 'logmsg' and 'logimg'.
+--
+-- * Failure. See 'pfail'.
+--
+-- * Delays. See 'sleep'.
+--
+-- * Actions in the /m/ monad which actually change the external system, like
+-- clicking on a button of a GUI. See 'poke'.
+--
+-- Instead of baking all possible effects into the base free monad, Pianola
+-- takes the approach of representing each effect using the 'Proxy' type from
+-- the pipes package.
+--
+-- The order of the trasformers in the monad stack is not arbitrary. For
+-- example: it does not make sense for a log message to make the computation
+-- fail or to trigger actions against the external system, so the log producer
+-- is colocated closest to the base monad, where it doesn't have access to
+-- those kind of effects.
+--
+-- Another example: it can be conveniento to automatically introduce a delay
+-- after every action (see 'ralentize') or to automatically log each action
+-- (see 'autolog'). Therefore, the 'Sealed' action producer is in the
+-- outermost position, having access to all the effects.
+--
+-- To actually execute a Pianola, use a driver function like
+-- 'Pianola.Pianola.Driver.simpleDriver' or a specialization of it.
+newtype Pianola m l o a = Pianola
+ { unPianola :: Produ (Sealed m) (Produ Delay (MaybeT (Produ l (Observer m l o)))) a
+ } deriving (Functor,Monad)
+
+instance Monad m => Loggy (Pianola m LogEntry o) where
+ logentry = Pianola . lift . lift . lift . logentry
+
+-- | Aborts a 'Pianola' computation.
+pfail :: Monad m => Pianola m l o a
+pfail = Pianola . lift . lift $ mzero
+
+-- | If the second 'Pianola' argument returns Nothing, the first one is executed.
+-- Often used in combination with 'pfail'.
+pmaybe :: Monad m => Pianola m l o a -> Pianola m l o (Maybe a) -> Pianola m l o a
+pmaybe f p = p >>= maybe f return
+
+-- | Lifts a 'Glance' into the 'Pianola' monad.
+peek :: Monad m => Glance m l o a -> Pianola m l o a
+peek = Pianola . lift . lift . lift . lift . liftF . Compose
+
+-- | Like 'peek', but if the 'Glance' returns zero results then Nothing is
+-- returned instead of failing and halting the whole computation.
+peekMaybe :: Monad m => Glance m l o a -> Pianola m l o (Maybe a)
+peekMaybe = peek . collect
+
+-- | Like 'peekMaybe', but the specified number of retries is performed before
+-- returning Nothing. There is an sleep of 1 second between each retry.
+retryPeek1s :: Monad m => Int -> Glance m l o a -> Pianola m l o (Maybe a)
+retryPeek1s = retryPeek $ sleep 1
+
+-- | A more general version of 'retryPeek1s' which intersperses any 'Pianola'
+-- action between retries.
+retryPeek :: Monad m => Pianola m l o u -> Int -> Glance m l o a -> Pianola m l o (Maybe a)
+retryPeek delay times glance =
+ let retryPeek' [] = return Nothing
+ retryPeek' (x:xs) = do
+ z <- peekMaybe x
+ maybe (delay >> retryPeek' xs) (return.return) z
+ in retryPeek' $ replicate times glance
+
+
+inject :: Monad m => Sealed m -> Pianola m l o ()
+inject = Pianola . respond
+
+-- | Takes a glance that extracts an action of type 'Sealed' from a data
+-- structure, and returns a 'Pianola' executing the action (when the Pianola is
+-- interpreted by some driver-like fuction like
+-- 'Pianola.Pianola.Driver.simpleDriver'.)
+poke :: Monad m => Glance m l o (Sealed m) -> Pianola m l o ()
+poke locator = peek locator >>= inject
+
+-- | Like 'poke', but if the 'Glance' returns zero results then Nothing is
+-- returned instead of failing and halting the whole computation.
+pokeMaybe :: Monad m => Glance m l o (Sealed m) -> Pianola m l o (Maybe ())
+pokeMaybe locator = do
+ actionMaybe <- peekMaybe locator
+ case actionMaybe of
+ Nothing -> return Nothing
+ Just action -> inject action >> return (Just ())
+
+-- | Like 'pokeMaybe', but the specified number of retries is performed before
+-- returning Nothing. There is an sleep of 1 second between each retry.
+retryPoke1s :: Monad m => Int -> Glance m l o (Sealed m) -> Pianola m l o (Maybe ())
+retryPoke1s = retryPoke $ sleep 1
+
+-- | A more general version of 'retryPoke1s' which intersperses any 'Pianola'
+-- action between retries.
+retryPoke :: Monad m => Pianola m l o u -> Int -> Glance m l o (Sealed m) -> Pianola m l o (Maybe ())
+retryPoke delay times glance = do
+ actionMaybe <- retryPeek delay times glance
+ case actionMaybe of
+ Nothing -> return Nothing
+ Just action -> inject action >> return (Just ())
+
+-- | Sleeps for the specified number of seconds
+sleep :: Monad m => Delay -> Pianola m l o ()
+sleep = Pianola . lift . respond
+
+-- | Expands the context of a 'Pianola' using a 'Glance'. Typical use: transform a Pianola whose context is a particular window to a Pianola whose context is the whole GUI, using a Glance which locates the window in the GUI.
+--
+-- > with glance1 $ peek glance2
+--
+-- is equal to
+--
+-- > peek $ glance1 >=> glance2
+--
+-- 'with' can be used to group peeks and pokes whose glances share part of thir paths in common:
+--
+-- > do
+-- > poke $ glance1 >=> glance2
+-- > poke $ glance1 >=> glance3
+--
+-- is equal to
+--
+-- > with glance1 $ do
+-- > poke glance2
+-- > poke glance3
+with :: Monad m => Glance m l o' o -> Pianola m l o a -> Pianola m l o' a
+with prefix pi =
+ Pianola $ hoist (hoist (hoist (hoist $ focus prefix))) $ unPianola pi
+
+-- | Like 'with', but when the element targeted by the 'Glance' doens't exist,
+-- the Pianola argument is not executed and 'Nothing' is returned.
+withMaybe :: Monad m => Glance m l o' o -> Pianola m l o a -> Pianola m l o' (Maybe a)
+withMaybe glance pi = do
+ r <- peekMaybe glance
+ case r of
+ Nothing -> return Nothing
+ Just _ -> with glance pi >>= return . Just
+
+-- | Like 'withMaybe', but several attempts to locate the target of the glance
+-- are performed, with a separation of 1 second.
+withRetry1s :: Monad m => Int -> Glance m l o' o -> Pianola m l o a -> Pianola m l o' (Maybe a)
+withRetry1s = withRetry $ sleep 1
+
+-- | A more general 'withMaybe' for which any 'Pianola' action can be interstpersed between retries.
+withRetry :: Monad m => Pianola m l o' u -> Int -> Glance m l o' o -> Pianola m l o a -> Pianola m l o' (Maybe a)
+withRetry delay times glance pi = do
+ r <- retryPeek delay times glance
+ case r of
+ Nothing -> return Nothing
+ Just _ -> with glance pi >>= return . Just
+
+-- | Takes a delay in seconds and a 'Pianola' as parameters, and returns a
+-- ralentized Pianola in which the delay has been inserted after every action.
+ralentize :: Delay -> Pianola m l o a -> Pianola m l o a
+ralentize = ralentizeByTag $ const True
+
+ralentizeByTag :: ([Tag] -> Bool) -> Delay -> Pianola m l o a -> Pianola m l o a
+ralentizeByTag f delay (Pianola p) =
+ let delayer () = forever $ do
+ s <- request ()
+ respond s
+ when (f . tags $ s) (lift $ respond delay)
+ in Pianola $ const p >-> delayer $ ()
+
+-- | Modifies a 'Pianola' so that the default tags associated to an action are
+-- logged automatically when the action is executed.
+autolog :: Pianola m LogEntry o a -> Pianola m LogEntry o a
+autolog (Pianola p) =
+ let logger () = forever $ do
+ s <- request ()
+ respond s
+ lift . lift . lift . logmsg $ fmtAction s
+ fmtAction s =
+ "### Executed action with tags:" <> mconcat ( map (" "<>) . tags $ s )
+ in Pianola $ const p >-> logger $ ()
+
+-- | Unwinds all the Glances contained in a 'Pianola' by supplying them with
+-- the monadic value passed as the first argument. When a 'Glance' returns with
+-- more than one result, one of the results is selected in order to continue (/TO DO/:
+-- emit a warning when this happens). The log messages of the glances are
+-- fused with the Pianola's own log stream. All the 'Sealed' actions are
+-- injected into the base monad. The delay and log effects remain uninjected.
+--
+-- Usually, clients should not call this function directly, but use a
+-- driver function like 'Pianola.Pianola.Driver.simpleDriver'.
+play :: Monad m => m o -> Pianola m l o a -> Produ Delay (MaybeT (Produ l m)) a
+play mom pi =
+ let smashMaybe m () = runMaybeT m >>= lift . hoistMaybe
+ smashProducer () = forever $
+ request () >>= lift . lift . respond
+ smash :: Monad m => MaybeT (Produ l (MaybeT (Produ l m))) a -> MaybeT (Produ l m) a
+ smash mp = runProxy $ smashMaybe mp >-> smashProducer
+ pi' = hoist (hoist (smash . hoist (hoist $ runObserver mom))) $ unPianola pi
+ injector () = forever $ do
+ s <- request ()
+ lift . lift . lift . lift $ unseal s
+ in runProxy $ const pi' >-> injector
+
diff --git a/src/Pianola/Pianola/Driver.hs b/src/Pianola/Pianola/Driver.hs
new file mode 100644
--- /dev/null
+++ b/src/Pianola/Pianola/Driver.hs
@@ -0,0 +1,113 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+
+module Pianola.Pianola.Driver (
+ simpleDriver,
+ DriverError(..),
+ filePathStream,
+ screenshotStream
+) where
+
+import Prelude hiding (catch,(.),id,head,repeat,tail,map,iterate)
+import Data.Stream.Infinite
+import qualified Data.ByteString as B
+import qualified Data.Text as T
+import qualified Data.Text.IO as TIO
+import Control.Category
+import Control.Error
+import Control.Proxy
+import Control.Exception
+import Control.Monad.State.Class
+import Control.Monad.Logic
+import Control.Concurrent (threadDelay)
+import Control.Monad.RWS.Strict
+import Pianola.Pianola
+import Pianola.Util
+import Pianola.Protocol
+import Pianola.Protocol.IO
+
+import System.FilePath
+
+delayer :: MonadIO m => () -> Consumer ProxyFast Delay m a
+delayer () = forever $ request () >>= liftIO . threadDelay . (*1000000)
+
+logger:: MonadIO m => (forall b. IOException -> m b) -> m FilePath -> () -> Consu LogEntry m a
+logger errHandler filegen () = forever $ do
+ entry <- request ()
+ case entry of
+ TextEntry txt -> lift . convertErr . liftIO . try $ TIO.putStrLn txt
+ ImageEntry image -> do
+ file <- lift filegen
+ lift . convertErr . liftIO . try $ B.writeFile file image
+ where convertErr x = x >>= either errHandler return
+
+-- | A more general version of 'screenshotStream', which allows the client to
+-- specify the prefix before the file number, the amount of padding for the
+-- file number, and the suffix after the file number.
+filePathStream :: String -> Int -> String -> FilePath -> Stream FilePath
+filePathStream extension padding prefix folder =
+ let pad i c str = replicate (max 0 (i - length str)) c ++ str
+ pathFromNumber = combine folder
+ . (\s -> prefix ++ s ++ extSeparator:extension)
+ . pad padding '0'
+ . show
+ in map pathFromNumber $ iterate succ 1
+
+-- | Returns an infinite stream of filenames for storing screenshots, located
+-- in the directory supplied as a parameter.
+screenshotStream :: FilePath -> Stream FilePath
+screenshotStream = filePathStream "png" 3 "pianola-capture-"
+
+-- | Possible failure outcomes when running a pianola computation.
+data DriverError =
+ -- | Local exception while storing screenshots or log messages.
+ DriverIOError IOException
+ -- | Exception when connecting the remote system.
+ |PianolaIOError IOException
+ -- | Remote system returns unparseable data.
+ |PianolaParseError T.Text
+ -- | An operation was requested on an obsolete snapshot (first integer) of
+ -- the remote system (whose current snapshot number is the second integer).
+ |PianolaSnapshotError Int Int
+ -- | Server couldn't complete requested operation (either because it
+ -- doesn't support the operation or because of an internal error.)
+ |PianolaServerError T.Text
+ -- | Failure from a call to 'pfail' or from a 'Glance' without results.
+ |PianolaFailure
+ deriving Show
+
+-- | Runs a pianola computation. Receives as argument a monadic action to
+-- obtain snapshots of type /o/ of a remote system, a connection endpoint to
+-- the remote system, a 'Pianola' computation with context of type /o/ and
+-- return value of type /a/, and an infinite stream of filenames to store the
+-- screenshots. Textual log messages are written to standard output. The
+-- computation may fail with an error of type 'DriverError'.
+--
+-- See also 'Pianola.Model.Swing.Driver.simpleSwingDriver'.
+simpleDriver :: Protocol o -> Endpoint -> Pianola Protocol LogEntry o a -> Stream FilePath -> EitherT DriverError IO a
+simpleDriver snapshot endpoint pianola namestream = do
+ let played = play snapshot pianola
+ -- the lift makes a hole for an (EitherT DriverIOError...)
+ rebased = hoist (hoist (hoist $ lift . runProtocol id)) $ played
+ logprod = runMaybeT $ runProxy $ const rebased >-> delayer
+
+ filegen = state $ \stream -> (head stream, tail stream)
+
+ logless = runProxy $ const logprod >-> logger left filegen
+
+ errpeeled = runEitherT . runEitherT . runEitherT $ logless
+ (result,_,()) <- lift $ runRWST errpeeled endpoint namestream
+ case result of
+ Left e -> left $ case e of
+ CommError ioerr -> PianolaIOError ioerr
+ ParseError perr -> PianolaParseError perr
+ Right s -> case s of
+ Left e -> left $ case e of
+ SnapshotError u v -> PianolaSnapshotError u v
+ ServerError txt -> PianolaServerError txt
+ Right r2 -> case r2 of
+ Left e -> left $ DriverIOError e
+ Right r3 -> case r3 of
+ Nothing -> left PianolaFailure
+ Just a -> return a
+
diff --git a/src/Pianola/Protocol.hs b/src/Pianola/Protocol.hs
new file mode 100644
--- /dev/null
+++ b/src/Pianola/Protocol.hs
@@ -0,0 +1,54 @@
+{-# LANGUAGE FlexibleInstances #-}
+
+module Pianola.Protocol (
+ ServerError (..),
+ ProtocolF,
+ Protocol (..),
+ call
+ ) where
+
+import Prelude hiding (catch,(.),id)
+import Data.MessagePack
+import Data.Attoparsec.ByteString
+import qualified Data.Iteratee as I
+import qualified Data.Text as T
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as BL
+import Data.Functor.Identity
+import Data.Functor.Compose
+import Control.Category
+import Control.Applicative
+import Control.Error
+import Control.Monad.Trans
+import Control.Monad.Free
+
+-- | A 'Functor' which models a RPC call as a pair in which the first component
+-- is a list of bytestrings (the arguments of the call) and the second is a
+-- pure 'Iteratee' that consumes the bytes sent from the server and returns the
+-- response of the call.
+type ProtocolF = Compose ((,) [BL.ByteString]) (I.Iteratee B.ByteString Identity)
+
+-- | A monad to represent interactions with a remote server. A free monad over
+-- a RPC call functor, augmented with some error conditions.
+type Protocol = EitherT ServerError (Free ProtocolF)
+
+-- | Constructs a RPC call from a packed list of arguments and a pure
+-- 'Iteratee' to consume the response.
+call :: [BL.ByteString] -> (I.Iteratee B.ByteString Identity x) -> Protocol x
+call bs i = lift . liftF $ Compose (bs,i)
+
+data ServerError =
+ -- | Client targeted obsolete snapshot.
+ SnapshotError Int Int
+ -- | Server couldn't perform the requested operation.
+ | ServerError T.Text
+ deriving Show
+
+instance Unpackable (ServerError) where
+ get = do
+ tag <- get::Parser Int
+ case tag of
+ 1 -> SnapshotError <$> get <*> get
+ 2 -> ServerError <$> get
+
+
diff --git a/src/Pianola/Protocol/IO.hs b/src/Pianola/Protocol/IO.hs
new file mode 100644
--- /dev/null
+++ b/src/Pianola/Protocol/IO.hs
@@ -0,0 +1,64 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Pianola.Protocol.IO (
+ RunInIOError(..),
+ Endpoint(..),
+ runProtocol
+ ) where
+
+import Prelude hiding (catch,(.))
+import System.IO
+import qualified Data.Text as T
+import qualified Data.Iteratee as I
+import qualified Data.Iteratee.IO.Handle as IH
+import qualified Data.Attoparsec.Iteratee as AI
+import Network
+import Data.Functor.Compose
+import Control.Category
+import Control.Error
+import Control.Exception
+import Control.Monad.Logic
+import Control.Monad.Free
+import Data.Functor.Identity
+import qualified Data.ByteString.Lazy as BL
+import Control.Monad.Reader
+import Pianola.Protocol
+
+data RunInIOError = CommError IOException
+ | ParseError T.Text
+ deriving Show
+
+data Endpoint = Endpoint {
+ hostName::HostName,
+ portID::PortID
+ }
+
+runFree:: (MonadIO m, MonadReader r m) => (r -> Endpoint) -> Free ProtocolF a -> EitherT RunInIOError m a
+runFree lens ( Free (Compose (b,i)) ) = do
+ let iterIO = I.ilift (return . runIdentity) i
+
+ rpcCall :: Endpoint -> (Handle -> IO b) -> IO b
+ rpcCall endpoint what2do = withSocketsDo $ do
+ bracket (connectTo (hostName endpoint) (portID endpoint))
+ hClose
+ what2do
+
+ doStuff ii h = do
+ mapM_ (BL.hPutStr h) b
+ hFlush h
+ I.run =<< IH.enumHandle 1024 h ii
+ endp <- lift $ asks lens
+ let ioErrHandler = \(ex :: IOException) -> return . Left . CommError $ ex
+ parseErrHandler = \(ex :: AI.ParseError) -> return . Left . ParseError . T.pack . show $ ex
+ nextFree <- EitherT . liftIO $
+ catches (fmap Right $ rpcCall endp $ doStuff iterIO)
+ [Handler ioErrHandler, Handler parseErrHandler]
+ runFree lens nextFree
+runFree _ ( Pure a ) = return a
+
+-- | Runs a sequence of RPC calls in a base monad which has access to an
+-- 'Endpoint' value which identifies the server. An accessor function must be
+-- provided to extract the Endpoint from the base monad's environment, which
+-- may be more general.
+runProtocol :: (MonadIO m, MonadReader r m) => (r -> Endpoint) -> Protocol a -> EitherT ServerError (EitherT RunInIOError m) a
+runProtocol lens = EitherT . runFree lens . runEitherT
diff --git a/src/Pianola/Tutorial.hs b/src/Pianola/Tutorial.hs
new file mode 100644
--- /dev/null
+++ b/src/Pianola/Tutorial.hs
@@ -0,0 +1,252 @@
+module Pianola.Tutorial (
+ -- * Setting up the test application
+ -- $setup
+
+ -- * First steps
+ -- $firststeps
+
+ -- * Logging
+ -- $logging
+
+ -- * Clicking buttons
+ -- $clicking
+
+ -- * Grouping actions
+ -- $grouping
+
+ -- * Logging, again
+ -- $autologging
+
+ -- * Sleeping
+ -- $sleeping
+
+ -- * Going slow
+ -- $ralentizing
+
+ -- * Failing
+ -- $failing
+
+ -- * Optional components
+ -- $optionals
+
+ -- * Retries
+ -- $retries
+
+ -- * Complex components
+ -- $complex
+
+) where
+
+import Prelude hiding (catch,(.),id,head,repeat,tail,map,iterate)
+import Data.Stream.Infinite
+import Control.Error
+import Pianola.Util
+import Pianola.Protocol
+import Pianola.Protocol.IO
+import Pianola.Pianola
+import Pianola.Pianola.Driver
+import Pianola.Model.Swing
+import Pianola.Model.Swing.Driver
+
+{- $setup
+ This tutorial assumes that the Java Swing test application bundled with the
+package is up and running. To set up the application, unpack the package
+sources with
+
+>>> cabal unpack pianola
+
+Then go to the
+
+>>> pianola/backends/java-swing
+
+folder and follow the instructions in the @README@ to compile and install the pianola agent jar into a local
+Maven repository. Finally, go to the
+
+>>> pianola/backends/java-swing-testapp
+
+folder and follow the instructions in the @README@ to configure and launch the test application.
+
+This tutorial will refer to the Java Swing application as the Application Under Test (AUT).
+-}
+{- $firststeps
+ This minimal pianola script prints the title of the AUT's main window:
+
+> import qualified Data.Text as T
+> import Network
+> import Control.Monad
+> import Control.Error
+>
+> import Pianola.Model.Swing.Driver
+>
+> extractTitle :: Pianola Protocol LogEntry (GUI Protocol) T.Text
+> extractTitle = peek $ mainWindow >=> title
+>
+> main:: IO ()
+> main = do
+> let port = PortNumber . fromIntegral $ 26060
+> endpoint = Endpoint "127.0.0.1" port
+> screenshots = screenshotStream "/tmp"
+> r <- runEitherT $ simpleSwingDriver endpoint extractTitle screenshots
+> putStrLn $ case r of
+> Left err -> do
+> "ERROR: " ++ show err
+> Right title -> "title: " ++ show title
+-}
+
+{- $logging
+We could also have logged the title inside the 'Pianola' monad:
+
+> extractTitle2 :: Pianola Protocol LogEntry (GUI Protocol) ()
+> extractTitle2 = do
+> txt <- peek $ mainWindow >=> title
+> logmsg txt
+
+Log messages emitted in the Pianola monad are printed as they are generated, unlike in a Writer monad. This is useful to check the progress of long-running scripts.
+
+The expression to the right of 'peek' has type 'Glance'. Glance is just a type synonym for the Kleisli arrows of a particular monad. This monad allows some effects and disallows others. Turns out that logging is one of the allowed effects, so we can also emit messages inside a Glance:
+
+> import Data.Functor.Identity
+>
+> extractTitle3 :: Pianola Protocol LogEntry (GUI Protocol) ()
+> extractTitle3 = do
+> peek $ \gui -> do
+> win <- mainWindow gui
+> logmsg $ runIdentity $ title win
+
+Why bother at all with logging inside a 'Glance', instead of always doing it in the 'Pianola' monad? As it happens, nondeterminism (returning several, or zero, results) is another of the allowed effects inside Glances. We can log about objects explored in search branches even if those branches eventually fail to produce any result. This can be useful for debugging.
+-}
+
+{- $clicking
+Enough with just inspecting the GUI and logging the results! What if we actually want to effect some change, like clicking a button? For this, we can use the 'poke' function.
+
+> clicky :: Pianola Protocol LogEntry (GUI Protocol) ()
+> clicky = poke $ mainWindow >=> contentPane >=> descendants >=> hasText (=="open dialog") >=> clickButton
+
+Like 'peek', 'poke' takes a 'Glance' as a parameter. Unlike 'peek', it only accepts Glances which return an action of type 'Sealed'. Values of this type encapsulate actions to be performed on the GUI. Users never construct values of 'Sealed'. Instead, they find them while exploring the data structure which represents the GUI.
+
+In the example, the 'Glance' supplied to 'poke' is made up of smaller Glances combined with '>=>'. One which extracts the main window of the application from the GUI as a whole, one to access the content pane of the window, one for obtaining all the sub-components of the content pane, one that selects components according to their text content, and finally one which extracts the click action of the component if the component is a button.
+-}
+
+
+{- $grouping
+Suppose we want to click the clear button in the window before we click the open dialog button. We can do it like this:
+
+> groupy :: Pianola Protocol LogEntry (GUI Protocol) ()
+> groupy = do
+> poke $ mainWindow >=> contentPane >=> descendants >=> hasText (=="clear") >=> clickButton
+> poke $ mainWindow >=> contentPane >=> descendants >=> hasText (=="open dialog") >=> clickButton
+
+There is a lot of repetition in the Glances. We can factor it out with the 'with' function:
+
+> groupy2 :: Pianola Protocol LogEntry (GUI Protocol) ()
+> groupy2 = with (mainWindow >=> contentPane >=> descendants) $ do
+> poke $ hasText (=="clear") >=> clickButton
+> poke $ hasText (=="open dialog") >=> clickButton
+
+This is equivalent to the previous code:
+
+> groupy3 :: Pianola Protocol LogEntry (GUI Protocol) ()
+> groupy3 = with mainWindow $ with contentPane $ with descendants $ do
+> poke $ hasText (=="clear") >=> clickButton
+> poke $ hasText (=="open dialog") >=> clickButton
+
+In this case, we could even go a little further:
+
+> groupy4 :: Pianola Protocol LogEntry (GUI Protocol) ()
+> groupy4 = with mainWindow $ with contentPane $ with descendants $ do
+> forM_ ["clear","open dialog] $ \txt ->
+> poke $ hasText (==txt) >=> clickButton
+
+-}
+
+{- $autologging
+Besides purely textual messages, we can also log window image captures. The
+easiest way is by using the 'logcapture' function.
+
+> captureExample :: Pianola Protocol LogEntry (GUI Protocol) ()
+> captureExample = with mainWindow $ logcapture
+
+Remember that in the first example of the tutorial, one of the parameters
+passed to 'simpleSwingDriver' was an infinite stream of screenshot filenames,
+created using 'screenshotStream'. Each time a screenshot is taken, the current
+head of the filename stream is used to store the screenshot.
+
+A certain degree of automatic logging is also supported. The 'autolog' function
+trasforms a Pianola by automatically inserting log messages after each executed
+action. The messages are not very detailed, but they distinguish between types
+of actions.
+
+> autologged = autolog groupy3
+-}
+
+{- $sleeping
+If we need to introduce a delay between two steps of a pianola computation, we
+can use the 'sleep' function, supplying it with the delay in seconds.
+
+> delayed1 :: Pianola Protocol LogEntry (GUI Protocol) ()
+> delayed1 = with mainWindow $ with contentPane $ with descendants $ do
+> poke $ hasText (=="clear") >=> clickButton
+> sleep 3
+> poke $ hasText (=="open dialog") >=> clickButton
+-}
+
+{- $ralentizing
+Sometimes it can be useful to play a computation in slow motion. Instead of
+inserting 'sleep' commands manually, we can use the 'ralentize' function which
+automatically inserts a delay after each action performed on the GUI.
+
+> ralentized = ralentize 4 groupy3
+-}
+
+
+{- $failing
+We can abort a pianola computation with 'pfail'. It is recommended that the
+user emits an informative log message before calling this function.
+
+Another way for a pianola computation to fail is when a glance to returns no
+results (unless we are using 'peekMaybe' or similar function, see the next
+section.)
+
+-}
+
+{- $optionals
+Sometimes we want to target a component which may be present in the interface,
+but without failing outright if the component can't be found. In those cases we
+can use 'peekMaybe' or 'pokeMaybe', which return 'Nothing' when the 'Glance'
+fails to find any result.
+
+> pokeOptional = with (mainWindow >=> contentPane >=> descendants) $ do
+> pokeMaybe $ hasText (=="no component which this text") >=> clickButton
+-}
+
+{- $retries
+For components which only appear after a certain delay, a few retries may be
+needed until the component is found. To target these kinds of components, we
+can use the 'retryPeek1s', 'retryPoke1s' and 'withRetry1s' functions.
+
+> retryExample = with mainWindow $ with contentPane $ do
+> poke $ clickButtonByText (=="open slow dialog")
+> with window $ do
+> pmaybe pfail $ withRetry1s 14 childWindow $ do
+> with contentPane $ poke $ clickButtonByText (=="close dialog")
+
+These functions can be combined with 'pmaybe' and 'pfail' to abort the pianola
+computation if the component is not found after the specified retries.
+
+But what if instead of waiting for a component to appear, we want to wait for a
+component to dissapear? We can do this with the help of the 'missing' function:
+
+> poke $ clickButtonByText (=="open slow dialog")
+> with window $ do
+> pmaybe pfail $ withRetry1s 14 childWindow $ do
+> with contentPane $ poke $ clickButtonByText (=="close dialog")
+> logmsg "clicked delayed close button"
+> pmaybe pfail $ retryPeek1s 14 $ missing childWindow
+-}
+
+
+{- $complex
+Complex Swing components like lists, tables and trees are represented Haskell-side as composed of 'Cell' values. See the documentation for 'Cell' and 'ComponentInfo' for more details.
+
+Cells do not count as regular children of a component and they do not appear among the results of a 'children' or 'descendants' call. Instead, see the family of functions 'listCellByText', 'tableCellByText' and 'treeCellByText'.
+ -}
diff --git a/src/Pianola/Util.hs b/src/Pianola/Util.hs
new file mode 100644
--- /dev/null
+++ b/src/Pianola/Util.hs
@@ -0,0 +1,102 @@
+{-# LANGUAGE FlexibleInstances #-}
+
+module Pianola.Util (
+ replusify,
+ tomaybet,
+ Treeish(..),
+ Produ,
+ Consu,
+ Loggy(..),
+ LogEntry(..),
+ Image,
+ Nullipotent(runNullipotent),
+ Tag,
+ Sealed(tags,unseal),
+ addTag
+ ) where
+
+import Prelude hiding (catch,(.),id)
+import Control.Category
+import Data.Tree
+import Data.MessagePack
+import Data.Attoparsec.ByteString
+import Control.Monad
+import Control.Comonad
+import Control.Comonad.Trans.Class
+import Control.Comonad.Trans.Env
+import Control.Applicative
+import Control.Monad.Trans.Maybe
+import Control.Monad.Logic
+import Control.Proxy
+import qualified Data.Text as T
+import qualified Data.ByteString as B
+
+import Pianola.Internal
+
+-- | Convenience function to transform a list into any 'MonadPlus'.
+replusify:: MonadPlus m => [a] -> m a
+replusify = msum . map return
+
+-- | Transforms a zero-or-many result into a zero-or-one result.
+tomaybet:: Monad m => LogicT m a -> MaybeT m a
+tomaybet = MaybeT . liftM replusify . observeManyT 1
+
+-- | Class of types whose values have children of the same type as themselves.
+class Treeish l where
+ -- | Direct descendants.
+ children :: MonadPlus m => l -> m l
+ -- | All direct or indirect descendants, plus the original value.
+ descendants :: MonadPlus m => l -> m l
+
+instance Treeish (Tree a) where
+ children = replusify . subForest
+ descendants = replusify . flatten . duplicate
+
+instance Treeish (EnvT e Tree a) where
+ children = replusify . map rootLabel . subForest . lower . duplicate
+ descendants = replusify . flatten . lower . duplicate
+
+-- useful msgpack instances
+instance (Unpackable a, Unpackable b) => Unpackable (Either a b) where
+ get = do
+ tag <- get::Parser Int
+ case tag of
+ 1 -> Left <$> get
+ 0 -> Right <$> get
+
+instance Unpackable a => Unpackable (Tree a) where
+ get = Node <$> get <*> get
+
+
+-- logging
+type Image = B.ByteString
+
+class Functor l => Loggy l where
+ logentry::LogEntry -> l ()
+
+ logmsg::T.Text -> l ()
+ logmsg = logentry . TextEntry
+
+ logimg::Image -> l ()
+ logimg = logentry . ImageEntry
+
+ -- | Logs a message and returns the second argument unchanged.
+ logmsgK::T.Text -> a -> l a
+ logmsgK msg = (<$ logmsg msg)
+
+data LogEntry = TextEntry T.Text
+ |ImageEntry Image
+
+-- pipes
+type Produ t = Producer ProxyFast t
+type Consu t = Consumer ProxyFast t
+
+instance Monad m => Loggy (Produ LogEntry m) where
+ logentry = respond
+
+instance (Monad l, Loggy l) => Loggy (LogicT l) where
+ logentry = lift . logentry
+
+instance (Monad l, Loggy l) => Loggy (MaybeT l) where
+ logentry = lift . logentry
+
diff --git a/tests/README.md b/tests/README.md
new file mode 100644
--- /dev/null
+++ b/tests/README.md
@@ -0,0 +1,8 @@
+The Java Swing test application must be up and running for these tests to work.
+
+When executing the tests, you can specify the host in which the test application is running in the following manner:
+
+> cabal test --test-options=10.0.2.2
+
+Default is localhost.
+
diff --git a/tests/tests-pianola.hs b/tests/tests-pianola.hs
new file mode 100644
--- /dev/null
+++ b/tests/tests-pianola.hs
@@ -0,0 +1,153 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Main where
+
+import Prelude hiding (catch,(.),id)
+import Data.Monoid
+import Data.Tree
+import qualified Data.Text as T
+import Network
+import Control.Category
+import Control.Monad
+import Control.Error
+import Control.Applicative
+
+import Pianola.Model.Swing.Driver
+
+import System.Environment
+import System.Exit (exitFailure)
+
+checkStatusBar :: (Monad m, ComponentLike c, Treeish (c m)) => (T.Text -> Bool) -> Pianola m LogEntry (c m) ()
+checkStatusBar predicate = do
+ with (descendants >=> hasName (=="status bar")) $ do
+ statusText <- peek text
+ logmsg $ "status text is: " <> statusText
+ unless (predicate statusText) $ do
+ logmsg $ "Unexpected text in status bar: " <> statusText
+ pfail
+ poke $ clickButtonByText (=="clear")
+
+checkDialog :: Monad m => Pianola m LogEntry (ComponentW m) ()
+checkDialog = do
+ poke $ clickButtonByText (=="open dialog")
+ with window $ with childWindow $ with contentPane $ do
+ poke $ clickButtonByText (=="click this")
+ poke $ clickButtonByText (=="close dialog")
+ checkStatusBar (=="clicked button in dialog")
+
+checkDelayedDialog :: Monad m => Pianola m LogEntry (ComponentW m) ()
+checkDelayedDialog = do
+ poke $ clickButtonByText (=="open slow dialog")
+ with window $ do
+ pmaybe pfail $ withRetry1s 14 childWindow $ do
+ with contentPane $ poke $ clickButtonByText (=="close dialog")
+ logmsg "clicked delayed close button"
+ pmaybe pfail $ retryPeek1s 14 $ missing childWindow
+ checkStatusBar (=="Performed delayed close")
+
+expandAndCheckLeafA :: Monad m => Int -> Pianola m LogEntry (ComponentW m) ()
+expandAndCheckLeafA depth = do
+ with descendants $ do
+ poke $ treeCellByText depth (=="leaf a") >=> expand True
+ checkStatusBar (=="leaf a is collapsed: false")
+
+type Test = Pianola Protocol LogEntry (GUI Protocol) ()
+
+testCase:: Test
+testCase = with mainWindow $ do
+ poke toFront
+ with contentPane $ do
+ poke $ descendants >=> hasText (=="En un lugar de la Mancha")
+ >=> setText "Lorem ipsum dolor sit amet"
+ checkStatusBar (=="Lorem ipsum dolor sit amet")
+ logmsg "testing dialog"
+ checkDialog
+ logmsg "dialog again, each action ralentized"
+ ralentize 2 $ checkDialog
+ logmsg "dialog with delayed open and close"
+ checkDelayedDialog
+ logmsg "testing right click"
+ poke $ descendants >=> hasText (=="click dbl click") >=> click
+ checkStatusBar (=="clicked on label")
+ poke $ descendants >=> hasText (=="click dbl click") >=> doubleClick
+ checkStatusBar (=="double-clicked on label")
+ poke $ rightClickByText (=="This is a label")
+ pmaybe pfail $ retryPoke1s 4 $
+ window >=> popupItem >=> hasText (=="popupitem2") >=> clickButton
+ checkStatusBar (=="clicked on popupitem2")
+ sleep 1
+ logmsg "testing checkbox"
+ poke $ descendants >=> hasText (=="This is a checkbox") >=> toggle True
+ checkStatusBar (=="checkbox is now true")
+ logmsg "foo log message"
+ with window $ toggleInMenuBar True $
+ map (==) ["Menu1","SubMenu1","submenuitem2"]
+ checkStatusBar (=="checkbox in menu is now true")
+ logmsg "getting a screenshot"
+ with window $ logcapture
+ logmsg "now for a second menu"
+ autolog $ with window $ selectInMenuBar $
+ map (==) ["Menu1","SubMenu1","submenuitem1"]
+ checkStatusBar (=="clicked on submenuitem1")
+ sleep 2
+ logmsg "opening a file chooser"
+ with (descendants >=> hasText (=="Open file chooser")) $ do
+ poke clickButton
+ with window $ with childWindow $ with contentPane $ do
+ poke $ descendants >=> hasText (=="") >=> setText "/tmp/foofile.txt"
+ poke $ clickButtonByText $ \txt -> or $ map (txt==) ["Open","Abrir"]
+ checkStatusBar (T.isInfixOf "foofile")
+ sleep 1
+ with descendants $ do
+ logmsg "working with a combo box"
+ selectInComboBox (=="ccc")
+ checkStatusBar (=="selected in combo: ccc")
+ with descendants $ do
+ sleep 2
+ poke $ selectTabByText (=="tab two")
+ sleep 2
+ poke $ tableCellByText 2 (=="7") >=> return._clickCell.fst
+ checkStatusBar (=="selected index in table: 2")
+ with descendants $ do
+ sleep 2
+ poke $ tableCellByText 1 (=="4") >=> return._doubleClickCell.fst
+ sleep 2
+ poke $ \g -> do
+ Table {} <- return . cType $ g
+ children >=> hasText (=="4") >=> setText "77" $ g
+ with window $ poke enter
+ checkStatusBar (=="table value at row 1 col 1 is 77")
+ with descendants $ do
+ sleep 2
+ poke $ selectTabByText (=="tab JTree a")
+ logmsg "tab change"
+ expandAndCheckLeafA 1
+ with descendants $ do
+ sleep 2
+ poke $ selectTabByText (=="tab JTree b")
+ logmsg "tab change"
+ expandAndCheckLeafA 0
+ with contentPane $ do
+ with descendants $ poke $ selectTabByText (=="labels")
+ sleep 1
+ poke $ labeledBy (=="label2") >=> setText "hope this works!"
+ checkStatusBar (=="hope this works!")
+ sleep 2
+ poke close
+
+main :: IO ()
+main = do
+ args <- getArgs
+ let addr = case args of
+ [] -> "127.0.0.1"
+ x:_ -> x
+ port = PortNumber . fromIntegral $ 26060
+ endpoint = Endpoint addr port
+
+ r <- runEitherT $ simpleSwingDriver endpoint testCase $ screenshotStream "dist/test"
+ case r of
+ Left err -> do
+ putStrLn $ "result: " <> show err
+ exitFailure
+ Right _ -> putStrLn $ "result: all ok"